windowing funcs initial commit

src/Sound/Tidal/Pattern.hs

@@ -502,6 +502,16 @@ withEvents f p = p {query = f . query p, pureValue = Nothing}
 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,23 @@ eventHasOnset :: Event a -> Bool
 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
+encloseEvent (Arc as ae) ev@(Event ctx (Just (Arc ws we)) part val)
+  | 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
+
+-- | 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) _) | we >= ws = ev
+                                                          | ws >  we = ev { whole = (Just (Arc we ws)), 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

@@ -2057,6 +2057,48 @@ fill p' p = struct (splitQueries $ p {query = q, pureValue = Nothing}) p'
     tolerance = 0.01
 -}
 
+_quant :: Time -> Pattern a -> Pattern a
+_quant 0 pat = pat
+_quant k pat =
+  withEventOnArc (quantEvent k) (timeToCycleArc . start) pat
+  where
+    quantEvent k ev = ev { whole = (fmap rounding <$> whole ev) }
+    rounding n = toTime $ ((/ k) $ fromIntegral $ round $ (* k) n)
+
+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 = Data.List.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
+alter f pat =
+  withEventOnArc (unflipEvent . alterEvent) (timeToCycleArc . start) pat
+  where alterEvent ev = ev { whole = (fmap alterTime <$> whole ev) }
+        alterTime w = (sam $ w) + (f $ cyclePos $ w)
+
+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)
+
 {- | @ply n@ repeats each event @n@ times within its arc.
 
 For example, the following are equivalent: