tidal 1.0.14 → 1.1.0
raw patch · 32 files changed
+650/−1060 lines, 32 filesdep +criteriondep +deepseqdep +weighdep −template-haskelldep ~base
Dependencies added: criterion, deepseq, weigh
Dependencies removed: template-haskell
Dependency ranges changed: base
Files
- BootTidal.hs +52/−45
- CHANGELOG.md +19/−0
- bench/Memory/Main.hs +10/−0
- bench/Memory/Tidal/Inputs.hs +83/−0
- bench/Memory/Tidal/UIB.hs +20/−0
- bench/Speed/Main.hs +22/−0
- bench/Speed/Tidal/CoreB.hs +50/−0
- bench/Speed/Tidal/Inputs.hs +82/−0
- bench/Speed/Tidal/PatternB.hs +45/−0
- bench/Speed/Tidal/UIB.hs +23/−0
- src/Sound/Tidal/Carabiner.hs +1/−0
- src/Sound/Tidal/Config.hs +4/−2
- src/Sound/Tidal/Control.hs +13/−3
- src/Sound/Tidal/Core.hs +10/−3
- src/Sound/Tidal/MiniTidal.hs +0/−652
- src/Sound/Tidal/MiniTidal/TH.hs +0/−18
- src/Sound/Tidal/MiniTidal/Token.hs +0/−122
- src/Sound/Tidal/Params.hs +5/−2
- src/Sound/Tidal/ParseBP.hs +5/−2
- src/Sound/Tidal/Pattern.hs +45/−15
- src/Sound/Tidal/Stream.hs +41/−17
- src/Sound/Tidal/Tempo.hs +7/−2
- src/Sound/Tidal/Transition.hs +2/−2
- src/Sound/Tidal/UI.hs +62/−9
- src/Sound/Tidal/Version.hs +1/−1
- test/Sound/Tidal/ControlTest.hs +2/−2
- test/Sound/Tidal/CoreTest.hs +2/−2
- test/Sound/Tidal/MiniTidalTest.hs +0/−147
- test/Sound/Tidal/PatternTest.hs +4/−2
- test/Sound/Tidal/UITest.hs +7/−4
- test/Test.hs +0/−2
- tidal.cabal +33/−6
BootTidal.hs view
@@ -7,51 +7,58 @@ -- total latency = oLatency + cFrameTimespan tidal <- startTidal (superdirtTarget {oLatency = 0.1, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig {cFrameTimespan = 1/20}) +:{ let p = streamReplace tidal-let hush = streamHush tidal-let list = streamList tidal-let mute = streamMute tidal-let unmute = streamUnmute tidal-let solo = streamSolo tidal-let unsolo = streamUnsolo tidal-let once = streamOnce tidal-let asap = once-let nudgeAll = streamNudgeAll tidal-let all = streamAll tidal-let resetCycles = streamResetCycles tidal-let setcps = asap . cps-let xfade i = transition tidal True (Sound.Tidal.Transition.xfadeIn 4) i-let xfadeIn i t = transition tidal True (Sound.Tidal.Transition.xfadeIn t) i-let histpan i t = transition tidal True (Sound.Tidal.Transition.histpan t) i-let wait i t = transition tidal True (Sound.Tidal.Transition.wait t) i-let waitT i f t = transition tidal True (Sound.Tidal.Transition.waitT f t) i-let jump i = transition tidal True (Sound.Tidal.Transition.jump) i-let jumpIn i t = transition tidal True (Sound.Tidal.Transition.jumpIn t) i-let jumpIn' i t = transition tidal True (Sound.Tidal.Transition.jumpIn' t) i-let jumpMod i t = transition tidal True (Sound.Tidal.Transition.jumpMod t) i-let mortal i lifespan release = transition tidal True (Sound.Tidal.Transition.mortal lifespan release) i-let interpolate i = transition tidal True (Sound.Tidal.Transition.interpolate) i-let interpolateIn i t = transition tidal True (Sound.Tidal.Transition.interpolateIn t) i-let clutch i = transition tidal True (Sound.Tidal.Transition.clutch) i-let clutchIn i t = transition tidal True (Sound.Tidal.Transition.clutchIn t) i-let anticipate i = transition tidal True (Sound.Tidal.Transition.anticipate) i-let anticipateIn i t = transition tidal True (Sound.Tidal.Transition.anticipateIn t) i-let forId i t = transition tidal False (Sound.Tidal.Transition.mortalOverlay t) i-let d1 = p 1-let d2 = p 2-let d3 = p 3-let d4 = p 4-let d5 = p 5-let d6 = p 6-let d7 = p 7-let d8 = p 8-let d9 = p 9-let d10 = p 10-let d11 = p 11-let d12 = p 12-let d13 = p 13-let d14 = p 14-let d15 = p 15-let d16 = p 16+ hush = streamHush tidal+ list = streamList tidal+ mute = streamMute tidal+ unmute = streamUnmute tidal+ solo = streamSolo tidal+ unsolo = streamUnsolo tidal+ once = streamOnce tidal+ asap = once+ nudgeAll = streamNudgeAll tidal+ all = streamAll tidal+ resetCycles = streamResetCycles tidal+ setcps = asap . cps+ xfade i = transition tidal True (Sound.Tidal.Transition.xfadeIn 4) i+ xfadeIn i t = transition tidal True (Sound.Tidal.Transition.xfadeIn t) i+ histpan i t = transition tidal True (Sound.Tidal.Transition.histpan t) i+ wait i t = transition tidal True (Sound.Tidal.Transition.wait t) i+ waitT i f t = transition tidal True (Sound.Tidal.Transition.waitT f t) i+ jump i = transition tidal True (Sound.Tidal.Transition.jump) i+ jumpIn i t = transition tidal True (Sound.Tidal.Transition.jumpIn t) i+ jumpIn' i t = transition tidal True (Sound.Tidal.Transition.jumpIn' t) i+ jumpMod i t = transition tidal True (Sound.Tidal.Transition.jumpMod t) i+ mortal i lifespan release = transition tidal True (Sound.Tidal.Transition.mortal lifespan release) i+ interpolate i = transition tidal True (Sound.Tidal.Transition.interpolate) i+ interpolateIn i t = transition tidal True (Sound.Tidal.Transition.interpolateIn t) i+ clutch i = transition tidal True (Sound.Tidal.Transition.clutch) i+ clutchIn i t = transition tidal True (Sound.Tidal.Transition.clutchIn t) i+ anticipate i = transition tidal True (Sound.Tidal.Transition.anticipate) i+ anticipateIn i t = transition tidal True (Sound.Tidal.Transition.anticipateIn t) i+ forId i t = transition tidal False (Sound.Tidal.Transition.mortalOverlay t) i+ setI = streamSetI tidal+ setF = streamSetF tidal+ setS = streamSetS tidal+ setR = streamSetI tidal+ setB = streamSetB tidal+ d1 = p 1 . (|< orbit 0) + d2 = p 2 . (|< orbit 1) + d3 = p 3 . (|< orbit 2) + d4 = p 4 . (|< orbit 3) + d5 = p 5 . (|< orbit 4) + d6 = p 6 . (|< orbit 5) + d7 = p 7 . (|< orbit 6) + d8 = p 8 . (|< orbit 7) + d9 = p 9 . (|< orbit 8)+ d10 = p 10 . (|< orbit 9)+ d11 = p 11 . (|< orbit 10)+ d12 = p 12 . (|< orbit 11)+ d13 = p 13+ d14 = p 14+ d15 = p 15+ d16 = p 16+:} :set prompt "tidal> "
CHANGELOG.md view
@@ -1,5 +1,24 @@ # TidalCycles log of changes +## 1.1.0 - Brincliffe Edge++* `binary` and `ascii` functions for playing with bit patterns @yaxu+* support chord inversions in chord parser @bgold-cosmos+* skip ticks when system clock jumps @yaxu+* fix crash bugs in mini notation parser and grp @yaxu+* new stitch function @yaxu+* |++, ++| and |++| for combining patterns of strings by concatenation @yaxu+* send best effort of a sound id to dirt / superdirt if sendParts is on, allowing parameter adjustment of previously triggered sound (without chopping) @yaxu+* qtrigger - quantise trigger to nearest cycle @yaxu+* add setI, setF et al to BootTidal.hs for setting state variables @yaxu+* BootTidal.hs now sends d1 .. d12 to orbits 0 .. 11 respectively @yaxu+* markov chain support with runMarkov and markovPat @bgold-cosmos+* simplify / fix mask and sew @yaxu+* Adjust <* and *> (and therefore |+, +| etc) to be closer to <*>, explanation here: https://penelope.hypotheses.org/1722 @yaxu+* extract minitidal into its own package tidal-parse (using cabal multipackages), renaming to Sound.Tidal.Parse @yaxu @dktr0+* benchmarking @nini-faroux+* minitidal refactor, support for parsing more of tidal, tests @dktr0+ ## 1.0.14 - IICON * 'chew' - like bite, but speeds playback rate up and down
+ bench/Memory/Main.hs view
@@ -0,0 +1,10 @@+module Main where ++import Weigh +import Tidal.UIB++main :: IO () +main = + mainWith $ do + euclidB+ fixB
+ bench/Memory/Tidal/Inputs.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}++module Tidal.Inputs where ++import Sound.Tidal.Pattern+import Sound.Tidal.Core+import Sound.Tidal.ParseBP+import Sound.Tidal.Core+import Sound.Tidal.Params+import Sound.Tidal.Control+import Sound.Tidal.UI+import Weigh ++columns :: Weigh () +columns = setColumns [Case, Allocated, Max, Live, GCs] ++{- Pattern inputs -} +xs3 = [1..10^3]+xs4 = [1..10^4]+xs5 = [1..10^5]+xs6 = [1..10^6]++xsA = [500000..1500000]++catPattSmall :: [Pattern Time]+catPattSmall = pure <$> xs3++catPattMed :: [Pattern Time]+catPattMed = pure <$> xs4 ++catPattMedB :: [Pattern Time]+catPattMedB = pure <$> xs5++catPattBig :: [Pattern Time]+catPattBig = pure <$> xs6 ++timeCatMed :: [(Time, Pattern Time)]+timeCatMed = zip xs5 catPattMed++timeCatBig :: [(Time, Pattern Time)]+timeCatBig = zip xs6 catPattBig++appendBig :: [Pattern Time]+appendBig = pure <$> xsA ++pattApp1 :: Pattern [Time]+pattApp1 = sequence catPattBig ++pattApp2 :: Pattern [Time]+pattApp2 = sequence appendBig++{- Arc Inputs -}+arcFunc :: Arc -> Arc +arcFunc (Arc s e) = Arc (s * 2) (e * 4) ++wqaMed = fromList xs5 +wqaBig = fromList xs6++{- fix inputs -} +fixArg1 :: ControlPattern +fixArg1 = pF "cc64" 1++fixArg2 :: ControlPattern+fixArg2 =+ fix ( # crush 4 ) (pF "cc65" 1)+ $ fix ( stut' 4 (0.125/4) ( + up "1" )) (pF "cc66" 1)+ $ fix ( |*| speed "-1" ) (pF "cc67" 1)+ $ fix ( (# delaytime 0.125).(# delay 0.5)) (pF "cc68" 1)+ $ fix ( # coarse 12) (pF "cc69" 1)+ $ s "[808bd:1(3,8), dr(7,8)]"+ # pF "cc64" (cF 0 "64")+ # pF "cc65" (cF 0 "65")+ # pF "cc66" (cF 0 "66")+ # pF "cc67" (cF 0 "67")+ # pF "cc68" (cF 0 "68")+ # pF "cc69" (cF 0 "69")++{- Euclid inputs -}+ecA1 :: [Pattern Int] +ecA1 = [1, 10^5]++ecA2 :: Pattern String +ecA2 = "x"
+ bench/Memory/Tidal/UIB.hs view
@@ -0,0 +1,20 @@+module Tidal.UIB where ++import Weigh +import Tidal.Inputs +import Sound.Tidal.UI+import Sound.Tidal.Core++fixB :: Weigh () +fixB = + wgroup "fix weigh" $ do+ columns+ func "fix 1" (fix (fast 2) fixArg1) fixArg2++euclidB :: Weigh () +euclidB = + wgroup "euclid" $ do + columns + func "euclid" (euclid (head ecA1) (head $ drop 1 ecA1)) ecA2+ func "euclidFull" (euclidFull (head ecA1) (head $ drop 1 ecA1) ecA2) ecA2+ func "euclidBool" (_euclidBool 1) 100000
+ bench/Speed/Main.hs view
@@ -0,0 +1,22 @@+module Main where++import Criterion.Main +import Tidal.PatternB+import Tidal.CoreB+import Tidal.UIB++patternBs :: [IO ()] +patternBs = defaultMain <$> [withQueryTimeB, withQueryArcB, withResultArcB, withQueryTimeB, subArcB]++coreBs :: [IO ()] +coreBs = defaultMain <$> [fromListB, stackB, appendB, concatB, _fastB]++uiBs :: [IO ()]+uiBs = defaultMain <$> [euclidB, fixB]++main :: IO ()+main = do + _ <- sequence coreBs + _ <- sequence patternBs+ _ <- sequence uiBs+ return ()
+ bench/Speed/Tidal/CoreB.hs view
@@ -0,0 +1,50 @@+module Tidal.CoreB where ++import Criterion.Main +import Tidal.Inputs+import Sound.Tidal.Pattern+import Sound.Tidal.Core ++_fastB :: [Benchmark]+_fastB = + [ bgroup "_fast" [+ bench "_fast < 0" $ whnf (_fast (-2)) pattApp2 + , bench "_fast > 0" $ whnf (_fast (toTime $ 10^6)) (cat catPattBig) ]+ ]++concatB :: [Benchmark] +concatB = + [ bgroup "concat" [+ bench "fastCat 10^3" $ whnf fastCat catPattSmall + , bench "fastCat 10^4" $ whnf fastCat catPattMed+ , bench "fastCat 10^5" $ whnf fastCat catPattMedB + , bench "fastCat 10^6" $ whnf fastCat catPattBig+ , bench "timeCat 10^5" $ whnf timeCat timeCatMed+ , bench "timeCat 10^6" $ whnf timeCat timeCatBig ]+ ]++fromListB :: [Benchmark]+fromListB = + [ bgroup "fromList" [+ bench "fromList" $ whnf fromList xs6 + , bench "fromList nf" $ nf fromList xs6+ , bench "fastFromList 10^3" $ whnf fastFromList xs3 + , bench "fastFromList 10^4" $ whnf fastFromList xs4 + , bench "fastFromList 10^5" $ whnf fastFromList xs5 + , bench "fastFromList 10^6" $ whnf fastFromList xs6+ , bench "fastFromList 10^6 nf" $ nf fastFromList xs6 ]+ ]++appendB :: [Benchmark] +appendB = + [ bgroup "append" [+ bench "append" $ whnf (append pattApp1) pattApp2+ , bench "fastAppend" $ whnf (fastAppend pattApp1) pattApp2 ] + ]++stackB :: [Benchmark] +stackB = + [ bgroup "stack" [+ bench "overlay" $ whnf (overlay pattApp1) pattApp2 + , bench "stack" $ whnf stack catPattBig ]+ ]
+ bench/Speed/Tidal/Inputs.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}++module Tidal.Inputs where ++import Sound.Tidal.Pattern+import Sound.Tidal.Core+import Sound.Tidal.ParseBP+import Sound.Tidal.Core+import Sound.Tidal.Params+import Sound.Tidal.Control+import Sound.Tidal.UI++{- Pattern inputs -} +xs3 = [1..10^3]+xs4 = [1..10^4]+xs5 = [1..10^5]+xs6 = [1..10^6]++xsA = [500000..1500000]++catPattSmall :: [Pattern Time]+catPattSmall = pure <$> xs3++catPattMed :: [Pattern Time]+catPattMed = pure <$> xs4 ++catPattMedB :: [Pattern Time]+catPattMedB = pure <$> xs5++catPattBig :: [Pattern Time]+catPattBig = pure <$> xs6 ++timeCatMed :: [(Time, Pattern Time)]+timeCatMed = zip xs5 catPattMed++timeCatBig :: [(Time, Pattern Time)]+timeCatBig = zip xs6 catPattBig++appendBig :: [Pattern Time]+appendBig = pure <$> xsA ++pattApp1 :: Pattern [Time]+pattApp1 = sequence catPattBig ++pattApp2 :: Pattern [Time]+pattApp2 = sequence appendBig++{- Arc Inputs -}+arcFunc :: Arc -> Arc +arcFunc (Arc s e) = Arc (s * 2) (e * 4) ++wqaMed :: Pattern Time+wqaMed = fromList xs5 ++wqaBig :: Pattern Time+wqaBig = fromList xs6++{- fix inputs -} +fixArg1 :: ControlPattern +fixArg1 = pF "cc64" 1++fixArg2 :: ControlPattern+fixArg2 =+ fix ( # crush 4 ) (pF "cc65" 1)+ $ fix ( stut' 4 (0.125/4) ( + up "1" )) (pF "cc66" 1)+ $ fix ( |*| speed "-1" ) (pF "cc67" 1)+ $ fix ( (# delaytime 0.125).(# delay 0.5)) (pF "cc68" 1)+ $ fix ( # coarse 12) (pF "cc69" 1)+ $ s "[808bd:1(3,8), dr(7,8)]"+ # pF "cc64" (cF 0 "64")+ # pF "cc65" (cF 0 "65")+ # pF "cc66" (cF 0 "66")+ # pF "cc67" (cF 0 "67")+ # pF "cc68" (cF 0 "68")+ # pF "cc69" (cF 0 "69")++{- Euclid inputs -}+ecA1 :: [Pattern Int] +ecA1 = [1, 100]++ecA2 :: Pattern String +ecA2 = "x"
+ bench/Speed/Tidal/PatternB.hs view
@@ -0,0 +1,45 @@+module Tidal.PatternB where ++import Criterion.Main+import Tidal.Inputs+import Sound.Tidal.Pattern++arc1 = Arc 3 5 +arc2 = Arc 4 6+arc3 = Arc 0 1+arc4 = Arc 1 2++withQueryTimeB :: [Benchmark] +withQueryTimeB = + [ bgroup "withQueryTime" [+ bench "wqt whnf" $ whnf withQueryTime (*2) + , bench "wqt2 whnf" $ whnf withQueryTime (+1)+ , bench "wqt nf" $ nf withQueryTime (*2) ]+ ]++withResultArcB :: [Benchmark]+withResultArcB = + [ bgroup "withResultArc" [+ bench "wqa med" $ whnf (withResultArc arcFunc) wqaMed+ , bench "wqa big" $ whnf (withResultArc arcFunc) wqaBig ]+ ]++withQueryArcB :: [Benchmark]+withQueryArcB = + [ bgroup "withQueryArc" [+ bench "wqa med" $ whnf (withQueryArc arcFunc) wqaMed+ , bench "wqa big" $ whnf (withQueryArc arcFunc) wqaBig ]+ ]++subArcB :: [Benchmark]+subArcB = + [ bgroup "subArc" [ + bench "intersecting" $ whnf (subArc arc1) arc2+ , bench "non-intersecting" $ whnf (subArc arc3) arc4 ]+ ]++sectB :: Benchmark +sectB = bench "sect" $ whnf (sect arc1) arc2++hullB :: Benchmark +hullB = bench "hull" $ whnf (hull arc1) arc2
+ bench/Speed/Tidal/UIB.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++module Tidal.UIB where ++import Criterion.Main+import Tidal.Inputs+import Sound.Tidal.Core+import Sound.Tidal.UI ++fixB :: [Benchmark]+fixB = + [ bgroup "fix" [+ bench "fix whnf" $ whnf (fix (fast 2) fixArg1) fixArg2+ , bench "fix nf" $ nf (fix (fast 2) fixArg1) fixArg2 ]+ ]++euclidB :: [Benchmark] +euclidB = + [ bgroup "euclid" [+ bench "euclid" $ whnf (euclid (head ecA1) (head $ drop 1 ecA1)) ecA2 + , bench "euclidFull" $ whnf (euclidFull (head ecA1) (head $ drop 1 ecA1) ecA2) ecA2+ , bench "euclidBool" $ whnf (_euclidBool 1) 100000]+ ]
src/Sound/Tidal/Carabiner.hs view
@@ -12,6 +12,7 @@ import Data.Maybe (isJust, fromJust) import qualified Sound.OSC.FD as O +port :: Int port = 17000 carabiner :: S.Stream -> Int -> Double -> IO Socket
src/Sound/Tidal/Config.hs view
@@ -7,7 +7,8 @@ cFrameTimespan :: Double, cTempoAddr :: String, cTempoPort :: Int,- cTempoClientPort :: Int+ cTempoClientPort :: Int,+ cSendParts :: Bool } defaultConfig :: Config@@ -17,5 +18,6 @@ cFrameTimespan = 1/20, cTempoAddr = "127.0.0.1", cTempoPort = 9160,- cTempoClientPort = 0 -- choose at random+ cTempoClientPort = 0, -- choose at random+ cSendParts = False }
src/Sound/Tidal/Control.hs view
@@ -367,13 +367,23 @@ msec :: Fractional a => Pattern a -> Pattern a msec p = ((realToFrac . (/1000)) <$> cF 1 "_cps") *| p -trigger :: Show a => a -> Pattern b -> Pattern b-trigger k pat = pat {query = q}+_trigger :: Show a => Bool -> a -> Pattern b -> Pattern b+_trigger quantise k pat = pat {query = q} where q st = query ((offset st) ~> pat) st+ f | quantise = fromIntegral . round+ | otherwise = id offset st = fromMaybe (pure 0) $ do pat <- Map.lookup ctrl (controls st)- return $ ((fromMaybe 0 . getR) <$> pat)+ return $ ((f . fromMaybe 0 . getR) <$> pat) ctrl = "_t_" ++ show k +trigger :: Show a => a -> Pattern b -> Pattern b+trigger = _trigger False++qtrigger :: Show a => a -> Pattern b -> Pattern b+qtrigger = _trigger True++qt :: Show a => a -> Pattern b -> Pattern b+qt = qtrigger _getP_ :: (Value -> Maybe a) -> Pattern Value -> Pattern a _getP_ f pat = filterJust $ f <$> pat
src/Sound/Tidal/Core.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns #-} module Sound.Tidal.Core where @@ -89,6 +89,13 @@ ( +|) :: Num a => Pattern a -> Pattern a -> Pattern a a +| b = (+) <$> a *> b +(|++|) :: Applicative a => a String -> a String -> a String+a |++| b = (++) <$> a <*> b+(|++ ) :: Pattern String -> Pattern String -> Pattern String+a |++ b = (++) <$> a <* b+( ++|) :: Pattern String -> Pattern String -> Pattern String+a ++| b = (++) <$> a *> b+ (|/|) :: (Applicative a, Fractional b) => a b -> a b -> a b a |/| b = (/) <$> a <*> b (|/ ) :: Fractional a => Pattern a -> Pattern a -> Pattern a@@ -228,9 +235,9 @@ -- their events are combined over time. overlay :: Pattern a -> Pattern a -> Pattern a -- Analog if they're both analog-overlay p@(Pattern Analog _) p'@(Pattern Analog _) = Pattern Analog $ \st -> query p st ++ query p' st+overlay !p@(Pattern Analog _) !p'@(Pattern Analog _) = Pattern Analog $ \st -> query p st ++ query p' st -- Otherwise digital. Won't really work to have a mixture.. Hmm-overlay p p' = Pattern Digital $ \st -> query p st ++ query p' st+overlay !p !p' = Pattern Digital $ \st -> query p st ++ query p' st -- | An infix alias of @overlay@ (<>) :: Pattern a -> Pattern a -> Pattern a
− src/Sound/Tidal/MiniTidal.hs
@@ -1,652 +0,0 @@-{-# LANGUAGE FlexibleInstances, TemplateHaskell #-}--module Sound.Tidal.MiniTidal (miniTidal,miniTidalIO,main) where--import Text.Parsec.Prim (parserZero)-import Text.ParserCombinators.Parsec-import Control.Monad (forever)-import Control.Applicative (liftA2)--- import Language.Haskell.TH--import Sound.Tidal.Context (Pattern,ControlMap,ControlPattern,Enumerable,Parseable,Time,Arc,TPat,Stream)-import qualified Sound.Tidal.Context as T-import Sound.Tidal.MiniTidal.Token-import Sound.Tidal.MiniTidal.TH----- This is depended upon by Estuary, and changes to its type will cause problems downstream for Estuary.-miniTidal :: String -> Either ParseError (Pattern ControlMap)-miniTidal = parse miniTidalParser "miniTidal"--miniTidalParser :: Parser ControlPattern-miniTidalParser = whiteSpace >> choice [- eof >> return T.silence,- do- x <- pattern- eof- return x- ]--class MiniTidal a where- literal :: Parser a -- parse an individual pure value of this type- simplePattern :: Parser (Pattern a) -- any way of making this pattern that wouldn't require parentheses if it was an argument- complexPattern :: Parser (Pattern a) -- producing this pattern by way of unary functions with an argument of a different type- transformationWithArguments:: Parser (Pattern a -> Pattern a) -- producing this pattern by with unary functions that take same type- transformationWithoutArguments :: Parser (Pattern a -> Pattern a) -- also producing this pattern by unary functions of same type- mergeOperator :: Parser (Pattern a -> Pattern a -> Pattern a) -- operators for combining this type of pattern, eg. # or |>- binaryFunctions :: Parser (a -> a -> a) -- binary functions on pure values of this type, eg. (+) for Int or other Num instances--literalArg :: MiniTidal a => Parser a-literalArg = choice [- literal,- nestedParens literal,- try $ applied $ parensOrNot literal- ]--listLiteralArg :: MiniTidal a => Parser [a]-listLiteralArg = brackets (commaSep $ parensOrNot literal)--pattern :: MiniTidal a => Parser (Pattern a)-pattern = chainl1 pattern' mergeOperator--pattern' :: MiniTidal a => Parser (Pattern a)-pattern' = choice [- nestedParens $ chainl1 pattern mergeOperator,- transformation <*> patternArg,- genericComplexPattern,- complexPattern,- simplePattern,- silence- ]--patternArg :: MiniTidal a => Parser (Pattern a)-patternArg = choice [- try $ parensOrApplied $ chainl1 pattern mergeOperator,- try $ parensOrApplied $ transformation <*> patternArg,- try $ parensOrApplied genericComplexPattern,- try $ parensOrApplied complexPattern,- try $ appliedOrNot simplePattern,- appliedOrNot silence- ]--transformation :: MiniTidal a => Parser (Pattern a -> Pattern a)-transformation = transformationWithArguments <|> transformationWithoutArguments--transformationArg :: MiniTidal a => Parser (Pattern a -> Pattern a)-transformationArg = choice [- try $ appliedOrNot $ transformationWithoutArguments,- parensOrApplied $ transformationWithArguments- ]--listPatternArg :: MiniTidal a => Parser [Pattern a]-listPatternArg = try $ parensOrNot $ brackets (commaSep pattern)--listTransformationArg :: MiniTidal a => Parser [Pattern a -> Pattern a]-listTransformationArg = try $ parensOrNot $ brackets (commaSep transformation)--silence :: Parser (Pattern a)-silence = $(function "silence")--instance MiniTidal ControlMap where- literal = parserZero- simplePattern = parserZero- transformationWithArguments = p_p <|> pControl_pControl- transformationWithoutArguments = p_p_noArgs- complexPattern = specificControlPatterns- mergeOperator = controlPatternMergeOperator- binaryFunctions = parserZero--controlPatternMergeOperator :: Parser (ControlPattern -> ControlPattern -> ControlPattern)-controlPatternMergeOperator = choice [- $(op "#"),- $(op "|>"),- $(op "<|"),- $(op "|>"),- $(op "|<|"),- $(op "|+|"),- $(op "|-|"),- $(op "|*|"),- $(op "|/|")- ]--specificControlPatterns :: Parser ControlPattern-specificControlPatterns = choice [- try $ parens specificControlPatterns,- $(function "coarse") <*> patternArg,- $(function "cut") <*> patternArg,- $(function "n") <*> patternArg,- $(function "up") <*> patternArg,- $(function "speed") <*> patternArg,- $(function "pan") <*> patternArg,- $(function "shape") <*> patternArg,- $(function "gain") <*> patternArg,- $(function "accelerate") <*> patternArg,- $(function "bandf") <*> patternArg,- $(function "bandq") <*> patternArg,- $(function "begin") <*> patternArg,- $(function "crush") <*> patternArg,- $(function "cutoff") <*> patternArg,- $(function "delayfeedback") <*> patternArg,- $(function "delaytime") <*> patternArg,- $(function "delay") <*> patternArg,- $(function "end") <*> patternArg,- $(function "hcutoff") <*> patternArg,- $(function "hresonance") <*> patternArg,- $(function "resonance") <*> patternArg,- $(function "shape") <*> patternArg,- $(function "loop") <*> patternArg,- $(function "s") <*> patternArg,- $(function "sound") <*> patternArg,- $(function "vowel") <*> patternArg,- $(function "unit") <*> patternArg,- $(function "note") <*> patternArg- ]--genericComplexPattern :: MiniTidal a => Parser (Pattern a)-genericComplexPattern = choice [- try $ parens genericComplexPattern,- lp_p <*> listPatternArg,- l_p <*> listLiteralArg,- pInt_p <*> patternArg- ]--p_p_noArgs :: Parser (Pattern a -> Pattern a)-p_p_noArgs = choice [- $(function "brak"),- $(function "rev"),- $(function "palindrome"),- $(function "stretch"),- $(function "loopFirst"),- $(function "degrade")- ]--p_p :: (MiniTidal a, MiniTidal a) => Parser (Pattern a -> Pattern a)-p_p = choice [- try $ parens p_p,- p_p_p <*> patternArg,- t_p_p <*> transformationArg,- lp_p_p <*> listPatternArg,- lt_p_p <*> listTransformationArg,- lpInt_p_p <*> listPatternArg,- pTime_p_p <*> patternArg,- pInt_p_p <*> patternArg,- pString_p_p <*> patternArg,- pDouble_p_p <*> patternArg,- vTime_p_p <*> literalArg,- vInt_p_p <*> literalArg,- vTimeTime_p_p <*> literalArg,- pDouble_p_p <*> patternArg,- lTime_p_p <*> listLiteralArg- ]--lt_p_p :: MiniTidal a => Parser ([t -> Pattern a] -> t -> Pattern a)-lt_p_p = choice [- try $ parens lt_p_p,- spreads <*> (nestedParens $ reservedOp "$" >> return ($))- ]--l_p :: MiniTidal a => Parser ([a] -> Pattern a)-l_p = choice [- $(function "listToPat"),- $(function "choose"),- $(function "cycleChoose")- ]--lp_p :: MiniTidal a => Parser ([Pattern a] -> Pattern a)-lp_p = choice [- $(function "stack"),- $(function "fastcat"),- $(function "slowcat"),- $(function "cat"),- $(function "randcat")- ]--pInt_p :: MiniTidal a => Parser (Pattern Int -> Pattern a)-pInt_p = choice [- try $ parens pInt_p,- l_pInt_p <*> listLiteralArg- ]--p_p_p :: MiniTidal a => Parser (Pattern a -> Pattern a -> Pattern a)-p_p_p = choice [- try $ parens p_p_p,- liftA2 <$> binaryFunctions,- $(function "overlay"),- $(function "append"),- vTime_p_p_p <*> literalArg,- pInt_p_p_p <*> patternArg- ]--pTime_p_p :: MiniTidal a => Parser (Pattern Time -> Pattern a -> Pattern a)-pTime_p_p = choice [- try $ parens pTime_p_p,- $(function "fast"),- $(function "fastGap"),- $(function "density"),- $(function "slow"),- $(function "trunc"),- $(function "fastGap"),- $(function "densityGap"),- $(function "sparsity"),- $(function "trunc"),- $(function "linger"),- $(function "segment"),- $(function "discretise"),- $(function "timeLoop"),- $(function "swing"),- pTime_pTime_p_p <*> patternArg- ]--lTime_p_p :: MiniTidal a => Parser ([Time] -> Pattern a -> Pattern a)-lTime_p_p = choice [- try $ parens lTime_p_p,- $(function "spaceOut"),- spreads <*> parens vTime_p_p -- re: spread- ]--spreads :: MiniTidal a => Parser ((b -> t -> Pattern a) -> [b] -> t -> Pattern a)-spreads = choice [- $(function "spread"),- $(function "slowspread"),- $(function "fastspread")- ]--pInt_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern a -> Pattern a)-pInt_p_p = choice [- try $ parens pInt_p_p,- $(function "iter"),- $(function "iter'"),- $(function "ply"),- $(function "substruct'"),- $(function "slowstripe"),- $(function "shuffle"),- $(function "scramble"),- pInt_pInt_p_p <*> patternArg- ]--pString_p_p :: MiniTidal a => Parser (Pattern String -> Pattern a -> Pattern a)-pString_p_p = $(function "substruct")--pDouble_p_p :: MiniTidal a => Parser (Pattern Double -> Pattern a -> Pattern a)-pDouble_p_p = choice [- try $ parens pDouble_p_p,- $(function "degradeBy"),- $(function "unDegradeBy"),- vInt_pDouble_p_p <*> literalArg- ]--vTime_p_p :: MiniTidal a => Parser (Time -> Pattern a -> Pattern a)-vTime_p_p = choice [- try $ parens vTime_p_p,- $(function "rotL"),- $(function "rotR"),- vTime_vTime_p_p <*> literalArg- ]--vInt_p_p :: MiniTidal a => Parser (Int -> Pattern a -> Pattern a)-vInt_p_p = $(function "repeatCycles")--vTimeTime_p_p :: MiniTidal a => Parser ((Time,Time) -> Pattern a -> Pattern a)-vTimeTime_p_p = choice [- $(function "compress"),- $(function "zoom"),- $(function "compressTo")- ]--t_p_p :: MiniTidal a => Parser ((Pattern a -> Pattern a) -> Pattern a -> Pattern a)-t_p_p = choice [- try $ parens t_p_p,- $(function "sometimes"),- $(function "often"),- $(function "rarely"),- $(function "almostNever"),- $(function "almostAlways"),- $(function "never"),- $(function "always"),- $(function "superimpose"),- $(function "someCycles"),- pInt_t_p_p <*> patternArg,- pDouble_t_p_p <*> patternArg,- lvInt_t_p_p <*> listLiteralArg,- vInt_t_p_p <*> literalArg,- vDouble_t_p_p <*> literalArg,- vTimeTime_t_p_p <*> literalArg- ]--lpInt_p_p :: MiniTidal a => Parser ([Pattern Int] -> Pattern a -> Pattern a)-lpInt_p_p = $(function "distrib")--lp_p_p :: MiniTidal a => Parser ([Pattern a] -> Pattern a -> Pattern a)-lp_p_p = choice [- try $ parens lp_p_p,- try $ spreads <*> parens p_p_p- ]--l_pInt_p :: MiniTidal a => Parser ([a] -> Pattern Int -> Pattern a)-l_pInt_p = choice [- try $ parens l_pInt_p,- vInt_l_pInt_p <*> literalArg- ]--vInt_l_pInt_p :: MiniTidal a => Parser (Int -> [a] -> Pattern Int -> Pattern a)-vInt_l_pInt_p = $(function "fit")--vTime_p_p_p :: MiniTidal a => Parser (Time -> Pattern a -> Pattern a -> Pattern a)-vTime_p_p_p = $(function "wedge")--vInt_pDouble_p_p :: MiniTidal a => Parser (Int -> Pattern Double -> Pattern a -> Pattern a)-vInt_pDouble_p_p = $(function "degradeOverBy")--pInt_t_p_p :: MiniTidal a => Parser (Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)-pInt_t_p_p = choice [- try $ parens pInt_t_p_p,- $(function "every"),- pInt_pInt_t_p_p <*> patternArg- ]--pDouble_t_p_p :: MiniTidal a => Parser (Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)-pDouble_t_p_p = $(function "sometimesBy")--lvInt_t_p_p :: MiniTidal a => Parser ([Int] -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)-lvInt_t_p_p = $(function "foldEvery")--vTime_vTime_p_p :: MiniTidal a => Parser (Time -> Time -> Pattern a -> Pattern a)-vTime_vTime_p_p = $(function "playFor")--vTimeTime_t_p_p :: MiniTidal a => Parser ((Time,Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)-vTimeTime_t_p_p = $(function "within")--vInt_t_p_p :: MiniTidal a => Parser (Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)-vInt_t_p_p = choice [- try $ parens vInt_t_p_p,- $(function "chunk"),- vInt_vInt_t_p_p <*> literalArg- ]--vDouble_t_p_p :: MiniTidal a => Parser (Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)-vDouble_t_p_p = $(function "someCyclesBy")--pInt_pInt_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern Int -> Pattern a -> Pattern a)-pInt_pInt_p_p = choice [- try $ parens pInt_pInt_p_p,- $(function "euclid"),- $(function "euclidInv"),- vInt_pInt_pInt_p_p <*> literalArg- ]--pTime_pTime_p_p :: MiniTidal a => Parser (Pattern Time -> Pattern Time -> Pattern a -> Pattern a)-pTime_pTime_p_p = $(function "swingBy")--pInt_pInt_t_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)-pInt_pInt_t_p_p = $(function "every'")--vInt_vInt_t_p_p :: MiniTidal a => Parser (Int -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)-vInt_vInt_t_p_p = $(function "whenmod")--pInt_p_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern a -> Pattern a -> Pattern a)-pInt_p_p_p = choice [- try $ parens pInt_p_p_p,- pInt_pInt_p_p_p <*> patternArg- ]--pInt_pInt_p_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a)-pInt_pInt_p_p_p = $(function "euclidFull")--vInt_pInt_pInt_p_p :: MiniTidal a => Parser (Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a)-vInt_pInt_pInt_p_p = choice [- try $ parens vInt_pInt_pInt_p_p,- pTime_vInt_pInt_pInt_p_p <*> patternArg- ]--pTime_vInt_pInt_pInt_p_p :: MiniTidal a => Parser (Pattern Time -> Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a)-pTime_vInt_pInt_pInt_p_p = $(function "fit'")--pControl_pControl :: Parser (ControlPattern -> ControlPattern)-pControl_pControl = choice [- try $ parens pControl_pControl,- pInt_pControl_pControl <*> patternArg,- pDouble_pControl_pControl <*> patternArg,- pTime_pControl_pControl <*> patternArg,- tControl_pControl_pControl <*> transformationArg- ]--tControl_pControl_pControl :: Parser ((ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern)-tControl_pControl_pControl = $(function "jux")--pInt_pControl_pControl :: Parser (Pattern Int -> ControlPattern -> ControlPattern)-pInt_pControl_pControl = choice [- $(function "chop"),- $(function "striate")- ]--pDouble_pControl_pControl :: Parser (Pattern Double -> ControlPattern -> ControlPattern)-pDouble_pControl_pControl = choice [- try $ parens pDouble_pControl_pControl,- pInt_pDouble_pControl_pControl <*> patternArg- ]--pInt_pDouble_pControl_pControl :: Parser (Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern)-pInt_pDouble_pControl_pControl = $(function "striate'")--pTime_pControl_pControl :: Parser (Pattern Time -> ControlPattern -> ControlPattern)-pTime_pControl_pControl = choice [- try $ parens pTime_pControl_pControl,- pDouble_pTime_pControl_pControl <*> patternArg- ]--pDouble_pTime_pControl_pControl :: Parser (Pattern Double -> Pattern Time -> ControlPattern -> ControlPattern)-pDouble_pTime_pControl_pControl = choice [- try $ parens pDouble_pTime_pControl_pControl,- pInteger_pDouble_pTime_pControl_pControl <*> patternArg- ]--pInteger_pDouble_pTime_pControl_pControl :: Parser (Pattern Integer -> Pattern Double -> Pattern Time -> ControlPattern -> ControlPattern)-pInteger_pDouble_pTime_pControl_pControl = $(function "stut")--simpleDoublePatterns :: Parser (Pattern Double)-simpleDoublePatterns = choice [- $(function "rand"),- $(function "sine"),- $(function "saw"),- $(function "isaw"),- $(function "tri"),- $(function "square"),- $(function "cosine")- ]--binaryNumFunctions :: Num a => Parser (a -> a -> a)-binaryNumFunctions = choice [- try $ parens binaryNumFunctions,- reservedOp "+" >> return (+),- reservedOp "-" >> return (-),- reservedOp "*" >> return (*)- ]--instance MiniTidal Int where- literal = int- simplePattern = parseBP' <|> (pure <$> int)- transformationWithArguments = p_p_noArgs- transformationWithoutArguments = p_p- complexPattern = (atom <*> int) <|> enumComplexPatterns <|> numComplexPatterns <|> intComplexPatterns- mergeOperator = numMergeOperator- binaryFunctions = binaryNumFunctions--instance MiniTidal Integer where- literal = integer- simplePattern = parseBP' <|> (pure <$> integer)- transformationWithArguments = p_p_noArgs- transformationWithoutArguments = p_p- complexPattern = (atom <*> integer) <|> enumComplexPatterns <|> numComplexPatterns- mergeOperator = numMergeOperator- binaryFunctions = binaryNumFunctions--instance MiniTidal Double where- literal = double- simplePattern = parseBP' <|> (try $ pure <$> double) <|> simpleDoublePatterns- transformationWithArguments = p_p_noArgs- transformationWithoutArguments = p_p- complexPattern = (atom <*> double) <|> enumComplexPatterns <|> numComplexPatterns- mergeOperator = numMergeOperator <|> fractionalMergeOperator- binaryFunctions = binaryNumFunctions--instance MiniTidal Time where- literal = (toRational <$> double) <|> (fromIntegral <$> integer)- simplePattern = parseBP' <|> (pure <$> literal)- transformationWithArguments = p_p_noArgs- transformationWithoutArguments = p_p- complexPattern = atom <*> literal <|> numComplexPatterns- mergeOperator = numMergeOperator <|> fractionalMergeOperator- binaryFunctions = binaryNumFunctions--instance MiniTidal Arc where- literal = do- xs <- parens (commaSep1 literal)- if length xs == 2 then return (T.Arc (xs!!0) (xs!!1)) else unexpected "Arcs must contain exactly two values"- simplePattern = pure <$> literal- transformationWithArguments = p_p_noArgs- transformationWithoutArguments = p_p- complexPattern = atom <*> literal- mergeOperator = parserZero- binaryFunctions = parserZero--instance MiniTidal (Time,Time) where- literal = do- xs <- parens (commaSep1 literal)- if length xs == 2 then return ((xs!!0),(xs!!1)) else unexpected "(Time,Time) must contain exactly two values"- simplePattern = pure <$> literal- transformationWithArguments = p_p_noArgs- transformationWithoutArguments = p_p- complexPattern = atom <*> literal- mergeOperator = parserZero- binaryFunctions = parserZero--instance MiniTidal String where- literal = stringLiteral- simplePattern = parseBP'- transformationWithArguments = p_p_noArgs- transformationWithoutArguments = p_p- complexPattern = atom <*> stringLiteral- mergeOperator = parserZero- binaryFunctions = parserZero--fractionalMergeOperator :: Fractional a => Parser (Pattern a -> Pattern a -> Pattern a)-fractionalMergeOperator = opParser "/" >> return (/)--numMergeOperator :: Num a => Parser (Pattern a -> Pattern a -> Pattern a)-numMergeOperator = choice [- opParser "+" >> return (+),- opParser "-" >> return (-),- opParser "*" >> return (*)- ]--enumComplexPatterns :: (Enum a, Num a, MiniTidal a) => Parser (Pattern a)-enumComplexPatterns = choice [- $(function "run") <*> patternArg,- $(function "scan") <*> patternArg- ]--numComplexPatterns :: (Num a, MiniTidal a) => Parser (Pattern a)-numComplexPatterns = choice [- $(function "irand") <*> literal,- $(function "toScale'") <*> literalArg <*> listLiteralArg <*> patternArg,- $(function "toScale") <*> listLiteralArg <*> patternArg- ]--intComplexPatterns :: Parser (Pattern Int)-intComplexPatterns = choice [- $(function "randStruct") <*> literalArg- ]--atom :: Applicative m => Parser (a -> m a)-atom = (functionParser "pure" <|> functionParser "atom" <|> functionParser "return") >> return (pure)--parseBP' :: (Enumerable a, Parseable a) => Parser (Pattern a)-parseBP' = parseTPat' >>= return . T.toPat--parseTPat' :: Parseable a => Parser (TPat a)-parseTPat' = parseRhythm' T.tPatParser--parseRhythm' :: Parseable a => Parser (TPat a) -> Parser (TPat a)-parseRhythm' f = do- char '\"' >> whiteSpace- x <- T.pSequence f'- char '\"' >> whiteSpace- return x- where f' = f- <|> do _ <- symbol "~" <?> "rest"- return T.TPat_Silence--miniTidalIO :: Stream -> String -> Either ParseError (IO ())-miniTidalIO tidal = parse (miniTidalIOParser tidal) "miniTidal"--miniTidalIOParser :: Stream -> Parser (IO ())-miniTidalIOParser tidal = whiteSpace >> choice [- eof >> return (return ()),- dParser tidal <*> patternArg-{- tParser tidal <*> transitionArg tidal <*> patternArg, -}--- (reserved "setcps" >> return (T.streamOnce tidal True . T.cps)) <*> literalArg- ]--dParser :: Stream -> Parser (ControlPattern -> IO ())-dParser tidal = choice [- reserved "d1" >> return (T.streamReplace tidal "1"),- reserved "d2" >> return (T.streamReplace tidal "2"),- reserved "d3" >> return (T.streamReplace tidal "3"),- reserved "d4" >> return (T.streamReplace tidal "4"),- reserved "d5" >> return (T.streamReplace tidal "5"),- reserved "d6" >> return (T.streamReplace tidal "6"),- reserved "d7" >> return (T.streamReplace tidal "7"),- reserved "d8" >> return (T.streamReplace tidal "8"),- reserved "d9" >> return (T.streamReplace tidal "9"),- reserved "d10" >> return (T.streamReplace tidal "10"),- reserved "d11" >> return (T.streamReplace tidal "11"),- reserved "d12" >> return (T.streamReplace tidal "12"),- reserved "d13" >> return (T.streamReplace tidal "13"),- reserved "d14" >> return (T.streamReplace tidal "14"),- reserved "d15" >> return (T.streamReplace tidal "15"),- reserved "d16" >> return (T.streamReplace tidal "16")- ]--{- tParser :: Stream -> Parser ((Time -> [ControlPattern] -> ControlPattern) -> ControlPattern -> IO ())-tParser tidal = choice [- reserved "t1" >> return ((ts tidal)!!0),- reserved "t2" >> return ((ts tidal)!!1),- reserved "t3" >> return ((ts tidal)!!2),- reserved "t4" >> return ((ts tidal)!!3),- reserved "t5" >> return ((ts tidal)!!4),- reserved "t6" >> return ((ts tidal)!!5),- reserved "t7" >> return ((ts tidal)!!6),- reserved "t8" >> return ((ts tidal)!!7),- reserved "t9" >> return ((ts tidal)!!8)- ] -}--{- transitionArg :: Stream -> Parser (Time -> [ControlPattern] -> ControlPattern)-transitionArg tidal = choice [- parensOrApplied $ (reserved "xfadeIn" >> return (T.transition tidal . T.xfadeIn)) <*> literalArg- ] -}---- below is a stand-alone Tidal interpreter--- can be compiled, for example, with: ghc --make Sound/Tidal/MiniTidal.hs -main-is Sound.Tidal.MiniTidal -o miniTidal--main :: IO ()-main = do- putStrLn "miniTidal"- tidal <- T.startTidal T.superdirtTarget T.defaultConfig- forever $ do- cmd <- miniTidalIO tidal <$> getLine- either (\x -> putStrLn $ "error: " ++ show x) id cmd---- things whose status in new tidal we are unsure of---(function "within'" >> return T.within') <*> literalArg <*> transformationArg,--- (function "revArc" >> return T.revArc) <*> literalArg,--- (function "prr" >> return T.prr) <*> literalArg <*> literalArg <*> patternArg,--- (function "preplace" >> return T.preplace) <*> literalArg <*> patternArg,--- (function "prep" >> return T.prep) <*> literalArg <*> patternArg,--- (function "preplace1" >> return T.preplace1) <*> patternArg,--- (function "protate" >> return T.protate) <*> literalArg <*> literalArg,--- (function "prot" >> return T.prot) <*> literalArg <*> literalArg,--- (function "prot1" >> return T.prot1) <*> literalArg,--- (function "fill" >> return T.fill) <*> patternArg,---function "struct" >> return T.struct,--- (function "sliceArc" >> return T.sliceArc) <*> literalArg--- function "breakUp" >> return T.breakUp, -- removed from new Tidal?
− src/Sound/Tidal/MiniTidal/TH.hs
@@ -1,18 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Sound.Tidal.MiniTidal.TH where--import Language.Haskell.TH-import Sound.Tidal.MiniTidal.Token--op :: String -> Q Exp-op x = do -- op "x" >> return T.x- let y = appE [|opParser|] $ return (LitE $ StringL x)- let z = appE [|return|] $ return (VarE $ mkName $ "T." ++ x)- uInfixE y [|(>>)|] z--function :: String -> Q Exp-function x = do -- function "x" >> return T.x- let y = appE [|functionParser|] $ return (LitE $ StringL x)- let z = appE [|return|] $ return (VarE $ mkName $ "T." ++ x)- uInfixE y [|(>>)|] z
− src/Sound/Tidal/MiniTidal/Token.hs
@@ -1,122 +0,0 @@-module Sound.Tidal.MiniTidal.Token where--import Data.Functor.Identity (Identity)-import Text.Parsec.Prim (ParsecT,parserZero)-import Text.ParserCombinators.Parsec-import Text.Parsec.Language (haskellDef)-import qualified Text.ParserCombinators.Parsec.Token as P--tokenParser :: P.TokenParser a-tokenParser = P.makeTokenParser $ haskellDef {- P.reservedNames = ["chop","striate","striate'","stut","jux","brak","rev",- "palindrome","fast","density","slow","iter","iter'","trunc","swingBy","every","whenmod",- "append","append'","silence","s","sound","n","up","speed","vowel","pan","shape","gain",- "accelerate","bandf","bandq","begin","coarse","crush","cut","cutoff","delayfeedback",- "delaytime","delay","end","hcutoff","hresonance","loop","resonance","shape","unit",- "sine","saw","isaw","fit","irand","tri","square","rand",- "pure","return","stack","fastcat","slowcat","cat","atom","overlay","run","scan","fast'",- "fastGap","densityGap","sparsity","rotL","rotR","playFor","every'","foldEvery",- "cosine","superimpose","trunc","linger","zoom","compress","sliceArc","within","within'",- "revArc","euclid","euclidFull","euclidInv","distrib","wedge","prr","preplace","prep","preplace1",- "protate","prot","prot1","discretise","segment","struct","substruct","compressTo",- "substruct'","stripe","slowstripe","stretch","fit'","chunk","loopFirst","timeLoop","swing",- "choose","degradeBy","unDegradeBy","degradeOverBy","sometimesBy","sometimes","often",- "rarely","almostNever","almostAlways","never","always","someCyclesBy","somecyclesBy",- "someCycles","somecycles","substruct'","repeatCycles","spaceOut","fill","ply","shuffle",- "scramble","breakUp","degrade","randcat","randStruct","toScale'","toScale","cycleChoose",- "d1","d2","d3","d4","d5","d6","d7","d8","d9","t1","t2","t3","t4","t5","t6","t7","t8","t9",- "cps","xfadeIn","note","spread","slowspread","fastspread"],- P.reservedOpNames = ["+","-","*","/","<~","~>","#","|+|","|-|","|*|","|/|","$","\"","|>","<|","|>|","|<|"]- }--{- Not currently in use-angles :: ParsecT String u Identity a -> ParsecT String u Identity a-angles = P.angles tokenParser-braces :: ParsecT String u Identity a -> ParsecT String u Identity a-braces = P.braces tokenParser-charLiteral :: ParsecT String u Identity Char-charLiteral = P.charLiteral tokenParser-colon :: ParsecT String u Identity String-colon = P.colon tokenParser-comma :: ParsecT String u Identity String-comma = P.comma tokenParser-decimal :: ParsecT String u Identity Integer-decimal = P.decimal tokenParser-dot :: ParsecT String u Identity String-dot = P.dot tokenParser-hexadecimal :: ParsecT String u Identity Integer-hexadecimal = P.hexadecimal tokenParser-identifier :: ParsecT String u Identity String-identifier = P.identifier tokenParser-lexeme :: ParsecT String u Identity a -> ParsecT String u Identity a-lexeme = P.lexeme tokenParser-naturalOrFloat :: ParsecT String u Identity (Either Integer Double)-naturalOrFloat = P.naturalOrFloat tokenParser-natural :: ParsecT String u Identity Integer-natural = P.natural tokenParser-octal :: ParsecT String u Identity Integer-octal = P.octal tokenParser-operator :: ParsecT String u Identity String-operator = P.operator tokenParser-semi :: ParsecT String u Identity String-semi = P.semi tokenParser-semiSep1 :: ParsecT String u Identity a -> ParsecT String u Identity [a]-semiSep1 = P.semiSep1 tokenParser-semiSep :: ParsecT String u Identity a -> ParsecT String u Identity [a]-semiSep = P.semiSep tokenParser--}--brackets :: ParsecT String u Identity a -> ParsecT String u Identity a-brackets = P.brackets tokenParser-commaSep1 :: ParsecT String u Identity a -> ParsecT String u Identity [a]-commaSep1 = P.commaSep1 tokenParser-commaSep :: ParsecT String u Identity a -> ParsecT String u Identity [a]-commaSep = P.commaSep tokenParser-float :: ParsecT String u Identity Double-float = P.float tokenParser-integer :: ParsecT String u Identity Integer-integer = P.integer tokenParser-parens :: ParsecT String u Identity a -> ParsecT String u Identity a-parens = P.parens tokenParser-reservedOp :: String -> ParsecT String u Identity ()-reservedOp = P.reservedOp tokenParser-reserved :: String -> ParsecT String u Identity ()-reserved = P.reserved tokenParser-stringLiteral :: ParsecT String u Identity String-stringLiteral = P.stringLiteral tokenParser-symbol :: String -> ParsecT String u Identity String-symbol = P.symbol tokenParser-whiteSpace :: ParsecT String u Identity ()-whiteSpace = P.whiteSpace tokenParser--functionParser :: String -> Parser ()-functionParser x = reserved x <|> try (parens (functionParser x))--opParser :: String -> Parser ()-opParser x = reservedOp x <|> try (parens (opParser x))--double :: Parser Double-double = choice [- parens $ symbol "-" >> float >>= return . (* (-1)),- parens double,- try float,- try $ fromIntegral <$> integer- ]--int :: Parser Int-int = try $ parensOrNot $ fromIntegral <$> integer--parensOrNot :: Parser a -> Parser a-parensOrNot p = p <|> try (parens (parensOrNot p))--nestedParens :: Parser a -> Parser a-nestedParens p = try (parens p) <|> try (parens (nestedParens p))--applied :: Parser a -> Parser a-applied p = opParser "$" >> p--appliedOrNot :: Parser a -> Parser a-appliedOrNot p = applied p <|> p--parensOrApplied :: Parser a -> Parser a-parensOrApplied p = try (parens p) <|> try (applied p)
src/Sound/Tidal/Params.hs view
@@ -4,6 +4,7 @@ import Sound.Tidal.Pattern import Sound.Tidal.Utils+import Data.Maybe (fromMaybe) -- | group multiple params into one grp :: [String -> ControlMap] -> Pattern String -> ControlPattern@@ -14,10 +15,12 @@ split = wordsBy (==':') mF :: String -> String -> ControlMap-mF name v = Map.singleton name (VF $ read v)+mF name v = fromMaybe Map.empty $ do f <- readMaybe v+ return $ Map.singleton name (VF f) mI :: String -> String -> ControlMap-mI name v = Map.singleton name (VI $ read v)+mI name v = fromMaybe Map.empty $ do i <- readMaybe v+ return $ Map.singleton name (VI i) mS :: String -> String -> ControlMap mS name v = Map.singleton name (VS v)
src/Sound/Tidal/ParseBP.hs view
@@ -366,8 +366,11 @@ name <- many1 $ letter <|> digit let chord = fromMaybe [0] $ lookup name chordTable do char '\''- i <- integer <?> "chord range"- let chord' = take (fromIntegral i) $ concatMap (\x -> map (+ x) chord) [0,12..]+ notFollowedBy space <?> "chord range or 'i'"+ let n = length chord+ i <- option n (fromIntegral <$> integer)+ j <- length <$> many (char 'i')+ let chord' = take i $ drop j $ concatMap (\x -> map (+ x) chord) [0,12..] return chord' <|> return chord
src/Sound/Tidal/Pattern.hs view
@@ -14,12 +14,14 @@ import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe, mapMaybe) import Data.Ratio (numerator, denominator) import Data.Typeable (Typeable)+import Control.DeepSeq (NFData(rnf)) + ------------------------------------------------------------------------ -- * Types -- | Time is rational-type Time = Rational+type Time = Rational -- | The 'sam' (start of cycle) for the given time value sam :: Time -> Time@@ -45,6 +47,10 @@ type Arc = ArcF Time +instance NFData a => + NFData (ArcF a) where + rnf (Arc s e) = rnf s `seq` rnf e+ instance {-# OVERLAPPING #-} Show Arc where show (Arc s e) = prettyRat s ++ ">" ++ prettyRat e @@ -136,6 +142,10 @@ type Event a = EventF (ArcF Time) a +instance (NFData a, NFData b) => + NFData (EventF a b) where + rnf (Event w p v) = 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) @@ -231,6 +241,13 @@ class Valuable a where toValue :: a -> Value +instance NFData Value where + rnf (VS s) = rnf s + rnf (VF f) = rnf f + rnf (VR r) = rnf r + rnf (VI i) = rnf i + rnf (VB b) = rnf b+ instance Valuable String where toValue = VS instance Valuable Double where@@ -287,6 +304,10 @@ ------------------------------------------------------------------------ -- * Instances +instance NFData a => + NFData (Pattern a) where + rnf (Pattern _ q) = rnf $ \s -> q s+ instance Functor Pattern where -- | apply a function to all the values in a pattern fmap f p = p {query = fmap (fmap f) . query p}@@ -343,13 +364,16 @@ -- If one of the patterns is digital, treat both as digital.. (TODO - needs extra thought) (<*) pf px = Pattern Digital q- where q st = concatMap match $ query pf st- where- match (Event fWhole fPart f) =- map- (Event fWhole fPart . f . value) $- query px $ st {arc = xQuery fWhole}- xQuery (Arc s _) = pure s -- for discrete events, match with the onset+ where q st = catMaybes $ concatMap match $ query pf st+ where+ match (Event fWhole fPart f) =+ map+ (\(Event _ xPart x) ->+ do let whole' = fWhole+ part' <- subArc fPart xPart+ return (Event whole' part' (f x))+ )+ (query px $ st {arc = fPart}) -- | Like <*>, but the structure only comes from the right (*>) :: Pattern (a -> b) -> Pattern a -> Pattern b@@ -362,13 +386,16 @@ query pf st -- for continuous events, use the original query (*>) pf px = Pattern Digital q- where q st = concatMap match $ query px st- where- match (Event xWhole xPart x) =- map- (\e -> Event xWhole xPart (value e x)) $- query pf $ fQuery xWhole- fQuery (Arc s _) = st {arc = pure s} -- for discrete events, match with the onset+ where q st = catMaybes $ concatMap match $ query pf st+ where+ match (Event _ fPart f) =+ map+ (\(Event xWhole xPart x) ->+ do let whole' = xWhole+ part' <- subArc fPart xPart+ return (Event whole' part' (f x))+ )+ (query px $ st {arc = fPart}) infixl 4 <*, *> @@ -769,6 +796,9 @@ -- formerly known as playWhen filterWhen :: (Time -> Bool) -> Pattern a -> Pattern a filterWhen test p = p {query = filter (test . wholeStart) . query p}++filterOnsets :: Pattern a -> Pattern a+filterOnsets p = p {query = filter (\e -> eventPartStart e == wholeStart e) . query p} playFor :: Time -> Time -> Pattern a -> Pattern a playFor s e = filterWhen (\t -> (t >= s) && (t < e))
src/Sound/Tidal/Stream.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} module Sound.Tidal.Stream where@@ -103,7 +103,8 @@ ("attack", Just $ VF (-1)), ("hold", Just $ VF 0), ("release", Just $ VF (-1)),- ("orbit", Just $ VI 0)+ ("orbit", Just $ VI 0),+ ("id", Just $ VI 0) ], oLatency = 0.02, oPreamble = [],@@ -144,20 +145,40 @@ | isJust (oShape target) = fmap (fmap toDatum) $ sequence $ map (\(n,v) -> Map.lookup n (value e) <|> v) (fromJust $ oShape target) | otherwise = Just $ concatMap (\(n,v) -> [O.string n, toDatum v]) $ Map.toList $ value e -toMessage :: Double -> OSCTarget -> T.Tempo -> Event (Map.Map String Value) -> Maybe O.Message-toMessage t target tempo e = do vs <- toData target addExtra- return $ O.Message (oPath target) $ oPreamble target ++ vs+toMessage :: Config -> Double -> OSCTarget -> T.Tempo -> Event (Map.Map String Value) -> Maybe O.Message+toMessage config t target tempo e = do vs <- toData target addExtra+ return $ O.Message (oPath target) $ oPreamble target ++ vs where on = sched tempo $ start $ whole e off = sched tempo $ stop $ whole e+ identifier = ((if (start $ whole e) == (start $ part e) then "X" else ">")+ ++ show (start $ whole e)+ ++ "-"+ ++ show (stop $ whole e)+ ++ "-"+ ++ getString "n"+ ++ "-"+ ++ getString "note"+ ++ "-"+ ++ getString "s"+ )+ getString s = fromMaybe "" $ do v <- Map.lookup s $ value e+ return $ simpleShow v+ simpleShow (VS s) = s+ simpleShow (VI i) = show i+ simpleShow (VF f) = show f+ simpleShow (VR r) = show r+ simpleShow (VB b) = show b delta = off - on messageStamp = oTimestamp target == MessageStamp -- If there is already cps in the event, the union will preserve that. addExtra = (\v -> (Map.union v $ Map.fromList (extra messageStamp) )) <$> e- extra False = [("cps", (VF $ T.cps tempo)),- ("delta", VF delta),- ("cycle", VF (fromRational $ start $ whole e))- ]+ addIdentifier | cSendParts config = (("id", VS identifier):)+ | otherwise = id+ extra False = addIdentifier [("cps", (VF $ T.cps tempo)),+ ("delta", VF delta),+ ("cycle", VF (fromRational $ start $ whole e))+ ] extra True = timestamp ++ (extra False) timestamp = [("sec", VI sec), ("usec", VI usec)@@ -181,17 +202,19 @@ tempo <- readMVar tempoMV now <- O.time let sMap' = Map.insert "_cps" (pure $ VF $ T.cps tempo) sMap- es = filter eventHasOnset $ query p (State {arc = T.nowArc st, controls = sMap'})+ es = filterEvents $ query p (State {arc = T.nowArc st, controls = sMap'})+ filterEvents | cSendParts config = id+ | otherwise = filter eventHasOnset on e = (sched tempo $ start $ whole e) + eventNudge e eventNudge e = fromJust $ getF $ fromMaybe (VF 0) $ Map.lookup "nudge" $ value e- messages target = catMaybes $ map (\e -> do m <- toMessage (on e + latency target) target tempo e+ messages target = catMaybes $ map (\e -> do m <- toMessage config (on e + latency target) target tempo e return $ (on e, m) ) es cpsChanges = map (\e -> (on e - now, Map.lookup "cps" $ value e)) es latency target = oLatency target + cFrameTimespan config + T.nudged tempo mapM_ (\(Cx target udp) -> E.catch (mapM_ (send target (latency target) udp) (messages target))- (\(_ ::E.SomeException)- -> putStrLn $ "Failed to send. Is the '" ++ oName target ++ "' target running?"+ (\(e ::E.SomeException)+ -> putStrLn $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e ) ) cxs mapM_ (doCps tempoMV) cpsChanges@@ -234,7 +257,7 @@ -- Evaluation of pat is forced so exceptions are picked up here, before replacing the existing pattern. streamReplace :: Show a => Stream -> a -> ControlPattern -> IO ()-streamReplace s k pat+streamReplace s k !pat = E.catch (do let x = queryArc pat (Arc 0 0) tempo <- readMVar $ sTempoMV s input <- takeMVar $ sInput s@@ -289,14 +312,15 @@ at e = sched fakeTempo $ start $ whole e on e = sched tempo $ start $ whole e cpsChanges = map (\e -> (on e - now, Map.lookup "cps" $ value e)) es+ config = sConfig st messages target =- catMaybes $ map (\e -> do m <- toMessage (at e + (oLatency target)) target fakeTempo e+ catMaybes $ map (\e -> do m <- toMessage config (at e + (oLatency target)) target fakeTempo e return $ (at e, m) ) es mapM_ (\(Cx target udp) -> E.catch (mapM_ (send target (oLatency target) udp) (messages target))- (\(_ ::E.SomeException)- -> putStrLn $ "Failed to send. Is the '" ++ oName target ++ "' target running?"+ (\(e ::E.SomeException)+ -> putStrLn $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e ) ) (sCxs st) mapM_ (doCps $ sTempoMV st) cpsChanges
src/Sound/Tidal/Tempo.hs view
@@ -78,7 +78,6 @@ getCurrentCycle t = (readMVar t) >>= (cyclesNow) >>= (return . toRational) -} - clocked :: Config -> (MVar Tempo -> State -> IO ()) -> IO (MVar Tempo, [ThreadId]) clocked config callback = do s <- O.time@@ -110,13 +109,19 @@ t' <- O.time let actualTick = floor $ (t' - start st) / frameTimespan -- reset ticks if ahead/behind by 4 or more- newTick | (abs $ actualTick - ticks st) > 4 = actualTick+ ahead = (abs $ actualTick - ticks st) > 4+ newTick | ahead = actualTick | otherwise = (ticks st) + 1 st' = st {ticks = newTick, nowArc = P.Arc s e, starting = not (synched tempo) }+ when ahead $ putStrLn $ "skip: " ++ show (actualTick - ticks st) callback tempoMV st'+ {-putStrLn ("actual tick: " ++ show actualTick+ ++ " old tick: " ++ show (ticks st)+ ++ " new tick: " ++ show newTick+ )-} loop tempoMV st' clientListen :: Config -> O.Time -> IO (MVar Tempo, ThreadId)
src/Sound/Tidal/Transition.hs view
@@ -47,8 +47,8 @@ mortalOverlay _ _ [] = silence mortalOverlay t now (pat:ps) = overlay (pop ps) (playFor s (s+t) pat) where pop [] = silence- pop (x:xs) = x- s = sam (now - fromIntegral (floor now `mod` floor t)) + sam t+ pop (x:_) = x+ s = sam (now - fromIntegral (floor now `mod` floor t :: Int)) + sam t {-| Washes away the current pattern after a certain delay by applying a function to it over time, then switching over to the next pattern to
src/Sound/Tidal/UI.hs view
@@ -4,14 +4,15 @@ import Prelude hiding ((<*), (*>)) -import Data.Char (digitToInt, isDigit)+import Data.Char (digitToInt, isDigit, ord)+import Data.Bits (testBit, Bits) -- import System.Random (randoms, mkStdGen) import System.Random.MWC import Control.Monad.ST import qualified Data.Vector as V import Data.Word (Word32) import Data.Ratio ((%),numerator,denominator)-import Data.List (sort, sortOn, findIndices, elemIndex, groupBy, transpose, intercalate)+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@@ -1051,6 +1052,45 @@ lindenmayerI :: Num b => Int -> String -> String -> [b] lindenmayerI n r s = fmap (fromIntegral . digitToInt) $ lindenmayer n r s +{- | @runMarkov n tmat xi seed@ generates a Markov chain (as a list) of length @n@+using the transition matrix @tmat@ starting from initial state @xi@, starting+with random numbers generated from @seed@+Each entry in the chain is the index of state (starting from zero). +Each row of the matrix will be automatically normalized. For example:+@+runMarkov 8 [[2,3], [1,3]] 0 0+@+will produce a two-state chain 8 steps long, from initial state @0@, where the+transition probability from state 0->0 is 2/5, 0->1 is 3/5, 1->0 is 1/4, and +1->1 is 3/4. -}+runMarkov :: Int -> [[Double]] -> Int -> Time -> [Int]+runMarkov n tp xi seed = reverse $ (iterate (markovStep $ renorm tp) [xi])!! (n-1) where+ markovStep tp xs = (fromJust $ findIndex (r <=) $ scanl1 (+) (tp!!(head xs))) : xs where+ r = timeToRand $ seed + (fromIntegral . length) xs / fromIntegral n+ renorm tp = [ map (/ sum x) x | x <- tp ]++{- @markovPat n xi tp@ generates a one-cycle pattern of @n@ steps in a Markov+chain starting from state @xi@ with transition matrix @tp@. Each row of the+transition matrix is automatically normalized. For example:+@+tidal> markovPat 8 1 [[3,5,2], [4,4,2], [0,1,0]]++(0>⅛)|1+(⅛>¼)|2+(¼>⅜)|1+(⅜>½)|1+(½>⅝)|2+(⅝>¾)|1+(¾>⅞)|1+(⅞>1)|0+@ -}+markovPat :: Pattern Int -> Pattern Int -> [[Double]] -> Pattern Int+markovPat = tParam2 _markovPat++_markovPat :: Int -> Int -> [[Double]] -> Pattern Int+_markovPat n xi tp = splitQueries $ Pattern Digital (\(State a@(Arc s e) _) -> + queryArc (listToPat $ runMarkov n tp xi (sam s)) a)+ {-| Removes events from second pattern that don't start during an event from first. @@ -1080,10 +1120,7 @@ -} mask :: Pattern Bool -> Pattern a -> Pattern a-mask maskpat pat = filterJust $ toMaybe <$> pat'- where pat' = matchManyToOne (flip const) maskpat pat- toMaybe (True, a) = Just a- toMaybe (False, _) = Nothing+mask b p = const <$> p <* (filterValues id b) {- mask :: Pattern Bool -> Pattern b -> Pattern b@@ -1375,10 +1412,11 @@ -- Uses the first (binary) pattern to switch between the following two -- patterns. sew :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a-sew stitch p1 p2 = overlay (const <$> p1 <* a) (const <$> p2 <* b)- where a = filterValues id stitch- b = filterValues not stitch+sew stitch a b = overlay (mask stitch a) (mask (inv stitch) b) +stitch :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a+stitch bool a b = overlay (struct bool a) (struct (inv bool) b)+ stutter :: Integral i => i -> Time -> Pattern a -> Pattern a stutter n t p = stack $ map (\i -> (t * fromIntegral i) `rotR` p) [0 .. (n-1)] @@ -1794,3 +1832,18 @@ chew n ipat pat = (squeezeJoinUp $ zoompat <$> ipat) |/ P.speed (pure $ fromIntegral n) where zoompat i = zoom (i'/(fromIntegral n), (i'+1)/(fromIntegral n)) (pat) where i' = fromIntegral $ i `mod` n++__binary :: Data.Bits.Bits b => Int -> b -> [Bool]+__binary n num = map (testBit num) $ reverse [0 .. n-1]++_binary :: Data.Bits.Bits b => Int -> b -> Pattern Bool+_binary n num = listToPat $ __binary n num++binaryN :: Data.Bits.Bits b => Int -> Pattern b -> Pattern Bool+binaryN n p = innerJoin $ _binary n <$> p++binary :: Data.Bits.Bits b => Pattern b -> Pattern Bool+binary = binaryN 8++ascii :: Pattern String -> Pattern Bool+ascii p = innerJoin $ (listToPat . concatMap (__binary 8 . ord)) <$> p
src/Sound/Tidal/Version.hs view
@@ -1,4 +1,4 @@ module Sound.Tidal.Version where tidal_version :: String-tidal_version = "1.0.14"+tidal_version = "1.1.0"
test/Sound/Tidal/ControlTest.hs view
@@ -18,6 +18,6 @@ describe "stutWith" $ do it "can mimic stut" $ do comparePD (Arc 0 1)- (stutWith 4 0.25 (# gain 1) $ sound "bd")- (stut 4 1 0.25 $ sound "bd")+ (filterOnsets $ stutWith 4 0.25 (# gain 1) $ sound "bd")+ (filterOnsets $ stut 4 1 0.25 $ sound "bd")
test/Sound/Tidal/CoreTest.hs view
@@ -129,11 +129,11 @@ it "goes from 0 up to 1 and back every cycle" $ do comparePD (Arc 0 1) (struct "t*8" (tri :: Pattern Double))- ("0 0.25 0.5 0.75 1 0.75 0.5 0.25")+ ("0.125 0.375 0.625 0.875 0.875 0.625 0.375 0.125") it "can be added to" $ do comparePD (Arc 0 1) (struct "t*8" $ (tri :: Pattern Double) + 1)- ("1 1.25 1.5 1.75 2 1.75 1.5 1.25")+ ("1.125 1.375 1.625 1.875 1.875 1.625 1.375 1.125") describe "every" $ do it "`every n id` doesn't change the pattern's structure" $ do comparePD (Arc 0 4)
− test/Sound/Tidal/MiniTidalTest.hs
@@ -1,147 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Sound.Tidal.MiniTidalTest where--import Test.Microspec-import Sound.Tidal.MiniTidal-import Sound.Tidal.Context as Tidal-import Data.Either-import Text.ParserCombinators.Parsec (ParseError)-import qualified Data.Map.Strict as Map--parsesTo :: String -> ControlPattern -> Property-parsesTo str p = x `shouldBe` y- where x = query <$> miniTidal str <*> Right (State (Arc 0 16) Map.empty)- y = Right $ query p $ State (Arc 0 16) Map.empty--causesParseError :: String -> Property-causesParseError str = isLeft (miniTidal str :: Either ParseError ControlPattern) `shouldBe` True--run :: Microspec ()-run =- describe "miniTidal" $ do-- it "parses the empty string as silence" $- "" `parsesTo` silence-- it "parses a string containing only spaces as silence" $- " " `parsesTo` silence-- it "parses a very simple single 's' pattern" $- "s \"bd cp\"" `parsesTo` s "bd cp"-- it "parses a single 's' pattern that uses angle brackets" $- "s \"<bd cp>\"" `parsesTo` s "<bd cp>"-- it "parses a single 's' pattern that uses square brackets" $- "s \"[bd sn] cp\"" `parsesTo` s "[bd sn] cp"-- it "parses a single 's' pattern that uses square brackets and *" $- "s \"[bd sn]*2 cp\"" `parsesTo` s "[bd sn]*2 cp"-- it "parses a single 's' pattern that uses Bjorklund rhythms" $- "s \"sn(5,16)\"" `parsesTo` s "sn(5,16)"-- it "parses a literal int as a double pattern" $- "pan 0" `parsesTo` (pan 0)-- it "parses a literal double as a double pattern" $- "pan 1.0" `parsesTo` (pan 1.0)-- it "parses a negative literal double as a double pattern" $- "pan (-1.0)" `parsesTo` (pan (-1.0))-- it "parses two merged patterns" $- "s \"bd cp\" # pan \"0 1\"" `parsesTo` (s "bd cp" # pan "0 1")-- it "parses three merged patterns" $- "s \"bd cp\" # pan \"0 1\" # gain \"0.5 0.7\"" `parsesTo`- (s "bd cp" # pan "0 1" # gain "0.5 0.7")-- it "parses three merged patterns, everything in brackets" $- "(s \"bd cp\" # pan \"0 1\" # gain \"0.5 0.7\")" `parsesTo`- ((s "bd cp" # pan "0 1" # gain "0.5 0.7"))-- it "parses three merged patterns, everything in muliple layers of brackets" $- "(((s \"bd cp\" # pan \"0 1\" # gain \"0.5 0.7\")))" `parsesTo`- ((((s "bd cp" # pan "0 1" # gain "0.5 0.7"))))-- it "parses three merged patterns with right associative brackets" $- "s \"bd cp\" # (pan \"0 1\" # gain \"0.5 0.7\")" `parsesTo`- (s "bd cp" # (pan "0 1" # gain "0.5 0.7"))-- it "parses three merged patterns with left associative brackets" $- "(s \"bd cp\" # pan \"0 1\") # gain \"0.5 0.7\"" `parsesTo`- ((s "bd cp" # pan "0 1") # gain "0.5 0.7")-- it "parses simple patterns in brackets applied to ParamPattern functions" $- "s (\"bd cp\")" `parsesTo` (s ("bd cp"))-- it "parses simple patterns applied to ParamPattern functions with $" $- "s $ \"bd cp\"" `parsesTo` (s $ "bd cp")-- it "parses addition of simple patterns" $- "n (\"0 1\" + \"2 3\")" `parsesTo` (n ("0 1" + "2 3"))-- it "parses multiplication of simple patterns as a merged parampattern" $- "s \"arpy*8\" # up (\"3\" * \"2\")" `parsesTo` (s "arpy*8" # up ("3" * "2"))-- it "parses pan patterns" $- "pan \"0 0.25 0.5 0.75 1\"" `parsesTo` (pan "0 0.25 0.5 0.75 1")-- it "parses note patterns" $- "note \"0 0.25 0.5 0.75 1\"" `parsesTo` (note "0 0.25 0.5 0.75 1")-- it "parses sine oscillators" $- "pan sine" `parsesTo` (pan sine)-- it "parses sine oscillators used in pan patterns" $- "s \"arpy*8\" # pan sine" `parsesTo` (s "arpy*8" # pan sine)-- it "parses fast transformations of parampatterns" $- "fast 2 $ s \"bd cp\"" `parsesTo` (fast 2 $ s "bd cp")-- it "parses fast transformations of parampatterns when in brackets" $- "(fast 2) $ s \"bd cp\"" `parsesTo` ((fast 2) $ s "bd cp")-- it "parses rev transformations of parampatterns" $- "rev $ s \"bd cp\"" `parsesTo` (rev $ s "bd cp")-- it "parses rev transformations of parampatterns when in brackets" $- "(rev) $ s \"bd cp\"" `parsesTo` ((rev) $ s "bd cp")-- it "parses jux transformations with transformations in brackets" $- "jux (rev) $ s \"arpy*8\" # up \"0 2 3 5 3 5 7 8\"" `parsesTo`- (jux (rev) $ s "arpy*8" # up "0 2 3 5 3 5 7 8")-- it "parses jux transformations with transformations not in brackets" $- "jux rev $ s \"arpy*8\" # up \"0 2 3 5 3 5 7 8\"" `parsesTo`- (jux rev $ s "arpy*8" # up "0 2 3 5 3 5 7 8")-- it "doesn't parse when a transformation requiring an argument is provided without parens or $ to jux" $- causesParseError "jux fast 2 $ s \"bd*4 cp\""-- it "parses multiple fast transformations of parampatterns" $- "fast 2 $ fast 2 $ s \"bd cp\"" `parsesTo` (fast 2 $ fast 2 $ s "bd cp")-- it "parses an 'every' transformation applied to a simple s pattern" $- "every 2 (fast 2) (s \"bd cp\")" `parsesTo` (every 2 (fast 2) (s "bd cp"))-- it "parses a transformed pattern merged with a pattern constructed from parampatterning an arithmetic expression on patterns" $- "(every 2 (fast 2) $ s \"arpy*8\") # up (\"[0 4 7 2,16 12 12 16]\" - \"<0 3 5 7>\")" `parsesTo` ((every 2 (fast 2) $ s "arpy*8") # up ("[0 4 7 2,16 12 12 16]" - "<0 3 5 7>"))-- it "parses a fast transformation applied to a simple (ie. non-param) pattern" $- "up (fast 2 \"<0 2 3 5>\")" `parsesTo`- (up (fast 2 "<0 2 3 5>"))-- it "parses a binary Num function spread over a simple Num pattern" $- "n (spread (+) [2,3,4] \"1 2 3\")" `parsesTo`- (n (spread (+) [2,3,4] "1 2 3"))-- it "parses an $ application spread over partially applied transformations of a non-Control Pattern" $- "n (spread ($) [density 2, rev, slow 2] $ \"1 2 3 4\")" `parsesTo`- (n (spread ($) [density 2, rev, slow 2] $ "1 2 3 4"))-- it "parses an $ application spread over partially applied transformations of a Control Pattern" $- "spread ($) [density 2, rev, slow 2, striate 3] $ sound \"[bd*2 [~ bd]] [sn future]*2 cp jvbass*4\"" `parsesTo`- (spread ($) [density 2, rev, slow 2, striate 3] $ sound "[bd*2 [~ bd]] [sn future]*2 cp jvbass*4")
test/Sound/Tidal/PatternTest.hs view
@@ -146,7 +146,9 @@ [(((0,1), (0,1)), 4 :: Int)] it "doesn't take structure from the right" $ do queryArc (pure (+1) <* (fastCat [pure 7, pure 8])) (Arc 0 1)- `shouldBe` fmap toEvent [(((0,1), (0,1)), 8 :: Int)]+ `shouldBe` fmap toEvent [(((0,1), (0,0.5)), 8 :: Int),+ (((0,1), (0.5,1)), 9 :: Int)+ ] describe "*>" $ do it "can apply a pattern of values to a pattern of functions" $ do@@ -523,7 +525,7 @@ it "filter above given threshold" $ do let fil = 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.5), (((1, 5%4), (1, 5%4)), 1.0), (((5%4, 3%2), (5%4, 3%2)), 1.5)] === res+ 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 describe "compressArc" $ do it "return empty if start time is greater than end time" $ do
test/Sound/Tidal/UITest.hs view
@@ -40,15 +40,18 @@ it "can turn a continuous pattern into multiple discrete events" $ do compareP (Arc 0 3) (segment 4 saw)- ("0 0.25 0.5 0.75" :: Pattern Double)+ ("0.125 0.375 0.625 0.875" :: Pattern Double) it "can hold a value over multiple cycles" $ do comparePD (Arc 0 8) (segment 0.5 saw)- (slow 2 "0" :: Pattern Double)+ (slow 2 "0.5" :: Pattern Double)+ {-+ -- not sure what this is supposed to do! it "holding values over multiple cycles works in combination" $ do comparePD (Arc 0 8) ("0*4" |+ (_segment (1/8) $ saw)) ("0*4" :: Pattern Double)+ -} describe "sometimesBy" $ do it "does nothing when set at 0% probability" $ do@@ -258,8 +261,8 @@ ("<0 1 2 3>"::Pattern Int) it "never gets an index out of bounds" $ do compareP (Arc 0 4)- (("0"::Pattern Int) |+ chooseBy (sig fromRational) [0,1,2,3])- ("<0>"::Pattern Int)+ ("0" |+ chooseBy (sig fromRational) [0,1,2,3])+ ("2"::Pattern Int) describe "arpeggiate" $ do it "can arpeggiate" $ do
test/Test.hs view
@@ -3,7 +3,6 @@ import Test.Microspec import Sound.Tidal.CoreTest-import Sound.Tidal.MiniTidalTest import Sound.Tidal.ParseTest import Sound.Tidal.PatternTest import Sound.Tidal.ControlTest@@ -14,7 +13,6 @@ main :: IO () main = microspec $ do Sound.Tidal.CoreTest.run- Sound.Tidal.MiniTidalTest.run Sound.Tidal.ParseTest.run Sound.Tidal.PatternTest.run Sound.Tidal.ControlTest.run
tidal.cabal view
@@ -1,5 +1,5 @@ name: tidal-version: 1.0.14+version: 1.1.0 synopsis: Pattern language for improvised music -- description: homepage: http://tidalcycles.org/@@ -33,7 +33,6 @@ Sound.Tidal.Control Sound.Tidal.Context Sound.Tidal.Core- Sound.Tidal.MiniTidal Sound.Tidal.Params Sound.Tidal.ParseBP Sound.Tidal.Pattern@@ -46,8 +45,7 @@ Sound.Tidal.Utils Sound.Tidal.Version Sound.Tidal.EspGrid- other-modules: Sound.Tidal.MiniTidal.TH- Sound.Tidal.MiniTidal.Token+ -- Sound.Tidal.TH Build-depends: base >=4.8 && <5 , containers < 0.7@@ -60,9 +58,9 @@ , vector < 0.13 , bifunctors < 5.6 , transformers >= 0.5 && < 0.5.7- , template-haskell >= 2.10.0.0 && < 2.15 , bytestring < 0.11 , clock < 0.9+ , deepseq >= 1.1.0.0 if !impl(ghc >= 8.4.1) build-depends: semigroups >= 0.18 && < 0.20@@ -75,7 +73,6 @@ ghc-options: -Wall other-modules: Sound.Tidal.ControlTest Sound.Tidal.CoreTest- Sound.Tidal.MiniTidalTest Sound.Tidal.ParseTest Sound.Tidal.PatternTest Sound.Tidal.ScalesTest@@ -88,6 +85,36 @@ , containers , parsec , tidal++ default-language: Haskell2010++benchmark bench-speed+ type: exitcode-stdio-1.0+ main-is: Main.hs + hs-source-dirs: bench/Speed+ other-modules: Tidal.PatternB+ Tidal.CoreB+ Tidal.UIB+ Tidal.Inputs+ build-depends: + base == 4.*+ , criterion+ , tidal+ ghc-options: -Wall -O2++ default-language: Haskell2010++benchmark bench-memory+ type: exitcode-stdio-1.0+ main-is: Main.hs + hs-source-dirs: bench/Memory + other-modules: Tidal.UIB+ Tidal.Inputs + build-depends:+ base == 4.*+ , weigh+ , tidal+ ghc-options: -Wall -O2 default-language: Haskell2010