tidal 1.4.5 → 1.4.6
raw patch · 19 files changed
+345/−236 lines, 19 files
Files
- BootTidal.hs +3/−0
- CHANGELOG.md +10/−0
- src/Sound/Tidal/Control.hs +3/−3
- src/Sound/Tidal/Core.hs +8/−8
- src/Sound/Tidal/Params.hs +27/−0
- src/Sound/Tidal/ParseBP.hs +62/−65
- src/Sound/Tidal/Pattern.hs +64/−38
- src/Sound/Tidal/Tempo.hs +0/−7
- src/Sound/Tidal/Transition.hs +4/−4
- src/Sound/Tidal/UI.hs +22/−21
- src/Sound/Tidal/Utils.hs +21/−0
- src/Sound/Tidal/Version.hs +1/−1
- test/Sound/Tidal/CoreTest.hs +12/−12
- test/Sound/Tidal/ParseTest.hs +24/−0
- test/Sound/Tidal/PatternTest.hs +56/−57
- test/Sound/Tidal/UITest.hs +11/−11
- test/TestUtils.hs +7/−4
- tidal.cabal +1/−1
- tidal.el +9/−4
BootTidal.hs view
@@ -3,6 +3,9 @@ :set prompt-cont "" import Sound.Tidal.Context+import System.IO (hSetEncoding, stdout, utf8)++hSetEncoding stdout utf8 -- total latency = oLatency + cFrameTimespan tidal <- startTidal (superdirtTarget {oLatency = 0.1, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig {cFrameTimespan = 1/20})
CHANGELOG.md view
@@ -1,5 +1,15 @@ # TidalCycles log of changes +## 1.4.6 - Megatron++ * Experimental ratio shorthand ref #573 @yaxu+ * Store mininotation source location(s) in events ref #245 @yaxu+ * Add more things to tidal-parse @dktr0 @yaxu+ * Separate out haskell parser from tidal-parse into new hackage module called 'haskellish' @dktr0+ * Support patterning polyrhythmic % steps in mininotation @yaxu+ * Fixes to emacs plugin (tidal.el) @xmacex+ * New parameters for freq, overgain, overshape, and missing midi params including the new nrpn ones @yaxu+ ## 1.4.5 - Porter Brook * Mini notation - `@` (and its alias `_`) now accepts rational relative durations. E.g. `a b@0.5 c d` to make `b` have a half step (that would be the same as `a@2 b c@2 c@d`). This can also be patterned `a b@<0.5 2> c d` @yaxu #435
src/Sound/Tidal/Control.hs view
@@ -65,7 +65,7 @@ _chop n = withEvents (concatMap chopEvent) where -- for each part, chopEvent :: Event ControlMap -> [Event ControlMap]- chopEvent (Event (Just w) p' v) = map (chomp v (length $ chopArc w n)) $ arcs w p'+ chopEvent (Event c (Just w) p' v) = map (chomp c v (length $ chopArc w n)) $ arcs w p' -- ignoring 'analog' events (those without wholes), chopEvent _ = [] -- cut whole into n bits, and number them@@ -78,8 +78,8 @@ -- if the old event had a begin and end, then multiply the new -- begin and end values by the old difference (end-begin), and -- add the old begin- chomp :: ControlMap -> Int -> (Int, (Arc, Arc)) -> Event ControlMap- chomp v n' (i, (w,p')) = Event (Just w) p' (Map.insert "begin" (VF b') $ Map.insert "end" (VF e') v)+ chomp :: Context -> ControlMap -> Int -> (Int, (Arc, Arc)) -> Event ControlMap+ chomp c v n' (i, (w,p')) = Event c (Just w) p' (Map.insert "begin" (VF b') $ Map.insert "end" (VF e') v) where b = fromMaybe 0 $ do v' <- Map.lookup "begin" v getF v' e = fromMaybe 1 $ do v' <- Map.lookup "end" v
src/Sound/Tidal/Core.hs view
@@ -20,7 +20,7 @@ sig f = Pattern q where q (State (Arc s e) _) | s > e = []- | otherwise = [Event Nothing (Arc s e) (f (s+((e-s)/2)))]+ | otherwise = [Event (Context []) Nothing (Arc s e) (f (s+((e-s)/2)))] -- | @sine@ returns a 'Pattern' of continuous 'Fractional' values following a -- sinewave with frequency of one cycle, and amplitude from 0 to 1.@@ -314,17 +314,17 @@ }) } where makeWholeRelative :: Event a -> Event a- makeWholeRelative (e@(Event Nothing _ _)) = e- makeWholeRelative (Event (Just (Arc s e)) p'@(Arc s' e') v) =- Event (Just $ Arc (s'-s) (e-e')) p' v+ makeWholeRelative (e@(Event {whole = Nothing})) = e+ makeWholeRelative (Event c (Just (Arc s e)) p'@(Arc s' e') v) =+ Event c (Just $ Arc (s'-s) (e-e')) p' v makeWholeAbsolute :: Event a -> Event a- makeWholeAbsolute (e@(Event Nothing _ _)) = e- makeWholeAbsolute (Event (Just (Arc s e)) p'@(Arc s' e') v) =- Event (Just $ Arc (s'-e) (e'+s)) p' v+ makeWholeAbsolute (e@(Event {whole = Nothing})) = e+ makeWholeAbsolute (Event c (Just (Arc s e)) p'@(Arc s' e') v) =+ Event c (Just $ Arc (s'-e) (e'+s)) p' v midCycle :: Arc -> Time midCycle (Arc s _) = sam s + 0.5 mapParts :: (Arc -> Arc) -> [Event a] -> [Event a]- mapParts f es = (\(Event w p' v) -> Event w (f p') v) <$> es+ mapParts f es = (\(Event c w p' v) -> Event c w (f p') v) <$> es -- | Returns the `mirror image' of a 'Arc' around the given point in time mirrorArc :: Time -> Arc -> Arc mirrorArc mid' (Arc s e) = Arc (mid' - (e-mid')) (mid'+(mid'-s))
src/Sound/Tidal/Params.hs view
@@ -37,6 +37,9 @@ cc :: Pattern String -> ControlPattern cc = grp [mF "ccn", mF "ccv"] +nrpn :: Pattern String -> ControlPattern+nrpn = grp [mI "nrpn", mI "val"]+ -- | Singular params pF :: String -> Pattern Double -> ControlPattern@@ -173,6 +176,9 @@ end :: Pattern Double -> ControlPattern end = pF "end" +freq :: Pattern Double -> ControlPattern+freq = pF "freq"+ -- | a pattern of numbers that specify volume. Values less than 1 make -- the sound quieter. Values greater than 1 make the sound louder. For -- the linear equivalent, see @amp@.@@ -281,6 +287,13 @@ -} orbit :: Pattern Int -> ControlPattern orbit = pI "orbit"++overgain :: Pattern Double -> ControlPattern+overgain = pF "overgain"++overshape :: Pattern Double -> ControlPattern+overshape = pF "overshape"+ -- | a pattern of numbers between 0 and 1, from left to right (assuming stereo), once round a circle (assuming multichannel) pan :: Pattern Double -> ControlPattern pan = pF "pan"@@ -558,6 +571,20 @@ ccn = pF "ccn" ccv :: Pattern Double -> ControlPattern ccv = pF "ccv"++polyTouch :: Pattern Double -> ControlPattern+polyTouch = pF "polyTouch"++midibend :: Pattern Double -> ControlPattern+midibend = pF "midibend"++miditouch :: Pattern Double -> ControlPattern+miditouch = pF "miditouch"++nrpnn :: Pattern Int -> ControlPattern+nrpnn = pI "nrpn"+nrpnv :: Pattern Int -> ControlPattern+nrpnv = pI "val" ctlNum :: Pattern Double -> ControlPattern ctlNum = pF "ctlNum"
src/Sound/Tidal/ParseBP.hs view
@@ -37,10 +37,10 @@ perr = parsecError err type MyParser = Text.Parsec.Prim.Parsec String Int- + -- | AST representation of patterns -data TPat a = TPat_Atom a+data TPat a = TPat_Atom (Maybe ((Int, Int), (Int, Int))) a | TPat_Fast (TPat Time) (TPat a) | TPat_Slow (TPat Time) (TPat a) | TPat_DegradeBy Int Double (TPat a)@@ -56,35 +56,10 @@ | TPat_EnumFromTo (TPat a) (TPat a) deriving (Show) -{--patLen :: TPat a -> Rational-patLen (TPat_Seq xs) = toRational $ sum $ map patLen xs-patLen TPat_Foot = error "Feet (.) aren't allowed here"-patLen (TPat_Elongate r) = r - 1-patLen (TPat_Repeat n) = toRational $ n - 1-patLen _ = 1--}--{--resolve a@(TPat_Atom _) = a-resolve (TPat_Fast a b) = TPat_Fast (resolve a) (resolve b)-resolve (TPat_Slow a b) = TPat_Slow (resolve a) (resolve b)-resolve (TPat_DegradeBy a b c) = TPat_DegradeBy a b (resolve c)-resolve (TPat_CycleChoose a bs) = TPat_CycleChoose a (map resolve bs)-resolve (TPat_Euclid a b c d) = TPat_Euclid (resolve a) (resolve b) (resolve c) (resolve d)-resolve (TPat_Stack as) = TPat_Stack resolve- | TPat_Polyrhythm (Maybe (TPat Rational)) [TPat a]- | TPat_Seq [TPat a]- | TPat_Silence- | TPat_Foot- | TPat_Elongate Rational- | TPat_Repeat Int- | TPat_EnumFromTo (TPat a) (TPat a)--}--toPat :: (Enumerable a, Parseable a) => TPat a -> Pattern a+toPat :: (Parseable a, Enumerable a) => TPat a -> Pattern a toPat = \case- TPat_Atom x -> pure x+ TPat_Atom (Just loc) x -> setContext (Context [loc]) $ pure x+ TPat_Atom Nothing x -> pure x TPat_Fast t x -> fast (toPat t) $ toPat x TPat_Slow t x -> slow (toPat t) $ toPat x TPat_DegradeBy seed amt x -> _degradeByUsing (rotL (0.0001 * (fromIntegral seed)) rand) amt $ toPat x@@ -145,7 +120,7 @@ class Parseable a where tPatParser :: MyParser (TPat a) doEuclid :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a- -- toEuclid :: a -> + -- toEuclid :: a -> class Enumerable a where fromTo :: a -> a -> Pattern a@@ -154,7 +129,7 @@ instance Parseable Double where tPatParser = pDouble doEuclid = euclidOff- + instance Enumerable Double where fromTo = enumFromTo' fromThenTo = enumFromThenTo'@@ -236,9 +211,10 @@ symbol :: String -> MyParser String symbol = P.symbol lexer -natural, integer :: MyParser Integer+natural, integer, decimal :: MyParser Integer natural = P.natural lexer integer = P.integer lexer+decimal = P.integer lexer float :: MyParser Double float = P.float lexer@@ -338,40 +314,48 @@ pPolyOut f = do ss <- braces (pSequence f `sepBy` symbol ",") spaces -- TODO needed? base <- do char '%'- spaces -- TODO needed/wanted?- r <- pRational <?> "rational" -- TODO does rational work ok here?+ r <- pSequence pRational <?> "rational number" return $ Just r <|> return Nothing pMult $ TPat_Polyrhythm base ss <|> do ss <- angles (pSequence f `sepBy` symbol ",") spaces -- TODO needed/wanted?- pMult $ TPat_Polyrhythm (Just $ TPat_Atom 1) ss+ pMult $ TPat_Polyrhythm (Just $ TPat_Atom Nothing 1) ss pString :: MyParser String pString = do c <- (letter <|> oneOf "0123456789") <?> "charnum" cs <- many (letter <|> oneOf "0123456789:.-_") <?> "string" return (c:cs) +wrapPos :: MyParser (TPat a) -> MyParser (TPat a)+wrapPos p = do b <- getPosition+ tpat <- p+ e <- getPosition+ let addPos (TPat_Atom _ v') =+ TPat_Atom (Just ((sourceColumn b, sourceLine b), (sourceColumn e, sourceLine e))) v'+ addPos x = x -- shouldn't happen..+ return $ addPos tpat+ pVocable :: MyParser (TPat String)-pVocable = TPat_Atom <$> pString+pVocable = wrapPos $ (TPat_Atom Nothing) <$> pString pDouble :: MyParser (TPat Double)-pDouble = do f <- choice [intOrFloat, parseNote] <?> "float"- do c <- parseChord- return $ TPat_Stack $ map (TPat_Atom . (+f)) c- <|> return (TPat_Atom f)- <|>- do c <- parseChord- return $ TPat_Stack $ map TPat_Atom c+pDouble = wrapPos $ do f <- choice [intOrFloat, parseNote] <?> "float"+ do c <- parseChord+ return $ TPat_Stack $ map ((TPat_Atom Nothing) . (+f)) c+ <|> return (TPat_Atom Nothing f)+ <|>+ do c <- parseChord+ return $ TPat_Stack $ map (TPat_Atom Nothing) c pBool :: MyParser (TPat Bool)-pBool = do oneOf "t1"- return $ TPat_Atom True- <|>- do oneOf "f0"- return $ TPat_Atom False+pBool = wrapPos $ do oneOf "t1"+ return $ TPat_Atom Nothing True+ <|>+ do oneOf "f0"+ return $ TPat_Atom Nothing False parseIntNote :: Integral i => MyParser i parseIntNote = do s <- sign@@ -384,13 +368,13 @@ return $ applySign s $ fromIntegral i pIntegral :: Integral a => MyParser (TPat a)-pIntegral = do i <- parseIntNote- do c <- parseChord- return $ TPat_Stack $ map (TPat_Atom . (+i)) c- <|> return (TPat_Atom i)- <|>- do c <- parseChord- return $ TPat_Stack $ map TPat_Atom c+pIntegral = wrapPos $ do i <- parseIntNote+ do c <- parseChord+ return $ TPat_Stack $ map ((TPat_Atom Nothing) . (+i)) c+ <|> return (TPat_Atom Nothing i)+ <|>+ do c <- parseChord+ return $ TPat_Stack $ map (TPat_Atom Nothing) c parseChord :: (Enum a, Num a) => MyParser [a] parseChord = do char '\''@@ -431,9 +415,9 @@ fromNote pat = either (const 0) id . runParser parseNote 0 "" <$> pat pColour :: MyParser (TPat ColourD)-pColour = do name <- many1 letter <?> "colour name"- colour <- readColourName name <?> "known colour"- return $ TPat_Atom colour+pColour = wrapPos $ do name <- many1 letter <?> "colour name"+ colour <- readColourName name <?> "known colour"+ return $ TPat_Atom Nothing colour pMult :: TPat a -> MyParser (TPat a) pMult thing = do char '*'@@ -469,14 +453,14 @@ c <- do symbol "," spaces pSequence pIntegral- <|> return (TPat_Atom 0)+ <|> return (TPat_Atom Nothing 0) return (a, b, c) pRatio :: MyParser Rational pRatio = do s <- sign- n <- natural+ n <- read <$> many1 digit result <- do char '%'- d <- natural+ d <- decimal return (n%d) <|> do char '.'@@ -486,9 +470,22 @@ return (toRational ((read $ show n ++ "." ++ frac) :: Double)) <|> return (n%1)- return $ applySign s result+ c <- (ratioChar <|> return 1)+ return $ applySign s (result * c)+ <|> ratioChar+ where ratioChar = do char 'h'+ return $ 1%2+ <|> do char 'q'+ return $ 1%4+ <|> do char 'e'+ return $ 1%8+ <|> do char 's'+ return $ 1%16+ <|> do char 't'+ return $ 1%3+ <|> do char 'f'+ return $ 1%5 pRational :: MyParser (TPat Rational)-pRational = TPat_Atom <$> pRatio-+pRational = wrapPos $ (TPat_Atom Nothing) <$> pRatio
src/Sound/Tidal/Pattern.hs view
@@ -136,10 +136,34 @@ isIn :: Arc -> Time -> Bool isIn (Arc s e) t = t >= s && t < e +data Context = Context {contextPosition :: [((Int, Int), (Int, Int))]}+ deriving (Eq, Ord)++instance NFData Context where + rnf (Context c) = rnf c++instance Show Context where+ show (Context cs) = show cs++combineContexts :: [Context] -> Context+combineContexts = Context . concatMap contextPosition++setContext :: Context -> Pattern a -> Pattern a+setContext c pat = withEvents (map (\e -> e {context = c})) pat++withContext :: (Context -> Context) -> Pattern a -> Pattern a+withContext f pat = withEvents (map (\e -> e {context = f $ context e})) pat++deltaContext :: Int -> Int -> Pattern a -> Pattern a+deltaContext column line pat = withEvents (map (\e -> e {context = f $ context e})) pat+ where f :: Context -> Context+ f (Context xs) = Context $ map (\((bx,by), (ex,ey)) -> ((bx+column,by+line), (ex+column,ey+line))) xs+ -- | An event is a value that's active during a timespan. If a whole -- is present, the part should be equal to or fit inside it. data EventF a b = Event- { whole :: Maybe a+ { context :: Context+ , whole :: Maybe a , part :: a , value :: b } deriving (Eq, Ord, Functor)@@ -148,21 +172,21 @@ instance (NFData a, NFData b) => NFData (EventF a b) where - rnf (Event w p v) = rnf w `seq` rnf p `seq` rnf v+ rnf (Event c w p v) = rnf c `seq` rnf w `seq` rnf p `seq` rnf v {-instance Bifunctor EventF where bimap f g (Event w p e) = Event (f w) (f p) (g e) -} instance {-# OVERLAPPING #-} Show a => Show (Event a) where- show (Event (Just (Arc ws we)) a@(Arc ps pe) e) =- h ++ "(" ++ show a ++ ")" ++ t ++ "|" ++ show e+ show (Event c (Just (Arc ws we)) a@(Arc ps pe) e) =+ show c ++ h ++ "(" ++ show a ++ ")" ++ t ++ "|" ++ show e where h | ws == ps = "" | otherwise = prettyRat ws ++ "-" t | we == pe = "" | otherwise = "-" ++ prettyRat we- show (Event Nothing a e) =- "~" ++ show a ++ "~|" ++ show e+ show (Event c Nothing a e) =+ show c ++ "~" ++ show a ++ "~|" ++ show e isAnalog :: Event a -> Bool isAnalog (Event {whole = Nothing}) = True@@ -188,7 +212,7 @@ | otherwise = e : defragParts es where i = findIndex (isAdjacent e) es e' = es !! fromJust i- defraged = Event (whole e) u (value e)+ defraged = Event (context e) (whole e) u (value e) u = hull (part e) (part e') -- | Returns 'True' if the two given events are adjacent parts of the same whole@@ -232,8 +256,9 @@ | otherwise = start (fromJust $ whole e) == start (part e) -- TODO - Is this used anywhere? Just tests, it seems+-- TODO - support 'context' field toEvent :: (((Time, Time), (Time, Time)), a) -> Event a-toEvent (((ws, we), (ps, pe)), v) = Event (Just $ Arc ws we) (Arc ps pe) v+toEvent (((ws, we), (ps, pe)), v) = Event (Context []) (Just $ Arc ws we) (Arc ps pe) v -- | an Arc and some named control values data State = State {arc :: Arc,@@ -337,19 +362,19 @@ applyPatToPat combineWholes pf px = Pattern q where q st = catMaybes $ concatMap match $ query pf st where- match (ef@(Event _ fPart f)) =+ match (ef@(Event (Context c) _ fPart f)) = map- (\ex@(Event _ xPart x) ->+ (\ex@(Event (Context c') _ xPart x) -> do whole' <- combineWholes (whole ef) (whole ex) part' <- subArc fPart xPart- return (Event whole' part' (f x))+ return (Event (Context $ c ++ c') whole' part' (f x)) ) (query px $ st {arc = (wholeOrPart ef)}) instance Applicative Pattern where -- | Repeat the given value once per cycle, forever pure v = Pattern $ \(State a _) ->- map (\a' -> Event (Just a') (sect a a') v) $ cycleArcsInArc a+ map (\a' -> Event (Context []) (Just a') (sect a a') v) $ cycleArcsInArc a (<*>) = applyPatToPatBoth @@ -358,15 +383,15 @@ where q st = catMaybes $ (concatMap match $ query pf st) ++ (concatMap matchX $ query (filterAnalog px) st) where -- match analog events from pf with all events from px- match ef@(Event Nothing fPart _) = map (withFX ef) (query px $ st {arc = fPart}) -- analog+ match ef@(Event _ Nothing fPart _) = map (withFX ef) (query px $ st {arc = fPart}) -- analog -- match digital events from pf with digital events from px- match ef@(Event (Just fWhole) _ _) = map (withFX ef) (query (filterDigital px) $ st {arc = fWhole}) -- digital+ match ef@(Event _ (Just fWhole) _ _) = map (withFX ef) (query (filterDigital px) $ st {arc = fWhole}) -- digital -- match analog events from px (constrained above) with digital events from px- matchX ex@(Event Nothing fPart _) = map (\ef -> withFX ef ex) (query (filterDigital pf) $ st {arc = fPart}) -- digital+ matchX ex@(Event _ Nothing fPart _) = map (\ef -> withFX ef ex) (query (filterDigital pf) $ st {arc = fPart}) -- digital matchX _ = error "can't happen" withFX ef ex = do whole' <- subMaybeArc (whole ef) (whole ex) part' <- subArc (part ef) (part ex)- return (Event whole' part' (value ef $ value ex))+ return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex)) applyPatToPatLeft :: Pattern (a -> b) -> Pattern a -> Pattern b applyPatToPatLeft pf px = Pattern q@@ -375,7 +400,7 @@ match ef = map (withFX ef) (query px $ st {arc = wholeOrPart ef}) withFX ef ex = do let whole' = whole ef part' <- subArc (part ef) (part ex)- return (Event whole' part' (value ef $ value ex))+ return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex)) applyPatToPatRight :: Pattern (a -> b) -> Pattern a -> Pattern b applyPatToPatRight pf px = Pattern q@@ -384,7 +409,7 @@ match ex = map (\ef -> withFX ef ex) (query pf $ st {arc = wholeOrPart ex}) withFX ef ex = do let whole' = whole ex part' <- subArc (part ef) (part ex)- return (Event whole' part' (value ef $ value ex))+ return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex)) -- | Like <*>, but the 'wholes' come from the left@@ -414,28 +439,28 @@ unwrap :: Pattern (Pattern a) -> Pattern a unwrap pp = pp {query = q} where q st = concatMap- (\(Event w p v) ->- mapMaybe (munge w p) $ query v st {arc = p})+ (\(Event c w p v) ->+ mapMaybe (munge c w p) $ query v st {arc = p}) (query pp st)- munge ow op (Event iw ip v') =+ munge oc ow op (Event ic iw ip v') = do w' <- subMaybeArc ow iw p' <- subArc op ip- return (Event w' p' v')+ return (Event (combineContexts [ic, oc]) w' p' v') -- | Turns a pattern of patterns into a single pattern. Like @unwrap@, -- but structure only comes from the inner pattern. innerJoin :: Pattern (Pattern a) -> Pattern a innerJoin pp = pp {query = q} where q st = concatMap- (\(Event _ op v) -> mapMaybe munge $ query v st {arc = op}+ (\(Event oc _ op v) -> mapMaybe (munge oc) $ query v st {arc = op} ) (query pp st)- where munge (Event iw ip v) =+ where munge oc (Event ic iw ip v) = do p <- subArc (arc st) ip p' <- subArc p (arc st)- return (Event iw p' v)+ return (Event (combineContexts [ic, oc]) iw p' v) -- | Turns a pattern of patterns into a single pattern. Like @unwrap@, -- but structure only comes from the outer pattern.@@ -443,13 +468,13 @@ outerJoin pp = pp {query = q} where q st = concatMap (\e ->- mapMaybe (munge (whole e) (part e)) $ query (value e) st {arc = pure (start $ wholeOrPart e)}+ mapMaybe (munge (context e) (whole e) (part e)) $ query (value e) st {arc = pure (start $ wholeOrPart e)} ) (query pp st)- where munge ow op (Event _ _ v') =+ where munge oc ow op (Event ic _ _ v') = do p' <- subArc (arc st) op- return (Event ow p' v')+ return (Event (combineContexts [oc, ic]) ow p' v') -- | Like @unwrap@, but cycles of the inner patterns are compressed to fit the -- timespan of the outer whole (or the original query if it's a continuous pattern?)@@ -457,14 +482,14 @@ squeezeJoin :: Pattern (Pattern a) -> Pattern a squeezeJoin pp = pp {query = q} where q st = concatMap- (\e@(Event w p v) ->- mapMaybe (munge w p) $ query (compressArc (cycleArc $ wholeOrPart e) v) st {arc = p}+ (\e@(Event c w p v) ->+ mapMaybe (munge c w p) $ query (compressArc (cycleArc $ wholeOrPart e) v) st {arc = p} ) (query pp st)- munge oWhole oPart (Event iWhole iPart v) =+ munge oContext oWhole oPart (Event iContext iWhole iPart v) = do w' <- subMaybeArc oWhole iWhole p' <- subArc oPart iPart- return (Event w' p' v)+ return (Event (combineContexts [iContext, oContext]) w' p' v) noOv :: String -> a noOv meth = error $ meth ++ ": not supported for patterns"@@ -483,7 +508,7 @@ a ~== b = Map.differenceWith (\a' b' -> if a' ~== b' then Nothing else Just a') a b == Map.empty instance TolerantEq (Event ControlMap) where- (Event w p x) ~== (Event w' p' x') = w == w' && p == p' && x ~== x'+ (Event _ w p x) ~== (Event _ w' p' x') = w == w' && p == p' && x ~== x' instance TolerantEq a => TolerantEq [a] where as ~== bs = (length as == length bs) && all (uncurry (~==)) (zip as bs)@@ -673,7 +698,7 @@ -- | Apply a function to the arcs/timespans (both whole and parts) of the result withResultArc :: (Arc -> Arc) -> Pattern a -> Pattern a withResultArc f pat = pat- { query = map (\(Event w p e) -> Event (f <$> w) (f p) e) . query pat}+ { query = map (\(Event c w p e) -> Event c (f <$> w) (f p) e) . query pat} -- | Apply a function to the time (both start and end of the timespans -- of both whole and parts) of the result@@ -701,7 +726,7 @@ -- | @withPart f p@ returns a new @Pattern@ with function @f@ applied -- to the part. withPart :: (Arc -> Arc) -> Pattern a -> Pattern a-withPart f = withEvent (\(Event w p v) -> Event w (f p) v)+withPart f = withEvent (\(Event c w p v) -> Event c w (f p) v) -- | Apply one of three functions to a Value, depending on its type applyFIS :: (Double -> Double) -> (Int -> Int) -> (String -> String) -> Value -> Value@@ -829,7 +854,8 @@ matchManyToOne f pa pb = pa {query = q} where q st = map match $ query pb st where- match (ex@(Event xWhole xPart x)) =- Event xWhole xPart (any (f x) (as $ start $ wholeOrPart ex), x)- as s = map value $ query pa $ fQuery s+ match (ex@(Event xContext xWhole xPart x)) =+ Event (combineContexts $ xContext:(map context as')) xWhole xPart (any (f x) (map value $ as'), x)+ where as' = as $ start $ wholeOrPart ex+ as s = query pa $ fQuery s fQuery s = st {arc = Arc s s}
src/Sound/Tidal/Tempo.hs view
@@ -3,18 +3,14 @@ module Sound.Tidal.Tempo where --- import Data.Time (getCurrentTime, UTCTime, NominalDiffTime, diffUTCTime, addUTCTime)--- import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Control.Concurrent.MVar import qualified Sound.Tidal.Pattern as P import qualified Sound.OSC.FD as O--- import qualified Sound.OSC.Transport.FD.UDP as O import qualified Network.Socket as N import Control.Concurrent (forkIO, ThreadId, threadDelay) import Control.Monad (forever, when, foldM) import Data.List (nub) import qualified Control.Exception as E-import Data.Maybe (fromJust) import Sound.Tidal.Config import Sound.Tidal.Utils (writeError) @@ -31,9 +27,6 @@ synched :: Bool } deriving Show---- sendTempo udp tempo remote_sockaddr --- data State = State {ticks :: Int, start :: O.Time,
src/Sound/Tidal/Transition.hs view
@@ -38,10 +38,10 @@ solo = False, history = (appendPat historyFlag) (silence:[]) }- transition' context = do tempo <- readMVar $ sTempoMV stream- now <- O.time- let c = timeToCycles tempo now- return $ f c context+ transition' pat' = do tempo <- readMVar $ sTempoMV stream+ now <- O.time+ let c = timeToCycles tempo now+ return $ f c pat' mortalOverlay :: Time -> Time -> [Pattern a] -> Pattern a mortalOverlay _ _ [] = silence
src/Sound/Tidal/UI.hs view
@@ -80,7 +80,7 @@ @ -} rand :: Fractional a => Pattern a-rand = Pattern (\(State a@(Arc s e) _) -> [Event Nothing a (realToFrac $ timeToRand $ (e + s)/2)])+rand = Pattern (\(State a@(Arc s e) _) -> [Event (Context []) Nothing a (realToFrac $ timeToRand $ (e + s)/2)]) {- | Just like `rand` but for whole numbers, `irand n` generates a pattern of (pseudo-) random whole numbers between `0` to `n-1` inclusive. Notably used to pick a random samples from a folder:@@ -874,19 +874,19 @@ -- grouped together in the rotation? f st es = constrainEvents (arc st) $ shiftValues $ sort $ defragParts es shiftValues es | i >= 0 =- zipWith (\(Event w p _) s -> Event w p s) es+ zipWith (\e s -> e {value = s}) es (drop i $ cycle $ map value es) | otherwise =- zipWith (\(Event w p _) s -> Event w p s) es+ zipWith (\e s -> e{value = s}) es (drop (length es - abs i) $ cycle $ map value es) wholeCycle (Arc s _) = Arc (sam s) (nextSam s) constrainEvents :: Arc -> [Event a] -> [Event a] constrainEvents a es = mapMaybe (constrainEvent a) es constrainEvent :: Arc -> Event a -> Maybe (Event a)- constrainEvent a (Event w p v) =+ constrainEvent a e = do- p' <- subArc p a- return (Event w p' v)+ p' <- subArc (part e) a+ return e {part = p'} -- | @segment n p@: 'samples' the pattern @p@ at a rate of @n@ -- events per cycle. Useful for turning a continuous pattern into a@@ -996,7 +996,7 @@ -- TODO - what does this do? Something for @stripe@ .. randStruct :: Int -> Pattern Int randStruct n = splitQueries $ Pattern {query = f}- where f st = map (\(a,b,c) -> Event (Just a) (fromJust b) c) $ filter (\(_,x,_) -> isJust x) as+ where f st = map (\(a,b,c) -> Event (Context []) (Just a) (fromJust b) c) $ filter (\(_,x,_) -> isJust x) as where as = map (\(i, Arc s' e') -> (Arc (s' + sam s) (e' + sam s), subArc (Arc s e) (Arc (s' + sam s) (e' + sam s)), i)) $@@ -1007,7 +1007,7 @@ -- TODO - what does this do? substruct' :: Pattern Int -> Pattern a -> Pattern a substruct' s p = p {query = \st -> concatMap (f st) (query s st)}- where f st (Event (Just a') _ i) = queryArc (compressArcTo a' (inside (pure $ 1/toRational(length (queryArc s (Arc (sam (start $ arc st)) (nextSam (start $ arc st)))))) (rotR (toRational i)) p)) a'+ where f st (Event c (Just a') _ i) = map (\e -> e {context = combineContexts [c, context e]}) $ queryArc (compressArcTo a' (inside (pure $ 1/toRational(length (queryArc s (Arc (sam (start $ arc st)) (nextSam (start $ arc st)))))) (rotR (toRational i)) p)) a' -- Ignore analog events (ones without wholes) f _ _ = [] @@ -1213,8 +1213,8 @@ loopFirst :: Pattern a -> Pattern a loopFirst p = splitQueries $ p {query = f} where f st = map- (\(Event w p' v) ->- Event (plus <$> w) (plus p') v) $+ (\(Event c w p' v) ->+ Event c (plus <$> w) (plus p') v) $ query p (st {arc = minus $ arc st}) where minus = fmap (subtract (sam s)) plus = fmap (+ sam s)@@ -1299,7 +1299,7 @@ arcs = zipWith Arc fractions (tail fractions) fractions = map (+ (sam $ start a)) [0, 1 / fromIntegral n' .. 1] toEv (a',v) = do a'' <- subArc a a'- return $ Event (Just a') a'' v+ return $ Event (Context []) (Just a') a'' v ur :: Time -> Pattern String -> [(String, Pattern a)] -> [(String, Pattern a -> Pattern a)] -> Pattern a ur t outer_p ps fs = _slow t $ unwrap $ adjust <$> timedValues (getPat . split <$> outer_p)@@ -1314,7 +1314,7 @@ 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 (Just a) a' v) -> Event (Just a) a' (a,v)) . filterDigital+ timedValues = withEvent (\(Event c (Just a) a' v) -> Event c (Just a) a' (a,v)) . filterDigital inhabit :: [(String, Pattern a)] -> Pattern String -> Pattern a inhabit ps p = squeezeJoin $ (\s -> fromMaybe silence $ lookup s ps) <$> p@@ -1331,7 +1331,7 @@ -- | @flatpat@ takes a Pattern of lists and pulls the list elements as -- separate Events flatpat :: Pattern [a] -> Pattern a-flatpat p = p {query = concatMap (\(Event b b' xs) -> map (Event b b') xs) . query p}+flatpat p = p {query = concatMap (\(Event c b b' xs) -> map (Event c b b') xs) . query p} -- | @layer@ takes a Pattern of lists and pulls the list elements as -- separate Events@@ -1352,10 +1352,10 @@ arpWith f p = withEvents munge p where munge es = concatMap (spreadOut . f) (groupBy (\a b -> whole a == whole b) $ sortOn whole es) spreadOut xs = mapMaybe (\(n, x) -> shiftIt n (length xs) x) $ enumerate xs- shiftIt n d (Event (Just (Arc s e)) a' v) =+ shiftIt n d (Event c (Just (Arc s e)) a' v) = do a'' <- subArc (Arc newS newE) a'- return (Event (Just $ Arc newS newE) a'' v)+ return (Event c (Just $ Arc newS newE) a'' v) where newS = s + (dur * fromIntegral n) newE = newS + dur dur = (e - s) / fromIntegral d@@ -1783,7 +1783,8 @@ | otherwise = Just $ value (head (nextEs st')) tween' queryA' v = [ Event- { whole = Just queryA'+ { context = context e,+ whole = Just queryA' , part = queryA' , value = value e + ((v - value e) * pc)} ]@@ -1852,15 +1853,15 @@ squeezeJoinUp :: Pattern (ControlPattern) -> ControlPattern squeezeJoinUp pp = pp {query = q} where q st = concatMap (f st) (query (filterDigital pp) st)- f st (Event (Just w) p v) =- mapMaybe (munge w p) $ query (compressArc (cycleArc w) (v |* P.speed (pure $ fromRational $ 1/(stop w - start w)))) st {arc = p}+ f st (Event c (Just w) p v) =+ mapMaybe (munge c w p) $ query (compressArc (cycleArc w) (v |* P.speed (pure $ fromRational $ 1/(stop w - start w)))) st {arc = p} -- already ignoring analog events, but for completeness.. f _ _ = []- munge oWhole oPart (Event (Just iWhole) iPart v) =+ munge co oWhole oPart (Event ci (Just iWhole) iPart v) = do w' <- subArc oWhole iWhole p' <- subArc oPart iPart- return (Event (Just w') p' v)- munge _ _ _ = Nothing+ return (Event (combineContexts [ci,co]) (Just w') p' v)+ munge _ _ _ _ = Nothing chew :: Int -> Pattern Int -> ControlPattern -> ControlPattern chew n ipat pat = (squeezeJoinUp $ zoompat <$> ipat) |/ P.speed (pure $ fromIntegral n)
src/Sound/Tidal/Utils.hs view
@@ -75,3 +75,24 @@ [] -> [] s':rest -> (s':w) : wordsBy p (drop 1 s'') where (w, s'') = break p rest++-- A hack to add to the source code context for mini-notation, so+-- events know where they are within a whole tidal pattern+deltaMini :: String -> String+deltaMini = outside 0 0+ where outside :: Int -> Int -> String -> String+ outside _ _ [] = []+ outside column line ('"':xs) = ("(deltaContext "+ ++ show column+ ++ " "+ ++ show line+ ++ " \""+ ++ inside (column+1) line xs+ )+ outside _ line ('\n':xs) = '\n':(outside 0 (line+1) xs)+ outside column line (x:xs) = x:(outside (column+1) line xs)+ inside :: Int -> Int -> String -> String+ inside _ _ [] = []+ inside column line ('"':xs) = '"':')':(outside (column+1) line xs)+ inside _ line ('\n':xs) = '\n':(inside 0 (line+1) xs)+ inside column line (x:xs) = x:(inside (column+1) line xs)
src/Sound/Tidal/Version.hs view
@@ -1,4 +1,4 @@ module Sound.Tidal.Version where tidal_version :: String-tidal_version = "1.4.5"+tidal_version = "1.4.6"
test/Sound/Tidal/CoreTest.hs view
@@ -94,36 +94,36 @@ describe "saw" $ do it "goes from 0 up to 1 every cycle" $ do it "0" $- (queryArc saw (Arc 0 0)) `shouldBe` [(Event Nothing (Arc 0 0) 0)]+ (queryArc saw (Arc 0 0)) `shouldBe` [(Event (Context []) Nothing (Arc 0 0) 0 :: Event Double)] it "0.25" $- (queryArc saw (Arc 0.25 0.25)) `shouldBe` [(Event Nothing (Arc 0.25 0.25) 0.25)]+ (queryArc saw (Arc 0.25 0.25)) `shouldBe` [(Event (Context []) Nothing (Arc 0.25 0.25) 0.25 :: Event Double)] it "0.5" $- (queryArc saw (Arc 0.5 0.5)) `shouldBe` [(Event Nothing (Arc 0.5 0.5) 0.5)]+ (queryArc saw (Arc 0.5 0.5)) `shouldBe` [(Event (Context []) Nothing (Arc 0.5 0.5) 0.5 :: Event Double)] it "0.75" $- (queryArc saw (Arc 0.75 0.75)) `shouldBe` [(Event Nothing (Arc 0.75 0.75) 0.75)]+ (queryArc saw (Arc 0.75 0.75)) `shouldBe` [(Event (Context []) Nothing (Arc 0.75 0.75) 0.75 :: Event Double)] it "can be added to" $ do (map value $ queryArc ((+1) <$> saw) (Arc 0.5 0.5)) `shouldBe` [1.5 :: Float] it "works on the left of <*>" $ do (queryArc ((+) <$> saw <*> pure 3) (Arc 0 1))- `shouldBe` [Event Nothing (Arc 0 1) 3.5]+ `shouldBe` [Event (Context []) Nothing (Arc 0 1) 3.5 :: Event Double] it "works on the right of <*>" $ do (queryArc ((fast 4 $ pure (+3)) <*> saw) (Arc 0 1)) `shouldBe` - [Event Nothing (Arc 0 0.25) 3.5,- Event Nothing (Arc 0.25 0.5) 3.5,- Event Nothing (Arc 0.5 0.75) 3.5,- Event Nothing (Arc 0.75 1) 3.5+ [Event (Context []) Nothing (Arc 0 0.25) 3.5 :: Event Double,+ Event (Context []) Nothing (Arc 0.25 0.5) 3.5,+ Event (Context []) Nothing (Arc 0.5 0.75) 3.5,+ Event (Context []) Nothing (Arc 0.75 1) 3.5 ] it "can be reversed" $ do it "works with whole cycles" $ (queryArc (rev saw) (Arc 0 1))- `shouldBe` [(Event Nothing (Arc 0 1) 0.5)]+ `shouldBe` [(Event (Context []) Nothing (Arc 0 1) 0.5 :: Event Double)] it "works with half cycles" $ (queryArc (rev saw) (Arc 0 0.5))- `shouldBe` [(Event Nothing (Arc 0 0.5) 0.75)]+ `shouldBe` [(Event (Context []) Nothing (Arc 0 0.5) 0.75 :: Event Double)] it "works with inset points" $ (queryArc (rev saw) (Arc 0.25 0.25))- `shouldBe` [(Event Nothing (Arc 0.25 0.25) 0.75)]+ `shouldBe` [(Event (Context []) Nothing (Arc 0.25 0.25) 0.75 :: Event Double)] describe "tri" $ do it "goes from 0 up to 1 and back every cycle" $ do
test/Sound/Tidal/ParseTest.hs view
@@ -71,6 +71,30 @@ compareP (Arc 0 2) ("{a b, c d e}" :: Pattern String) (stack [fastcat [pure "a", pure "b"], slow 1.5 $ fastcat [pure "c", pure "d", pure "e"]])+ it "can parse .. with ints" $ do+ compareP (Arc 0 2)+ ("0 .. 8" :: Pattern Int)+ ("0 1 2 3 4 5 6 7 8")+ it "can parse .. with rationals" $ do+ compareP (Arc 0 2)+ ("0 .. 8" :: Pattern Rational)+ ("0 1 2 3 4 5 6 7 8")+ it "can handle repeats (!) and durations (@) with <>" $ do+ compareP (Arc 0 31)+ ("<a!3 b ! c@5>" :: Pattern String)+ (slow 10 "[a a a b b] c")+ it "can handle repeats (!) and durations (@) with <> (with ints)" $ do+ compareP (Arc 0 31)+ ("<1!3 2 ! 3@5>" :: Pattern Int)+ (slow 10 "[1 1 1 2 2] 3")+ it "can handle fractional durations" $ do+ compareP (Arc 0 2)+ ("a@0.5 b@1%6 b@1%6 b@1%6" :: Pattern String)+ ("a b*3")+ it "can handle fractional durations (with rationals)" $ do+ compareP (Arc 0 2)+ ("1%3@0.5 3%4@1%6 3%4@1%6 3%4@1%6" :: Pattern Rational)+ ("1%3 0.75*3") it "can parse a chord" $ do compareP (Arc 0 2) ("'major" :: Pattern Int)
test/Sound/Tidal/PatternTest.hs view
@@ -7,7 +7,6 @@ import Prelude hiding ((*>), (<*)) -import Data.Bifunctor (first, second) import Data.Ratio import Sound.Tidal.Control@@ -28,51 +27,51 @@ {- describe "Event" $ do it "(Bifunctor) first: Apply a function to the Arc elements: whole and part" $ do- let res = Event (Just $ Arc 1 2) (Arc 3 4) 5 :: Event Int+ let res = Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event (Context []) Int f = (+1) property $ first f res ===- Event (Just $ Arc 2 3) (Arc 4 5) 5+ Event (Context []) (Just $ Arc 2 3) (Arc 4 5) 5 it "(Bifunctor) second: Apply a function to the event element" $ do- let res = Event (Just $ Arc 1 2) (Arc 3 4) 5 :: Event Int+ let res = Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event (Context []) Int f = (+1) property $ second f res ===- Event (Just $ Arc 1 2) (Arc 3 4) 6-}+ Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 6-} describe "whole" $ do it "returns the whole Arc in an Event" $ do- property $ (Just $ Arc 1 2) === whole (Event (Just $ Arc 1 2) (Arc 3 4) 5 :: Event Int)+ property $ (Just $ Arc 1 2) === whole (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event Int) describe "part" $ do it "returns the part Arc in an Event" $ do- property $ (Arc 3 4) === part (Event (Just $ Arc 1 2) (Arc 3 4) 5 :: Event Int)+ property $ (Arc 3 4) === part (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event Int) describe "value" $ do it "returns the event value in an Event" $ do- property $ 5 === value (Event (Just $ Arc 1 2) (Arc 3 4) ( 5 :: Int))+ property $ 5 === value (Event (Context []) (Just $ Arc (1 :: Rational) 2) (Arc 3 4) ( 5 :: Int)) describe "wholeStart" $ do it "retrieve the onset of an event: the start of the whole Arc" $ do - property $ 1 === wholeStart (Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ property $ 1 === wholeStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventHasOnset" $ do it "return True when the start values of the two arcs in an event are equal" $ do - let ev = (Event (Just $ Arc 1 2) (Arc 1 3) (4 :: Int)) + let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 1 3) (4 :: Int)) property $ True === eventHasOnset ev it "return False when the start values of the two arcs in an event are not equal" $ do - let ev = (Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) + let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) property $ False === eventHasOnset ev describe "pure" $ do it "fills a whole cycle" $ do- property $ queryArc (pure 0) (Arc 0 1) === [(Event (Just $ Arc 0 1) (Arc 0 1) (0 :: Int))]+ property $ queryArc (pure 0) (Arc 0 1) === [(Event (Context []) (Just $ Arc 0 1) (Arc 0 1) (0 :: Int))] it "returns the part of an pure that you ask for, preserving the whole" $ do- property $ queryArc (pure 0) (Arc 0.25 0.75) === [(Event (Just $ Arc 0 1) (Arc 0.25 0.75) (0 :: Int))]+ property $ queryArc (pure 0) (Arc 0.25 0.75) === [(Event (Context []) (Just $ Arc 0 1) (Arc 0.25 0.75) (0 :: Int))] it "gives correct fragments when you go over cycle boundaries" $ do property $ queryArc (pure 0) (Arc 0.25 1.25) ===- [ (Event (Just $ Arc 0 1) (Arc 0.25 1) (0 :: Int)),- (Event (Just $ Arc 1 2) (Arc 1 1.25) 0)+ [ (Event (Context []) (Just $ Arc 0 1) (Arc 0.25 1) (0 :: Int)),+ (Event (Context []) (Just $ Arc 1 2) (Arc 1 1.25) 0) ] it "works with zero-length queries" $ do it "0" $@@ -86,8 +85,8 @@ it "copes with cross-cycle queries" $ do (queryArc(_fastGap 2 $ fastCat [pure "a", pure "b"]) (Arc 0.5 1.5)) `shouldBe`- [(Event (Just $ Arc (1 % 1) (5 % 4)) (Arc (1 % 1) (5 % 4)) ("a" :: String)),- (Event (Just $ Arc (5 % 4) (3 % 2)) (Arc (5 % 4) (3 % 2)) "b")+ [(Event (Context []) (Just $ Arc (1 % 1) (5 % 4)) (Arc (1 % 1) (5 % 4)) ("a" :: String)),+ (Event (Context []) (Just $ Arc (5 % 4) (3 % 2)) (Arc (5 % 4) (3 % 2)) "b") ] it "does not return events outside of the query" $ do (queryArc(_fastGap 2 $ fastCat [pure "a", pure ("b" :: String)]) (Arc 0.5 0.9))@@ -192,9 +191,9 @@ b = fastCat [pure "c", pure "d", pure "e"] pp = fastCat [pure a, pure b] queryArc (unwrap pp) (Arc 0 1)- `shouldBe` [(Event (Just $ Arc (0 % 1) (1 % 2)) (Arc (0 % 1) (1 % 2)) ("a" :: String)),- (Event (Just $ Arc (1 % 2) (2 % 3)) (Arc (1 % 2) (2 % 3)) "d"),- (Event (Just $ Arc (2 % 3) (1 % 1)) (Arc (2 % 3) (1 % 1)) "e")+ `shouldBe` [(Event (Context []) (Just $ Arc (0 % 1) (1 % 2)) (Arc (0 % 1) (1 % 2)) ("a" :: String)),+ (Event (Context []) (Just $ Arc (1 % 2) (2 % 3)) (Arc (1 % 2) (2 % 3)) "d"),+ (Event (Context []) (Just $ Arc (2 % 3) (1 % 1)) (Arc (2 % 3) (1 % 1)) "e") ] describe "squeezeJoin" $ do@@ -203,11 +202,11 @@ b = fastCat [pure "c", pure "d", pure "e"] pp = fastCat [pure a, pure b] queryArc (squeezeJoin pp) (Arc 0 1)- `shouldBe` [(Event (Just $ Arc (0 % 1) (1 % 4)) (Arc (0 % 1) (1 % 4)) ("a" :: String)),- (Event (Just $ Arc (1 % 4) (1 % 2)) (Arc (1 % 4) (1 % 2)) "b"),- (Event (Just $ Arc (1 % 2) (2 % 3)) (Arc (1 % 2) (2 % 3)) "c"),- (Event (Just $ Arc (2 % 3) (5 % 6)) (Arc (2 % 3) (5 % 6)) "d"),- (Event (Just $ Arc (5 % 6) (1 % 1)) (Arc (5 % 6) (1 % 1)) "e")+ `shouldBe` [(Event (Context []) (Just $ Arc (0 % 1) (1 % 4)) (Arc (0 % 1) (1 % 4)) ("a" :: String)),+ (Event (Context []) (Just $ Arc (1 % 4) (1 % 2)) (Arc (1 % 4) (1 % 2)) "b"),+ (Event (Context []) (Just $ Arc (1 % 2) (2 % 3)) (Arc (1 % 2) (2 % 3)) "c"),+ (Event (Context []) (Just $ Arc (2 % 3) (5 % 6)) (Arc (2 % 3) (5 % 6)) "d"),+ (Event (Context []) (Just $ Arc (5 % 6) (1 % 1)) (Arc (5 % 6) (1 % 1)) "e") ] describe ">>=" $ do@@ -252,38 +251,38 @@ describe "controlI" $ do it "can retrieve values from state" $ (query (pure 3 + cF_ "hello") $ State (Arc 0 1) (Map.singleton "hello" (pure $ VF 0.5)))- `shouldBe` [(Event (Just $ Arc (0 % 1) (1 % 1)) (Arc (0 % 1) (1 % 1)) 3.5)]+ `shouldBe` [(Event (Context []) (Just $ Arc (0 % 1) (1 % 1)) (Arc (0 % 1) (1 % 1)) 3.5)] describe "wholeStart" $ do it "retrieve first element of a tuple, inside first element of a tuple, inside the first of another" $ do - property $ 1 === wholeStart (Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ property $ 1 === wholeStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "wholeStop" $ do it "retrieve the end time from the first Arc in an Event" $ do- property $ 2 === wholeStop (Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ property $ 2 === wholeStop (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventPartStart" $ do it "retrieve the start time of the second Arc in an Event" $ do - property $ 3 === eventPartStart (Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ property $ 3 === eventPartStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventPartStop" $ do it "retrieve the end time of the second Arc in an Event" $ do - property $ 4 === eventPartStop (Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ property $ 4 === eventPartStop (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventPart" $ do it "retrieve the second Arc in an Event" $ do - property $ Arc 3 4 === eventPart (Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ property $ Arc 3 4 === eventPart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventValue" $ do it "retrieve the second value from a tuple" $ do - property $ 5 === eventValue (Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ property $ 5 === eventValue (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventHasOnset" $ do it "return True when the start values of the two arcs in an event are equal" $ do - let ev = (Event (Just $ Arc 1 2) (Arc 1 3) (4 :: Int)) + let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 1 3) (4 :: Int)) property $ True === eventHasOnset ev it "return False when the start values of the two arcs in an event are not equal" $ do - let ev = (Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) + let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) property $ False === eventHasOnset ev describe "sam" $ do@@ -361,16 +360,16 @@ describe "onsetIn" $ do it "If the beginning of an Event is within a given Arc, same rules as 'isIn'" $ do - let res = onsetIn (Arc 2.0 2.8) (Event (Just $ Arc 2.2 2.7) (Arc 3.3 3.8) (5 :: Int))+ let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 2.2 2.7) (Arc 3.3 3.8) (5 :: Int)) property $ True === res it "Beginning of Event is equal to beggining of given Arc" $ do - let res = onsetIn (Arc 2.0 2.8) (Event (Just $ Arc 2.0 2.7) (Arc 3.3 3.8) (5 :: Int))+ let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 2.0 2.7) (Arc 3.3 3.8) (5 :: Int)) property $ True === res it "Beginning of an Event is less than the start of the Arc" $ do - let res = onsetIn (Arc 2.0 2.8) (Event (Just $ Arc 1.2 1.7) (Arc 3.3 3.8) (5 :: Int))+ let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 1.2 1.7) (Arc 3.3 3.8) (5 :: Int)) property $ False === res it "Start of Event is greater than the start of the given Arc" $ do - let res = onsetIn (Arc 2.0 2.8) (Event (Just $ Arc 3.1 3.5) (Arc 4.0 4.6) (5 :: Int))+ let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 3.1 3.5) (Arc 4.0 4.6) (5 :: Int)) property $ False === res describe "subArc" $ do@@ -404,16 +403,16 @@ describe "isAdjacent" $ do it "if the given Events are adjacent parts of the same whole" $ do - let res = isAdjacent (Event (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Just $ Arc 1 2) (Arc 4 3) (5 :: Int))+ let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (5 :: Int)) property $ True === res it "if first Arc of of first Event is not equal to first Arc of second Event" $ do- let res = isAdjacent (Event (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Just $ Arc 7 8) (Arc 4 3) (5 :: Int))+ let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int)) property $ False === res it "if the value of the first Event does not equal the value of the second Event" $ do - let res = isAdjacent (Event (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Just $ Arc 1 2) (Arc 4 3) (6 :: Int))+ let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (6 :: Int)) property $ False === res it "second value of second Arc of first Event not equal to first value of second Arc in second Event..." $ do- let res = isAdjacent (Event (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))+ let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) property $ False === res describe "defragParts" $ do @@ -421,24 +420,24 @@ let res = defragParts ([] :: [Event Int]) property $ [] === res it "if list consists of only one Event return it as is" $ do - let res = defragParts [(Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))]- property $ [Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] === res + let res = defragParts [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))]+ property $ [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] === res it "if list contains adjacent Events return list with Parts combined" $ do - let res = defragParts [(Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)), (Event (Just $ Arc 1 2) (Arc 4 3) (5 :: Int))]- property $ [(Event (Just $ Arc 1 2) (Arc 3 4) 5)] === res+ let res = defragParts [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)), (Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (5 :: Int))]+ property $ [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5)] === res it "if list contains more than one Event none of which are adjacent, return List as is" $ do - let res = defragParts [(Event (Just $ Arc 1 2) (Arc 3 4) 5), (Event (Just $ Arc 7 8) (Arc 4 3) (5 :: Int))]- property $ [Event (Just $ Arc 1 2) (Arc 3 4) 5, Event (Just $ Arc 7 8) (Arc 4 3) (5 :: Int)] === res+ let res = defragParts [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5), (Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int))]+ property $ [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5, Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int)] === res describe "compareDefrag" $ do it "compare list with Events with empty list of Events" $ do- let res = compareDefrag [Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int), Event (Just $ Arc 1 2) (Arc 4 3) (5 :: Int)] []+ let res = compareDefrag [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int), Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (5 :: Int)] [] property $ False === res it "compare lists containing same Events but of different length" $ do - let res = compareDefrag [Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int), Event (Just $ Arc 1 2) (Arc 4 3) 5] [Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)]+ let res = compareDefrag [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int), Event (Context []) (Just $ Arc 1 2) (Arc 4 3) 5] [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] property $ True === res it "compare lists of same length with same Events" $ do - let res = compareDefrag [Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] [Event (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)]+ let res = compareDefrag [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] property $ True === res describe "sect" $ do @@ -453,7 +452,7 @@ describe "withResultArc" $ do it "apply given function to the Arcs" $ do- let p = withResultArc (+5) (fast "1 2" "3 4" :: Pattern Int) + let p = withResultArc (+5) (stripContext $ fast "1 2" "3 4" :: Pattern Int) let res = queryArc p (Arc 0 1) property $ res === fmap toEvent [(((5, 11%2), (5, 11%2)), 3), (((11%2, 23%4), (11%2, 23%4)), 3), (((23%4, 6), (23%4, 6)), 4)] @@ -524,7 +523,7 @@ property $ [] === res it "filter above given threshold" $ do - let fil = filterWhen (>0.5) $ struct "t*4" $ (tri :: Pattern Double) + 1+ let fil = stripContext $ filterWhen (>0.5) $ struct "t*4" $ (tri :: Pattern Double) + 1 let res = queryArc fil (Arc 0.5 1.5) property $ fmap toEvent [(((3%4, 1), (3%4, 1)), 1.25), (((1, 5%4), (1, 5%4)), 1.25), (((5%4, 3%2), (5%4, 3%2)), 1.75)] === res @@ -543,15 +542,15 @@ it "otherwise compress difference between start and end values of Arc" $ do let p = fast "1 2" "3 4" :: Pattern Time- let res = queryArc (compressArc (Arc 0.2 0.8) p) (Arc 0 1)+ let res = queryArc (stripContext $ compressArc (Arc 0.2 0.8) p) (Arc 0 1) let expected = fmap toEvent [(((1%5, 1%2), (1%5, 1%2)), 3%1), (((1%2, 13%20), (1%2, 13%20)), 3%1), (((13%20, 4%5), (13%20, 4%5)), 4%1)] property $ expected === res -- pending "Sound.Tidal.Pattern.eventL" $ do -- it "succeeds if the first event 'whole' is shorter" $ do- -- property $ eventL (Event (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 1.1)) "x")+ -- property $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 1.1)) "x") -- it "fails if the events are the same length" $ do- -- property $ not $ eventL (Event (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 1)) "x")+ -- property $ not $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 1)) "x") -- it "fails if the second event is shorter" $ do- -- property $ not $ eventL (Event (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 0.5)) "x")+ -- property $ not $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 0.5)) "x")
test/Sound/Tidal/UITest.hs view
@@ -81,47 +81,47 @@ describe "rand" $ do it "generates a (pseudo-)random number between zero & one" $ do it "at the start of a cycle" $- (queryArc rand (Arc 0 0)) `shouldBe` [Event Nothing (Arc 0 0) (0.5000844 :: Float)]+ (queryArc rand (Arc 0 0)) `shouldBe` [Event (Context []) Nothing (Arc 0 0) (0.5000844 :: Float)] it "at 1/4 of a cycle" $ (queryArc rand (Arc 0.25 0.25)) `shouldBe` - [Event Nothing (Arc 0.25 0.25) (0.8587171 :: Float)]+ [Event (Context []) Nothing (Arc 0.25 0.25) (0.8587171 :: Float)] it "at 3/4 of a cycle" $ (queryArc rand (Arc 0.75 0.75)) `shouldBe` - [Event Nothing (Arc 0.75 0.75) (0.7277789 :: Float)]+ [Event (Context []) Nothing (Arc 0.75 0.75) (0.7277789 :: Float)] describe "range" $ do describe "scales a pattern to the supplied range" $ do describe "from 3 to 4" $ do it "at the start of a cycle" $ (queryArc (Sound.Tidal.UI.range 3 4 saw) (Arc 0 0)) `shouldBe` - [Event Nothing (Arc 0 0) (3 :: Float)]+ [Event (Context []) Nothing (Arc 0 0) (3 :: Float)] it "at 1/4 of a cycle" $ (queryArc (Sound.Tidal.UI.range 3 4 saw) (Arc 0.25 0.25)) `shouldBe`- [Event Nothing (Arc 0.25 0.25) (3.25 :: Float)]+ [Event (Context []) Nothing (Arc 0.25 0.25) (3.25 :: Float)] it "at 3/4 of a cycle" $ (queryArc (Sound.Tidal.UI.range 3 4 saw) (Arc 0.75 0.75)) `shouldBe` - [Event Nothing (Arc 0.75 0.75) (3.75 :: Float)]+ [Event (Context []) Nothing (Arc 0.75 0.75) (3.75 :: Float)] describe "from -1 to 1" $ do it "at 1/2 of a cycle" $ (queryArc (Sound.Tidal.UI.range (-1) 1 saw) (Arc 0.5 0.5)) `shouldBe`- [Event Nothing (Arc 0.5 0.5) (0 :: Float)]+ [Event (Context []) Nothing (Arc 0.5 0.5) (0 :: Float)] describe "from 4 to 2" $ do it "at the start of a cycle" $ (queryArc (Sound.Tidal.UI.range 4 2 saw) (Arc 0 0)) `shouldBe` - [Event Nothing (Arc 0 0) (4 :: Float)]+ [Event (Context []) Nothing (Arc 0 0) (4 :: Float)] it "at 1/4 of a cycle" $ (queryArc (Sound.Tidal.UI.range 4 2 saw) (Arc 0.25 0.25)) `shouldBe` - [Event Nothing (Arc 0.25 0.25) (3.5 :: Float)]+ [Event (Context []) Nothing (Arc 0.25 0.25) (3.5 :: Float)] it "at 3/4 of a cycle" $ (queryArc (Sound.Tidal.UI.range 4 2 saw) (Arc 0.75 0.75)) `shouldBe` - [Event Nothing (Arc 0.75 0.75) (2.5 :: Float)]+ [Event (Context []) Nothing (Arc 0.75 0.75) (2.5 :: Float)] describe "from 10 to 10" $ do it "at 1/2 of a cycle" $ (queryArc (Sound.Tidal.UI.range 10 10 saw) (Arc 0.5 0.5)) `shouldBe` - [Event Nothing (Arc 0.5 0.5) (10 :: Float)]+ [Event (Context []) Nothing (Arc 0.5 0.5) (10 :: Float)] describe "rot" $ do it "rotates values in a pattern irrespective of structure" $
test/TestUtils.hs view
@@ -15,18 +15,21 @@ -- | Compare the events of two patterns using the given arc compareP :: (Ord a, Show a) => Arc -> Pattern a -> Pattern a -> Property-compareP a p p' = (sort $ query p $ State a Map.empty) `shouldBe` (sort $ query p' $ State a Map.empty)+compareP a p p' = (sort $ query (stripContext p) $ State a Map.empty) `shouldBe` (sort $ query (stripContext p') $ State a Map.empty) -- | Like @compareP@, but tries to 'defragment' the events comparePD :: (Ord a) => Arc -> Pattern a -> Pattern a -> Bool comparePD a p p' = compareDefrag es es'- where es = query p (State a Map.empty)- es' = query p' (State a Map.empty)+ where es = query (stripContext p) (State a Map.empty)+ es' = query (stripContext p') (State a Map.empty) -- | Like @compareP@, but for control patterns, with some tolerance for floating point error compareTol :: Arc -> ControlPattern -> ControlPattern -> Bool-compareTol a p p' = (sort $ queryArc p a) ~== (sort $ queryArc p' a)+compareTol a p p' = (sort $ queryArc (stripContext p) a) ~== (sort $ queryArc (stripContext p') a) -- | Utility to create a pattern from a String ps :: String -> Pattern String ps = parseBP_E++stripContext :: Pattern a -> Pattern a+stripContext = setContext $ Context []
tidal.cabal view
@@ -1,5 +1,5 @@ name: tidal-version: 1.4.5+version: 1.4.6 synopsis: Pattern language for improvised music -- description: homepage: http://tidalcycles.org/
tidal.el view
@@ -40,6 +40,7 @@ (require 'find-lisp) (require 'pulse) (require 'haskell-mode)+(require 'subr-x) (defvar tidal-buffer "*tidal*"@@ -65,13 +66,17 @@ ("separator" . "\\") )) ((or (string-equal system-type "darwin") (string-equal system-type "gnu/linux"))- '(("path" . "ghc-pkg describe $(ghc-pkg latest tidal) | grep data-dir | cut -f2 -d' '")+ '(("path" . "ghc-pkg field -f ~/.cabal/store/ghc-$(ghc --numeric-version)/package.db tidal data-dir") ("separator" . "/") )) ) ))- (concat (substring (shell-command-to-string (cdr (assoc "path" filepath))) 0 -1) (cdr (assoc "separator" filepath)) "BootTidal.hs")- )+ (concat+ (string-trim (cadr (split-string+ (shell-command-to-string (cdr (assoc "path" filepath))) ":")))+ (cdr (assoc "separator" filepath))+ "BootTidal.hs")+ ) "*Full path to BootTidal.hs (inferred by introspecting ghc-pkg package db)." ) @@ -105,7 +110,7 @@ nil tidal-interpreter-arguments) (tidal-see-output))- (tidal-send-string (concat ":script " tidal-boot-script-path))+ (tidal-send-string ":script ~/src/tidal/BootTidal.hs") ) (defun tidal-see-output ()