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 Music.Theory.Bjorklund
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 []
withQueryArc :: (Arc -> Arc) -> Pattern a -> Pattern a
withQueryArc f p = Pattern $ \a -> arc p (f a)
withQueryTime :: (Time -> Time) -> Pattern a -> Pattern a
withQueryTime = withQueryArc . mapArc
withResultArc :: (Arc -> Arc) -> Pattern a -> Pattern a
withResultArc f p = Pattern $ \a -> mapArcs f $ arc p a
withResultTime :: (Time -> Time) -> Pattern a -> Pattern a
withResultTime = withResultArc . 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 =
splitQueries $ Pattern $ \(s,e) -> mapSnds' (trimArc (sam s)) $ arc p (s,e)
where trimArc s' (s,e) = (max (s') s, min (s'+1) e)
slowcat :: [Pattern a] -> Pattern a
slowcat [] = silence
slowcat ps = splitQueries $ Pattern f
where ps' = map splitAtSam ps
l = length ps'
f (s,e) = arc (withResultTime (+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]
scan n = cat $ map run [1 .. n]
density :: Time -> Pattern a -> Pattern a
density 0 p = silence
density 1 p = p
density r p = withResultTime (/ r) $ withQueryTime (* r) p
densityGap :: Time -> Pattern a -> Pattern a
densityGap 0 p = silence
densityGap r p = splitQueries $ withResultArc (\(s,e) -> (sam s + ((s sam s)/r), (sam s + ((e sam s)/r)))) $ Pattern (\a -> arc p $ mapArc (\t -> sam t + (min 1 (r * cyclePos t))) a)
slow :: Time -> Pattern a -> Pattern a
slow 0 = id
slow t = density (1/t)
(<~) :: Time -> Pattern a -> Pattern a
(<~) t p = withResultTime (subtract t) $ withQueryTime (+ 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 = splitQueries $ Pattern $ \a -> mapArcs mirrorArc (arc p (mirrorArc a))
palindrome p = append' p (rev p)
when :: (Int -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
when test f p = splitQueries $ Pattern apply
where apply a | test (floor $ fst a) = (arc $ f p) a
| otherwise = (arc p) a
whenT :: (Time -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
whenT test f p = splitQueries $ Pattern apply
where apply a | test (fst a) = (arc $ f p) a
| otherwise = (arc p) a
playWhen :: (Time -> Bool) -> Pattern a -> Pattern a
playWhen test (Pattern f) = Pattern $ (filter (\e -> test (eventOnset e))) . f
playFor :: Time -> Time -> Pattern a -> Pattern a
playFor s e = playWhen (\t -> and [t >= s, t < e])
seqP :: [(Time, Time, Pattern a)] -> Pattern a
seqP = stack . (map (\(s, e, p) -> playFor s e ((sam s) ~> p)))
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
fadeOut :: Time -> Pattern a -> Pattern a
fadeOut n = spread' (degradeBy) (slow n $ envL)
fadeIn :: Time -> Pattern a -> Pattern a
fadeIn n = spread' (degradeBy) (slow n $ (1) <$> envL)
spread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b
spread f xs p = cat $ map (\x -> f x p) xs
slowspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b
slowspread f xs p = slowcat $ map (\x -> f x p) xs
spread' :: (a -> Pattern b -> Pattern c) -> Pattern a -> Pattern b -> Pattern c
spread' f timepat pat =
Pattern $ \r -> concatMap (\(_,r', x) -> (arc (f x pat) r')) (rs r)
where rs r = arc (filterOnsetsInRange timepat) r
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 = splitQueries $ Pattern apply
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
unDegradeBy :: Double -> Pattern a -> Pattern a
unDegradeBy x p = unMaybe $ (\a f -> toMaybe (f <= x) a) <$> p <*> rand
where toMaybe False _ = Nothing
toMaybe True a = Just a
unMaybe = (fromJust <$>) . filterValues isJust
sometimesBy :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy x f p = overlay (degradeBy x p) (f $ unDegradeBy x p)
sometimes = sometimesBy 0.5
often = sometimesBy 0.75
rarely = sometimesBy 0.25
almostNever = sometimesBy 0.1
almostAlways = sometimesBy 0.9
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')
whenmod :: Int -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
whenmod a b = Sound.Tidal.Pattern.when ((\t -> (t `mod` a) >= b ))
superimpose f p = stack [p, f p]
splitQueries :: Pattern a -> Pattern a
splitQueries p = Pattern $ \a -> concatMap (arc p) $ arcCycles a
trunc :: Time -> Pattern a -> Pattern a
trunc t p = slow t $ splitQueries $ p'
where p' = Pattern $ \a -> mapArcs (stretch . trunc') $ arc p (trunc' a)
trunc' (s,e) = (min s ((sam s) + t), min e ((sam s) + t))
stretch (s,e) = (sam s + ((s sam s) / t), sam s + ((e sam s) / t))
zoom :: Arc -> Pattern a -> Pattern a
zoom a@(s,e) p = splitQueries $ withResultArc (mapCycle ((/d) . (subtract s))) $ withQueryArc (mapCycle ((+s) . (*d))) p
where d = es
compress :: Arc -> Pattern a -> Pattern a
compress a@(s,e) p | s >= e = silence
| otherwise = s ~> densityGap (1/(es)) p
sliceArc :: Arc -> Pattern a -> Pattern a
sliceArc a@(s,e) p | s >= e = silence
| otherwise = compress a $ zoom a p
within :: Arc -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
within (s,e) f p = stack [sliceArc (0,s) p,
compress (s,e) $ f $ zoom (s,e) p,
sliceArc (e,1) p
]
revArc a = within a rev
e :: Int -> Int -> Pattern b -> Pattern b
e n k p = (flip const) <$> (filterValues (== True) $ listToPat $ bjorklund (n,k)) <*> p
e' :: Int -> Int -> Pattern b -> Pattern b
e' n k p = cat $ map (\x -> if x then p else silence) (bjorklund (n,k))