From e4aa2d653a2d924c05db8c2e31b39231a9f1ee95 Mon Sep 17 00:00:00 2001
From: Renzo Torr- <56176668+geikha@users.noreply.github.com>
Date: Fri, 9 Aug 2024 03:51:04 -0300
Subject: [PATCH] better quant performance

---
 src/Sound/Tidal/Pattern.hs | 12 ++++--------
 src/Sound/Tidal/UI.hs      | 19 +++++++++++++------
 2 files changed, 17 insertions(+), 14 deletions(-)

diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs
index 498e8360..ef7d89cc 100644
--- a/src/Sound/Tidal/Pattern.hs
+++ b/src/Sound/Tidal/Pattern.hs
@@ -915,14 +915,10 @@ eventHasOnset e | isAnalog e = False
 -- | Given any event, return it as if it was queried between the given arc
 encloseEvent :: Arc -> Event a -> Maybe (Event a)
 encloseEvent _ (Event _ Nothing _ _) = Nothing -- TODO how to handle analogs
-encloseEvent (Arc as ae) ev@(Event _ (Just (Arc ws we)) _ _)
-  | we <= as = Nothing
-  | ws >= ae = Nothing
-  | ws >= as && we <= ae = Just ev  -- fully within
-  | ws >= as && we >  ae = Just ev { part = Arc ws ae }  -- starts within, ends outside
-  | ws < as  && we >  ae = Just ev { part = Arc as ae }   -- starts outside, ends outside
-  | ws < as  && we <= ae = Just ev { part = Arc as we }  -- starts outside, ends within
-  | otherwise = Nothing
+encloseEvent a@(Arc as ae) ev@(Event ctx (Just w@(Arc ws we)) part val)
+  | we <= as || ws >= ae = Nothing -- outside
+  | ws >= as && we <= ae = Just ev -- fully within
+  | otherwise = Just ev { part = sect w a } -- intersects
 
 -- | If an event ends before it starts, switch starts with ends
 unflipEvent :: Event a -> Event a
diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs
index e5e3fc0b..107896b7 100644
--- a/src/Sound/Tidal/UI.hs
+++ b/src/Sound/Tidal/UI.hs
@@ -37,6 +37,8 @@ module Sound.Tidal.UI where
 
 import           Prelude               hiding ((*>), (<*))
 
+import           Control.Applicative (liftA2)
+
 import           Data.Bits             (Bits, shiftL, shiftR, testBit, xor)
 import           Data.Char             (digitToInt, isDigit, ord)
 
@@ -2060,10 +2062,16 @@ fill p' p = struct (splitQueries $ p {query = q, pureValue = Nothing}) p'
 _quant :: Time -> Pattern a -> Pattern a
 _quant 0 pat = pat
 _quant k pat =
-  withEventOnArc (quantEvent k) (timeToCycleArc . start) pat
+  withEventOnArc (quantEvent k) (surround) pat
   where
+    surround qa@(Arc qs qe) = Arc (qs - lookahead) (qe + lookahead)
+    lookahead = 1/k
     quantEvent k ev = ev { whole = (fmap rounding <$> whole ev) }
-    rounding n = toTime $ ((/ k) $ fromIntegral $ round $ (* k) n)
+    rounding n = (roundNumerator n) % k'
+    roundNumerator n = (nn * k' + (nd `div` 2)) `div` nd
+      where nn = numerator n
+            nd = denominator n
+    k' = numerator k
 
 quant :: Pattern Time -> Pattern a -> Pattern a
 quant = patternify _quant
@@ -2090,14 +2098,13 @@ fill' = patternify2 _fill
 alterT :: (Time -> Time) -> Pattern a -> Pattern a
 alterT f pat =
   withEventOnArc (unflipEvent . alterEvent) (timeToCycleArc . start) pat
-  where alterEvent ev = ev { whole = (fmap alterTime <$> whole ev) }
-        alterTime w = (sam $ w) + (f $ cyclePos $ w)
+  where alterEvent ev = ev { whole = (fmap (mapCycle f) $ whole ev) }
 
 alterF :: (Double -> Double) -> Pattern a -> Pattern a
 alterF f pat =
   withEventOnArc (unflipEvent . alterEvent) (timeToCycleArc . start) pat
-  where alterEvent ev = ev { whole = (fmap alterTime <$> whole ev) }
-        alterTime t = (sam $ t) + (toRational $ f $ fromRational $ cyclePos $ t)
+  where alterEvent ev = ev { whole = (fmap (mapCycle f') $ whole ev) }
+        f' = toRational . f . fromRational
 
 {- | @ply n@ repeats each event @n@ times within its arc.