From 73070728461c9dcd01cad9ef830a15ccb83f1ede Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Mon, 15 Apr 2024 10:18:14 +0100 Subject: [PATCH] more efficient sew, plus some auto-reformatting --- src/Sound/Tidal/UI.hs | 78 ++++++++++++++++++++++++++----------------- 1 file changed, 47 insertions(+), 31 deletions(-) diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index d0c28c952..ea3ca48a8 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} {- UI.hs - Tidal's main 'user interface' functions, for transforming @@ -33,22 +35,25 @@ module Sound.Tidal.UI where -import Prelude hiding ((<*), (*>)) +import Prelude hiding ((*>), (<*)) -import Data.Char (digitToInt, isDigit, ord) -import Data.Bits (testBit, Bits, xor, shiftL, shiftR) +import Data.Bits (Bits, shiftL, shiftR, testBit, xor) +import Data.Char (digitToInt, isDigit, ord) -import Data.Ratio ((%), Ratio) -import Data.Fixed (mod') -import Data.List (sort, sortOn, findIndices, elemIndex, groupBy, transpose, intercalate, findIndex) -import Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe) -import qualified Data.Text as T -import qualified Data.Map.Strict as Map -import Data.Bool (bool) +import Data.Bool (bool) +import Data.Fixed (mod') +import Data.List (elemIndex, findIndex, findIndices, + groupBy, intercalate, sort, sortOn, + transpose) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, + mapMaybe) +import Data.Ratio (Ratio, (%)) +import qualified Data.Text as T import Sound.Tidal.Bjorklund (bjorklund) import Sound.Tidal.Core -import qualified Sound.Tidal.Params as P +import qualified Sound.Tidal.Params as P import Sound.Tidal.Pattern import Sound.Tidal.Utils @@ -689,7 +694,7 @@ wedge pt pa pb = innerJoin $ (\t -> _wedge t pa pb) <$> pt _wedge :: Time -> Pattern a -> Pattern a -> Pattern a _wedge 0 _ p' = p' -_wedge 1 p _ = p +_wedge 1 p _ = p _wedge t p p' = overlay (_fastGap (1/t) p) (t `rotR` _fastGap (1/(1-t)) p') @@ -976,10 +981,10 @@ _distrib :: [Int] -> Pattern a -> Pattern a _distrib xs p = boolsToPat (foldr distrib' (replicate (last xs) True) (reverse $ layers xs)) p where distrib' :: [Bool] -> [Bool] -> [Bool] - distrib' [] _ = [] - distrib' (_:a) [] = False : distrib' a [] + distrib' [] _ = [] + distrib' (_:a) [] = False : distrib' a [] distrib' (True:a) (x:b) = x : distrib' a b - distrib' (False:a) b = False : distrib' a b + distrib' (False:a) b = False : distrib' a b layers = map bjorklund . (zip<*>tail) boolsToPat a b' = flip const <$> filterValues (== True) (fastFromList a) <* b' @@ -1296,9 +1301,9 @@ randArcs n = return pairs where pairUp [] = [] pairUp xs = Arc 0 (head xs) : pairUp' xs - pairUp' [] = [] - pairUp' [_] = [] - pairUp' [a, _] = [Arc a 1] + pairUp' [] = [] + pairUp' [_] = [] + pairUp' [a, _] = [Arc a 1] pairUp' (a:b:xs) = Arc a b: pairUp' (b:xs) @@ -1850,12 +1855,12 @@ ur t outer_p ps fs = _slow t $ unwrap $ adjust <$> timedValues (getPat . split < where split = wordsBy (==':') getPat (s:xs) = (match s, transform xs) -- TODO - check this really can't happen.. - getPat _ = error "can't happen?" + getPat _ = error "can't happen?" match s = fromMaybe silence $ lookup s ps' ps' = map (fmap (_fast t)) ps adjust (a, (p, f)) = f a p transform (x:_) a = transform' x a - transform _ _ = id + transform _ _ = id transform' str (Arc s e) p = s `rotR` inside (pure $ 1/(e-s)) (matchF str) p matchF str = fromMaybe id $ lookup str fs timedValues = withEvent (\(Event c (Just a) a' v) -> Event c (Just a) a' (a,v)) . filterDigital @@ -1886,7 +1891,7 @@ inhabit ps p = squeezeJoin $ (\s -> fromMaybe silence $ lookup s ps) <$> p spaceOut :: [Time] -> Pattern a -> Pattern a spaceOut xs p = _slow (toRational $ sum xs) $ stack $ map (`compressArc` p) spaceArcs where markOut :: Time -> [Time] -> [Arc] - markOut _ [] = [] + markOut _ [] = [] markOut offset (x:xs') = Arc offset (offset+x):markOut (offset+x) xs' spaceArcs = map (\(Arc a b) -> Arc (a/s) (b/s)) $ markOut 0 xs s = sum xs @@ -1979,7 +1984,7 @@ _arp name p = arpWith f p ("thumbup", thumbup), ("thumbupdown", \x -> init (thumbup x) ++ init (reverse $ thumbup x)) ] - converge [] = [] + converge [] = [] converge (x:xs) = x : converge' xs converge' [] = [] converge' xs = last xs : converge (init xs) @@ -2020,7 +2025,7 @@ rolledWith t = withEvents aux where aux es = concatMap (steppityIn) (groupBy (\a b -> whole a == whole b) $ ((isRev t) es)) isRev b = (\x -> if x > 0 then id else reverse ) b steppityIn xs = mapMaybe (\(n, ev) -> (timeguard n xs ev t)) $ enumerate xs - timeguard _ _ ev 0 = return ev + timeguard _ _ ev 0 = return ev timeguard n xs ev _ = (shiftIt n (length xs) ev) shiftIt n d (Event c (Just (Arc s e)) a' v) = do a'' <- subArc (Arc newS e) a' @@ -2171,7 +2176,18 @@ _pressBy r pat = squeezeJoin $ (compressTo (r,1) . pure) <$> pat > (s "cp:3*16" # speed sine + 1.5) -} sew :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a -sew pb a b = overlay (mask pb a) (mask (inv pb) b) +-- Replaced with more efficient version below +-- sew pb a b = overlay (mask pb a) (mask (inv pb) b) +sew pb a b = Pattern $ pf + where pf st = concatMap match evs + where evs = query pb st + parts = map part evs + subarc = Arc (minimum $ map start parts) (maximum $ map stop parts) + match ev | value ev = find (query a st {arc = subarc}) ev + | otherwise = find (query b st {arc = subarc}) ev + find evs' ev = catMaybes $ map (check ev) evs' + check bev xev = do newarc <- subArc (part bev) (part xev) + return $ xev {part = newarc} {-| Uses the first (binary) pattern to switch between the following two patterns. The resulting structure comes from the binary @@ -2595,7 +2611,7 @@ contrastRange = contrastBy f f (VF s, VF e) (VF v) = v >= s && v <= e f (VN s, VN e) (VN v) = v >= s && v <= e f (VS s, VS e) (VS v) = v == s && v == e - f _ _ = False + f _ _ = False {- | The @fix@ function applies another function to matching events in a pattern of @@ -2694,7 +2710,7 @@ mono :: Pattern a -> Pattern a mono p = Pattern $ \(State a cm) -> flatten $ query p (State a cm) where flatten :: [Event a] -> [Event a] flatten = mapMaybe constrainPart . truncateOverlaps . sortOn whole - truncateOverlaps [] = [] + truncateOverlaps [] = [] truncateOverlaps (e:es) = e : truncateOverlaps (mapMaybe (snip e) es) -- TODO - decide what to do about analog events.. snip a b | start (wholeOrPart b) >= stop (wholeOrPart a) = Just b @@ -2782,9 +2798,9 @@ deconstruct :: Int -> Pattern String -> String deconstruct n p = intercalate " " $ map showStep $ toList p where showStep :: [String] -> String - showStep [] = "~" + showStep [] = "~" showStep [x] = x - showStep xs = "[" ++ (intercalate ", " xs) ++ "]" + showStep xs = "[" ++ (intercalate ", " xs) ++ "]" toList :: Pattern a -> [[a]] toList pat = map (\(s,e) -> map value $ queryArc (_segment n' pat) (Arc s e)) arcs where breaks = [0, (1/n') ..] @@ -2820,7 +2836,7 @@ _bite n ipat pat = squeezeJoin $ zoompat <$> ipat -- | Chooses from a list of patterns, using a pattern of integers. squeeze :: Pattern Int -> [Pattern a] -> Pattern a -squeeze _ [] = silence +squeeze _ [] = silence squeeze ipat pats = squeezeJoin $ (pats !!!) <$> ipat squeezeJoinUp :: Pattern (ControlPattern) -> ControlPattern @@ -2896,5 +2912,5 @@ grain s w = P.begin b # P.end e necklace :: Rational -> [Int] -> Pattern Bool necklace perCycle xs = _slow ((toRational $ sum xs) / perCycle) $ listToPat $ list xs where list :: [Int] -> [Bool] - list [] = [] + list [] = [] list (x:xs') = (True:(replicate (x-1) False)) ++ list xs'