encloseEvent & query windowing functions

src/Sound/Tidal/Pattern.hs

@@ -502,6 +502,16 @@
 withPart :: (Arc -> Arc) -> Pattern a -> Pattern a
 withPart f = withEvent (\(Event c w p v) -> Event c w (f p) v)
 
+-- | @withEventsOnArc ef af p@ returns a new @Pattern@ with ef applied to the events list queried from the query arc modified by af, then enclosed into the original arc
+-- function @f@
+withEventsOnArc :: ([Event a] -> [Event a]) -> (Arc -> Arc) -> Pattern a -> Pattern a
+withEventsOnArc ef af p = splitQueries $ p {query = \st -> mapMaybe (encloseEvent $ arc st) $ ef $ query p st { arc = af $ arc st}}
+
+-- | @withEventOnArc ef af p@ returns a new @Pattern@ with ef applied to the each event queried from the query arc modified by af, then enclosed into the original arc
+-- function @f@
+withEventOnArc :: (Event a -> Event a) -> (Arc -> Arc) -> Pattern a -> Pattern a
+withEventOnArc ef af p = withEventsOnArc (ef <$>) af p
+
 _extract :: (Value -> Maybe a) -> String -> ControlPattern -> Pattern a
 _extract f name pat = filterJust $ withValue (Map.lookup name >=> f) pat
 
@@ -902,6 +912,19 @@
 eventHasOnset e | isAnalog e = False
                 | otherwise = start (fromJust $ whole e) == start (part e)
 
+-- | 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 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
+unflipEvent ev@(Event _ (Just (Arc ws we)) (Arc ps pe) _) = if we >= ws then ev else ev { whole = (Just (Arc we ws)), part = (Arc pe ps) }
+unflipEvent ev@(Event _ Nothing (Arc ps pe) _) = if pe >= ps then ev else ev { part = (Arc pe ps) }
+
 -- TODO - Is this used anywhere? Just tests, it seems
 -- TODO - support 'context' field
 toEvent :: (((Time, Time), (Time, Time)), a) -> Event a

src/Sound/Tidal/UI.hs

@@ -37,14 +37,16 @@
 
 import           Prelude               hiding ((*>), (<*))
 
+import           Control.Applicative (liftA2)
+
 import           Data.Bits             (Bits, shiftL, shiftR, testBit, xor)
 import           Data.Char             (digitToInt, isDigit, ord)
 
 import           Data.Bool             (bool)
 import           Data.Fixed            (mod')
 import           Data.List             (elemIndex, findIndex, findIndices,
                                         groupBy, intercalate, sort, sortOn,
-                                        transpose)
+                                        sortBy, transpose)
 import qualified Data.Map.Strict       as Map
 import           Data.Maybe            (catMaybes, fromJust, fromMaybe, isJust,
                                         mapMaybe)
@@ -2057,6 +2059,53 @@
     tolerance = 0.01
 -}
 
+_quant :: Time -> Pattern a -> Pattern a
+_quant 0 pat = pat
+_quant k 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 = (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
+
+_fill :: Time -> Time -> Pattern a -> Pattern a
+_fill l m pat =
+  withEventsOnArc (map multiplyEvent . updateEvents . sortEvents) (lookahead) pat
+  where lookahead a = a { start = (`subtract` l) $ start a, stop = (+l) $ stop a }
+        sortEvents = sortBy (\e0 e1 -> compare (start $ part e0) (start $ part e1))
+        updateEvents es = (zipWith updatePair es (drop 1 es)) ++ safeLast es
+        safeLast [] = []
+        safeLast es = [last es]
+        updatePair ev ev2 = ev { whole = (liftA2 updateArc (whole ev) (whole ev2)) }
+        updateArc (Arc s0 _) (Arc s1 _) = Arc s0 s1
+        multiplyEvent ev = ev { whole = multiplyDuration <$> whole ev }
+        multiplyDuration (Arc s e) = Arc s (s + ((e-s)*m))
+
+fill :: Pattern Time -> Pattern a -> Pattern a
+fill = patternify (_fill 1)
+
+fill' :: Pattern Time -> Pattern Time -> Pattern a -> Pattern a
+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 (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 (mapCycle f') $ whole ev) }
+        f' = toRational . f . fromRational
+
 {- | @ply n@ repeats each event @n@ times within its arc.
 
 For example, the following are equivalent: