module Sound.Tidal.Pattern where
import Control.Applicative
import Data.Monoid
import Data.Fixed
import Data.List
import Data.Maybe
import Data.Ratio
import Debug.Trace
import Data.Typeable
import Data.Function
import System.Random.Mersenne.Pure64
import Sound.Tidal.Time
import Sound.Tidal.Utils
data Pattern a = Pattern {arc :: Arc -> [Event a]}
instance (Show a) => Show (Pattern a) where
show p@(Pattern _) = show $ arc p (0, 1)
instance Functor Pattern where
fmap f (Pattern a) = Pattern $ fmap (fmap (mapThd' f)) a
instance Applicative Pattern where
pure x = Pattern $ \(s, e) -> map
(\t -> ((t%1, (t+1)%1),
(t%1, (t+1)%1),
x
)
)
[floor s .. ((ceiling e) 1)]
(Pattern fs) <*> (Pattern xs) =
Pattern $ \a -> concatMap applyX (fs a)
where applyX ((s,e), (s', e'), f) =
map (\(_, _, x) -> ((s,e), (s', e'), f x))
(filter
(\(_, a', _) -> isIn a' s)
(xs (s',e'))
)
instance Monoid (Pattern a) where
mempty = silence
mappend = overlay
instance Monad Pattern where
return = pure
p >>= f =
Pattern (\a -> concatMap
(\((s,e), (s',e'), x) -> mapSnds' (const (s',e')) $
filter
(\(_, a', _) -> isIn a' s)
(arc (f x) (s',e'))
)
(arc p a)
)
atom :: a -> Pattern a
atom = pure
silence :: Pattern a
silence = Pattern $ const []
mapQueryArc :: (Arc -> Arc) -> Pattern a -> Pattern a
mapQueryArc f p = Pattern $ \a -> arc p (f a)
mapQueryTime :: (Time -> Time) -> Pattern a -> Pattern a
mapQueryTime = mapQueryArc . mapArc
mapResultArc :: (Arc -> Arc) -> Pattern a -> Pattern a
mapResultArc f p = Pattern $ \a -> mapArcs f $ arc p a
mapResultTime :: (Time -> Time) -> Pattern a -> Pattern a
mapResultTime = mapResultArc . mapArc
overlay :: Pattern a -> Pattern a -> Pattern a
overlay p p' = Pattern $ \a -> (arc p a) ++ (arc p' a)
(>+<) = overlay
stack :: [Pattern a] -> Pattern a
stack ps = foldr overlay silence ps
append :: Pattern a -> Pattern a -> Pattern a
append a b = cat [a,b]
append' :: Pattern a -> Pattern a -> Pattern a
append' a b = slow 2 $ cat [a,b]
cat :: [Pattern a] -> Pattern a
cat ps = density (fromIntegral $ length ps) $ slowcat ps
splitAtSam :: Pattern a -> Pattern a
splitAtSam p =
Pattern $ \a -> concatMap (\(s,e) -> mapSnds' (trimArc (sam s)) $ arc p (s,e)) (arcCycles a)
where trimArc s' (s,e) = (max (s') s, min (s'+1) e)
slowcat :: [Pattern a] -> Pattern a
slowcat [] = silence
slowcat ps = Pattern $ \a -> concatMap f (arcCycles a)
where ps' = map splitAtSam ps
l = length ps'
f (s,e) = arc (mapResultTime (+offset) p) (s',e')
where p = ps' !! n
r = (floor s) :: Int
n = (r `mod` l) :: Int
offset = (fromIntegral $ r ((r n) `div` l)) :: Time
(s', e') = (soffset, eoffset)
listToPat :: [a] -> Pattern a
listToPat = cat . map atom
maybeListToPat :: [Maybe a] -> Pattern a
maybeListToPat = cat . map f
where f Nothing = silence
f (Just x) = atom x
run n = listToPat [0 .. n1]
density :: Time -> Pattern a -> Pattern a
density 0 p = p
density 1 p = p
density r p = mapResultTime (/ r) $ mapQueryTime (* r) p
densityGap :: Time -> Pattern a -> Pattern a
densityGap r p = mapResultTime (\t -> sam t + ((cyclePos t) / r)) $ Pattern (\a -> concatMap (\a' -> arc p $ mapArc (\t -> sam t + (min 1 (r * cyclePos t))) a') (arcCycles a))
slow :: Time -> Pattern a -> Pattern a
slow 0 = id
slow t = density (1/t)
(<~) :: Time -> Pattern a -> Pattern a
(<~) t p = mapResultTime (subtract t) $ mapQueryTime (+ t) p
(~>) :: Time -> Pattern a -> Pattern a
(~>) = (<~) . (0)
brak :: Pattern a -> Pattern a
brak = every 2 (((1%4) ~>) . (\x -> cat [x, silence]))
iter :: Int -> Pattern a -> Pattern a
iter n p = slowcat $ map (\i -> ((fromIntegral i)%(fromIntegral n)) <~ p) [0 .. n]
rev :: Pattern a -> Pattern a
rev p = Pattern $ \a -> concatMap
(\a' -> mapArcs mirrorArc $
(arc p (mirrorArc a')))
(arcCycles a)
palindrome p = append' p (rev p)
when :: (Int -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
when test f p = Pattern $ \a -> concatMap apply (arcCycles a)
where apply a | test (floor $ fst a) = (arc $ f p) a
| otherwise = (arc p) a
every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
every 0 f p = p
every n f p = when ((== 0) . (`mod` n)) f p
sig :: (Time -> a) -> Pattern a
sig f = Pattern f'
where f' (s,e) | s > e = []
| otherwise = [((s,e), (s,e), f s)]
sinewave :: Pattern Double
sinewave = sig $ \t -> sin $ pi * 2 * (fromRational t)
sine = sinewave
sinerat = fmap toRational sine
ratsine = sinerat
sinewave1 :: Pattern Double
sinewave1 = fmap ((/ 2) . (+ 1)) sinewave
sine1 = sinewave1
sinerat1 = fmap toRational sine1
sineAmp1 :: Double -> Pattern Double
sineAmp1 offset = (+ offset) <$> sinewave1
sawwave :: Pattern Double
sawwave = ((subtract 1) . (* 2)) <$> sawwave1
saw = sawwave
sawrat = fmap toRational saw
sawwave1 :: Pattern Double
sawwave1 = sig $ \t -> mod' (fromRational t) 1
saw1 = sawwave1
sawrat1 = fmap toRational saw1
triwave :: Pattern Double
triwave = ((subtract 1) . (* 2)) <$> triwave1
tri = triwave
trirat = fmap toRational tri
triwave1 :: Pattern Double
triwave1 = append sawwave1 (rev sawwave1)
tri1 = triwave1
trirat1 = fmap toRational tri1
squarewave1 :: Pattern Double
squarewave1 = sig $
\t -> fromIntegral $ floor $ (mod' (fromRational t) 1) * 2
square1 = squarewave1
squarewave :: Pattern Double
squarewave = ((subtract 1) . (* 2)) <$> squarewave1
square = squarewave
envL :: Pattern Double
envL = sig $ \t -> max 0 $ min (fromRational t) 1
filterValues :: (a -> Bool) -> Pattern a -> Pattern a
filterValues f (Pattern x) = Pattern $ (filter (f . thd')) . x
filterOnsets :: Pattern a -> Pattern a
filterOnsets (Pattern f) =
Pattern $ (filter (\e -> eventOnset e >= eventStart e)) . f
filterStartInRange :: Pattern a -> Pattern a
filterStartInRange (Pattern f) =
Pattern $ \(s,e) -> filter ((>= s) . eventOnset) $ f (s,e)
filterOnsetsInRange = filterOnsets . filterStartInRange
seqToRelOnsets :: Arc -> Pattern a -> [(Double, a)]
seqToRelOnsets (s, e) p = map (\((s', _), _, x) -> (fromRational $ (s's) / (es), x)) $ arc (filterOnsetsInRange p) (s, e)
segment :: Pattern a -> Pattern [a]
segment p = Pattern $ \(s,e) -> filter (\(_,(s',e'),_) -> s' < e && e' > s) $ groupByTime (segment' (arc p (s,e)))
segment' :: [Event a] -> [Event a]
segment' es = foldr split es pts
where pts = nub $ points es
split :: Time -> [Event a] -> [Event a]
split _ [] = []
split t ((ev@(a,(s,e), v)):es) | t > s && t < e = (a,(s,t),v):(a,(t,e),v):(split t es)
| otherwise = ev:split t es
points :: [Event a] -> [Time]
points [] = []
points ((_,(s,e), _):es) = s:e:(points es)
groupByTime :: [Event a] -> [Event [a]]
groupByTime es = map mrg $ groupBy ((==) `on` snd') $ sortBy (compare `on` snd') es
where mrg es@((a, a', _):_) = (a, a', map thd' es)
ifp :: (Int -> Bool) -> (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
ifp test f1 f2 p = Pattern $ \a -> concatMap apply (arcCycles a)
where apply a | test (floor $ fst a) = (arc $ f1 p) a
| otherwise = (arc $ f2 p) a
rand :: Pattern Double
rand = Pattern $ \a -> [(a, a, fst $ randomDouble $ pureMT $ floor $ (*1000000) $ (midPoint a))]
irand :: Double -> Pattern Int
irand i = (floor . (*i)) <$> rand
degradeBy :: Double -> Pattern a -> Pattern a
degradeBy x p = unMaybe $ (\a f -> toMaybe (f > x) a) <$> p <*> rand
where toMaybe False _ = Nothing
toMaybe True a = Just a
unMaybe = (fromJust <$>) . filterValues isJust
degrade :: Pattern a -> Pattern a
degrade = degradeBy 0.5
wedge :: Time -> Pattern a -> Pattern a -> Pattern a
wedge t p p' = overlay (densityGap (1/t) p) (t <~ densityGap (1/(1t)) p')