From 410e4a5d0d84138d2834dd7566d472fad93b7c03 Mon Sep 17 00:00:00 2001
From: alex <alex@slab.org>
Date: Wed, 10 Apr 2024 17:37:04 +0100
Subject: [PATCH] preserve/calculate tactus correctly across applicatives

---
 src/Sound/Tidal/Pattern.hs | 10 +++++-----
 src/Sound/Tidal/Time.hs    | 15 ++++++++++-----
 src/Sound/Tidal/UI.hs      |  2 +-
 3 files changed, 16 insertions(+), 11 deletions(-)

diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs
index 968151068..e13a95559 100644
--- a/src/Sound/Tidal/Pattern.hs
+++ b/src/Sound/Tidal/Pattern.hs
@@ -79,7 +79,7 @@ steps = tParam _steps
 keepMeta :: Pattern a -> Pattern a -> Pattern a
 keepMeta from to = to {tactus = tactus from, pureValue = pureValue from}
 
-keepTactus :: Pattern a -> Pattern a -> Pattern a
+keepTactus :: Pattern a -> Pattern b -> Pattern b
 keepTactus from to = to {tactus = tactus from}
 
 -- type StateMap = Map.Map String (Pattern Value)
@@ -121,19 +121,19 @@ instance Applicative Pattern where
   -- > (⅓>½)-⅔|11
   -- > ⅓-(½>⅔)|12
   -- >   (⅔>1)|102
-  (<*>) = applyPatToPatBoth
+  (<*>) a b = (applyPatToPatBoth a b) {tactus = lcmr <$> tactus a <*> tactus b }
 
 -- | Like @<*>@, but the "wholes" come from the left
 (<*) :: Pattern (a -> b) -> Pattern a -> Pattern b
-(<*) = applyPatToPatLeft
+(<*) a b = keepTactus a $ applyPatToPatLeft a b
 
 -- | Like @<*>@, but the "wholes" come from the right
 (*>) :: Pattern (a -> b) -> Pattern a -> Pattern b
-(*>) = applyPatToPatRight
+(*>) a b = keepTactus b $ applyPatToPatRight a b
 
 -- | Like @<*>@, but the "wholes" come from the left
 (<<*) :: Pattern (a -> b) -> Pattern a -> Pattern b
-(<<*) = applyPatToPatSqueeze
+(<<*) a b = (applyPatToPatSqueeze a b) {tactus = (*) <$> tactus a <*> tactus b }
 
 infixl 4 <*, *>, <<*
 applyPatToPat :: (Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)) -> Pattern (a -> b) -> Pattern a -> Pattern b
diff --git a/src/Sound/Tidal/Time.hs b/src/Sound/Tidal/Time.hs
index 8f0aa9e01..da3dfd605 100644
--- a/src/Sound/Tidal/Time.hs
+++ b/src/Sound/Tidal/Time.hs
@@ -1,11 +1,12 @@
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
 
 module Sound.Tidal.Time where
 
-import Control.Applicative
-import GHC.Generics
-import Control.DeepSeq (NFData)
+import           Control.Applicative
+import           Control.DeepSeq     (NFData)
+import           Data.Ratio
+import           GHC.Generics
 
 -- | Time is rational
 type Time = Rational
@@ -13,7 +14,7 @@ type Time = Rational
 -- | An arc of time, with a start time (or onset) and a stop time (or offset)
 data ArcF a = Arc
   { start :: a
-  , stop :: a
+  , stop  :: a
   } deriving (Eq, Ord, Functor, Show, Generic)
 
 type Arc = ArcF Time
@@ -152,3 +153,7 @@ mapCycle f (Arc s e) = Arc (sam' + f (s - sam')) (sam' + f (e - sam'))
 -- the arc represented by @a@.
 isIn :: Arc -> Time -> Bool
 isIn (Arc s e) t = t >= s && t < e
+
+-- | Returns the lowest common multiple of two rational numbers
+lcmr :: Rational -> Rational -> Rational
+lcmr a b = lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)
diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs
index 3661d83f4..c232cf1a7 100644
--- a/src/Sound/Tidal/UI.hs
+++ b/src/Sound/Tidal/UI.hs
@@ -521,7 +521,7 @@ There is also `iter'`, which shifts the pattern in the opposite direction.
 
 -}
 iter :: Pattern Int -> Pattern c -> Pattern c
-iter = tParam _iter
+iter a pat = keepTactus pat $ tParam _iter a pat
 
 _iter :: Int -> Pattern a -> Pattern a
 _iter n p = slowcat $ map (\i -> (fromIntegral i % fromIntegral n) `rotL` p) [0 .. (n-1)]