From 4e89123b7d29dde7c2c332ab2fdcef1aa9e6c1f1 Mon Sep 17 00:00:00 2001
From: alex <alex@slab.org>
Date: Thu, 6 Jun 2024 11:24:13 +0100
Subject: [PATCH] tactus tweaks, add s_taperBy

---
 src/Sound/Tidal/Control.hs  |  2 +-
 src/Sound/Tidal/Core.hs     |  3 ++-
 src/Sound/Tidal/Pattern.hs  |  3 +++
 src/Sound/Tidal/Stepwise.hs | 26 +++++++++++++++++++++++++-
 4 files changed, 31 insertions(+), 3 deletions(-)

diff --git a/src/Sound/Tidal/Control.hs b/src/Sound/Tidal/Control.hs
index 560fbfc8..47373dcb 100644
--- a/src/Sound/Tidal/Control.hs
+++ b/src/Sound/Tidal/Control.hs
@@ -331,7 +331,7 @@ _splice bits ipat pat = withEvent f (slice (pure bits) ipat pat) # P.unit (pure
   > d1 $ splice 8 "[<0*8 0*2> 3*4 2 4] [4 .. 7]" $ sound "breaks165"
 -}
 splice :: Pattern Int -> Pattern Int -> ControlPattern -> Pattern (Map.Map String Value)
-splice bitpat ipat pat = innerJoin $ (\bits -> _splice bits ipat pat) <$> bitpat
+splice bitpat ipat pat = setTactusFrom bitpat $ innerJoin $ (\bits -> _splice bits ipat pat) <$> bitpat
 
 {-|
   @loopAt@ makes a sample fit the given number of cycles. Internally, it
diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs
index 5e9f7eb2..7fbd10b0 100644
--- a/src/Sound/Tidal/Core.hs
+++ b/src/Sound/Tidal/Core.hs
@@ -483,7 +483,8 @@ zoom :: (Time, Time) -> Pattern a -> Pattern a
 zoom (s,e) = zoomArc (Arc s e)
 
 zoomArc :: Arc -> Pattern a -> Pattern a
-zoomArc (Arc s e) p = withTactus (*d) $ splitQueries $
+zoomArc (Arc s e) p | s >= e = nothing
+                    | otherwise = withTactus (*d) $ splitQueries $
   withResultArc (mapCycle ((/d) . subtract s)) $ withQueryArc (mapCycle ((+s) . (*d))) p
      where d = e-s
 
diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs
index 7d8a2a2c..f7bf4d4f 100644
--- a/src/Sound/Tidal/Pattern.hs
+++ b/src/Sound/Tidal/Pattern.hs
@@ -65,6 +65,9 @@ pattern f = Pattern f Nothing Nothing
 setTactus :: Rational -> Pattern a -> Pattern a
 setTactus r p = p {tactus = Just 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}
 
diff --git a/src/Sound/Tidal/Stepwise.hs b/src/Sound/Tidal/Stepwise.hs
index 2ba8fa29..e52bd683 100644
--- a/src/Sound/Tidal/Stepwise.hs
+++ b/src/Sound/Tidal/Stepwise.hs
@@ -94,10 +94,31 @@ s_taperlist pat@(Pattern _ (Just t) _) = pat : map (\r -> _s_sub r pat) [1 .. t]
 -- TODO exception?
 s_taperlist pat                        = [pat]
 
+
+s_taperlistBy :: Int -> Int -> Pattern a -> [Pattern a]
+s_taperlistBy amount times pat@(Pattern _ (Just t) _) 
+  | times == 1 = [pat]
+  | times <= 0 = []
+  | amount == 0 = [pat]
+  | backwards = reverse l
+  | otherwise = l
+  where backwards = amount > 0
+        n = toRational $ abs amount
+        start = t - (toRational $ max 0 $ n * (toRational $ times - 1))
+        l = (map (\i -> zoom (0, (start + (n * (toRational i))) / t) pat) [0 .. times-2]) ++ [pat]
+
 -- | Plays one fewer step from the pattern each repetition, down to nothing
 s_taper :: Pattern a -> Pattern a
 s_taper = s_cat . s_taperlist
 
+-- | Plays one fewer step from the pattern each repetition, down to nothing
+_s_taperBy :: Int -> Int -> Pattern a -> Pattern a
+_s_taperBy amount times pat = s_cat $ s_taperlistBy amount times pat
+
+-- | Plays one fewer step from the pattern each repetition, down to nothing
+s_taperBy :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a
+s_taperBy = s_patternify2 _s_taperBy
+
 -- | Successively plays a pattern from each group in turn
 s_alt :: [[Pattern a]] -> Pattern a
 s_alt groups = s_cat $ concat $ take (c * length groups) $ transpose $ map cycle groups
@@ -119,6 +140,9 @@ s_patternify :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Patt
 s_patternify f (Pattern _ _ (Just a)) b = f a b
 s_patternify f pa p                     = stepJoin $ (`f` p) <$> pa
 
+s_patternify2 :: (a -> b -> c -> Pattern d) -> Pattern a -> Pattern b -> c -> Pattern d
+s_patternify2 f a b p = stepJoin $ (\x y -> f x y p) <$> a <*> b
+
 stepJoin :: Pattern (Pattern a) -> Pattern a
 stepJoin pp = Pattern q first_t Nothing
   where q st@(State a c) = query (timecat $ retime $ slices $ query (rotL (sam $ start a) pp) (st {arc = Arc 0 1})) st
@@ -133,7 +157,7 @@ stepJoin pp = Pattern q first_t Nothing
                 adjust dur pat = (dur*total_tactus, pat)
         -- break up events at all start/end points, into groups, including empty ones.
         slices :: [Event (Pattern a)] -> [(Time, Pattern a)]
-        slices evs = map (\s -> ((snd s - fst s), stack $ map value $ fit s evs)) $ pairs $ sort $ nubOrd $ 0:1:concatMap (\ev -> start (part ev):stop (part ev):[]) evs
+        slices evs = map (\s -> ((snd s - fst s), stack $ map (\x -> withContext (\c -> combineContexts [c, context x])  $ value x) $ fit s evs)) $ pairs $ sort $ nubOrd $ 0:1:concatMap (\ev -> start (part ev):stop (part ev):[]) evs
         -- list of slices of events within the given range
         fit :: (Rational, Rational) -> [Event (Pattern a)] -> [Event (Pattern a)]
         fit (b,e) evs = catMaybes $ map (match (b,e)) evs