diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index f7bf4d4f..ef7d89cc 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,19 @@ 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 -- 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 diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index b3af7f38..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) @@ -44,7 +46,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) @@ -2057,6 +2059,53 @@ 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) (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: