beat function for "step sequencer" style rhythm notation. (Backported from Strudel)

src/Sound/Tidal/UI.hs

@@ -295,9 +295,9 @@
 probabilities and weighted appropriately by the weights in the list of pairs.
 -}
 wchooseBy :: Pattern Double -> [(a,Double)] -> Pattern a
 wchooseBy pat pairs = match <$> pat
   where
     match r = values !! head (findIndices (> (r*total)) cweights)
     cweights = scanl1 (+) (map snd pairs)
     values = map fst pairs
     total = sum $ map snd pairs
@@ -1006,7 +1006,7 @@
     distrib' (_:a) []       = False : distrib' a []
     distrib' (True:a) (x:b) = x : distrib' a b
     distrib' (False:a) b    = False : distrib' a b
     layers = map bjorklund . (zip<*>tail)
     boolsToPat a b' = flip const <$> filterValues (== True) (fastFromList a) <* b'
 
 {-| @euclidInv@ fills in the blanks left by `euclid`, i.e., it inverts the
@@ -1318,10 +1318,10 @@
   do rs <- mapM (\x -> pure (toRational x / toRational n) <~ choose [1 :: Int,2,3]) [0 .. (n-1)]
      let rats = map toRational rs
          total = sum rats
          pairs = pairUp $ accumulate $ map (/total) rats
      return pairs
        where pairUp [] = []
              pairUp xs = Arc 0 (head xs) : pairUp' xs
              pairUp' []       = []
              pairUp' [_]      = []
              pairUp' [a, _]   = [Arc a 1]
@@ -1335,7 +1335,7 @@
           where as = map (\(i, Arc s' e') ->
                     (Arc (s' + sam s) (e' + sam s),
                        subArc (Arc s e) (Arc (s' + sam s) (e' + sam s)), i)) $
                       enumerate $ value $ head $
                       queryArc (randArcs n) (Arc (sam s) (nextSam s))
                 (Arc s e) = arc st
 
@@ -1386,7 +1386,7 @@
 -- ruleset in form "a:b,b:ab"
 parseLMRule' :: String -> [(Char, String)]
 parseLMRule' str = map fixer $ parseLMRule str
   where fixer (c,r) = (head c, r)
 
 {- | Returns the @n@th iteration of a
   [Lindenmayer System](https://en.wikipedia.org/wiki/L-system)
@@ -1435,7 +1435,7 @@
 1->1 is 3/4.  -}
 runMarkov :: Int -> [[Double]] -> Int -> Time -> [Int]
 runMarkov n tp xi seed = reverse $ (iterate (markovStep $ renorm) [xi])!! (n-1) where
   markovStep tp' xs = (fromJust $ findIndex (r <=) $ scanl1 (+) (tp'!!(head xs))) : xs where
     r = timeToRand $ seed + (fromIntegral . length) xs / fromIntegral n
   renorm = [ map (/ sum x) x | x <- tp ]
 
@@ -1460,6 +1460,23 @@
 _markovPat n xi tp = setTactus (toRational n) $ splitQueries $ pattern (\(State a@(Arc s _) _) ->
   queryArc (listToPat $ runMarkov n tp xi (sam s)) a)
 
+{-|
+@beat@ structures a pattern by picking subdivisions of a cycle.
+Takes in a pattern that tells it which parts to play (polyphony is recommeded here),
+and the number of parts by which to subdivide the cycle (also pattern-able).
+For example:
+> d1 $ beat "[3,4.2,9,11,14]" 16 $ s "sd"
+-}
+beat :: Pattern Time -> Pattern Time -> Pattern a -> Pattern a
+beat = patternify2 $ __beat innerJoin
+
+__beat :: (Pattern (Pattern a) -> Pattern a) -> Time -> Time -> Pattern a -> Pattern a
+__beat join t d p = join $ (compress (s,e) . pure) <$> p
+                      where s = t' / d
+                            e  = (t'+1) / d
+                            t' = t `mod'` d
+
+
 {-|
 @mask@ takes a boolean pattern and ‘masks’ another pattern with it. That is,
 events are only carried over if they match within a ‘true’ event in the binary
@@ -1785,7 +1802,7 @@
   where events a seed = mapMaybe toEv $ zip arcs shuffled
           where shuffled = map snd $ sortOn fst $ zip rs [0 .. (n'-1)]
                 rs = timeToRands seed n' :: [Double]
                 arcs = zipWith Arc fractions (tail fractions)
                 fractions = map (+ (sam $ start a)) [0, 1 / fromIntegral n' .. 1]
                 toEv (a',v) = do a'' <- subArc a a'
                                  return $ Event (Context []) (Just a') a'' v