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 _) = intercalate " " $ map showEvent $ arc p (0, 1)
showTime t | denominator t == 1 = show (numerator t)
| otherwise = show (numerator t) ++ ('/':show (denominator t))
showArc a = concat[showTime $ fst a, (' ':showTime (snd a))]
showEvent (a, b, v) | a == b = concat["(",show v,
(' ':showArc a),
")"
]
| otherwise = show v
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) -> map (\ev -> ((s,e), (s',e'), thd' ev)) $
filter
(\(a', _, _) -> isIn a' s)
(arc (f x) (s,e))
)
(arc p a)
)
unwrap :: Pattern (Pattern a) -> Pattern a
unwrap p = Pattern $ \a -> concatMap ((\p' -> arc p' a) . thd') (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 = when ((== 1) . (`mod` 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
foldEvery :: [Int] -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
foldEvery ns f p = foldr ($) p (map (\x -> every x f) ns)
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
envLR :: Pattern Double
envLR = (1) <$> envL
envEq :: Pattern Double
envEq = sig $ \t -> sin (pi/2 * (max 0 $ min (fromRational (1t)) 1))
envEqR = sig $ \t -> cos (pi/2 * (max 0 $ min (fromRational (1t)) 1))
fadeOut :: Time -> Pattern a -> Pattern a
fadeOut n = spread' (degradeBy) (slow n $ envL)
fadeOut' :: Time -> Time -> Pattern a -> Pattern a
fadeOut' from dur p = spread' (degradeBy) (from ~> slow dur envL) p
fadeIn' :: Time -> Time -> Pattern a -> Pattern a
fadeIn' from dur p = spread' (\n p -> 1 <~ degradeBy n p) (from ~> slow dur ((1) <$> envL)) p
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, timeToRand $ (midPoint a))]
timeToRand t = fst $ randomDouble $ pureMT $ floor $ (*1000000) t
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 a -> Pattern a
e n k p = (flip const) <$> (filterValues (== True) $ listToPat $ bjorklund (n,k)) <*> p
e' :: Int -> Int -> Pattern a -> Pattern a
e' n k p = cat $ map (\x -> if x then p else silence) (bjorklund (n,k))
index :: Real b => b -> Pattern b -> Pattern c -> Pattern c
index sz indexpat pat = spread' (zoom' $ toRational sz) (toRational . (*(1sz)) <$> indexpat) pat
where zoom' sz start = zoom (start, start+sz)
prrw :: (a -> b -> c) -> Int -> (Time, Time) -> Pattern a -> Pattern b -> Pattern c
prrw f rot (blen, vlen) beatPattern valuePattern =
let
ecompare (_,e1,_) (_,e2,_) = compare (fst e1) (fst e2)
beats = sortBy ecompare $ arc beatPattern (0, blen)
values = fmap thd' . sortBy ecompare $ arc valuePattern (0, vlen)
cycles = blen * (fromIntegral $ lcm (length beats) (length values) `div` (length beats))
in
slow cycles $ stack $ zipWith
(\( _, (start, end), v') v -> (start ~>) $ densityGap (1 / (end start)) $ pure (f v' v))
(sortBy ecompare $ arc (density cycles $ beatPattern) (0, blen))
(drop (rot `mod` length values) $ cycle values)
prr :: Int -> (Time, Time) -> Pattern a -> Pattern a -> Pattern a
prr = prrw $ flip const
preplace :: (Time, Time) -> Pattern a -> Pattern a -> Pattern a
preplace = preplaceWith $ flip const
prep = preplace
preplace1 :: Pattern a -> Pattern a -> Pattern a
preplace1 = prr 0 (1, 1)
preplaceWith :: (a -> b -> c) -> (Time, Time) -> Pattern a -> Pattern b -> Pattern c
preplaceWith f (blen, plen) = prrw f 0 (blen, plen)
prw = preplaceWith
preplaceWith1 :: (a -> b -> c) -> Pattern a -> Pattern b -> Pattern c
preplaceWith1 f = prrw f 0 (1, 1)
prw1 = preplaceWith1
(<~>) :: Pattern a -> Pattern a -> Pattern a
(<~>) = preplace (1, 1)
protate :: Time -> Int -> Pattern a -> Pattern a
protate len rot p = prr rot (len, len) p p
prot = protate
prot1 = protate 1
(<<~) :: Int -> Pattern a -> Pattern a
(<<~) = protate 1
(~>>) :: Int -> Pattern a -> Pattern a
(~>>) = (<<~) . (0)
pequal :: Ord a => Time -> Pattern a -> Pattern a -> Bool
pequal cycles p1 p2 = (sort $ arc p1 (0, cycles)) == (sort $ arc p2 (0, cycles))
discretise :: Time -> Pattern a -> Pattern a
discretise n p = density n $ (atom (id)) <*> p
randcat :: [Pattern a] -> Pattern a
randcat ps = spread' (<~) (discretise 1 $ ((%1) . fromIntegral) <$> irand (fromIntegral $ length ps)) (slowcat ps)