From 8b660198df52d2addd99601c50f71ea1f44271f7 Mon Sep 17 00:00:00 2001 From: Renzo Torr- <56176668+geikha@users.noreply.github.com> Date: Fri, 19 Jul 2024 02:40:23 -0300 Subject: [PATCH 1/3] windowing funcs initial commit --- src/Sound/Tidal/Pattern.hs | 27 ++++++++++++++++++++++++ src/Sound/Tidal/UI.hs | 42 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 69 insertions(+) diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index f7bf4d4f..e0f57541 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/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 diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index b3af7f38..b27f1ea6 100644 --- a/src/Sound/Tidal/UI.hs +++ b/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: From da741d64e0c67d36cc4ebcffd094d57c8539fc67 Mon Sep 17 00:00:00 2001 From: Renzo Torr- <56176668+geikha@users.noreply.github.com> Date: Fri, 19 Jul 2024 03:19:55 -0300 Subject: [PATCH 2/3] minor fixes --- src/Sound/Tidal/Pattern.hs | 8 ++++---- src/Sound/Tidal/UI.hs | 6 +++--- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index e0f57541..498e8360 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -914,8 +914,8 @@ 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 -encloseEvent (Arc as ae) ev@(Event ctx (Just (Arc ws we)) part val) +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 @@ -926,8 +926,8 @@ encloseEvent (Arc as ae) ev@(Event ctx (Just (Arc ws we)) part val) -- | 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) } +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 diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index b27f1ea6..e5e3fc0b 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -44,7 +44,7 @@ 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) @@ -2072,7 +2072,7 @@ _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)) + 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] @@ -2088,7 +2088,7 @@ fill' :: Pattern Time -> Pattern Time -> Pattern a -> Pattern a fill' = patternify2 _fill alterT :: (Time -> Time) -> Pattern a -> Pattern a -alter f pat = +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) 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 3/3] 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.