Merge pull request #1111 from tidalcycles/patterned-tactus

Patterned tactus WIP

cabal.project

@@ -1 +1,2 @@
+tests: True
 packages: ./ tidal-parse tidal-listener tidal-link

src/Sound/Tidal/Control.hs

@@ -26,14 +26,25 @@ module Sound.Tidal.Control where
 -}
 
 import qualified Data.Map.Strict as Map
-import Data.Maybe (fromJust, fromMaybe, isJust)
-import Data.Ratio
+import Data.Maybe (fromMaybe)
+import Data.Ratio ((%))
 import Sound.Tidal.Core
+  ( cF,
+    cat,
+    fastcat,
+    overlay,
+    sine,
+    slowcat,
+    stack,
+    (#),
+    (*|),
+    (|*),
+    (|>|),
+  )
 import qualified Sound.Tidal.Params as P
 import Sound.Tidal.Pattern
 import Sound.Tidal.Stream.Types (patternTimeID)
-import Sound.Tidal.UI
-import Sound.Tidal.Utils
+import Sound.Tidal.UI (bite, _irand)
 import Prelude hiding ((*>), (<*))
 
 -- | `spin` will "spin" and layer up a pattern the given number of times,
@@ -95,7 +106,7 @@ chopArc :: Arc -> Int -> [Arc]
 chopArc (Arc s e) n = map (\i -> Arc (s + (e - s) * (fromIntegral i / fromIntegral n)) (s + (e - s) * (fromIntegral (i + 1) / fromIntegral n))) [0 .. n - 1]
 
 _chop :: Int -> ControlPattern -> ControlPattern
-_chop n pat = squeezeJoin $ f <$> pat
+_chop n pat = keepTactus (withTactus (* toRational n) pat) $ squeezeJoin $ f <$> pat
   where
     f v = fastcat $ map (pure . rangemap v) slices
     rangemap v (b, e) = Map.union (fromMaybe (makeMap (b, e)) $ merge v (b, e)) v

src/Sound/Tidal/Core.hs

@@ -21,8 +21,9 @@
 module Sound.Tidal.Core where
 
 import Data.Fixed (mod')
+import Data.List (sortOn)
 import qualified Data.Map.Strict as Map
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
 import Sound.Tidal.Pattern
 import Prelude hiding ((*>), (<*))
 
@@ -379,7 +380,9 @@ fastCat :: [Pattern a] -> Pattern a
 fastCat (p : []) = p
 fastCat ps = setTactus t $ _fast (toTime $ length ps) $ cat ps
   where
-    t = fromMaybe (toRational $ length ps) $ ((* (toRational $ length ps)) . foldl1 lcmr) <$> (sequence $ map tactus ps)
+    t = fastCat <$> (sequence $ map tactus ps)
+
+--  where t = fromMaybe (toRational $ length ps) $ ((* (toRational $ length ps)) . foldl1 lcmr) <$> (sequence $ map tactus ps)
 
 -- | Alias for @fastCat@
 fastcat :: [Pattern a] -> Pattern a
@@ -400,7 +403,7 @@ fastcat = fastCat
 --  >              ]
 timeCat :: [(Time, Pattern a)] -> Pattern a
 timeCat ((_, p) : []) = p
-timeCat tps = setTactus total $ stack $ map (\(s, e, p) -> compressArc (Arc (s / total) (e / total)) p) $ arrange 0 $ filter (\(t, _) -> t > 0) $ tps
+timeCat tps = setTactus (Just $ pure total) $ stack $ map (\(s, e, p) -> compressArc (Arc (s / total) (e / total)) p) $ arrange 0 $ filter (\(t, _) -> t > 0) $ tps
   where
     total = sum $ map fst tps
     arrange :: Time -> [(Time, Pattern a)] -> [(Time, Time, Pattern a)]
@@ -427,6 +430,25 @@ timecat = timeCat
 overlay :: Pattern a -> Pattern a -> Pattern a
 overlay = (<>)
 
+-- | Serialises a pattern so there's only one event playing at any one
+-- time, making it /monophonic/. Events which start/end earlier are given priority.
+mono :: Pattern a -> Pattern a
+mono p = pattern $ \(State a cm) -> flatten $ query p (State a cm)
+  where
+    flatten :: [Event a] -> [Event a]
+    flatten = mapMaybe constrainPart . truncateOverlaps . sortOn whole
+    truncateOverlaps [] = []
+    truncateOverlaps (e : es) = e : truncateOverlaps (mapMaybe (snip e) es)
+    -- TODO - decide what to do about analog events..
+    snip a b
+      | start (wholeOrPart b) >= stop (wholeOrPart a) = Just b
+      | stop (wholeOrPart b) <= stop (wholeOrPart a) = Nothing
+      | otherwise = Just b {whole = Just $ Arc (stop $ wholeOrPart a) (stop $ wholeOrPart b)}
+    constrainPart :: Event a -> Maybe (Event a)
+    constrainPart e = do
+      a <- subArc (wholeOrPart e) (part e)
+      return $ e {part = a}
+
 -- | 'stack' combines a list of 'Pattern's into a new pattern, so that their
 -- events are combined over time, i.e., all of the patterns in the list are played
 -- simultaneously.
@@ -450,7 +472,10 @@ stack pats = (foldr overlay silence pats) {tactus = t}
   where
     t
       | length pats == 0 = Nothing
-      | otherwise = foldl1 lcmr <$> (sequence $ map tactus pats)
+      -- TODO - something cleverer..
+      | otherwise = (mono . stack) <$> (sequence $ map tactus pats)
+
+--          | otherwise = foldl1 lcmr <$> (sequence $ map tactus pats)
 
 -- ** Manipulating time
 
@@ -506,6 +531,9 @@ sparsity = slow
 zoom :: (Time, Time) -> Pattern a -> Pattern a
 zoom (s, e) = zoomArc (Arc s e)
 
+zoompat :: Pattern Time -> Pattern Time -> Pattern a -> Pattern a
+zoompat = patternify2 $ curry zoom
+
 zoomArc :: Arc -> Pattern a -> Pattern a
 zoomArc (Arc s e) p
   | s >= e = nothing

src/Sound/Tidal/Pattern.hs

@@ -56,30 +56,30 @@ data State = State
   }
 
 -- | A datatype representing events taking place over time
-data Pattern a = Pattern {query :: State -> [Event a], tactus :: Maybe Rational, pureValue :: Maybe a}
+data Pattern a = Pattern {query :: State -> [Event a], tactus :: Maybe (Pattern Rational), pureValue :: Maybe a}
   deriving (Generic, Functor)
 
 instance (NFData a) => NFData (Pattern a)
 
 pattern :: (State -> [Event a]) -> Pattern a
 pattern f = Pattern f Nothing Nothing
 
-setTactus :: Rational -> Pattern a -> Pattern a
-setTactus r p = p {tactus = Just r}
+setTactus :: Maybe (Pattern Rational) -> Pattern a -> Pattern a
+setTactus r p = p {tactus = r}
 
 setTactusFrom :: Pattern b -> Pattern a -> Pattern a
 setTactusFrom a b = b {tactus = tactus a}
 
 withTactus :: (Rational -> Rational) -> Pattern a -> Pattern a
-withTactus f p = p {tactus = f <$> tactus p}
+withTactus f p = p {tactus = fmap (fmap f) $ tactus p}
 
-_steps :: Rational -> Pattern a -> Pattern a
-_steps target p@(Pattern _ (Just t) _) = setTactus target $ _fast (target / t) p
+steps :: Pattern Rational -> Pattern a -> Pattern a
+steps target p@(Pattern _ (Just t) _) = setTactus (Just target) $ fast (target / t) p
 -- raise error?
-_steps _ p = p
+steps _ p = p
 
-steps :: Pattern Rational -> Pattern a -> Pattern a
-steps = patternify _steps
+-- _steps :: Pattern Rational -> Pattern a -> Pattern a
+-- _steps = patternify _steps
 
 keepMeta :: Pattern a -> Pattern a -> Pattern a
 keepMeta from to = to {tactus = tactus from, pureValue = pureValue from}
@@ -131,8 +131,7 @@ instance Applicative Pattern where
   -- > (⅓>½)-⅔|11
   -- > ⅓-(½>⅔)|12
   -- >   (⅔>1)|102
-  (<*>) :: Pattern (a -> b) -> Pattern a -> Pattern b
-  (<*>) a b = (applyPatToPatBoth a b) {tactus = lcmr <$> tactus a <*> tactus b}
+  (<*>) a b = (applyPatToPatBoth a b) {tactus = (\a' b' -> lcmr <$> a' <*> b') <$> tactus a <*> tactus b}
 
 -- | Like @<*>@, but the "wholes" come from the left
 (<*) :: Pattern (a -> b) -> Pattern a -> Pattern b
@@ -151,7 +150,7 @@ infixl 4 <*, *>, <<*
 applyPatToPat :: (Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)) -> Pattern (a -> b) -> Pattern a -> Pattern b
 applyPatToPat combineWholes pf px = pattern q
   where
-    q st = concatMap (catMaybes . match) (query pf st)
+    q st = catMaybes $ concatMap match $ query pf st
       where
         match ef@(Event (Context c) _ fPart f) =
           map
@@ -166,7 +165,7 @@ applyPatToPat combineWholes pf px = pattern q
 applyPatToPatBoth :: Pattern (a -> b) -> Pattern a -> Pattern b
 applyPatToPatBoth pf px = pattern q
   where
-    q st = catMaybes $ concatMap match (query pf st) ++ concatMap matchX (query (filterAnalog px) st)
+    q st = catMaybes $ (concatMap match $ query pf st) ++ (concatMap matchX $ query (filterAnalog px) st)
       where
         -- match analog events from pf with all events from px
         match ef@(Event _ Nothing fPart _) = map (withFX ef) (query px $ st {arc = fPart}) -- analog
@@ -183,7 +182,7 @@ applyPatToPatBoth pf px = pattern q
 applyPatToPatLeft :: Pattern (a -> b) -> Pattern a -> Pattern b
 applyPatToPatLeft pf px = pattern q
   where
-    q st = concatMap (catMaybes . match) (query pf st)
+    q st = catMaybes $ concatMap match $ query pf st
       where
         match ef = map (withFX ef) (query px $ st {arc = wholeOrPart ef})
         withFX ef ex = do
@@ -194,7 +193,7 @@ applyPatToPatLeft pf px = pattern q
 applyPatToPatRight :: Pattern (a -> b) -> Pattern a -> Pattern b
 applyPatToPatRight pf px = pattern q
   where
-    q st = concatMap (catMaybes . match) (query px st)
+    q st = catMaybes $ concatMap match $ query px st
       where
         match ex = map (`withFX` ex) (query pf $ st {arc = wholeOrPart ex})
         withFX ef ex = do
@@ -246,18 +245,22 @@ unwrap pp = pp {query = q, pureValue = Nothing}
 -- | Turns a pattern of patterns into a single pattern. Like @unwrap@,
 -- but structure only comes from the inner pattern.
 innerJoin :: Pattern (Pattern a) -> Pattern a
-innerJoin pp = pp {query = q, pureValue = Nothing}
+innerJoin pp = setTactus (Just $ innerJoin' $ filterJust $ tactus <$> pp) $ innerJoin' pp
   where
-    q st =
-      concatMap
-        (\(Event oc _ op v) -> mapMaybe (munge oc) $ query v st {arc = op})
-        (query pp st)
+    -- \| innerJoin but without tactus manipulation (to avoid recursion)
+    innerJoin' :: Pattern (Pattern b) -> Pattern b
+    innerJoin' pp = pp {query = q, pureValue = Nothing}
       where
-        munge oc (Event ic iw ip v) =
-          do
-            p <- subArc (arc st) ip
-            p' <- subArc p (arc st)
-            return (Event (combineContexts [ic, oc]) iw p' v)
+        q st =
+          concatMap
+            (\(Event oc _ op v) -> mapMaybe (munge oc) $ query v st {arc = op})
+            (query pp st)
+          where
+            munge oc (Event ic iw ip v) =
+              do
+                p <- subArc (arc st) ip
+                p' <- subArc p (arc st)
+                return (Event (combineContexts [ic, oc]) iw p' v)
 
 -- | Turns a pattern of patterns into a single pattern. Like @unwrap@,
 -- but structure only comes from the outer pattern.
@@ -279,6 +282,7 @@ outerJoin pp = pp {query = q, pureValue = Nothing}
 -- | Like @unwrap@, but cycles of the inner patterns are compressed to fit the
 -- timespan of the outer whole (or the original query if it's a continuous pattern?)
 -- TODO - what if a continuous pattern contains a discrete one, or vice-versa?
+-- TODO - tactus
 squeezeJoin :: Pattern (Pattern a) -> Pattern a
 squeezeJoin pp = pp {query = q, pureValue = Nothing}
   where