diff --git a/Sound/Tidal/Pattern.hs b/Sound/Tidal/Pattern.hs --- a/Sound/Tidal/Pattern.hs +++ b/Sound/Tidal/Pattern.hs @@ -30,21 +30,25 @@ show p@(Pattern _) = show $ arc p (0, 1) instance Functor Pattern where - fmap f (Pattern a) = Pattern $ fmap (fmap (mapSnd f)) a + fmap f (Pattern a) = Pattern $ fmap (fmap (mapThd' f)) a -- | @pure a@ returns a pattern with an event with value @a@, which -- has a duration of one cycle, and repeats every cycle. instance Applicative Pattern where pure x = Pattern $ \(s, e) -> map - (\t -> ((t%1, (t+1)%1), x)) + (\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), f) = - map (\(_, x) -> ((s,e), f x)) + where applyX ((s,e), (s', e'), f) = + map (\(_, _, x) -> ((s,e), (s', e'), f x)) (filter - (\(a', _) -> isIn a' s) - (xs (s,e)) + (\(_, a', _) -> isIn a' s) + (xs (s',e')) ) -- | @mempty@ is a synonym for @silence@. @@ -58,10 +62,11 @@ return = pure p >>= f = Pattern (\a -> concatMap - (\((s,e), x) -> mapFsts (const (s,e)) $ - filter - (\(a', _) -> isIn a' s) - (arc (f x) (s,e)) + -- TODO - this is a total guess + (\((s,e), (s',e'), x) -> mapSnds' (const (s',e')) $ + filter + (\(_, a', _) -> isIn a' s) + (arc (f x) (s',e')) ) (arc p a) ) @@ -89,7 +94,7 @@ -- applied to the @Arc@ values in the events returned from the -- original @Pattern@ @p@. mapResultArc :: (Arc -> Arc) -> Pattern a -> Pattern a -mapResultArc f p = Pattern $ \a -> mapFsts f $ arc p a +mapResultArc f p = Pattern $ \a -> mapArcs f $ arc p a -- | @mapResultTime f p@ returns a new @Pattern@ with function @f@ -- applied to the both the start and end @Time@ of the @Arc@ values in @@ -126,14 +131,11 @@ cat :: [Pattern a] -> Pattern a cat ps = density (fromIntegral $ length ps) $ slowcat ps -{-slowcat' ps = Pattern $ \a -> concatMap f (arcCycles a) - where l = length ps - f (s,e) = arc p (s,e) - where p = ps !! n - n = (floor s) `mod` l-} --- Concatenates so that the first loop of each pattern is played in --- turn, second loop of each pattern, and so on.. +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@ does the same as @cat@, but maintaining the duration of -- the original patterns. It is the equivalent of @append'@, but with @@ -142,9 +144,10 @@ slowcat :: [Pattern a] -> Pattern a slowcat [] = silence slowcat ps = Pattern $ \a -> concatMap f (arcCycles a) - where l = length ps + where ps' = map splitAtSam ps + l = length ps' f (s,e) = arc (mapResultTime (+offset) p) (s',e') - where p = ps !! n + where p = ps' !! n r = (floor s) :: Int n = (r `mod` l) :: Int offset = (fromIntegral $ r - ((r - n) `div` l)) :: Time @@ -182,12 +185,12 @@ slow t = density (1/t) --- | The @<~@ operator shift (or rotate) a pattern to the left (or +-- | The @<~@ operator shifts (or rotates) a pattern to the left (or -- counter-clockwise) by the given @Time@ value. For example -- @(1%16) <~ p@ will return a pattern with all the events moved -- one 16th of a cycle to the left. (<~) :: Time -> Pattern a -> Pattern a -(<~) t p = filterOffsets $ mapResultTime (+ t) $ mapQueryTime (subtract t) p +(<~) t p = mapResultTime (+ t) $ mapQueryTime (subtract t) p -- | The @~>@ operator does the same as @~>@ but shifts events to the -- right (or clockwise) rather than to the left. @@ -198,7 +201,7 @@ -- reversed (or mirrored). rev :: Pattern a -> Pattern a rev p = Pattern $ \a -> concatMap - (\a' -> mapFsts mirrorArc $ + (\a' -> mapArcs mirrorArc $ (arc p (mirrorArc a'))) (arcCycles a) @@ -225,7 +228,7 @@ sig :: (Time -> a) -> Pattern a sig f = Pattern f' where f' (s,e) | s > e = [] - | otherwise = [((s,e), f s)] + | otherwise = [((s,e), (s,e), f s)] -- | @sinewave@ returns a @Pattern@ of continuous @Double@ values following a -- sinewave with frequency of one cycle, and amplitude from -1 to 1. @@ -297,16 +300,23 @@ squarewave = ((subtract 1) . (* 2)) <$> squarewave1 square = squarewave --- Filter out events that start before range -filterOffsets :: Pattern a -> Pattern a -filterOffsets (Pattern f) = - Pattern $ \(s, e) -> filter ((>= s) . eventStart) $ f (s, e) +-- Filter out events that have had their onsets cut off +filterOnsets :: Pattern a -> Pattern a +filterOnsets (Pattern f) = + Pattern $ (filter (\e -> eventOnset e >= eventStart e)) . f +-- Filter events which have onsets, which are within the given range +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 = mapFsts (fromRational . (/ (e-s)) . (subtract s) . fst) $ arc (filterOffsets p) (s, e) +seqToRelOnsets (s, e) p = map (\((s', _), _, x) -> (fromRational $ (s'-s) / (e-s), 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 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 @@ -314,16 +324,16 @@ split :: Time -> [Event a] -> [Event a] split _ [] = [] -split t ((ev@((s,e), v)):es) | t > s && t < e = ((s,t),v):((t,e),v):(split t es) - | otherwise = ev:split t es +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) +points ((_,(s,e), _):es) = s:e:(points es) groupByTime :: [Event a] -> [Event [a]] -groupByTime es = map mrg $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) es - where mrg es@((a, _):_) = (a, map snd es) +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) @@ -331,4 +341,4 @@ | otherwise = (arc $ f2 p) a rand :: Pattern Double -rand = Pattern $ \a -> [(a, fst $ randomDouble $ pureMT $ floor $ (*1000000) $ (midPoint a))] +rand = Pattern $ \a -> [(a, a, fst $ randomDouble $ pureMT $ floor $ (*1000000) $ (midPoint a))] diff --git a/Sound/Tidal/Strategies.hs b/Sound/Tidal/Strategies.hs --- a/Sound/Tidal/Strategies.hs +++ b/Sound/Tidal/Strategies.hs @@ -42,12 +42,12 @@ spread f xs p = cat $ map (\x -> f x p) xs slowspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b -slowspread f xs p = slow (fromIntegral $ length $ xs) $ spread f xs p +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 (filterOffsets timepat) r + Pattern $ \r -> concatMap (\(_,r', x) -> (arc (f x pat) r')) (rs r) + where rs r = arc (filterOnsetsInRange timepat) r {- scrumple :: Time -> Pattern a -> Pattern a -> Pattern a @@ -72,14 +72,16 @@ trunc :: Time -> Pattern a -> Pattern a trunc t p = slow t $ Pattern $ \a -> concatMap f $ arcCycles a - where f a = mapFsts (stretch . trunc') $ arc p (trunc' a) + where f 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)) +--spreadf :: [Pattern a -> Pattern b] -> Pattern a -> Pattern b +spreadf ts p = spread ($) + spin :: Int -> OscPattern -> OscPattern spin steps p = stack $ map (\n -> (((fromIntegral n)%(fromIntegral steps)) <~ p |+| pan (pure $ (fromIntegral n)/(fromIntegral steps)))) [0 .. steps] - {-stripe :: Arc -> Pattern a -> Pattern a stripe (stripeS, stripeE) p = slow t $ Pattern $ \a -> concatMap f $ arcCycles a where f a = mapFsts (stretch . stripe') $ arc p (stripe' a) @@ -87,7 +89,7 @@ stretch (s,e) = (sam s + ((s - sam s) / t), sam s + ((e - sam s) / t)) -} - +iter :: Int -> Pattern a -> Pattern a iter n p = slowcat $ map (\i -> ((fromIntegral i)%(fromIntegral n)) <~ p) [0 .. n] spin4 step p = stack $ map (\n -> ((toRational n)/4) <~ p |+| pan (pure $ n)) [0,step .. 3] @@ -102,10 +104,12 @@ | otherwise = stack $ map (\(i, p') -> p' |+| (((fromIntegral i) % l) <~ p)) (zip [0 ..] ps) where l = fromIntegral $ length ps +{- cross f p p' = Pattern $ \t -> concat [filter flt $ arc p t, filter (not . flt) $ arc p' t ] where flt = f . cyclePos . fst . fst +-} inside n f p = density n $ f (slow n p) diff --git a/Sound/Tidal/Stream.hs b/Sound/Tidal/Stream.hs --- a/Sound/Tidal/Stream.hs +++ b/Sound/Tidal/Stream.hs @@ -39,6 +39,8 @@ type OscPattern = Pattern OscMap +latency = 0.04 + defaultDatum :: Param -> Maybe Datum defaultDatum (S _ (Just x)) = Just $ string x defaultDatum (I _ (Just x)) = Just $ int32 x @@ -74,7 +76,6 @@ toMessage s shape change ticks (o, m) = do m' <- applyShape' shape m let beat = fromIntegral ticks / fromIntegral tpb - latency = 0.02 logicalNow = (logicalTime change beat) beat' = (fromIntegral ticks + 1) / fromIntegral tpb logicalPeriod = (logicalTime change (beat + 1)) - logicalNow @@ -155,14 +156,17 @@ --defaultV Nothing = defaultDatum nParam makeS = make string + +makeF :: OscShape -> String -> Pattern Double -> OscPattern makeF = make float + makeI = make int32 param :: OscShape -> String -> Param param shape n = head $ filter (\x -> name x == n) (params shape) merge :: OscPattern -> OscPattern -> OscPattern -merge x y = Map.union <$> x <*> y +merge x y = (flip Map.union) <$> x <*> y infixl 1 |+| (|+|) :: OscPattern -> OscPattern -> OscPattern diff --git a/Sound/Tidal/Time.hs b/Sound/Tidal/Time.hs --- a/Sound/Tidal/Time.hs +++ b/Sound/Tidal/Time.hs @@ -1,5 +1,7 @@ module Sound.Tidal.Time where +import Sound.Tidal.Utils + -- | Time is represented by a rational number. Each natural number -- represents both the start of the next rhythmic cycle, and the end -- of the previous one. Rational numbers are used so that subdivisions @@ -10,8 +12,14 @@ -- @ { t : s <= t && t < e } @ type Arc = (Time, Time) --- | An Event is a value that occurs during the given @Arc@ -type Event a = (Arc, a) +-- | An Event is a value that occurs during the period given by the +-- first @Arc@. The second one indicates the event's "domain of +-- influence". These will often be the same, but many temporal +-- transformations, such as rotation and scaling time, may resuqlt in +-- arcs being split or truncated. In such cases, the first arc is +-- preserved, but the second arc reflects the portion of the event +-- which is relevant. +type Event a = (Arc, Arc, a) -- | The starting point of the current cycle. A cycle occurs from each -- natural number to the next, so this is equivalent to @floor@. @@ -57,8 +65,15 @@ -- | The start time of the given @Event@ eventStart :: Event a -> Time -eventStart = fst . fst +eventStart = fst . snd' +-- | The start time of the given @Event@ +eventOnset :: Event a -> Time +eventOnset = fst . fst' + -- | The midpoint of an @Arc@ midPoint :: Arc -> Time midPoint (s,e) = s + ((e - s) / 2) + +hasOnset :: Event a -> Bool +hasOnset ((s,_), (s',_), _) = s == s' diff --git a/Sound/Tidal/Utils.hs b/Sound/Tidal/Utils.hs --- a/Sound/Tidal/Utils.hs +++ b/Sound/Tidal/Utils.hs @@ -25,3 +25,29 @@ maybeRead :: String -> Maybe Double maybeRead = fmap fst . listToMaybe . reads + +fst' (a, _, _) = a +snd' (_, b, _) = b +thd' (_, _, c) = c + + +mapFst' :: (a -> x) -> (a, b, c) -> (x, b, c) +mapFst' f (x,y,z) = (f x,y,z) + +mapSnd' :: (b -> x) -> (a, b, c) -> (a, x, c) +mapSnd' f (x,y,z) = (x,f y,z) + +mapThd' :: (c -> x) -> (a, b, c) -> (a, b, x) +mapThd' f (x,y,z) = (x,y,f z) + +mapFsts' :: (a -> x) -> [(a, b, c)] -> [(x, b, c)] +mapFsts' = fmap . mapFst' + +mapSnds' :: (b -> x) -> [(a, b, c)] -> [(a, x, c)] +mapSnds' = fmap . mapSnd' + +mapThds' :: (c -> x) -> [(a, b, c)] -> [(a, b, x)] +mapThds' = fmap . mapThd' + +mapArcs :: (a -> a) -> [(a, a, x)] -> [(a, a, x)] +mapArcs f = (mapFsts' f) . (mapSnds' f) diff --git a/doc/tidal.md b/doc/tidal.md --- a/doc/tidal.md +++ b/doc/tidal.md @@ -99,7 +99,7 @@ different parts: ~~~~ {#mycode .haskell} -d1 $ sound "[bd ht lt, sn cp]" +d1 $ sound "[bd bd bd, sn cp sn cp]" ~~~~ This would play the sequence `bd bd bd` at the same time as `sn cp sn @@ -123,9 +123,11 @@ ~~~~ You can make parts of patterns repeat by using `*`, for example the -following example produces the same pattern as the previous one: +following expressions produce the same pattern: ~~~~ {#mycode .haskell} +d1 $ sound "[bd bd bd, sn cp sn cp]" + d1 $ sound "[bd*3, [sn cp]*2]" ~~~~ diff --git a/tidal.cabal b/tidal.cabal --- a/tidal.cabal +++ b/tidal.cabal @@ -1,5 +1,5 @@ name: tidal -version: 0.2.13 +version: 0.3 synopsis: Pattern language for improvised music -- description: homepage: http://yaxu.org/tidal/ diff --git a/tidal.el b/tidal.el --- a/tidal.el +++ b/tidal.el @@ -56,6 +56,9 @@ (tidal-see-output)) (tidal-send-string ":set prompt \"\"") (tidal-send-string ":module Sound.Tidal.Context") +; (tidal-send-string ":module Volca.Beat Volca.Key") +; (tidal-send-string "(note, [portamento, expression, voice, octave, detune, vcoegint, cutoff, vcfegint, lforate, lfopitchint, lfocutoffint, attack, decay, sustain, delaytime , delayfeedback], keystop) <- keystart") +; (tidal-send-string "(drum, [clapSpeed, clavesSpeed, agogoSpeed, crashSpeed, stutterTime, stutterDepth, tomDecay, clhatDecay, ophatDecay, hatGrain], beatstop) <- startbeat") (tidal-send-string "d1 <- dirtStream") (tidal-send-string "d2 <- dirtStream") (tidal-send-string "d3 <- dirtStream") @@ -67,6 +70,7 @@ (tidal-send-string "d9 <- dirtStream") (tidal-send-string "bps <- bpsSetter") (tidal-send-string "let hush = mapM_ ($ silence) [d1,d2,d3,d4,d5,d6,d7,d8,d9]") + (tidal-send-string "let solo = (>>) hush") (tidal-send-string ":set prompt \"tidal> \"") )