tidal 1.9.5 → 1.10.0
raw patch · 57 files changed
+2288/−15000 lines, 57 filesdep +hspecdep +tidal-coredep −microspecdep ~containersdep ~deepseqdep ~hoscsetup-changed
Dependencies added: hspec, tidal-core
Dependencies removed: microspec
Dependency ranges changed: containers, deepseq, hosc, mtl, tidal-link
Files
- BootTidal.hs +20/−72
- README.md +12/−10
- Setup.hs +1/−0
- bench/Memory/Main.hs +5/−5
- bench/Memory/Tidal/Inputs.hs +41/−22
- bench/Memory/Tidal/UIB.hs +17/−11
- bench/Speed/Main.hs +6/−6
- bench/Speed/Tidal/CoreB.hs +69/−36
- bench/Speed/Tidal/Inputs.hs +36/−21
- bench/Speed/Tidal/PatternB.hs +48/−24
- bench/Speed/Tidal/UIB.hs +24/−14
- src/Sound/Tidal/Bjorklund.hs +0/−50
- src/Sound/Tidal/Boot.hs +396/−0
- src/Sound/Tidal/Chords.hs +0/−374
- src/Sound/Tidal/Config.hs +55/−32
- src/Sound/Tidal/Context.hs +2/−4
- src/Sound/Tidal/Control.hs +0/−595
- src/Sound/Tidal/Core.hs +0/−947
- src/Sound/Tidal/ID.hs +3/−4
- src/Sound/Tidal/Params.hs +0/−3557
- src/Sound/Tidal/ParseBP.hs +0/−700
- src/Sound/Tidal/Pattern.hs +0/−1101
- src/Sound/Tidal/Safe/Boot.hs +93/−50
- src/Sound/Tidal/Safe/Context.hs +62/−41
- src/Sound/Tidal/Scales.hs +0/−356
- src/Sound/Tidal/Show.hs +0/−241
- src/Sound/Tidal/Simple.hs +0/−68
- src/Sound/Tidal/Stream.hs +18/−749
- src/Sound/Tidal/Stream/Listen.hs +113/−0
- src/Sound/Tidal/Stream/Main.hs +78/−0
- src/Sound/Tidal/Stream/Process.hs +355/−0
- src/Sound/Tidal/Stream/Target.hs +226/−0
- src/Sound/Tidal/Stream/Types.hs +83/−0
- src/Sound/Tidal/Stream/UI.hs +155/−0
- src/Sound/Tidal/StreamTypes.hs +0/−24
- src/Sound/Tidal/Tempo.hs +0/−306
- src/Sound/Tidal/Time.hs +0/−154
- src/Sound/Tidal/Transition.hs +230/−132
- src/Sound/Tidal/UI.hs +0/−2900
- src/Sound/Tidal/Utils.hs +0/−103
- src/Sound/Tidal/Version.hs +5/−5
- test/Sound/Tidal/ChordsTest.hs +0/−55
- test/Sound/Tidal/ControlTest.hs +0/−49
- test/Sound/Tidal/CoreTest.hs +0/−332
- test/Sound/Tidal/ExceptionsTest.hs +0/−66
- test/Sound/Tidal/ParamsTest.hs +0/−40
- test/Sound/Tidal/ParseTest.hs +0/−254
- test/Sound/Tidal/PatternTest.hs +0/−547
- test/Sound/Tidal/ScalesTest.hs +0/−318
- test/Sound/Tidal/StreamTest.hs +7/−7
- test/Sound/Tidal/UITest.hs +0/−433
- test/Sound/Tidal/UtilsTest.hs +0/−56
- test/Test.hs +2/−23
- test/TestUtils.hs +42/−24
- test/dontcrash.hs +26/−28
- tidal.cabal +43/−50
- tidal.el +15/−4
BootTidal.hs view
@@ -1,82 +1,30 @@+:set -fno-warn-orphans+:set -XMultiParamTypeClasses :set -XOverloadedStrings :set prompt "" -import Sound.Tidal.Context+-- Import all the boot functions and aliases.+import Sound.Tidal.Boot -import System.IO (hSetEncoding, stdout, utf8)-hSetEncoding stdout utf8+default (Rational, Integer, Double, Pattern String) -tidal <- startTidal (superdirtTarget {oLatency = 0.05, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig {cVerbose = True, cFrameTimespan = 1/20})+-- Create a Tidal Stream with the default settings.+-- Use 'mkTidalWith' to customize these settings.+tidalInst <- mkTidal -:{-let only = (hush >>)- p = streamReplace tidal- hush = streamHush tidal- panic = do hush- once $ sound "superpanic"- list = streamList tidal- mute = streamMute tidal- unmute = streamUnmute tidal- unmuteAll = streamUnmuteAll tidal- unsoloAll = streamUnsoloAll tidal- solo = streamSolo tidal- unsolo = streamUnsolo tidal- once = streamOnce tidal- first = streamFirst tidal- asap = once- nudgeAll = streamNudgeAll tidal- all = streamAll tidal- resetCycles = streamResetCycles tidal- setCycle = streamSetCycle tidal- setcps = asap . cps- getcps = streamGetcps tidal- getnow = streamGetnow tidal- 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- jumpMod' i t p = transition tidal True (Sound.Tidal.Transition.jumpMod' t p) 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- 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-:}+-- tidalInst <- mkTidalWith [(superdirtTarget { oLatency = 0.01 }, [superdirtShape])] (setFrameTimespan (1/50) $ setProcessAhead (1/20) defaultConfig) -:{-let getState = streamGet tidal- setI = streamSetI tidal- setF = streamSetF tidal- setS = streamSetS tidal- setR = streamSetR tidal- setB = streamSetB tidal-:}+-- This orphan instance makes the boot aliases work!+-- It has to go after you define 'tidalInst'.+instance Tidally where tidal = tidalInst +-- `enableLink` and `disableLink` can be used to toggle synchronisation using the Link protocol.+-- Uncomment the next line to enable Link on startup.+-- enableLink++-- You can also add your own aliases in this file. For example:+-- fastsquizzed pat = fast 2 $ pat # squiz 1.5++:set -fwarn-orphans -Wno-type-defaults :set prompt "tidal> " :set prompt-cont ""--default (Pattern String, Integer, Double)
README.md view
@@ -1,16 +1,18 @@ -Tidal [](https://github.com/tidalcycles/Tidal/actions)-=====--Language for live coding algorithmic patterns+# Tidal <a href="https://github.com/tidalcycles/Tidal/LICENSE"><img alt="License" src="https://img.shields.io/github/license/tidalcycles/Tidal"></a> -For documentation, mailing list and more info see here: - https://tidalcycles.org/+<a href="https://github.com/tidalcycles/Tidal/actions/workflows/ci.yml"><img alt="Cabal" src="https://img.shields.io/github/actions/workflow/status/tidalcycles/Tidal/ci.yml?label=Cabal&logo=githubactions&logoColor=white"></a>+<a href="https://github.com/tidalcycles/Tidal/actions/workflows/stack.yml"><img alt="Stack" src="https://img.shields.io/github/actions/workflow/status/tidalcycles/Tidal/stack.yml?label=Stack&logo=githubactions&logoColor=white"></a>+<a href="https://github.com/tidalcycles/Tidal/actions/workflows/nix.yml"><img alt="Nix" src="https://img.shields.io/github/actions/workflow/status/tidalcycles/Tidal/nix.yml?label=Nix&logo=githubactions&logoColor=white"></a>+<a href="https://github.com/tidalcycles/Tidal/actions/workflows/windows.yml"><img alt="Windows" src="https://img.shields.io/github/actions/workflow/status/tidalcycles/Tidal/windows.yml?label=Windows&logo=githubactions&logoColor=white"></a> -You can help speed up Tidal development by contributing to the collective fund here: - https://opencollective.com/tidalcycles+[](https://doi.org/10.5281/zenodo.592191)+ +[Uzu language](https://uzu.lurk.org/) for live coding algorithmic patterns -(c) Alex McLean and contributors, 2022+For documentation, mailing list and more info see [here](https://tidalcycles.org/). +You can help speed up Tidal development by [contributing to the collective fund](https://opencollective.com/tidalcycles)! -Distributed under the terms of the GNU Public license version 3 (or later).+(c) Alex McLean and other [contributors](https://github.com/tidalcycles/Tidal/graphs/contributors), 2025 +Licensed under the GNU Public License v3.0. Ports and other projects making use of Tidal source code as a reference for e.g. algorithms and/or types are derivative works and bound by the same license.
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
bench/Memory/Main.hs view
@@ -1,10 +1,10 @@-module Main where +module Main where -import Weigh import Tidal.UIB+import Weigh -main :: IO () -main = - mainWith $ do +main :: IO ()+main =+ mainWith $ do euclidB fixB
bench/Memory/Tidal/Inputs.hs view
@@ -2,32 +2,51 @@ module Tidal.Inputs where -import Sound.Tidal.Pattern-import Sound.Tidal.Core-import Sound.Tidal.ParseBP()+import Sound.Tidal.Control (stut')+import Sound.Tidal.Core (cF, fromList, (#), (|*|)) import Sound.Tidal.Params-import Sound.Tidal.Control-import Sound.Tidal.UI+ ( coarse,+ crush,+ delay,+ delaytime,+ pF,+ s,+ speed,+ up,+ )+import Sound.Tidal.ParseBP ()+import Sound.Tidal.Pattern+ ( Arc,+ ArcF (Arc),+ ControlPattern,+ Pattern,+ Time,+ )+import Sound.Tidal.UI (fix) import Weigh+ ( Column (Allocated, Case, GCs, Live, Max),+ Weigh,+ setColumns,+ ) columns :: Weigh () columns = setColumns [Case, Allocated, Max, Live, GCs] {- Pattern inputs -} xs3 :: [Time]-xs3 = [1..10000]+xs3 = [1 .. 10000] xs4 :: [Time]-xs4 = [1..100000]+xs4 = [1 .. 100000] xs5 :: [Time]-xs5 = [1..1000000]+xs5 = [1 .. 1000000] xs6 :: [Time]-xs6 = [1..10000000]+xs6 = [1 .. 10000000] xsA :: [Time]-xsA = [500000..1500000]+xsA = [500000 .. 1500000] catPattSmall :: [Pattern Time] catPattSmall = pure <$> xs3@@ -72,18 +91,18 @@ 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")+ 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]
bench/Memory/Tidal/UIB.hs view
@@ -1,19 +1,25 @@-module Tidal.UIB where +module Tidal.UIB where -import Weigh -import Tidal.Inputs import Sound.Tidal.Context+ ( euclid,+ euclidFull,+ fast,+ fix,+ _euclidBool,+ )+import Tidal.Inputs (columns, ecA1, ecA2, fixArg1, fixArg2)+import Weigh (Weigh, func, wgroup) -fixB :: Weigh () -fixB = +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+euclidB :: Weigh ()+euclidB =+ wgroup "euclid" $ do+ columns+ func "euclid" (euclid (head ecA1) (ecA1 !! 1)) ecA2+ func "euclidFull" (euclidFull (head ecA1) (ecA1 !! 1) ecA2) ecA2 func "euclidBool" (_euclidBool 1) 100000
bench/Speed/Main.hs view
@@ -1,22 +1,22 @@ module Main where -import Criterion.Main -import Tidal.PatternB+import Criterion.Main import Tidal.CoreB+import Tidal.PatternB import Tidal.UIB -patternBs :: [IO ()] +patternBs :: [IO ()] patternBs = defaultMain <$> [withQueryTimeB, withQueryArcB, withResultArcB, withQueryTimeB, subArcB] -coreBs :: [IO ()] +coreBs :: [IO ()] coreBs = defaultMain <$> [fromListB, stackB, appendB, concatB, _fastB] uiBs :: [IO ()] uiBs = defaultMain <$> [euclidB, fixB] main :: IO ()-main = do - _ <- sequence coreBs +main = do+ _ <- sequence coreBs _ <- sequence patternBs _ <- sequence uiBs return ()
bench/Speed/Tidal/CoreB.hs view
@@ -1,50 +1,83 @@-module Tidal.CoreB where +module Tidal.CoreB where -import Criterion.Main +import Criterion.Main (Benchmark, bench, bgroup, nf, whnf)+import Sound.Tidal.Core+ ( append,+ cat,+ fastAppend,+ fastCat,+ fastFromList,+ fromList,+ overlay,+ stack,+ timeCat,+ )+import Sound.Tidal.Pattern (toTime, _fast) import Tidal.Inputs-import Sound.Tidal.Pattern-import Sound.Tidal.Core + ( catPattBig,+ catPattMed,+ catPattMedB,+ catPattSmall,+ pattApp1,+ pattApp2,+ timeCatBig,+ timeCatMed,+ xs3,+ xs4,+ xs5,+ xs6,+ ) _fastB :: [Benchmark]-_fastB = - [ bgroup "_fast" [- bench "_fast < 0" $ whnf (_fast (-2)) pattApp2 - , bench "_fast > 0" $ whnf (_fast (toTime $ 10^6)) (cat catPattBig) ]+_fastB =+ [ bgroup+ "_fast"+ [ bench "_fast < 0" $ whnf (_fast (-2)) pattApp2,+ bench "_fast > 0" $ whnf (_fast (toTime $ (10 :: Int) ^ (6 :: Int))) (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 ]+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 ]+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 ] +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 ]+stackB :: [Benchmark]+stackB =+ [ bgroup+ "stack"+ [ bench "overlay" $ whnf (overlay pattApp1) pattApp2,+ bench "stack" $ whnf stack catPattBig+ ] ]
bench/Speed/Tidal/Inputs.hs view
@@ -2,27 +2,41 @@ module Tidal.Inputs where -import Sound.Tidal.Pattern-import Sound.Tidal.Core-import Sound.Tidal.ParseBP()+import Sound.Tidal.Core (cF, fromList, (#), (|*|)) import Sound.Tidal.Params-import Sound.Tidal.UI+ ( coarse,+ crush,+ delay,+ delaytime,+ pF,+ s,+ speed,+ )+import Sound.Tidal.ParseBP ()+import Sound.Tidal.Pattern+ ( Arc,+ ArcF (Arc),+ ControlPattern,+ Pattern,+ Time,+ )+import Sound.Tidal.UI (fix) {- Pattern inputs -} xs3 :: [Time]-xs3 = [1..10000]+xs3 = [1 .. 10000] xs4 :: [Time]-xs4 = [1..100000]+xs4 = [1 .. 100000] xs5 :: [Time]-xs5 = [1..1000000]+xs5 = [1 .. 1000000] xs6 :: [Time]-xs6 = [1..10000000]+xs6 = [1 .. 10000000] xsA :: [Time]-xsA = [500000..1500000]+xsA = [500000 .. 1500000] catPattSmall :: [Pattern Time] catPattSmall = pure <$> xs3@@ -67,18 +81,19 @@ 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")+ 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]
bench/Speed/Tidal/PatternB.hs view
@@ -1,45 +1,69 @@-module Tidal.PatternB where +module Tidal.PatternB where -import Criterion.Main-import Tidal.Inputs+import Criterion.Main (Benchmark, bench, bgroup, nf, whnf) import Sound.Tidal.Pattern+ ( ArcF (Arc),+ Time,+ hull,+ sect,+ subArc,+ withQueryArc,+ withQueryTime,+ withResultArc,+ )+import Tidal.Inputs (arcFunc, wqaBig, wqaMed) -arc1 = Arc 3 5 +arc1 :: ArcF Time+arc1 = Arc 3 5++arc2 :: ArcF Time arc2 = Arc 4 6++arc3 :: ArcF Time arc3 = Arc 0 1++arc4 :: ArcF Time 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) ]+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 ]+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 ]+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 ]+subArcB =+ [ bgroup+ "subArc"+ [ bench "intersecting" $ whnf (subArc arc1) arc2,+ bench "non-intersecting" $ whnf (subArc arc3) arc4+ ] ] -sectB :: Benchmark +sectB :: Benchmark sectB = bench "sect" $ whnf (sect arc1) arc2 -hullB :: Benchmark +hullB :: Benchmark hullB = bench "hull" $ whnf (hull arc1) arc2
bench/Speed/Tidal/UIB.hs view
@@ -1,22 +1,32 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} -module Tidal.UIB where +module Tidal.UIB where -import Criterion.Main-import Tidal.Inputs+import Criterion.Main (Benchmark, bench, bgroup, nf, whnf) import Sound.Tidal.Context+ ( euclid,+ euclidFull,+ fast,+ fix,+ _euclidBool,+ )+import Tidal.Inputs (ecA1, ecA2, fixArg1, fixArg2) fixB :: [Benchmark]-fixB = - [ bgroup "fix" [- bench "fix whnf" $ whnf (fix (fast 2) fixArg1) fixArg2- , bench "fix nf" $ nf (fix (fast 2) fixArg1) fixArg2 ]+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]+euclidB :: [Benchmark]+euclidB =+ [ bgroup+ "euclid"+ [ bench "euclid" $ whnf (euclid (head ecA1) (ecA1 !! 1)) ecA2,+ bench "euclidFull" $ whnf (euclidFull (head ecA1) (ecA1 !! 1) ecA2) ecA2,+ bench "euclidBool" $ whnf (_euclidBool 1) 100000+ ] ]
− src/Sound/Tidal/Bjorklund.hs
@@ -1,50 +0,0 @@-module Sound.Tidal.Bjorklund (bjorklund) where--{-- Bjorklund.hs - Euclidean patterns- Copyright (C) 2006-2020, Rohan Drape and contributors-- This library is free software: you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this library. If not, see <http://www.gnu.org/licenses/>.--}---- The below is taken from the hmt library. Tidal used to just include--- the library but removed for now due to dependency problems.. We--- could however likely benefit from other parts of the library..--type STEP a = ((Int,Int),([[a]],[[a]]))--left :: STEP a -> STEP a-left ((i,j),(xs,ys)) =- let (xs',xs'') = splitAt j xs- in ((j,i-j),(zipWith (++) xs' ys,xs''))--right :: STEP a -> STEP a-right ((i,j),(xs,ys)) =- let (ys',ys'') = splitAt i ys- in ((i,j-i),(zipWith (++) xs ys',ys''))--bjorklund' :: STEP a -> STEP a-bjorklund' (n,x) =- let (i,j) = n- in if min i j <= 1- then (n,x)- else bjorklund' (if i > j then left (n,x) else right (n,x))--bjorklund :: (Int,Int) -> [Bool]-bjorklund (i,j') =- let j = j' - i- x = replicate i [True]- y = replicate j [False]- (_,(x',y')) = bjorklund' ((i,j),(x,y))- in concat x' ++ concat y'
+ src/Sound/Tidal/Boot.hs view
@@ -0,0 +1,396 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++module Sound.Tidal.Boot+ ( Tidally (..),+ OscMap,+ mkOscMap,+ mkTidal,+ mkTidalWith,+ only,+ p,+ _p,+ p_,+ hush,+ panic,+ list,+ mute,+ unmute,+ unmuteAll,+ unsoloAll,+ solo,+ unsolo,+ once,+ asap,+ first,+ nudgeAll,+ all,+ resetCycles,+ setCycle,+ setcps,+ getcps,+ setbpm,+ getbpm,+ getnow,+ enableLink,+ disableLink,+ d1,+ d2,+ d3,+ d4,+ d5,+ d6,+ d7,+ d8,+ d9,+ d10,+ d11,+ d12,+ d13,+ d14,+ d15,+ d16,+ _d1,+ _d2,+ _d3,+ _d4,+ _d5,+ _d6,+ _d7,+ _d8,+ _d9,+ _d10,+ _d11,+ _d12,+ _d13,+ _d14,+ _d15,+ _d16,+ d1_,+ d2_,+ d3_,+ d4_,+ d5_,+ d6_,+ d7_,+ d8_,+ d9_,+ d10_,+ d11_,+ d12_,+ d13_,+ d14_,+ d15_,+ d16_,+ getState,+ setI,+ setF,+ setS,+ setR,+ setB,+ xfade,+ xfadeIn,+ module Sound.Tidal.Context,+ histpan,+ wait,+ waitT,+ jump,+ jumpIn,+ jumpIn',+ jumpMod,+ jumpMod',+ mortal,+ interpolate,+ interpolateIn,+ clutch,+ clutchIn,+ anticipate,+ anticipateIn,+ forId,+ )+where++{-+ Boot.hs - Shortcuts for using an in-scope Tidal Stream.+ Copyright (C) 2023, Alex McLean and contributors++ This library is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This library is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this library. If not, see <http://www.gnu.org/licenses/>.+-}++import Sound.Tidal.Context hiding (anticipate, anticipateIn, clutch, clutchIn, histpan, interpolate, interpolateIn, jump, jumpIn, jumpIn', jumpMod, jumpMod', mortal, mortalOverlay, wait, waitT, wash, washIn, xfadeIn)+import Sound.Tidal.ID (ID)+import System.IO (hSetEncoding, stdout, utf8)+import Prelude hiding (all, (*>), (<*))++-- | Functions using this constraint can access the in-scope Tidal instance.+-- You must implement an instance of this in 'BootTidal.hs'. Note that GHC+-- will complain that it is an "orphan" instance, but that is ok.+class Tidally where+ tidal :: Stream++type OscMap = [(Target, [OSC])]++-- | A reasonable OscMap+mkOscMap :: OscMap+mkOscMap = [(superdirtTarget {oLatency = 0.05, oAddress = "127.0.0.1", oPort = 57120}, [superdirtShape])]++-- | Creates a Tidal instance using default config. Use 'mkTidalWith' to customize.+mkTidal :: IO Stream+mkTidal = mkTidalWith mkOscMap defaultConfig++-- | See 'Sound.Tidal.Stream.startStream'.+mkTidalWith :: OscMap -> Config -> IO Stream+mkTidalWith oscmap config = do+ hSetEncoding stdout utf8+ startStream config oscmap++-- | 'hush' then execute the given action.+only :: (Tidally) => IO () -> IO ()+only = (hush >>)++-- | See 'Sound.Tidal.Stream.streamReplace'.+p :: (Tidally) => ID -> ControlPattern -> IO ()+p = streamReplace tidal++-- | Silences a specific stream, regardless of ControlPattern input. Useful for rapid muting of streams+_p :: (Tidally) => ID -> ControlPattern -> IO ()+_p k _ = streamReplace tidal k silence++-- | Silences a specific stream, regardless of ControlPattern input. Useful for rapid muting of streams+p_ :: (Tidally) => ID -> ControlPattern -> IO ()+p_ = _p++-- | See 'Sound.Tidal.Stream.streamHush'.+hush :: (Tidally) => IO ()+hush = streamHush tidal++panic :: (Tidally) => IO ()+panic = hush >> once (sound "superpanic")++-- | See 'Sound.Tidal.Stream.streamList'.+list :: (Tidally) => IO ()+list = streamList tidal++-- | See 'Sound.Tidal.Stream.streamMute'.+mute :: (Tidally) => ID -> IO ()+mute = streamMute tidal++-- | See 'Sound.Tidal.Stream.streamUnmute'.+unmute :: (Tidally) => ID -> IO ()+unmute = streamUnmute tidal++-- | See 'Sound.Tidal.Stream.streamUnmuteAll'.+unmuteAll :: (Tidally) => IO ()+unmuteAll = streamUnmuteAll tidal++-- | See 'Sound.Tidal.Stream.streamUnsoloAll'.+unsoloAll :: (Tidally) => IO ()+unsoloAll = streamUnsoloAll tidal++-- | See 'Sound.Tidal.Stream.streamSolo'.+solo :: (Tidally) => ID -> IO ()+solo = streamSolo tidal++-- | See 'Sound.Tidal.Stream.streamUnsolo'.+unsolo :: (Tidally) => ID -> IO ()+unsolo = streamUnsolo tidal++-- | See 'Sound.Tidal.Stream.streamOnce'.+once :: (Tidally) => ControlPattern -> IO ()+once = streamOnce tidal++-- | An alias for 'once'.+asap :: (Tidally) => ControlPattern -> IO ()+asap = once++-- | See 'Sound.Tidal.Stream.first'.+first :: (Tidally) => ControlPattern -> IO ()+first = streamFirst tidal++-- | See 'Sound.Tidal.Stream.nudgeAll'.+nudgeAll :: (Tidally) => Double -> IO ()+nudgeAll = streamNudgeAll tidal++-- | See 'Sound.Tidal.Stream.streamAll'.+all :: (Tidally) => (ControlPattern -> ControlPattern) -> IO ()+all = streamAll tidal++-- | See 'Sound.Tidal.Stream.resetCycles'.+resetCycles :: (Tidally) => IO ()+resetCycles = streamResetCycles tidal++-- | See 'Sound.Tidal.Stream.streamSetCycle'.+setCycle :: (Tidally) => Time -> IO ()+setCycle = streamSetCycle tidal++-- | See 'Sound.Tidal.Params.cps'.+setcps :: (Tidally) => Pattern Double -> IO ()+setcps = once . cps++-- | See 'Sound.Tidal.Stream.streamGetCPS'.+getcps :: (Tidally) => IO Time+getcps = streamGetCPS tidal++-- | See 'Sound.Tidal.Stream.streamGetBPM'.+setbpm :: (Tidally) => Time -> IO ()+setbpm = streamSetBPM tidal++-- | See 'Sound.Tidal.Stream.streamGetBPM'.+getbpm :: (Tidally) => IO Time+getbpm = streamGetBPM tidal++-- | See 'Sound.Tidal.Stream.streamGetnow'.+getnow :: (Tidally) => IO Time+getnow = streamGetNow tidal++enableLink :: (Tidally) => IO ()+enableLink = streamEnableLink tidal++disableLink :: (Tidally) => IO ()+disableLink = streamDisableLink tidal++-- | Replace what's playing on the given orbit.+d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14, d15, d16 :: (Tidally) => ControlPattern -> IO ()+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++-- | Rapidly silence what's playing on the given orbit+_d1, _d2, _d3, _d4, _d5, _d6, _d7, _d8, _d9, _d10, _d11, _d12, _d13, _d14, _d15, _d16 :: (Tidally) => ControlPattern -> IO ()+_d1 = _p 1+_d2 = _p 2+_d3 = _p 3+_d4 = _p 4+_d5 = _p 5+_d6 = _p 6+_d7 = _p 7+_d8 = _p 8+_d9 = _p 9+_d10 = _p 10+_d11 = _p 11+_d12 = _p 12+_d13 = _p 13+_d14 = _p 14+_d15 = _p 15+_d16 = _p 16++-- | Rapidly silence what's playing on the given orbit+d1_, d2_, d3_, d4_, d5_, d6_, d7_, d8_, d9_, d10_, d11_, d12_, d13_, d14_, d15_, d16_ :: (Tidally) => ControlPattern -> IO ()+d1_ = _d1+d2_ = _d2+d3_ = _d3+d4_ = _d4+d5_ = _d5+d6_ = _d6+d7_ = _d7+d8_ = _d8+d9_ = _d9+d10_ = _d10+d11_ = _d11+d12_ = _d12+d13_ = _d13+d14_ = _d14+d15_ = _d15+d16_ = _d16++-- | See 'Sound.Tidal.Stream.streamGet'.+getState :: (Tidally) => String -> IO (Maybe Value)+getState = streamGet tidal++-- | See 'Sound.Tidal.Stream.streamSetI'.+setI :: (Tidally) => String -> Pattern Int -> IO ()+setI = streamSetI tidal++-- | See 'Sound.Tidal.Stream.streamSetF'.+setF :: (Tidally) => String -> Pattern Double -> IO ()+setF = streamSetF tidal++-- | See 'Sound.Tidal.Stream.streamSetS'.+setS :: (Tidally) => String -> Pattern String -> IO ()+setS = streamSetS tidal++-- | See 'Sound.Tidal.Stream.streamSetR'.+setR :: (Tidally) => String -> Pattern Rational -> IO ()+setR = streamSetR tidal++-- | See 'Sound.Tidal.Stream.streamSetB'.+setB :: (Tidally) => String -> Pattern Bool -> IO ()+setB = streamSetB tidal++xfade :: (Tidally) => ID -> ControlPattern -> IO ()+xfade i = transition tidal True (_xfadeIn 4) i++xfadeIn :: (Tidally) => ID -> Time -> ControlPattern -> IO ()+xfadeIn i t = transition tidal True (_xfadeIn t) i++histpan :: (Tidally) => ID -> Int -> ControlPattern -> IO ()+histpan i t = transition tidal True (_histpan t) i++wait :: (Tidally) => ID -> Time -> ControlPattern -> IO ()+wait i t = transition tidal True (_wait t) i++waitT :: (Tidally) => ID -> (Time -> [ControlPattern] -> ControlPattern) -> Time -> ControlPattern -> IO ()+waitT i f t = transition tidal True (_waitT f t) i++jump :: (Tidally) => ID -> ControlPattern -> IO ()+jump i = transition tidal True _jump i++jumpIn :: (Tidally) => ID -> Int -> ControlPattern -> IO ()+jumpIn i t = transition tidal True (_jumpIn t) i++jumpIn' :: (Tidally) => ID -> Int -> ControlPattern -> IO ()+jumpIn' i t = transition tidal True (_jumpIn' t) i++jumpMod :: (Tidally) => ID -> Int -> ControlPattern -> IO ()+jumpMod i t = transition tidal True (_jumpMod t) i++jumpMod' :: (Tidally) => ID -> Int -> Int -> ControlPattern -> IO ()+jumpMod' i t pat = transition tidal True (_jumpMod' t pat) i++mortal :: (Tidally) => ID -> Time -> Time -> ControlPattern -> IO ()+mortal i lifespan releasetime = transition tidal True (_mortal lifespan releasetime) i++interpolate :: (Tidally) => ID -> ControlPattern -> IO ()+interpolate i = transition tidal True _interpolate i++interpolateIn :: (Tidally) => ID -> Time -> ControlPattern -> IO ()+interpolateIn i t = transition tidal True (_interpolateIn t) i++clutch :: (Tidally) => ID -> ControlPattern -> IO ()+clutch i = transition tidal True _clutch i++clutchIn :: (Tidally) => ID -> Time -> ControlPattern -> IO ()+clutchIn i t = transition tidal True (_clutchIn t) i++anticipate :: (Tidally) => ID -> ControlPattern -> IO ()+anticipate i = transition tidal True _anticipate i++anticipateIn :: (Tidally) => ID -> Time -> ControlPattern -> IO ()+anticipateIn i t = transition tidal True (_anticipateIn t) i++forId :: (Tidally) => ID -> Time -> ControlPattern -> IO ()+forId i t = transition tidal False (_mortalOverlay t) i
− src/Sound/Tidal/Chords.hs
@@ -1,374 +0,0 @@-module Sound.Tidal.Chords where--{-- Chords.hs - For .. chords- Copyright (C) 2020, Alex McLean and contributors-- This library is free software: you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this library. If not, see <http://www.gnu.org/licenses/>.--}--import Data.Maybe--import Sound.Tidal.Pattern---- * Chord definitions---- ** Major chords--major :: Num a => [a]-major = [0,4,7]-aug :: Num a => [a]-aug = [0,4,8]-six :: Num a => [a]-six = [0,4,7,9]-sixNine :: Num a => [a]-sixNine = [0,4,7,9,14]-major7 :: Num a => [a]-major7 = [0,4,7,11]-major9 :: Num a => [a]-major9 = [0,4,7,11,14]-add9 :: Num a => [a]-add9 = [0,4,7,14]-major11 :: Num a => [a]-major11 = [0,4,7,11,14,17]-add11 :: Num a => [a]-add11 = [0,4,7,17]-major13 :: Num a => [a]-major13 = [0,4,7,11,14,21]-add13 :: Num a => [a]-add13 = [0,4,7,21]---- ** Dominant chords--dom7 :: Num a => [a]-dom7 = [0,4,7,10]-dom9 :: Num a => [a]-dom9 = [0,4,7,14]-dom11 :: Num a => [a]-dom11 = [0,4,7,17]-dom13 :: Num a => [a]-dom13 = [0,4,7,21]-sevenFlat5 :: Num a => [a]-sevenFlat5 = [0,4,6,10]-sevenSharp5 :: Num a => [a]-sevenSharp5 = [0,4,8,10]-sevenFlat9 :: Num a => [a]-sevenFlat9 = [0,4,7,10,13]-nine :: Num a => [a]-nine = [0,4,7,10,14]-eleven :: Num a => [a]-eleven = [0,4,7,10,14,17]-thirteen :: Num a => [a]-thirteen = [0,4,7,10,14,17,21]---- ** Minor chords--minor :: Num a => [a]-minor = [0,3,7]-diminished :: Num a => [a]-diminished = [0,3,6]-minorSharp5 :: Num a => [a]-minorSharp5 = [0,3,8]-minor6 :: Num a => [a]-minor6 = [0,3,7,9]-minorSixNine :: Num a => [a]-minorSixNine = [0,3,9,7,14]-minor7flat5 :: Num a => [a]-minor7flat5 = [0,3,6,10]-minor7 :: Num a => [a]-minor7 = [0,3,7,10]-minor7sharp5 :: Num a => [a]-minor7sharp5 = [0,3,8,10]-minor7flat9 :: Num a => [a]-minor7flat9 = [0,3,7,10,13]-minor7sharp9 :: Num a => [a]-minor7sharp9 = [0,3,7,10,15]-diminished7 :: Num a => [a]-diminished7 = [0,3,6,9]-minor9 :: Num a => [a]-minor9 = [0,3,7,10,14]-minor11 :: Num a => [a]-minor11 = [0,3,7,10,14,17]-minor13 :: Num a => [a]-minor13 = [0,3,7,10,14,17,21]-minorMajor7 :: Num a => [a]-minorMajor7 = [0,3,7,11]---- ** Other chords--one :: Num a => [a]-one = [0]-five :: Num a => [a]-five = [0,7]-sus2 :: Num a => [a]-sus2 = [0,2,7]-sus4 :: Num a => [a]-sus4 = [0,5,7]-sevenSus2 :: Num a => [a]-sevenSus2 = [0,2,7,10]-sevenSus4 :: Num a => [a]-sevenSus4 = [0,5,7,10]-nineSus4 :: Num a => [a]-nineSus4 = [0,5,7,10,14]---- ** Questionable chords--sevenFlat10 :: Num a => [a]-sevenFlat10 = [0,4,7,10,15]-nineSharp5 :: Num a => [a]-nineSharp5 = [0,1,13]-minor9sharp5 :: Num a => [a]-minor9sharp5 = [0,1,14]-sevenSharp5flat9 :: Num a => [a]-sevenSharp5flat9 = [0,4,8,10,13]-minor7sharp5flat9 :: Num a => [a]-minor7sharp5flat9 = [0,3,8,10,13]-elevenSharp :: Num a => [a]-elevenSharp = [0,4,7,10,14,18]-minor11sharp :: Num a => [a]-minor11sharp = [0,3,7,10,14,18]---- * Chord functions---- | @chordate cs m n@ selects the @n@th "chord" (a chord is a list of Ints)--- from a list of chords @cs@ and transposes it by @m@--- chordate :: Num b => [[b]] -> b -> Int -> [b]--- chordate cs m n = map (+m) $ cs!!n---- | @enchord chords pn pc@ turns every note in the note pattern @pn@ into--- a chord, selecting from the chord lists @chords@ using the index pattern--- @pc@. For example, @Chords.enchord [Chords.major Chords.minor] "c g" "0 1"@--- will create a pattern of a C-major chord followed by a G-minor chord.--- enchord :: Num a => [[a]] -> Pattern a -> Pattern Int -> Pattern a--- enchord chords pn pc = flatpat $ (chordate chords) <$> pn <*> pc--{-|- The @chordTable@ function outputs a list of all available chords and their- corresponding notes. For example, its first entry is @("major",[0,4,7])@ which- means that a major triad is formed by the root (0), the major third (4 semitones- above the root), and the perfect fifth (7 semitones above the root).-- As the list is big, you can use the function 'chordL'.-- If you know the notes from a chord, but can’t find the name of it, you can use this Haskell code to do a reverse look up into the table:-- > filter (\(_,x)->x==[0,4,7,10]) chordTable-- This will output @[("dom7",[0,4,7,10])]@-- (You’ll need to run @import Sound.Tidal.Chords@ before using this function.)--}-chordTable :: Num a => [(String, [a])]-chordTable = [("major", major),- ("maj", major),- ("M", major),- ("aug", aug),- ("plus", aug),- ("sharp5", aug),- ("six", six),- ("6", six),- ("sixNine", sixNine),- ("six9", sixNine),- ("sixby9", sixNine),- ("6by9", sixNine),- ("major7", major7),- ("maj7", major7),- ("major9", major9),- ("maj9", major9),- ("add9", add9),- ("major11", major11),- ("maj11", major11),- ("add11", add11),- ("major13", major13),- ("maj13", major13),- ("add13", add13),- ("dom7", dom7),- ("dom9", dom9),- ("dom11", dom11),- ("dom13", dom13),- ("sevenFlat5", sevenFlat5),- ("7f5", sevenFlat5),- ("sevenSharp5", sevenSharp5),- ("7s5", sevenSharp5),- ("sevenFlat9", sevenFlat9),- ("7f9", sevenFlat9),- ("nine", nine),- ("eleven", eleven),- ("11", eleven),- ("thirteen", thirteen),- ("13", thirteen),- ("minor", minor),- ("min", minor),- ("m", minor),- ("diminished", diminished),- ("dim", diminished),- ("minorSharp5", minorSharp5),- ("msharp5", minorSharp5),- ("mS5", minorSharp5),- ("minor6", minor6),- ("min6", minor6),- ("m6", minor6),- ("minorSixNine", minorSixNine),- ("minor69", minorSixNine),- ("min69", minorSixNine),- ("minSixNine", minorSixNine),- ("m69", minorSixNine),- ("mSixNine", minorSixNine),- ("m6by9", minorSixNine),- ("minor7flat5", minor7flat5),- ("minor7f5", minor7flat5),- ("min7flat5", minor7flat5),- ("min7f5", minor7flat5),- ("m7flat5", minor7flat5),- ("m7f5", minor7flat5),- ("minor7", minor7),- ("min7", minor7),- ("m7", minor7),- ("minor7sharp5", minor7sharp5),- ("minor7s5", minor7sharp5),- ("min7sharp5", minor7sharp5),- ("min7s5", minor7sharp5),- ("m7sharp5", minor7sharp5),- ("m7s5", minor7sharp5),- ("minor7flat9", minor7flat9),- ("minor7f9", minor7flat9),- ("min7flat9", minor7flat9),- ("min7f9", minor7flat9),- ("m7flat9", minor7flat9),- ("m7f9", minor7flat9),- ("minor7sharp9", minor7sharp9),- ("minor7s9", minor7sharp9),- ("min7sharp9", minor7sharp9),- ("min7s9", minor7sharp9),- ("m7sharp9", minor7sharp9),- ("m7s9", minor7sharp9),- ("diminished7", diminished7),- ("dim7", diminished7),- ("minor9", minor9),- ("min9", minor9),- ("m9", minor9),- ("minor11", minor11),- ("min11", minor11),- ("m11", minor11),- ("minor13", minor13),- ("min13", minor13),- ("m13", minor13),- ("minorMajor7", minorMajor7),- ("minMaj7", minorMajor7),- ("mmaj7", minorMajor7),- ("one", one),- ("1", one),- ("five", five),- ("5", five),- ("sus2", sus2),- ("sus4", sus4),- ("sevenSus2", sevenSus2),- ("7sus2", sevenSus2),- ("sevenSus4", sevenSus4),- ("7sus4", sevenSus4),- ("nineSus4", nineSus4),- ("ninesus4", nineSus4),- ("9sus4", nineSus4),- ("sevenFlat10", sevenFlat10),- ("7f10", sevenFlat10),- ("nineSharp5", nineSharp5),- ("9sharp5", nineSharp5),- ("9s5", nineSharp5),- ("minor9sharp5", minor9sharp5),- ("minor9s5", minor9sharp5),- ("min9sharp5", minor9sharp5),- ("min9s5", minor9sharp5),- ("m9sharp5", minor9sharp5),- ("m9s5", minor9sharp5),- ("sevenSharp5flat9", sevenSharp5flat9),- ("7s5f9", sevenSharp5flat9),- ("minor7sharp5flat9", minor7sharp5flat9),- ("m7sharp5flat9", minor7sharp5flat9),- ("elevenSharp", elevenSharp),- ("11s", elevenSharp),- ("minor11sharp", minor11sharp),- ("m11sharp", minor11sharp),- ("m11s", minor11sharp)- ]---- | Look up a specific chord: @chordL "minor7"@ returns @(0>1)|[0,3,7,10]@.-chordL :: Num a => Pattern String -> Pattern [a]-chordL p = (\name -> fromMaybe [] $ lookup name chordTable) <$> p--{-|-Outputs all the available chords:--@-major maj M aug plus sharp5 six 6 sixNine six9 sixby9 6by9 major7 maj7-major9 maj9 add9 major11 maj11 add11 major13 maj13 add13 dom7 dom9 dom11-dom13 sevenFlat5 7f5 sevenSharp5 7s5 sevenFlat9 7f9 nine eleven 11 thirteen 13-minor min m diminished dim minorSharp5 msharp5 mS5 minor6 min6 m6 minorSixNine-minor69 min69 minSixNine m69 mSixNine m6by9 minor7flat5 minor7f5 min7flat5-min7f5 m7flat5 m7f5 minor7 min7 m7 minor7sharp5 minor7s5 min7sharp5 min7s5-m7sharp5 m7s5 minor7flat9 minor7f9 min7flat9 min7f9 m7flat9 m7f9 minor7sharp9-minor7s9 min7sharp9 min7s9 m7sharp9 m7s9 diminished7 dim7 minor9 min9 m9-minor11 min11 m11 minor13 min13 m13 minorMajor7 minMaj7 mmaj7 one 1 five 5-sus2 sus4 sevenSus2 7sus2 sevenSus4 7sus4 nineSus4 ninesus4 9sus4 sevenFlat10-7f10 nineSharp5 9sharp5 9s5 minor9sharp5 minor9s5 min9sharp5 min9s5 m9sharp5-m9s5 sevenSharp5flat9 7s5f9 minor7sharp5flat9 m7sharp5flat9 elevenSharp 11s-minor11sharp m11sharp m11s-@--(You’ll need to run @import Sound.Tidal.Chords@ before using this function.)--}-chordList :: String-chordList = unwords $ map fst (chordTable :: [(String, [Int])])--data Modifier = Range Int | Drop Int | Invert | Open deriving Eq--instance Show Modifier where- show (Range i) = "Range " ++ show i- show (Drop i) = "Drop " ++ show i- show Invert = "Invert"- show Open = "Open"--applyModifier :: (Enum a, Num a) => Modifier -> [a] -> [a]-applyModifier (Range i) ds = take i $ concatMap (\x -> map (+ x) ds) [0,12..]-applyModifier Invert [] = []-applyModifier Invert (d:ds) = ds ++ [d+12]-applyModifier Open ds = case length ds > 2 of- True -> [ (ds !! 0 - 12), (ds !! 2 - 12), (ds !! 1) ] ++ reverse (take (length ds - 3) (reverse ds))- False -> ds-applyModifier (Drop i) ds = case length ds < i of- True -> ds- False -> (ds!!s - 12):(xs ++ drop 1 ys)- where (xs,ys) = splitAt s ds- s = length ds - i--applyModifierPat :: (Num a, Enum a) => Pattern [a] -> Pattern [Modifier] -> Pattern [a]-applyModifierPat pat modsP = do- ch <- pat- ms <- modsP- return $ foldl (flip applyModifier) ch ms--applyModifierPatSeq :: (Num a, Enum a) => (a -> b) -> Pattern [a] -> [Pattern [Modifier]] -> Pattern [b]-applyModifierPatSeq f pat [] = fmap (map f) pat-applyModifierPatSeq f pat (mP:msP) = applyModifierPatSeq f (applyModifierPat pat mP) msP--chordToPatSeq :: (Num a, Enum a) => (a -> b) -> Pattern a -> Pattern String -> [Pattern [Modifier]] -> Pattern b-chordToPatSeq f noteP nameP modsP = uncollect $ do- n <- noteP- name <- nameP- let ch = map (+ n) (fromMaybe [0] $ lookup name chordTable)- applyModifierPatSeq f (return ch) modsP---- | Turns a given pattern of some 'Num' type, a pattern of chord names, and a--- list of patterns of modifiers into a chord pattern-chord :: (Num a, Enum a) => Pattern a -> Pattern String -> [Pattern [Modifier]] -> Pattern a-chord = chordToPatSeq id
src/Sound/Tidal/Config.hs view
@@ -1,7 +1,9 @@ module Sound.Tidal.Config where -import Data.Int(Int64)-import Foreign.C.Types (CDouble)+import Control.Monad (when)+import Data.Int (Int64)+import Foreign.C (CDouble)+import qualified Sound.Tidal.Clock as Clock {- Config.hs - For default Tidal configuration values.@@ -21,35 +23,56 @@ along with this library. If not, see <http://www.gnu.org/licenses/>. -} -data Config = Config {cCtrlListen :: Bool,- cCtrlAddr :: String,- cCtrlPort :: Int,- cCtrlBroadcast :: Bool,- cFrameTimespan :: Double,- cEnableLink :: Bool,- cProcessAhead :: Double,- cTempoAddr :: String,- cTempoPort :: Int,- cTempoClientPort :: Int,- cSkipTicks :: Int64,- cVerbose :: Bool,- cQuantum :: CDouble,- cBeatsPerCycle :: CDouble- }+data Config = Config+ { cCtrlListen :: Bool,+ cCtrlAddr :: String,+ cCtrlPort :: Int,+ cCtrlBroadcast :: Bool,+ cVerbose :: Bool,+ cQuantum :: CDouble,+ cBeatsPerCycle :: CDouble,+ cFrameTimespan :: Double,+ cEnableLink :: Bool,+ cSkipTicks :: Int64,+ cProcessAhead :: Double+ } defaultConfig :: Config-defaultConfig = Config {cCtrlListen = True,- cCtrlAddr ="127.0.0.1",- cCtrlPort = 6010,- cCtrlBroadcast = False,- cFrameTimespan = 1/20,- cEnableLink = True,- cProcessAhead = 3/10,- cTempoAddr = "127.0.0.1",- cTempoPort = 9160,- cTempoClientPort = 0, -- choose at random- cSkipTicks = 10,- cVerbose = True,- cQuantum = 4,- cBeatsPerCycle = 4- }+defaultConfig =+ Config+ { cCtrlListen = True,+ cCtrlAddr = "127.0.0.1",+ cCtrlPort = 6010,+ cCtrlBroadcast = False,+ cVerbose = True,+ cFrameTimespan = Clock.clockFrameTimespan Clock.defaultConfig,+ cEnableLink = Clock.clockEnableLink Clock.defaultConfig,+ cProcessAhead = Clock.clockProcessAhead Clock.defaultConfig,+ cSkipTicks = Clock.clockSkipTicks Clock.defaultConfig,+ cQuantum = Clock.clockQuantum Clock.defaultConfig,+ cBeatsPerCycle = Clock.clockBeatsPerCycle Clock.defaultConfig+ }++toClockConfig :: Config -> Clock.ClockConfig+toClockConfig conf =+ Clock.ClockConfig+ { Clock.clockFrameTimespan = cFrameTimespan conf,+ Clock.clockEnableLink = cEnableLink conf,+ Clock.clockProcessAhead = cProcessAhead conf,+ Clock.clockSkipTicks = cSkipTicks conf,+ Clock.clockQuantum = cQuantum conf,+ Clock.clockBeatsPerCycle = cBeatsPerCycle conf+ }++verbose :: Config -> String -> IO ()+verbose c s = when (cVerbose c) $ putStrLn s++setFrameTimespan :: Double -> Config -> Config+setFrameTimespan n c =+ c {cFrameTimespan = n}++setProcessAhead :: Double -> Config -> Config+setProcessAhead n c =+ c+ { cProcessAhead = n+ }
src/Sound/Tidal/Context.hs view
@@ -18,11 +18,7 @@ along with this library. If not, see <http://www.gnu.org/licenses/>. -} -import Prelude hiding ((<*), (*>))- import Data.Ratio as C--import Sound.Tidal.Config as C import Sound.Tidal.Control as C import Sound.Tidal.Core as C import Sound.Tidal.Params as C@@ -31,7 +27,9 @@ import Sound.Tidal.Scales as C import Sound.Tidal.Show as C import Sound.Tidal.Simple as C+import Sound.Tidal.Stepwise as C import Sound.Tidal.Stream as C import Sound.Tidal.Transition as C import Sound.Tidal.UI as C import Sound.Tidal.Version as C+import Prelude hiding (all, drop, take, (*>), (<*))
− src/Sound/Tidal/Control.hs
@@ -1,595 +0,0 @@-{-# LANGUAGE FlexibleInstances, OverloadedStrings, FlexibleContexts, BangPatterns #-}--module Sound.Tidal.Control where-{-- Control.hs - Functions which concern control patterns, which are- patterns of hashmaps, used for synth control values.-- Copyright (C) 2020, Alex McLean and contributors-- This library is free software: you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this library. If not, see <http://www.gnu.org/licenses/>.--}--import Prelude hiding ((<*), (*>))--import qualified Data.Map.Strict as Map-import Data.Maybe (fromMaybe, isJust, fromJust)-import Data.Ratio--import Sound.Tidal.Pattern-import Sound.Tidal.Core-import Sound.Tidal.StreamTypes (patternTimeID)-import Sound.Tidal.UI-import qualified Sound.Tidal.Params as P-import Sound.Tidal.Utils--{- | `spin` will "spin" and layer up a pattern the given number of times,-with each successive layer offset in time by an additional @1/n@ of a cycle,-and panned by an additional @1/n@. The result is a pattern that seems to spin-around. This function work well on multichannel systems.--> d1 $ slow 3-> $ spin 4-> $ sound "drum*3 tabla:4 [arpy:2 ~ arpy] [can:2 can:3]"--}-spin :: Pattern Int -> ControlPattern -> ControlPattern-spin = tParam _spin--_spin :: Int -> ControlPattern -> ControlPattern-_spin copies p =- stack $ map (\i -> let offset = toInteger i % toInteger copies in- offset `rotL` p- # P.pan (pure $ fromRational offset)- )- [0 .. (copies - 1)]----{- | `chop` granularises every sample in place as it is played, turning a- pattern of samples into a pattern of sample parts. Can be used to explore- granular synthesis.-- Use an integer value to specify how many granules each sample is chopped into:-- > d1 $ chop 16 $ sound "arpy arp feel*4 arpy*4"-- Different values of @chop@ can yield very different results, depending on the- samples used:-- > d1 $ chop 16 $ sound (samples "arpy*8" (run 16))- > d1 $ chop 32 $ sound (samples "arpy*8" (run 16))- > d1 $ chop 256 $ sound "bd*4 [sn cp] [hh future]*2 [cp feel]"-- You can also use @chop@ (or 'striate') with very long samples to cut them into short- chunks and pattern those chunks. The following cuts a sample into 32 parts, and- plays it over 8 cycles:-- > d1 $ loopAt 8 $ chop 32 $ sound "bev"-- The 'loopAt' takes care of changing the speed of sample playback so that the- sample fits in the given number of cycles perfectly. As a result, in the above- the granules line up perfectly, so you can’t really hear that the sample has- been cut into bits. Again, this becomes more apparent when you do further- manipulations of the pattern, for example 'rev' to reverse the order of the cut- up bits:-- > d1 $ loopAt 8 $ rev $ chop 32 $ sound "bev"--}-chop :: Pattern Int -> ControlPattern -> ControlPattern-chop = tParam _chop--chopArc :: Arc -> Int -> [Arc]-chopArc (Arc s e) n = map (\i -> Arc (s + (e-s)*(fromIntegral i/fromIntegral n)) (s + (e-s)*(fromIntegral (i+1) / fromIntegral n))) [0 .. n-1]--_chop :: Int -> ControlPattern -> ControlPattern-_chop n = withEvents (concatMap chopEvent)- where -- for each part,- chopEvent :: Event ValueMap -> [Event ValueMap]- 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- arcs w' p' = numberedArcs p' $ chopArc w' n- -- each bit is a new whole, with part that's the intersection of old part and new whole- -- (discard new parts that don't intersect with the old part)- numberedArcs :: Arc -> [Arc] -> [(Int, (Arc, Arc))]- numberedArcs p' as = map ((fromJust <$>) <$>) $ filter (isJust . snd . snd) $ enumerate $ map (\a -> (a, subArc p' a)) as- -- begin set to i/n, end set to i+1/n- -- 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 :: Context -> ValueMap -> Int -> (Int, (Arc, Arc)) -> Event ValueMap- 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- getF v'- d = e-b- b' = ((fromIntegral i/fromIntegral n') * d) + b- e' = ((fromIntegral (i+1) / fromIntegral n') * d) + b--{---- A simpler definition than the above, but this version doesn't chop--- with multiple chops, and only works with a single 'pure' event..-_chop' :: Int -> ControlPattern -> ControlPattern-_chop' n p = begin (fromList begins) # end (fromList ends) # p- where step = 1/(fromIntegral n)- begins = [0,step .. (1-step)]- ends = (tail begins) ++ [1]--}---{-| Striate is a kind of granulator, cutting samples into bits in a similar to-chop, but the resulting bits are organised differently. For example:--> d1 $ striate 3 $ sound "ho ho:2 ho:3 hc"--This plays the loop the given number of times, but triggers progressive portions-of each sample. So in this case it plays the loop three times, the first-time playing the first third of each sample, then the second time playing the-second third of each sample, and lastly playing the last third of each sample.-Replacing @striate@ with 'chop' above, one can hear that the ''chop' version-plays the bits from each chopped-up sample in turn, while @striate@ "interlaces"-the cut up bits of samples together.--You can also use @striate@ with very long samples, to cut them into short-chunks and pattern those chunks. This is where things get towards granular-synthesis. The following cuts a sample into 128 parts, plays it over 8 cycles-and manipulates those parts by reversing and rotating the loops:--> d1 $ slow 8 $ striate 128 $ sound "bev"--}--striate :: Pattern Int -> ControlPattern -> ControlPattern-striate = tParam _striate--_striate :: Int -> ControlPattern -> ControlPattern-_striate n p = fastcat $ map offset [0 .. n-1]- where offset i = mergePlayRange (fromIntegral i / fromIntegral n, fromIntegral (i+1) / fromIntegral n) <$> p--mergePlayRange :: (Double, Double) -> ValueMap -> ValueMap-mergePlayRange (b,e) cm = Map.insert "begin" (VF ((b*d')+b')) $ Map.insert "end" (VF ((e*d')+b')) cm- where b' = fromMaybe 0 $ Map.lookup "begin" cm >>= getF- e' = fromMaybe 1 $ Map.lookup "end" cm >>= getF- d' = e' - b'---{-|-The @striateBy@ function is a variant of `striate` with an extra-parameter which specifies the length of each part. The @striateBy@-function still scans across the sample over a single cycle, but if-each bit is longer, it creates a sort of stuttering effect. For-example the following will cut the @bev@ sample into 32 parts, but each-will be 1/16th of a sample long:--> d1 $ slow 32 $ striateBy 32 (1/16) $ sound "bev"--Note that `striate` and @striateBy@ use the `begin` and `end` parameters-internally. This means that you probably shouldn't also specify `begin` or-`end`.--}-striateBy :: Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern-striateBy = tParam2 _striateBy---- | DEPRECATED, use 'striateBy' instead.-striate' :: Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern-striate' = striateBy--_striateBy :: Int -> Double -> ControlPattern -> ControlPattern-_striateBy n f p = fastcat $ map (offset . fromIntegral) [0 .. n-1]- where offset i = p # P.begin (pure (slot * i) :: Pattern Double) # P.end (pure ((slot * i) + f) :: Pattern Double)- slot = (1 - f) / fromIntegral n---{- | `gap` is similar to `chop` in that it granualizes every sample in place as it is played,-but every other grain is silent. Use an integer value to specify how many granules-each sample is chopped into:--> d1 $ gap 8 $ sound "jvbass"-> d1 $ gap 16 $ sound "[jvbass drum:4]"--}--gap :: Pattern Int -> ControlPattern -> ControlPattern-gap = tParam _gap--_gap :: Int -> ControlPattern -> ControlPattern-_gap n p = _fast (toRational n) (cat [pure 1, silence]) |>| _chop n p--{- |- @weave@ applies one control pattern to a list of other control patterns, with- a successive time offset. It uses an `OscPattern` to apply the function at- different levels to each pattern, creating a weaving effect. For example:-- > d1 $ weave 16 (pan sine)- > [ sound "bd sn cp"- > , sound "casio casio:1"- > , sound "[jvbass*2 jvbass:2]/2"- > , sound "hc*4"- > ]-- In the above, the @pan sine@ control pattern is slowed down by the given- number of cycles, in particular 16, and applied to all of the given sound- patterns. What makes this interesting is that the @pan@ control pattern is- successively offset for each of the given sound patterns; because the @pan@ is- closed down by 16 cycles, and there are four patterns, they are ‘spread out’,- i.e. with a gap of four cycles. For this reason, the four patterns seem to- chase after each other around the stereo field. Try listening on headphones to- hear this more clearly.-- You can even have it the other way round, and have the effect parameters chasing- after each other around a sound parameter, like this:-- > d1 $ weave 16 (sound "arpy" >| n (run 8))- > [ vowel "a e i"- > , vowel "i [i o] o u"- > , vowel "[e o]/3 [i o u]/2"- > , speed "1 2 3"- > ]--}-weave :: Time -> ControlPattern -> [ControlPattern] -> ControlPattern-weave t p ps = weave' t p (map (#) ps)---{-|- @weaveWith@ is similar to the above, but weaves with a list of functions, rather- than a list of controls. For example:-- > d1 $ weaveWith 3 (sound "bd [sn drum:2*2] bd*2 [sn drum:1]")- > [ fast 2- > , (# speed "0.5")- > , chop 16- > ]--}-weaveWith :: Time -> Pattern a -> [Pattern a -> Pattern a] -> Pattern a-weaveWith t p fs | l == 0 = silence- | otherwise = _slow t $ stack $ zipWith (\ i f -> (fromIntegral i % l) `rotL` _fast t (f (_slow t p))) [0 :: Int ..] fs- where l = fromIntegral $ length fs---- | An old alias for 'weaveWith'.-weave' :: Time -> Pattern a -> [Pattern a -> Pattern a] -> Pattern a-weave' = weaveWith--{- |-(A function that takes two ControlPatterns, and blends them together into-a new ControlPattern. An ControlPattern is basically a pattern of messages to-a synthesiser.)--Shifts between the two given patterns, using distortion.--Example:--> d1 $ interlace (sound "bd sn kurt") (every 3 rev $ sound "bd sn:2")--}-interlace :: ControlPattern -> ControlPattern -> ControlPattern-interlace a b = weave 16 (P.shape (sine * 0.9)) [a, b]--{--{- | Just like `striate`, but also loops each sample chunk a number of times specified in the second argument.-The primed version is just like `striateBy`, where the loop count is the third argument. For example:--> d1 $ striateL' 3 0.125 4 $ sound "feel sn:2"--Like `striate`, these use the `begin` and `end` parameters internally, as well as the `loop` parameter for these versions.--}-striateL :: Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern-striateL = tParam2 _striateL--striateL' :: Pattern Int -> Pattern Double -> Pattern Int -> ControlPattern -> ControlPattern-striateL' = tParam3 _striateL'--_striateL :: Int -> Int -> ControlPattern -> ControlPattern-_striateL n l p = _striate n p # loop (pure $ fromIntegral l)-_striateL' n f l p = _striateBy n f p # loop (pure $ fromIntegral l)---en :: [(Int, Int)] -> Pattern String -> Pattern String-en ns p = stack $ map (\(i, (k, n)) -> _e k n (samples p (pure i))) $ enumerate ns---}--{-| @slice@ is similar to 'chop' and 'striate', in that it’s used to slice- samples up into bits. The difference is that it allows you to rearrange those- bits as a pattern.-- > d1 $ slice 8 "7 6 5 4 3 2 1 0"- > $ sound "breaks165"- > # legato 1-- The above slices the sample into eight bits, and then plays them backwards,- equivalent of applying rev $ chop 8. Here’s a more complex example:-- > d1 $ slice 8 "[<0*8 0*2> 3*4 2 4] [4 .. 7]"- > $ sound "breaks165"- > # legato 1--}-slice :: Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern-slice pN pI p = P.begin b # P.end e # p- where b = div' <$> pI <* pN- e = (\i n -> div' i n + div' 1 n) <$> pI <* pN- div' num den = fromIntegral (num `mod` den) / fromIntegral den--_slice :: Int -> Int -> ControlPattern -> ControlPattern-_slice n i p =- p- # P.begin (pure $ fromIntegral i / fromIntegral n)- # P.end (pure $ fromIntegral (i+1) / fromIntegral n)--{-|- @randslice@ chops the sample into the given number of pieces and then plays back- a random one each cycle:-- > d1 $ randslice 32 $ sound "bev"-- Use 'fast' to get more than one per cycle:-- > d1 $ fast 4 $ randslice 32 $ sound "bev"--}-randslice :: Pattern Int -> ControlPattern -> ControlPattern-randslice = tParam $ \n p -> innerJoin $ (\i -> _slice n i p) <$> _irand n--_splice :: Int -> Pattern Int -> ControlPattern -> Pattern (Map.Map String Value)-_splice bits ipat pat = withEvent f (slice (pure bits) ipat pat) # P.unit (pure "c")- where f ev = case Map.lookup "speed" (value ev) of- (Just (VF s)) -> ev {value = Map.insert "speed" (VF $ d*s) (value ev)} -- if there is a speed parameter already present- _ -> ev {value = Map.insert "speed" (VF d) (value ev)}- where d = sz / fromRational (wholeStop ev - wholeStart ev)- sz = 1/fromIntegral bits--{-|- @splice@ is similar to 'slice', but the slices are automatically pitched up or down- to fit their ‘slot’.-- > d1 $ splice 8 "[<0*8 0*2> 3*4 2 4] [4 .. 7]" $ sound "breaks165"--}-splice :: Pattern Int -> Pattern Int -> ControlPattern -> Pattern (Map.Map String Value)-splice bitpat ipat pat = innerJoin $ (\bits -> _splice bits ipat pat) <$> bitpat--{-|- @loopAt@ makes a sample fit the given number of cycles. Internally, it- works by setting the `unit` parameter to @"c"@, changing the playback- speed of the sample with the `speed` parameter, and setting setting- the `density` of the pattern to match.-- > d1 $ loopAt 4 $ sound "breaks125"-- It’s a good idea to use this in conjuction with 'chop', so the break is chopped- into pieces and you don’t have to wait for the whole sample to start/stop.-- > d1 $ loopAt 4 $ chop 32 $ sound "breaks125"-- Like all Tidal functions, you can mess about with this considerably. The below- example shows how you can supply a pattern of cycle counts to @loopAt@:-- > d1 $ juxBy 0.6 (|* speed "2")- > $ slowspread (loopAt) [4,6,2,3]- > $ chop 12- > $ sound "fm:14"--}-loopAt :: Pattern Time -> ControlPattern -> ControlPattern-loopAt n p = slow n p |* P.speed (fromRational <$> (1/n)) # P.unit (pure "c")--{-|- @hurry@ is similiar to 'fast' in that it speeds up a pattern, but it also- increases the speed control by the same factor. So, if you’re triggering- samples, the sound gets higher in pitch. For example:-- > d1 $ every 2 (hurry 2) $ sound "bd sn:2 ~ cp"--}-hurry :: Pattern Rational -> ControlPattern -> ControlPattern-hurry !x = (|* P.speed (fromRational <$> x)) . fast x--{- | @smash@ is a combination of `spread` and `striate` — it cuts the samples-into the given number of bits, and then cuts between playing the loop-at different speeds according to the values in the list. So this:--> d1 $ smash 3 [2,3,4] $ sound "ho ho:2 ho:3 hc"--is a bit like this:--> d1 $ spread (slow) [2,3,4] $ striate 3 $ sound "ho ho:2 ho:3 hc"--This is quite dancehall:--> d1 $ ( spread' slow "1%4 2 1 3"-> $ spread (striate) [2,3,4,1]-> $ sound "sn:2 sid:3 cp sid:4"-> )-> # speed "[1 2 1 1]/2"--}--smash :: Pattern Int -> [Pattern Time] -> ControlPattern -> Pattern ValueMap-smash n xs p = slowcat $ map (`slow` p') xs- where p' = striate n p--{- | An altenative form of `smash`, which uses `chop` instead of `striate`.-- Compare the following variations:-- > d1 $ smash 6 [2,3,4] $ sound "ho ho:2 ho:3 hc"- > d1 $ smash' 6 [2,3,4] $ sound "ho ho:2 ho:3 hc"- > d1 $ smash 12 [2,3,4] $ s "bev*4"- > d1 $ smash' 12 [2,3,4] $ s "bev*4"--}-smash' :: Int -> [Pattern Time] -> ControlPattern -> ControlPattern-smash' n xs p = slowcat $ map (`slow` p') xs- where p' = _chop n p--{- |- Applies a type of delay to a pattern.- It has three parameters, which could be called @depth@, @time@ and @feedback@.- @depth@ is and integer, and @time@ and @feedback@ are floating point numbers.-- This adds a bit of echo:-- > d1 $ echo 4 0.2 0.5 $ sound "bd sn"-- The above results in 4 echos, each one 50% quieter than the last, with 1/5th of a cycle between them.-- It is possible to reverse the echo:-- > d1 $ echo 4 (-0.2) 0.5 $ sound "bd sn"--}-echo :: Pattern Integer -> Pattern Rational -> Pattern Double -> ControlPattern -> ControlPattern-echo = tParam3 _echo--_echo :: Integer -> Rational -> Double -> ControlPattern -> ControlPattern-_echo count time feedback p = _echoWith count time (|* P.gain (pure $ feedback)) p--{- |- @echoWith@ is similar to 'echo', but instead of just decreasing volume to- produce echoes, @echoWith@ applies a function each step and overlays the- result delayed by the given time.-- > d1 $ echoWith 2 "1%3" (# vowel "{a e i o u}%2") $ sound "bd sn"-- In this case there are two _overlays_ delayed by 1/3 of a cycle, where each- has the 'vowel' filter applied.-- > d1 $ echoWith 4 (1/6) (|* speed "1.5") $ sound "arpy arpy:2"-- In the above, three versions are put on top, with each step getting higher in- pitch as @|* speed "1.5"@ is successively applied.--}-echoWith :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-echoWith n t f p = innerJoin $ (\a b -> _echoWith a b f p) <$> n <* t--_echoWith :: (Num n, Ord n) => n -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-_echoWith count time f p | count <= 1 = p- | otherwise = overlay (f (time `rotR` _echoWith (count-1) time f p)) p---- | DEPRECATED, use 'echo' instead-stut :: Pattern Integer -> Pattern Double -> Pattern Rational -> ControlPattern -> ControlPattern-stut = tParam3 _stut--_stut :: Integer -> Double -> Rational -> ControlPattern -> ControlPattern-_stut count feedback steptime p = stack (p:map (\x -> ((x%1)*steptime) `rotR` (p |* P.gain (pure $ scalegain (fromIntegral x)))) [1..(count-1)])- where scalegain- = (+feedback) . (*(1-feedback)) . (/ fromIntegral count) . (fromIntegral count -)---- | DEPRECATED, use 'echoWith' instead-stutWith :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-stutWith n t f p = innerJoin $ (\a b -> _stutWith a b f p) <$> n <* t--_stutWith :: (Num n, Ord n) => n -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-_stutWith count steptime f p | count <= 1 = p- | otherwise = overlay (f (steptime `rotR` _stutWith (count-1) steptime f p)) p---- | DEPRECATED, use 'echoWith' instead-stut' :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-stut' = stutWith---- | Turns a pattern of seconds into a pattern of (rational) cycle durations-sec :: Fractional a => Pattern a -> Pattern a-sec p = (realToFrac <$> cF 1 "_cps") *| p---- | Turns a pattern of milliseconds into a pattern of (rational)--- cycle durations, according to the current cps.-msec :: Fractional a => Pattern a -> Pattern a-msec p = (realToFrac . (/1000) <$> cF 1 "_cps") *| p---- | Align the start of a pattern with the time a pattern is evaluated,--- rather than the global start time. Because of this, the pattern will--- probably not be aligned to the pattern grid.-trigger :: Pattern a -> Pattern a-trigger = triggerWith id---- | (Alias @__qt__@) Quantise trigger. Aligns the start of the pattern--- with the next cycle boundary. For example, this pattern will fade in--- starting with the next cycle after the pattern is evaluated:------ > d1 $ qtrigger $ s "hh(5, 8)" # amp envL------ Note that the pattern will start playing immediately. The /start/ of the--- pattern aligns with the next cycle boundary, but events will play before--- if the pattern has events at negative timestamps (which most loops do).--- These events can be filtered out, for example:------ > d1 $ qtrigger $ filterWhen (>= 0) $ s "hh(5, 8)"------ Alternatively, you can use 'wait' to achieve the same result:------ > wait 1 1 $ s "bd hh hh hh"-qtrigger :: Pattern a -> Pattern a-qtrigger = ctrigger---- | Alias for 'qtrigger'.-qt :: Pattern a -> Pattern a-qt = qtrigger---- | Ceiling trigger. Aligns the start of a pattern to the next cycle--- boundary, just like 'qtrigger'.-ctrigger :: Pattern a -> Pattern a-ctrigger = triggerWith $ (fromIntegral :: Int -> Rational) . ceiling---- | Rounded trigger. Aligns the start of a pattern to the nearest cycle--- boundary, either next or previous.-rtrigger :: Pattern a -> Pattern a-rtrigger = triggerWith $ (fromIntegral :: Int -> Rational) . round---- | Floor trigger. Aligns the start of a pattern to the previous cycle--- boundary.-ftrigger :: Pattern a -> Pattern a-ftrigger = triggerWith $ (fromIntegral :: Int -> Rational) . floor--{- | (Alias @__mt__@) Mod trigger. Aligns the start of a pattern to the- next cycle boundary where the cycle is evenly divisible by a given- number. 'qtrigger' is equivalent to @mtrigger 1@.-- In the following example, when activating the @d1@ pattern, it will start at the- same time as the next clap, even if it has to wait for 3 cycles. Once activated,- the @arpy@ sound will play on every cycle, just like any other pattern:-- > do- > resetCycles- > d2 $ every 4 (# s "clap") $ s "bd"-- > d1 $ mtrigger 4 $ filterWhen (>=0) $ s "arpy"--}-mtrigger :: Int -> Pattern a -> Pattern a-mtrigger n = triggerWith $ fromIntegral . nextMod- where nextMod t = n * ceiling (t / (fromIntegral n))---- | Alias for 'mtrigger'.-mt :: Int -> Pattern a -> Pattern a-mt = mtrigger--{- | This aligns the start of a pattern to some value relative to the- time the pattern is evaluated. The provided function maps the evaluation- time (on the global cycle clock) to a new time, and then @triggerWith@- aligns the pattern's start to the time that's returned.-- This is a more flexible triggering function. In fact, all the other trigger- functions are defined based on @triggerWith@. For example, 'trigger' is just- @triggerWith id@.-- In the next example, use @d1@ as a metronome, and play with different values- (from 0 to 1) on the @const@ expression. You’ll notice how the @clap@ is- displaced from the beginning of each cycle to the end, as the number increases:-- > d1 $ s "bd hh!3"- >- > d2 $ triggerWith (const 0.1) $ s "clap"-- This last example is equivalent to this:-- > d2 $ rotR 0.1 $ s "clap"--}-triggerWith :: (Time -> Time) -> Pattern a -> Pattern a-triggerWith f pat = pat {query = q}- where q st = query (rotR (offset st) pat) st- offset st = fromMaybe 0 $ f- <$> (Map.lookup patternTimeID (controls st) >>= getR)--splat :: Pattern Int -> ControlPattern -> ControlPattern -> ControlPattern-splat slices epat pat = chop slices pat # bite 1 (const 0 <$> pat) epat
− src/Sound/Tidal/Core.hs
@@ -1,947 +0,0 @@-{-# LANGUAGE FlexibleInstances, BangPatterns #-}--{-- Core.hs - For functions judged to be 'core' to tidal functionality.- Copyright (C) 2020, Alex McLean and contributors-- This library is free software: you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this library. If not, see <http://www.gnu.org/licenses/>.--}--module Sound.Tidal.Core where--import Prelude hiding ((<*), (*>))--import Data.Fixed (mod')-import qualified Data.Map.Strict as Map-import Data.Maybe (fromMaybe)-import Sound.Tidal.Pattern---- ** Elemental patterns--{-| Takes a function of time to values, and turns it into a 'Pattern'.- Useful for creating continuous patterns such as 'sine' or 'perlin'.-- For example, 'saw' is defined as-- > saw = sig $ \t -> mod' (fromRational t) 1--}-sig :: (Time -> a) -> Pattern a-sig f = Pattern q- where q (State (Arc s e) _)- | s > e = []- | otherwise = [Event (Context []) Nothing (Arc s e) (f (s+((e-s)/2)))]---- | @sine@ - unipolar sinewave. A pattern of continuous values following a--- sinewave with frequency of one cycle, and amplitude from 0 to 1.-sine :: Fractional a => Pattern a-sine = sig $ \t -> (sin_rat ((pi :: Double) * 2 * fromRational t) + 1) / 2- where sin_rat = fromRational . toRational . sin---- | @sine2@ - bipolar sinewave. A pattern of continuous values following a--- sinewave with frequency of one cycle, and amplitude from -1 to 1.-sine2 :: Fractional a => Pattern a-sine2 = sig $ \t -> sin_rat ((pi :: Double) * 2 * fromRational t)- where sin_rat = fromRational . toRational . sin---- | @cosine@ - unipolar cosine wave. A pattern of continuous values--- following a cosine with frequency of one cycle, and amplitude from--- 0 to 1. Equivalent to @0.25 ~> sine@.-cosine :: Fractional a => Pattern a-cosine = 0.25 `rotR` sine---- | @cosine2@ - bipolar cosine wave. A pattern of continuous values--- following a cosine with frequency of one cycle, and amplitude from--- -1 to 1. Equivalent to @0.25 ~> sine2@.-cosine2 :: Fractional a => Pattern a-cosine2 = 0.25 `rotR` sine2---- | @saw@ - unipolar ascending sawtooth wave. A pattern of continuous values--- following a sawtooth with frequency of one cycle, and amplitude from--- 0 to 1.-saw :: (Fractional a, Real a) => Pattern a-saw = sig $ \t -> mod' (fromRational t) 1---- | @saw2@ - bipolar ascending sawtooth wave. A pattern of continuous values--- following a sawtooth with frequency of one cycle, and amplitude from--- -1 to 1.-saw2 :: (Fractional a, Real a) => Pattern a-saw2 = sig $ \t -> mod' (fromRational t) 1 * 2 - 1---- | @isaw@ like @saw@, but a descending (inverse) sawtooth.-isaw :: (Fractional a, Real a) => Pattern a-isaw = (1-) <$> saw---- | @isaw2@ like @saw2@, but a descending (inverse) sawtooth.-isaw2 :: (Fractional a, Real a) => Pattern a-isaw2 = (*(-1)) <$> saw2---- | @tri@ - unipolar triangle wave. A pattern of continuous values--- following a triangle wave with frequency of one cycle, and amplitude from--- 0 to 1.-tri :: (Fractional a, Real a) => Pattern a-tri = fastAppend saw isaw---- | @tri2@ - bipolar triangle wave. A pattern of continuous values--- following a triangle wave with frequency of one cycle, and amplitude from--- -1 to 1.-tri2 :: (Fractional a, Real a) => Pattern a-tri2 = fastAppend saw2 isaw2---- | @square@ - unipolar square wave. A pattern of continuous values--- following a square wave with frequency of one cycle, and amplitude from--- 0 to 1.--- | @square@ is like 'sine', for square waves.-square :: (Fractional a) => Pattern a-square = sig $- \t -> fromIntegral ((floor $ mod' (fromRational t :: Double) 1 * 2) :: Integer)---- | @square2@ - bipolar square wave. A pattern of continuous values--- following a square wave with frequency of one cycle, and amplitude from--- -1 to 1.-square2 :: (Fractional a) => Pattern a-square2 = sig $- \t -> fromIntegral (floor (mod' (fromRational t :: Double) 1 * 2) * 2 - 1 :: Integer)---- | @envL@ is a 'Pattern' of continuous 'Double' values, representing--- a linear interpolation between 0 and 1 during the first cycle, then--- staying constant at 1 for all following cycles. Possibly only--- useful if you're using something like the retrig function defined--- in tidal.el.-envL :: Pattern Double-envL = sig $ \t -> max 0 $ min (fromRational t) 1---- | like 'envL' but reversed.-envLR :: Pattern Double-envLR = (1-) <$> envL---- | 'Equal power' version of 'env', for gain-based transitions-envEq :: Pattern Double-envEq = sig $ \t -> sqrt (sin (pi/2 * max 0 (min (fromRational (1-t)) 1)))---- | Equal power reversed-envEqR :: Pattern Double-envEqR = sig $ \t -> sqrt (cos (pi/2 * max 0 (min (fromRational (1-t)) 1)))---- ** Pattern algebra---- class for types that support a left-biased union-class Unionable a where- union :: a -> a -> a---- default union is just to take the left hand side..-instance Unionable a where- union = const--instance {-# OVERLAPPING #-} Unionable ValueMap where- union = Map.union--(|+|) :: (Applicative a, Num b) => a b -> a b -> a b-a |+| b = (+) <$> a <*> b-(|+ ) :: Num a => Pattern a -> Pattern a -> Pattern a-a |+ b = (+) <$> a <* b-( +|) :: Num a => Pattern a -> Pattern a -> Pattern a-a +| b = (+) <$> a *> b-(||+) :: 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-(||++) :: 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-a |/ b = (/) <$> a <* b-( /|) :: Fractional a => Pattern a -> Pattern a -> Pattern a-a /| b = (/) <$> a *> b-(||/) :: Fractional a => Pattern a -> Pattern a -> Pattern a-a ||/ b = (/) <$> a <<* b--(|*|) :: (Applicative a, Num b) => a b -> a b -> a b-a |*| b = (*) <$> a <*> b-(|* ) :: Num a => Pattern a -> Pattern a -> Pattern a-a |* b = (*) <$> a <* b-( *|) :: Num a => Pattern a -> Pattern a -> Pattern a-a *| b = (*) <$> a *> b-(||*) :: Num a => Pattern a -> Pattern a -> Pattern a-a ||* b = (*) <$> a <<* b--(|-|) :: (Applicative a, Num b) => a b -> a b -> a b-a |-| b = (-) <$> a <*> b-(|- ) :: Num a => Pattern a -> Pattern a -> Pattern a-a |- b = (-) <$> a <* b-( -|) :: Num a => Pattern a -> Pattern a -> Pattern a-a -| b = (-) <$> a *> b-(||-) :: Num a => Pattern a -> Pattern a -> Pattern a-a ||- b = (-) <$> a <<* b--(|%|) :: (Applicative a, Moddable b) => a b -> a b -> a b-a |%| b = gmod <$> a <*> b-(|% ) :: Moddable a => Pattern a -> Pattern a -> Pattern a-a |% b = gmod <$> a <* b-( %|) :: Moddable a => Pattern a -> Pattern a -> Pattern a-a %| b = gmod <$> a *> b-(||%) :: Moddable a => Pattern a -> Pattern a -> Pattern a-a ||% b = gmod <$> a <<* b--(|**|) :: (Applicative a, Floating b) => a b -> a b -> a b-a |**| b = (**) <$> a <*> b-(|** ) :: Floating a => Pattern a -> Pattern a -> Pattern a-a |** b = (**) <$> a <* b-( **|) :: Floating a => Pattern a -> Pattern a -> Pattern a-a **| b = (**) <$> a *> b-(||**) :: Floating a => Pattern a -> Pattern a -> Pattern a-a ||** b = (**) <$> a <<* b--(|>|) :: (Applicative a, Unionable b) => a b -> a b -> a b-a |>| b = flip union <$> a <*> b-(|> ) :: Unionable a => Pattern a -> Pattern a -> Pattern a-a |> b = flip union <$> a <* b-( >|) :: Unionable a => Pattern a -> Pattern a -> Pattern a-a >| b = flip union <$> a *> b-(||>) :: Unionable a => Pattern a -> Pattern a -> Pattern a-a ||> b = flip union <$> a <<* b--(|<|) :: (Applicative a, Unionable b) => a b -> a b -> a b-a |<| b = union <$> a <*> b-(|< ) :: Unionable a => Pattern a -> Pattern a -> Pattern a-a |< b = union <$> a <* b-( <|) :: Unionable a => Pattern a -> Pattern a -> Pattern a-a <| b = union <$> a *> b-(||<) :: Unionable a => Pattern a -> Pattern a -> Pattern a-a ||< b = union <$> a <<* b---- Backward compatibility - structure from left, values from right.-(#) :: Unionable b => Pattern b -> Pattern b -> Pattern b-(#) = (|>)------ ** Constructing patterns--{-| Turns a list of values into a pattern, playing one of them per cycle.- The following are equivalent:-- > d1 $ n (fromList [0, 1, 2]) # s "superpiano"- > d1 $ n "<0 1 2>" # s "superpiano"--}-fromList :: [a] -> Pattern a-fromList = cat . map pure--{-| Turns a list of values into a pattern, playing /all/ of them per cycle.- The following are equivalent:-- > d1 $ n (fastFromList [0, 1, 2]) # s "superpiano"- > d1 $ n "[0 1 2]" # s "superpiano"--}-fastFromList :: [a] -> Pattern a-fastFromList = fastcat . map pure---- | A synonym for 'fastFromList'-listToPat :: [a] -> Pattern a-listToPat = fastFromList---- | 'fromMaybes; is similar to 'fromList', but allows values to--- be optional using the 'Maybe' type, so that 'Nothing' results in--- gaps in the pattern.--- The following are equivalent:--- > d1 $ n (fromMaybes [Just 0, Nothing, Just 2]) # s "superpiano"--- > d1 $ n "0 ~ 2" # s "superpiano"-fromMaybes :: [Maybe a] -> Pattern a-fromMaybes = fastcat . map f- where f Nothing = silence- f (Just x) = pure x--{-| A pattern of whole numbers from 0 to the given number, in a single cycle.- Can be used used to @run@ through a folder of samples in order:-- > d1 $ n (run 8) # sound "amencutup"-- The first parameter to run can be given as a pattern:-- > d1 $ n (run "<4 8 4 6>") # sound "amencutup"--}-run :: (Enum a, Num a) => Pattern a -> Pattern a-run = (>>= _run)--_run :: (Enum a, Num a) => a -> Pattern a-_run n = fastFromList [0 .. n-1]---- | Similar to 'run', but starts from @1@ for the first cycle, successively--- adds a number until it gets up to @n@.--- > d1 $ n (scan 8) # sound "amencutup"-scan :: (Enum a, Num a) => Pattern a -> Pattern a-scan = (>>= _scan)--_scan :: (Enum a, Num a) => a -> Pattern a-_scan n = slowcat $ map _run [1 .. n]---- ** Combining patterns---- | Alternate between cycles of the two given patterns--- > d1 $ append (sound "bd*2 sn") (sound "arpy jvbass*2")-append :: Pattern a -> Pattern a -> Pattern a-append a b = cat [a,b]--{- |- Like 'append', but for a list of patterns. Interlaces them, playing the- first cycle from each in turn, then the second cycle from each, and so on. It- concatenates a list of patterns into a new pattern; each pattern in the list- will maintain its original duration. For example:-- > d1 $ cat [sound "bd*2 sn", sound "arpy jvbass*2"]- > d1 $ cat [sound "bd*2 sn", sound "arpy jvbass*2", sound "drum*2"]- > d1 $ cat [sound "bd*2 sn", sound "jvbass*3", sound "drum*2", sound "ht mt"]--}-cat :: [Pattern a] -> Pattern a-cat [] = silence-cat ps = Pattern q- where n = length ps- q st = concatMap (f st) $ arcCyclesZW (arc st)- f st a = query (withResultTime (+offset) p) $ st {arc = Arc (subtract offset (start a)) (subtract offset (stop a))}- where p = ps !! i- cyc = (floor $ start a) :: Int- i = cyc `mod` n- offset = (fromIntegral $ cyc - ((cyc - i) `div` n)) :: Time---- | Alias for 'cat'-slowCat :: [Pattern a] -> Pattern a-slowCat = cat-slowcat :: [Pattern a] -> Pattern a-slowcat = slowCat---- | Alias for 'append'-slowAppend :: Pattern a -> Pattern a -> Pattern a-slowAppend = append-slowappend :: Pattern a -> Pattern a -> Pattern a-slowappend = append---- | Like 'append', but twice as fast--- > d1 $ fastAppend (sound "bd*2 sn") (sound "arpy jvbass*2")-fastAppend :: Pattern a -> Pattern a -> Pattern a-fastAppend a b = _fast 2 $ append a b-fastappend :: Pattern a -> Pattern a -> Pattern a-fastappend = fastAppend--{-| The same as 'cat', but speeds up the result by the number of- patterns there are, so the cycles from each are squashed to fit a- single cycle.-- > d1 $ fastcat [sound "bd*2 sn", sound "arpy jvbass*2"]- > d1 $ fastcat [sound "bd*2 sn", sound "arpy jvbass*2", sound "drum*2"]- > d1 $ fastcat [sound "bd*2 sn", sound "jvbass*3", sound "drum*2", sound "ht mt"]--}-fastCat :: [Pattern a] -> Pattern a-fastCat ps = _fast (toTime $ length ps) $ cat ps---- | Alias for @fastCat@-fastcat :: [Pattern a] -> Pattern a-fastcat = fastCat--{- | Similar to @fastCat@, but each pattern is given a relative duration.- You provide proportionate sizes of the patterns to each other for when they’re- concatenated into one cycle. The larger the value in the list, the larger- relative size the pattern takes in the final loop. If all values are equal- then this is equivalent to fastcat (e.g. the following two code fragments are- equivalent).-- > d1 $ fastcat [s "bd*4", s "hh27*8", s "superpiano" # n 0]-- > d1 $ timeCat [ (1, s "bd*4")- > , (1, s "hh27*8")- > , (1, s "superpiano" # n 0)- > ]---}-timeCat :: [(Time, Pattern a)] -> Pattern a-timeCat tps = stack $ map (\(s,e,p) -> compressArc (Arc (s/total) (e/total)) p) $ arrange 0 tps- where total = sum $ map fst tps- arrange :: Time -> [(Time, Pattern a)] -> [(Time, Time, Pattern a)]- arrange _ [] = []- arrange t ((t',p):tps') = (t,t+t',p) : arrange (t+t') tps'---- | Alias for @timeCat@-timecat :: [(Time, Pattern a)] -> Pattern a-timecat = timeCat--{- | @overlay@ combines two 'Pattern's into a new pattern, so that their events-are combined over time. For example, the following two lines are equivalent:--> d1 $ sound (overlay "bd sn:2" "cp*3")-> d1 $ sound "[bd sn:2, cp*3]"--@overlay@ is equal to '<>',--> (<>) :: Semigroup a => a -> a -> a--which can thus be used as an infix operator equivalent of 'overlay':--> d1 $ sound ("bd sn:2" <> "cp*3")--}-overlay :: Pattern a -> Pattern a -> Pattern a-overlay = (<>)--{- | 'stack' combines a list of 'Pattern's into a new pattern, so that their-events are combined over time, i.e., all of the patterns in the list are played-simultaneously.--> d1 $ stack [-> sound "bd bd*2",-> sound "hh*2 [sn cp] cp future*4",-> sound "arpy" +| n "0 .. 15"-> ]--This is particularly useful if you want to apply a function or synth control-pattern to multiple patterns at once:--> d1 $ whenmod 5 3 (striate 3) $ stack [-> sound "bd bd*2",-> sound "hh*2 [sn cp] cp future*4",-> sound "arpy" +| n "0 .. 15"-> ] # speed "[[1 0.8], [1.5 2]*2]/3"--}-stack :: [Pattern a] -> Pattern a-stack = foldr overlay silence---- ** Manipulating time---- | Shifts a pattern back in time by the given amount, expressed in cycles-(<~) :: Pattern Time -> Pattern a -> Pattern a-(<~) = tParam rotL---- | Shifts a pattern forward in time by the given amount, expressed in cycles-(~>) :: Pattern Time -> Pattern a -> Pattern a-(~>) = tParam rotR--{-| Slow down a pattern by the factors in the given time pattern, "squeezing"- the pattern to fit the slot given in the time pattern. It is the slow analogue- to 'fastSqueeze'.-- If the time pattern only has a single value in a cycle, @slowSqueeze@ becomes equivalent to slow. These are equivalent:-- > d1 $ slow "<2 4>" $ s "bd*8"- > d1 $ slowSqueeze "<2 4>" $ s "bd*8"-- When the time pattern has multiple values, however, the behavior is a little- different. Instead, a slowed version of the pattern will be made for each value- in the time pattern, and they’re all combined together in a cycle according to- the structure of the time pattern. For example, these are equivalent:-- > d1 $ slowSqueeze "2 4 8 16" $ s "bd*8"- > d1 $ s "bd*4 bd*2 bd bd/2"-- as are these:-- > d1 $ slowSqueeze "2 4 [8 16]" $ s "bd*8"- > d1 $ s "bd*4 bd*2 [bd bd/2]"--}-slowSqueeze :: Pattern Time -> Pattern a -> Pattern a-slowSqueeze = tParamSqueeze _slow---- | An alias for @slow@-sparsity :: Pattern Time -> Pattern a -> Pattern a-sparsity = slow--{- | Plays a portion of a pattern, specified by a time arc (start and end time).- The new resulting pattern is played over the time period of the original pattern.-- > d1 $ zoom (0.25, 0.75) $ sound "bd*2 hh*3 [sn bd]*2 drum"-- In the pattern above, @zoom@ is used with an arc from 25% to 75%. It is- equivalent to:-- > d1 $ sound "hh*3 [sn bd]*2"-- Here’s an example of it being used with a conditional:-- > d1 $ every 4 (zoom (0.25, 0.75)) $ sound "bd*2 hh*3 [sn bd]*2 drum"--}-zoom :: (Time, Time) -> Pattern a -> Pattern a-zoom (s,e) = zoomArc (Arc s e)--zoomArc :: Arc -> Pattern a -> Pattern a-zoomArc (Arc s e) p = splitQueries $- withResultArc (mapCycle ((/d) . subtract s)) $ withQueryArc (mapCycle ((+s) . (*d))) p- where d = e-s--{-| @fastGap@ is similar to 'fast' but maintains its cyclic alignment, i.e.,- rather than playing the pattern multiple times, it instead leaves a gap in- the remaining space of the cycle. For example, @fastGap 2 p@ would squash the- events in pattern @p@ into the first half of each cycle (and the second halves- would be empty). The factor should be at least 1.--}-fastGap :: Pattern Time -> Pattern a -> Pattern a-fastGap = tParam _fastGap---- | An alias for @fastGap@-densityGap :: Pattern Time -> Pattern a -> Pattern a-densityGap = fastGap--{-|- @compress@ takes a pattern and squeezes it within the specified time span (i.e.- the ‘arc’). The new resulting pattern is a sped up version of the original.-- > d1 $ compress (1/4, 3/4) $ s "[bd sn]!"-- In the above example, the pattern will play in an arc spanning from 25% to 75%- of the duration of a cycle. It is equivalent to:-- > d1 $ s "~ [bd sn]! ~"-- Another example, where all events are different:-- > d1 $ compress (1/4, 3/4) $ n (run 4) # s "arpy"-- It differs from 'zoom' in that it preserves the original pattern but it speeds- up its events so to match with the new time period.--}-compress :: (Time,Time) -> Pattern a -> Pattern a-compress (s,e) = compressArc (Arc s e)--compressTo :: (Time,Time) -> Pattern a -> Pattern a-compressTo (s,e) = compressArcTo (Arc s e)--repeatCycles :: Pattern Int -> Pattern a -> Pattern a-repeatCycles = tParam _repeatCycles--_repeatCycles :: Int -> Pattern a -> Pattern a-_repeatCycles n p = cat (replicate n p)--fastRepeatCycles :: Int -> Pattern a -> Pattern a-fastRepeatCycles n p = cat (replicate n p)---- | * Higher order functions---- | Functions which work on other functions (higher order functions)--{- | @every n f p@ applies the function @f@ to @p@, but only affects- every @n@ cycles.-- It takes three inputs: how often the function should be applied (e.g. 3 to- apply it every 3 cycles), the function to be applied, and the pattern you are- applying it to. For example: to reverse a pattern every three cycles (and for- the other two play it normally)-- > d1 $ every 3 rev $ n "0 1 [~ 2] 3" # sound "arpy"-- Note that if the function you’re applying requires additional parameters- itself (such as fast 2 to make a pattern twice as fast), then you’ll need to- wrap it in parenthesis, like so:-- > d1 $ every 3 (fast 2) $ n "0 1 [~ 2] 3" # sound "arpy"-- Otherwise, the every function will think it is being passed too many parameters.--}-every :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-every tp f p = innerJoin $ (\t -> _every t f p) <$> tp--_every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-_every 0 _ p = p-_every n f p = when ((== 0) . (`mod` n)) f p--{-| @every' n o f p@ is like @every n f p@ but with an offset of @o@ cycles.-- For example, @every' 3 0 (fast 2)@ will speed up the cycle on cycles 0,3,6,…- whereas @every' 3 1 (fast 2)@ will transform the pattern on cycles 1,4,7,….-- With this in mind, setting the second argument of @every'@ to 0 gives the- equivalent every function. For example, every 3 is equivalent to every' 3 0.-- The @every@ functions can be used to silence a full cycle or part of a cycle- by using silent or mask "~". Mask provides additional flexibility to turn on/off- individual steps.-- > d1 $ every 3 silent $ n "2 9 11 2" # s "hh27"- > d1 $ every 3 (mask "~") $ n "2 9 10 2" # s "hh27"- > d1 $ every 3 (mask "0 0 0 0") $ n "2 9 11 2" # s "hh27"--}-every' :: Pattern Int -> Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-every' np op f p = do { n <- np; o <- op; _every' n o f p }--_every' :: Int -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-_every' n o = when ((== o) . (`mod` n))--{- | @foldEvery ns f p@ applies the function @f@ to @p@, and is applied for- each cycle in @ns@.-- It is similar to chaining multiple @every@ functions together. It transforms- a pattern with a function, once per any of the given number of cycles. If a- particular cycle is the start of more than one of the given cycle periods, then- it it applied more than once.-- > d1 $ foldEvery [5,3] (|+ n 1) $ s "moog" # legato 1-- The first moog samples are tuned to C2, C3 and C4. Note how on cycles that are- multiples of 3 or 5 the pitch is an octave higher, and on multiples of 15 the- pitch is two octaves higher, as the transformation is applied twice.--}-foldEvery :: [Int] -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-foldEvery ns f p = foldr (`_every` f) p ns--{-|-The given pattern transformation is applied only @when@ the given test function-returns @True@. The test function will be called with the current cycle as-a number.--> d1 $ when (elem '4' . show)-> (striate 4)-> $ sound "hh hc"--The above will only apply @striate 4@ to the pattern if the current-cycle number contains the number 4. So the fourth cycle will be-striated and the fourteenth and so on. Expect lots of striates after-cycle number 399.--}-when :: (Int -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-when test f p = splitQueries $ p {query = apply}- where apply st | test (floor $ start $ arc st) = query (f p) st- | otherwise = query p st--{- | Like 'when', but works on continuous time values rather than cycle numbers.- The following will apply @# speed 2@ only when the remainder of the current- @Time@ divided by 2 is less than 0.5:-- > d1 $ whenT ((< 0.5) . (flip Data.Fixed.mod' 2))- > (# speed 2)- > $ sound "hh(4,8) hc(3,8)"--}-whenT :: (Time -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-whenT test f p = splitQueries $ p {query = apply}- where apply st | test (start $ arc st) = query (f p) st- | otherwise = query p st--_getP_ :: (Value -> Maybe a) -> Pattern Value -> Pattern a-_getP_ f pat = filterJust $ f <$> pat--_getP :: a -> (Value -> Maybe a) -> Pattern Value -> Pattern a-_getP d f pat = fromMaybe d . f <$> pat--_cX :: a -> (Value -> Maybe a) -> String -> Pattern a-_cX d f s = Pattern $ \(State a m) -> queryArc (maybe (pure d) (_getP d f . valueToPattern) $ Map.lookup s m) a--_cX_ :: (Value -> Maybe a) -> String -> Pattern a-_cX_ f s = Pattern $ \(State a m) -> queryArc (maybe silence (_getP_ f . valueToPattern) $ Map.lookup s m) a--cF :: Double -> String -> Pattern Double-cF d = _cX d getF-cF_ :: String -> Pattern Double-cF_ = _cX_ getF-cF0 :: String -> Pattern Double-cF0 = _cX 0 getF--cN :: Note -> String -> Pattern Note-cN d = _cX d getN-cN_ :: String -> Pattern Note-cN_ = _cX_ getN-cN0 :: String -> Pattern Note-cN0 = _cX (Note 0) getN--cI :: Int -> String -> Pattern Int-cI d = _cX d getI-cI_ :: String -> Pattern Int-cI_ = _cX_ getI-cI0 :: String -> Pattern Int-cI0 = _cX 0 getI--cB :: Bool -> String -> Pattern Bool-cB d = _cX d getB-cB_ :: String -> Pattern Bool-cB_ = _cX_ getB-cB0 :: String -> Pattern Bool-cB0 = _cX False getB--cR :: Rational -> String -> Pattern Rational-cR d = _cX d getR-cR_ :: String -> Pattern Rational-cR_ = _cX_ getR-cR0 :: String -> Pattern Rational-cR0 = _cX 0 getR--cT :: Time -> String -> Pattern Time-cT = cR-cT0 :: String -> Pattern Time-cT0 = cR0-cT_ :: String -> Pattern Time-cT_ = cR_--cS :: String -> String -> Pattern String-cS d = _cX d getS-cS_ :: String -> Pattern String-cS_ = _cX_ getS-cS0 :: String -> Pattern String-cS0 = _cX "" getS---- Default controller inputs (for MIDI)-in0 :: Pattern Double-in0 = cF 0 "0"-in1 :: Pattern Double-in1 = cF 0 "1"-in2 :: Pattern Double-in2 = cF 0 "2"-in3 :: Pattern Double-in3 = cF 0 "3"-in4 :: Pattern Double-in4 = cF 0 "4"-in5 :: Pattern Double-in5 = cF 0 "5"-in6 :: Pattern Double-in6 = cF 0 "6"-in7 :: Pattern Double-in7 = cF 0 "7"-in8 :: Pattern Double-in8 = cF 0 "8"-in9 :: Pattern Double-in9 = cF 0 "9"-in10 :: Pattern Double-in10 = cF 0 "10"-in11 :: Pattern Double-in11 = cF 0 "11"-in12 :: Pattern Double-in12 = cF 0 "12"-in13 :: Pattern Double-in13 = cF 0 "13"-in14 :: Pattern Double-in14 = cF 0 "14"-in15 :: Pattern Double-in15 = cF 0 "15"-in16 :: Pattern Double-in16 = cF 0 "16"-in17 :: Pattern Double-in17 = cF 0 "17"-in18 :: Pattern Double-in18 = cF 0 "18"-in19 :: Pattern Double-in19 = cF 0 "19"-in20 :: Pattern Double-in20 = cF 0 "20"-in21 :: Pattern Double-in21 = cF 0 "21"-in22 :: Pattern Double-in22 = cF 0 "22"-in23 :: Pattern Double-in23 = cF 0 "23"-in24 :: Pattern Double-in24 = cF 0 "24"-in25 :: Pattern Double-in25 = cF 0 "25"-in26 :: Pattern Double-in26 = cF 0 "26"-in27 :: Pattern Double-in27 = cF 0 "27"-in28 :: Pattern Double-in28 = cF 0 "28"-in29 :: Pattern Double-in29 = cF 0 "29"-in30 :: Pattern Double-in30 = cF 0 "30"-in31 :: Pattern Double-in31 = cF 0 "31"-in32 :: Pattern Double-in32 = cF 0 "32"-in33 :: Pattern Double-in33 = cF 0 "33"-in34 :: Pattern Double-in34 = cF 0 "34"-in35 :: Pattern Double-in35 = cF 0 "35"-in36 :: Pattern Double-in36 = cF 0 "36"-in37 :: Pattern Double-in37 = cF 0 "37"-in38 :: Pattern Double-in38 = cF 0 "38"-in39 :: Pattern Double-in39 = cF 0 "39"-in40 :: Pattern Double-in40 = cF 0 "40"-in41 :: Pattern Double-in41 = cF 0 "41"-in42 :: Pattern Double-in42 = cF 0 "42"-in43 :: Pattern Double-in43 = cF 0 "43"-in44 :: Pattern Double-in44 = cF 0 "44"-in45 :: Pattern Double-in45 = cF 0 "45"-in46 :: Pattern Double-in46 = cF 0 "46"-in47 :: Pattern Double-in47 = cF 0 "47"-in48 :: Pattern Double-in48 = cF 0 "48"-in49 :: Pattern Double-in49 = cF 0 "49"-in50 :: Pattern Double-in50 = cF 0 "50"-in51 :: Pattern Double-in51 = cF 0 "51"-in52 :: Pattern Double-in52 = cF 0 "52"-in53 :: Pattern Double-in53 = cF 0 "53"-in54 :: Pattern Double-in54 = cF 0 "54"-in55 :: Pattern Double-in55 = cF 0 "55"-in56 :: Pattern Double-in56 = cF 0 "56"-in57 :: Pattern Double-in57 = cF 0 "57"-in58 :: Pattern Double-in58 = cF 0 "58"-in59 :: Pattern Double-in59 = cF 0 "59"-in60 :: Pattern Double-in60 = cF 0 "60"-in61 :: Pattern Double-in61 = cF 0 "61"-in62 :: Pattern Double-in62 = cF 0 "62"-in63 :: Pattern Double-in63 = cF 0 "63"-in64 :: Pattern Double-in64 = cF 0 "64"-in65 :: Pattern Double-in65 = cF 0 "65"-in66 :: Pattern Double-in66 = cF 0 "66"-in67 :: Pattern Double-in67 = cF 0 "67"-in68 :: Pattern Double-in68 = cF 0 "68"-in69 :: Pattern Double-in69 = cF 0 "69"-in70 :: Pattern Double-in70 = cF 0 "70"-in71 :: Pattern Double-in71 = cF 0 "71"-in72 :: Pattern Double-in72 = cF 0 "72"-in73 :: Pattern Double-in73 = cF 0 "73"-in74 :: Pattern Double-in74 = cF 0 "74"-in75 :: Pattern Double-in75 = cF 0 "75"-in76 :: Pattern Double-in76 = cF 0 "76"-in77 :: Pattern Double-in77 = cF 0 "77"-in78 :: Pattern Double-in78 = cF 0 "78"-in79 :: Pattern Double-in79 = cF 0 "79"-in80 :: Pattern Double-in80 = cF 0 "80"-in81 :: Pattern Double-in81 = cF 0 "81"-in82 :: Pattern Double-in82 = cF 0 "82"-in83 :: Pattern Double-in83 = cF 0 "83"-in84 :: Pattern Double-in84 = cF 0 "84"-in85 :: Pattern Double-in85 = cF 0 "85"-in86 :: Pattern Double-in86 = cF 0 "86"-in87 :: Pattern Double-in87 = cF 0 "87"-in88 :: Pattern Double-in88 = cF 0 "88"-in89 :: Pattern Double-in89 = cF 0 "89"-in90 :: Pattern Double-in90 = cF 0 "90"-in91 :: Pattern Double-in91 = cF 0 "91"-in92 :: Pattern Double-in92 = cF 0 "92"-in93 :: Pattern Double-in93 = cF 0 "93"-in94 :: Pattern Double-in94 = cF 0 "94"-in95 :: Pattern Double-in95 = cF 0 "95"-in96 :: Pattern Double-in96 = cF 0 "96"-in97 :: Pattern Double-in97 = cF 0 "97"-in98 :: Pattern Double-in98 = cF 0 "98"-in99 :: Pattern Double-in99 = cF 0 "99"-in100 :: Pattern Double-in100 = cF 0 "100"-in101 :: Pattern Double-in101 = cF 0 "101"-in102 :: Pattern Double-in102 = cF 0 "102"-in103 :: Pattern Double-in103 = cF 0 "103"-in104 :: Pattern Double-in104 = cF 0 "104"-in105 :: Pattern Double-in105 = cF 0 "105"-in106 :: Pattern Double-in106 = cF 0 "106"-in107 :: Pattern Double-in107 = cF 0 "107"-in108 :: Pattern Double-in108 = cF 0 "108"-in109 :: Pattern Double-in109 = cF 0 "109"-in110 :: Pattern Double-in110 = cF 0 "110"-in111 :: Pattern Double-in111 = cF 0 "111"-in112 :: Pattern Double-in112 = cF 0 "112"-in113 :: Pattern Double-in113 = cF 0 "113"-in114 :: Pattern Double-in114 = cF 0 "114"-in115 :: Pattern Double-in115 = cF 0 "115"-in116 :: Pattern Double-in116 = cF 0 "116"-in117 :: Pattern Double-in117 = cF 0 "117"-in118 :: Pattern Double-in118 = cF 0 "118"-in119 :: Pattern Double-in119 = cF 0 "119"-in120 :: Pattern Double-in120 = cF 0 "120"-in121 :: Pattern Double-in121 = cF 0 "121"-in122 :: Pattern Double-in122 = cF 0 "122"-in123 :: Pattern Double-in123 = cF 0 "123"-in124 :: Pattern Double-in124 = cF 0 "124"-in125 :: Pattern Double-in125 = cF 0 "125"-in126 :: Pattern Double-in126 = cF 0 "126"-in127 :: Pattern Double-in127 = cF 0 "127"
src/Sound/Tidal/ID.hs view
@@ -1,4 +1,4 @@-module Sound.Tidal.ID (ID(..)) where+module Sound.Tidal.ID (ID (..)) where {- ID.hs - Polymorphic pattern identifiers@@ -18,13 +18,12 @@ along with this library. If not, see <http://www.gnu.org/licenses/>. -} -import GHC.Exts ( IsString(..) )+import GHC.Exts (IsString (..)) -- | Wrapper for literals that can be coerced to a string and used as an identifier. -- | Similar to Show typeclass, but constrained to strings and integers and designed -- | so that similar cases (such as 1 and "1") convert to the same value.-newtype ID = ID { fromID :: String } deriving (Eq, Show, Ord, Read)-+newtype ID = ID {fromID :: String} deriving (Eq, Show, Ord, Read) noOv :: String -> a noOv meth = error $ meth ++ ": not supported for ids"
− src/Sound/Tidal/Params.hs
@@ -1,3557 +0,0 @@-module Sound.Tidal.Params where---- Please note, this file is generated by bin/generate-params.hs--- Submit any pull requests against that file and/or params-header.hs--- in the same folder, thanks.--{-- Params.hs - Provides the basic control patterns available to TidalCycles by default- Copyright (C) 2021, Alex McLean and contributors-- This library is free software: you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this library. If not, see <http://www.gnu.org/licenses/>.--}--import qualified Data.Map.Strict as Map--import Sound.Tidal.Pattern-import Sound.Tidal.Core ((#))-import Sound.Tidal.Utils-import Data.Maybe (fromMaybe)-import Data.Word (Word8)-import Data.Fixed (mod')---- | Group multiple params into one.-grp :: [String -> ValueMap] -> Pattern String -> ControlPattern-grp [] _ = empty-grp fs p = splitby <$> p- where splitby name = Map.unions $ map (\(v, f) -> f v) $ zip (split name) fs- split :: String -> [String]- split = wordsBy (==':')--mF :: String -> String -> ValueMap-mF name v = fromMaybe Map.empty $ do f <- readMaybe v- return $ Map.singleton name (VF f)--mI :: String -> String -> ValueMap-mI name v = fromMaybe Map.empty $ do i <- readMaybe v- return $ Map.singleton name (VI i)--mS :: String -> String -> ValueMap-mS name v = Map.singleton name (VS v)---- * Param makers--pF :: String -> Pattern Double -> ControlPattern-pF name = fmap (Map.singleton name . VF)--pI :: String -> Pattern Int -> ControlPattern-pI name = fmap (Map.singleton name . VI)--pB :: String -> Pattern Bool -> ControlPattern-pB name = fmap (Map.singleton name . VB)- -pR :: String -> Pattern Rational -> ControlPattern-pR name = fmap (Map.singleton name . VR)--pN :: String -> Pattern Note -> ControlPattern-pN name = fmap (Map.singleton name . VN)--pS :: String -> Pattern String -> ControlPattern-pS name = fmap (Map.singleton name . VS)--pX :: String -> Pattern [Word8] -> ControlPattern-pX name = fmap (Map.singleton name . VX)--pStateF ::- String -> -- ^ A parameter, e.g. `note`; a- -- `String` recognizable by a `ValueMap`.- String -> -- ^ Identifies the cycling state pattern.- -- Can be anything the user wants.- (Maybe Double -> Double) ->- ControlPattern-pStateF name sName update =- pure $ Map.singleton name $ VState statef- where statef :: ValueMap -> (ValueMap, Value)- statef sMap = (Map.insert sName v sMap, v)- where v = VF $ update- $ Map.lookup sName sMap >>= getF---- | `pStateList` is made with cyclic lists in mind,--- but it can even "cycle" through infinite lists.-pStateList ::- String -> -- ^ A parameter, e.g. `note`; a- -- `String` recognizable by a `ValueMap`.- String -> -- ^ Identifies the cycling state pattern.- -- Can be anything the user wants.- [Value] -> -- ^ The list to cycle through.- ControlPattern-pStateList name sName xs =- pure $ Map.singleton name $ VState statef- where- statef :: ValueMap -> (ValueMap, Value)- statef sMap = ( Map.insert sName- (VList $ tail looped) sMap- , head looped)- where xs' = fromMaybe xs- $ Map.lookup sName sMap >>= getList- -- do this instead of a cycle, so it can get updated with the a list- looped | null xs' = xs- | otherwise = xs'---- | A wrapper for `pStateList` that accepts a `[Double]`--- rather than a `[Value]`.-pStateListF :: String -> String -> [Double] -> ControlPattern-pStateListF name sName = pStateList name sName . map VF---- | A wrapper for `pStateList` that accepts a `[String]`--- rather than a `[Value]`.-pStateListS :: String -> String -> [String] -> ControlPattern-pStateListS name sName = pStateList name sName . map VS---- * Grouped params--sound :: Pattern String -> ControlPattern-sound = grp [mS "s", mF "n"]--sTake :: String -> [String] -> ControlPattern-sTake name xs = pStateListS "s" name xs--cc :: Pattern String -> ControlPattern-cc = grp [mF "ccn", mF "ccv"]--nrpn :: Pattern String -> ControlPattern-nrpn = grp [mI "nrpn", mI "val"]--nrpnn :: Pattern Int -> ControlPattern-nrpnn = pI "nrpn"--nrpnv :: Pattern Int -> ControlPattern-nrpnv = pI "val"--{-| @grain'@ is a shortcut to join a @begin@ and @end@-- These are equivalent:-- > d1 $ slow 2 $ s "bev" # grain' "0.2:0.3" # legato 1- > d1 $ slow 2 $ s "bev" # begin 0.2 # end 0.3 # legato 1--}-grain' :: Pattern String -> ControlPattern-grain' = grp [mF "begin", mF "end"]--midinote :: Pattern Note -> ControlPattern-midinote = note . (subtract 60 <$>)--drum :: Pattern String -> ControlPattern-drum = n . (subtract 60 . drumN <$>)--drumN :: Num a => String -> a-drumN "hq" = 27-drumN "sl" = 28-drumN "ps" = 29-drumN "pl" = 30-drumN "st" = 31-drumN "sq" = 32-drumN "ml" = 33-drumN "mb" = 34-drumN "ab" = 35-drumN "bd" = 36-drumN "rm" = 37-drumN "sn" = 38-drumN "cp" = 39-drumN "es" = 40-drumN "lf" = 41-drumN "ch" = 42-drumN "lt" = 43-drumN "hh" = 44-drumN "ft" = 45-drumN "oh" = 46-drumN "mt" = 47-drumN "hm" = 48-drumN "cr" = 49-drumN "ht" = 50-drumN "ri" = 51-drumN "cy" = 52-drumN "be" = 53-drumN "ta" = 54-drumN "sc" = 55-drumN "cb" = 56-drumN "cs" = 57-drumN "vi" = 58-drumN "rc" = 59-drumN "hb" = 60-drumN "lb" = 61-drumN "mh" = 62-drumN "hc" = 63-drumN "lc" = 64-drumN "he" = 65-drumN "le" = 66-drumN "ag" = 67-drumN "la" = 68-drumN "ca" = 69-drumN "ma" = 70-drumN "sw" = 71-drumN "lw" = 72-drumN "sg" = 73-drumN "lg" = 74-drumN "cl" = 75-drumN "hi" = 76-drumN "li" = 77-drumN "mc" = 78-drumN "oc" = 79-drumN "tr" = 80-drumN "ot" = 81-drumN "sh" = 82-drumN "jb" = 83-drumN "bt" = 84-drumN "ct" = 85-drumN "ms" = 86-drumN "os" = 87-drumN _ = 0---- * Generated params--{- | A pattern of numbers that speed up (or slow down) samples while they play.-- In the following example, the sound starts at the original pitch and gets- higher as it plays:-- > d1 $ s "arpy" # accelerate 2-- You can use a negative number to make the sound get lower. In this example, a- different acceleration is applied to each played note using state values:-- > d1 $ arp "up" $ note "c'maj'4" # s "arpy" # accelerateTake "susan" [0.2,1,-1]--}-accelerate :: Pattern Double -> ControlPattern-accelerate = pF "accelerate"--accelerateTake :: String -> [Double] -> ControlPattern-accelerateTake name xs = pStateListF "accelerate" name xs-accelerateCount :: String -> ControlPattern-accelerateCount name = pStateF "accelerate" name (maybe 0 (+1))-accelerateCountTo :: String -> Pattern Double -> Pattern ValueMap-accelerateCountTo name ipat = innerJoin $ (\i -> pStateF "accelerate" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--acceleratebus :: Pattern Int -> Pattern Double -> ControlPattern-acceleratebus _ _ = error $ "Control parameter 'accelerate' can't be sent to a bus."--{-| Controls the amplitude (volume) of the sound. Like 'gain', but linear.- Default value is 0.4.-- > d1 $ s "arpy" # amp "<0.4 0.8 0.2>"--}-amp :: Pattern Double -> ControlPattern-amp = pF "amp"-ampTake :: String -> [Double] -> ControlPattern-ampTake name xs = pStateListF "amp" name xs-ampCount :: String -> ControlPattern-ampCount name = pStateF "amp" name (maybe 0 (+1))-ampCountTo :: String -> Pattern Double -> Pattern ValueMap-ampCountTo name ipat = innerJoin $ (\i -> pStateF "amp" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--ampbus :: Pattern Int -> Pattern Double -> ControlPattern-ampbus busid pat = (pF "amp" pat) # (pI "^amp" busid)-amprecv :: Pattern Int -> ControlPattern-amprecv busid = pI "^amp" busid---- | -array :: Pattern [Word8] -> ControlPattern-array = pX "array"-arrayTake :: String -> [Double] -> ControlPattern-arrayTake name xs = pStateListF "array" name xs-arraybus :: Pattern Int -> Pattern [Word8] -> ControlPattern-arraybus _ _ = error $ "Control parameter 'array' can't be sent to a bus."---- | a pattern of numbers to specify the attack time (in seconds) of an envelope applied to each sample.-attack :: Pattern Double -> ControlPattern-attack = pF "attack"-attackTake :: String -> [Double] -> ControlPattern-attackTake name xs = pStateListF "attack" name xs-attackCount :: String -> ControlPattern-attackCount name = pStateF "attack" name (maybe 0 (+1))-attackCountTo :: String -> Pattern Double -> Pattern ValueMap-attackCountTo name ipat = innerJoin $ (\i -> pStateF "attack" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--attackbus :: Pattern Int -> Pattern Double -> ControlPattern-attackbus busid pat = (pF "attack" pat) # (pI "^attack" busid)-attackrecv :: Pattern Int -> ControlPattern-attackrecv busid = pI "^attack" busid---- | a pattern of numbers from 0 to 1. Sets the center frequency of the band-pass filter.-bandf :: Pattern Double -> ControlPattern-bandf = pF "bandf"-bandfTake :: String -> [Double] -> ControlPattern-bandfTake name xs = pStateListF "bandf" name xs-bandfCount :: String -> ControlPattern-bandfCount name = pStateF "bandf" name (maybe 0 (+1))-bandfCountTo :: String -> Pattern Double -> Pattern ValueMap-bandfCountTo name ipat = innerJoin $ (\i -> pStateF "bandf" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--bandfbus :: Pattern Int -> Pattern Double -> ControlPattern-bandfbus busid pat = (pF "bandf" pat) # (pI "^bandf" busid)-bandfrecv :: Pattern Int -> ControlPattern-bandfrecv busid = pI "^bandf" busid---- | a pattern of anumbers from 0 to 1. Sets the q-factor of the band-pass filter.-bandq :: Pattern Double -> ControlPattern-bandq = pF "bandq"-bandqTake :: String -> [Double] -> ControlPattern-bandqTake name xs = pStateListF "bandq" name xs-bandqCount :: String -> ControlPattern-bandqCount name = pStateF "bandq" name (maybe 0 (+1))-bandqCountTo :: String -> Pattern Double -> Pattern ValueMap-bandqCountTo name ipat = innerJoin $ (\i -> pStateF "bandq" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--bandqbus :: Pattern Int -> Pattern Double -> ControlPattern-bandqbus busid pat = (pF "bandq" pat) # (pI "^bandq" busid)-bandqrecv :: Pattern Int -> ControlPattern-bandqrecv busid = pI "^bandq" busid--{- | @begin@ receives a pattern of numbers from 0 to 1 and skips the beginning-of each sample by the indicated proportion. I.e., 0 would play the sample from-the start, 1 would skip the whole sample, and 0.25 would cut off the first-quarter.--In this example, the first 3 @ade@ samples are played on every cycle, but the-start point from which they are played changes on each cycle:--> d1 $ n "0 1 2" # s "ade" # begin "<0 0.25 0.5 0.75>" # legato 1--}-begin :: Pattern Double -> ControlPattern-begin = pF "begin"-beginTake :: String -> [Double] -> ControlPattern-beginTake name xs = pStateListF "begin" name xs-beginCount :: String -> ControlPattern-beginCount name = pStateF "begin" name (maybe 0 (+1))-beginCountTo :: String -> Pattern Double -> Pattern ValueMap-beginCountTo name ipat = innerJoin $ (\i -> pStateF "begin" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--beginbus :: Pattern Int -> Pattern Double -> ControlPattern-beginbus _ _ = error $ "Control parameter 'begin' can't be sent to a bus."---- | Spectral binshift-binshift :: Pattern Double -> ControlPattern-binshift = pF "binshift"-binshiftTake :: String -> [Double] -> ControlPattern-binshiftTake name xs = pStateListF "binshift" name xs-binshiftCount :: String -> ControlPattern-binshiftCount name = pStateF "binshift" name (maybe 0 (+1))-binshiftCountTo :: String -> Pattern Double -> Pattern ValueMap-binshiftCountTo name ipat = innerJoin $ (\i -> pStateF "binshift" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--binshiftbus :: Pattern Int -> Pattern Double -> ControlPattern-binshiftbus busid pat = (pF "binshift" pat) # (pI "^binshift" busid)-binshiftrecv :: Pattern Int -> ControlPattern-binshiftrecv busid = pI "^binshift" busid---- | -button0 :: Pattern Double -> ControlPattern-button0 = pF "button0"-button0Take :: String -> [Double] -> ControlPattern-button0Take name xs = pStateListF "button0" name xs-button0Count :: String -> ControlPattern-button0Count name = pStateF "button0" name (maybe 0 (+1))-button0CountTo :: String -> Pattern Double -> Pattern ValueMap-button0CountTo name ipat = innerJoin $ (\i -> pStateF "button0" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button0bus :: Pattern Int -> Pattern Double -> ControlPattern-button0bus busid pat = (pF "button0" pat) # (pI "^button0" busid)-button0recv :: Pattern Int -> ControlPattern-button0recv busid = pI "^button0" busid---- | -button1 :: Pattern Double -> ControlPattern-button1 = pF "button1"-button1Take :: String -> [Double] -> ControlPattern-button1Take name xs = pStateListF "button1" name xs-button1Count :: String -> ControlPattern-button1Count name = pStateF "button1" name (maybe 0 (+1))-button1CountTo :: String -> Pattern Double -> Pattern ValueMap-button1CountTo name ipat = innerJoin $ (\i -> pStateF "button1" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button1bus :: Pattern Int -> Pattern Double -> ControlPattern-button1bus busid pat = (pF "button1" pat) # (pI "^button1" busid)-button1recv :: Pattern Int -> ControlPattern-button1recv busid = pI "^button1" busid---- | -button10 :: Pattern Double -> ControlPattern-button10 = pF "button10"-button10Take :: String -> [Double] -> ControlPattern-button10Take name xs = pStateListF "button10" name xs-button10Count :: String -> ControlPattern-button10Count name = pStateF "button10" name (maybe 0 (+1))-button10CountTo :: String -> Pattern Double -> Pattern ValueMap-button10CountTo name ipat = innerJoin $ (\i -> pStateF "button10" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button10bus :: Pattern Int -> Pattern Double -> ControlPattern-button10bus busid pat = (pF "button10" pat) # (pI "^button10" busid)-button10recv :: Pattern Int -> ControlPattern-button10recv busid = pI "^button10" busid---- | -button11 :: Pattern Double -> ControlPattern-button11 = pF "button11"-button11Take :: String -> [Double] -> ControlPattern-button11Take name xs = pStateListF "button11" name xs-button11Count :: String -> ControlPattern-button11Count name = pStateF "button11" name (maybe 0 (+1))-button11CountTo :: String -> Pattern Double -> Pattern ValueMap-button11CountTo name ipat = innerJoin $ (\i -> pStateF "button11" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button11bus :: Pattern Int -> Pattern Double -> ControlPattern-button11bus busid pat = (pF "button11" pat) # (pI "^button11" busid)-button11recv :: Pattern Int -> ControlPattern-button11recv busid = pI "^button11" busid---- | -button12 :: Pattern Double -> ControlPattern-button12 = pF "button12"-button12Take :: String -> [Double] -> ControlPattern-button12Take name xs = pStateListF "button12" name xs-button12Count :: String -> ControlPattern-button12Count name = pStateF "button12" name (maybe 0 (+1))-button12CountTo :: String -> Pattern Double -> Pattern ValueMap-button12CountTo name ipat = innerJoin $ (\i -> pStateF "button12" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button12bus :: Pattern Int -> Pattern Double -> ControlPattern-button12bus busid pat = (pF "button12" pat) # (pI "^button12" busid)-button12recv :: Pattern Int -> ControlPattern-button12recv busid = pI "^button12" busid---- | -button13 :: Pattern Double -> ControlPattern-button13 = pF "button13"-button13Take :: String -> [Double] -> ControlPattern-button13Take name xs = pStateListF "button13" name xs-button13Count :: String -> ControlPattern-button13Count name = pStateF "button13" name (maybe 0 (+1))-button13CountTo :: String -> Pattern Double -> Pattern ValueMap-button13CountTo name ipat = innerJoin $ (\i -> pStateF "button13" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button13bus :: Pattern Int -> Pattern Double -> ControlPattern-button13bus busid pat = (pF "button13" pat) # (pI "^button13" busid)-button13recv :: Pattern Int -> ControlPattern-button13recv busid = pI "^button13" busid---- | -button14 :: Pattern Double -> ControlPattern-button14 = pF "button14"-button14Take :: String -> [Double] -> ControlPattern-button14Take name xs = pStateListF "button14" name xs-button14Count :: String -> ControlPattern-button14Count name = pStateF "button14" name (maybe 0 (+1))-button14CountTo :: String -> Pattern Double -> Pattern ValueMap-button14CountTo name ipat = innerJoin $ (\i -> pStateF "button14" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button14bus :: Pattern Int -> Pattern Double -> ControlPattern-button14bus busid pat = (pF "button14" pat) # (pI "^button14" busid)-button14recv :: Pattern Int -> ControlPattern-button14recv busid = pI "^button14" busid---- | -button15 :: Pattern Double -> ControlPattern-button15 = pF "button15"-button15Take :: String -> [Double] -> ControlPattern-button15Take name xs = pStateListF "button15" name xs-button15Count :: String -> ControlPattern-button15Count name = pStateF "button15" name (maybe 0 (+1))-button15CountTo :: String -> Pattern Double -> Pattern ValueMap-button15CountTo name ipat = innerJoin $ (\i -> pStateF "button15" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button15bus :: Pattern Int -> Pattern Double -> ControlPattern-button15bus busid pat = (pF "button15" pat) # (pI "^button15" busid)-button15recv :: Pattern Int -> ControlPattern-button15recv busid = pI "^button15" busid---- | -button2 :: Pattern Double -> ControlPattern-button2 = pF "button2"-button2Take :: String -> [Double] -> ControlPattern-button2Take name xs = pStateListF "button2" name xs-button2Count :: String -> ControlPattern-button2Count name = pStateF "button2" name (maybe 0 (+1))-button2CountTo :: String -> Pattern Double -> Pattern ValueMap-button2CountTo name ipat = innerJoin $ (\i -> pStateF "button2" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button2bus :: Pattern Int -> Pattern Double -> ControlPattern-button2bus busid pat = (pF "button2" pat) # (pI "^button2" busid)-button2recv :: Pattern Int -> ControlPattern-button2recv busid = pI "^button2" busid---- | -button3 :: Pattern Double -> ControlPattern-button3 = pF "button3"-button3Take :: String -> [Double] -> ControlPattern-button3Take name xs = pStateListF "button3" name xs-button3Count :: String -> ControlPattern-button3Count name = pStateF "button3" name (maybe 0 (+1))-button3CountTo :: String -> Pattern Double -> Pattern ValueMap-button3CountTo name ipat = innerJoin $ (\i -> pStateF "button3" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button3bus :: Pattern Int -> Pattern Double -> ControlPattern-button3bus busid pat = (pF "button3" pat) # (pI "^button3" busid)-button3recv :: Pattern Int -> ControlPattern-button3recv busid = pI "^button3" busid---- | -button4 :: Pattern Double -> ControlPattern-button4 = pF "button4"-button4Take :: String -> [Double] -> ControlPattern-button4Take name xs = pStateListF "button4" name xs-button4Count :: String -> ControlPattern-button4Count name = pStateF "button4" name (maybe 0 (+1))-button4CountTo :: String -> Pattern Double -> Pattern ValueMap-button4CountTo name ipat = innerJoin $ (\i -> pStateF "button4" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button4bus :: Pattern Int -> Pattern Double -> ControlPattern-button4bus busid pat = (pF "button4" pat) # (pI "^button4" busid)-button4recv :: Pattern Int -> ControlPattern-button4recv busid = pI "^button4" busid---- | -button5 :: Pattern Double -> ControlPattern-button5 = pF "button5"-button5Take :: String -> [Double] -> ControlPattern-button5Take name xs = pStateListF "button5" name xs-button5Count :: String -> ControlPattern-button5Count name = pStateF "button5" name (maybe 0 (+1))-button5CountTo :: String -> Pattern Double -> Pattern ValueMap-button5CountTo name ipat = innerJoin $ (\i -> pStateF "button5" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button5bus :: Pattern Int -> Pattern Double -> ControlPattern-button5bus busid pat = (pF "button5" pat) # (pI "^button5" busid)-button5recv :: Pattern Int -> ControlPattern-button5recv busid = pI "^button5" busid---- | -button6 :: Pattern Double -> ControlPattern-button6 = pF "button6"-button6Take :: String -> [Double] -> ControlPattern-button6Take name xs = pStateListF "button6" name xs-button6Count :: String -> ControlPattern-button6Count name = pStateF "button6" name (maybe 0 (+1))-button6CountTo :: String -> Pattern Double -> Pattern ValueMap-button6CountTo name ipat = innerJoin $ (\i -> pStateF "button6" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button6bus :: Pattern Int -> Pattern Double -> ControlPattern-button6bus busid pat = (pF "button6" pat) # (pI "^button6" busid)-button6recv :: Pattern Int -> ControlPattern-button6recv busid = pI "^button6" busid---- | -button7 :: Pattern Double -> ControlPattern-button7 = pF "button7"-button7Take :: String -> [Double] -> ControlPattern-button7Take name xs = pStateListF "button7" name xs-button7Count :: String -> ControlPattern-button7Count name = pStateF "button7" name (maybe 0 (+1))-button7CountTo :: String -> Pattern Double -> Pattern ValueMap-button7CountTo name ipat = innerJoin $ (\i -> pStateF "button7" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button7bus :: Pattern Int -> Pattern Double -> ControlPattern-button7bus busid pat = (pF "button7" pat) # (pI "^button7" busid)-button7recv :: Pattern Int -> ControlPattern-button7recv busid = pI "^button7" busid---- | -button8 :: Pattern Double -> ControlPattern-button8 = pF "button8"-button8Take :: String -> [Double] -> ControlPattern-button8Take name xs = pStateListF "button8" name xs-button8Count :: String -> ControlPattern-button8Count name = pStateF "button8" name (maybe 0 (+1))-button8CountTo :: String -> Pattern Double -> Pattern ValueMap-button8CountTo name ipat = innerJoin $ (\i -> pStateF "button8" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button8bus :: Pattern Int -> Pattern Double -> ControlPattern-button8bus busid pat = (pF "button8" pat) # (pI "^button8" busid)-button8recv :: Pattern Int -> ControlPattern-button8recv busid = pI "^button8" busid---- | -button9 :: Pattern Double -> ControlPattern-button9 = pF "button9"-button9Take :: String -> [Double] -> ControlPattern-button9Take name xs = pStateListF "button9" name xs-button9Count :: String -> ControlPattern-button9Count name = pStateF "button9" name (maybe 0 (+1))-button9CountTo :: String -> Pattern Double -> Pattern ValueMap-button9CountTo name ipat = innerJoin $ (\i -> pStateF "button9" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--button9bus :: Pattern Int -> Pattern Double -> ControlPattern-button9bus busid pat = (pF "button9" pat) # (pI "^button9" busid)-button9recv :: Pattern Int -> ControlPattern-button9recv busid = pI "^button9" busid---- | -ccn :: Pattern Double -> ControlPattern-ccn = pF "ccn"-ccnTake :: String -> [Double] -> ControlPattern-ccnTake name xs = pStateListF "ccn" name xs-ccnCount :: String -> ControlPattern-ccnCount name = pStateF "ccn" name (maybe 0 (+1))-ccnCountTo :: String -> Pattern Double -> Pattern ValueMap-ccnCountTo name ipat = innerJoin $ (\i -> pStateF "ccn" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--ccnbus :: Pattern Int -> Pattern Double -> ControlPattern-ccnbus _ _ = error $ "Control parameter 'ccn' can't be sent to a bus."---- | -ccv :: Pattern Double -> ControlPattern-ccv = pF "ccv"-ccvTake :: String -> [Double] -> ControlPattern-ccvTake name xs = pStateListF "ccv" name xs-ccvCount :: String -> ControlPattern-ccvCount name = pStateF "ccv" name (maybe 0 (+1))-ccvCountTo :: String -> Pattern Double -> Pattern ValueMap-ccvCountTo name ipat = innerJoin $ (\i -> pStateF "ccv" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--ccvbus :: Pattern Int -> Pattern Double -> ControlPattern-ccvbus _ _ = error $ "Control parameter 'ccv' can't be sent to a bus."---- | choose the channel the pattern is sent to in superdirt-channel :: Pattern Int -> ControlPattern-channel = pI "channel"-channelTake :: String -> [Double] -> ControlPattern-channelTake name xs = pStateListF "channel" name xs-channelCount :: String -> ControlPattern-channelCount name = pStateF "channel" name (maybe 0 (+1))-channelCountTo :: String -> Pattern Double -> Pattern ValueMap-channelCountTo name ipat = innerJoin $ (\i -> pStateF "channel" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--channelbus :: Pattern Int -> Pattern Int -> ControlPattern-channelbus _ _ = error $ "Control parameter 'channel' can't be sent to a bus."---- | -clhatdecay :: Pattern Double -> ControlPattern-clhatdecay = pF "clhatdecay"-clhatdecayTake :: String -> [Double] -> ControlPattern-clhatdecayTake name xs = pStateListF "clhatdecay" name xs-clhatdecayCount :: String -> ControlPattern-clhatdecayCount name = pStateF "clhatdecay" name (maybe 0 (+1))-clhatdecayCountTo :: String -> Pattern Double -> Pattern ValueMap-clhatdecayCountTo name ipat = innerJoin $ (\i -> pStateF "clhatdecay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--clhatdecaybus :: Pattern Int -> Pattern Double -> ControlPattern-clhatdecaybus busid pat = (pF "clhatdecay" pat) # (pI "^clhatdecay" busid)-clhatdecayrecv :: Pattern Int -> ControlPattern-clhatdecayrecv busid = pI "^clhatdecay" busid---- | fake-resampling, a pattern of numbers for lowering the sample rate, i.e. 1 for original 2 for half, 3 for a third and so on.-coarse :: Pattern Double -> ControlPattern-coarse = pF "coarse"-coarseTake :: String -> [Double] -> ControlPattern-coarseTake name xs = pStateListF "coarse" name xs-coarseCount :: String -> ControlPattern-coarseCount name = pStateF "coarse" name (maybe 0 (+1))-coarseCountTo :: String -> Pattern Double -> Pattern ValueMap-coarseCountTo name ipat = innerJoin $ (\i -> pStateF "coarse" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--coarsebus :: Pattern Int -> Pattern Double -> ControlPattern-coarsebus busid pat = (pF "coarse" pat) # (pI "^coarse" busid)-coarserecv :: Pattern Int -> ControlPattern-coarserecv busid = pI "^coarse" busid---- | Spectral comb-comb :: Pattern Double -> ControlPattern-comb = pF "comb"-combTake :: String -> [Double] -> ControlPattern-combTake name xs = pStateListF "comb" name xs-combCount :: String -> ControlPattern-combCount name = pStateF "comb" name (maybe 0 (+1))-combCountTo :: String -> Pattern Double -> Pattern ValueMap-combCountTo name ipat = innerJoin $ (\i -> pStateF "comb" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--combbus :: Pattern Int -> Pattern Double -> ControlPattern-combbus busid pat = (pF "comb" pat) # (pI "^comb" busid)-combrecv :: Pattern Int -> ControlPattern-combrecv busid = pI "^comb" busid---- | -control :: Pattern Double -> ControlPattern-control = pF "control"-controlTake :: String -> [Double] -> ControlPattern-controlTake name xs = pStateListF "control" name xs-controlCount :: String -> ControlPattern-controlCount name = pStateF "control" name (maybe 0 (+1))-controlCountTo :: String -> Pattern Double -> Pattern ValueMap-controlCountTo name ipat = innerJoin $ (\i -> pStateF "control" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--controlbus :: Pattern Int -> Pattern Double -> ControlPattern-controlbus _ _ = error $ "Control parameter 'control' can't be sent to a bus."--{-| A control pattern; 'setcps' is the standalone function.-- Patterns don’t (yet) have independent tempos though, if you change it on one- pattern, it changes on all of them.-- > p "cpsfun" $ s "bd sd(3,8)" # cps (slow 8 $ 0.5 + saw)--}-cps :: Pattern Double -> ControlPattern-cps = pF "cps"-cpsTake :: String -> [Double] -> ControlPattern-cpsTake name xs = pStateListF "cps" name xs-cpsCount :: String -> ControlPattern-cpsCount name = pStateF "cps" name (maybe 0 (+1))-cpsCountTo :: String -> Pattern Double -> Pattern ValueMap-cpsCountTo name ipat = innerJoin $ (\i -> pStateF "cps" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--cpsbus :: Pattern Int -> Pattern Double -> ControlPattern-cpsbus busid pat = (pF "cps" pat) # (pI "^cps" busid)-cpsrecv :: Pattern Int -> ControlPattern-cpsrecv busid = pI "^cps" busid---- | bit crushing, a pattern of numbers from 1 (for drastic reduction in bit-depth) to 16 (for barely no reduction).-crush :: Pattern Double -> ControlPattern-crush = pF "crush"-crushTake :: String -> [Double] -> ControlPattern-crushTake name xs = pStateListF "crush" name xs-crushCount :: String -> ControlPattern-crushCount name = pStateF "crush" name (maybe 0 (+1))-crushCountTo :: String -> Pattern Double -> Pattern ValueMap-crushCountTo name ipat = innerJoin $ (\i -> pStateF "crush" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--crushbus :: Pattern Int -> Pattern Double -> ControlPattern-crushbus busid pat = (pF "crush" pat) # (pI "^crush" busid)-crushrecv :: Pattern Int -> ControlPattern-crushrecv busid = pI "^crush" busid---- | -ctlNum :: Pattern Double -> ControlPattern-ctlNum = pF "ctlNum"-ctlNumTake :: String -> [Double] -> ControlPattern-ctlNumTake name xs = pStateListF "ctlNum" name xs-ctlNumCount :: String -> ControlPattern-ctlNumCount name = pStateF "ctlNum" name (maybe 0 (+1))-ctlNumCountTo :: String -> Pattern Double -> Pattern ValueMap-ctlNumCountTo name ipat = innerJoin $ (\i -> pStateF "ctlNum" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--ctlNumbus :: Pattern Int -> Pattern Double -> ControlPattern-ctlNumbus _ _ = error $ "Control parameter 'ctlNum' can't be sent to a bus."---- | -ctranspose :: Pattern Double -> ControlPattern-ctranspose = pF "ctranspose"-ctransposeTake :: String -> [Double] -> ControlPattern-ctransposeTake name xs = pStateListF "ctranspose" name xs-ctransposeCount :: String -> ControlPattern-ctransposeCount name = pStateF "ctranspose" name (maybe 0 (+1))-ctransposeCountTo :: String -> Pattern Double -> Pattern ValueMap-ctransposeCountTo name ipat = innerJoin $ (\i -> pStateF "ctranspose" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--ctransposebus :: Pattern Int -> Pattern Double -> ControlPattern-ctransposebus busid pat = (pF "ctranspose" pat) # (pI "^ctranspose" busid)-ctransposerecv :: Pattern Int -> ControlPattern-ctransposerecv busid = pI "^ctranspose" busid---- | In the style of classic drum-machines, `cut` will stop a playing sample as soon as another samples with in same cutgroup is to be played. An example would be an open hi-hat followed by a closed one, essentially muting the open.-cut :: Pattern Int -> ControlPattern-cut = pI "cut"-cutTake :: String -> [Double] -> ControlPattern-cutTake name xs = pStateListF "cut" name xs-cutCount :: String -> ControlPattern-cutCount name = pStateF "cut" name (maybe 0 (+1))-cutCountTo :: String -> Pattern Double -> Pattern ValueMap-cutCountTo name ipat = innerJoin $ (\i -> pStateF "cut" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--cutbus :: Pattern Int -> Pattern Int -> ControlPattern-cutbus busid pat = (pI "cut" pat) # (pI "^cut" busid)-cutrecv :: Pattern Int -> ControlPattern-cutrecv busid = pI "^cut" busid---- | a pattern of numbers from 0 to 1. Applies the cutoff frequency of the low-pass filter.-cutoff :: Pattern Double -> ControlPattern-cutoff = pF "cutoff"-cutoffTake :: String -> [Double] -> ControlPattern-cutoffTake name xs = pStateListF "cutoff" name xs-cutoffCount :: String -> ControlPattern-cutoffCount name = pStateF "cutoff" name (maybe 0 (+1))-cutoffCountTo :: String -> Pattern Double -> Pattern ValueMap-cutoffCountTo name ipat = innerJoin $ (\i -> pStateF "cutoff" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--cutoffbus :: Pattern Int -> Pattern Double -> ControlPattern-cutoffbus busid pat = (pF "cutoff" pat) # (pI "^cutoff" busid)-cutoffrecv :: Pattern Int -> ControlPattern-cutoffrecv busid = pI "^cutoff" busid---- | -cutoffegint :: Pattern Double -> ControlPattern-cutoffegint = pF "cutoffegint"-cutoffegintTake :: String -> [Double] -> ControlPattern-cutoffegintTake name xs = pStateListF "cutoffegint" name xs-cutoffegintCount :: String -> ControlPattern-cutoffegintCount name = pStateF "cutoffegint" name (maybe 0 (+1))-cutoffegintCountTo :: String -> Pattern Double -> Pattern ValueMap-cutoffegintCountTo name ipat = innerJoin $ (\i -> pStateF "cutoffegint" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--cutoffegintbus :: Pattern Int -> Pattern Double -> ControlPattern-cutoffegintbus busid pat = (pF "cutoffegint" pat) # (pI "^cutoffegint" busid)-cutoffegintrecv :: Pattern Int -> ControlPattern-cutoffegintrecv busid = pI "^cutoffegint" busid---- | -decay :: Pattern Double -> ControlPattern-decay = pF "decay"-decayTake :: String -> [Double] -> ControlPattern-decayTake name xs = pStateListF "decay" name xs-decayCount :: String -> ControlPattern-decayCount name = pStateF "decay" name (maybe 0 (+1))-decayCountTo :: String -> Pattern Double -> Pattern ValueMap-decayCountTo name ipat = innerJoin $ (\i -> pStateF "decay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--decaybus :: Pattern Int -> Pattern Double -> ControlPattern-decaybus busid pat = (pF "decay" pat) # (pI "^decay" busid)-decayrecv :: Pattern Int -> ControlPattern-decayrecv busid = pI "^decay" busid---- | -degree :: Pattern Double -> ControlPattern-degree = pF "degree"-degreeTake :: String -> [Double] -> ControlPattern-degreeTake name xs = pStateListF "degree" name xs-degreeCount :: String -> ControlPattern-degreeCount name = pStateF "degree" name (maybe 0 (+1))-degreeCountTo :: String -> Pattern Double -> Pattern ValueMap-degreeCountTo name ipat = innerJoin $ (\i -> pStateF "degree" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--degreebus :: Pattern Int -> Pattern Double -> ControlPattern-degreebus busid pat = (pF "degree" pat) # (pI "^degree" busid)-degreerecv :: Pattern Int -> ControlPattern-degreerecv busid = pI "^degree" busid---- | a pattern of numbers from 0 to 1. Sets the level of the delay signal.-delay :: Pattern Double -> ControlPattern-delay = pF "delay"-delayTake :: String -> [Double] -> ControlPattern-delayTake name xs = pStateListF "delay" name xs-delayCount :: String -> ControlPattern-delayCount name = pStateF "delay" name (maybe 0 (+1))-delayCountTo :: String -> Pattern Double -> Pattern ValueMap-delayCountTo name ipat = innerJoin $ (\i -> pStateF "delay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--delaybus :: Pattern Int -> Pattern Double -> ControlPattern-delaybus busid pat = (pF "delay" pat) # (pI "^delay" busid)-delayrecv :: Pattern Int -> ControlPattern-delayrecv busid = pI "^delay" busid---- | a pattern of numbers from 0 to 1. Sets the amount of delay feedback.-delayfeedback :: Pattern Double -> ControlPattern-delayfeedback = pF "delayfeedback"-delayfeedbackTake :: String -> [Double] -> ControlPattern-delayfeedbackTake name xs = pStateListF "delayfeedback" name xs-delayfeedbackCount :: String -> ControlPattern-delayfeedbackCount name = pStateF "delayfeedback" name (maybe 0 (+1))-delayfeedbackCountTo :: String -> Pattern Double -> Pattern ValueMap-delayfeedbackCountTo name ipat = innerJoin $ (\i -> pStateF "delayfeedback" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--delayfeedbackbus :: Pattern Int -> Pattern Double -> ControlPattern-delayfeedbackbus busid pat = (pF "delayfeedback" pat) # (pI "^delayfeedback" busid)-delayfeedbackrecv :: Pattern Int -> ControlPattern-delayfeedbackrecv busid = pI "^delayfeedback" busid---- | a pattern of numbers from 0 to 1. Sets the length of the delay.-delaytime :: Pattern Double -> ControlPattern-delaytime = pF "delaytime"-delaytimeTake :: String -> [Double] -> ControlPattern-delaytimeTake name xs = pStateListF "delaytime" name xs-delaytimeCount :: String -> ControlPattern-delaytimeCount name = pStateF "delaytime" name (maybe 0 (+1))-delaytimeCountTo :: String -> Pattern Double -> Pattern ValueMap-delaytimeCountTo name ipat = innerJoin $ (\i -> pStateF "delaytime" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--delaytimebus :: Pattern Int -> Pattern Double -> ControlPattern-delaytimebus busid pat = (pF "delaytime" pat) # (pI "^delaytime" busid)-delaytimerecv :: Pattern Int -> ControlPattern-delaytimerecv busid = pI "^delaytime" busid---- | -detune :: Pattern Double -> ControlPattern-detune = pF "detune"-detuneTake :: String -> [Double] -> ControlPattern-detuneTake name xs = pStateListF "detune" name xs-detuneCount :: String -> ControlPattern-detuneCount name = pStateF "detune" name (maybe 0 (+1))-detuneCountTo :: String -> Pattern Double -> Pattern ValueMap-detuneCountTo name ipat = innerJoin $ (\i -> pStateF "detune" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--detunebus :: Pattern Int -> Pattern Double -> ControlPattern-detunebus busid pat = (pF "detune" pat) # (pI "^detune" busid)-detunerecv :: Pattern Int -> ControlPattern-detunerecv busid = pI "^detune" busid---- | noisy fuzzy distortion-distort :: Pattern Double -> ControlPattern-distort = pF "distort"-distortTake :: String -> [Double] -> ControlPattern-distortTake name xs = pStateListF "distort" name xs-distortCount :: String -> ControlPattern-distortCount name = pStateF "distort" name (maybe 0 (+1))-distortCountTo :: String -> Pattern Double -> Pattern ValueMap-distortCountTo name ipat = innerJoin $ (\i -> pStateF "distort" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--distortbus :: Pattern Int -> Pattern Double -> ControlPattern-distortbus busid pat = (pF "distort" pat) # (pI "^distort" busid)-distortrecv :: Pattern Int -> ControlPattern-distortrecv busid = pI "^distort" busid---- | DJ filter, below 0.5 is low pass filter, above is high pass filter.-djf :: Pattern Double -> ControlPattern-djf = pF "djf"-djfTake :: String -> [Double] -> ControlPattern-djfTake name xs = pStateListF "djf" name xs-djfCount :: String -> ControlPattern-djfCount name = pStateF "djf" name (maybe 0 (+1))-djfCountTo :: String -> Pattern Double -> Pattern ValueMap-djfCountTo name ipat = innerJoin $ (\i -> pStateF "djf" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--djfbus :: Pattern Int -> Pattern Double -> ControlPattern-djfbus busid pat = (pF "djf" pat) # (pI "^djf" busid)-djfrecv :: Pattern Int -> ControlPattern-djfrecv busid = pI "^djf" busid---- | when set to `1` will disable all reverb for this pattern. See `room` and `size` for more information about reverb.-dry :: Pattern Double -> ControlPattern-dry = pF "dry"-dryTake :: String -> [Double] -> ControlPattern-dryTake name xs = pStateListF "dry" name xs-dryCount :: String -> ControlPattern-dryCount name = pStateF "dry" name (maybe 0 (+1))-dryCountTo :: String -> Pattern Double -> Pattern ValueMap-dryCountTo name ipat = innerJoin $ (\i -> pStateF "dry" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--drybus :: Pattern Int -> Pattern Double -> ControlPattern-drybus busid pat = (pF "dry" pat) # (pI "^dry" busid)-dryrecv :: Pattern Int -> ControlPattern-dryrecv busid = pI "^dry" busid---- | -dur :: Pattern Double -> ControlPattern-dur = pF "dur"-durTake :: String -> [Double] -> ControlPattern-durTake name xs = pStateListF "dur" name xs-durCount :: String -> ControlPattern-durCount name = pStateF "dur" name (maybe 0 (+1))-durCountTo :: String -> Pattern Double -> Pattern ValueMap-durCountTo name ipat = innerJoin $ (\i -> pStateF "dur" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--durbus :: Pattern Int -> Pattern Double -> ControlPattern-durbus busid pat = (pF "dur" pat) # (pI "^dur" busid)-durrecv :: Pattern Int -> ControlPattern-durrecv busid = pI "^dur" busid--{- | Similar to `begin`, but cuts the end off samples, shortening them; e.g.- 0.75 to cut off the last quarter of each sample.-- > d1 $ s "bev" >| begin 0.5 >| end "[0.65 0.55]"-- The example above will play the sample two times for cycle, but the second time- will play a shorter segment than the first time, creating a kind of canon effect.--}-end :: Pattern Double -> ControlPattern-end = pF "end"-endTake :: String -> [Double] -> ControlPattern-endTake name xs = pStateListF "end" name xs-endCount :: String -> ControlPattern-endCount name = pStateF "end" name (maybe 0 (+1))-endCountTo :: String -> Pattern Double -> Pattern ValueMap-endCountTo name ipat = innerJoin $ (\i -> pStateF "end" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--endbus :: Pattern Int -> Pattern Double -> ControlPattern-endbus _ _ = error $ "Control parameter 'end' can't be sent to a bus."---- | Spectral enhance-enhance :: Pattern Double -> ControlPattern-enhance = pF "enhance"-enhanceTake :: String -> [Double] -> ControlPattern-enhanceTake name xs = pStateListF "enhance" name xs-enhanceCount :: String -> ControlPattern-enhanceCount name = pStateF "enhance" name (maybe 0 (+1))-enhanceCountTo :: String -> Pattern Double -> Pattern ValueMap-enhanceCountTo name ipat = innerJoin $ (\i -> pStateF "enhance" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--enhancebus :: Pattern Int -> Pattern Double -> ControlPattern-enhancebus busid pat = (pF "enhance" pat) # (pI "^enhance" busid)-enhancerecv :: Pattern Int -> ControlPattern-enhancerecv busid = pI "^enhance" busid---- | -expression :: Pattern Double -> ControlPattern-expression = pF "expression"-expressionTake :: String -> [Double] -> ControlPattern-expressionTake name xs = pStateListF "expression" name xs-expressionCount :: String -> ControlPattern-expressionCount name = pStateF "expression" name (maybe 0 (+1))-expressionCountTo :: String -> Pattern Double -> Pattern ValueMap-expressionCountTo name ipat = innerJoin $ (\i -> pStateF "expression" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--expressionbus :: Pattern Int -> Pattern Double -> ControlPattern-expressionbus busid pat = (pF "expression" pat) # (pI "^expression" busid)-expressionrecv :: Pattern Int -> ControlPattern-expressionrecv busid = pI "^expression" busid---- | As with fadeTime, but controls the fade in time of the grain envelope. Not used if the grain begins at position 0 in the sample.-fadeInTime :: Pattern Double -> ControlPattern-fadeInTime = pF "fadeInTime"-fadeInTimeTake :: String -> [Double] -> ControlPattern-fadeInTimeTake name xs = pStateListF "fadeInTime" name xs-fadeInTimeCount :: String -> ControlPattern-fadeInTimeCount name = pStateF "fadeInTime" name (maybe 0 (+1))-fadeInTimeCountTo :: String -> Pattern Double -> Pattern ValueMap-fadeInTimeCountTo name ipat = innerJoin $ (\i -> pStateF "fadeInTime" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--fadeInTimebus :: Pattern Int -> Pattern Double -> ControlPattern-fadeInTimebus _ _ = error $ "Control parameter 'fadeInTime' can't be sent to a bus."---- | Used when using begin/end or chop/striate and friends, to change the fade out time of the 'grain' envelope.-fadeTime :: Pattern Double -> ControlPattern-fadeTime = pF "fadeTime"-fadeTimeTake :: String -> [Double] -> ControlPattern-fadeTimeTake name xs = pStateListF "fadeTime" name xs-fadeTimeCount :: String -> ControlPattern-fadeTimeCount name = pStateF "fadeTime" name (maybe 0 (+1))-fadeTimeCountTo :: String -> Pattern Double -> Pattern ValueMap-fadeTimeCountTo name ipat = innerJoin $ (\i -> pStateF "fadeTime" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--fadeTimebus :: Pattern Int -> Pattern Double -> ControlPattern-fadeTimebus _ _ = error $ "Control parameter 'fadeTime' can't be sent to a bus."---- | -frameRate :: Pattern Double -> ControlPattern-frameRate = pF "frameRate"-frameRateTake :: String -> [Double] -> ControlPattern-frameRateTake name xs = pStateListF "frameRate" name xs-frameRateCount :: String -> ControlPattern-frameRateCount name = pStateF "frameRate" name (maybe 0 (+1))-frameRateCountTo :: String -> Pattern Double -> Pattern ValueMap-frameRateCountTo name ipat = innerJoin $ (\i -> pStateF "frameRate" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--frameRatebus :: Pattern Int -> Pattern Double -> ControlPattern-frameRatebus _ _ = error $ "Control parameter 'frameRate' can't be sent to a bus."---- | -frames :: Pattern Double -> ControlPattern-frames = pF "frames"-framesTake :: String -> [Double] -> ControlPattern-framesTake name xs = pStateListF "frames" name xs-framesCount :: String -> ControlPattern-framesCount name = pStateF "frames" name (maybe 0 (+1))-framesCountTo :: String -> Pattern Double -> Pattern ValueMap-framesCountTo name ipat = innerJoin $ (\i -> pStateF "frames" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--framesbus :: Pattern Int -> Pattern Double -> ControlPattern-framesbus _ _ = error $ "Control parameter 'frames' can't be sent to a bus."---- | Spectral freeze-freeze :: Pattern Double -> ControlPattern-freeze = pF "freeze"-freezeTake :: String -> [Double] -> ControlPattern-freezeTake name xs = pStateListF "freeze" name xs-freezeCount :: String -> ControlPattern-freezeCount name = pStateF "freeze" name (maybe 0 (+1))-freezeCountTo :: String -> Pattern Double -> Pattern ValueMap-freezeCountTo name ipat = innerJoin $ (\i -> pStateF "freeze" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--freezebus :: Pattern Int -> Pattern Double -> ControlPattern-freezebus busid pat = (pF "freeze" pat) # (pI "^freeze" busid)-freezerecv :: Pattern Int -> ControlPattern-freezerecv busid = pI "^freeze" busid---- | -freq :: Pattern Double -> ControlPattern-freq = pF "freq"-freqTake :: String -> [Double] -> ControlPattern-freqTake name xs = pStateListF "freq" name xs-freqCount :: String -> ControlPattern-freqCount name = pStateF "freq" name (maybe 0 (+1))-freqCountTo :: String -> Pattern Double -> Pattern ValueMap-freqCountTo name ipat = innerJoin $ (\i -> pStateF "freq" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--freqbus :: Pattern Int -> Pattern Double -> ControlPattern-freqbus busid pat = (pF "freq" pat) # (pI "^freq" busid)-freqrecv :: Pattern Int -> ControlPattern-freqrecv busid = pI "^freq" busid---- | for internal sound routing-from :: Pattern Double -> ControlPattern-from = pF "from"-fromTake :: String -> [Double] -> ControlPattern-fromTake name xs = pStateListF "from" name xs-fromCount :: String -> ControlPattern-fromCount name = pStateF "from" name (maybe 0 (+1))-fromCountTo :: String -> Pattern Double -> Pattern ValueMap-fromCountTo name ipat = innerJoin $ (\i -> pStateF "from" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--frombus :: Pattern Int -> Pattern Double -> ControlPattern-frombus busid pat = (pF "from" pat) # (pI "^from" busid)-fromrecv :: Pattern Int -> ControlPattern-fromrecv busid = pI "^from" busid---- | frequency shifter-fshift :: Pattern Double -> ControlPattern-fshift = pF "fshift"-fshiftTake :: String -> [Double] -> ControlPattern-fshiftTake name xs = pStateListF "fshift" name xs-fshiftCount :: String -> ControlPattern-fshiftCount name = pStateF "fshift" name (maybe 0 (+1))-fshiftCountTo :: String -> Pattern Double -> Pattern ValueMap-fshiftCountTo name ipat = innerJoin $ (\i -> pStateF "fshift" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--fshiftbus :: Pattern Int -> Pattern Double -> ControlPattern-fshiftbus busid pat = (pF "fshift" pat) # (pI "^fshift" busid)-fshiftrecv :: Pattern Int -> ControlPattern-fshiftrecv busid = pI "^fshift" busid---- | frequency shifter-fshiftnote :: Pattern Double -> ControlPattern-fshiftnote = pF "fshiftnote"-fshiftnoteTake :: String -> [Double] -> ControlPattern-fshiftnoteTake name xs = pStateListF "fshiftnote" name xs-fshiftnoteCount :: String -> ControlPattern-fshiftnoteCount name = pStateF "fshiftnote" name (maybe 0 (+1))-fshiftnoteCountTo :: String -> Pattern Double -> Pattern ValueMap-fshiftnoteCountTo name ipat = innerJoin $ (\i -> pStateF "fshiftnote" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--fshiftnotebus :: Pattern Int -> Pattern Double -> ControlPattern-fshiftnotebus busid pat = (pF "fshiftnote" pat) # (pI "^fshiftnote" busid)-fshiftnoterecv :: Pattern Int -> ControlPattern-fshiftnoterecv busid = pI "^fshiftnote" busid---- | frequency shifter-fshiftphase :: Pattern Double -> ControlPattern-fshiftphase = pF "fshiftphase"-fshiftphaseTake :: String -> [Double] -> ControlPattern-fshiftphaseTake name xs = pStateListF "fshiftphase" name xs-fshiftphaseCount :: String -> ControlPattern-fshiftphaseCount name = pStateF "fshiftphase" name (maybe 0 (+1))-fshiftphaseCountTo :: String -> Pattern Double -> Pattern ValueMap-fshiftphaseCountTo name ipat = innerJoin $ (\i -> pStateF "fshiftphase" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--fshiftphasebus :: Pattern Int -> Pattern Double -> ControlPattern-fshiftphasebus busid pat = (pF "fshiftphase" pat) # (pI "^fshiftphase" busid)-fshiftphaserecv :: Pattern Int -> ControlPattern-fshiftphaserecv busid = pI "^fshiftphase" busid--{- | Used to control the amplitude (volume) of the sound. Values less than 1-make the sound quieter and values greater than 1 make the sound louder.--@gain@ uses a power function, so the volume change around 1 is subtle, but it-gets more noticeable as it increases or decreases. Typical values for @gain@ are-between 0 and 1.5.--For the linear equivalent, see 'amp'.--> d1 $ s "arpy" # gain 0.8--This plays the first arpy sample at a quieter level than the default.--> d1 $ s "ab*16" # gain (range 0.8 1.3 $ sine)--This plays a hihat sound, 16 times per cycle, with a @gain@ moving from 0.8 to 1.3-following a sine wave.--}-gain :: Pattern Double -> ControlPattern-gain = pF "gain"-gainTake :: String -> [Double] -> ControlPattern-gainTake name xs = pStateListF "gain" name xs-gainCount :: String -> ControlPattern-gainCount name = pStateF "gain" name (maybe 0 (+1))-gainCountTo :: String -> Pattern Double -> Pattern ValueMap-gainCountTo name ipat = innerJoin $ (\i -> pStateF "gain" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--gainbus :: Pattern Int -> Pattern Double -> ControlPattern-gainbus _ _ = error $ "Control parameter 'gain' can't be sent to a bus."---- | -gate :: Pattern Double -> ControlPattern-gate = pF "gate"-gateTake :: String -> [Double] -> ControlPattern-gateTake name xs = pStateListF "gate" name xs-gateCount :: String -> ControlPattern-gateCount name = pStateF "gate" name (maybe 0 (+1))-gateCountTo :: String -> Pattern Double -> Pattern ValueMap-gateCountTo name ipat = innerJoin $ (\i -> pStateF "gate" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--gatebus :: Pattern Int -> Pattern Double -> ControlPattern-gatebus busid pat = (pF "gate" pat) # (pI "^gate" busid)-gaterecv :: Pattern Int -> ControlPattern-gaterecv busid = pI "^gate" busid---- | -harmonic :: Pattern Double -> ControlPattern-harmonic = pF "harmonic"-harmonicTake :: String -> [Double] -> ControlPattern-harmonicTake name xs = pStateListF "harmonic" name xs-harmonicCount :: String -> ControlPattern-harmonicCount name = pStateF "harmonic" name (maybe 0 (+1))-harmonicCountTo :: String -> Pattern Double -> Pattern ValueMap-harmonicCountTo name ipat = innerJoin $ (\i -> pStateF "harmonic" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--harmonicbus :: Pattern Int -> Pattern Double -> ControlPattern-harmonicbus busid pat = (pF "harmonic" pat) # (pI "^harmonic" busid)-harmonicrecv :: Pattern Int -> ControlPattern-harmonicrecv busid = pI "^harmonic" busid---- | -hatgrain :: Pattern Double -> ControlPattern-hatgrain = pF "hatgrain"-hatgrainTake :: String -> [Double] -> ControlPattern-hatgrainTake name xs = pStateListF "hatgrain" name xs-hatgrainCount :: String -> ControlPattern-hatgrainCount name = pStateF "hatgrain" name (maybe 0 (+1))-hatgrainCountTo :: String -> Pattern Double -> Pattern ValueMap-hatgrainCountTo name ipat = innerJoin $ (\i -> pStateF "hatgrain" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--hatgrainbus :: Pattern Int -> Pattern Double -> ControlPattern-hatgrainbus busid pat = (pF "hatgrain" pat) # (pI "^hatgrain" busid)-hatgrainrecv :: Pattern Int -> ControlPattern-hatgrainrecv busid = pI "^hatgrain" busid---- | High pass sort of spectral filter-hbrick :: Pattern Double -> ControlPattern-hbrick = pF "hbrick"-hbrickTake :: String -> [Double] -> ControlPattern-hbrickTake name xs = pStateListF "hbrick" name xs-hbrickCount :: String -> ControlPattern-hbrickCount name = pStateF "hbrick" name (maybe 0 (+1))-hbrickCountTo :: String -> Pattern Double -> Pattern ValueMap-hbrickCountTo name ipat = innerJoin $ (\i -> pStateF "hbrick" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--hbrickbus :: Pattern Int -> Pattern Double -> ControlPattern-hbrickbus busid pat = (pF "hbrick" pat) # (pI "^hbrick" busid)-hbrickrecv :: Pattern Int -> ControlPattern-hbrickrecv busid = pI "^hbrick" busid---- | a pattern of numbers from 0 to 1. Applies the cutoff frequency of the high-pass filter. Also has alias @hpf@-hcutoff :: Pattern Double -> ControlPattern-hcutoff = pF "hcutoff"-hcutoffTake :: String -> [Double] -> ControlPattern-hcutoffTake name xs = pStateListF "hcutoff" name xs-hcutoffCount :: String -> ControlPattern-hcutoffCount name = pStateF "hcutoff" name (maybe 0 (+1))-hcutoffCountTo :: String -> Pattern Double -> Pattern ValueMap-hcutoffCountTo name ipat = innerJoin $ (\i -> pStateF "hcutoff" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--hcutoffbus :: Pattern Int -> Pattern Double -> ControlPattern-hcutoffbus busid pat = (pF "hcutoff" pat) # (pI "^hcutoff" busid)-hcutoffrecv :: Pattern Int -> ControlPattern-hcutoffrecv busid = pI "^hcutoff" busid---- | a pattern of numbers to specify the hold time (in seconds) of an envelope applied to each sample. Only takes effect if `attack` and `release` are also specified.-hold :: Pattern Double -> ControlPattern-hold = pF "hold"-holdTake :: String -> [Double] -> ControlPattern-holdTake name xs = pStateListF "hold" name xs-holdCount :: String -> ControlPattern-holdCount name = pStateF "hold" name (maybe 0 (+1))-holdCountTo :: String -> Pattern Double -> Pattern ValueMap-holdCountTo name ipat = innerJoin $ (\i -> pStateF "hold" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--holdbus :: Pattern Int -> Pattern Double -> ControlPattern-holdbus busid pat = (pF "hold" pat) # (pI "^hold" busid)-holdrecv :: Pattern Int -> ControlPattern-holdrecv busid = pI "^hold" busid---- | -hours :: Pattern Double -> ControlPattern-hours = pF "hours"-hoursTake :: String -> [Double] -> ControlPattern-hoursTake name xs = pStateListF "hours" name xs-hoursCount :: String -> ControlPattern-hoursCount name = pStateF "hours" name (maybe 0 (+1))-hoursCountTo :: String -> Pattern Double -> Pattern ValueMap-hoursCountTo name ipat = innerJoin $ (\i -> pStateF "hours" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--hoursbus :: Pattern Int -> Pattern Double -> ControlPattern-hoursbus _ _ = error $ "Control parameter 'hours' can't be sent to a bus."---- | a pattern of numbers from 0 to 1. Applies the resonance of the high-pass filter. Has alias @hpq@-hresonance :: Pattern Double -> ControlPattern-hresonance = pF "hresonance"-hresonanceTake :: String -> [Double] -> ControlPattern-hresonanceTake name xs = pStateListF "hresonance" name xs-hresonanceCount :: String -> ControlPattern-hresonanceCount name = pStateF "hresonance" name (maybe 0 (+1))-hresonanceCountTo :: String -> Pattern Double -> Pattern ValueMap-hresonanceCountTo name ipat = innerJoin $ (\i -> pStateF "hresonance" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--hresonancebus :: Pattern Int -> Pattern Double -> ControlPattern-hresonancebus busid pat = (pF "hresonance" pat) # (pI "^hresonance" busid)-hresonancerecv :: Pattern Int -> ControlPattern-hresonancerecv busid = pI "^hresonance" busid---- | -imag :: Pattern Double -> ControlPattern-imag = pF "imag"-imagTake :: String -> [Double] -> ControlPattern-imagTake name xs = pStateListF "imag" name xs-imagCount :: String -> ControlPattern-imagCount name = pStateF "imag" name (maybe 0 (+1))-imagCountTo :: String -> Pattern Double -> Pattern ValueMap-imagCountTo name ipat = innerJoin $ (\i -> pStateF "imag" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--imagbus :: Pattern Int -> Pattern Double -> ControlPattern-imagbus busid pat = (pF "imag" pat) # (pI "^imag" busid)-imagrecv :: Pattern Int -> ControlPattern-imagrecv busid = pI "^imag" busid---- | -kcutoff :: Pattern Double -> ControlPattern-kcutoff = pF "kcutoff"-kcutoffTake :: String -> [Double] -> ControlPattern-kcutoffTake name xs = pStateListF "kcutoff" name xs-kcutoffCount :: String -> ControlPattern-kcutoffCount name = pStateF "kcutoff" name (maybe 0 (+1))-kcutoffCountTo :: String -> Pattern Double -> Pattern ValueMap-kcutoffCountTo name ipat = innerJoin $ (\i -> pStateF "kcutoff" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--kcutoffbus :: Pattern Int -> Pattern Double -> ControlPattern-kcutoffbus busid pat = (pF "kcutoff" pat) # (pI "^kcutoff" busid)-kcutoffrecv :: Pattern Int -> ControlPattern-kcutoffrecv busid = pI "^kcutoff" busid---- | shape/bass enhancer-krush :: Pattern Double -> ControlPattern-krush = pF "krush"-krushTake :: String -> [Double] -> ControlPattern-krushTake name xs = pStateListF "krush" name xs-krushCount :: String -> ControlPattern-krushCount name = pStateF "krush" name (maybe 0 (+1))-krushCountTo :: String -> Pattern Double -> Pattern ValueMap-krushCountTo name ipat = innerJoin $ (\i -> pStateF "krush" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--krushbus :: Pattern Int -> Pattern Double -> ControlPattern-krushbus busid pat = (pF "krush" pat) # (pI "^krush" busid)-krushrecv :: Pattern Int -> ControlPattern-krushrecv busid = pI "^krush" busid---- | -lagogo :: Pattern Double -> ControlPattern-lagogo = pF "lagogo"-lagogoTake :: String -> [Double] -> ControlPattern-lagogoTake name xs = pStateListF "lagogo" name xs-lagogoCount :: String -> ControlPattern-lagogoCount name = pStateF "lagogo" name (maybe 0 (+1))-lagogoCountTo :: String -> Pattern Double -> Pattern ValueMap-lagogoCountTo name ipat = innerJoin $ (\i -> pStateF "lagogo" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lagogobus :: Pattern Int -> Pattern Double -> ControlPattern-lagogobus busid pat = (pF "lagogo" pat) # (pI "^lagogo" busid)-lagogorecv :: Pattern Int -> ControlPattern-lagogorecv busid = pI "^lagogo" busid---- | Low pass sort of spectral filter-lbrick :: Pattern Double -> ControlPattern-lbrick = pF "lbrick"-lbrickTake :: String -> [Double] -> ControlPattern-lbrickTake name xs = pStateListF "lbrick" name xs-lbrickCount :: String -> ControlPattern-lbrickCount name = pStateF "lbrick" name (maybe 0 (+1))-lbrickCountTo :: String -> Pattern Double -> Pattern ValueMap-lbrickCountTo name ipat = innerJoin $ (\i -> pStateF "lbrick" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lbrickbus :: Pattern Int -> Pattern Double -> ControlPattern-lbrickbus busid pat = (pF "lbrick" pat) # (pI "^lbrick" busid)-lbrickrecv :: Pattern Int -> ControlPattern-lbrickrecv busid = pI "^lbrick" busid---- | -lclap :: Pattern Double -> ControlPattern-lclap = pF "lclap"-lclapTake :: String -> [Double] -> ControlPattern-lclapTake name xs = pStateListF "lclap" name xs-lclapCount :: String -> ControlPattern-lclapCount name = pStateF "lclap" name (maybe 0 (+1))-lclapCountTo :: String -> Pattern Double -> Pattern ValueMap-lclapCountTo name ipat = innerJoin $ (\i -> pStateF "lclap" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lclapbus :: Pattern Int -> Pattern Double -> ControlPattern-lclapbus busid pat = (pF "lclap" pat) # (pI "^lclap" busid)-lclaprecv :: Pattern Int -> ControlPattern-lclaprecv busid = pI "^lclap" busid---- | -lclaves :: Pattern Double -> ControlPattern-lclaves = pF "lclaves"-lclavesTake :: String -> [Double] -> ControlPattern-lclavesTake name xs = pStateListF "lclaves" name xs-lclavesCount :: String -> ControlPattern-lclavesCount name = pStateF "lclaves" name (maybe 0 (+1))-lclavesCountTo :: String -> Pattern Double -> Pattern ValueMap-lclavesCountTo name ipat = innerJoin $ (\i -> pStateF "lclaves" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lclavesbus :: Pattern Int -> Pattern Double -> ControlPattern-lclavesbus busid pat = (pF "lclaves" pat) # (pI "^lclaves" busid)-lclavesrecv :: Pattern Int -> ControlPattern-lclavesrecv busid = pI "^lclaves" busid---- | -lclhat :: Pattern Double -> ControlPattern-lclhat = pF "lclhat"-lclhatTake :: String -> [Double] -> ControlPattern-lclhatTake name xs = pStateListF "lclhat" name xs-lclhatCount :: String -> ControlPattern-lclhatCount name = pStateF "lclhat" name (maybe 0 (+1))-lclhatCountTo :: String -> Pattern Double -> Pattern ValueMap-lclhatCountTo name ipat = innerJoin $ (\i -> pStateF "lclhat" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lclhatbus :: Pattern Int -> Pattern Double -> ControlPattern-lclhatbus busid pat = (pF "lclhat" pat) # (pI "^lclhat" busid)-lclhatrecv :: Pattern Int -> ControlPattern-lclhatrecv busid = pI "^lclhat" busid---- | -lcrash :: Pattern Double -> ControlPattern-lcrash = pF "lcrash"-lcrashTake :: String -> [Double] -> ControlPattern-lcrashTake name xs = pStateListF "lcrash" name xs-lcrashCount :: String -> ControlPattern-lcrashCount name = pStateF "lcrash" name (maybe 0 (+1))-lcrashCountTo :: String -> Pattern Double -> Pattern ValueMap-lcrashCountTo name ipat = innerJoin $ (\i -> pStateF "lcrash" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lcrashbus :: Pattern Int -> Pattern Double -> ControlPattern-lcrashbus busid pat = (pF "lcrash" pat) # (pI "^lcrash" busid)-lcrashrecv :: Pattern Int -> ControlPattern-lcrashrecv busid = pI "^lcrash" busid---- | controls the amount of overlap between two adjacent sounds-legato :: Pattern Double -> ControlPattern-legato = pF "legato"-legatoTake :: String -> [Double] -> ControlPattern-legatoTake name xs = pStateListF "legato" name xs-legatoCount :: String -> ControlPattern-legatoCount name = pStateF "legato" name (maybe 0 (+1))-legatoCountTo :: String -> Pattern Double -> Pattern ValueMap-legatoCountTo name ipat = innerJoin $ (\i -> pStateF "legato" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--legatobus :: Pattern Int -> Pattern Double -> ControlPattern-legatobus _ _ = error $ "Control parameter 'legato' can't be sent to a bus."---- | -leslie :: Pattern Double -> ControlPattern-leslie = pF "leslie"-leslieTake :: String -> [Double] -> ControlPattern-leslieTake name xs = pStateListF "leslie" name xs-leslieCount :: String -> ControlPattern-leslieCount name = pStateF "leslie" name (maybe 0 (+1))-leslieCountTo :: String -> Pattern Double -> Pattern ValueMap-leslieCountTo name ipat = innerJoin $ (\i -> pStateF "leslie" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lesliebus :: Pattern Int -> Pattern Double -> ControlPattern-lesliebus busid pat = (pF "leslie" pat) # (pI "^leslie" busid)-leslierecv :: Pattern Int -> ControlPattern-leslierecv busid = pI "^leslie" busid---- | -lfo :: Pattern Double -> ControlPattern-lfo = pF "lfo"-lfoTake :: String -> [Double] -> ControlPattern-lfoTake name xs = pStateListF "lfo" name xs-lfoCount :: String -> ControlPattern-lfoCount name = pStateF "lfo" name (maybe 0 (+1))-lfoCountTo :: String -> Pattern Double -> Pattern ValueMap-lfoCountTo name ipat = innerJoin $ (\i -> pStateF "lfo" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lfobus :: Pattern Int -> Pattern Double -> ControlPattern-lfobus busid pat = (pF "lfo" pat) # (pI "^lfo" busid)-lforecv :: Pattern Int -> ControlPattern-lforecv busid = pI "^lfo" busid---- | -lfocutoffint :: Pattern Double -> ControlPattern-lfocutoffint = pF "lfocutoffint"-lfocutoffintTake :: String -> [Double] -> ControlPattern-lfocutoffintTake name xs = pStateListF "lfocutoffint" name xs-lfocutoffintCount :: String -> ControlPattern-lfocutoffintCount name = pStateF "lfocutoffint" name (maybe 0 (+1))-lfocutoffintCountTo :: String -> Pattern Double -> Pattern ValueMap-lfocutoffintCountTo name ipat = innerJoin $ (\i -> pStateF "lfocutoffint" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lfocutoffintbus :: Pattern Int -> Pattern Double -> ControlPattern-lfocutoffintbus busid pat = (pF "lfocutoffint" pat) # (pI "^lfocutoffint" busid)-lfocutoffintrecv :: Pattern Int -> ControlPattern-lfocutoffintrecv busid = pI "^lfocutoffint" busid---- | -lfodelay :: Pattern Double -> ControlPattern-lfodelay = pF "lfodelay"-lfodelayTake :: String -> [Double] -> ControlPattern-lfodelayTake name xs = pStateListF "lfodelay" name xs-lfodelayCount :: String -> ControlPattern-lfodelayCount name = pStateF "lfodelay" name (maybe 0 (+1))-lfodelayCountTo :: String -> Pattern Double -> Pattern ValueMap-lfodelayCountTo name ipat = innerJoin $ (\i -> pStateF "lfodelay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lfodelaybus :: Pattern Int -> Pattern Double -> ControlPattern-lfodelaybus busid pat = (pF "lfodelay" pat) # (pI "^lfodelay" busid)-lfodelayrecv :: Pattern Int -> ControlPattern-lfodelayrecv busid = pI "^lfodelay" busid---- | -lfoint :: Pattern Double -> ControlPattern-lfoint = pF "lfoint"-lfointTake :: String -> [Double] -> ControlPattern-lfointTake name xs = pStateListF "lfoint" name xs-lfointCount :: String -> ControlPattern-lfointCount name = pStateF "lfoint" name (maybe 0 (+1))-lfointCountTo :: String -> Pattern Double -> Pattern ValueMap-lfointCountTo name ipat = innerJoin $ (\i -> pStateF "lfoint" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lfointbus :: Pattern Int -> Pattern Double -> ControlPattern-lfointbus busid pat = (pF "lfoint" pat) # (pI "^lfoint" busid)-lfointrecv :: Pattern Int -> ControlPattern-lfointrecv busid = pI "^lfoint" busid---- | -lfopitchint :: Pattern Double -> ControlPattern-lfopitchint = pF "lfopitchint"-lfopitchintTake :: String -> [Double] -> ControlPattern-lfopitchintTake name xs = pStateListF "lfopitchint" name xs-lfopitchintCount :: String -> ControlPattern-lfopitchintCount name = pStateF "lfopitchint" name (maybe 0 (+1))-lfopitchintCountTo :: String -> Pattern Double -> Pattern ValueMap-lfopitchintCountTo name ipat = innerJoin $ (\i -> pStateF "lfopitchint" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lfopitchintbus :: Pattern Int -> Pattern Double -> ControlPattern-lfopitchintbus busid pat = (pF "lfopitchint" pat) # (pI "^lfopitchint" busid)-lfopitchintrecv :: Pattern Int -> ControlPattern-lfopitchintrecv busid = pI "^lfopitchint" busid---- | -lfoshape :: Pattern Double -> ControlPattern-lfoshape = pF "lfoshape"-lfoshapeTake :: String -> [Double] -> ControlPattern-lfoshapeTake name xs = pStateListF "lfoshape" name xs-lfoshapeCount :: String -> ControlPattern-lfoshapeCount name = pStateF "lfoshape" name (maybe 0 (+1))-lfoshapeCountTo :: String -> Pattern Double -> Pattern ValueMap-lfoshapeCountTo name ipat = innerJoin $ (\i -> pStateF "lfoshape" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lfoshapebus :: Pattern Int -> Pattern Double -> ControlPattern-lfoshapebus busid pat = (pF "lfoshape" pat) # (pI "^lfoshape" busid)-lfoshaperecv :: Pattern Int -> ControlPattern-lfoshaperecv busid = pI "^lfoshape" busid---- | -lfosync :: Pattern Double -> ControlPattern-lfosync = pF "lfosync"-lfosyncTake :: String -> [Double] -> ControlPattern-lfosyncTake name xs = pStateListF "lfosync" name xs-lfosyncCount :: String -> ControlPattern-lfosyncCount name = pStateF "lfosync" name (maybe 0 (+1))-lfosyncCountTo :: String -> Pattern Double -> Pattern ValueMap-lfosyncCountTo name ipat = innerJoin $ (\i -> pStateF "lfosync" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lfosyncbus :: Pattern Int -> Pattern Double -> ControlPattern-lfosyncbus busid pat = (pF "lfosync" pat) # (pI "^lfosync" busid)-lfosyncrecv :: Pattern Int -> ControlPattern-lfosyncrecv busid = pI "^lfosync" busid---- | -lhitom :: Pattern Double -> ControlPattern-lhitom = pF "lhitom"-lhitomTake :: String -> [Double] -> ControlPattern-lhitomTake name xs = pStateListF "lhitom" name xs-lhitomCount :: String -> ControlPattern-lhitomCount name = pStateF "lhitom" name (maybe 0 (+1))-lhitomCountTo :: String -> Pattern Double -> Pattern ValueMap-lhitomCountTo name ipat = innerJoin $ (\i -> pStateF "lhitom" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lhitombus :: Pattern Int -> Pattern Double -> ControlPattern-lhitombus busid pat = (pF "lhitom" pat) # (pI "^lhitom" busid)-lhitomrecv :: Pattern Int -> ControlPattern-lhitomrecv busid = pI "^lhitom" busid---- | -lkick :: Pattern Double -> ControlPattern-lkick = pF "lkick"-lkickTake :: String -> [Double] -> ControlPattern-lkickTake name xs = pStateListF "lkick" name xs-lkickCount :: String -> ControlPattern-lkickCount name = pStateF "lkick" name (maybe 0 (+1))-lkickCountTo :: String -> Pattern Double -> Pattern ValueMap-lkickCountTo name ipat = innerJoin $ (\i -> pStateF "lkick" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lkickbus :: Pattern Int -> Pattern Double -> ControlPattern-lkickbus busid pat = (pF "lkick" pat) # (pI "^lkick" busid)-lkickrecv :: Pattern Int -> ControlPattern-lkickrecv busid = pI "^lkick" busid---- | -llotom :: Pattern Double -> ControlPattern-llotom = pF "llotom"-llotomTake :: String -> [Double] -> ControlPattern-llotomTake name xs = pStateListF "llotom" name xs-llotomCount :: String -> ControlPattern-llotomCount name = pStateF "llotom" name (maybe 0 (+1))-llotomCountTo :: String -> Pattern Double -> Pattern ValueMap-llotomCountTo name ipat = innerJoin $ (\i -> pStateF "llotom" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--llotombus :: Pattern Int -> Pattern Double -> ControlPattern-llotombus busid pat = (pF "llotom" pat) # (pI "^llotom" busid)-llotomrecv :: Pattern Int -> ControlPattern-llotomrecv busid = pI "^llotom" busid---- | A pattern of numbers. Specifies whether delaytime is calculated relative to cps. When set to 1, delaytime is a direct multiple of a cycle.-lock :: Pattern Double -> ControlPattern-lock = pF "lock"-lockTake :: String -> [Double] -> ControlPattern-lockTake name xs = pStateListF "lock" name xs-lockCount :: String -> ControlPattern-lockCount name = pStateF "lock" name (maybe 0 (+1))-lockCountTo :: String -> Pattern Double -> Pattern ValueMap-lockCountTo name ipat = innerJoin $ (\i -> pStateF "lock" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lockbus :: Pattern Int -> Pattern Double -> ControlPattern-lockbus busid pat = (pF "lock" pat) # (pI "^lock" busid)-lockrecv :: Pattern Int -> ControlPattern-lockrecv busid = pI "^lock" busid---- | loops the sample (from `begin` to `end`) the specified number of times.-loop :: Pattern Double -> ControlPattern-loop = pF "loop"-loopTake :: String -> [Double] -> ControlPattern-loopTake name xs = pStateListF "loop" name xs-loopCount :: String -> ControlPattern-loopCount name = pStateF "loop" name (maybe 0 (+1))-loopCountTo :: String -> Pattern Double -> Pattern ValueMap-loopCountTo name ipat = innerJoin $ (\i -> pStateF "loop" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--loopbus :: Pattern Int -> Pattern Double -> ControlPattern-loopbus _ _ = error $ "Control parameter 'loop' can't be sent to a bus."---- | -lophat :: Pattern Double -> ControlPattern-lophat = pF "lophat"-lophatTake :: String -> [Double] -> ControlPattern-lophatTake name xs = pStateListF "lophat" name xs-lophatCount :: String -> ControlPattern-lophatCount name = pStateF "lophat" name (maybe 0 (+1))-lophatCountTo :: String -> Pattern Double -> Pattern ValueMap-lophatCountTo name ipat = innerJoin $ (\i -> pStateF "lophat" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lophatbus :: Pattern Int -> Pattern Double -> ControlPattern-lophatbus busid pat = (pF "lophat" pat) # (pI "^lophat" busid)-lophatrecv :: Pattern Int -> ControlPattern-lophatrecv busid = pI "^lophat" busid---- | -lrate :: Pattern Double -> ControlPattern-lrate = pF "lrate"-lrateTake :: String -> [Double] -> ControlPattern-lrateTake name xs = pStateListF "lrate" name xs-lrateCount :: String -> ControlPattern-lrateCount name = pStateF "lrate" name (maybe 0 (+1))-lrateCountTo :: String -> Pattern Double -> Pattern ValueMap-lrateCountTo name ipat = innerJoin $ (\i -> pStateF "lrate" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lratebus :: Pattern Int -> Pattern Double -> ControlPattern-lratebus busid pat = (pF "lrate" pat) # (pI "^lrate" busid)-lraterecv :: Pattern Int -> ControlPattern-lraterecv busid = pI "^lrate" busid---- | -lsize :: Pattern Double -> ControlPattern-lsize = pF "lsize"-lsizeTake :: String -> [Double] -> ControlPattern-lsizeTake name xs = pStateListF "lsize" name xs-lsizeCount :: String -> ControlPattern-lsizeCount name = pStateF "lsize" name (maybe 0 (+1))-lsizeCountTo :: String -> Pattern Double -> Pattern ValueMap-lsizeCountTo name ipat = innerJoin $ (\i -> pStateF "lsize" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lsizebus :: Pattern Int -> Pattern Double -> ControlPattern-lsizebus busid pat = (pF "lsize" pat) # (pI "^lsize" busid)-lsizerecv :: Pattern Int -> ControlPattern-lsizerecv busid = pI "^lsize" busid---- | -lsnare :: Pattern Double -> ControlPattern-lsnare = pF "lsnare"-lsnareTake :: String -> [Double] -> ControlPattern-lsnareTake name xs = pStateListF "lsnare" name xs-lsnareCount :: String -> ControlPattern-lsnareCount name = pStateF "lsnare" name (maybe 0 (+1))-lsnareCountTo :: String -> Pattern Double -> Pattern ValueMap-lsnareCountTo name ipat = innerJoin $ (\i -> pStateF "lsnare" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--lsnarebus :: Pattern Int -> Pattern Double -> ControlPattern-lsnarebus busid pat = (pF "lsnare" pat) # (pI "^lsnare" busid)-lsnarerecv :: Pattern Int -> ControlPattern-lsnarerecv busid = pI "^lsnare" busid---- | A pattern of numbers. Specifies whether the pitch of played samples should be tuned relative to their pitch metadata, if it exists. When set to 1, pitch metadata is applied. When set to 0, pitch metadata is ignored.-metatune :: Pattern Double -> ControlPattern-metatune = pF "metatune"-metatuneTake :: String -> [Double] -> ControlPattern-metatuneTake name xs = pStateListF "metatune" name xs-metatuneCount :: String -> ControlPattern-metatuneCount name = pStateF "metatune" name (maybe 0 (+1))-metatuneCountTo :: String -> Pattern Double -> Pattern ValueMap-metatuneCountTo name ipat = innerJoin $ (\i -> pStateF "metatune" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--metatunebus :: Pattern Int -> Pattern Double -> ControlPattern-metatunebus busid pat = (pF "metatune" pat) # (pI "^metatune" busid)-metatunerecv :: Pattern Int -> ControlPattern-metatunerecv busid = pI "^metatune" busid---- | -midibend :: Pattern Double -> ControlPattern-midibend = pF "midibend"-midibendTake :: String -> [Double] -> ControlPattern-midibendTake name xs = pStateListF "midibend" name xs-midibendCount :: String -> ControlPattern-midibendCount name = pStateF "midibend" name (maybe 0 (+1))-midibendCountTo :: String -> Pattern Double -> Pattern ValueMap-midibendCountTo name ipat = innerJoin $ (\i -> pStateF "midibend" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--midibendbus :: Pattern Int -> Pattern Double -> ControlPattern-midibendbus _ _ = error $ "Control parameter 'midibend' can't be sent to a bus."---- | -midichan :: Pattern Double -> ControlPattern-midichan = pF "midichan"-midichanTake :: String -> [Double] -> ControlPattern-midichanTake name xs = pStateListF "midichan" name xs-midichanCount :: String -> ControlPattern-midichanCount name = pStateF "midichan" name (maybe 0 (+1))-midichanCountTo :: String -> Pattern Double -> Pattern ValueMap-midichanCountTo name ipat = innerJoin $ (\i -> pStateF "midichan" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--midichanbus :: Pattern Int -> Pattern Double -> ControlPattern-midichanbus _ _ = error $ "Control parameter 'midichan' can't be sent to a bus."---- | -midicmd :: Pattern String -> ControlPattern-midicmd = pS "midicmd"-midicmdTake :: String -> [Double] -> ControlPattern-midicmdTake name xs = pStateListF "midicmd" name xs-midicmdbus :: Pattern Int -> Pattern String -> ControlPattern-midicmdbus _ _ = error $ "Control parameter 'midicmd' can't be sent to a bus."---- | -miditouch :: Pattern Double -> ControlPattern-miditouch = pF "miditouch"-miditouchTake :: String -> [Double] -> ControlPattern-miditouchTake name xs = pStateListF "miditouch" name xs-miditouchCount :: String -> ControlPattern-miditouchCount name = pStateF "miditouch" name (maybe 0 (+1))-miditouchCountTo :: String -> Pattern Double -> Pattern ValueMap-miditouchCountTo name ipat = innerJoin $ (\i -> pStateF "miditouch" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--miditouchbus :: Pattern Int -> Pattern Double -> ControlPattern-miditouchbus _ _ = error $ "Control parameter 'miditouch' can't be sent to a bus."---- | -minutes :: Pattern Double -> ControlPattern-minutes = pF "minutes"-minutesTake :: String -> [Double] -> ControlPattern-minutesTake name xs = pStateListF "minutes" name xs-minutesCount :: String -> ControlPattern-minutesCount name = pStateF "minutes" name (maybe 0 (+1))-minutesCountTo :: String -> Pattern Double -> Pattern ValueMap-minutesCountTo name ipat = innerJoin $ (\i -> pStateF "minutes" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--minutesbus :: Pattern Int -> Pattern Double -> ControlPattern-minutesbus _ _ = error $ "Control parameter 'minutes' can't be sent to a bus."---- | -modwheel :: Pattern Double -> ControlPattern-modwheel = pF "modwheel"-modwheelTake :: String -> [Double] -> ControlPattern-modwheelTake name xs = pStateListF "modwheel" name xs-modwheelCount :: String -> ControlPattern-modwheelCount name = pStateF "modwheel" name (maybe 0 (+1))-modwheelCountTo :: String -> Pattern Double -> Pattern ValueMap-modwheelCountTo name ipat = innerJoin $ (\i -> pStateF "modwheel" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--modwheelbus :: Pattern Int -> Pattern Double -> ControlPattern-modwheelbus busid pat = (pF "modwheel" pat) # (pI "^modwheel" busid)-modwheelrecv :: Pattern Int -> ControlPattern-modwheelrecv busid = pI "^modwheel" busid---- | -mtranspose :: Pattern Double -> ControlPattern-mtranspose = pF "mtranspose"-mtransposeTake :: String -> [Double] -> ControlPattern-mtransposeTake name xs = pStateListF "mtranspose" name xs-mtransposeCount :: String -> ControlPattern-mtransposeCount name = pStateF "mtranspose" name (maybe 0 (+1))-mtransposeCountTo :: String -> Pattern Double -> Pattern ValueMap-mtransposeCountTo name ipat = innerJoin $ (\i -> pStateF "mtranspose" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--mtransposebus :: Pattern Int -> Pattern Double -> ControlPattern-mtransposebus busid pat = (pF "mtranspose" pat) # (pI "^mtranspose" busid)-mtransposerecv :: Pattern Int -> ControlPattern-mtransposerecv busid = pI "^mtranspose" busid---- | The note or sample number to choose for a synth or sampleset-n :: Pattern Note -> ControlPattern-n = pN "n"-nTake :: String -> [Double] -> ControlPattern-nTake name xs = pStateListF "n" name xs-nCount :: String -> ControlPattern-nCount name = pStateF "n" name (maybe 0 (+1))-nCountTo :: String -> Pattern Double -> Pattern ValueMap-nCountTo name ipat = innerJoin $ (\i -> pStateF "n" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--nbus :: Pattern Int -> Pattern Note -> ControlPattern-nbus _ _ = error $ "Control parameter 'n' can't be sent to a bus."---- | The note or pitch to play a sound or synth with-note :: Pattern Note -> ControlPattern-note = pN "note"-noteTake :: String -> [Double] -> ControlPattern-noteTake name xs = pStateListF "note" name xs-noteCount :: String -> ControlPattern-noteCount name = pStateF "note" name (maybe 0 (+1))-noteCountTo :: String -> Pattern Double -> Pattern ValueMap-noteCountTo name ipat = innerJoin $ (\i -> pStateF "note" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--notebus :: Pattern Int -> Pattern Note -> ControlPattern-notebus _ _ = error $ "Control parameter 'note' can't be sent to a bus."---- | Nudges events into the future by the specified number of seconds. Negative numbers work up to a point as well (due to internal latency)-nudge :: Pattern Double -> ControlPattern-nudge = pF "nudge"-nudgeTake :: String -> [Double] -> ControlPattern-nudgeTake name xs = pStateListF "nudge" name xs-nudgeCount :: String -> ControlPattern-nudgeCount name = pStateF "nudge" name (maybe 0 (+1))-nudgeCountTo :: String -> Pattern Double -> Pattern ValueMap-nudgeCountTo name ipat = innerJoin $ (\i -> pStateF "nudge" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--nudgebus :: Pattern Int -> Pattern Double -> ControlPattern-nudgebus busid pat = (pF "nudge" pat) # (pI "^nudge" busid)-nudgerecv :: Pattern Int -> ControlPattern-nudgerecv busid = pI "^nudge" busid---- | -octave :: Pattern Int -> ControlPattern-octave = pI "octave"-octaveTake :: String -> [Double] -> ControlPattern-octaveTake name xs = pStateListF "octave" name xs-octaveCount :: String -> ControlPattern-octaveCount name = pStateF "octave" name (maybe 0 (+1))-octaveCountTo :: String -> Pattern Double -> Pattern ValueMap-octaveCountTo name ipat = innerJoin $ (\i -> pStateF "octave" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--octavebus :: Pattern Int -> Pattern Int -> ControlPattern-octavebus _ _ = error $ "Control parameter 'octave' can't be sent to a bus."---- | -octaveR :: Pattern Double -> ControlPattern-octaveR = pF "octaveR"-octaveRTake :: String -> [Double] -> ControlPattern-octaveRTake name xs = pStateListF "octaveR" name xs-octaveRCount :: String -> ControlPattern-octaveRCount name = pStateF "octaveR" name (maybe 0 (+1))-octaveRCountTo :: String -> Pattern Double -> Pattern ValueMap-octaveRCountTo name ipat = innerJoin $ (\i -> pStateF "octaveR" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--octaveRbus :: Pattern Int -> Pattern Double -> ControlPattern-octaveRbus busid pat = (pF "octaveR" pat) # (pI "^octaveR" busid)-octaveRrecv :: Pattern Int -> ControlPattern-octaveRrecv busid = pI "^octaveR" busid---- | octaver effect-octer :: Pattern Double -> ControlPattern-octer = pF "octer"-octerTake :: String -> [Double] -> ControlPattern-octerTake name xs = pStateListF "octer" name xs-octerCount :: String -> ControlPattern-octerCount name = pStateF "octer" name (maybe 0 (+1))-octerCountTo :: String -> Pattern Double -> Pattern ValueMap-octerCountTo name ipat = innerJoin $ (\i -> pStateF "octer" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--octerbus :: Pattern Int -> Pattern Double -> ControlPattern-octerbus busid pat = (pF "octer" pat) # (pI "^octer" busid)-octerrecv :: Pattern Int -> ControlPattern-octerrecv busid = pI "^octer" busid---- | octaver effect-octersub :: Pattern Double -> ControlPattern-octersub = pF "octersub"-octersubTake :: String -> [Double] -> ControlPattern-octersubTake name xs = pStateListF "octersub" name xs-octersubCount :: String -> ControlPattern-octersubCount name = pStateF "octersub" name (maybe 0 (+1))-octersubCountTo :: String -> Pattern Double -> Pattern ValueMap-octersubCountTo name ipat = innerJoin $ (\i -> pStateF "octersub" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--octersubbus :: Pattern Int -> Pattern Double -> ControlPattern-octersubbus busid pat = (pF "octersub" pat) # (pI "^octersub" busid)-octersubrecv :: Pattern Int -> ControlPattern-octersubrecv busid = pI "^octersub" busid---- | octaver effect-octersubsub :: Pattern Double -> ControlPattern-octersubsub = pF "octersubsub"-octersubsubTake :: String -> [Double] -> ControlPattern-octersubsubTake name xs = pStateListF "octersubsub" name xs-octersubsubCount :: String -> ControlPattern-octersubsubCount name = pStateF "octersubsub" name (maybe 0 (+1))-octersubsubCountTo :: String -> Pattern Double -> Pattern ValueMap-octersubsubCountTo name ipat = innerJoin $ (\i -> pStateF "octersubsub" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--octersubsubbus :: Pattern Int -> Pattern Double -> ControlPattern-octersubsubbus busid pat = (pF "octersubsub" pat) # (pI "^octersubsub" busid)-octersubsubrecv :: Pattern Int -> ControlPattern-octersubsubrecv busid = pI "^octersubsub" busid---- | -offset :: Pattern Double -> ControlPattern-offset = pF "offset"-offsetTake :: String -> [Double] -> ControlPattern-offsetTake name xs = pStateListF "offset" name xs-offsetCount :: String -> ControlPattern-offsetCount name = pStateF "offset" name (maybe 0 (+1))-offsetCountTo :: String -> Pattern Double -> Pattern ValueMap-offsetCountTo name ipat = innerJoin $ (\i -> pStateF "offset" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--offsetbus :: Pattern Int -> Pattern Double -> ControlPattern-offsetbus _ _ = error $ "Control parameter 'offset' can't be sent to a bus."---- | -ophatdecay :: Pattern Double -> ControlPattern-ophatdecay = pF "ophatdecay"-ophatdecayTake :: String -> [Double] -> ControlPattern-ophatdecayTake name xs = pStateListF "ophatdecay" name xs-ophatdecayCount :: String -> ControlPattern-ophatdecayCount name = pStateF "ophatdecay" name (maybe 0 (+1))-ophatdecayCountTo :: String -> Pattern Double -> Pattern ValueMap-ophatdecayCountTo name ipat = innerJoin $ (\i -> pStateF "ophatdecay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--ophatdecaybus :: Pattern Int -> Pattern Double -> ControlPattern-ophatdecaybus busid pat = (pF "ophatdecay" pat) # (pI "^ophatdecay" busid)-ophatdecayrecv :: Pattern Int -> ControlPattern-ophatdecayrecv busid = pI "^ophatdecay" busid---- | a pattern of numbers. An "orbit" is a global parameter context for patterns. Patterns with the same orbit will share hardware output bus offset and global effects, e.g. reverb and delay. The maximum number of orbits is specified in the superdirt startup, numbers higher than maximum will wrap around.-orbit :: Pattern Int -> ControlPattern-orbit = pI "orbit"-orbitTake :: String -> [Double] -> ControlPattern-orbitTake name xs = pStateListF "orbit" name xs-orbitCount :: String -> ControlPattern-orbitCount name = pStateF "orbit" name (maybe 0 (+1))-orbitCountTo :: String -> Pattern Double -> Pattern ValueMap-orbitCountTo name ipat = innerJoin $ (\i -> pStateF "orbit" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--orbitbus :: Pattern Int -> Pattern Int -> ControlPattern-orbitbus busid pat = (pI "orbit" pat) # (pI "^orbit" busid)-orbitrecv :: Pattern Int -> ControlPattern-orbitrecv busid = pI "^orbit" busid---- | -overgain :: Pattern Double -> ControlPattern-overgain = pF "overgain"-overgainTake :: String -> [Double] -> ControlPattern-overgainTake name xs = pStateListF "overgain" name xs-overgainCount :: String -> ControlPattern-overgainCount name = pStateF "overgain" name (maybe 0 (+1))-overgainCountTo :: String -> Pattern Double -> Pattern ValueMap-overgainCountTo name ipat = innerJoin $ (\i -> pStateF "overgain" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--overgainbus :: Pattern Int -> Pattern Double -> ControlPattern-overgainbus _ _ = error $ "Control parameter 'overgain' can't be sent to a bus."---- | -overshape :: Pattern Double -> ControlPattern-overshape = pF "overshape"-overshapeTake :: String -> [Double] -> ControlPattern-overshapeTake name xs = pStateListF "overshape" name xs-overshapeCount :: String -> ControlPattern-overshapeCount name = pStateF "overshape" name (maybe 0 (+1))-overshapeCountTo :: String -> Pattern Double -> Pattern ValueMap-overshapeCountTo name ipat = innerJoin $ (\i -> pStateF "overshape" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--overshapebus :: Pattern Int -> Pattern Double -> ControlPattern-overshapebus busid pat = (pF "overshape" pat) # (pI "^overshape" busid)-overshaperecv :: Pattern Int -> ControlPattern-overshaperecv busid = pI "^overshape" busid---- | 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"-panTake :: String -> [Double] -> ControlPattern-panTake name xs = pStateListF "pan" name xs-panCount :: String -> ControlPattern-panCount name = pStateF "pan" name (maybe 0 (+1))-panCountTo :: String -> Pattern Double -> Pattern ValueMap-panCountTo name ipat = innerJoin $ (\i -> pStateF "pan" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--panbus :: Pattern Int -> Pattern Double -> ControlPattern-panbus busid pat = (pF "pan" pat) # (pI "^pan" busid)-panrecv :: Pattern Int -> ControlPattern-panrecv busid = pI "^pan" busid---- | a pattern of numbers between -1.0 and 1.0, which controls the relative position of the centre pan in a pair of adjacent speakers (multichannel only)-panorient :: Pattern Double -> ControlPattern-panorient = pF "panorient"-panorientTake :: String -> [Double] -> ControlPattern-panorientTake name xs = pStateListF "panorient" name xs-panorientCount :: String -> ControlPattern-panorientCount name = pStateF "panorient" name (maybe 0 (+1))-panorientCountTo :: String -> Pattern Double -> Pattern ValueMap-panorientCountTo name ipat = innerJoin $ (\i -> pStateF "panorient" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--panorientbus :: Pattern Int -> Pattern Double -> ControlPattern-panorientbus busid pat = (pF "panorient" pat) # (pI "^panorient" busid)-panorientrecv :: Pattern Int -> ControlPattern-panorientrecv busid = pI "^panorient" busid---- | a pattern of numbers between -inf and inf, which controls how much multichannel output is fanned out (negative is backwards ordering)-panspan :: Pattern Double -> ControlPattern-panspan = pF "panspan"-panspanTake :: String -> [Double] -> ControlPattern-panspanTake name xs = pStateListF "panspan" name xs-panspanCount :: String -> ControlPattern-panspanCount name = pStateF "panspan" name (maybe 0 (+1))-panspanCountTo :: String -> Pattern Double -> Pattern ValueMap-panspanCountTo name ipat = innerJoin $ (\i -> pStateF "panspan" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--panspanbus :: Pattern Int -> Pattern Double -> ControlPattern-panspanbus busid pat = (pF "panspan" pat) # (pI "^panspan" busid)-panspanrecv :: Pattern Int -> ControlPattern-panspanrecv busid = pI "^panspan" busid---- | a pattern of numbers between 0.0 and 1.0, which controls the multichannel spread range (multichannel only)-pansplay :: Pattern Double -> ControlPattern-pansplay = pF "pansplay"-pansplayTake :: String -> [Double] -> ControlPattern-pansplayTake name xs = pStateListF "pansplay" name xs-pansplayCount :: String -> ControlPattern-pansplayCount name = pStateF "pansplay" name (maybe 0 (+1))-pansplayCountTo :: String -> Pattern Double -> Pattern ValueMap-pansplayCountTo name ipat = innerJoin $ (\i -> pStateF "pansplay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--pansplaybus :: Pattern Int -> Pattern Double -> ControlPattern-pansplaybus busid pat = (pF "pansplay" pat) # (pI "^pansplay" busid)-pansplayrecv :: Pattern Int -> ControlPattern-pansplayrecv busid = pI "^pansplay" busid---- | a pattern of numbers between 0.0 and inf, which controls how much each channel is distributed over neighbours (multichannel only)-panwidth :: Pattern Double -> ControlPattern-panwidth = pF "panwidth"-panwidthTake :: String -> [Double] -> ControlPattern-panwidthTake name xs = pStateListF "panwidth" name xs-panwidthCount :: String -> ControlPattern-panwidthCount name = pStateF "panwidth" name (maybe 0 (+1))-panwidthCountTo :: String -> Pattern Double -> Pattern ValueMap-panwidthCountTo name ipat = innerJoin $ (\i -> pStateF "panwidth" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--panwidthbus :: Pattern Int -> Pattern Double -> ControlPattern-panwidthbus busid pat = (pF "panwidth" pat) # (pI "^panwidth" busid)-panwidthrecv :: Pattern Int -> ControlPattern-panwidthrecv busid = pI "^panwidth" busid---- | -partials :: Pattern Double -> ControlPattern-partials = pF "partials"-partialsTake :: String -> [Double] -> ControlPattern-partialsTake name xs = pStateListF "partials" name xs-partialsCount :: String -> ControlPattern-partialsCount name = pStateF "partials" name (maybe 0 (+1))-partialsCountTo :: String -> Pattern Double -> Pattern ValueMap-partialsCountTo name ipat = innerJoin $ (\i -> pStateF "partials" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--partialsbus :: Pattern Int -> Pattern Double -> ControlPattern-partialsbus busid pat = (pF "partials" pat) # (pI "^partials" busid)-partialsrecv :: Pattern Int -> ControlPattern-partialsrecv busid = pI "^partials" busid---- | Phaser Audio DSP effect | params are 'phaserrate' and 'phaserdepth'-phaserdepth :: Pattern Double -> ControlPattern-phaserdepth = pF "phaserdepth"-phaserdepthTake :: String -> [Double] -> ControlPattern-phaserdepthTake name xs = pStateListF "phaserdepth" name xs-phaserdepthCount :: String -> ControlPattern-phaserdepthCount name = pStateF "phaserdepth" name (maybe 0 (+1))-phaserdepthCountTo :: String -> Pattern Double -> Pattern ValueMap-phaserdepthCountTo name ipat = innerJoin $ (\i -> pStateF "phaserdepth" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--phaserdepthbus :: Pattern Int -> Pattern Double -> ControlPattern-phaserdepthbus busid pat = (pF "phaserdepth" pat) # (pI "^phaserdepth" busid)-phaserdepthrecv :: Pattern Int -> ControlPattern-phaserdepthrecv busid = pI "^phaserdepth" busid---- | Phaser Audio DSP effect | params are 'phaserrate' and 'phaserdepth'-phaserrate :: Pattern Double -> ControlPattern-phaserrate = pF "phaserrate"-phaserrateTake :: String -> [Double] -> ControlPattern-phaserrateTake name xs = pStateListF "phaserrate" name xs-phaserrateCount :: String -> ControlPattern-phaserrateCount name = pStateF "phaserrate" name (maybe 0 (+1))-phaserrateCountTo :: String -> Pattern Double -> Pattern ValueMap-phaserrateCountTo name ipat = innerJoin $ (\i -> pStateF "phaserrate" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--phaserratebus :: Pattern Int -> Pattern Double -> ControlPattern-phaserratebus busid pat = (pF "phaserrate" pat) # (pI "^phaserrate" busid)-phaserraterecv :: Pattern Int -> ControlPattern-phaserraterecv busid = pI "^phaserrate" busid---- | -pitch1 :: Pattern Double -> ControlPattern-pitch1 = pF "pitch1"-pitch1Take :: String -> [Double] -> ControlPattern-pitch1Take name xs = pStateListF "pitch1" name xs-pitch1Count :: String -> ControlPattern-pitch1Count name = pStateF "pitch1" name (maybe 0 (+1))-pitch1CountTo :: String -> Pattern Double -> Pattern ValueMap-pitch1CountTo name ipat = innerJoin $ (\i -> pStateF "pitch1" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--pitch1bus :: Pattern Int -> Pattern Double -> ControlPattern-pitch1bus busid pat = (pF "pitch1" pat) # (pI "^pitch1" busid)-pitch1recv :: Pattern Int -> ControlPattern-pitch1recv busid = pI "^pitch1" busid---- | -pitch2 :: Pattern Double -> ControlPattern-pitch2 = pF "pitch2"-pitch2Take :: String -> [Double] -> ControlPattern-pitch2Take name xs = pStateListF "pitch2" name xs-pitch2Count :: String -> ControlPattern-pitch2Count name = pStateF "pitch2" name (maybe 0 (+1))-pitch2CountTo :: String -> Pattern Double -> Pattern ValueMap-pitch2CountTo name ipat = innerJoin $ (\i -> pStateF "pitch2" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--pitch2bus :: Pattern Int -> Pattern Double -> ControlPattern-pitch2bus busid pat = (pF "pitch2" pat) # (pI "^pitch2" busid)-pitch2recv :: Pattern Int -> ControlPattern-pitch2recv busid = pI "^pitch2" busid---- | -pitch3 :: Pattern Double -> ControlPattern-pitch3 = pF "pitch3"-pitch3Take :: String -> [Double] -> ControlPattern-pitch3Take name xs = pStateListF "pitch3" name xs-pitch3Count :: String -> ControlPattern-pitch3Count name = pStateF "pitch3" name (maybe 0 (+1))-pitch3CountTo :: String -> Pattern Double -> Pattern ValueMap-pitch3CountTo name ipat = innerJoin $ (\i -> pStateF "pitch3" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--pitch3bus :: Pattern Int -> Pattern Double -> ControlPattern-pitch3bus busid pat = (pF "pitch3" pat) # (pI "^pitch3" busid)-pitch3recv :: Pattern Int -> ControlPattern-pitch3recv busid = pI "^pitch3" busid---- | -polyTouch :: Pattern Double -> ControlPattern-polyTouch = pF "polyTouch"-polyTouchTake :: String -> [Double] -> ControlPattern-polyTouchTake name xs = pStateListF "polyTouch" name xs-polyTouchCount :: String -> ControlPattern-polyTouchCount name = pStateF "polyTouch" name (maybe 0 (+1))-polyTouchCountTo :: String -> Pattern Double -> Pattern ValueMap-polyTouchCountTo name ipat = innerJoin $ (\i -> pStateF "polyTouch" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--polyTouchbus :: Pattern Int -> Pattern Double -> ControlPattern-polyTouchbus _ _ = error $ "Control parameter 'polyTouch' can't be sent to a bus."---- | -portamento :: Pattern Double -> ControlPattern-portamento = pF "portamento"-portamentoTake :: String -> [Double] -> ControlPattern-portamentoTake name xs = pStateListF "portamento" name xs-portamentoCount :: String -> ControlPattern-portamentoCount name = pStateF "portamento" name (maybe 0 (+1))-portamentoCountTo :: String -> Pattern Double -> Pattern ValueMap-portamentoCountTo name ipat = innerJoin $ (\i -> pStateF "portamento" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--portamentobus :: Pattern Int -> Pattern Double -> ControlPattern-portamentobus busid pat = (pF "portamento" pat) # (pI "^portamento" busid)-portamentorecv :: Pattern Int -> ControlPattern-portamentorecv busid = pI "^portamento" busid---- | -progNum :: Pattern Double -> ControlPattern-progNum = pF "progNum"-progNumTake :: String -> [Double] -> ControlPattern-progNumTake name xs = pStateListF "progNum" name xs-progNumCount :: String -> ControlPattern-progNumCount name = pStateF "progNum" name (maybe 0 (+1))-progNumCountTo :: String -> Pattern Double -> Pattern ValueMap-progNumCountTo name ipat = innerJoin $ (\i -> pStateF "progNum" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--progNumbus :: Pattern Int -> Pattern Double -> ControlPattern-progNumbus _ _ = error $ "Control parameter 'progNum' can't be sent to a bus."---- | used in SuperDirt softsynths as a control rate or "speed"-rate :: Pattern Double -> ControlPattern-rate = pF "rate"-rateTake :: String -> [Double] -> ControlPattern-rateTake name xs = pStateListF "rate" name xs-rateCount :: String -> ControlPattern-rateCount name = pStateF "rate" name (maybe 0 (+1))-rateCountTo :: String -> Pattern Double -> Pattern ValueMap-rateCountTo name ipat = innerJoin $ (\i -> pStateF "rate" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--ratebus :: Pattern Int -> Pattern Double -> ControlPattern-ratebus busid pat = (pF "rate" pat) # (pI "^rate" busid)-raterecv :: Pattern Int -> ControlPattern-raterecv busid = pI "^rate" busid---- | Spectral conform-real :: Pattern Double -> ControlPattern-real = pF "real"-realTake :: String -> [Double] -> ControlPattern-realTake name xs = pStateListF "real" name xs-realCount :: String -> ControlPattern-realCount name = pStateF "real" name (maybe 0 (+1))-realCountTo :: String -> Pattern Double -> Pattern ValueMap-realCountTo name ipat = innerJoin $ (\i -> pStateF "real" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--realbus :: Pattern Int -> Pattern Double -> ControlPattern-realbus busid pat = (pF "real" pat) # (pI "^real" busid)-realrecv :: Pattern Int -> ControlPattern-realrecv busid = pI "^real" busid---- | a pattern of numbers to specify the release time (in seconds) of an envelope applied to each sample.-release :: Pattern Double -> ControlPattern-release = pF "release"-releaseTake :: String -> [Double] -> ControlPattern-releaseTake name xs = pStateListF "release" name xs-releaseCount :: String -> ControlPattern-releaseCount name = pStateF "release" name (maybe 0 (+1))-releaseCountTo :: String -> Pattern Double -> Pattern ValueMap-releaseCountTo name ipat = innerJoin $ (\i -> pStateF "release" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--releasebus :: Pattern Int -> Pattern Double -> ControlPattern-releasebus busid pat = (pF "release" pat) # (pI "^release" busid)-releaserecv :: Pattern Int -> ControlPattern-releaserecv busid = pI "^release" busid---- | a pattern of numbers from 0 to 1. Specifies the resonance of the low-pass filter.-resonance :: Pattern Double -> ControlPattern-resonance = pF "resonance"-resonanceTake :: String -> [Double] -> ControlPattern-resonanceTake name xs = pStateListF "resonance" name xs-resonanceCount :: String -> ControlPattern-resonanceCount name = pStateF "resonance" name (maybe 0 (+1))-resonanceCountTo :: String -> Pattern Double -> Pattern ValueMap-resonanceCountTo name ipat = innerJoin $ (\i -> pStateF "resonance" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--resonancebus :: Pattern Int -> Pattern Double -> ControlPattern-resonancebus busid pat = (pF "resonance" pat) # (pI "^resonance" busid)-resonancerecv :: Pattern Int -> ControlPattern-resonancerecv busid = pI "^resonance" busid---- | ring modulation-ring :: Pattern Double -> ControlPattern-ring = pF "ring"-ringTake :: String -> [Double] -> ControlPattern-ringTake name xs = pStateListF "ring" name xs-ringCount :: String -> ControlPattern-ringCount name = pStateF "ring" name (maybe 0 (+1))-ringCountTo :: String -> Pattern Double -> Pattern ValueMap-ringCountTo name ipat = innerJoin $ (\i -> pStateF "ring" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--ringbus :: Pattern Int -> Pattern Double -> ControlPattern-ringbus busid pat = (pF "ring" pat) # (pI "^ring" busid)-ringrecv :: Pattern Int -> ControlPattern-ringrecv busid = pI "^ring" busid---- | ring modulation-ringdf :: Pattern Double -> ControlPattern-ringdf = pF "ringdf"-ringdfTake :: String -> [Double] -> ControlPattern-ringdfTake name xs = pStateListF "ringdf" name xs-ringdfCount :: String -> ControlPattern-ringdfCount name = pStateF "ringdf" name (maybe 0 (+1))-ringdfCountTo :: String -> Pattern Double -> Pattern ValueMap-ringdfCountTo name ipat = innerJoin $ (\i -> pStateF "ringdf" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--ringdfbus :: Pattern Int -> Pattern Double -> ControlPattern-ringdfbus busid pat = (pF "ringdf" pat) # (pI "^ringdf" busid)-ringdfrecv :: Pattern Int -> ControlPattern-ringdfrecv busid = pI "^ringdf" busid---- | ring modulation-ringf :: Pattern Double -> ControlPattern-ringf = pF "ringf"-ringfTake :: String -> [Double] -> ControlPattern-ringfTake name xs = pStateListF "ringf" name xs-ringfCount :: String -> ControlPattern-ringfCount name = pStateF "ringf" name (maybe 0 (+1))-ringfCountTo :: String -> Pattern Double -> Pattern ValueMap-ringfCountTo name ipat = innerJoin $ (\i -> pStateF "ringf" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--ringfbus :: Pattern Int -> Pattern Double -> ControlPattern-ringfbus busid pat = (pF "ringf" pat) # (pI "^ringf" busid)-ringfrecv :: Pattern Int -> ControlPattern-ringfrecv busid = pI "^ringf" busid---- | a pattern of numbers from 0 to 1. Sets the level of reverb.-room :: Pattern Double -> ControlPattern-room = pF "room"-roomTake :: String -> [Double] -> ControlPattern-roomTake name xs = pStateListF "room" name xs-roomCount :: String -> ControlPattern-roomCount name = pStateF "room" name (maybe 0 (+1))-roomCountTo :: String -> Pattern Double -> Pattern ValueMap-roomCountTo name ipat = innerJoin $ (\i -> pStateF "room" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--roombus :: Pattern Int -> Pattern Double -> ControlPattern-roombus busid pat = (pF "room" pat) # (pI "^room" busid)-roomrecv :: Pattern Int -> ControlPattern-roomrecv busid = pI "^room" busid---- | -sagogo :: Pattern Double -> ControlPattern-sagogo = pF "sagogo"-sagogoTake :: String -> [Double] -> ControlPattern-sagogoTake name xs = pStateListF "sagogo" name xs-sagogoCount :: String -> ControlPattern-sagogoCount name = pStateF "sagogo" name (maybe 0 (+1))-sagogoCountTo :: String -> Pattern Double -> Pattern ValueMap-sagogoCountTo name ipat = innerJoin $ (\i -> pStateF "sagogo" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--sagogobus :: Pattern Int -> Pattern Double -> ControlPattern-sagogobus busid pat = (pF "sagogo" pat) # (pI "^sagogo" busid)-sagogorecv :: Pattern Int -> ControlPattern-sagogorecv busid = pI "^sagogo" busid---- | -sclap :: Pattern Double -> ControlPattern-sclap = pF "sclap"-sclapTake :: String -> [Double] -> ControlPattern-sclapTake name xs = pStateListF "sclap" name xs-sclapCount :: String -> ControlPattern-sclapCount name = pStateF "sclap" name (maybe 0 (+1))-sclapCountTo :: String -> Pattern Double -> Pattern ValueMap-sclapCountTo name ipat = innerJoin $ (\i -> pStateF "sclap" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--sclapbus :: Pattern Int -> Pattern Double -> ControlPattern-sclapbus busid pat = (pF "sclap" pat) # (pI "^sclap" busid)-sclaprecv :: Pattern Int -> ControlPattern-sclaprecv busid = pI "^sclap" busid---- | -sclaves :: Pattern Double -> ControlPattern-sclaves = pF "sclaves"-sclavesTake :: String -> [Double] -> ControlPattern-sclavesTake name xs = pStateListF "sclaves" name xs-sclavesCount :: String -> ControlPattern-sclavesCount name = pStateF "sclaves" name (maybe 0 (+1))-sclavesCountTo :: String -> Pattern Double -> Pattern ValueMap-sclavesCountTo name ipat = innerJoin $ (\i -> pStateF "sclaves" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--sclavesbus :: Pattern Int -> Pattern Double -> ControlPattern-sclavesbus busid pat = (pF "sclaves" pat) # (pI "^sclaves" busid)-sclavesrecv :: Pattern Int -> ControlPattern-sclavesrecv busid = pI "^sclaves" busid---- | Spectral scramble-scram :: Pattern Double -> ControlPattern-scram = pF "scram"-scramTake :: String -> [Double] -> ControlPattern-scramTake name xs = pStateListF "scram" name xs-scramCount :: String -> ControlPattern-scramCount name = pStateF "scram" name (maybe 0 (+1))-scramCountTo :: String -> Pattern Double -> Pattern ValueMap-scramCountTo name ipat = innerJoin $ (\i -> pStateF "scram" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--scrambus :: Pattern Int -> Pattern Double -> ControlPattern-scrambus busid pat = (pF "scram" pat) # (pI "^scram" busid)-scramrecv :: Pattern Int -> ControlPattern-scramrecv busid = pI "^scram" busid---- | -scrash :: Pattern Double -> ControlPattern-scrash = pF "scrash"-scrashTake :: String -> [Double] -> ControlPattern-scrashTake name xs = pStateListF "scrash" name xs-scrashCount :: String -> ControlPattern-scrashCount name = pStateF "scrash" name (maybe 0 (+1))-scrashCountTo :: String -> Pattern Double -> Pattern ValueMap-scrashCountTo name ipat = innerJoin $ (\i -> pStateF "scrash" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--scrashbus :: Pattern Int -> Pattern Double -> ControlPattern-scrashbus busid pat = (pF "scrash" pat) # (pI "^scrash" busid)-scrashrecv :: Pattern Int -> ControlPattern-scrashrecv busid = pI "^scrash" busid---- | -seconds :: Pattern Double -> ControlPattern-seconds = pF "seconds"-secondsTake :: String -> [Double] -> ControlPattern-secondsTake name xs = pStateListF "seconds" name xs-secondsCount :: String -> ControlPattern-secondsCount name = pStateF "seconds" name (maybe 0 (+1))-secondsCountTo :: String -> Pattern Double -> Pattern ValueMap-secondsCountTo name ipat = innerJoin $ (\i -> pStateF "seconds" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--secondsbus :: Pattern Int -> Pattern Double -> ControlPattern-secondsbus _ _ = error $ "Control parameter 'seconds' can't be sent to a bus."---- | -semitone :: Pattern Double -> ControlPattern-semitone = pF "semitone"-semitoneTake :: String -> [Double] -> ControlPattern-semitoneTake name xs = pStateListF "semitone" name xs-semitoneCount :: String -> ControlPattern-semitoneCount name = pStateF "semitone" name (maybe 0 (+1))-semitoneCountTo :: String -> Pattern Double -> Pattern ValueMap-semitoneCountTo name ipat = innerJoin $ (\i -> pStateF "semitone" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--semitonebus :: Pattern Int -> Pattern Double -> ControlPattern-semitonebus busid pat = (pF "semitone" pat) # (pI "^semitone" busid)-semitonerecv :: Pattern Int -> ControlPattern-semitonerecv busid = pI "^semitone" busid---- | wave shaping distortion, a pattern of numbers from 0 for no distortion up to 1 for loads of distortion.-shape :: Pattern Double -> ControlPattern-shape = pF "shape"-shapeTake :: String -> [Double] -> ControlPattern-shapeTake name xs = pStateListF "shape" name xs-shapeCount :: String -> ControlPattern-shapeCount name = pStateF "shape" name (maybe 0 (+1))-shapeCountTo :: String -> Pattern Double -> Pattern ValueMap-shapeCountTo name ipat = innerJoin $ (\i -> pStateF "shape" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--shapebus :: Pattern Int -> Pattern Double -> ControlPattern-shapebus busid pat = (pF "shape" pat) # (pI "^shape" busid)-shaperecv :: Pattern Int -> ControlPattern-shaperecv busid = pI "^shape" busid---- | a pattern of numbers from 0 to 1. Sets the perceptual size (reverb time) of the `room` to be used in reverb.-size :: Pattern Double -> ControlPattern-size = pF "size"-sizeTake :: String -> [Double] -> ControlPattern-sizeTake name xs = pStateListF "size" name xs-sizeCount :: String -> ControlPattern-sizeCount name = pStateF "size" name (maybe 0 (+1))-sizeCountTo :: String -> Pattern Double -> Pattern ValueMap-sizeCountTo name ipat = innerJoin $ (\i -> pStateF "size" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--sizebus :: Pattern Int -> Pattern Double -> ControlPattern-sizebus busid pat = (pF "size" pat) # (pI "^size" busid)-sizerecv :: Pattern Int -> ControlPattern-sizerecv busid = pI "^size" busid---- | -slide :: Pattern Double -> ControlPattern-slide = pF "slide"-slideTake :: String -> [Double] -> ControlPattern-slideTake name xs = pStateListF "slide" name xs-slideCount :: String -> ControlPattern-slideCount name = pStateF "slide" name (maybe 0 (+1))-slideCountTo :: String -> Pattern Double -> Pattern ValueMap-slideCountTo name ipat = innerJoin $ (\i -> pStateF "slide" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slidebus :: Pattern Int -> Pattern Double -> ControlPattern-slidebus busid pat = (pF "slide" pat) # (pI "^slide" busid)-sliderecv :: Pattern Int -> ControlPattern-sliderecv busid = pI "^slide" busid---- | -slider0 :: Pattern Double -> ControlPattern-slider0 = pF "slider0"-slider0Take :: String -> [Double] -> ControlPattern-slider0Take name xs = pStateListF "slider0" name xs-slider0Count :: String -> ControlPattern-slider0Count name = pStateF "slider0" name (maybe 0 (+1))-slider0CountTo :: String -> Pattern Double -> Pattern ValueMap-slider0CountTo name ipat = innerJoin $ (\i -> pStateF "slider0" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider0bus :: Pattern Int -> Pattern Double -> ControlPattern-slider0bus busid pat = (pF "slider0" pat) # (pI "^slider0" busid)-slider0recv :: Pattern Int -> ControlPattern-slider0recv busid = pI "^slider0" busid---- | -slider1 :: Pattern Double -> ControlPattern-slider1 = pF "slider1"-slider1Take :: String -> [Double] -> ControlPattern-slider1Take name xs = pStateListF "slider1" name xs-slider1Count :: String -> ControlPattern-slider1Count name = pStateF "slider1" name (maybe 0 (+1))-slider1CountTo :: String -> Pattern Double -> Pattern ValueMap-slider1CountTo name ipat = innerJoin $ (\i -> pStateF "slider1" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider1bus :: Pattern Int -> Pattern Double -> ControlPattern-slider1bus busid pat = (pF "slider1" pat) # (pI "^slider1" busid)-slider1recv :: Pattern Int -> ControlPattern-slider1recv busid = pI "^slider1" busid---- | -slider10 :: Pattern Double -> ControlPattern-slider10 = pF "slider10"-slider10Take :: String -> [Double] -> ControlPattern-slider10Take name xs = pStateListF "slider10" name xs-slider10Count :: String -> ControlPattern-slider10Count name = pStateF "slider10" name (maybe 0 (+1))-slider10CountTo :: String -> Pattern Double -> Pattern ValueMap-slider10CountTo name ipat = innerJoin $ (\i -> pStateF "slider10" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider10bus :: Pattern Int -> Pattern Double -> ControlPattern-slider10bus busid pat = (pF "slider10" pat) # (pI "^slider10" busid)-slider10recv :: Pattern Int -> ControlPattern-slider10recv busid = pI "^slider10" busid---- | -slider11 :: Pattern Double -> ControlPattern-slider11 = pF "slider11"-slider11Take :: String -> [Double] -> ControlPattern-slider11Take name xs = pStateListF "slider11" name xs-slider11Count :: String -> ControlPattern-slider11Count name = pStateF "slider11" name (maybe 0 (+1))-slider11CountTo :: String -> Pattern Double -> Pattern ValueMap-slider11CountTo name ipat = innerJoin $ (\i -> pStateF "slider11" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider11bus :: Pattern Int -> Pattern Double -> ControlPattern-slider11bus busid pat = (pF "slider11" pat) # (pI "^slider11" busid)-slider11recv :: Pattern Int -> ControlPattern-slider11recv busid = pI "^slider11" busid---- | -slider12 :: Pattern Double -> ControlPattern-slider12 = pF "slider12"-slider12Take :: String -> [Double] -> ControlPattern-slider12Take name xs = pStateListF "slider12" name xs-slider12Count :: String -> ControlPattern-slider12Count name = pStateF "slider12" name (maybe 0 (+1))-slider12CountTo :: String -> Pattern Double -> Pattern ValueMap-slider12CountTo name ipat = innerJoin $ (\i -> pStateF "slider12" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider12bus :: Pattern Int -> Pattern Double -> ControlPattern-slider12bus busid pat = (pF "slider12" pat) # (pI "^slider12" busid)-slider12recv :: Pattern Int -> ControlPattern-slider12recv busid = pI "^slider12" busid---- | -slider13 :: Pattern Double -> ControlPattern-slider13 = pF "slider13"-slider13Take :: String -> [Double] -> ControlPattern-slider13Take name xs = pStateListF "slider13" name xs-slider13Count :: String -> ControlPattern-slider13Count name = pStateF "slider13" name (maybe 0 (+1))-slider13CountTo :: String -> Pattern Double -> Pattern ValueMap-slider13CountTo name ipat = innerJoin $ (\i -> pStateF "slider13" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider13bus :: Pattern Int -> Pattern Double -> ControlPattern-slider13bus busid pat = (pF "slider13" pat) # (pI "^slider13" busid)-slider13recv :: Pattern Int -> ControlPattern-slider13recv busid = pI "^slider13" busid---- | -slider14 :: Pattern Double -> ControlPattern-slider14 = pF "slider14"-slider14Take :: String -> [Double] -> ControlPattern-slider14Take name xs = pStateListF "slider14" name xs-slider14Count :: String -> ControlPattern-slider14Count name = pStateF "slider14" name (maybe 0 (+1))-slider14CountTo :: String -> Pattern Double -> Pattern ValueMap-slider14CountTo name ipat = innerJoin $ (\i -> pStateF "slider14" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider14bus :: Pattern Int -> Pattern Double -> ControlPattern-slider14bus busid pat = (pF "slider14" pat) # (pI "^slider14" busid)-slider14recv :: Pattern Int -> ControlPattern-slider14recv busid = pI "^slider14" busid---- | -slider15 :: Pattern Double -> ControlPattern-slider15 = pF "slider15"-slider15Take :: String -> [Double] -> ControlPattern-slider15Take name xs = pStateListF "slider15" name xs-slider15Count :: String -> ControlPattern-slider15Count name = pStateF "slider15" name (maybe 0 (+1))-slider15CountTo :: String -> Pattern Double -> Pattern ValueMap-slider15CountTo name ipat = innerJoin $ (\i -> pStateF "slider15" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider15bus :: Pattern Int -> Pattern Double -> ControlPattern-slider15bus busid pat = (pF "slider15" pat) # (pI "^slider15" busid)-slider15recv :: Pattern Int -> ControlPattern-slider15recv busid = pI "^slider15" busid---- | -slider2 :: Pattern Double -> ControlPattern-slider2 = pF "slider2"-slider2Take :: String -> [Double] -> ControlPattern-slider2Take name xs = pStateListF "slider2" name xs-slider2Count :: String -> ControlPattern-slider2Count name = pStateF "slider2" name (maybe 0 (+1))-slider2CountTo :: String -> Pattern Double -> Pattern ValueMap-slider2CountTo name ipat = innerJoin $ (\i -> pStateF "slider2" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider2bus :: Pattern Int -> Pattern Double -> ControlPattern-slider2bus busid pat = (pF "slider2" pat) # (pI "^slider2" busid)-slider2recv :: Pattern Int -> ControlPattern-slider2recv busid = pI "^slider2" busid---- | -slider3 :: Pattern Double -> ControlPattern-slider3 = pF "slider3"-slider3Take :: String -> [Double] -> ControlPattern-slider3Take name xs = pStateListF "slider3" name xs-slider3Count :: String -> ControlPattern-slider3Count name = pStateF "slider3" name (maybe 0 (+1))-slider3CountTo :: String -> Pattern Double -> Pattern ValueMap-slider3CountTo name ipat = innerJoin $ (\i -> pStateF "slider3" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider3bus :: Pattern Int -> Pattern Double -> ControlPattern-slider3bus busid pat = (pF "slider3" pat) # (pI "^slider3" busid)-slider3recv :: Pattern Int -> ControlPattern-slider3recv busid = pI "^slider3" busid---- | -slider4 :: Pattern Double -> ControlPattern-slider4 = pF "slider4"-slider4Take :: String -> [Double] -> ControlPattern-slider4Take name xs = pStateListF "slider4" name xs-slider4Count :: String -> ControlPattern-slider4Count name = pStateF "slider4" name (maybe 0 (+1))-slider4CountTo :: String -> Pattern Double -> Pattern ValueMap-slider4CountTo name ipat = innerJoin $ (\i -> pStateF "slider4" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider4bus :: Pattern Int -> Pattern Double -> ControlPattern-slider4bus busid pat = (pF "slider4" pat) # (pI "^slider4" busid)-slider4recv :: Pattern Int -> ControlPattern-slider4recv busid = pI "^slider4" busid---- | -slider5 :: Pattern Double -> ControlPattern-slider5 = pF "slider5"-slider5Take :: String -> [Double] -> ControlPattern-slider5Take name xs = pStateListF "slider5" name xs-slider5Count :: String -> ControlPattern-slider5Count name = pStateF "slider5" name (maybe 0 (+1))-slider5CountTo :: String -> Pattern Double -> Pattern ValueMap-slider5CountTo name ipat = innerJoin $ (\i -> pStateF "slider5" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider5bus :: Pattern Int -> Pattern Double -> ControlPattern-slider5bus busid pat = (pF "slider5" pat) # (pI "^slider5" busid)-slider5recv :: Pattern Int -> ControlPattern-slider5recv busid = pI "^slider5" busid---- | -slider6 :: Pattern Double -> ControlPattern-slider6 = pF "slider6"-slider6Take :: String -> [Double] -> ControlPattern-slider6Take name xs = pStateListF "slider6" name xs-slider6Count :: String -> ControlPattern-slider6Count name = pStateF "slider6" name (maybe 0 (+1))-slider6CountTo :: String -> Pattern Double -> Pattern ValueMap-slider6CountTo name ipat = innerJoin $ (\i -> pStateF "slider6" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider6bus :: Pattern Int -> Pattern Double -> ControlPattern-slider6bus busid pat = (pF "slider6" pat) # (pI "^slider6" busid)-slider6recv :: Pattern Int -> ControlPattern-slider6recv busid = pI "^slider6" busid---- | -slider7 :: Pattern Double -> ControlPattern-slider7 = pF "slider7"-slider7Take :: String -> [Double] -> ControlPattern-slider7Take name xs = pStateListF "slider7" name xs-slider7Count :: String -> ControlPattern-slider7Count name = pStateF "slider7" name (maybe 0 (+1))-slider7CountTo :: String -> Pattern Double -> Pattern ValueMap-slider7CountTo name ipat = innerJoin $ (\i -> pStateF "slider7" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider7bus :: Pattern Int -> Pattern Double -> ControlPattern-slider7bus busid pat = (pF "slider7" pat) # (pI "^slider7" busid)-slider7recv :: Pattern Int -> ControlPattern-slider7recv busid = pI "^slider7" busid---- | -slider8 :: Pattern Double -> ControlPattern-slider8 = pF "slider8"-slider8Take :: String -> [Double] -> ControlPattern-slider8Take name xs = pStateListF "slider8" name xs-slider8Count :: String -> ControlPattern-slider8Count name = pStateF "slider8" name (maybe 0 (+1))-slider8CountTo :: String -> Pattern Double -> Pattern ValueMap-slider8CountTo name ipat = innerJoin $ (\i -> pStateF "slider8" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider8bus :: Pattern Int -> Pattern Double -> ControlPattern-slider8bus busid pat = (pF "slider8" pat) # (pI "^slider8" busid)-slider8recv :: Pattern Int -> ControlPattern-slider8recv busid = pI "^slider8" busid---- | -slider9 :: Pattern Double -> ControlPattern-slider9 = pF "slider9"-slider9Take :: String -> [Double] -> ControlPattern-slider9Take name xs = pStateListF "slider9" name xs-slider9Count :: String -> ControlPattern-slider9Count name = pStateF "slider9" name (maybe 0 (+1))-slider9CountTo :: String -> Pattern Double -> Pattern ValueMap-slider9CountTo name ipat = innerJoin $ (\i -> pStateF "slider9" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--slider9bus :: Pattern Int -> Pattern Double -> ControlPattern-slider9bus busid pat = (pF "slider9" pat) # (pI "^slider9" busid)-slider9recv :: Pattern Int -> ControlPattern-slider9recv busid = pI "^slider9" busid---- | Spectral smear-smear :: Pattern Double -> ControlPattern-smear = pF "smear"-smearTake :: String -> [Double] -> ControlPattern-smearTake name xs = pStateListF "smear" name xs-smearCount :: String -> ControlPattern-smearCount name = pStateF "smear" name (maybe 0 (+1))-smearCountTo :: String -> Pattern Double -> Pattern ValueMap-smearCountTo name ipat = innerJoin $ (\i -> pStateF "smear" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--smearbus :: Pattern Int -> Pattern Double -> ControlPattern-smearbus busid pat = (pF "smear" pat) # (pI "^smear" busid)-smearrecv :: Pattern Int -> ControlPattern-smearrecv busid = pI "^smear" busid---- | -songPtr :: Pattern Double -> ControlPattern-songPtr = pF "songPtr"-songPtrTake :: String -> [Double] -> ControlPattern-songPtrTake name xs = pStateListF "songPtr" name xs-songPtrCount :: String -> ControlPattern-songPtrCount name = pStateF "songPtr" name (maybe 0 (+1))-songPtrCountTo :: String -> Pattern Double -> Pattern ValueMap-songPtrCountTo name ipat = innerJoin $ (\i -> pStateF "songPtr" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--songPtrbus :: Pattern Int -> Pattern Double -> ControlPattern-songPtrbus _ _ = error $ "Control parameter 'songPtr' can't be sent to a bus."--{-|- A pattern of numbers which changes the speed of sample playback which also- changes pitch. Negative values will play the sample backwards.-- > d1 $ slow 5 $ s "sax:5" # legato 1 # speed 0.5-- This will play the @sax:5@ sample at half its rate. As a result, the sample will- last twice the normal time, and will be pitched a whole octave lower. This is- equivalent to @d1 $ slow 5 $ s "sax:5" # legato 1 |- note 12@.-- > d1 $ fast 2 $ s "breaks125:1" # cps (125/60/4) # speed (-2)-- In the above example, the break (which lasts for exactly one bar at 125 BPM), will be played backwards, and at double speed (so, we use @fast 2@ to fill the whole cycle).--}-speed :: Pattern Double -> ControlPattern-speed = pF "speed"-speedTake :: String -> [Double] -> ControlPattern-speedTake name xs = pStateListF "speed" name xs-speedCount :: String -> ControlPattern-speedCount name = pStateF "speed" name (maybe 0 (+1))-speedCountTo :: String -> Pattern Double -> Pattern ValueMap-speedCountTo name ipat = innerJoin $ (\i -> pStateF "speed" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--speedbus :: Pattern Int -> Pattern Double -> ControlPattern-speedbus _ _ = error $ "Control parameter 'speed' can't be sent to a bus."---- | -squiz :: Pattern Double -> ControlPattern-squiz = pF "squiz"-squizTake :: String -> [Double] -> ControlPattern-squizTake name xs = pStateListF "squiz" name xs-squizCount :: String -> ControlPattern-squizCount name = pStateF "squiz" name (maybe 0 (+1))-squizCountTo :: String -> Pattern Double -> Pattern ValueMap-squizCountTo name ipat = innerJoin $ (\i -> pStateF "squiz" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--squizbus :: Pattern Int -> Pattern Double -> ControlPattern-squizbus busid pat = (pF "squiz" pat) # (pI "^squiz" busid)-squizrecv :: Pattern Int -> ControlPattern-squizrecv busid = pI "^squiz" busid---- | -stepsPerOctave :: Pattern Double -> ControlPattern-stepsPerOctave = pF "stepsPerOctave"-stepsPerOctaveTake :: String -> [Double] -> ControlPattern-stepsPerOctaveTake name xs = pStateListF "stepsPerOctave" name xs-stepsPerOctaveCount :: String -> ControlPattern-stepsPerOctaveCount name = pStateF "stepsPerOctave" name (maybe 0 (+1))-stepsPerOctaveCountTo :: String -> Pattern Double -> Pattern ValueMap-stepsPerOctaveCountTo name ipat = innerJoin $ (\i -> pStateF "stepsPerOctave" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--stepsPerOctavebus :: Pattern Int -> Pattern Double -> ControlPattern-stepsPerOctavebus busid pat = (pF "stepsPerOctave" pat) # (pI "^stepsPerOctave" busid)-stepsPerOctaverecv :: Pattern Int -> ControlPattern-stepsPerOctaverecv busid = pI "^stepsPerOctave" busid---- | -stutterdepth :: Pattern Double -> ControlPattern-stutterdepth = pF "stutterdepth"-stutterdepthTake :: String -> [Double] -> ControlPattern-stutterdepthTake name xs = pStateListF "stutterdepth" name xs-stutterdepthCount :: String -> ControlPattern-stutterdepthCount name = pStateF "stutterdepth" name (maybe 0 (+1))-stutterdepthCountTo :: String -> Pattern Double -> Pattern ValueMap-stutterdepthCountTo name ipat = innerJoin $ (\i -> pStateF "stutterdepth" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--stutterdepthbus :: Pattern Int -> Pattern Double -> ControlPattern-stutterdepthbus busid pat = (pF "stutterdepth" pat) # (pI "^stutterdepth" busid)-stutterdepthrecv :: Pattern Int -> ControlPattern-stutterdepthrecv busid = pI "^stutterdepth" busid---- | -stuttertime :: Pattern Double -> ControlPattern-stuttertime = pF "stuttertime"-stuttertimeTake :: String -> [Double] -> ControlPattern-stuttertimeTake name xs = pStateListF "stuttertime" name xs-stuttertimeCount :: String -> ControlPattern-stuttertimeCount name = pStateF "stuttertime" name (maybe 0 (+1))-stuttertimeCountTo :: String -> Pattern Double -> Pattern ValueMap-stuttertimeCountTo name ipat = innerJoin $ (\i -> pStateF "stuttertime" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--stuttertimebus :: Pattern Int -> Pattern Double -> ControlPattern-stuttertimebus busid pat = (pF "stuttertime" pat) # (pI "^stuttertime" busid)-stuttertimerecv :: Pattern Int -> ControlPattern-stuttertimerecv busid = pI "^stuttertime" busid--{-|- A pattern of numbers that indicates the total duration of sample playback in seconds.-- This @sustain@ refers to the whole playback duration and is not to be confused with the sustain level of a typical ADSR envelope.-- > d1 $ fast 2 $ s "breaks125:1" # cps (120/60/4) # sustain 1-- At 120 BPM, a cycle lasts for two seconds. In the above example, we cut the- sample so it plays just for one second, and repeat this part two times, so we- fill the whole cycle. Note that sample pitch isn’t modified.-- > d1 $ s "breaks125:2!3" # cps (120/60/4) # sustain "0.4 0.2 0.4" # begin "0 0 0.4"-- Here, we take advantage that sustain receives a pattern to build a different- break from the original sample.--}-sustain :: Pattern Double -> ControlPattern-sustain = pF "sustain"-sustainTake :: String -> [Double] -> ControlPattern-sustainTake name xs = pStateListF "sustain" name xs-sustainCount :: String -> ControlPattern-sustainCount name = pStateF "sustain" name (maybe 0 (+1))-sustainCountTo :: String -> Pattern Double -> Pattern ValueMap-sustainCountTo name ipat = innerJoin $ (\i -> pStateF "sustain" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--sustainbus :: Pattern Int -> Pattern Double -> ControlPattern-sustainbus _ _ = error $ "Control parameter 'sustain' can't be sent to a bus."---- | -sustainpedal :: Pattern Double -> ControlPattern-sustainpedal = pF "sustainpedal"-sustainpedalTake :: String -> [Double] -> ControlPattern-sustainpedalTake name xs = pStateListF "sustainpedal" name xs-sustainpedalCount :: String -> ControlPattern-sustainpedalCount name = pStateF "sustainpedal" name (maybe 0 (+1))-sustainpedalCountTo :: String -> Pattern Double -> Pattern ValueMap-sustainpedalCountTo name ipat = innerJoin $ (\i -> pStateF "sustainpedal" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--sustainpedalbus :: Pattern Int -> Pattern Double -> ControlPattern-sustainpedalbus busid pat = (pF "sustainpedal" pat) # (pI "^sustainpedal" busid)-sustainpedalrecv :: Pattern Int -> ControlPattern-sustainpedalrecv busid = pI "^sustainpedal" busid--{- |- @timescale@ is the main function used to activate time-stretching, and usually- the only one you need. It receives a single parameter which is the stretching- rate to apply.-- You can use any positive number as the ratio, but the particular method used is- designed for ratios greater than 1, and work reasonably well for values between- 0.1 and 3.-- > d1 $ slow 2 $ s "breaks152" # legato 1 # timescale (152/130) # cps (130/60/4)-- In the example above, we set tempo at 130 beats per minute. But we want to play- one of the @breaks152@ samples, which are, as indicated, at 152 BPM. So, the- ratio we want is 152 over 130. This will slow down the sample to fit in our 130- BPM tempo.--}-timescale :: Pattern Double -> ControlPattern-timescale = pF "timescale"--timescaleTake :: String -> [Double] -> ControlPattern-timescaleTake name xs = pStateListF "timescale" name xs-timescaleCount :: String -> ControlPattern-timescaleCount name = pStateF "timescale" name (maybe 0 (+1))-timescaleCountTo :: String -> Pattern Double -> Pattern ValueMap-timescaleCountTo name ipat = innerJoin $ (\i -> pStateF "timescale" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--timescalebus :: Pattern Int -> Pattern Double -> ControlPattern-timescalebus _ _ = error $ "Control parameter 'timescale' can't be sent to a bus."--{- | Time stretch window size.--The algorithm used to time-stretch a sample divides a sample in many little parts, modifies them, and puts them all together again. It uses one particular parameter, called @windowSize@, which is the length of each sample part.--The @windowSize@ value is automatically calculated, but can be changed with @timescalewin@. The @windowSize@ value is multiplied by the number provided.--@timescalewin@ can be used to improve the quality of time-stretching for some samples, or simply as an effect.--Consider the following two examples. In the first one, @timescalewin 0.01@ makes-the window size a lot smaller, and the extreme chopping of the sample causes-a rougher sound. In the second one, @timescalewin 10@ makes the chunks a lot-bigger. The method used overlaps the treated chunks when recomposing the sample,-and, with the bigger window size, this overlap is noticeable and causes a kind-of delay effect.--> d1 $ slow 2-> $ s "breaks152"-> # legato 1-> # timescale (152/130)-> # timescalewin 0.01-> # cps (130/60/4)--> d1 $ slow 2-> $ s "breaks152"-> # legato 1-> # timescale (152/130)-> # timescalewin 10-> # cps (130/60/4)---}-timescalewin :: Pattern Double -> ControlPattern-timescalewin = pF "timescalewin"--timescalewinTake :: String -> [Double] -> ControlPattern-timescalewinTake name xs = pStateListF "timescalewin" name xs-timescalewinCount :: String -> ControlPattern-timescalewinCount name = pStateF "timescalewin" name (maybe 0 (+1))-timescalewinCountTo :: String -> Pattern Double -> Pattern ValueMap-timescalewinCountTo name ipat = innerJoin $ (\i -> pStateF "timescalewin" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--timescalewinbus :: Pattern Int -> Pattern Double -> ControlPattern-timescalewinbus _ _ = error $ "Control parameter 'timescalewin' can't be sent to a bus."---- | for internal sound routing-to :: Pattern Double -> ControlPattern-to = pF "to"-toTake :: String -> [Double] -> ControlPattern-toTake name xs = pStateListF "to" name xs-toCount :: String -> ControlPattern-toCount name = pStateF "to" name (maybe 0 (+1))-toCountTo :: String -> Pattern Double -> Pattern ValueMap-toCountTo name ipat = innerJoin $ (\i -> pStateF "to" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--tobus :: Pattern Int -> Pattern Double -> ControlPattern-tobus busid pat = (pF "to" pat) # (pI "^to" busid)-torecv :: Pattern Int -> ControlPattern-torecv busid = pI "^to" busid---- | for internal sound routing-toArg :: Pattern String -> ControlPattern-toArg = pS "toArg"-toArgTake :: String -> [Double] -> ControlPattern-toArgTake name xs = pStateListF "toArg" name xs-toArgbus :: Pattern Int -> Pattern String -> ControlPattern-toArgbus busid pat = (pS "toArg" pat) # (pI "^toArg" busid)-toArgrecv :: Pattern Int -> ControlPattern-toArgrecv busid = pI "^toArg" busid---- | -tomdecay :: Pattern Double -> ControlPattern-tomdecay = pF "tomdecay"-tomdecayTake :: String -> [Double] -> ControlPattern-tomdecayTake name xs = pStateListF "tomdecay" name xs-tomdecayCount :: String -> ControlPattern-tomdecayCount name = pStateF "tomdecay" name (maybe 0 (+1))-tomdecayCountTo :: String -> Pattern Double -> Pattern ValueMap-tomdecayCountTo name ipat = innerJoin $ (\i -> pStateF "tomdecay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--tomdecaybus :: Pattern Int -> Pattern Double -> ControlPattern-tomdecaybus busid pat = (pF "tomdecay" pat) # (pI "^tomdecay" busid)-tomdecayrecv :: Pattern Int -> ControlPattern-tomdecayrecv busid = pI "^tomdecay" busid---- | Tremolo Audio DSP effect | params are 'tremolorate' and 'tremolodepth'-tremolodepth :: Pattern Double -> ControlPattern-tremolodepth = pF "tremolodepth"-tremolodepthTake :: String -> [Double] -> ControlPattern-tremolodepthTake name xs = pStateListF "tremolodepth" name xs-tremolodepthCount :: String -> ControlPattern-tremolodepthCount name = pStateF "tremolodepth" name (maybe 0 (+1))-tremolodepthCountTo :: String -> Pattern Double -> Pattern ValueMap-tremolodepthCountTo name ipat = innerJoin $ (\i -> pStateF "tremolodepth" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--tremolodepthbus :: Pattern Int -> Pattern Double -> ControlPattern-tremolodepthbus busid pat = (pF "tremolodepth" pat) # (pI "^tremolodepth" busid)-tremolodepthrecv :: Pattern Int -> ControlPattern-tremolodepthrecv busid = pI "^tremolodepth" busid---- | Tremolo Audio DSP effect | params are 'tremolorate' and 'tremolodepth'-tremolorate :: Pattern Double -> ControlPattern-tremolorate = pF "tremolorate"-tremolorateTake :: String -> [Double] -> ControlPattern-tremolorateTake name xs = pStateListF "tremolorate" name xs-tremolorateCount :: String -> ControlPattern-tremolorateCount name = pStateF "tremolorate" name (maybe 0 (+1))-tremolorateCountTo :: String -> Pattern Double -> Pattern ValueMap-tremolorateCountTo name ipat = innerJoin $ (\i -> pStateF "tremolorate" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--tremoloratebus :: Pattern Int -> Pattern Double -> ControlPattern-tremoloratebus busid pat = (pF "tremolorate" pat) # (pI "^tremolorate" busid)-tremoloraterecv :: Pattern Int -> ControlPattern-tremoloraterecv busid = pI "^tremolorate" busid---- | tube distortion-triode :: Pattern Double -> ControlPattern-triode = pF "triode"-triodeTake :: String -> [Double] -> ControlPattern-triodeTake name xs = pStateListF "triode" name xs-triodeCount :: String -> ControlPattern-triodeCount name = pStateF "triode" name (maybe 0 (+1))-triodeCountTo :: String -> Pattern Double -> Pattern ValueMap-triodeCountTo name ipat = innerJoin $ (\i -> pStateF "triode" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--triodebus :: Pattern Int -> Pattern Double -> ControlPattern-triodebus busid pat = (pF "triode" pat) # (pI "^triode" busid)-trioderecv :: Pattern Int -> ControlPattern-trioderecv busid = pI "^triode" busid---- | -tsdelay :: Pattern Double -> ControlPattern-tsdelay = pF "tsdelay"-tsdelayTake :: String -> [Double] -> ControlPattern-tsdelayTake name xs = pStateListF "tsdelay" name xs-tsdelayCount :: String -> ControlPattern-tsdelayCount name = pStateF "tsdelay" name (maybe 0 (+1))-tsdelayCountTo :: String -> Pattern Double -> Pattern ValueMap-tsdelayCountTo name ipat = innerJoin $ (\i -> pStateF "tsdelay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--tsdelaybus :: Pattern Int -> Pattern Double -> ControlPattern-tsdelaybus busid pat = (pF "tsdelay" pat) # (pI "^tsdelay" busid)-tsdelayrecv :: Pattern Int -> ControlPattern-tsdelayrecv busid = pI "^tsdelay" busid---- | -uid :: Pattern Double -> ControlPattern-uid = pF "uid"-uidTake :: String -> [Double] -> ControlPattern-uidTake name xs = pStateListF "uid" name xs-uidCount :: String -> ControlPattern-uidCount name = pStateF "uid" name (maybe 0 (+1))-uidCountTo :: String -> Pattern Double -> Pattern ValueMap-uidCountTo name ipat = innerJoin $ (\i -> pStateF "uid" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--uidbus :: Pattern Int -> Pattern Double -> ControlPattern-uidbus _ _ = error $ "Control parameter 'uid' can't be sent to a bus."--{- |- Used in conjunction with `speed`. It accepts values of @r@ (rate, default- behavior), @c@ (cycles), or @s@ (seconds). Using @unit "c"@ means `speed`- will be interpreted in units of cycles, e.g. @speed "1"@ means samples will be- stretched to fill a cycle. Using @unit "s"@ means the playback speed will be- adjusted so that the duration is the number of seconds specified by `speed`.-- In the following example, @speed 2@ means that samples will be stretched to fill- half a cycle:-- > d1 $ stack [- > s "sax:5" # legato 1 # speed 2 # unit "c",- > s "bd*2"- > ]--}-unit :: Pattern String -> ControlPattern-unit = pS "unit"-unitTake :: String -> [Double] -> ControlPattern-unitTake name xs = pStateListF "unit" name xs-unitbus :: Pattern Int -> Pattern String -> ControlPattern-unitbus _ _ = error $ "Control parameter 'unit' can't be sent to a bus."---- | -val :: Pattern Double -> ControlPattern-val = pF "val"-valTake :: String -> [Double] -> ControlPattern-valTake name xs = pStateListF "val" name xs-valCount :: String -> ControlPattern-valCount name = pStateF "val" name (maybe 0 (+1))-valCountTo :: String -> Pattern Double -> Pattern ValueMap-valCountTo name ipat = innerJoin $ (\i -> pStateF "val" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--valbus :: Pattern Int -> Pattern Double -> ControlPattern-valbus _ _ = error $ "Control parameter 'val' can't be sent to a bus."---- | -vcfegint :: Pattern Double -> ControlPattern-vcfegint = pF "vcfegint"-vcfegintTake :: String -> [Double] -> ControlPattern-vcfegintTake name xs = pStateListF "vcfegint" name xs-vcfegintCount :: String -> ControlPattern-vcfegintCount name = pStateF "vcfegint" name (maybe 0 (+1))-vcfegintCountTo :: String -> Pattern Double -> Pattern ValueMap-vcfegintCountTo name ipat = innerJoin $ (\i -> pStateF "vcfegint" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--vcfegintbus :: Pattern Int -> Pattern Double -> ControlPattern-vcfegintbus busid pat = (pF "vcfegint" pat) # (pI "^vcfegint" busid)-vcfegintrecv :: Pattern Int -> ControlPattern-vcfegintrecv busid = pI "^vcfegint" busid---- | -vcoegint :: Pattern Double -> ControlPattern-vcoegint = pF "vcoegint"-vcoegintTake :: String -> [Double] -> ControlPattern-vcoegintTake name xs = pStateListF "vcoegint" name xs-vcoegintCount :: String -> ControlPattern-vcoegintCount name = pStateF "vcoegint" name (maybe 0 (+1))-vcoegintCountTo :: String -> Pattern Double -> Pattern ValueMap-vcoegintCountTo name ipat = innerJoin $ (\i -> pStateF "vcoegint" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--vcoegintbus :: Pattern Int -> Pattern Double -> ControlPattern-vcoegintbus busid pat = (pF "vcoegint" pat) # (pI "^vcoegint" busid)-vcoegintrecv :: Pattern Int -> ControlPattern-vcoegintrecv busid = pI "^vcoegint" busid---- | -velocity :: Pattern Double -> ControlPattern-velocity = pF "velocity"-velocityTake :: String -> [Double] -> ControlPattern-velocityTake name xs = pStateListF "velocity" name xs-velocityCount :: String -> ControlPattern-velocityCount name = pStateF "velocity" name (maybe 0 (+1))-velocityCountTo :: String -> Pattern Double -> Pattern ValueMap-velocityCountTo name ipat = innerJoin $ (\i -> pStateF "velocity" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--velocitybus :: Pattern Int -> Pattern Double -> ControlPattern-velocitybus busid pat = (pF "velocity" pat) # (pI "^velocity" busid)-velocityrecv :: Pattern Int -> ControlPattern-velocityrecv busid = pI "^velocity" busid---- | -voice :: Pattern Double -> ControlPattern-voice = pF "voice"-voiceTake :: String -> [Double] -> ControlPattern-voiceTake name xs = pStateListF "voice" name xs-voiceCount :: String -> ControlPattern-voiceCount name = pStateF "voice" name (maybe 0 (+1))-voiceCountTo :: String -> Pattern Double -> Pattern ValueMap-voiceCountTo name ipat = innerJoin $ (\i -> pStateF "voice" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--voicebus :: Pattern Int -> Pattern Double -> ControlPattern-voicebus busid pat = (pF "voice" pat) # (pI "^voice" busid)-voicerecv :: Pattern Int -> ControlPattern-voicerecv busid = pI "^voice" busid---- | formant filter to make things sound like vowels, a pattern of either `a`, `e`, `i`, `o` or `u`. Use a rest (`~`) for no effect.-vowel :: Pattern String -> ControlPattern-vowel = pS "vowel"-vowelTake :: String -> [Double] -> ControlPattern-vowelTake name xs = pStateListF "vowel" name xs-vowelbus :: Pattern Int -> Pattern String -> ControlPattern-vowelbus busid pat = (pS "vowel" pat) # (pI "^vowel" busid)-vowelrecv :: Pattern Int -> ControlPattern-vowelrecv busid = pI "^vowel" busid---- | -waveloss :: Pattern Double -> ControlPattern-waveloss = pF "waveloss"-wavelossTake :: String -> [Double] -> ControlPattern-wavelossTake name xs = pStateListF "waveloss" name xs-wavelossCount :: String -> ControlPattern-wavelossCount name = pStateF "waveloss" name (maybe 0 (+1))-wavelossCountTo :: String -> Pattern Double -> Pattern ValueMap-wavelossCountTo name ipat = innerJoin $ (\i -> pStateF "waveloss" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--wavelossbus :: Pattern Int -> Pattern Double -> ControlPattern-wavelossbus busid pat = (pF "waveloss" pat) # (pI "^waveloss" busid)-wavelossrecv :: Pattern Int -> ControlPattern-wavelossrecv busid = pI "^waveloss" busid---- | -xsdelay :: Pattern Double -> ControlPattern-xsdelay = pF "xsdelay"-xsdelayTake :: String -> [Double] -> ControlPattern-xsdelayTake name xs = pStateListF "xsdelay" name xs-xsdelayCount :: String -> ControlPattern-xsdelayCount name = pStateF "xsdelay" name (maybe 0 (+1))-xsdelayCountTo :: String -> Pattern Double -> Pattern ValueMap-xsdelayCountTo name ipat = innerJoin $ (\i -> pStateF "xsdelay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat--xsdelaybus :: Pattern Int -> Pattern Double -> ControlPattern-xsdelaybus busid pat = (pF "xsdelay" pat) # (pI "^xsdelay" busid)-xsdelayrecv :: Pattern Int -> ControlPattern-xsdelayrecv busid = pI "^xsdelay" busid------ * Aliases--voi :: Pattern Double -> ControlPattern-voi = voice-voibus :: Pattern Int -> Pattern Double -> ControlPattern-voibus = voicebus-voirecv :: Pattern Int -> ControlPattern-voirecv = voicerecv--vco :: Pattern Double -> ControlPattern-vco = vcoegint-vcobus :: Pattern Int -> Pattern Double -> ControlPattern-vcobus = vcoegintbus-vcorecv :: Pattern Int -> ControlPattern-vcorecv = vcoegintrecv--vcf :: Pattern Double -> ControlPattern-vcf = vcfegint-vcfbus :: Pattern Int -> Pattern Double -> ControlPattern-vcfbus = vcfegintbus-vcfrecv :: Pattern Int -> ControlPattern-vcfrecv = vcfegintrecv--up :: Pattern Note -> ControlPattern-up = note--tremr :: Pattern Double -> ControlPattern-tremr = tremolorate-tremrbus :: Pattern Int -> Pattern Double -> ControlPattern-tremrbus = tremoloratebus-tremrrecv :: Pattern Int -> ControlPattern-tremrrecv = tremoloraterecv--tremdp :: Pattern Double -> ControlPattern-tremdp = tremolodepth-tremdpbus :: Pattern Int -> Pattern Double -> ControlPattern-tremdpbus = tremolodepthbus-tremdprecv :: Pattern Int -> ControlPattern-tremdprecv = tremolodepthrecv--tdecay :: Pattern Double -> ControlPattern-tdecay = tomdecay-tdecaybus :: Pattern Int -> Pattern Double -> ControlPattern-tdecaybus = tomdecaybus-tdecayrecv :: Pattern Int -> ControlPattern-tdecayrecv = tomdecayrecv--sz :: Pattern Double -> ControlPattern-sz = size-szbus :: Pattern Int -> Pattern Double -> ControlPattern-szbus = sizebus-szrecv :: Pattern Int -> ControlPattern-szrecv = sizerecv--sus :: Pattern Double -> ControlPattern-sus = sustain--stt :: Pattern Double -> ControlPattern-stt = stuttertime-sttbus :: Pattern Int -> Pattern Double -> ControlPattern-sttbus = stuttertimebus-sttrecv :: Pattern Int -> ControlPattern-sttrecv = stuttertimerecv--std :: Pattern Double -> ControlPattern-std = stutterdepth-stdbus :: Pattern Int -> Pattern Double -> ControlPattern-stdbus = stutterdepthbus-stdrecv :: Pattern Int -> ControlPattern-stdrecv = stutterdepthrecv--sld :: Pattern Double -> ControlPattern-sld = slide-sldbus :: Pattern Int -> Pattern Double -> ControlPattern-sldbus = slidebus-sldrecv :: Pattern Int -> ControlPattern-sldrecv = sliderecv--scr :: Pattern Double -> ControlPattern-scr = scrash-scrbus :: Pattern Int -> Pattern Double -> ControlPattern-scrbus = scrashbus-scrrecv :: Pattern Int -> ControlPattern-scrrecv = scrashrecv--scp :: Pattern Double -> ControlPattern-scp = sclap-scpbus :: Pattern Int -> Pattern Double -> ControlPattern-scpbus = sclapbus-scprecv :: Pattern Int -> ControlPattern-scprecv = sclaprecv--scl :: Pattern Double -> ControlPattern-scl = sclaves-sclbus :: Pattern Int -> Pattern Double -> ControlPattern-sclbus = sclavesbus-sclrecv :: Pattern Int -> ControlPattern-sclrecv = sclavesrecv--sag :: Pattern Double -> ControlPattern-sag = sagogo-sagbus :: Pattern Int -> Pattern Double -> ControlPattern-sagbus = sagogobus-sagrecv :: Pattern Int -> ControlPattern-sagrecv = sagogorecv--s :: Pattern String -> ControlPattern-s = sound--rel :: Pattern Double -> ControlPattern-rel = release-relbus :: Pattern Int -> Pattern Double -> ControlPattern-relbus = releasebus-relrecv :: Pattern Int -> ControlPattern-relrecv = releaserecv--por :: Pattern Double -> ControlPattern-por = portamento-porbus :: Pattern Int -> Pattern Double -> ControlPattern-porbus = portamentobus-porrecv :: Pattern Int -> ControlPattern-porrecv = portamentorecv--pit3 :: Pattern Double -> ControlPattern-pit3 = pitch3-pit3bus :: Pattern Int -> Pattern Double -> ControlPattern-pit3bus = pitch3bus-pit3recv :: Pattern Int -> ControlPattern-pit3recv = pitch3recv--pit2 :: Pattern Double -> ControlPattern-pit2 = pitch2-pit2bus :: Pattern Int -> Pattern Double -> ControlPattern-pit2bus = pitch2bus-pit2recv :: Pattern Int -> ControlPattern-pit2recv = pitch2recv--pit1 :: Pattern Double -> ControlPattern-pit1 = pitch1-pit1bus :: Pattern Int -> Pattern Double -> ControlPattern-pit1bus = pitch1bus-pit1recv :: Pattern Int -> ControlPattern-pit1recv = pitch1recv--phasr :: Pattern Double -> ControlPattern-phasr = phaserrate-phasrbus :: Pattern Int -> Pattern Double -> ControlPattern-phasrbus = phaserratebus-phasrrecv :: Pattern Int -> ControlPattern-phasrrecv = phaserraterecv--phasdp :: Pattern Double -> ControlPattern-phasdp = phaserdepth-phasdpbus :: Pattern Int -> Pattern Double -> ControlPattern-phasdpbus = phaserdepthbus-phasdprecv :: Pattern Int -> ControlPattern-phasdprecv = phaserdepthrecv--ohdecay :: Pattern Double -> ControlPattern-ohdecay = ophatdecay-ohdecaybus :: Pattern Int -> Pattern Double -> ControlPattern-ohdecaybus = ophatdecaybus-ohdecayrecv :: Pattern Int -> ControlPattern-ohdecayrecv = ophatdecayrecv--number :: Pattern Note -> ControlPattern-number = n--lsn :: Pattern Double -> ControlPattern-lsn = lsnare-lsnbus :: Pattern Int -> Pattern Double -> ControlPattern-lsnbus = lsnarebus-lsnrecv :: Pattern Int -> ControlPattern-lsnrecv = lsnarerecv--lpq :: Pattern Double -> ControlPattern-lpq = resonance-lpqbus :: Pattern Int -> Pattern Double -> ControlPattern-lpqbus = resonancebus-lpqrecv :: Pattern Int -> ControlPattern-lpqrecv = resonancerecv--lpf :: Pattern Double -> ControlPattern-lpf = cutoff-lpfbus :: Pattern Int -> Pattern Double -> ControlPattern-lpfbus = cutoffbus-lpfrecv :: Pattern Int -> ControlPattern-lpfrecv = cutoffrecv--loh :: Pattern Double -> ControlPattern-loh = lophat-lohbus :: Pattern Int -> Pattern Double -> ControlPattern-lohbus = lophatbus-lohrecv :: Pattern Int -> ControlPattern-lohrecv = lophatrecv--llt :: Pattern Double -> ControlPattern-llt = llotom-lltbus :: Pattern Int -> Pattern Double -> ControlPattern-lltbus = llotombus-lltrecv :: Pattern Int -> ControlPattern-lltrecv = llotomrecv--lht :: Pattern Double -> ControlPattern-lht = lhitom-lhtbus :: Pattern Int -> Pattern Double -> ControlPattern-lhtbus = lhitombus-lhtrecv :: Pattern Int -> ControlPattern-lhtrecv = lhitomrecv--lfop :: Pattern Double -> ControlPattern-lfop = lfopitchint-lfopbus :: Pattern Int -> Pattern Double -> ControlPattern-lfopbus = lfopitchintbus-lfoprecv :: Pattern Int -> ControlPattern-lfoprecv = lfopitchintrecv--lfoi :: Pattern Double -> ControlPattern-lfoi = lfoint-lfoibus :: Pattern Int -> Pattern Double -> ControlPattern-lfoibus = lfointbus-lfoirecv :: Pattern Int -> ControlPattern-lfoirecv = lfointrecv--lfoc :: Pattern Double -> ControlPattern-lfoc = lfocutoffint-lfocbus :: Pattern Int -> Pattern Double -> ControlPattern-lfocbus = lfocutoffintbus-lfocrecv :: Pattern Int -> ControlPattern-lfocrecv = lfocutoffintrecv--lcr :: Pattern Double -> ControlPattern-lcr = lcrash-lcrbus :: Pattern Int -> Pattern Double -> ControlPattern-lcrbus = lcrashbus-lcrrecv :: Pattern Int -> ControlPattern-lcrrecv = lcrashrecv--lcp :: Pattern Double -> ControlPattern-lcp = lclap-lcpbus :: Pattern Int -> Pattern Double -> ControlPattern-lcpbus = lclapbus-lcprecv :: Pattern Int -> ControlPattern-lcprecv = lclaprecv--lcl :: Pattern Double -> ControlPattern-lcl = lclaves-lclbus :: Pattern Int -> Pattern Double -> ControlPattern-lclbus = lclavesbus-lclrecv :: Pattern Int -> ControlPattern-lclrecv = lclavesrecv--lch :: Pattern Double -> ControlPattern-lch = lclhat-lchbus :: Pattern Int -> Pattern Double -> ControlPattern-lchbus = lclhatbus-lchrecv :: Pattern Int -> ControlPattern-lchrecv = lclhatrecv--lbd :: Pattern Double -> ControlPattern-lbd = lkick-lbdbus :: Pattern Int -> Pattern Double -> ControlPattern-lbdbus = lkickbus-lbdrecv :: Pattern Int -> ControlPattern-lbdrecv = lkickrecv--lag :: Pattern Double -> ControlPattern-lag = lagogo-lagbus :: Pattern Int -> Pattern Double -> ControlPattern-lagbus = lagogobus-lagrecv :: Pattern Int -> ControlPattern-lagrecv = lagogorecv--hpq :: Pattern Double -> ControlPattern-hpq = hresonance-hpqbus :: Pattern Int -> Pattern Double -> ControlPattern-hpqbus = hresonancebus-hpqrecv :: Pattern Int -> ControlPattern-hpqrecv = hresonancerecv--hpf :: Pattern Double -> ControlPattern-hpf = hcutoff-hpfbus :: Pattern Int -> Pattern Double -> ControlPattern-hpfbus = hcutoffbus-hpfrecv :: Pattern Int -> ControlPattern-hpfrecv = hcutoffrecv--hg :: Pattern Double -> ControlPattern-hg = hatgrain-hgbus :: Pattern Int -> Pattern Double -> ControlPattern-hgbus = hatgrainbus-hgrecv :: Pattern Int -> ControlPattern-hgrecv = hatgrainrecv--gat :: Pattern Double -> ControlPattern-gat = gate-gatbus :: Pattern Int -> Pattern Double -> ControlPattern-gatbus = gatebus-gatrecv :: Pattern Int -> ControlPattern-gatrecv = gaterecv--fadeOutTime :: Pattern Double -> ControlPattern-fadeOutTime = fadeTime--dt :: Pattern Double -> ControlPattern-dt = delaytime-dtbus :: Pattern Int -> Pattern Double -> ControlPattern-dtbus = delaytimebus-dtrecv :: Pattern Int -> ControlPattern-dtrecv = delaytimerecv--dfb :: Pattern Double -> ControlPattern-dfb = delayfeedback-dfbbus :: Pattern Int -> Pattern Double -> ControlPattern-dfbbus = delayfeedbackbus-dfbrecv :: Pattern Int -> ControlPattern-dfbrecv = delayfeedbackrecv--det :: Pattern Double -> ControlPattern-det = detune-detbus :: Pattern Int -> Pattern Double -> ControlPattern-detbus = detunebus-detrecv :: Pattern Int -> ControlPattern-detrecv = detunerecv--delayt :: Pattern Double -> ControlPattern-delayt = delaytime-delaytbus :: Pattern Int -> Pattern Double -> ControlPattern-delaytbus = delaytimebus-delaytrecv :: Pattern Int -> ControlPattern-delaytrecv = delaytimerecv--delayfb :: Pattern Double -> ControlPattern-delayfb = delayfeedback-delayfbbus :: Pattern Int -> Pattern Double -> ControlPattern-delayfbbus = delayfeedbackbus-delayfbrecv :: Pattern Int -> ControlPattern-delayfbrecv = delayfeedbackrecv--ctfg :: Pattern Double -> ControlPattern-ctfg = cutoffegint-ctfgbus :: Pattern Int -> Pattern Double -> ControlPattern-ctfgbus = cutoffegintbus-ctfgrecv :: Pattern Int -> ControlPattern-ctfgrecv = cutoffegintrecv--ctf :: Pattern Double -> ControlPattern-ctf = cutoff-ctfbus :: Pattern Int -> Pattern Double -> ControlPattern-ctfbus = cutoffbus-ctfrecv :: Pattern Int -> ControlPattern-ctfrecv = cutoffrecv--chdecay :: Pattern Double -> ControlPattern-chdecay = clhatdecay-chdecaybus :: Pattern Int -> Pattern Double -> ControlPattern-chdecaybus = clhatdecaybus-chdecayrecv :: Pattern Int -> ControlPattern-chdecayrecv = clhatdecayrecv--bpq :: Pattern Double -> ControlPattern-bpq = bandq-bpqbus :: Pattern Int -> Pattern Double -> ControlPattern-bpqbus = bandqbus-bpqrecv :: Pattern Int -> ControlPattern-bpqrecv = bandqrecv--bpf :: Pattern Double -> ControlPattern-bpf = bandf-bpfbus :: Pattern Int -> Pattern Double -> ControlPattern-bpfbus = bandfbus-bpfrecv :: Pattern Int -> ControlPattern-bpfrecv = bandfrecv--att :: Pattern Double -> ControlPattern-att = attack-attbus :: Pattern Int -> Pattern Double -> ControlPattern-attbus = attackbus-attrecv :: Pattern Int -> ControlPattern-attrecv = attackrecv
− src/Sound/Tidal/ParseBP.hs
@@ -1,700 +0,0 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, CPP, DeriveFunctor, GADTs, StandaloneDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-unused-do-bind #-}--module Sound.Tidal.ParseBP where--{-- ParseBP.hs - Parser for Tidal's "mini-notation", inspired by- Bernard Bel's BP2 (Bol Processor 2) system.- Copyright (C) 2020, Alex McLean and contributors-- This library is free software: you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this library. If not, see <http://www.gnu.org/licenses/>.--}--import Control.Applicative ()-import qualified Control.Exception as E-import Data.Bifunctor (first)-import Data.Colour-import Data.Colour.Names-import Data.Functor.Identity (Identity)-import Data.List (intercalate)-import Data.Maybe-import Data.Ratio-import Data.Typeable (Typeable)-import GHC.Exts ( IsString(..) )-import Text.Parsec.Error-import Text.ParserCombinators.Parsec-import Text.ParserCombinators.Parsec.Language ( haskellDef )-import qualified Text.ParserCombinators.Parsec.Token as P-import qualified Text.Parsec.Prim-import Sound.Tidal.Pattern-import Sound.Tidal.UI-import Sound.Tidal.Core-import Sound.Tidal.Chords-import Sound.Tidal.Utils (fromRight)--data TidalParseError = TidalParseError {parsecError :: ParseError,- code :: String- }- deriving (Eq, Typeable)--instance E.Exception TidalParseError--instance Show TidalParseError where- show err = "Syntax error in sequence:\n \"" ++ code err ++ "\"\n " ++ pointer ++ " " ++ message- where pointer = replicate (sourceColumn $ errorPos perr) ' ' ++ "^"- message = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" $ errorMessages perr- perr = parsecError err--type MyParser = Text.Parsec.Prim.Parsec String Int---- | AST representation of patterns--data TPat a where- TPat_Atom :: (Maybe ((Int, Int), (Int, Int))) -> a -> (TPat a)- TPat_Fast :: (TPat Time) -> (TPat a) -> (TPat a)- TPat_Slow :: (TPat Time) -> (TPat a) -> (TPat a)- TPat_DegradeBy :: Int -> Double -> (TPat a) -> (TPat a)- TPat_CycleChoose :: Int -> [TPat a] -> (TPat a)- TPat_Euclid :: (TPat Int) -> (TPat Int) -> (TPat Int) -> (TPat a) -> (TPat a)- TPat_Stack :: [TPat a] -> (TPat a)- TPat_Polyrhythm :: (Maybe (TPat Rational)) -> [TPat a] -> (TPat a)- TPat_Seq :: [TPat a] -> (TPat a)- TPat_Silence :: (TPat a)- TPat_Foot :: (TPat a)- TPat_Elongate :: Rational -> (TPat a) -> (TPat a)- TPat_Repeat :: Int -> (TPat a) -> (TPat a)- TPat_EnumFromTo :: (TPat a) -> (TPat a) -> (TPat a)- TPat_Var :: String -> (TPat a)- TPat_Chord :: (Num b, Enum b, Parseable b, Enumerable b) => (b -> a) -> (TPat b) -> (TPat String) -> [TPat [Modifier]] -> (TPat a)--instance Show a => Show (TPat a) where- show (TPat_Atom c v) = "TPat_Atom (" ++ show c ++ ") (" ++ show v ++ ")"- show (TPat_Fast t v) = "TPat_Fast (" ++ show t ++ ") (" ++ show v ++ ")"- show (TPat_Slow t v) = "TPat_Slow (" ++ show t ++ ") (" ++ show v ++ ")"- show (TPat_DegradeBy x r v) = "TPat_DegradeBy (" ++ show x ++ ") (" ++ show r ++ ") (" ++ show v ++ ")"- show (TPat_CycleChoose x vs) = "TPat_CycleChoose (" ++ show x ++ ") (" ++ show vs ++ ")"- show (TPat_Euclid a b c v) = "TPat_Euclid (" ++ show a ++ ") (" ++ show b ++ ") (" ++ show c ++ ") " ++ show v ++ ")"- show (TPat_Stack vs) = "TPat_Stack " ++ show vs- show (TPat_Polyrhythm mSteprate vs) = "TPat_Polyrhythm (" ++ show mSteprate ++ ") " ++ show vs- show (TPat_Seq vs) = "TPat_Seq " ++ show vs- show TPat_Silence = "TPat_Silence"- show TPat_Foot = "TPat_Foot"- show (TPat_Elongate r v) = "TPat_Elongate (" ++ show r ++ ") (" ++ show v ++ ")"- show (TPat_Repeat r v) = "TPat_Repeat (" ++ show r ++ ") (" ++ show v ++ ")"- show (TPat_EnumFromTo a b) = "TPat_EnumFromTo (" ++ show a ++ ") (" ++ show b ++ ")"- show (TPat_Var s) = "TPat_Var " ++ show s- show (TPat_Chord g iP nP msP) = "TPat_Chord (" ++ (show $ fmap g iP) ++ ") (" ++ show nP ++ ") (" ++ show msP ++ ")"--instance Functor TPat where- fmap f (TPat_Atom c v) = TPat_Atom c (f v)- fmap f (TPat_Fast t v) = TPat_Fast t (fmap f v)- fmap f (TPat_Slow t v) = TPat_Slow t (fmap f v)- fmap f (TPat_DegradeBy x r v) = TPat_DegradeBy x r (fmap f v)- fmap f (TPat_CycleChoose x vs) = TPat_CycleChoose x (map (fmap f) vs)- fmap f (TPat_Euclid a b c v) = TPat_Euclid a b c (fmap f v)- fmap f (TPat_Stack vs) = TPat_Stack (map (fmap f) vs)- fmap f (TPat_Polyrhythm mSteprate vs) = TPat_Polyrhythm mSteprate (map (fmap f) vs)- fmap f (TPat_Seq vs) = TPat_Seq (map (fmap f) vs)- fmap _ TPat_Silence = TPat_Silence- fmap _ TPat_Foot = TPat_Foot- fmap f (TPat_Elongate r v) = TPat_Elongate r (fmap f v)- fmap f (TPat_Repeat r v) = TPat_Repeat r (fmap f v)- fmap f (TPat_EnumFromTo a b) = TPat_EnumFromTo (fmap f a) (fmap f b)- fmap _ (TPat_Var s) = TPat_Var s- fmap f (TPat_Chord g iP nP msP) = TPat_Chord (f . g) iP nP msP--tShowList :: (Show a) => [TPat a] -> String-tShowList vs = "[" ++ intercalate "," (map tShow vs) ++ "]"--tShow :: (Show a) => TPat a -> String-tShow (TPat_Atom _ v) = "pure " ++ show v-tShow (TPat_Fast t v) = "fast " ++ show t ++ " $ " ++ tShow v-tShow (TPat_Slow t v) = "slow " ++ show t ++ " $ " ++ tShow v--- TODO - should be _degradeByUsing, but needs a simplified version..-tShow (TPat_DegradeBy _ r v) = "degradeBy " ++ show r ++ " $ " ++ tShow v--- TODO - ditto-tShow (TPat_CycleChoose _ vs) = "cycleChoose " ++ tShowList vs--tShow (TPat_Euclid a b c v) = "doEuclid (" ++ intercalate ") (" (map tShow [a,b,c]) ++ ") $ " ++ tShow v-tShow (TPat_Stack vs) = "stack " ++ tShowList vs--tShow (TPat_Polyrhythm mSteprate vs) = "stack [" ++ intercalate ", " (map adjust_speed pats) ++ "]"- where adjust_speed (sz, pat) = "(fast (" ++ (steprate ++ "/" ++ show sz) ++ ") $ " ++ pat ++ ")"- steprate :: String- steprate = maybe base_first tShow mSteprate- base_first | null pats = "0"- | otherwise = show $ fst $ head pats- pats = map steps_tpat vs--tShow (TPat_Seq vs) = snd $ steps_seq vs--tShow TPat_Silence = "silence"-tShow (TPat_EnumFromTo a b) = "unwrap $ fromTo <$> (" ++ tShow a ++ ") <*> (" ++ tShow b ++ ")"-tShow (TPat_Var s) = "getControl " ++ s-tShow (TPat_Chord f n name mods) = "chord (" ++ (tShow $ fmap f n) ++ ") (" ++ tShow name ++ ")" ++ tShowList mods-tShow a = "can't happen? " ++ show a---toPat :: (Parseable a, Enumerable a) => TPat a -> Pattern a-toPat = \case- 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- TPat_CycleChoose seed xs -> unwrap $ segment 1 $ chooseBy (rotL (0.0001 * fromIntegral seed) rand) $ map toPat xs- TPat_Euclid n k s thing -> doEuclid (toPat n) (toPat k) (toPat s) (toPat thing)- TPat_Stack xs -> stack $ map toPat xs- TPat_Silence -> silence- TPat_EnumFromTo a b -> unwrap $ fromTo <$> toPat a <*> toPat b- TPat_Foot -> error "Can't happen, feet are pre-processed."- TPat_Polyrhythm mSteprate ps -> stack $ map adjust_speed pats- where adjust_speed (sz, pat) = fast ((/sz) <$> steprate) pat- pats = map resolve_tpat ps- steprate :: Pattern Rational- steprate = (maybe base_first toPat mSteprate)- base_first | null pats = pure 0- | otherwise = pure $ fst $ head pats- TPat_Seq xs -> snd $ resolve_seq xs- TPat_Var s -> getControl s- TPat_Chord f iP nP mP -> chordToPatSeq f (toPat iP) (toPat nP) (map toPat mP)- _ -> silence--resolve_tpat :: (Enumerable a, Parseable a) => TPat a -> (Rational, Pattern a)-resolve_tpat (TPat_Seq xs) = resolve_seq xs-resolve_tpat a = (1, toPat a)--resolve_seq :: (Enumerable a, Parseable a) => [TPat a] -> (Rational, Pattern a)-resolve_seq xs = (total_size, timeCat sized_pats)- where sized_pats = map (toPat <$>) $ resolve_size xs- total_size = sum $ map fst sized_pats--resolve_size :: [TPat a] -> [(Rational, TPat a)]-resolve_size [] = []-resolve_size ((TPat_Elongate r p):ps) = (r, p):resolve_size ps-resolve_size ((TPat_Repeat n p):ps) = replicate n (1,p) ++ resolve_size ps-resolve_size (p:ps) = (1,p):resolve_size ps---steps_tpat :: (Show a) => TPat a -> (Rational, String)-steps_tpat (TPat_Seq xs) = steps_seq xs-steps_tpat a = (1, tShow a)--steps_seq :: (Show a) => [TPat a] -> (Rational, String)-steps_seq xs = (total_size, "timeCat [" ++ intercalate "," (map (\(r,s) -> "(" ++ show r ++ ", " ++ s ++ ")") sized_pats) ++ "]")- where sized_pats = steps_size xs- total_size = sum $ map fst sized_pats--steps_size :: Show a => [TPat a] -> [(Rational, String)]-steps_size [] = []-steps_size ((TPat_Elongate r p):ps) = (r, tShow p):steps_size ps-steps_size ((TPat_Repeat n p):ps) = replicate n (1, tShow p) ++ steps_size ps-steps_size (p:ps) = (1,tShow p):steps_size ps--parseBP :: (Enumerable a, Parseable a) => String -> Either ParseError (Pattern a)-parseBP s = toPat <$> parseTPat s--parseBP_E :: (Enumerable a, Parseable a) => String -> Pattern a-parseBP_E s = toE parsed- where- parsed = parseTPat s- -- TODO - custom error- toE (Left e) = E.throw $ TidalParseError {parsecError = e, code = s}- toE (Right tp) = toPat tp--parseTPat :: Parseable a => String -> Either ParseError (TPat a)-parseTPat = runParser (pSequence f' Prelude.<* eof) (0 :: Int) ""- where f' = do tPatParser- <|> do symbol "~" <?> "rest"- return TPat_Silence--cP :: (Enumerable a, Parseable a) => String -> Pattern a-cP s = innerJoin $ parseBP_E <$> _cX_ getS s--class Parseable a where- tPatParser :: MyParser (TPat a)- doEuclid :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a- getControl :: String -> Pattern a- getControl _ = silence--class Enumerable a where- fromTo :: a -> a -> Pattern a- fromThenTo :: a -> a -> a -> Pattern a--instance Parseable Char where- tPatParser = pChar- doEuclid = euclidOff--instance Enumerable Char where- fromTo = enumFromTo'- fromThenTo a b c = fastFromList [a,b,c]--instance Parseable Double where- tPatParser = pDouble- doEuclid = euclidOff- getControl = cF_--instance Enumerable Double where- fromTo = enumFromTo'- fromThenTo = enumFromThenTo'--instance Parseable Note where- tPatParser = pNote- doEuclid = euclidOff- getControl = cN_--instance Enumerable Note where- fromTo = enumFromTo'- fromThenTo = enumFromThenTo'--instance Parseable String where- tPatParser = pVocable- doEuclid = euclidOff- getControl = cS_--instance Enumerable String where- fromTo a b = fastFromList [a,b]- fromThenTo a b c = fastFromList [a,b,c]--instance Parseable Bool where- tPatParser = pBool- doEuclid = euclidOffBool- getControl = cB_--instance Enumerable Bool where- fromTo a b = fastFromList [a,b]- fromThenTo a b c = fastFromList [a,b,c]--instance Parseable Int where- tPatParser = pIntegral- doEuclid = euclidOff- getControl = cI_--instance Enumerable Int where- fromTo = enumFromTo'- fromThenTo = enumFromThenTo'--instance Parseable Integer where- tPatParser = pIntegral- doEuclid = euclidOff- getControl = fmap fromIntegral . cI_--instance Enumerable Integer where- fromTo = enumFromTo'- fromThenTo = enumFromThenTo'--instance Parseable Rational where- tPatParser = pRational- doEuclid = euclidOff- getControl = cR_--instance Enumerable Rational where- fromTo = enumFromTo'- fromThenTo = enumFromThenTo'--enumFromTo' :: (Ord a, Enum a) => a -> a -> Pattern a-enumFromTo' a b | a > b = fastFromList $ reverse $ enumFromTo b a- | otherwise = fastFromList $ enumFromTo a b--enumFromThenTo' :: (Ord a, Enum a, Num a) => a -> a -> a -> Pattern a-enumFromThenTo' a b c | a > c = fastFromList $ reverse $ enumFromThenTo c (c + (a-b)) a- | otherwise = fastFromList $ enumFromThenTo a b c--type ColourD = Colour Double--instance Parseable ColourD where- tPatParser = pColour- doEuclid = euclidOff--instance Enumerable ColourD where- fromTo a b = fastFromList [a,b]- fromThenTo a b c = fastFromList [a,b,c]--instance (Enumerable a, Parseable a) => IsString (Pattern a) where- fromString = parseBP_E--lexer :: P.GenTokenParser String u Data.Functor.Identity.Identity-lexer = P.makeTokenParser haskellDef--braces, brackets, parens, angles:: MyParser a -> MyParser a-braces = P.braces lexer-brackets = P.brackets lexer-parens = P.parens lexer-angles = P.angles lexer--symbol :: String -> MyParser String-symbol = P.symbol lexer--natural, integer, decimal :: MyParser Integer-natural = P.natural lexer-integer = P.integer lexer-decimal = P.integer lexer--float :: MyParser Double-float = P.float lexer--naturalOrFloat :: MyParser (Either Integer Double)-naturalOrFloat = P.naturalOrFloat lexer--data Sign = Positive | Negative--applySign :: Num a => Sign -> a -> a-applySign Positive = id-applySign Negative = negate--sign :: MyParser Sign-sign = do char '-'- return Negative- <|> do char '+'- return Positive- <|> return Positive--intOrFloat :: MyParser Double-intOrFloat = try pFloat <|> pInteger--pSequence :: Parseable a => MyParser (TPat a) -> MyParser (TPat a)-pSequence f = do- spaces- s <- many $ do- a <- pPart f- spaces- do- try $ symbol ".."- b <- pPart f- return $ TPat_EnumFromTo a b- <|> pElongate a- <|> pRepeat a- <|> return a- <|> do- symbol "."- return TPat_Foot- pRand $ resolve_feet s- where resolve_feet ps | length ss > 1 = TPat_Seq $ map TPat_Seq ss- | otherwise = TPat_Seq ps- where ss = splitFeet ps- splitFeet :: [TPat t] -> [[TPat t]]- splitFeet [] = []- splitFeet pats = foot : splitFeet pats'- where (foot, pats') = takeFoot pats- takeFoot [] = ([], [])- takeFoot (TPat_Foot:pats'') = ([], pats'')- takeFoot (pat:pats'') = first (pat:) $ takeFoot pats''--pRepeat :: TPat a -> MyParser (TPat a)-pRepeat a = do es <- many1 $ do char '!'- n <- (subtract 1 . read <$> many1 digit) <|> return 1- spaces- return n- return $ TPat_Repeat (1 + sum es) a--pElongate :: TPat a -> MyParser (TPat a)-pElongate a = do rs <- many1 $ do oneOf "@_"- r <- (subtract 1 <$> pRatio) <|> return 1- spaces- return r- return $ TPat_Elongate (1 + sum rs) a--pSingle :: MyParser (TPat a) -> MyParser (TPat a)-pSingle f = f >>= pRand >>= pMult--pVar :: MyParser (TPat a)-pVar = wrapPos $ do char '^'- name <- many (letter <|> oneOf "0123456789:.-_") <?> "string"- return $ TPat_Var name--pPart :: Parseable a => MyParser (TPat a) -> MyParser (TPat a)-pPart f = (pSingle f <|> pPolyIn f <|> pPolyOut f <|> pVar) >>= pE >>= pRand--newSeed :: MyParser Int-newSeed = do seed <- Text.Parsec.Prim.getState- Text.Parsec.Prim.modifyState (+1)- return seed--pPolyIn :: Parseable a => MyParser (TPat a) -> MyParser (TPat a)-pPolyIn f = do x <- brackets $ do s <- pSequence f <?> "sequence"- stackTail s <|> chooseTail s <|> return s- pMult x- where stackTail s = do symbol ","- ss <- pSequence f `sepBy` symbol ","- return $ TPat_Stack (s:ss)- chooseTail s = do symbol "|"- ss <- pSequence f `sepBy` symbol "|"- seed <- newSeed- return $ TPat_CycleChoose seed (s:ss)--pPolyOut :: Parseable a => MyParser (TPat a) -> MyParser (TPat a)-pPolyOut f = do ss <- braces (pSequence f `sepBy` symbol ",")- base <- do char '%'- r <- pSequence pRational <?> "rational number"- return $ Just r- <|> return Nothing- pMult $ TPat_Polyrhythm base ss- <|>- do ss <- angles (pSequence f `sepBy` symbol ",")- pMult $ TPat_Polyrhythm (Just $ TPat_Atom Nothing 1) ss--pCharNum :: MyParser Char-pCharNum = (letter <|> oneOf "0123456789") <?> "letter or number"--pString :: MyParser String-pString = do c <- pCharNum <?> "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 = wrapPos $ TPat_Atom Nothing <$> pString--pChar :: MyParser (TPat Char)-pChar = wrapPos $ TPat_Atom Nothing <$> pCharNum--pDouble :: MyParser (TPat Double)-pDouble = try $ do d <- pDoubleWithoutChord- pChord d <|> return d- <|> pChord (TPat_Atom Nothing 0)- <|> pDoubleWithoutChord--pDoubleWithoutChord :: MyParser (TPat Double)-pDoubleWithoutChord = pPart $ wrapPos $ do s <- sign- f <- choice [fromRational <$> pRatio, parseNote] <?> "float"- return $ TPat_Atom Nothing (applySign s f)--pNote :: MyParser (TPat Note)-pNote = try $ do n <- pNoteWithoutChord- pChord n <|> return n- <|> pChord (TPat_Atom Nothing 0)- <|> pNoteWithoutChord- <|> do TPat_Atom Nothing . fromRational <$> pRatio--pNoteWithoutChord :: MyParser (TPat Note)-pNoteWithoutChord = pPart $ wrapPos $ do s <- sign- f <- choice [intOrFloat, parseNote] <?> "float"- return $ TPat_Atom Nothing (Note $ applySign s f)---pBool :: MyParser (TPat Bool)-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- d <- choice [intOrFloat, parseNote]- if isInt d- then return $ applySign s $ round d- else fail "not an integer"--pIntegral :: (Integral a, Parseable a, Enumerable a) => MyParser (TPat a)-pIntegral = try $ do i <- pIntegralWithoutChord- pChord i <|> return i- <|> pChord (TPat_Atom Nothing 0)- <|> pIntegralWithoutChord--pIntegralWithoutChord :: (Integral a, Parseable a, Enumerable a) => MyParser (TPat a)-pIntegralWithoutChord = pPart $ wrapPos $ fmap (TPat_Atom Nothing) parseIntNote--parseChord :: (Enum a, Num a) => MyParser [a]-parseChord = do char '\''- name <- many1 $ letter <|> digit- let foundChord = fromMaybe [0] $ lookup name chordTable- do char '\''- notFollowedBy space <?> "chord range or 'i' or 'o'"- let n = length foundChord- i <- option n (fromIntegral <$> integer)- j <- length <$> many (char 'i')- o <- length <$> many (char 'o')- let chord' = take i $ drop j $ concatMap (\x -> map (+ x) foundChord) [0,12..]- -- open voiced chords- let chordo' = if o > 0 && n > 2 then- [ (chord' !! 0 - 12), (chord' !! 2 - 12), (chord' !! 1) ] ++ reverse (take (length chord' - 3) (reverse chord'))- else chord'- return chordo'- <|> return foundChord--parseNote :: Num a => MyParser a-parseNote = do n <- notenum- modifiers <- many noteModifier- octave <- option 5 natural- let n' = foldr (+) n modifiers- return $ fromIntegral $ n' + ((octave-5)*12)- where- notenum :: MyParser Integer- notenum = choice [char 'c' >> return 0,- char 'd' >> return 2,- char 'e' >> return 4,- char 'f' >> return 5,- char 'g' >> return 7,- char 'a' >> return 9,- char 'b' >> return 11- ]- noteModifier :: MyParser Integer- noteModifier = choice [char 's' >> return 1,- char 'f' >> return (-1),- char 'n' >> return 0- ]--fromNote :: Num a => Pattern String -> Pattern a-fromNote pat = fromRight 0 . runParser parseNote 0 "" <$> pat--pColour :: MyParser (TPat ColourD)-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 '*'- spaces- r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational- return $ TPat_Fast r thing- <|>- do char '/'- spaces- r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational- return $ TPat_Slow r thing- <|>- return thing--pRand :: TPat a -> MyParser (TPat a)-pRand thing = do char '?'- r <- float <|> return 0.5- spaces- seed <- newSeed- return $ TPat_DegradeBy seed r thing- <|> return thing--pE :: TPat a -> MyParser (TPat a)-pE thing = do (n,k,s) <- parens pair- pure $ TPat_Euclid n k s thing- <|> return thing- where pair :: MyParser (TPat Int, TPat Int, TPat Int)- pair = do a <- pSequence pIntegral- spaces- symbol ","- spaces- b <- pSequence pIntegral- c <- do symbol ","- spaces- pSequence pIntegral- <|> return (TPat_Atom Nothing 0)- return (a, b, c)--pRational :: MyParser (TPat Rational)-pRational = wrapPos $ TPat_Atom Nothing <$> pRatio--pRatio :: MyParser Rational-pRatio = do- s <- sign- r <- do n <- try intOrFloat- v <- pFraction n <|> return (toRational n)- r <- pRatioChar <|> return 1- return (v * r)- <|>- pRatioChar- return $ applySign s r--pInteger :: MyParser Double-pInteger = read <$> many1 digit--pFloat :: MyParser Double-pFloat = do- i <- many1 digit- d <- option "0" (char '.' >> many1 digit)- e <- option "0" (char 'e' >> do- s <- option "" (char '-' >> return "-")- e' <- many1 digit- return $ s++e')- return $ read (i++"."++d++"e"++e)--pFraction :: RealFrac a => a -> MyParser Rational-pFraction n = do- char '%'- d <- pInteger- if (isInt n)- then return ((round n) % (round d))- else fail "fractions need int numerator and denominator"--pRatioChar :: Fractional a => MyParser a-pRatioChar = pRatioSingleChar 'w' 1- <|> pRatioSingleChar 'h' 0.5- <|> pRatioSingleChar 'q' 0.25- <|> pRatioSingleChar 'e' 0.125- <|> pRatioSingleChar 's' 0.0625- <|> pRatioSingleChar 't' (1/3)- <|> pRatioSingleChar 'f' 0.2- <|> pRatioSingleChar 'x' (1/6)--pRatioSingleChar :: Fractional a => Char -> a -> MyParser a-pRatioSingleChar c v = try $ do- char c- notFollowedBy (letter)- return v--isInt :: RealFrac a => a -> Bool-isInt x = x == fromInteger (round x)-------instance Parseable [Modifier] where- tPatParser = pModifiers- doEuclid = euclidOff--instance Enumerable [Modifier] where- fromTo a b = fastFromList [a,b]- fromThenTo a b c = fastFromList [a,b,c]--parseModInv :: MyParser Modifier-parseModInv = char 'i' >> return Invert--parseModInvNum :: MyParser [Modifier]-parseModInvNum = do- char 'i'- n <- pInteger- return $ replicate (round n) Invert--parseModDrop :: MyParser [Modifier]-parseModDrop = do- char 'd'- n <- pInteger- return $ [Drop $ round n]--parseModOpen :: MyParser Modifier-parseModOpen = char 'o' >> return Open--parseModRange :: MyParser Modifier-parseModRange = parseIntNote >>= \i -> return $ Range $ fromIntegral (i :: Integer)--parseModifiers :: MyParser [Modifier]-parseModifiers = (many1 parseModOpen) <|> parseModDrop <|> (fmap pure parseModRange) <|> try parseModInvNum <|> (many1 parseModInv) <?> "modifier"--pModifiers :: MyParser (TPat [Modifier])-pModifiers = wrapPos $ TPat_Atom Nothing <$> parseModifiers--pChord :: (Enum a, Num a, Parseable a, Enumerable a) => TPat a -> MyParser (TPat a)-pChord i = do- char '\''- n <- pPart pVocable <?> "chordname"- ms <- option [] $ many1 $ (char '\'' >> pPart pModifiers)- return $ TPat_Chord id i n ms
− src/Sound/Tidal/Pattern.hs
@@ -1,1101 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--{-- Pattern.hs - core representation of Tidal patterns- Copyright (C) 2020 Alex McLean and contributors-- This library is free software: you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this library. If not, see <http://www.gnu.org/licenses/>.--}--module Sound.Tidal.Pattern (module Sound.Tidal.Pattern,- module Sound.Tidal.Time- )-where--import Prelude hiding ((<*), (*>))--import Control.Applicative (liftA2)-import GHC.Generics-import Control.DeepSeq (NFData)-import Control.Monad ((>=>))-import qualified Data.Map.Strict as Map-import Data.Maybe (isJust, fromJust, catMaybes, mapMaybe)-import Data.List (delete, findIndex, (\\))-import Data.Word (Word8)-import Data.Data (Data) -- toConstr-import Data.Typeable (Typeable)-import Data.Fixed (mod')--import Sound.Tidal.Time----------------------------------------------------------------------------- * Types---- | an Arc and some named control values-data State = State {arc :: Arc,- controls :: ValueMap- }---- | A datatype representing events taking place over time-data Pattern a = Pattern {query :: State -> [Event a]}- deriving (Generic, Functor)--instance NFData a => NFData (Pattern a)---- type StateMap = Map.Map String (Pattern Value)-type ControlPattern = Pattern ValueMap---- * Applicative and friends--instance Applicative Pattern where- -- | Repeat the given value once per cycle, forever- pure v = Pattern $ \(State a _) ->- map (\a' -> Event- (Context [])- (Just a')- (sect a a')- v)- $ cycleArcsInArc a-- -- | In each of @a <*> b@, @a <* b@ and @a *> b@- -- (using the definitions from this module, not the Prelude),- -- the time structure of the result- -- depends on the structures of both @a@ and @b@.- -- They all result in @Event@s with identical @part@s and @value@s.- -- However, their @whole@s are different.- --- -- For instance, @listToPat [(+1), (+2)] <*> "0 10 100"@- -- gives the following 4-@Event@ cycle:- -- > (0>⅓)|1- -- > (⅓>½)|11- -- > (½>⅔)|12- -- > (⅔>1)|102- -- If we use @<*@ instead, we get this:- -- > (0>⅓)-½|1- -- > 0-(⅓>½)|11- -- > (½>⅔)-1|12- -- > ½-(⅔>1)|102- -- And if we use @*>@, we get this:- -- > (0>⅓)|1- -- > (⅓>½)-⅔|11- -- > ⅓-(½>⅔)|12- -- > (⅔>1)|102- (<*>) = applyPatToPatBoth---- | Like @<*>@, but the "wholes" come from the left-(<*) :: Pattern (a -> b) -> Pattern a -> Pattern b-(<*) = applyPatToPatLeft---- | Like @<*>@, but the "wholes" come from the right-(*>) :: Pattern (a -> b) -> Pattern a -> Pattern b-(*>) = applyPatToPatRight---- | Like @<*>@, but the "wholes" come from the left-(<<*) :: Pattern (a -> b) -> Pattern a -> Pattern b-(<<*) = applyPatToPatSqueeze--infixl 4 <*, *>, <<*-applyPatToPat :: (Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)) -> Pattern (a -> b) -> Pattern a -> Pattern b-applyPatToPat combineWholes pf px = Pattern q- where q st = catMaybes $ concatMap match $ query pf st- where- match ef@(Event (Context c) _ fPart f) =- map- (\ex@(Event (Context c') _ xPart x) ->- do whole' <- combineWholes (whole ef) (whole ex)- part' <- subArc fPart xPart- return (Event (Context $ c ++ c') whole' part' (f x))- )- (query px $ st {arc = wholeOrPart ef})--applyPatToPatBoth :: Pattern (a -> b) -> Pattern a -> Pattern b-applyPatToPatBoth pf px = Pattern q- 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 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 analog events from px (constrained above) with digital events from px- matchX ex@(Event _ Nothing fPart _) = map (`withFX` 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 (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex))--applyPatToPatLeft :: Pattern (a -> b) -> Pattern a -> Pattern b-applyPatToPatLeft pf px = Pattern q- where q st = catMaybes $ concatMap match $ query pf st- where- 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 (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex))--applyPatToPatRight :: Pattern (a -> b) -> Pattern a -> Pattern b-applyPatToPatRight pf px = Pattern q- where q st = catMaybes $ concatMap match $ query px st- where- match ex = map (`withFX` ex) (query pf $ st {arc = wholeOrPart ex})- withFX ef ex = do let whole' = whole ex- part' <- subArc (part ef) (part ex)- return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex))--applyPatToPatSqueeze :: Pattern (a -> b) -> Pattern a -> Pattern b-applyPatToPatSqueeze pf px = squeezeJoin $ (\f -> f <$> px) <$> pf---- * Monad and friends------ $monadAndFriends------ Note there are four ways of joining - the default 'unwrap' used by @>>=@, as well--- as @innerJoin@, @innerJoin@ and @squeezeJoin@.--instance Monad Pattern where- return = pure- p >>= f = unwrap (f <$> p)---- | Turns a pattern of patterns into a single pattern.--- (this is actually 'join')------ 1/ For query 'arc', get the events from the outer pattern @pp@--- 2/ Query the inner pattern using the 'part' of the outer--- 3/ For each inner event, set the whole and part to be the intersection--- of the outer whole and part, respectively--- 4/ Concatenate all the events together (discarding wholes/parts that didn't intersect)------ TODO - what if a continuous pattern contains a discrete one, or vice-versa?-unwrap :: Pattern (Pattern a) -> Pattern a-unwrap pp = pp {query = q}- where q st = concatMap- (\(Event c w p v) ->- mapMaybe (munge c w p) $ query v st {arc = p})- (query pp st)- munge oc ow op (Event ic iw ip v') =- do- w' <- subMaybeArc ow iw- p' <- subArc op ip- 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 oc _ op v) -> mapMaybe (munge oc) $ query v st {arc = op}- )- (query pp st)- where munge oc (Event ic iw ip v) =- do- p <- subArc (arc st) ip- p' <- subArc p (arc st)- 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.-outerJoin :: Pattern (Pattern a) -> Pattern a-outerJoin pp = pp {query = q}- where q st = concatMap- (\e ->- mapMaybe (munge (context e) (whole e) (part e)) $ query (value e) st {arc = pure (start $ wholeOrPart e)}- )- (query pp st)- where munge oc ow op (Event ic _ _ v') =- do- p' <- subArc (arc st) op- 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?)--- TODO - what if a continuous pattern contains a discrete one, or vice-versa?-squeezeJoin :: Pattern (Pattern a) -> Pattern a-squeezeJoin pp = pp {query = q}- where q st = concatMap- (\e@(Event c w p v) ->- mapMaybe (munge c w p) $ query (focusArc (wholeOrPart e) v) st {arc = p}- )- (query pp st)- munge oContext oWhole oPart (Event iContext iWhole iPart v) =- do w' <- subMaybeArc oWhole iWhole- p' <- subArc oPart iPart- return (Event (combineContexts [iContext, oContext]) w' p' v)---_trigJoin :: Bool -> Pattern (Pattern a) -> Pattern a-_trigJoin cycleZero pat_of_pats = Pattern q- where q st =- catMaybes $- concatMap- (\oe@(Event oc (Just jow) op ov) ->- map (\oe@(Event ic (iw) ip iv) ->- do w <- subMaybeArc (Just jow) iw- p <- subArc op ip- return $ Event (combineContexts [ic, oc]) w p iv- )- $ query (((if cycleZero then id else cyclePos) $ start jow) `rotR` ov) st- )- (query (filterDigital pat_of_pats) st)--trigJoin :: Pattern (Pattern a) -> Pattern a-trigJoin = _trigJoin False--trigZeroJoin :: Pattern (Pattern a) -> Pattern a-trigZeroJoin = _trigJoin True--reset :: Pattern Bool -> Pattern a -> Pattern a-reset bp pat = trigJoin $ (\v -> if v then pat else silence) <$> bp--resetTo :: Pattern Rational -> Pattern a -> Pattern a-resetTo bp pat = trigJoin $ (\v -> rotL v pat) <$> bp--restart :: Pattern Bool -> Pattern a -> Pattern a-restart bp pat = trigZeroJoin $ (\v -> if v then pat else silence) <$> bp--restartTo :: Pattern Rational -> Pattern a -> Pattern a-restartTo bp pat = trigZeroJoin $ (\v -> rotL v pat) <$> bp---- | * Patterns as numbers--noOv :: String -> a-noOv meth = error $ meth ++ ": not supported for patterns"--instance Eq (Pattern a) where- (==) = noOv "(==)"--instance Ord a => Ord (Pattern a) where- min = liftA2 min- max = liftA2 max- compare = noOv "compare"- (<=) = noOv "(<=)"--instance Num a => Num (Pattern a) where- negate = fmap negate- (+) = liftA2 (+)- (*) = liftA2 (*)- fromInteger = pure . fromInteger- abs = fmap abs- signum = fmap signum--instance Enum a => Enum (Pattern a) where- succ = fmap succ- pred = fmap pred- toEnum = pure . toEnum- fromEnum = noOv "fromEnum"- enumFrom = noOv "enumFrom"- enumFromThen = noOv "enumFromThen"- enumFromTo = noOv "enumFromTo"- enumFromThenTo = noOv "enumFromThenTo"--instance Monoid (Pattern a) where- mempty = empty--instance Semigroup (Pattern a) where- (<>) !p !p' = Pattern $ \st -> query p st ++ query p' st--instance (Num a, Ord a) => Real (Pattern a) where- toRational = noOv "toRational"--instance (Integral a) => Integral (Pattern a) where- quot = liftA2 quot- rem = liftA2 rem- div = liftA2 div- mod = liftA2 mod- toInteger = noOv "toInteger"- x `quotRem` y = (x `quot` y, x `rem` y)- x `divMod` y = (x `div` y, x `mod` y)--instance (Fractional a) => Fractional (Pattern a) where- recip = fmap recip- fromRational = pure . fromRational--instance (Floating a) => Floating (Pattern a) where- pi = pure pi- sqrt = fmap sqrt- exp = fmap exp- log = fmap log- sin = fmap sin- cos = fmap cos- asin = fmap asin- atan = fmap atan- acos = fmap acos- sinh = fmap sinh- cosh = fmap cosh- asinh = fmap asinh- atanh = fmap atanh- acosh = fmap acosh--instance (RealFrac a) => RealFrac (Pattern a) where- properFraction = noOv "properFraction"- truncate = noOv "truncate"- round = noOv "round"- ceiling = noOv "ceiling"- floor = noOv "floor"--instance (RealFloat a) => RealFloat (Pattern a) where- floatRadix = noOv "floatRadix"- floatDigits = noOv "floatDigits"- floatRange = noOv "floatRange"- decodeFloat = noOv "decodeFloat"- encodeFloat = ((.).(.)) pure encodeFloat- exponent = noOv "exponent"- significand = noOv "significand"- scaleFloat n = fmap (scaleFloat n)- isNaN = noOv "isNaN"- isInfinite = noOv "isInfinite"- isDenormalized = noOv "isDenormalized"- isNegativeZero = noOv "isNegativeZero"- isIEEE = noOv "isIEEE"- atan2 = liftA2 atan2--instance Num ValueMap where- negate = (applyFIS negate negate id <$>)- (+) = Map.unionWith (fNum2 (+) (+))- (*) = Map.unionWith (fNum2 (*) (*))- fromInteger i = Map.singleton "n" $ VI (fromInteger i)- signum = (applyFIS signum signum id <$>)- abs = (applyFIS abs abs id <$>)--instance Fractional ValueMap where- recip = fmap (applyFIS recip id id)- fromRational r = Map.singleton "speed" $ VF (fromRational r)--class Moddable a where- gmod :: a -> a -> a--instance Moddable Double where- gmod = mod'-instance Moddable Rational where- gmod = mod'-instance Moddable Note where- gmod (Note a) (Note b) = Note (mod' a b)-instance Moddable Int where- gmod = mod-instance Moddable ValueMap where- gmod = Map.unionWith (fNum2 mod mod')--instance Floating ValueMap- where pi = noOv "pi"- exp _ = noOv "exp"- log _ = noOv "log"- sin _ = noOv "sin"- cos _ = noOv "cos"- asin _ = noOv "asin"- acos _ = noOv "acos"- atan _ = noOv "atan"- sinh _ = noOv "sinh"- cosh _ = noOv "cosh"- asinh _ = noOv "asinh"- acosh _ = noOv "acosh"- atanh _ = noOv "atanh"----------------------------------------------------------------------------- * Internal/fundamental functions--empty :: Pattern a-empty = Pattern {query = const []}--silence :: Pattern a-silence = empty--queryArc :: Pattern a -> Arc -> [Event a]-queryArc p a = query p $ State a Map.empty---- | Splits queries that span cycles. For example `query p (0.5, 1.5)` would be--- turned into two queries, `(0.5,1)` and `(1,1.5)`, and the results--- combined. Being able to assume queries don't span cycles often--- makes transformations easier to specify.-splitQueries :: Pattern a -> Pattern a-splitQueries p = p {query = \st -> concatMap (\a -> query p st {arc = a}) $ arcCyclesZW (arc st)}---- | 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 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-withResultTime :: (Time -> Time) -> Pattern a -> Pattern a-withResultTime f = withResultArc (\(Arc s e) -> Arc (f s) (f e))---- | Apply a function to the timespan of the query-withQueryArc :: (Arc -> Arc) -> Pattern a -> Pattern a-withQueryArc f pat = pat {query = query pat . (\(State a m) -> State (f a) m)}---- | Apply a function to the time (both start and end) of the query-withQueryTime :: (Time -> Time) -> Pattern a -> Pattern a-withQueryTime f pat = withQueryArc (\(Arc s e) -> Arc (f s) (f e)) pat---- | Apply a function to the control values of the query-withQueryControls :: (ValueMap -> ValueMap) -> Pattern a -> Pattern a-withQueryControls f pat = pat { query = query pat . (\(State a m) -> State a (f m))}---- | @withEvent f p@ returns a new @Pattern@ with each event mapped over--- function @f@.-withEvent :: (Event a -> Event b) -> Pattern a -> Pattern b-withEvent f p = p {query = map f . query p}---- | @withEvent f p@ returns a new @Pattern@ with each value mapped over--- function @f@.-withValue :: (a -> b) -> Pattern a -> Pattern b-withValue f pat = withEvent (fmap f) pat---- | @withEvent f p@ returns a new @Pattern@ with f applied to the resulting list of events for each query--- function @f@.-withEvents :: ([Event a] -> [Event b]) -> Pattern a -> Pattern b-withEvents f p = p {query = f . query p}---- | @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 c w p v) -> Event c w (f p) v)--_extract :: (Value -> Maybe a) -> String -> ControlPattern -> Pattern a-_extract f name pat = filterJust $ withValue (Map.lookup name >=> f) pat---- | Extract a pattern of integer values by from a control pattern, given the name of the control-extractI :: String -> ControlPattern -> Pattern Int-extractI = _extract getI---- | Extract a pattern of floating point values by from a control pattern, given the name of the control-extractF :: String -> ControlPattern -> Pattern Double-extractF = _extract getF---- | Extract a pattern of string values by from a control pattern, given the name of the control-extractS :: String -> ControlPattern -> Pattern String-extractS = _extract getS---- | Extract a pattern of boolean values by from a control pattern, given the name of the control-extractB :: String -> ControlPattern -> Pattern Bool-extractB = _extract getB---- | Extract a pattern of rational values by from a control pattern, given the name of the control-extractR :: String -> ControlPattern -> Pattern Rational-extractR = _extract getR---- | Extract a pattern of note values by from a control pattern, given the name of the control-extractN :: String -> ControlPattern -> Pattern Note -extractN = _extract getN--compressArc :: Arc -> Pattern a -> Pattern a-compressArc (Arc s e) p | s > e = empty- | s > 1 || e > 1 = empty- | s < 0 || e < 0 = empty- | otherwise = s `rotR` _fastGap (1/(e-s)) p--compressArcTo :: Arc -> Pattern a -> Pattern a-compressArcTo (Arc s e) = compressArc (Arc (cyclePos s) (e - sam s))--focusArc :: Arc -> Pattern a -> Pattern a-focusArc (Arc s e) p = (cyclePos s) `rotR` (_fast (1/(e-s)) p)---{-| Speed up a pattern by the given time pattern.--For example, the following will play the sound pattern @"bd sn kurt"@ twice as-fast (i.e., so it repeats twice per cycle), and the vowel pattern three times-as fast:--> d1 $ sound (fast 2 "bd sn kurt")-> # fast 3 (vowel "a e o")--The first parameter can be patterned to, for example, play the pattern at twice-the speed for the first half of each cycle and then four times the speed for the-second half:--> d1 $ fast "2 4" $ sound "bd sn kurt cp"--}-fast :: Pattern Time -> Pattern a -> Pattern a-fast = tParam _fast--{-| @fastSqueeze@ speeds up a pattern by a time pattern given as input,- squeezing the resulting pattern inside one cycle and playing the original- pattern at every repetition.-- To better understand how it works, compare it with 'fast':-- >>> print $ fast "1 2" $ s "bd sn"- (0>½)|s: "bd"- (½>¾)|s: "bd"- (¾>1)|s: "sn"-- This will give @bd@ played in the first half cycle, and @bd sn@ in the second- half. On the other hand, using fastSqueeze;-- >>> print $ fastSqueeze "1 2" $ s "bd sn"- (0>¼)|s: "bd"- (¼>½)|s: "sn"- (½>⅝)|s: "bd"- (⅝>¾)|s: "sn"- (¾>⅞)|s: "bd"- (⅞>1)|s: "sn"-- The original pattern will play in the first half, and two repetitions of the- original pattern will play in the second half. That is, every repetition- contains the whole pattern.-- If the time pattern has a single value, it becomes equivalent to 'fast':-- > d1 $ fastSqueeze 2 $ s "bd sn"- > d1 $ fast 2 $ s "bd sn"- > d1 $ s "[bd sn]*2"--}-fastSqueeze :: Pattern Time -> Pattern a -> Pattern a-fastSqueeze = tParamSqueeze _fast---- | An alias for @fast@-density :: Pattern Time -> Pattern a -> Pattern a-density = fast--_fast :: Time -> Pattern a -> Pattern a-_fast rate pat | rate == 0 = silence- | rate < 0 = rev $ _fast (negate rate) pat- | otherwise = withResultTime (/ rate) $ withQueryTime (* rate) pat--{-| Slow down a pattern by the given time pattern.-- For example, the following will play the sound pattern @"bd sn kurt"@ twice as- slow (i.e., so it repeats once every two cycles), and the vowel pattern three- times as slow:-- > d1 $ sound (slow 2 "bd sn kurt")- > # slow 3 (vowel "a e o")--}-slow :: Pattern Time -> Pattern a -> Pattern a-slow = tParam _slow-_slow :: Time -> Pattern a -> Pattern a-_slow 0 _ = silence-_slow r p = _fast (1/r) p--_fastGap :: Time -> Pattern a -> Pattern a-_fastGap 0 _ = empty-_fastGap r p = splitQueries $- withResultArc (\(Arc s e) -> Arc (sam s + ((s - sam s)/r'))- (sam s + ((e - sam s)/r'))- ) $ p {query = f}- where r' = max r 1- -- zero width queries of the next sam should return zero in this case..- f st@(State a _) | start a' == nextSam (start a) = []- | otherwise = query p st {arc = a'}- where mungeQuery t = sam t + min 1 (r' * cyclePos t)- a' = (\(Arc s e) -> Arc (mungeQuery s) (mungeQuery e)) a--{-| Shifts a pattern back in time by the given amount, expressed in cycles.-- This will skip to the fourth cycle:-- > do- > resetCycles- > d1 $ rotL 4 $ seqP- > [ (0, 12, sound "bd bd*2")- > , (4, 12, sound "hh*2 [sn cp] cp future*4")- > , (8, 12, sound (samples "arpy*8" (run 16)))- > ]-- Useful when building and testing out longer sequences.--}-rotL :: Time -> Pattern a -> Pattern a-rotL t p = withResultTime (subtract t) $ withQueryTime (+ t) p--{-| Shifts a pattern forward in time by the given amount, expressed in cycles.- Opposite of 'rotL'.--}-rotR :: Time -> Pattern a -> Pattern a-rotR t = rotL (negate t)--{- | @rev p@ returns @p@ with the event positions in each cycle reversed (or- mirrored).-- For example rev @"1 [~ 2] ~ 3"@ is equivalent to rev @"3 ~ [2 ~] 1"@.-- Note that @rev@ reverses on a cycle-by-cycle basis. This means that @rev (slow- 2 "1 2 3 4")@ would actually result in @(slow 2 "2 1 4 3")@. This is because the- @slow 2@ makes the repeating pattern last two cycles, each of which is reversed- independently.-- In practice rev is generally used with conditionals, for example with every:-- > d1 $ every 3 rev $ n "0 1 [~ 2] 3" # sound "arpy"-- or 'jux':-- > d1 $ jux rev $ n (iter 4 "0 1 [~ 2] 3") # sound "arpy"--}-rev :: Pattern a -> Pattern a-rev p =- splitQueries $ p {- query = \st -> map makeWholeAbsolute $- mapParts (mirrorArc (midCycle $ arc st)) $- map makeWholeRelative- (query p st- {arc = mirrorArc (midCycle $ arc st) (arc st)- })- }- where makeWholeRelative :: Event a -> Event a- 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 {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 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))---- | Mark values in the first pattern which match with at least one--- value in the second pattern.-matchManyToOne :: (b -> a -> Bool) -> Pattern a -> Pattern b -> Pattern (Bool, b)-matchManyToOne f pa pb = pa {query = q}- where q st = map match $ query pb st- where- match ex@(Event xContext xWhole xPart x) =- Event (combineContexts $ xContext:map context as') xWhole xPart (any (f x . value) as', x)- where as' = as $ start $ wholeOrPart ex- as s = query pa $ fQuery s- fQuery s = st {arc = Arc s s}---- ** Event filters---- | Remove events from patterns that to not meet the given test-filterValues :: (a -> Bool) -> Pattern a -> Pattern a-filterValues f p = p {query = filter (f . value) . query p}---- | Turns a pattern of 'Maybe' values into a pattern of values,--- dropping the events of 'Nothing'.-filterJust :: Pattern (Maybe a) -> Pattern a-filterJust p = fromJust <$> filterValues isJust p--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 (filterDigital p)}--filterEvents :: (Event a -> Bool) -> Pattern a -> Pattern a-filterEvents f p = p {query = filter f . query p}--filterDigital :: Pattern a -> Pattern a-filterDigital = filterEvents isDigital--filterAnalog :: Pattern a -> Pattern a-filterAnalog = filterEvents isAnalog--playFor :: Time -> Time -> Pattern a -> Pattern a-playFor s e pat = Pattern $ \st -> maybe [] (\a -> query pat (st {arc = a})) $ subArc (Arc s e) (arc st)---- ** Temporal parameter helpers--tParam :: (t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a-tParam f tv p = innerJoin $ (`f` p) <$> tv--tParam2 :: (a -> b -> c -> Pattern d) -> Pattern a -> Pattern b -> c -> Pattern d-tParam2 f a b p = innerJoin $ (\x y -> f x y p) <$> a <*> b--tParam3 :: (a -> b -> c -> Pattern d -> Pattern e) -> (Pattern a -> Pattern b -> Pattern c -> Pattern d -> Pattern e)-tParam3 f a b c p = innerJoin $ (\x y z -> f x y z p) <$> a <*> b <*> c--tParamSqueeze :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c)-tParamSqueeze f tv p = squeezeJoin $ (`f` p) <$> tv---- ** Context--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---- A hack to add to manipulate source code to add calls to--- 'deltaContext' around strings, so events from mininotation 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--class Stringy a where- deltaContext :: Int -> Int -> a -> a--instance Stringy (Pattern a) where- 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---- deltaContext on an actual (non overloaded) string is a no-op-instance Stringy String where- deltaContext _ _ = id---- ** Events---- | Some context for an event, currently just position within sourcecode-data Context = Context {contextPosition :: [((Int, Int), (Int, Int))]}- deriving (Eq, Ord, Generic)-instance NFData Context---- | 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- { context :: Context- , whole :: Maybe a- , part :: a- , value :: b- } deriving (Eq, Ord, Functor, Generic)-instance (NFData a, NFData b) => NFData (EventF a b)--type Event a = EventF (ArcF Time) a---- * Event utilities--isAnalog :: Event a -> Bool-isAnalog (Event {whole = Nothing}) = True-isAnalog _ = False--isDigital :: Event a -> Bool-isDigital = not . isAnalog---- | `True` if an `Event`'s starts is within given `Arc`-onsetIn :: Arc -> Event a -> Bool-onsetIn a e = isIn a (wholeStart e)---- | Returns a list of events, with any adjacent parts of the same whole combined-defragParts :: Eq a => [Event a] -> [Event a]-defragParts [] = []-defragParts [e] = [e]-defragParts (e:es) | isJust i = defraged : defragParts (delete e' es)- | otherwise = e : defragParts es- where i = findIndex (isAdjacent e) es- e' = es !! fromJust i- 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-isAdjacent :: Eq a => Event a -> Event a -> Bool-isAdjacent e e' = (whole e == whole e')- && (value e == value e')- && ((stop (part e) == start (part e'))- ||- (stop (part e') == start (part e))- )--wholeOrPart :: Event a -> Arc-wholeOrPart (Event {whole = Just a}) = a-wholeOrPart e = part e---- | Get the onset of an event's 'whole'-wholeStart :: Event a -> Time-wholeStart = start . wholeOrPart---- | Get the offset of an event's 'whole'-wholeStop :: Event a -> Time-wholeStop = stop . wholeOrPart---- | Get the onset of an event's 'whole'-eventPartStart :: Event a -> Time-eventPartStart = start . part---- | Get the offset of an event's 'part'-eventPartStop :: Event a -> Time-eventPartStop = stop . part---- | Get the timespan of an event's 'part'-eventPart :: Event a -> Arc-eventPart = part--eventValue :: Event a -> a-eventValue = value--eventHasOnset :: Event a -> Bool-eventHasOnset e | isAnalog e = False- | 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 (Context []) (Just $ Arc ws we) (Arc ps pe) v-- -- Resolves higher order VState values to plain values, by passing through (and changing) state-resolveState :: ValueMap -> [Event ValueMap] -> (ValueMap, [Event ValueMap])-resolveState sMap [] = (sMap, [])-resolveState sMap (e:es) = (sMap'', (e {value = v'}):es')- where f sm (VState v) = v sm- f sm v = (sm, v)- (sMap', v') | eventHasOnset e = Map.mapAccum f sMap (value e) -- pass state through VState functions- | otherwise = (sMap, Map.filter notVState $ value e) -- filter out VState values without onsets- (sMap'', es') = resolveState sMap' es- notVState (VState _) = False- notVState _ = True---- ** Values---- | Polymorphic values--data Value = VS { svalue :: String }- | VF { fvalue :: Double }- | VN { nvalue :: Note }- | VR { rvalue :: Rational }- | VI { ivalue :: Int }- | VB { bvalue :: Bool }- | VX { xvalue :: [Word8] } -- Used for OSC 'blobs'- | VPattern {pvalue :: Pattern Value}- | VList {lvalue :: [Value]}- | VState {statevalue :: ValueMap -> (ValueMap, Value)}- deriving (Typeable, Generic)--class Valuable a where- toValue :: a -> Value-instance NFData Value--type ValueMap = Map.Map String Value---- | Note is Double, but with a different parser-newtype Note = Note { unNote :: Double }- deriving (Typeable, Data, Generic, Eq, Ord, Enum, Num, Fractional, Floating, Real, RealFrac)--instance NFData Note--instance Show Note where- show n = (show . unNote $ n) ++ "n (" ++ pitchClass ++ octave ++ ")"- where- pitchClass = pcs !! mod noteInt 12- octave = show $ div noteInt 12 + 5- noteInt = round . unNote $ n- pcs = ["c", "cs", "d", "ds", "e", "f", "fs", "g", "gs", "a", "as", "b"]--instance Valuable String where- toValue a = VS a-instance Valuable Double where- toValue a = VF a-instance Valuable Rational where- toValue a = VR a-instance Valuable Int where- toValue a = VI a-instance Valuable Bool where- toValue a = VB a-instance Valuable Note where- toValue a = VN a-instance Valuable [Word8] where- toValue a = VX a-instance Valuable [Value] where- toValue a = VList a--instance Eq Value where- (VS x) == (VS y) = x == y- (VB x) == (VB y) = x == y- (VF x) == (VF y) = x == y- (VI x) == (VI y) = x == y- (VN x) == (VN y) = x == y- (VR x) == (VR y) = x == y- (VX x) == (VX y) = x == y-- (VF x) == (VI y) = x == fromIntegral y- (VI y) == (VF x) = x == fromIntegral y-- (VF x) == (VR y) = toRational x == y- (VR y) == (VF x) = toRational x == y- (VI x) == (VR y) = toRational x == y- (VR y) == (VI x) = toRational x == y-- _ == _ = False--instance Ord Value where- compare (VS x) (VS y) = compare x y- compare (VB x) (VB y) = compare x y- compare (VF x) (VF y) = compare x y- compare (VN x) (VN y) = compare (unNote x) (unNote y)- compare (VI x) (VI y) = compare x y- compare (VR x) (VR y) = compare x y- compare (VX x) (VX y) = compare x y-- compare (VS _) _ = LT- compare _ (VS _) = GT- compare (VB _) _ = LT- compare _ (VB _) = GT- compare (VX _) _ = LT- compare _ (VX _) = GT-- compare (VF x) (VI y) = compare x (fromIntegral y)- compare (VI x) (VF y) = compare (fromIntegral x) y-- compare (VR x) (VI y) = compare x (fromIntegral y)- compare (VI x) (VR y) = compare (fromIntegral x) y-- compare (VF x) (VR y) = compare x (fromRational y)- compare (VR x) (VF y) = compare (fromRational x) y-- compare (VN x) (VI y) = compare x (fromIntegral y)- compare (VI x) (VN y) = compare (fromIntegral x) y-- compare (VN x) (VR y) = compare (unNote x) (fromRational y)- compare (VR x) (VN y) = compare (fromRational x) (unNote y)-- compare (VF x) (VN y) = compare x (unNote y)- compare (VN x) (VF y) = compare (unNote x) y-- -- you can't really compare patterns, state or lists..- compare (VPattern _) (VPattern _) = EQ- compare (VPattern _) _ = GT- compare _ (VPattern _) = LT-- compare (VState _) (VState _) = EQ- compare (VState _) _ = GT- compare _ (VState _) = LT-- compare (VList _) (VList _) = EQ- compare (VList _) _ = GT- compare _ (VList _) = LT---- | General utilities..---- | Apply one of three functions to a Value, depending on its type-applyFIS :: (Double -> Double) -> (Int -> Int) -> (String -> String) -> Value -> Value-applyFIS f _ _ (VF f') = VF (f f')-applyFIS f _ _ (VN (Note f')) = VN (Note $ f f')-applyFIS _ f _ (VI i) = VI (f i)-applyFIS _ _ f (VS s) = VS (f s)-applyFIS f f' f'' (VState x) = VState $ \cmap -> (applyFIS f f' f'') <$> (x cmap)-applyFIS _ _ _ v = v---- | Apply one of two functions to a pair of Values, depending on their types (int--- or float; strings and rationals are ignored)-fNum2 :: (Int -> Int -> Int) -> (Double -> Double -> Double) -> Value -> Value -> Value-fNum2 fInt _ (VI a) (VI b) = VI (fInt a b)-fNum2 _ fFloat (VF a) (VF b) = VF (fFloat a b)-fNum2 _ fFloat (VN (Note a)) (VN (Note b)) = VN (Note $ fFloat a b)-fNum2 _ fFloat (VF a) (VN (Note b)) = VN (Note $ fFloat a b)-fNum2 _ fFloat (VN (Note a)) (VF b) = VN (Note $ fFloat a b)-fNum2 _ fFloat (VI a) (VF b) = VF (fFloat (fromIntegral a) b)-fNum2 _ fFloat (VF a) (VI b) = VF (fFloat a (fromIntegral b))-fNum2 fInt fFloat (VState a) b = VState $ \cmap -> ((\a' -> fNum2 fInt fFloat a' b) <$> (a cmap))-fNum2 fInt fFloat a (VState b) = VState $ \cmap -> ((\b' -> fNum2 fInt fFloat a b') <$> (b cmap))-fNum2 _ _ x _ = x--getI :: Value -> Maybe Int-getI (VI i) = Just i-getI (VR x) = Just $ floor x-getI (VF x) = Just $ floor x-getI _ = Nothing--getF :: Value -> Maybe Double-getF (VF f) = Just f-getF (VR x) = Just $ fromRational x-getF (VI x) = Just $ fromIntegral x-getF _ = Nothing--getN :: Value -> Maybe Note-getN (VN n) = Just n-getN (VF f) = Just $ Note f-getN (VR x) = Just $ Note $ fromRational x-getN (VI x) = Just $ Note $ fromIntegral x-getN _ = Nothing--getS :: Value -> Maybe String-getS (VS s) = Just s-getS _ = Nothing--getB :: Value -> Maybe Bool-getB (VB b) = Just b-getB _ = Nothing--getR :: Value -> Maybe Rational-getR (VR r) = Just r-getR (VF x) = Just $ toRational x-getR (VI x) = Just $ toRational x-getR _ = Nothing--getBlob :: Value -> Maybe [Word8]-getBlob (VX xs) = Just xs-getBlob _ = Nothing--getList :: Value -> Maybe [Value]-getList (VList vs) = Just vs-getList _ = Nothing--valueToPattern :: Value -> Pattern Value-valueToPattern (VPattern pat) = pat-valueToPattern v = pure v----- functions relating to chords/patterns of lists---sameDur :: Event a -> Event a -> Bool-sameDur e1 e2 = (whole e1 == whole e2) && (part e1 == part e2)--groupEventsBy :: Eq a => (Event a -> Event a -> Bool) -> [Event a] -> [[Event a]]-groupEventsBy _ [] = []-groupEventsBy f (e:es) = eqs:(groupEventsBy f (es \\ eqs))- where eqs = e:[x | x <- es, f e x]---- assumes that all events in the list have same whole/part-collectEvent :: [Event a] -> Maybe (Event [a])-collectEvent [] = Nothing-collectEvent l@(e:_) = Just $ e {context = con, value = vs}- where con = unionC $ map context l- vs = map value l- unionC [] = Context []- unionC ((Context is):cs) = Context (is ++ iss)- where Context iss = unionC cs--collectEventsBy :: Eq a => (Event a -> Event a -> Bool) -> [Event a] -> [Event [a]]-collectEventsBy f es = remNo $ map collectEvent (groupEventsBy f es)- where- remNo [] = []- remNo (Nothing:cs) = remNo cs- remNo ((Just c):cs) = c : (remNo cs)---- | collects all events satisfying the same constraint into a list-collectBy :: Eq a => (Event a -> Event a -> Bool) -> Pattern a -> Pattern [a]-collectBy f = withEvents (collectEventsBy f)---- | collects all events occuring at the exact same time into a list-collect :: Eq a => Pattern a -> Pattern [a]-collect = collectBy sameDur--uncollectEvent :: Event [a] -> [Event a]-uncollectEvent e = [e {value = (value e)!!i, context = resolveContext i (context e)} | i <-[0..length (value e) - 1]]- where resolveContext i (Context xs) = case length xs <= i of- True -> Context []- False -> Context [xs!!i]--uncollectEvents :: [Event [a]] -> [Event a]-uncollectEvents = concatMap uncollectEvent---- | merges all values in a list into one pattern by stacking the values-uncollect :: Pattern [a] -> Pattern a-uncollect = withEvents uncollectEvents
src/Sound/Tidal/Safe/Boot.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoMonomorphismRestriction #-} {- Safe/Boot.hs - as in BootTidal but in the Op monad Copyright (C) 2021 Johannes Waldmann and contributors@@ -18,9 +19,7 @@ You should have received a copy of the GNU General Public License along with this library. If not, see <http://www.gnu.org/licenses/>. -}- {-# OPTIONS_GHC -Wno-missing-signatures #-}-{-# language NoMonomorphismRestriction #-} module Sound.Tidal.Safe.Boot where @@ -31,98 +30,142 @@ -- this will be provided by the Reader monad p = streamReplace+ hush = streamHush+ list = streamList+ mute = streamMute+ unmute = streamUnmute+ solo = streamSolo+ unsolo = streamUnsolo+ once = streamOnce+ first = streamFirst+ asap = once+ nudgeAll = streamNudgeAll+ all = streamAll -{-|- Resets the cycle count back to 0.- Useful to make sure a pattern or set of patterns start from the beginning:+-- |+-- Resets the cycle count back to 0.+-- Useful to make sure a pattern or set of patterns start from the beginning:+--+-- > do+-- > resetCycles+-- > d1 $ s "bd hh hh hh"+-- > d2 $ s "ade" # cut 1+--+-- Cycle count affects all patterns, so if there are any active, all of them will immediately jump to the beginning.+-- @resetCycles@ is also userful in multi-user Tidal.+--+-- Also see 'setCycle', 'getnow'.+resetCycles = streamResetCycles - > do- > resetCycles- > d1 $ s "bd hh hh hh"- > d2 $ s "ade" # cut 1+-- |+-- Adjusts the number of cycles per second, i.e., tempo.+-- Accepts integers, decimals, and fractions.+--+-- The default number of cycles per second is 0.5625, equivalent to 135\/60\/4, i.e.,+-- 135 beats per minute if there are 4 beats per cycle.+--+-- Representing cycles per second using fractions has the advantage of being more+-- human-readable and more closely aligned with how tempo is commonly represented+-- in music as beats per minute (bpm). For example, techno has a typical range of+-- 120-140 bpm and house has a range of 115-130 bpm. To set the tempo in Tidal to+-- fast house, e.g.,: @setcps (130\/60\/4)@.+--+-- The following sound the same:+--+-- > setcps (130/60/4)+-- > d1 $ n "1" # s "kick kick kick kick"+--+-- and+--+-- > setcps (130/60/1)+-- > d1 $ n "1" # s "kick"+setcps = asap . cps - Cycle count affects all patterns, so if there are any active, all of them will immediately jump to the beginning.- @resetCycles@ is also userful in multi-user Tidal.+-- * Transitions - Also see 'setCycle', 'getnow'.--}-resetCycles = streamResetCycles+xfade i = transition True (Sound.Tidal.Transition._xfadeIn 4) i -{-|- Adjusts the number of cycles per second, i.e., tempo.- Accepts integers, decimals, and fractions.+xfadeIn i t = transition True (Sound.Tidal.Transition._xfadeIn t) i - The default number of cycles per second is 0.5625, equivalent to 135\/60\/4, i.e.,- 135 beats per minute if there are 4 beats per cycle.+histpan i t = transition True (Sound.Tidal.Transition._histpan t) i - Representing cycles per second using fractions has the advantage of being more- human-readable and more closely aligned with how tempo is commonly represented- in music as beats per minute (bpm). For example, techno has a typical range of- 120-140 bpm and house has a range of 115-130 bpm. To set the tempo in Tidal to- fast house, e.g.,: @setcps (130\/60\/4)@.+wait i t = transition True (Sound.Tidal.Transition._wait t) i - The following sound the same:+waitT i f t = transition True (Sound.Tidal.Transition._waitT f t) i - > setcps (130/60/4)- > d1 $ n "1" # s "kick kick kick kick"+jump i = transition True (Sound.Tidal.Transition._jump) i - and+jumpIn i t = transition True (Sound.Tidal.Transition._jumpIn t) i - > setcps (130/60/1)- > d1 $ n "1" # s "kick"--}-setcps = asap . cps+jumpIn' i t = transition True (Sound.Tidal.Transition._jumpIn' t) i --- * Transitions+jumpMod i t = transition True (Sound.Tidal.Transition._jumpMod t) i -xfade i = transition True (Sound.Tidal.Transition.xfadeIn 4) i-xfadeIn i t = transition True (Sound.Tidal.Transition.xfadeIn t) i-histpan i t = transition True (Sound.Tidal.Transition.histpan t) i-wait i t = transition True (Sound.Tidal.Transition.wait t) i-waitT i f t = transition True (Sound.Tidal.Transition.waitT f t) i-jump i = transition True (Sound.Tidal.Transition.jump) i-jumpIn i t = transition True (Sound.Tidal.Transition.jumpIn t) i-jumpIn' i t = transition True (Sound.Tidal.Transition.jumpIn' t) i-jumpMod i t = transition True (Sound.Tidal.Transition.jumpMod t) i-mortal i lifespan releaseTime = transition True (Sound.Tidal.Transition.mortal lifespan releaseTime) i-interpolate i = transition True (Sound.Tidal.Transition.interpolate) i-interpolateIn i t = transition True (Sound.Tidal.Transition.interpolateIn t) i-clutch i = transition True (Sound.Tidal.Transition.clutch) i-clutchIn i t = transition True (Sound.Tidal.Transition.clutchIn t) i-anticipate i = transition True (Sound.Tidal.Transition.anticipate) i-anticipateIn i t = transition True (Sound.Tidal.Transition.anticipateIn t) i-forId i t = transition False (Sound.Tidal.Transition.mortalOverlay t) i+mortal i lifespan releaseTime = transition True (Sound.Tidal.Transition._mortal lifespan releaseTime) i +interpolate i = transition True (Sound.Tidal.Transition._interpolate) i++interpolateIn i t = transition True (Sound.Tidal.Transition._interpolateIn t) i++clutch i = transition True (Sound.Tidal.Transition._clutch) i++clutchIn i t = transition True (Sound.Tidal.Transition._clutchIn t) i++anticipate i = transition True (Sound.Tidal.Transition._anticipate) i++anticipateIn i t = transition True (Sound.Tidal.Transition._anticipateIn t) i++forId i t = transition False (Sound.Tidal.Transition._mortalOverlay t) i+ 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 setI = streamSetI+ setF = streamSetF+ setS = streamSetS+ setR = streamSetR+ setB = streamSetB
src/Sound/Tidal/Safe/Context.hs view
@@ -18,42 +18,47 @@ You should have received a copy of the GNU General Public License along with this library. If not, see <http://www.gnu.org/licenses/>. -}--{-# language GeneralizedNewtypeDeriving #-}-{-# language NoMonomorphismRestriction #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module Sound.Tidal.Safe.Context- ( Op () -- do not export constructor,- -- so the user has no way of putting arbitraty IO stuff- -- in "Op", and below "run"- , exec- , streamReplace- , streamHush- , streamList- , streamMute- , streamUnmute- , streamSolo- , streamUnsolo- , streamOnce- , streamFirst- , streamNudgeAll- , streamAll- , streamResetCycles- , streamSetI- , streamSetF- , streamSetS- , streamSetR- , streamSetB- , transition- , module C- , Target(..)+ ( Op (), -- do not export constructor,+ -- so the user has no way of putting arbitraty IO stuff+ -- in "Op", and below "run"+ exec,+ streamReplace,+ streamHush,+ streamList,+ streamMute,+ streamUnmute,+ streamSolo,+ streamUnsolo,+ streamOnce,+ streamFirst,+ streamNudgeAll,+ streamAll,+ streamResetCycles,+ streamSetI,+ streamSetF,+ streamSetS,+ streamSetR,+ streamSetB,+ transition,+ module C,+ Target (..), ) where +-- import Sound.Tidal.Transition as C++import Control.Monad.Catch+import Control.Monad.Reader import Data.Ratio as C import Sound.Tidal.Config as C+import Sound.Tidal.Context (Stream)+import qualified Sound.Tidal.Context as C import Sound.Tidal.Control as C import Sound.Tidal.Core as C import Sound.Tidal.Params as C@@ -61,44 +66,60 @@ import Sound.Tidal.Pattern as C import Sound.Tidal.Scales as C import Sound.Tidal.Simple as C-import Sound.Tidal.Stream- (startTidal, superdirtTarget, Target(..))--- import Sound.Tidal.Transition as C+import Sound.Tidal.Stream.Main (startTidal)+import Sound.Tidal.Stream.Target (superdirtTarget)+import Sound.Tidal.Stream.Types (Target (..)) import Sound.Tidal.UI as C import Sound.Tidal.Version as C -import qualified Sound.Tidal.Context as C-import Sound.Tidal.Context (Stream)-import Control.Monad.Reader-import Control.Monad.Catch--newtype Op r = Op ( ReaderT Stream IO r )- deriving (Functor, Applicative, Monad, MonadCatch,MonadThrow)+newtype Op r = Op (ReaderT Stream IO r)+ deriving (Functor, Applicative, Monad, MonadCatch, MonadThrow) exec :: Stream -> Op r -> IO r exec stream (Op m) = runReaderT m stream -op1 f = Op $ do a <- ask; lift $ f a-op2 f b = Op $ do a <- ask; lift $ f a b -op3 f b c = Op $ do a <- ask; lift $ f a b c-op4 f b c d = Op $ do a <- ask; lift $ f a b c d+op1 f = Op $ do a <- ask; lift $ f a++op2 f b = Op $ do a <- ask; lift $ f a b++op3 f b c = Op $ do a <- ask; lift $ f a b c++op4 f b c d = Op $ do a <- ask; lift $ f a b c d+ op5 f b c d e = Op $ do a <- ask; lift $ f a b c d e streamReplace = op3 C.streamReplace+ streamHush = op1 C.streamHush+ streamList = op1 C.streamList+ streamMute = op2 C.streamMute+ streamUnmute = op2 C.streamUnmute+ streamSolo = op2 C.streamSolo+ streamUnsolo = op2 C.streamUnsolo+ streamOnce = op2 C.streamOnce+ streamFirst = op2 C.streamFirst+ streamNudgeAll = op2 C.streamNudgeAll+ streamAll = op2 C.streamAll+ streamResetCycles = op1 C.streamResetCycles+ transition = op5 C.transition+ streamSetI = op3 C.streamSetI+ streamSetF = op3 C.streamSetF+ streamSetS = op3 C.streamSetS+ streamSetR = op3 C.streamSetR+ streamSetB = op3 C.streamSetB
− src/Sound/Tidal/Scales.hs
@@ -1,356 +0,0 @@-module Sound.Tidal.Scales (scale, scaleList, scaleTable, getScale) where--{-- Scale.hs - Scales for TidalCycles- Copyright (C) 2020, lvm (Mauro) and contributors-- This library is free software: you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this library. If not, see <http://www.gnu.org/licenses/>.--}--import Prelude hiding ((<*), (*>))-import Data.Maybe-import Sound.Tidal.Pattern-import Sound.Tidal.Utils---- * Scale definitions---- ** Five notes scales-minPent :: Fractional a => [a]-minPent = [0,3,5,7,10]-majPent :: Fractional a => [a]-majPent = [0,2,4,7,9]---- | Another mode of major pentatonic-ritusen :: Fractional a => [a]-ritusen = [0,2,5,7,9]---- | Another mode of major pentatonic-egyptian :: Fractional a => [a]-egyptian = [0,2,5,7,10]---- *** Other scales--kumai :: Fractional a => [a]-kumai = [0,2,3,7,9]-hirajoshi :: Fractional a => [a]-hirajoshi = [0,2,3,7,8]-iwato :: Fractional a => [a]-iwato = [0,1,5,6,10]-chinese :: Fractional a => [a]-chinese = [0,4,6,7,11]-indian :: Fractional a => [a]-indian = [0,4,5,7,10]-pelog :: Fractional a => [a]-pelog = [0,1,3,7,8]---- *** More scales--prometheus :: Fractional a => [a]-prometheus = [0,2,4,6,11]-scriabin :: Fractional a => [a]-scriabin = [0,1,4,7,9]---- *** Han Chinese pentatonic scales-gong :: Fractional a => [a]-gong = [0,2,4,7,9]-shang :: Fractional a => [a]-shang = [0,2,5,7,10]-jiao :: Fractional a => [a]-jiao = [0,3,5,8,10]-zhi :: Fractional a => [a]-zhi = [0,2,5,7,9]-yu :: Fractional a => [a]-yu = [0,3,5,7,10]---- ** 6 note scales-whole' :: Fractional a => [a]-whole' = [0,2,4,6,8,10]-augmented :: Fractional a => [a]-augmented = [0,3,4,7,8,11]-augmented2 :: Fractional a => [a]-augmented2 = [0,1,4,5,8,9]---- *** Hexatonic modes with no tritone-hexMajor7 :: Fractional a => [a]-hexMajor7 = [0,2,4,7,9,11]-hexDorian :: Fractional a => [a]-hexDorian = [0,2,3,5,7,10]-hexPhrygian :: Fractional a => [a]-hexPhrygian = [0,1,3,5,8,10]-hexSus :: Fractional a => [a]-hexSus = [0,2,5,7,9,10]-hexMajor6 :: Fractional a => [a]-hexMajor6 = [0,2,4,5,7,9]-hexAeolian :: Fractional a => [a]-hexAeolian = [0,3,5,7,8,10]---- ** 7 note scales-major :: Fractional a => [a]-major = [0,2,4,5,7,9,11]-ionian :: Fractional a => [a]-ionian = [0,2,4,5,7,9,11]-dorian :: Fractional a => [a]-dorian = [0,2,3,5,7,9,10]-phrygian :: Fractional a => [a]-phrygian = [0,1,3,5,7,8,10]-lydian :: Fractional a => [a]-lydian = [0,2,4,6,7,9,11]-mixolydian :: Fractional a => [a]-mixolydian = [0,2,4,5,7,9,10]-aeolian :: Fractional a => [a]-aeolian = [0,2,3,5,7,8,10]-minor :: Fractional a => [a]-minor = [0,2,3,5,7,8,10]-locrian :: Fractional a => [a]-locrian = [0,1,3,5,6,8,10]-harmonicMinor :: Fractional a => [a]-harmonicMinor = [0,2,3,5,7,8,11]-harmonicMajor :: Fractional a => [a]-harmonicMajor = [0,2,4,5,7,8,11]-melodicMinor :: Fractional a => [a]-melodicMinor = [0,2,3,5,7,9,11]-melodicMinorDesc :: Fractional a => [a]-melodicMinorDesc = [0,2,3,5,7,8,10]-melodicMajor :: Fractional a => [a]-melodicMajor = [0,2,4,5,7,8,10]-bartok :: Fractional a => [a]-bartok = melodicMajor-hindu :: Fractional a => [a]-hindu = melodicMajor---- *** Raga modes-todi :: Fractional a => [a]-todi = [0,1,3,6,7,8,11]-purvi :: Fractional a => [a]-purvi = [0,1,4,6,7,8,11]-marva :: Fractional a => [a]-marva = [0,1,4,6,7,9,11]-bhairav :: Fractional a => [a]-bhairav = [0,1,4,5,7,8,11]-ahirbhairav :: Fractional a => [a]-ahirbhairav = [0,1,4,5,7,9,10]---- *** More modes-superLocrian :: Fractional a => [a]-superLocrian = [0,1,3,4,6,8,10]-romanianMinor :: Fractional a => [a]-romanianMinor = [0,2,3,6,7,9,10]-hungarianMinor :: Fractional a => [a]-hungarianMinor = [0,2,3,6,7,8,11]-neapolitanMinor :: Fractional a => [a]-neapolitanMinor = [0,1,3,5,7,8,11]-enigmatic :: Fractional a => [a]-enigmatic = [0,1,4,6,8,10,11]-spanish :: Fractional a => [a]-spanish = [0,1,4,5,7,8,10]---- *** Modes of whole tones with added note ->-leadingWhole :: Fractional a => [a]-leadingWhole = [0,2,4,6,8,10,11]-lydianMinor :: Fractional a => [a]-lydianMinor = [0,2,4,6,7,8,10]-neapolitanMajor :: Fractional a => [a]-neapolitanMajor = [0,1,3,5,7,9,11]-locrianMajor :: Fractional a => [a]-locrianMajor = [0,2,4,5,6,8,10]---- ** 8 note scales-diminished :: Fractional a => [a]-diminished = [0,1,3,4,6,7,9,10]-diminished2 :: Fractional a => [a]-diminished2 = [0,2,3,5,6,8,9,11]---- ** Modes of limited transposition-messiaen1 :: Fractional a => [a]-messiaen1 = whole'-messiaen2 :: Fractional a => [a]-messiaen2 = diminished-messiaen3 :: Fractional a => [a]-messiaen3 = [0, 2, 3, 4, 6, 7, 8, 10, 11]-messiaen4 :: Fractional a => [a]-messiaen4 = [0, 1, 2, 5, 6, 7, 8, 11]-messiaen5 :: Fractional a => [a]-messiaen5 = [0, 1, 5, 6, 7, 11]-messiaen6 :: Fractional a => [a]-messiaen6 = [0, 2, 4, 5, 6, 8, 10, 11]-messiaen7 :: Fractional a => [a]-messiaen7 = [0, 1, 2, 3, 5, 6, 7, 8, 9, 11]---- ** Arabic maqams taken from SuperCollider's Scale.sc-bayati :: Fractional a => [a]-bayati = [0, 1.5, 3, 5, 7, 8, 10]-hijaz :: Fractional a => [a]-hijaz = [0, 1, 4, 5, 7, 8.5, 10]-sikah :: Fractional a => [a]-sikah = [0, 1.5, 3.5, 5.5, 7, 8.5, 10.5]-rast :: Fractional a => [a]-rast = [0, 2, 3.5, 5, 7, 9, 10.5]-iraq :: Fractional a => [a]-iraq = [0, 1.5, 3.5, 5, 6.5, 8.5, 10.5]-saba :: Fractional a => [a]-saba = [0, 1.5, 3, 4, 6, 8, 10]---- ** 12 note scales-chromatic :: Fractional a => [a]-chromatic = [0,1,2,3,4,5,6,7,8,9,10,11]--{-|- Interprets a pattern of note numbers into a particular named scale. For example:-- > d1- > $ jux rev- > $ chunk 4 (fast 2 . (|- n 12))- > $ off 0.25 (|+ 7)- > $ struct (iter 4 "t(5,8)")- > $ n (scale "ritusen" "0 .. 7")- > # sound "superpiano"--}-scale :: Fractional a => Pattern String -> Pattern Int -> Pattern a-scale = getScale scaleTable--{-|- Build a scale function, with additional scales if you wish. For example:-- > let myscale =- > getScale- > ( scaleTable ++- > [ ("techno", [0,2,3,5,7,8,10])- > , ("broken", [0,1,4,7,8,10])- > ]- > )-- The above takes the standard 'scaleTable' as a starting point and adds two custom scales to it. You’ll be able to use the new function in place of the normal one:-- > d1 $ n (myscale "techno" "0 1 2 3 4 5 6 7") # sound "superpiano"--}-getScale :: Fractional a => [(String, [a])] -> Pattern String -> Pattern Int -> Pattern a-getScale table sp p = (\n scaleName- -> noteInScale (fromMaybe [0] $ lookup scaleName table) n) <$> p <* sp- where octave s x = x `div` length s- noteInScale s x = (s !!! x) + fromIntegral (12 * octave s x)--{-|- Outputs this list of all the available scales:--@-minPent majPent ritusen egyptian kumai hirajoshi iwato chinese indian pelog-prometheus scriabin gong shang jiao zhi yu whole wholetone augmented augmented2-hexMajor7 hexDorian hexPhrygian hexSus hexMajor6 hexAeolian major ionian dorian-phrygian lydian mixolydian aeolian minor locrian harmonicMinor harmonicMajor-melodicMinor melodicMinorDesc melodicMajor bartok hindu todi purvi marva bhairav-ahirbhairav superLocrian romanianMinor hungarianMinor neapolitanMinor enigmatic-spanish leadingWhole lydianMinor neapolitanMajor locrianMajor diminished-octatonic diminished2 octatonic2 messiaen1 messiaen2 messiaen3 messiaen4-messiaen5 messiaen6 messiaen7 chromatic bayati hijaz sikah rast saba iraq-@--}-scaleList :: String-scaleList = unwords $ map fst (scaleTable :: [(String, [Rational])])--{-|- Outputs a list of all available scales and their corresponding notes. For- example, its first entry is @("minPent",[0,3,5,7,10]@) which means that- a minor pentatonic scale is formed by the root (0), the minor third (3 semitones- above the root), the perfect fourth (5 semitones above the root), etc.-- As the list is big, you can use the Haskell function lookup to look up a- specific scale: @lookup "phrygian" scaleTable@. This will output- @Just [0.0,1.0,3.0,5.0,7.0,8.0,10.0]@.-- You can also do a reverse lookup into the scale table. For example:-- > filter ( \(_, x) -> take 3 x == [0,2,4] ) scaleTable-- The above example will output all scales of which the first three notes are- the root, the major second (2 semitones above the fundamental), and the major- third (4 semitones above the root).--}-scaleTable :: Fractional a => [(String, [a])]-scaleTable = [("minPent", minPent),- ("majPent", majPent),- ("ritusen", ritusen),- ("egyptian", egyptian),- ("kumai", kumai),- ("hirajoshi", hirajoshi),- ("iwato", iwato),- ("chinese", chinese),- ("indian", indian),- ("pelog", pelog),- ("prometheus", prometheus),- ("scriabin", scriabin),- ("gong", gong),- ("shang", shang),- ("jiao", jiao),- ("zhi", zhi),- ("yu", yu),- ("whole", whole'),- ("wholetone", whole'),- ("augmented", augmented),- ("augmented2", augmented2),- ("hexMajor7", hexMajor7),- ("hexDorian", hexDorian),- ("hexPhrygian", hexPhrygian),- ("hexSus", hexSus),- ("hexMajor6", hexMajor6),- ("hexAeolian", hexAeolian),- ("major", major),- ("ionian", ionian),- ("dorian", dorian),- ("phrygian", phrygian),- ("lydian", lydian),- ("mixolydian", mixolydian),- ("aeolian", aeolian),- ("minor", minor),- ("locrian", locrian),- ("harmonicMinor", harmonicMinor),- ("harmonicMajor", harmonicMajor),- ("melodicMinor", melodicMinor),- ("melodicMinorDesc", melodicMinorDesc),- ("melodicMajor", melodicMajor),- ("bartok", bartok),- ("hindu", hindu),- ("todi", todi),- ("purvi", purvi),- ("marva", marva),- ("bhairav", bhairav),- ("ahirbhairav", ahirbhairav),- ("superLocrian", superLocrian),- ("romanianMinor", romanianMinor),- ("hungarianMinor", hungarianMinor),- ("neapolitanMinor", neapolitanMinor),- ("enigmatic", enigmatic),- ("spanish", spanish),- ("leadingWhole", leadingWhole),- ("lydianMinor", lydianMinor),- ("neapolitanMajor", neapolitanMajor),- ("locrianMajor", locrianMajor),- ("diminished", diminished),- ("octatonic", diminished),- ("diminished2", diminished2),- ("octatonic2", diminished2),- ("messiaen1", messiaen1),- ("messiaen2", messiaen2),- ("messiaen3", messiaen3),- ("messiaen4", messiaen4),- ("messiaen5", messiaen5),- ("messiaen6", messiaen6),- ("messiaen7", messiaen7),- ("chromatic", chromatic),- ("bayati", bayati),- ("hijaz", hijaz),- ("sikah", sikah),- ("rast", rast),- ("saba", saba),- ("iraq", iraq)- ]
− src/Sound/Tidal/Show.hs
@@ -1,241 +0,0 @@-{-# LANGUAGE FlexibleInstances, RecordWildCards #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Sound.Tidal.Show (show, showAll, draw, drawLine, drawLineSz, stepcount, showStateful) where---{-- Show.hs - Library for visualising Tidal patterns as text- Copyright (C) 2020, Alex McLean and contributors-- This library is free software: you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this library. If not, see <http://www.gnu.org/licenses/>.--}--import Sound.Tidal.Pattern--import Data.List (intercalate, sortOn)-import Data.Ratio (numerator, denominator)-import Data.Maybe (fromMaybe, isJust)--import qualified Data.Map.Strict as Map--instance (Show a) => Show (Pattern a) where- show = showPattern (Arc 0 1)--showStateful :: ControlPattern -> String-showStateful p = intercalate "\n" evStrings- where (_, evs) = resolveState (Map.empty) $ sortOn part $ queryArc (filterOnsets p) (Arc 0 1)- evs' = map showEvent evs- maxPartLength :: Int- maxPartLength = maximum $ map (length . fst) evs'- evString :: (String, String) -> String- evString ev = ((replicate (maxPartLength - (length (fst ev))) ' ')- ++ fst ev- ++ snd ev- )- evStrings = map evString evs'--showPattern :: Show a => Arc -> Pattern a -> String-showPattern a p = intercalate "\n" evStrings- where evs = map showEvent $ sortOn part $ queryArc p a- maxPartLength :: Int- maxPartLength = maximum $ map (length . fst) evs- evString :: (String, String) -> String- evString ev = replicate (maxPartLength - length (fst ev)) ' '- ++ uncurry (++) ev- evStrings = map evString evs--showEvent :: Show a => Event a -> (String, String)-showEvent (Event _ (Just (Arc ws we)) a@(Arc ps pe) e) =- (h ++ "(" ++ show a ++ ")" ++ t ++ "|", show e)- where h | ws == ps = ""- | otherwise = prettyRat ws ++ "-"- t | we == pe = ""- | otherwise = "-" ++ prettyRat we--showEvent (Event _ Nothing a e) =- ("~" ++ show a ++ "~|", show e)---- Show everything, including event context-showAll :: Show a => Arc -> Pattern a -> String-showAll a p = intercalate "\n" $ map showEventAll $ sortOn part $ queryArc p a---- Show context of an event-showEventAll :: Show a => Event a -> String-showEventAll e = show (context e) ++ uncurry (++) (showEvent e)--instance Show Context where- show (Context cs) = show cs--instance Show Value where- show (VS s) = ('"':s) ++ "\""- show (VI i) = show i- show (VF f) = show f ++ "f"- show (VN n) = show n- show (VR r) = prettyRat r ++ "r"- show (VB b) = show b- show (VX xs) = show xs- show (VPattern pat) = "(" ++ show pat ++ ")"- show (VState f) = show $ f Map.empty- show (VList vs) = show $ map show vs--instance {-# OVERLAPPING #-} Show ValueMap where- show m = intercalate ", " $ map (\(name, v) -> name ++ ": " ++ show v) $ Map.toList m--instance {-# OVERLAPPING #-} Show Arc where- show (Arc s e) = prettyRat s ++ ">" ++ prettyRat e--instance {-# OVERLAPPING #-} Show a => Show (Event a) where- show e = uncurry (++) (showEvent e)--prettyRat :: Rational -> String-prettyRat r | unit == 0 && frac > 0 = showFrac (numerator frac) (denominator frac)- | otherwise = show unit ++ showFrac (numerator frac) (denominator frac)- where unit = floor r :: Int- frac = r - toRational unit--showFrac :: Integer -> Integer -> String-showFrac 0 _ = ""-showFrac 1 2 = "½"-showFrac 1 3 = "⅓"-showFrac 2 3 = "⅔"-showFrac 1 4 = "¼"-showFrac 3 4 = "¾"-showFrac 1 5 = "⅕"-showFrac 2 5 = "⅖"-showFrac 3 5 = "⅗"-showFrac 4 5 = "⅘"-showFrac 1 6 = "⅙"-showFrac 5 6 = "⅚"-showFrac 1 7 = "⅐"-showFrac 1 8 = "⅛"-showFrac 3 8 = "⅜"-showFrac 5 8 = "⅝"-showFrac 7 8 = "⅞"-showFrac 1 9 = "⅑"-showFrac 1 10 = "⅒"--showFrac n d = fromMaybe plain $ do n' <- up n- d' <- down d- return $ n' ++ d'- where plain = show n ++ "/" ++ show d- up 1 = Just "¹"- up 2 = Just "²"- up 3 = Just "³"- up 4 = Just "⁴"- up 5 = Just "⁵"- up 6 = Just "⁶"- up 7 = Just "⁷"- up 8 = Just "⁸"- up 9 = Just "⁹"- up 0 = Just "⁰"- up _ = Nothing- down 1 = Just "₁"- down 2 = Just "₂"- down 3 = Just "₃"- down 4 = Just "₄"- down 5 = Just "₅"- down 6 = Just "₆"- down 7 = Just "₇"- down 8 = Just "₈"- down 9 = Just "₉"- down 0 = Just "₀"- down _ = Nothing--stepcount :: Pattern a -> Int-stepcount pat = fromIntegral $ eventSteps $ concatMap ((\ev -> [start ev, stop ev]) . part) (filter eventHasOnset $ queryArc pat (Arc 0 1))- where eventSteps xs = foldr (lcm . denominator) 1 xs--data Render = Render Int Int String--instance Show Render where- show (Render cyc i render) | i <= 1024 = "\n[" ++ show cyc ++ (if cyc == 1 then " cycle" else " cycles") ++ "]\n" ++ render- | otherwise = "That pattern is too complex to draw."---drawLine :: Pattern Char -> Render-drawLine = drawLineSz 78--drawLineSz :: Int -> Pattern Char -> Render-drawLineSz sz pat = joinCycles sz $ drawCycles pat- where- drawCycles :: Pattern Char -> [Render]- drawCycles pat' = draw pat':drawCycles (rotL 1 pat')- joinCycles :: Int -> [Render] -> Render- joinCycles _ [] = Render 0 0 ""- joinCycles n ((Render cyc l s):cs) | l > n = Render 0 0 ""- | otherwise = Render (cyc+cyc') (l + l' + 1) $ intercalate "\n" $ map (uncurry (++)) lineZip- where- (Render cyc' l' s') = joinCycles (n-l-1) cs- linesN = max (length $ lines s) (length $ lines s')- lineZip = take linesN $- zip (lines s ++ repeat (replicate l ' '))- (lines s' ++ repeat (replicate l' ' '))-- -- where maximum (map (length . head . (++ [""]) . lines) cs)---draw :: Pattern Char -> Render-draw pat = Render 1 s (intercalate "\n" $ map (('|' :) .drawLevel) ls)- where ls = levels pat- s = stepcount pat- rs = toRational s- drawLevel :: [Event Char] -> String- drawLevel [] = replicate s '.'- drawLevel (e:es) = map f $ take s $ zip (drawLevel es ++ repeat '.') (drawEvent e ++ repeat '.')- f ('.', x) = x- f (x, _) = x- drawEvent :: Event Char -> String- drawEvent ev = replicate (floor $ rs * evStart) '.'- ++ (value ev:replicate (floor (rs * (evStop - evStart)) - 1) '-')- where evStart = start $ wholeOrPart ev- evStop = stop $ wholeOrPart ev--{--fitsWhole :: Event b -> [Event b] -> Bool-fitsWhole event events =- not $ any (\event' -> isJust $ subArc (wholeOrPart event) (wholeOrPart event')) events--addEventWhole :: Event b -> [[Event b]] -> [[Event b]]-addEventWhole e [] = [[e]]-addEventWhole e (level:ls)- | isAnalog e = level:ls- | fitsWhole e level = (e:level) : ls- | otherwise = level : addEventWhole e ls--arrangeEventsWhole :: [Event b] -> [[Event b]]-arrangeEventsWhole = foldr addEventWhole []--levelsWhole :: Eq a => Pattern a -> [[Event a]]-levelsWhole pat = arrangeEventsWhole $ sortOn' ((\Arc{..} -> 0 - (stop - start)) . wholeOrPart) (defragParts $ queryArc pat (Arc 0 1))--sortOn' :: Ord a => (b -> a) -> [b] -> [b]-sortOn' f = map snd . sortOn fst . map (\x -> let y = f x in y `seq` (y, x))--}--fits :: Event b -> [Event b] -> Bool-fits (Event _ _ part' _) events = not $ any (\Event{..} -> isJust $ subArc part' part) events--addEvent :: Event b -> [[Event b]] -> [[Event b]]-addEvent e [] = [[e]]-addEvent e (level:ls)- | fits e level = (e:level) : ls- | otherwise = level : addEvent e ls--arrangeEvents :: [Event b] -> [[Event b]]-arrangeEvents = foldr addEvent []--levels :: Eq a => Pattern a -> [[Event a]]--- levels pat = arrangeEvents $ sortOn' ((\Arc{..} -> stop - start) . part) (defragParts $ queryArc pat (Arc 0 1))-levels pat = arrangeEvents $ reverse $ defragParts $ queryArc pat (Arc 0 1)
− src/Sound/Tidal/Simple.hs
@@ -1,68 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--{-- Simple.hs - Things for making Tidal extra-simple to use, originally made for 8 year olds.- Copyright (C) 2020, Alex McLean and contributors-- This library is free software: you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this library. If not, see <http://www.gnu.org/licenses/>.--}--module Sound.Tidal.Simple where--import Sound.Tidal.Control (chop, hurry)-import Sound.Tidal.Core ((#), (|*), (<~))-import Sound.Tidal.Params (crush, gain, pan, speed, s)-import Sound.Tidal.ParseBP (parseBP_E)-import Sound.Tidal.Pattern (ControlPattern, silence, rev)-import GHC.Exts ( IsString(..) )--instance {-# OVERLAPPING #-} IsString ControlPattern where- fromString = s . parseBP_E--crunch :: ControlPattern -> ControlPattern-crunch = (# crush 3)--scratch :: ControlPattern -> ControlPattern-scratch = rev . chop 32--louder :: ControlPattern -> ControlPattern-louder = (|* gain 1.2)--quieter :: ControlPattern -> ControlPattern-quieter = (|* gain 0.8)--silent :: ControlPattern -> ControlPattern-silent = const silence--skip :: ControlPattern -> ControlPattern-skip = (0.25 <~)--left :: ControlPattern -> ControlPattern-left = (# pan 0)--right :: ControlPattern -> ControlPattern-right = (# pan 1)--higher :: ControlPattern -> ControlPattern-higher = (|* speed 1.5)--lower :: ControlPattern -> ControlPattern-lower = (|* speed 0.75)--faster :: ControlPattern -> ControlPattern-faster = hurry 2--slower :: ControlPattern -> ControlPattern-slower = hurry 0.5
src/Sound/Tidal/Stream.hs view
@@ -1,11 +1,24 @@-{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}-{-# language DeriveGeneric, StandaloneDeriving #-}+module Sound.Tidal.Stream+ ( module Sound.Tidal.Config,+ module Sound.Tidal.Stream.Types,+ module Sound.Tidal.Stream.Process,+ module Sound.Tidal.Stream.Target,+ module Sound.Tidal.Stream.UI,+ module Sound.Tidal.Stream.Listen,+ module Sound.Tidal.Stream.Main,+ )+where -module Sound.Tidal.Stream (module Sound.Tidal.Stream) where+import Sound.Tidal.Config+import Sound.Tidal.Stream.Listen+import Sound.Tidal.Stream.Main+import Sound.Tidal.Stream.Process+import Sound.Tidal.Stream.Target+import Sound.Tidal.Stream.Types+import Sound.Tidal.Stream.UI {-- Stream.hs - Tidal's thingie for turning patterns into OSC streams+ Stream.hs - re-exports of all stream modules Copyright (C) 2020, Alex McLean and contributors This library is free software: you can redistribute it and/or modify@@ -21,747 +34,3 @@ You should have received a copy of the GNU General Public License along with this library. If not, see <http://www.gnu.org/licenses/>. -}--import Control.Applicative ((<|>))-import Control.Concurrent.MVar-import Control.Concurrent-import Control.Monad (forM_, when)-import Data.Coerce (coerce)-import qualified Data.Map.Strict as Map-import Data.Maybe (fromJust, fromMaybe, catMaybes, isJust)-import qualified Control.Exception as E-import Foreign-import Foreign.C.Types-import System.IO (hPutStrLn, stderr)--import qualified Sound.Osc.Fd as O-import qualified Sound.Osc.Time.Timeout as O-import qualified Network.Socket as N--import Sound.Tidal.Config-import Sound.Tidal.Core (stack, (#))-import Sound.Tidal.ID-import qualified Sound.Tidal.Link as Link-import Sound.Tidal.Params (pS)-import Sound.Tidal.Pattern-import qualified Sound.Tidal.Tempo as T-import Sound.Tidal.Utils ((!!!))-import Data.List (sortOn)-import System.Random (getStdRandom, randomR)-import Sound.Tidal.Show ()--import Sound.Tidal.Version--import Sound.Tidal.StreamTypes as Sound.Tidal.Stream--data Stream = Stream {sConfig :: Config,- sBusses :: MVar [Int],- sStateMV :: MVar ValueMap,- -- sOutput :: MVar ControlPattern,- sLink :: Link.AbletonLink,- sListen :: Maybe O.Udp,- sPMapMV :: MVar PlayMap,- sActionsMV :: MVar [T.TempoAction],- sGlobalFMV :: MVar (ControlPattern -> ControlPattern),- sCxs :: [Cx]- }--data Cx = Cx {cxTarget :: Target,- cxUDP :: O.Udp,- cxOSCs :: [OSC],- cxAddr :: N.AddrInfo,- cxBusAddr :: Maybe N.AddrInfo- }- deriving (Show)--data StampStyle = BundleStamp- | MessageStamp- deriving (Eq, Show)--data Schedule = Pre StampStyle- | Live- deriving (Eq, Show)--data Target = Target {oName :: String,- oAddress :: String,- oPort :: Int,- oBusPort :: Maybe Int,- oLatency :: Double,- oWindow :: Maybe Arc,- oSchedule :: Schedule,- oHandshake :: Bool- }- deriving Show--data Args = Named {requiredArgs :: [String]}- | ArgList [(String, Maybe Value)]- deriving Show--data OSC = OSC {path :: String,- args :: Args- }- | OSCContext {path :: String}- deriving Show--data ProcessedEvent =- ProcessedEvent {- peHasOnset :: Bool,- peEvent :: Event ValueMap,- peCps :: Link.BPM,- peDelta :: Link.Micros,- peCycle :: Time,- peOnWholeOrPart :: Link.Micros,- peOnWholeOrPartOsc :: O.Time,- peOnPart :: Link.Micros,- peOnPartOsc :: O.Time- }--sDefault :: String -> Maybe Value-sDefault x = Just $ VS x-fDefault :: Double -> Maybe Value-fDefault x = Just $ VF x-rDefault :: Rational -> Maybe Value-rDefault x = Just $ VR x-iDefault :: Int -> Maybe Value-iDefault x = Just $ VI x-bDefault :: Bool -> Maybe Value-bDefault x = Just $ VB x-xDefault :: [Word8] -> Maybe Value-xDefault x = Just $ VX x--required :: Maybe Value-required = Nothing--superdirtTarget :: Target-superdirtTarget = Target {oName = "SuperDirt",- oAddress = "127.0.0.1",- oPort = 57120,- oBusPort = Just 57110,- oLatency = 0.2,- oWindow = Nothing,- oSchedule = Pre BundleStamp,- oHandshake = True- }--superdirtShape :: OSC-superdirtShape = OSC "/dirt/play" $ Named {requiredArgs = ["s"]}--dirtTarget :: Target-dirtTarget = Target {oName = "Dirt",- oAddress = "127.0.0.1",- oPort = 7771,- oBusPort = Nothing,- oLatency = 0.02,- oWindow = Nothing,- oSchedule = Pre MessageStamp,- oHandshake = False- }--dirtShape :: OSC-dirtShape = OSC "/play" $ ArgList [("cps", fDefault 0),- ("s", required),- ("offset", fDefault 0),- ("begin", fDefault 0),- ("end", fDefault 1),- ("speed", fDefault 1),- ("pan", fDefault 0.5),- ("velocity", fDefault 0.5),- ("vowel", sDefault ""),- ("cutoff", fDefault 0),- ("resonance", fDefault 0),- ("accelerate", fDefault 0),- ("shape", fDefault 0),- ("kriole", iDefault 0),- ("gain", fDefault 1),- ("cut", iDefault 0),- ("delay", fDefault 0),- ("delaytime", fDefault (-1)),- ("delayfeedback", fDefault (-1)),- ("crush", fDefault 0),- ("coarse", iDefault 0),- ("hcutoff", fDefault 0),- ("hresonance", fDefault 0),- ("bandf", fDefault 0),- ("bandq", fDefault 0),- ("unit", sDefault "rate"),- ("loop", fDefault 0),- ("n", fDefault 0),- ("attack", fDefault (-1)),- ("hold", fDefault 0),- ("release", fDefault (-1)),- ("orbit", iDefault 0) -- ,- -- ("id", iDefault 0)- ]--defaultCps :: O.Time-defaultCps = 0.5625---- Start an instance of Tidal--- Spawns a thread within Tempo that acts as the clock--- Spawns a thread that listens to and acts on OSC control messages-startStream :: Config -> [(Target, [OSC])] -> IO Stream-startStream config oscmap- = do sMapMV <- newMVar Map.empty- pMapMV <- newMVar Map.empty- bussesMV <- newMVar []- globalFMV <- newMVar id- actionsMV <- newEmptyMVar-- tidal_status_string >>= verbose config- verbose config $ "Listening for external controls on " ++ cCtrlAddr config ++ ":" ++ show (cCtrlPort config)- listen <- openListener config-- cxs <- mapM (\(target, os) -> do remote_addr <- resolve (oAddress target) (show $ oPort target)- remote_bus_addr <- if isJust $ oBusPort target- then Just <$> resolve (oAddress target) (show $ fromJust $ oBusPort target)- else return Nothing- let broadcast = if cCtrlBroadcast config then 1 else 0- u <- O.udp_socket (\sock sockaddr -> do N.setSocketOption sock N.Broadcast broadcast- N.connect sock sockaddr- ) (oAddress target) (oPort target)- return $ Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxTarget = target, cxOSCs = os}- ) oscmap- let bpm = (coerce defaultCps) * 60 * (cBeatsPerCycle config)- abletonLink <- Link.create bpm- let stream = Stream {sConfig = config,- sBusses = bussesMV,- sStateMV = sMapMV,- sLink = abletonLink,- sListen = listen,- sPMapMV = pMapMV,- sActionsMV = actionsMV,- sGlobalFMV = globalFMV,- sCxs = cxs- }- sendHandshakes stream- let ac = T.ActionHandler {- T.onTick = onTick stream,- T.onSingleTick = onSingleTick stream,- T.updatePattern = updatePattern stream- }- -- Spawn a thread that acts as the clock- _ <- T.clocked config sMapMV pMapMV actionsMV ac abletonLink- -- Spawn a thread to handle OSC control messages- _ <- forkIO $ ctrlResponder 0 config stream- return stream---- It only really works to handshake with one target at the moment..-sendHandshakes :: Stream -> IO ()-sendHandshakes stream = mapM_ sendHandshake $ filter (oHandshake . cxTarget) (sCxs stream)- where sendHandshake cx = if (isJust $ sListen stream)- then- do -- send it _from_ the udp socket we're listening to, so the- -- replies go back there- sendO False (sListen stream) cx $ O.Message "/dirt/handshake" []- else- hPutStrLn stderr "Can't handshake with SuperCollider without control port."--sendO :: Bool -> (Maybe O.Udp) -> Cx -> O.Message -> IO ()-sendO isBusMsg (Just listen) cx msg = O.sendTo listen (O.Packet_Message msg) (N.addrAddress addr)- where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx- | otherwise = cxAddr cx-sendO _ Nothing cx msg = O.sendMessage (cxUDP cx) msg--sendBndl :: Bool -> (Maybe O.Udp) -> Cx -> O.Bundle -> IO ()-sendBndl isBusMsg (Just listen) cx bndl = O.sendTo listen (O.Packet_Bundle bndl) (N.addrAddress addr)- where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx- | otherwise = cxAddr cx-sendBndl _ Nothing cx bndl = O.sendBundle (cxUDP cx) bndl--resolve :: String -> String -> IO N.AddrInfo-resolve host port = do let hints = N.defaultHints { N.addrSocketType = N.Stream }- addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just port)- return addr---- Start an instance of Tidal with superdirt OSC-startTidal :: Target -> Config -> IO Stream-startTidal target config = startStream config [(target, [superdirtShape])]--startMulti :: [Target] -> Config -> IO ()-startMulti _ _ = hPutStrLn stderr $ "startMulti has been removed, please check the latest documentation on tidalcycles.org"--toDatum :: Value -> O.Datum-toDatum (VF x) = O.float x-toDatum (VN x) = O.float x-toDatum (VI x) = O.int32 x-toDatum (VS x) = O.string x-toDatum (VR x) = O.float $ ((fromRational x) :: Double)-toDatum (VB True) = O.int32 (1 :: Int)-toDatum (VB False) = O.int32 (0 :: Int)-toDatum (VX xs) = O.Blob $ O.blob_pack xs-toDatum _ = error "toDatum: unhandled value"--toData :: OSC -> Event ValueMap -> Maybe [O.Datum]-toData (OSC {args = ArgList as}) e = fmap (fmap (toDatum)) $ sequence $ map (\(n,v) -> Map.lookup n (value e) <|> v) as-toData (OSC {args = Named rqrd}) e- | hasRequired rqrd = Just $ concatMap (\(n,v) -> [O.string n, toDatum v]) $ Map.toList $ value e- | otherwise = Nothing- where hasRequired [] = True- hasRequired xs = null $ filter (not . (`elem` ks)) xs- ks = Map.keys (value e)-toData _ _ = Nothing--substitutePath :: String -> ValueMap -> Maybe String-substitutePath str cm = parse str- where parse [] = Just []- parse ('{':xs) = parseWord xs- parse (x:xs) = do xs' <- parse xs- return (x:xs')- parseWord xs | b == [] = getString cm a- | otherwise = do v <- getString cm a- xs' <- parse (tail b)- return $ v ++ xs'- where (a,b) = break (== '}') xs--getString :: ValueMap -> String -> Maybe String-getString cm s = (simpleShow <$> Map.lookup param cm) <|> defaultValue dflt- where (param, dflt) = break (== '=') s- simpleShow :: Value -> String- simpleShow (VS str) = str- simpleShow (VI i) = show i- simpleShow (VF f) = show f- simpleShow (VN n) = show n- simpleShow (VR r) = show r- simpleShow (VB b) = show b- simpleShow (VX xs) = show xs- simpleShow (VState _) = show "<stateful>"- simpleShow (VPattern _) = show "<pattern>"- simpleShow (VList _) = show "<list>"- defaultValue :: String -> Maybe String- defaultValue ('=':dfltVal) = Just dfltVal- defaultValue _ = Nothing--playStack :: PlayMap -> ControlPattern-playStack pMap = stack . (map pattern) . (filter active) . Map.elems $ pMap- where active pState = if hasSolo pMap- then solo pState- else not (mute pState)--toOSC :: [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)]-toOSC busses pe osc@(OSC _ _)- = catMaybes (playmsg:busmsgs)- -- playmap is a ValueMap where the keys don't start with ^ and are not ""- -- busmap is a ValueMap containing the rest of the keys from the event value- -- The partition is performed in order to have special handling of bus ids.- where- (playmap, busmap) = Map.partitionWithKey (\k _ -> null k || head k /= '^') $ val pe- -- Map in bus ids where needed.- --- -- Bus ids are integers- -- If busses is empty, the ids to send are directly contained in the the values of the busmap.- -- Otherwise, the ids to send are contained in busses at the indices of the values of the busmap.- -- Both cases require that the values of the busmap are only ever integers,- -- that is, they are Values with constructor VI- -- (but perhaps we should explicitly crash with an error message if it contains something else?).- -- Map.mapKeys tail is used to remove ^ from the keys.- -- In case (value e) has the key "", we will get a crash here.- playmap' = Map.union (Map.mapKeys tail $ Map.map (\(VI i) -> VS ('c':(show $ toBus i))) busmap) playmap- val = value . peEvent- -- Only events that start within the current nowArc are included- playmsg | peHasOnset pe = do- -- If there is already cps in the event, the union will preserve that.- let extra = Map.fromList [("cps", (VF (coerce $! peCps pe))),- ("delta", VF (T.addMicrosToOsc (peDelta pe) 0)),- ("cycle", VF (fromRational (peCycle pe)))- ]- addExtra = Map.union playmap' extra- ts = (peOnWholeOrPartOsc pe) + nudge -- + latency- vs <- toData osc ((peEvent pe) {value = addExtra})- mungedPath <- substitutePath (path osc) playmap'- return (ts,- False, -- bus message ?- O.Message mungedPath vs- )- | otherwise = Nothing- toBus n | null busses = n- | otherwise = busses !!! n- busmsgs = map- (\(('^':k), (VI b)) -> do v <- Map.lookup k playmap- return $ (tsPart,- True, -- bus message ?- O.Message "/c_set" [O.int32 b, toDatum v]- )- )- (Map.toList busmap)- where- tsPart = (peOnPartOsc pe) + nudge -- + latency- nudge = fromJust $ getF $ fromMaybe (VF 0) $ Map.lookup "nudge" $ playmap-toOSC _ pe (OSCContext oscpath)- = map cToM $ contextPosition $ context $ peEvent pe- where cToM :: ((Int,Int),(Int,Int)) -> (Double, Bool, O.Message)- cToM ((x, y), (x',y')) = (ts,- False, -- bus message ?- O.Message oscpath $ (O.string ident):(O.float (peDelta pe)):(O.float cyc):(map O.int32 [x,y,x',y'])- )- cyc :: Double- cyc = fromRational $ peCycle pe- nudge = fromMaybe 0 $ Map.lookup "nudge" (value $ peEvent pe) >>= getF- ident = fromMaybe "unknown" $ Map.lookup "_id_" (value $ peEvent pe) >>= getS- ts = (peOnWholeOrPartOsc pe) + nudge -- + latency----- Used for Tempo callback-updatePattern :: Stream -> ID -> Time -> ControlPattern -> IO ()-updatePattern stream k !t pat = do- let x = queryArc pat (Arc 0 0)- pMap <- seq x $ takeMVar (sPMapMV stream)- let playState = updatePS $ Map.lookup (fromID k) pMap- putMVar (sPMapMV stream) $ Map.insert (fromID k) playState pMap- where updatePS (Just playState) = do playState {pattern = pat', history = pat:(history playState)}- updatePS Nothing = PlayState pat' False False [pat']- patControls = Map.singleton patternTimeID (VR t)- pat' = withQueryControls (Map.union patControls)- $ pat # pS "_id_" (pure $ fromID k)--processCps :: T.LinkOperations -> [Event ValueMap] -> IO [ProcessedEvent]-processCps ops = mapM processEvent- where- processEvent :: Event ValueMap -> IO ProcessedEvent- processEvent e = do- let wope = wholeOrPart e- partStartCycle = start $ part e- partStartBeat = (T.cyclesToBeat ops) (realToFrac partStartCycle)- onCycle = start wope- onBeat = (T.cyclesToBeat ops) (realToFrac onCycle)- offCycle = stop wope- offBeat = (T.cyclesToBeat ops) (realToFrac offCycle)- on <- (T.timeAtBeat ops) onBeat- onPart <- (T.timeAtBeat ops) partStartBeat- when (eventHasOnset e) (do- let cps' = Map.lookup "cps" (value e) >>= getF- maybe (return ()) (\newCps -> (T.setTempo ops) ((T.cyclesToBeat ops) (newCps * 60)) on) $ coerce cps'- )- off <- (T.timeAtBeat ops) offBeat- bpm <- (T.getTempo ops)- let cps = ((T.beatToCycles ops) bpm) / 60- let delta = off - on- return $! ProcessedEvent {- peHasOnset = eventHasOnset e,- peEvent = e,- peCps = cps,- peDelta = delta,- peCycle = onCycle,- peOnWholeOrPart = on,- peOnWholeOrPartOsc = (T.linkToOscTime ops) on,- peOnPart = onPart,- peOnPartOsc = (T.linkToOscTime ops) onPart- }----- streamFirst but with random cycle instead of always first cicle-streamOnce :: Stream -> ControlPattern -> IO ()-streamOnce st p = do i <- getStdRandom $ randomR (0, 8192)- streamFirst st $ rotL (toRational (i :: Int)) p---- here let's do modifyMVar_ on actions-streamFirst :: Stream -> ControlPattern -> IO ()-streamFirst stream pat = modifyMVar_ (sActionsMV stream) (\actions -> return $ (T.SingleTick pat) : actions)---- Used for Tempo callback-onTick :: Stream -> TickState -> T.LinkOperations -> ValueMap -> IO ValueMap-onTick stream st ops s- = doTick stream st ops s---- Used for Tempo callback--- Tempo changes will be applied.--- However, since the full arc is processed at once and since Link does not support--- scheduling, tempo change may affect scheduling of events that happen earlier--- in the normal stream (the one handled by onTick).-onSingleTick :: Stream -> T.LinkOperations -> ValueMap -> ControlPattern -> IO ValueMap-onSingleTick stream ops s pat = do- pMapMV <- newMVar $ Map.singleton "fake"- (PlayState {pattern = pat,- mute = False,- solo = False,- history = []- }- )-- -- The nowArc is a full cycle- let state = TickState {tickArc = (Arc 0 1), tickNudge = 0}- doTick (stream {sPMapMV = pMapMV}) state ops s----- | Query the current pattern (contained in argument @stream :: Stream@)--- for the events in the current arc (contained in argument @st :: T.State@),--- translate them to OSC messages, and send these.------ If an exception occurs during sending,--- this functions prints a warning and continues, because--- the likely reason is that the backend (supercollider) isn't running.------ If any exception occurs before or outside sending--- (e.g., while querying the pattern, while computing a message),--- this function prints a warning and resets the current pattern--- to the previous one (or to silence if there isn't one) and continues,--- because the likely reason is that something is wrong with the current pattern.-doTick :: Stream -> TickState -> T.LinkOperations -> ValueMap -> IO ValueMap-doTick stream st ops sMap =- E.handle (\ (e :: E.SomeException) -> do- hPutStrLn stderr $ "Failed to Stream.doTick: " ++ show e- hPutStrLn stderr $ "Return to previous pattern."- setPreviousPatternOrSilence stream- return sMap) (do- pMap <- readMVar (sPMapMV stream)- busses <- readMVar (sBusses stream)- sGlobalF <- readMVar (sGlobalFMV stream)- bpm <- (T.getTempo ops)- let- cxs = sCxs stream- patstack = sGlobalF $ playStack pMap- cps = ((T.beatToCycles ops) bpm) / 60- sMap' = Map.insert "_cps" (VF $ coerce cps) sMap- extraLatency = tickNudge st- -- First the state is used to query the pattern- es = sortOn (start . part) $ query patstack (State {arc = tickArc st,- controls = sMap'- }- )- -- Then it's passed through the events- (sMap'', es') = resolveState sMap' es- tes <- processCps ops es'- -- For each OSC target- forM_ cxs $ \cx@(Cx target _ oscs _ _) -> do- -- Latency is configurable per target.- -- Latency is only used when sending events live.- let latency = oLatency target- ms = concatMap (\e -> concatMap (toOSC busses e) oscs) tes- -- send the events to the OSC target- forM_ ms $ \ m -> (do- send (sListen stream) cx latency extraLatency m) `E.catch` \ (e :: E.SomeException) -> do- hPutStrLn stderr $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e- sMap'' `seq` return sMap'')--setPreviousPatternOrSilence :: Stream -> IO ()-setPreviousPatternOrSilence stream =- modifyMVar_ (sPMapMV stream) $ return- . Map.map ( \ pMap -> case history pMap of- _:p:ps -> pMap { pattern = p, history = p:ps }- _ -> pMap { pattern = silence, history = [silence] }- )---- send has three modes:--- Send events early using timestamp in the OSC bundle - used by Superdirt--- Send events early by adding timestamp to the OSC message - used by Dirt--- Send events live by delaying the thread-send :: Maybe O.Udp -> Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO ()-send listen cx latency extraLatency (time, isBusMsg, m)- | oSchedule target == Pre BundleStamp = sendBndl isBusMsg listen cx $ O.Bundle timeWithLatency [m]- | oSchedule target == Pre MessageStamp = sendO isBusMsg listen cx $ addtime m- | otherwise = do _ <- forkOS $ do now <- O.time- threadDelay $ floor $ (timeWithLatency - now) * 1000000- sendO isBusMsg listen cx m- return ()- where addtime (O.Message mpath params) = O.Message mpath ((O.int32 sec):((O.int32 usec):params))- ut = O.ntpr_to_posix timeWithLatency- sec :: Int- sec = floor ut- usec :: Int- usec = floor $ 1000000 * (ut - (fromIntegral sec))- target = cxTarget cx- timeWithLatency = time - latency + extraLatency---- Interaction--streamNudgeAll :: Stream -> Double -> IO ()-streamNudgeAll s nudge = T.setNudge (sActionsMV s) nudge--streamResetCycles :: Stream -> IO ()-streamResetCycles s = streamSetCycle s 0--streamSetCycle :: Stream -> Time -> IO ()-streamSetCycle s cyc = T.setCycle cyc (sActionsMV s)--hasSolo :: Map.Map k PlayState -> Bool-hasSolo = (>= 1) . length . filter solo . Map.elems--streamList :: Stream -> IO ()-streamList s = do pMap <- readMVar (sPMapMV s)- let hs = hasSolo pMap- putStrLn $ concatMap (showKV hs) $ Map.toList pMap- where showKV :: Bool -> (PatId, PlayState) -> String- showKV True (k, (PlayState {solo = True})) = k ++ " - solo\n"- showKV True (k, _) = "(" ++ k ++ ")\n"- showKV False (k, (PlayState {solo = False})) = k ++ "\n"- showKV False (k, _) = "(" ++ k ++ ") - muted\n"---- Evaluation of pat is forced so exceptions are picked up here, before replacing the existing pattern.--streamReplace :: Stream -> ID -> ControlPattern -> IO ()-streamReplace s k !pat- = modifyMVar_ (sActionsMV s) (\actions -> return $ (T.StreamReplace k pat) : actions)--streamMute :: Stream -> ID -> IO ()-streamMute s k = withPatIds s [k] (\x -> x {mute = True})--streamMutes :: Stream -> [ID] -> IO ()-streamMutes s ks = withPatIds s ks (\x -> x {mute = True})--streamUnmute :: Stream -> ID -> IO ()-streamUnmute s k = withPatIds s [k] (\x -> x {mute = False})--streamSolo :: Stream -> ID -> IO ()-streamSolo s k = withPatIds s [k] (\x -> x {solo = True})--streamUnsolo :: Stream -> ID -> IO ()-streamUnsolo s k = withPatIds s [k] (\x -> x {solo = False})--withPatIds :: Stream -> [ID] -> (PlayState -> PlayState) -> IO ()-withPatIds s ks f- = do playMap <- takeMVar $ sPMapMV s- let pMap' = foldr (Map.update (\x -> Just $ f x)) playMap (map fromID ks)- putMVar (sPMapMV s) pMap'- return ()---- TODO - is there a race condition here?-streamMuteAll :: Stream -> IO ()-streamMuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = True})--streamHush :: Stream -> IO ()-streamHush s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {pattern = silence, history = silence:history x})--streamUnmuteAll :: Stream -> IO ()-streamUnmuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = False})--streamUnsoloAll :: Stream -> IO ()-streamUnsoloAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {solo = False})--streamSilence :: Stream -> ID -> IO ()-streamSilence s k = withPatIds s [k] (\x -> x {pattern = silence, history = silence:history x})--streamAll :: Stream -> (ControlPattern -> ControlPattern) -> IO ()-streamAll s f = do _ <- swapMVar (sGlobalFMV s) f- return ()--streamGet :: Stream -> String -> IO (Maybe Value)-streamGet s k = Map.lookup k <$> readMVar (sStateMV s)--streamSet :: Valuable a => Stream -> String -> Pattern a -> IO ()-streamSet s k pat = do sMap <- takeMVar $ sStateMV s- let pat' = toValue <$> pat- sMap' = Map.insert k (VPattern pat') sMap- putMVar (sStateMV s) $ sMap'--streamSetI :: Stream -> String -> Pattern Int -> IO ()-streamSetI = streamSet--streamSetF :: Stream -> String -> Pattern Double -> IO ()-streamSetF = streamSet--streamSetS :: Stream -> String -> Pattern String -> IO ()-streamSetS = streamSet--streamSetB :: Stream -> String -> Pattern Bool -> IO ()-streamSetB = streamSet--streamSetR :: Stream -> String -> Pattern Rational -> IO ()-streamSetR = streamSet--openListener :: Config -> IO (Maybe O.Udp)-openListener c- | cCtrlListen c = catchAny run (\_ -> do verbose c "That port isn't available, perhaps another Tidal instance is already listening on that port?"- return Nothing- )- | otherwise = return Nothing- where- run = do sock <- O.udpServer (cCtrlAddr c) (cCtrlPort c)- when (cCtrlBroadcast c) $ N.setSocketOption (O.udpSocket sock) N.Broadcast 1- return $ Just sock- catchAny :: IO a -> (E.SomeException -> IO a) -> IO a- catchAny = E.catch---- Listen to and act on OSC control messages-ctrlResponder :: Int -> Config -> Stream -> IO ()-ctrlResponder waits c (stream@(Stream {sListen = Just sock}))- = do ms <- recvMessagesTimeout 2 sock- if (null ms)- then do checkHandshake -- there was a timeout, check handshake- ctrlResponder (waits+1) c stream- else do mapM_ act ms- ctrlResponder 0 c stream- where- checkHandshake = do busses <- readMVar (sBusses stream)- when (null busses) $ do when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).."- sendHandshakes stream-- act (O.Message "/dirt/hello" _) = sendHandshakes stream- act (O.Message "/dirt/handshake/reply" xs) = do prev <- swapMVar (sBusses stream) $ bufferIndices xs- -- Only report the first time..- when (null prev) $ verbose c $ "Connected to SuperDirt."- return ()- where- bufferIndices [] = []- bufferIndices (x:xs') | x == (O.AsciiString $ O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs'- | otherwise = bufferIndices xs'- -- External controller commands- act (O.Message "/ctrl" (O.Int32 k:v:[]))- = act (O.Message "/ctrl" [O.string $ show k,v])- act (O.Message "/ctrl" (O.AsciiString k:v@(O.Float _):[]))- = add (O.ascii_to_string k) (VF (fromJust $ O.datum_floating v))- act (O.Message "/ctrl" (O.AsciiString k:O.AsciiString v:[]))- = add (O.ascii_to_string k) (VS (O.ascii_to_string v))- act (O.Message "/ctrl" (O.AsciiString k:O.Int32 v:[]))- = add (O.ascii_to_string k) (VI (fromIntegral v))- -- Stream playback commands- act (O.Message "/mute" (k:[]))- = withID k $ streamMute stream- act (O.Message "/unmute" (k:[]))- = withID k $ streamUnmute stream- act (O.Message "/solo" (k:[]))- = withID k $ streamSolo stream- act (O.Message "/unsolo" (k:[]))- = withID k $ streamUnsolo stream- act (O.Message "/muteAll" [])- = streamMuteAll stream- act (O.Message "/unmuteAll" [])- = streamUnmuteAll stream- act (O.Message "/unsoloAll" [])- = streamUnsoloAll stream- act (O.Message "/hush" [])- = streamHush stream- act (O.Message "/silence" (k:[]))- = withID k $ streamSilence stream- act m = hPutStrLn stderr $ "Unhandled OSC: " ++ show m- add :: String -> Value -> IO ()- add k v = do sMap <- takeMVar (sStateMV stream)- putMVar (sStateMV stream) $ Map.insert k v sMap- return ()- withID :: O.Datum -> (ID -> IO ()) -> IO ()- withID (O.AsciiString k) func = func $ (ID . O.ascii_to_string) k- withID (O.Int32 k) func = func $ (ID . show) k- withID _ _ = return ()-ctrlResponder _ _ _ = return ()--verbose :: Config -> String -> IO ()-verbose c s = when (cVerbose c) $ putStrLn s--recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message]-recvMessagesTimeout n sock = fmap (maybe [] O.packetMessages) $ O.recvPacketTimeout n sock--streamGetcps :: Stream -> IO Double-streamGetcps s = do- let config = sConfig s- ss <- Link.createAndCaptureAppSessionState (sLink s)- bpm <- Link.getTempo ss- Link.destroySessionState ss- return $! coerce $ bpm / (cBeatsPerCycle config) / 60--streamGetnow :: Stream -> IO Double-streamGetnow s = do- let config = sConfig s- ss <- Link.createAndCaptureAppSessionState (sLink s)- now <- Link.clock (sLink s)- beat <- Link.beatAtTime ss now (cQuantum config)- Link.destroySessionState ss- return $! coerce $ beat / (cBeatsPerCycle config)--getProcessAhead :: Stream -> Link.Micros-getProcessAhead str = round $ (cProcessAhead $ sConfig str) * 100000--streamGetAhead :: Stream -> IO Double-streamGetAhead str = do- ss <- Link.createAndCaptureAppSessionState (sLink str)- now <- Link.clock (sLink str)- beat <- Link.beatAtTime ss (now + (getProcessAhead str)) (cQuantum $! sConfig str)- Link.destroySessionState ss- return $ coerce $! beat / (cBeatsPerCycle $! sConfig str)
+ src/Sound/Tidal/Stream/Listen.hs view
@@ -0,0 +1,113 @@+module Sound.Tidal.Stream.Listen where++import Control.Concurrent.MVar+import qualified Control.Exception as E+import Control.Monad (when)+import qualified Data.Map as Map+import Data.Maybe (fromJust)+import qualified Network.Socket as N+import qualified Sound.Osc.Fd as O+import qualified Sound.Osc.Transport.Fd.Udp as O+import Sound.Tidal.Config+import Sound.Tidal.ID+import Sound.Tidal.Pattern+import Sound.Tidal.Stream.Types+import Sound.Tidal.Stream.UI+import System.IO (hPutStrLn, stderr)++{-+ Listen.hs - logic for listening and acting on incoming OSC messages+ Copyright (C) 2025, Alex McLean and contributors++ This library is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This library is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this library. If not, see <http://www.gnu.org/licenses/>.+-}++openListener :: Config -> IO (Maybe O.Udp)+openListener c+ | cCtrlListen c =+ catchAny+ run+ ( \_ -> do+ verbose c "That port isn't available, perhaps another Tidal instance is already listening on that port?"+ return Nothing+ )+ | otherwise = return Nothing+ where+ run = do+ sock <- O.udpServer (cCtrlAddr c) (cCtrlPort c)+ when (cCtrlBroadcast c) $ N.setSocketOption (O.udpSocket sock) N.Broadcast 1+ return $ Just sock+ catchAny :: IO a -> (E.SomeException -> IO a) -> IO a+ catchAny = E.catch++-- Listen to and act on OSC control messages+ctrlResponder :: Config -> Stream -> IO ()+ctrlResponder _ (stream@(Stream {sListen = Just sock})) = loop+ where+ loop :: IO ()+ loop = do+ O.recvMessages sock >>= mapM_ act+ loop+ -- External controller commands+ act :: O.Message -> IO ()+ act (O.Message "/ctrl" (O.Int32 k : v : [])) =+ act (O.Message "/ctrl" [O.string $ show k, v])+ act (O.Message "/ctrl" (O.AsciiString k : v@(O.Float _) : [])) =+ add (O.ascii_to_string k) (VF (fromJust $ O.datum_floating v))+ act (O.Message "/ctrl" (O.AsciiString k : O.AsciiString v : [])) =+ add (O.ascii_to_string k) (VS (O.ascii_to_string v))+ act (O.Message "/ctrl" (O.AsciiString k : O.Int32 v : [])) =+ add (O.ascii_to_string k) (VI (fromIntegral v))+ -- Stream playback commands+ act (O.Message "/mute" (k : [])) =+ withID k $ streamMute stream+ act (O.Message "/unmute" (k : [])) =+ withID k $ streamUnmute stream+ act (O.Message "/solo" (k : [])) =+ withID k $ streamSolo stream+ act (O.Message "/unsolo" (k : [])) =+ withID k $ streamUnsolo stream+ act (O.Message "/muteAll" []) =+ streamMuteAll stream+ act (O.Message "/unmuteAll" []) =+ streamUnmuteAll stream+ act (O.Message "/unsoloAll" []) =+ streamUnsoloAll stream+ act (O.Message "/hush" []) =+ streamHush stream+ act (O.Message "/silence" (k : [])) =+ withID k $ streamSilence stream+ -- Cycle properties commands+ act (O.Message "/setcps" [O.Float k]) =+ streamSetCPS stream $ toTime k+ act (O.Message "/setbpm" [O.Float k]) =+ streamSetBPM stream $ toTime k+ act (O.Message "/setCycle" [O.Float k]) =+ streamSetCycle stream $ toTime k+ act (O.Message "/resetCycles" _) =+ streamResetCycles stream+ -- Nudge all command+ act (O.Message "/nudgeAll" [O.Double k]) =+ streamNudgeAll stream k+ act m = hPutStrLn stderr $ "Unhandled OSC: " ++ show m+ add :: String -> Value -> IO ()+ add k v = do+ sMap <- takeMVar (sStateMV stream)+ putMVar (sStateMV stream) $ Map.insert k v sMap+ return ()+ withID :: O.Datum -> (ID -> IO ()) -> IO ()+ withID (O.AsciiString k) func = func $ (ID . O.ascii_to_string) k+ withID (O.Int32 k) func = func $ (ID . show) k+ withID _ _ = return ()+ctrlResponder _ _ = return ()
+ src/Sound/Tidal/Stream/Main.hs view
@@ -0,0 +1,78 @@+module Sound.Tidal.Stream.Main where++import Control.Concurrent (forkIO, newMVar)+import qualified Data.Map as Map+import qualified Sound.Tidal.Clock as Clock+import Sound.Tidal.Config+ ( Config (cCtrlAddr, cCtrlPort),+ toClockConfig,+ verbose,+ )+import Sound.Tidal.Stream.Listen+ ( ctrlResponder,+ openListener,+ )+import Sound.Tidal.Stream.Process (doTick)+import Sound.Tidal.Stream.Target (getCXs, superdirtShape)+import Sound.Tidal.Stream.Types (OSC, Stream (..), Target)+import Sound.Tidal.Version (tidal_status_string)+import System.IO (hPutStrLn, stderr)++{-+ Main.hs - Start tidals stream, listen and act on incoming messages+ Copyright (C) 2020, Alex McLean and contributors++ This library is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This library is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this library. If not, see <http://www.gnu.org/licenses/>.+-}++-- Start an instance of Tidal with superdirt OSC+startTidal :: Target -> Config -> IO Stream+startTidal target config = startStream config [(target, [superdirtShape])]++-- Start an instance of Tidal+-- Spawns a thread within Tempo that acts as the clock+-- Spawns a thread that listens to and acts on OSC control messages+startStream :: Config -> [(Target, [OSC])] -> IO Stream+startStream config oscmap = do+ sMapMV <- newMVar Map.empty+ pMapMV <- newMVar Map.empty+ globalFMV <- newMVar id++ tidal_status_string >>= verbose config+ verbose config $ "Listening for external controls on " ++ cCtrlAddr config ++ ":" ++ show (cCtrlPort config)+ listen <- openListener config++ cxs <- getCXs config oscmap++ clockRef <- Clock.clocked (toClockConfig config) (doTick sMapMV pMapMV globalFMV cxs)++ let stream =+ Stream+ { sConfig = config,+ sStateMV = sMapMV,+ sClockRef = clockRef,+ -- sLink = abletonLink,+ sListen = listen,+ sPMapMV = pMapMV,+ -- sActionsMV = actionsMV,+ sGlobalFMV = globalFMV,+ sCxs = cxs+ }++ -- Spawn a thread to handle OSC control messages+ _ <- forkIO $ ctrlResponder config stream+ return stream++startMulti :: [Target] -> Config -> IO ()+startMulti _ _ = hPutStrLn stderr "startMulti has been removed, please check the latest documentation on tidalcycles.org"
+ src/Sound/Tidal/Stream/Process.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}++module Sound.Tidal.Stream.Process where++{-+ Process.hs - Tidal's thingie for turning patterns into OSC streams+ Copyright (C) 2020, Alex McLean and contributors++ This library is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This library is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this library. If not, see <http://www.gnu.org/licenses/>.+-}++import Control.Applicative ((<|>))+import Control.Concurrent.MVar+ ( MVar,+ modifyMVar_,+ newMVar,+ putMVar,+ readMVar,+ takeMVar,+ )+import qualified Control.Exception as E+import Control.Monad (forM_, when)+import Data.Coerce (coerce)+import Data.List (sortOn)+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, fromJust, fromMaybe)+import qualified Sound.Osc.Fd as O+import qualified Sound.Tidal.Clock as Clock+import Sound.Tidal.Core (stack, (#))+import Sound.Tidal.ID (ID (fromID))+import qualified Sound.Tidal.Link as Link+import Sound.Tidal.Params (pS)+import Sound.Tidal.Pattern+import Sound.Tidal.Pattern.Types (patternTimeID)+import Sound.Tidal.Show ()+import Sound.Tidal.Stream.Target (send)+import Sound.Tidal.Stream.Types+import Sound.Tidal.Utils ((!!!))+import System.IO (hPutStrLn, stderr)++data ProcessedEvent = ProcessedEvent+ { peHasOnset :: Bool,+ peEvent :: Event ValueMap,+ peCps :: Double,+ peDelta :: Link.Micros,+ peCycle :: Time,+ peOnWholeOrPart :: Link.Micros,+ peOnWholeOrPartOsc :: O.Time,+ peOnPart :: Link.Micros,+ peOnPartOsc :: O.Time+ }++-- | Query the current pattern (contained in argument @stream :: Stream@)+-- for the events in the current arc (contained in argument @st :: T.State@),+-- translate them to OSC messages, and send these.+--+-- If an exception occurs during sending,+-- this functions prints a warning and continues, because+-- the likely reason is that the backend (supercollider) isn't running.+--+-- If any exception occurs before or outside sending+-- (e.g., while querying the pattern, while computing a message),+-- this function prints a warning and resets the current pattern+-- to the previous one (or to silence if there isn't one) and continues,+-- because the likely reason is that something is wrong with the current pattern.+doTick ::+ MVar ValueMap -> -- pattern state+ MVar PlayMap -> -- currently playing+ MVar (ControlPattern -> ControlPattern) -> -- current global fx+ [Cx] -> -- target addresses+ (Time, Time) -> -- current arc+ Double -> -- nudge+ Clock.ClockConfig -> -- config of the clock+ Clock.ClockRef -> -- reference to the clock+ (Link.SessionState, Link.SessionState) -> -- second session state is for keeping track of tempo changes+ IO ()+doTick stateMV playMV globalFMV cxs (st, end) nudge cconf cref (ss, temposs) =+ E.handle handleException $ do+ modifyMVar_ stateMV $ \sMap -> do+ pMap <- readMVar playMV+ sGlobalF <- readMVar globalFMV+ bpm <- Clock.getTempo ss+ let cps = Clock.beatToCycles cconf (fromRational bpm) / 60+ cycleLatency = toRational $ nudge / cps+ patstack = rotR cycleLatency $ sGlobalF $ playStack pMap+ sMap' = Map.insert "_cps" (VF $ coerce cps) sMap+ -- First the state is used to query the pattern+ es =+ sortOn (start . part) $+ query+ patstack+ ( State+ { arc = Arc st end,+ controls = sMap'+ }+ )+ -- Then it's passed through the events+ (sMap'', es') = resolveState sMap' es+ tes <- processCps cconf cref (ss, temposs) es'+ -- For each OSC target+ forM_ cxs $ \cx@(Cx target _ oscs _ _ bussesMV) -> do+ busses <- mapM readMVar bussesMV+ -- Latency is configurable per target.+ -- Latency is only used when sending events live.+ let latency = oLatency target+ ms = concatMap (\e -> concatMap (toOSC busses e) oscs) tes+ -- send the events to the OSC target+ forM_ ms $ \m ->+ send cx latency 0 m `E.catch` \(e :: E.SomeException) ->+ hPutStrLn stderr $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e+ return sMap''+ where+ handleException :: E.SomeException -> IO ()+ handleException e = do+ hPutStrLn stderr $ "Failed to Stream.doTick: " ++ show e+ hPutStrLn stderr "Return to previous pattern."+ setPreviousPatternOrSilence playMV++processCps :: Clock.ClockConfig -> Clock.ClockRef -> (Link.SessionState, Link.SessionState) -> [Event ValueMap] -> IO [ProcessedEvent]+processCps cconf cref (ss, temposs) = mapM processEvent+ where+ processEvent :: Event ValueMap -> IO ProcessedEvent+ processEvent e = do+ let wope = wholeOrPart e+ partStartCycle = start $ part e+ partStartBeat = Clock.cyclesToBeat cconf (realToFrac partStartCycle)+ onCycle = start wope+ onBeat = Clock.cyclesToBeat cconf (realToFrac onCycle)+ offCycle = stop wope+ offBeat = Clock.cyclesToBeat cconf (realToFrac offCycle)+ on <- Clock.timeAtBeat cconf ss onBeat+ onPart <- Clock.timeAtBeat cconf ss partStartBeat+ when+ (eventHasOnset e)+ ( do+ let cps' = Map.lookup "cps" (value e) >>= getF+ maybe (return ()) ((\newCps -> Clock.setTempoCPS newCps on cconf temposs) . toRational) cps'+ )+ off <- Clock.timeAtBeat cconf ss offBeat+ bpm <- Clock.getTempo ss+ wholeOrPartOsc <- Clock.linkToOscTime cref on+ onPartOsc <- Clock.linkToOscTime cref onPart+ let cps = Clock.beatToCycles cconf (fromRational bpm) / 60+ let delta = off - on+ return $!+ ProcessedEvent+ { peHasOnset = eventHasOnset e,+ peEvent = e,+ peCps = cps,+ peDelta = delta,+ peCycle = onCycle,+ peOnWholeOrPart = on,+ peOnWholeOrPartOsc = wholeOrPartOsc,+ peOnPart = onPart,+ peOnPartOsc = onPartOsc+ }++toOSC :: Maybe [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)]+toOSC maybeBusses pe osc@(OSC _ _) =+ catMaybes (playmsg : busmsgs)+ where+ -- playmap is a ValueMap where the keys don't start with ^ and are not ""+ -- busmap is a ValueMap containing the rest of the keys from the event value+ -- The partition is performed in order to have special handling of bus ids.++ (playmap, busmap) = Map.partitionWithKey (\k _ -> null k || head k /= '^') $ val pe+ -- Map in bus ids where needed.+ --+ -- Bus ids are integers+ -- If busses is empty, the ids to send are directly contained in the the values of the busmap.+ -- Otherwise, the ids to send are contained in busses at the indices of the values of the busmap.+ -- Both cases require that the values of the busmap are only ever integers,+ -- that is, they are Values with constructor VI+ -- (but perhaps we should explicitly crash with an error message if it contains something else?).+ -- Map.mapKeys tail is used to remove ^ from the keys.+ -- In case (value e) has the key "", we will get a crash here.+ playmap' = Map.union (Map.mapKeys (drop 1) $ Map.map (\v -> VS ('c' : show (toBus $ fromMaybe 0 $ getI v))) busmap) playmap+ val = value . peEvent+ -- Only events that start within the current nowArc are included+ playmsg+ | peHasOnset pe = do+ -- If there is already cps in the event, the union will preserve that.+ let extra =+ Map.fromList+ [ ("cps", VF (peCps pe)),+ ("delta", VF (Clock.addMicrosToOsc (peDelta pe) 0)),+ ("cycle", VF (fromRational (peCycle pe)))+ ]+ addExtra = Map.union playmap' extra+ ts = peOnWholeOrPartOsc pe + nudge -- + latency+ vs <- toData osc ((peEvent pe) {value = addExtra})+ mungedPath <- substitutePath (path osc) playmap'+ return+ ( ts,+ False, -- bus message ?+ O.Message mungedPath vs+ )+ | otherwise = Nothing+ toBus n+ | Just busses <- maybeBusses, (not . null) busses = busses !!! n+ | otherwise = n+ busmsgs =+ map+ ( \(k, b) -> do+ k' <- if not (null k) && head k == '^' then Just (drop 1 k) else Nothing+ v <- Map.lookup k' playmap+ bi <- getI b+ return+ ( tsPart,+ True, -- bus message ?+ O.Message "/c_set" [O.int32 (toBus bi), toDatum v]+ )+ )+ (Map.toList busmap)+ where+ tsPart = peOnPartOsc pe + nudge -- + latency+ nudge = fromJust $ getF $ fromMaybe (VF 0) $ Map.lookup "nudge" playmap+toOSC _ pe (OSCContext oscpath) =+ map cToM $ contextPosition $ context $ peEvent pe+ where+ cToM :: ((Int, Int), (Int, Int)) -> (Double, Bool, O.Message)+ cToM ((x, y), (x', y')) =+ ( ts,+ False, -- bus message ?+ O.Message oscpath $ O.string ident : O.float (peDelta pe) : O.float cyc : map O.int32 [x, y, x', y']+ )+ cyc :: Double+ cyc = fromRational $ peCycle pe+ nudge = fromMaybe 0 $ Map.lookup "nudge" (value $ peEvent pe) >>= getF+ ident = fromMaybe "unknown" $ Map.lookup "_id_" (value $ peEvent pe) >>= getS+ ts = peOnWholeOrPartOsc pe + nudge -- + latency++toData :: OSC -> Event ValueMap -> Maybe [O.Datum]+toData (OSC {args = ArgList as}) e = fmap (fmap toDatum) $ mapM (\(n, v) -> Map.lookup n (value e) <|> v) as+toData (OSC {args = Named rqrd}) e+ | hasRequired rqrd = Just $ concatMap (\(n, v) -> [O.string n, toDatum v]) $ Map.toList $ value e+ | otherwise = Nothing+ where+ hasRequired [] = True+ hasRequired xs = all (`elem` ks) xs+ ks = Map.keys (value e)+toData _ _ = Nothing++toDatum :: Value -> O.Datum+toDatum (VF x) = O.float x+toDatum (VN x) = O.float x+toDatum (VI x) = O.int32 x+toDatum (VS x) = O.string x+toDatum (VR x) = O.float (fromRational x :: Double)+toDatum (VB True) = O.int32 (1 :: Int)+toDatum (VB False) = O.int32 (0 :: Int)+toDatum (VX xs) = O.Blob $ O.blob_pack xs+toDatum _ = error "toDatum: unhandled value"++substitutePath :: String -> ValueMap -> Maybe String+substitutePath str cm = parse str+ where+ parse [] = Just []+ parse ('{' : xs) = parseWord xs+ parse (x : xs) = do+ xs' <- parse xs+ return (x : xs')+ parseWord xs+ | null b = getString cm a+ | otherwise = do+ v <- getString cm a+ xs' <- parse (drop 1 b)+ return $ v ++ xs'+ where+ (a, b) = break (== '}') xs++getString :: ValueMap -> String -> Maybe String+getString cm s = (simpleShow <$> Map.lookup param cm) <|> defaultValue dflt+ where+ (param, dflt) = break (== '=') s+ simpleShow :: Value -> String+ simpleShow (VS str) = str+ simpleShow (VI i) = show i+ simpleShow (VF f) = show f+ simpleShow (VN n) = show n+ simpleShow (VR r) = show r+ simpleShow (VB b) = show b+ simpleShow (VX xs) = show xs+ simpleShow (VState _) = show "<stateful>"+ simpleShow (VPattern _) = show "<pattern>"+ simpleShow (VList _) = show "<list>"+ defaultValue :: String -> Maybe String+ defaultValue ('=' : dfltVal) = Just dfltVal+ defaultValue _ = Nothing++playStack :: PlayMap -> ControlPattern+playStack pMap = stack . map psPattern . filter active . Map.elems $ pMap+ where+ active pState =+ if hasSolo pMap+ then psSolo pState+ else not (psMute pState)++hasSolo :: Map.Map k PlayState -> Bool+hasSolo = any psSolo . Map.elems++onSingleTick :: Clock.ClockConfig -> Clock.ClockRef -> MVar ValueMap -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> ControlPattern -> IO ()+onSingleTick clockConfig clockRef stateMV _ globalFMV cxs pat = do+ pMapMV <-+ newMVar $+ Map.singleton+ "fake"+ ( PlayState+ { psPattern = pat,+ psMute = False,+ psSolo = False,+ psHistory = []+ }+ )+ Clock.clockOnce (doTick stateMV pMapMV globalFMV cxs) clockConfig clockRef++-- Used for Tempo callback+updatePattern :: Stream -> ID -> Time -> ControlPattern -> IO ()+updatePattern stream k !t pat = do+ let x = queryArc pat (Arc 0 0)+ pMap <- seq x $ takeMVar (sPMapMV stream)+ let playState = updatePS $ Map.lookup (fromID k) pMap+ putMVar (sPMapMV stream) $ Map.insert (fromID k) playState pMap+ where+ updatePS (Just playState) = do playState {psPattern = pat', psHistory = pat : psHistory playState}+ updatePS Nothing = PlayState pat' False False [pat']+ patControls = Map.singleton patternTimeID (VR t)+ pat' =+ withQueryControls (Map.union patControls) $+ pat # pS "_id_" (pure $ fromID k)++setPreviousPatternOrSilence :: MVar PlayMap -> IO ()+setPreviousPatternOrSilence playMV =+ modifyMVar_ playMV $+ return+ . Map.map+ ( \pMap -> case psHistory pMap of+ _ : p : ps -> pMap {psPattern = p, psHistory = p : ps}+ _ -> pMap {psPattern = silence, psHistory = [silence]}+ )
+ src/Sound/Tidal/Stream/Target.hs view
@@ -0,0 +1,226 @@+module Sound.Tidal.Stream.Target where++import Control.Concurrent+ ( forkIO,+ forkOS,+ newMVar,+ readMVar,+ swapMVar,+ threadDelay,+ )+import Control.Monad (when)+import Data.Maybe (catMaybes, fromJust, isJust)+import Foreign (Word8)+import qualified Network.Socket as N+import qualified Sound.Osc.Fd as O+import qualified Sound.Osc.Time.Timeout as O+import qualified Sound.Osc.Transport.Fd.Udp as O+import Sound.Tidal.Config+import Sound.Tidal.Pattern+import Sound.Tidal.Stream.Types++{-+ Target.hs - Create and send to OSC targets+ Copyright (C) 2020, Alex McLean and contributors++ This library is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This library is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this library. If not, see <http://www.gnu.org/licenses/>.+-}++getCXs :: Config -> [(Target, [OSC])] -> IO [Cx]+getCXs config oscmap =+ mapM+ ( \(target, os) -> do+ remote_addr <- resolve (oAddress target) (oPort target)+ remote_bus_addr <- mapM (resolve (oAddress target)) (oBusPort target)+ remote_busses <- sequence (oBusPort target >> Just (newMVar []))++ let broadcast = if cCtrlBroadcast config then 1 else 0+ u <-+ O.udp_socket+ (\sock _ -> do N.setSocketOption sock N.Broadcast broadcast)+ (oAddress target)+ (oPort target)+ let cx = Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxBusses = remote_busses, cxTarget = target, cxOSCs = os}+ _ <- forkIO $ handshake cx config+ return cx+ )+ oscmap++resolve :: String -> Int -> IO N.AddrInfo+resolve host port = do+ let hints = N.defaultHints {N.addrSocketType = N.Stream}+ addr : _ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port)+ return addr++handshake :: Cx -> Config -> IO ()+handshake Cx {cxUDP = udp, cxBusses = Just bussesMV, cxAddr = addr} c = sendHandshake >> listen 0+ where+ sendHandshake :: IO ()+ sendHandshake = O.sendTo udp (O.Packet_Message $ O.Message "/dirt/handshake" []) (N.addrAddress addr)+ listen :: Int -> IO ()+ listen waits = do+ ms <- recvMessagesTimeout 2 udp+ if null ms+ then do+ checkHandshake waits -- there was a timeout, check handshake+ listen (waits + 1)+ else do+ mapM_ respond ms+ listen 0+ checkHandshake :: Int -> IO ()+ checkHandshake waits = do+ busses <- readMVar bussesMV+ when (null busses) $ do+ when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).."+ sendHandshake+ respond :: O.Message -> IO ()+ respond (O.Message "/dirt/hello" _) = sendHandshake+ respond (O.Message "/dirt/handshake/reply" xs) = do+ prev <- swapMVar bussesMV $ bufferIndices xs+ -- Only report the first time..+ when (null prev) $ verbose c $ "Connected to SuperDirt."+ respond _ = return ()+ bufferIndices :: [O.Datum] -> [Int]+ bufferIndices [] = []+ bufferIndices (x : xs')+ | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs'+ | otherwise = bufferIndices xs'+handshake _ _ = return ()++recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message]+recvMessagesTimeout n sock = fmap (maybe [] O.packetMessages) $ O.recvPacketTimeout n sock++-- send has three modes:+-- Send events early using timestamp in the OSC bundle - used by Superdirt+-- Send events early by adding timestamp to the OSC message - used by Dirt+-- Send events live by delaying the thread+send :: Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO ()+send cx latency extraLatency (time, isBusMsg, m)+ | oSchedule target == Pre BundleStamp = sendBndl isBusMsg cx $ O.Bundle timeWithLatency [m]+ | oSchedule target == Pre MessageStamp = sendO isBusMsg cx $ addtime m+ | otherwise = do+ _ <- forkOS $ do+ now <- O.time+ threadDelay $ floor $ (timeWithLatency - now) * 1000000+ sendO isBusMsg cx m+ return ()+ where+ addtime (O.Message mpath params) = O.Message mpath ((O.int32 sec) : ((O.int32 usec) : params))+ ut = O.ntpr_to_posix timeWithLatency+ sec :: Int+ sec = floor ut+ usec :: Int+ usec = floor $ 1000000 * (ut - (fromIntegral sec))+ target = cxTarget cx+ timeWithLatency = time - latency + extraLatency++sendBndl :: Bool -> Cx -> O.Bundle -> IO ()+sendBndl isBusMsg cx bndl = O.sendTo (cxUDP cx) (O.Packet_Bundle bndl) (N.addrAddress addr)+ where+ addr+ | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx+ | otherwise = cxAddr cx++sendO :: Bool -> Cx -> O.Message -> IO ()+sendO isBusMsg cx msg = O.sendTo (cxUDP cx) (O.Packet_Message msg) (N.addrAddress addr)+ where+ addr+ | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx+ | otherwise = cxAddr cx++superdirtTarget :: Target+superdirtTarget =+ Target+ { oName = "SuperDirt",+ oAddress = "127.0.0.1",+ oPort = 57120,+ oBusPort = Just 57110,+ oLatency = 0.2,+ oWindow = Nothing,+ oSchedule = Pre BundleStamp,+ oHandshake = True+ }++superdirtShape :: OSC+superdirtShape = OSC "/dirt/play" $ Named {requiredArgs = ["s"]}++dirtTarget :: Target+dirtTarget =+ Target+ { oName = "Dirt",+ oAddress = "127.0.0.1",+ oPort = 7771,+ oBusPort = Nothing,+ oLatency = 0.02,+ oWindow = Nothing,+ oSchedule = Pre MessageStamp,+ oHandshake = False+ }++dirtShape :: OSC+dirtShape =+ OSC "/play" $+ ArgList+ [ ("cps", fDefault 0),+ ("s", Nothing),+ ("offset", fDefault 0),+ ("begin", fDefault 0),+ ("end", fDefault 1),+ ("speed", fDefault 1),+ ("pan", fDefault 0.5),+ ("velocity", fDefault 0.5),+ ("vowel", sDefault ""),+ ("cutoff", fDefault 0),+ ("resonance", fDefault 0),+ ("accelerate", fDefault 0),+ ("shape", fDefault 0),+ ("kriole", iDefault 0),+ ("gain", fDefault 1),+ ("cut", iDefault 0),+ ("delay", fDefault 0),+ ("delaytime", fDefault (-1)),+ ("delayfeedback", fDefault (-1)),+ ("crush", fDefault 0),+ ("coarse", iDefault 0),+ ("hcutoff", fDefault 0),+ ("hresonance", fDefault 0),+ ("bandf", fDefault 0),+ ("bandq", fDefault 0),+ ("unit", sDefault "rate"),+ ("loop", fDefault 0),+ ("n", fDefault 0),+ ("attack", fDefault (-1)),+ ("hold", fDefault 0),+ ("release", fDefault (-1)),+ ("orbit", iDefault 0) -- ,+ -- ("id", iDefault 0)+ ]++sDefault :: String -> Maybe Value+sDefault x = Just $ VS x++fDefault :: Double -> Maybe Value+fDefault x = Just $ VF x++rDefault :: Rational -> Maybe Value+rDefault x = Just $ VR x++iDefault :: Int -> Maybe Value+iDefault x = Just $ VI x++bDefault :: Bool -> Maybe Value+bDefault x = Just $ VB x++xDefault :: [Word8] -> Maybe Value+xDefault x = Just $ VX x
+ src/Sound/Tidal/Stream/Types.hs view
@@ -0,0 +1,83 @@+module Sound.Tidal.Stream.Types where++import Control.Concurrent.MVar+import qualified Data.Map.Strict as Map+import qualified Network.Socket as N+import qualified Sound.Osc.Transport.Fd.Udp as O+import qualified Sound.Tidal.Clock as Clock+import Sound.Tidal.Config+import Sound.Tidal.Pattern+import Sound.Tidal.Show ()++data Stream = Stream+ { sConfig :: Config,+ sStateMV :: MVar ValueMap,+ -- sOutput :: MVar ControlPattern,+ sClockRef :: Clock.ClockRef,+ sListen :: Maybe O.Udp,+ sPMapMV :: MVar PlayMap,+ sGlobalFMV :: MVar (ControlPattern -> ControlPattern),+ sCxs :: [Cx]+ }++data Cx = Cx+ { cxTarget :: Target,+ cxUDP :: O.Udp,+ cxOSCs :: [OSC],+ cxAddr :: N.AddrInfo,+ cxBusAddr :: Maybe N.AddrInfo,+ cxBusses :: Maybe (MVar [Int])+ }++data StampStyle+ = BundleStamp+ | MessageStamp+ deriving (Eq, Show)++data Schedule+ = Pre StampStyle+ | Live+ deriving (Eq, Show)++data Target = Target+ { oName :: String,+ oAddress :: String,+ oPort :: Int,+ oBusPort :: Maybe Int,+ oLatency :: Double,+ oWindow :: Maybe Arc,+ oSchedule :: Schedule,+ oHandshake :: Bool+ }+ deriving (Show)++data Args+ = Named {requiredArgs :: [String]}+ | ArgList [(String, Maybe Value)]+ deriving (Show)++data OSC+ = OSC+ { path :: String,+ args :: Args+ }+ | OSCContext {path :: String}+ deriving (Show)++data PlayState = PlayState+ { psPattern :: ControlPattern,+ psMute :: Bool,+ psSolo :: Bool,+ psHistory :: [ControlPattern]+ }+ deriving (Show)++type PatId = String++type PlayMap = Map.Map PatId PlayState++-- data TickState = TickState {+-- tickArc :: Arc,+-- tickNudge :: Double+-- }+-- deriving Show
+ src/Sound/Tidal/Stream/UI.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Sound.Tidal.Stream.UI where++import Control.Concurrent.MVar+import qualified Control.Exception as E+import qualified Data.Map as Map+import qualified Sound.Tidal.Clock as Clock+import Sound.Tidal.Config+import Sound.Tidal.ID+import Sound.Tidal.Pattern+import Sound.Tidal.Stream.Process+import Sound.Tidal.Stream.Types+import System.IO (hPutStrLn, stderr)+import System.Random (getStdRandom, randomR)++streamNudgeAll :: Stream -> Double -> IO ()+streamNudgeAll s = Clock.setNudge (sClockRef s)++streamResetCycles :: Stream -> IO ()+streamResetCycles s = streamSetCycle s 0++streamSetCycle :: Stream -> Time -> IO ()+streamSetCycle s = Clock.setClock (sClockRef s)++streamSetCPS :: Stream -> Time -> IO ()+streamSetCPS s = Clock.setCPS (toClockConfig $ sConfig s) (sClockRef s)++streamSetBPM :: Stream -> Time -> IO ()+streamSetBPM s = Clock.setBPM (sClockRef s)++streamGetCPS :: Stream -> IO Time+streamGetCPS s = Clock.getCPS (toClockConfig $ sConfig s) (sClockRef s)++-- Deprecated - compat with old style BootTidal.hs+streamGetcps :: Stream -> IO Time+streamGetcps = streamGetCPS++streamGetBPM :: Stream -> IO Time+streamGetBPM s = Clock.getBPM (sClockRef s)++streamGetNow :: Stream -> IO Time+streamGetNow s = Clock.getCycleTime (toClockConfig $ sConfig s) (sClockRef s)++-- Deprecated - compat with old style BootTidal.hs+streamGetnow :: Stream -> IO Time+streamGetnow = streamGetNow++streamEnableLink :: Stream -> IO ()+streamEnableLink s = Clock.enableLink (sClockRef s)++streamDisableLink :: Stream -> IO ()+streamDisableLink s = Clock.disableLink (sClockRef s)++streamList :: Stream -> IO ()+streamList s = do+ pMap <- readMVar (sPMapMV s)+ let hs = hasSolo pMap+ putStrLn $ concatMap (showKV hs) $ Map.toList pMap+ where+ showKV :: Bool -> (PatId, PlayState) -> String+ showKV True (k, (PlayState {psSolo = True})) = k ++ " - solo\n"+ showKV True (k, _) = "(" ++ k ++ ")\n"+ showKV False (k, (PlayState {psSolo = False})) = k ++ "\n"+ showKV False (k, _) = "(" ++ k ++ ") - muted\n"++streamReplace :: Stream -> ID -> ControlPattern -> IO ()+streamReplace stream k !pat = do+ t <- Clock.getCycleTime (toClockConfig $ sConfig stream) (sClockRef stream)+ E.handle+ ( \(e :: E.SomeException) -> do+ hPutStrLn stderr $ "Failed to Stream.streamReplace: " ++ show e+ hPutStrLn stderr "Return to previous pattern."+ setPreviousPatternOrSilence (sPMapMV stream)+ )+ (updatePattern stream k t pat)++-- streamFirst but with random cycle instead of always first cicle+streamOnce :: Stream -> ControlPattern -> IO ()+streamOnce st p = do+ i <- getStdRandom $ randomR (0, 8192)+ streamFirst st $ rotL (toRational (i :: Int)) p++streamFirst :: Stream -> ControlPattern -> IO ()+streamFirst stream pat = onSingleTick (toClockConfig $ sConfig stream) (sClockRef stream) (sStateMV stream) (sPMapMV stream) (sGlobalFMV stream) (sCxs stream) pat++streamMute :: Stream -> ID -> IO ()+streamMute s k = withPatIds s [k] (\x -> x {psMute = True})++streamMutes :: Stream -> [ID] -> IO ()+streamMutes s ks = withPatIds s ks (\x -> x {psMute = True})++streamUnmute :: Stream -> ID -> IO ()+streamUnmute s k = withPatIds s [k] (\x -> x {psMute = False})++streamSolo :: Stream -> ID -> IO ()+streamSolo s k = withPatIds s [k] (\x -> x {psSolo = True})++streamUnsolo :: Stream -> ID -> IO ()+streamUnsolo s k = withPatIds s [k] (\x -> x {psSolo = False})++withPatIds :: Stream -> [ID] -> (PlayState -> PlayState) -> IO ()+withPatIds s ks f =+ do+ playMap <- takeMVar $ sPMapMV s+ let pMap' = foldr (Map.update (\x -> Just $ f x)) playMap (map fromID ks)+ putMVar (sPMapMV s) pMap'+ return ()++-- TODO - is there a race condition here?+streamMuteAll :: Stream -> IO ()+streamMuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psMute = True})++streamHush :: Stream -> IO ()+streamHush s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psPattern = silence, psHistory = silence : psHistory x})++streamUnmuteAll :: Stream -> IO ()+streamUnmuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psMute = False})++streamUnsoloAll :: Stream -> IO ()+streamUnsoloAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psSolo = False})++streamSilence :: Stream -> ID -> IO ()+streamSilence s k = withPatIds s [k] (\x -> x {psPattern = silence, psHistory = silence : psHistory x})++streamAll :: Stream -> (ControlPattern -> ControlPattern) -> IO ()+streamAll s f = do+ _ <- swapMVar (sGlobalFMV s) f+ return ()++streamGet :: Stream -> String -> IO (Maybe Value)+streamGet s k = Map.lookup k <$> readMVar (sStateMV s)++streamSet :: (Valuable a) => Stream -> String -> Pattern a -> IO ()+streamSet s k pat = do+ sMap <- takeMVar $ sStateMV s+ let pat' = toValue <$> pat+ sMap' = Map.insert k (VPattern pat') sMap+ putMVar (sStateMV s) $ sMap'++streamSetI :: Stream -> String -> Pattern Int -> IO ()+streamSetI = streamSet++streamSetF :: Stream -> String -> Pattern Double -> IO ()+streamSetF = streamSet++streamSetS :: Stream -> String -> Pattern String -> IO ()+streamSetS = streamSet++streamSetB :: Stream -> String -> Pattern Bool -> IO ()+streamSetB = streamSet++streamSetR :: Stream -> String -> Pattern Rational -> IO ()+streamSetR = streamSet
− src/Sound/Tidal/StreamTypes.hs
@@ -1,24 +0,0 @@-module Sound.Tidal.StreamTypes where--import qualified Data.Map.Strict as Map-import Sound.Tidal.Pattern-import Sound.Tidal.Show ()--data PlayState = PlayState {pattern :: ControlPattern,- mute :: Bool,- solo :: Bool,- history :: [ControlPattern]- }- deriving Show--type PatId = String-type PlayMap = Map.Map PatId PlayState--data TickState = TickState {- tickArc :: Arc,- tickNudge :: Double- }- deriving Show--patternTimeID :: String-patternTimeID = "_t_pattern"
− src/Sound/Tidal/Tempo.hs
@@ -1,306 +0,0 @@-{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-}-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-orphans #-}---module Sound.Tidal.Tempo where--import Control.Concurrent.MVar-import qualified Sound.Tidal.Pattern as P-import qualified Sound.Osc.Fd as O-import Control.Concurrent (forkIO, ThreadId, threadDelay)-import Control.Monad (when)-import qualified Data.Map.Strict as Map-import qualified Control.Exception as E-import Sound.Tidal.ID-import Sound.Tidal.Config-import Sound.Tidal.Utils (writeError)-import qualified Sound.Tidal.Link as Link-import Foreign.C.Types (CDouble(..))-import System.IO (hPutStrLn, stderr)-import Data.Int(Int64)--import Sound.Tidal.StreamTypes--{-- Tempo.hs - Tidal's scheduler- Copyright (C) 2020, Alex McLean and contributors-- This library is free software: you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this library. If not, see <http://www.gnu.org/licenses/>.--}--instance Show O.Udp where- show _ = "-unshowable-"--type TransitionMapper = P.Time -> [P.ControlPattern] -> P.ControlPattern--data TempoAction =- SetCycle P.Time- | SingleTick P.ControlPattern- | SetNudge Double- | StreamReplace ID P.ControlPattern- | Transition Bool TransitionMapper ID P.ControlPattern--data State = State {ticks :: Int64,- start :: Link.Micros,- nowArc :: P.Arc,- nudged :: Double- }- deriving Show--data ActionHandler =- ActionHandler {- onTick :: TickState -> LinkOperations -> P.ValueMap -> IO P.ValueMap,- onSingleTick :: LinkOperations -> P.ValueMap -> P.ControlPattern -> IO P.ValueMap,- updatePattern :: ID -> P.Time -> P.ControlPattern -> IO ()- }--data LinkOperations =- LinkOperations {- timeAtBeat :: Link.Beat -> IO Link.Micros,- timeToCycles :: Link.Micros -> IO P.Time,- getTempo :: IO Link.BPM,- setTempo :: Link.BPM -> Link.Micros -> IO (),- linkToOscTime :: Link.Micros -> O.Time,- beatToCycles :: CDouble -> CDouble,- cyclesToBeat :: CDouble -> CDouble- }--{-|- Start cycles from the given cycle number.-- > setCycle 5- > d1 $ n "6 2 0 8" # s "east"--}-setCycle :: P.Time -> MVar [TempoAction] -> IO ()-setCycle cyc actionsMV = modifyMVar_ actionsMV (\actions -> return $ SetCycle cyc : actions)--setNudge :: MVar [TempoAction] -> Double -> IO ()-setNudge actionsMV nudge = modifyMVar_ actionsMV (\actions -> return $ SetNudge nudge : actions)--timeToCycles' :: Config -> Link.SessionState -> Link.Micros -> IO P.Time-timeToCycles' config ss time = do- beat <- Link.beatAtTime ss time (cQuantum config)- return $! (toRational beat) / (toRational (cBeatsPerCycle config))---- At what time does the cycle occur according to Link?-cyclesToTime :: Config -> Link.SessionState -> P.Time -> IO Link.Micros-cyclesToTime config ss cyc = do- let beat = (fromRational cyc) * (cBeatsPerCycle config)- Link.timeAtBeat ss beat (cQuantum config)--addMicrosToOsc :: Link.Micros -> O.Time -> O.Time-addMicrosToOsc m t = ((fromIntegral m) / 1000000) + t---- clocked assumes tempoMV is empty-clocked :: Config -> MVar P.ValueMap -> MVar PlayMap -> MVar [TempoAction] -> ActionHandler -> Link.AbletonLink -> IO [ThreadId]-clocked config stateMV mapMV actionsMV ac abletonLink- = do -- TODO - do something with thread id- clockTid <- forkIO $ loopInit- return $! [clockTid]- where frameTimespan :: Link.Micros- frameTimespan = round $ (cFrameTimespan config) * 1000000- quantum :: CDouble- quantum = cQuantum config- beatsPerCycle :: CDouble- beatsPerCycle = cBeatsPerCycle config- loopInit :: IO a- loopInit =- do- when (cEnableLink config) $ Link.enable abletonLink- sessionState <- Link.createAndCaptureAppSessionState abletonLink- now <- Link.clock abletonLink- let startAt = now + processAhead- Link.requestBeatAtTime sessionState 0 startAt quantum- Link.commitAndDestroyAppSessionState abletonLink sessionState- putMVar actionsMV []- let st = State {ticks = 0,- start = now,- nowArc = P.Arc 0 0,- nudged = 0- }- checkArc $! st- -- Time is processed at a fixed rate according to configuration- -- logicalTime gives the time when a tick starts based on when- -- processing first started.- logicalTime :: Link.Micros -> Int64 -> Link.Micros- logicalTime startTime ticks' = startTime + ticks' * frameTimespan- -- tick moves the logical time forward or recalculates the ticks in case- -- the logical time is out of sync with Link time.- -- tick delays the thread when logical time is ahead of Link time.- tick :: State -> IO a- tick st = do- now <- Link.clock abletonLink- let preferredNewTick = ticks st + 1- logicalNow = logicalTime (start st) preferredNewTick- aheadOfNow = now + processAhead- actualTick = (aheadOfNow - start st) `div` frameTimespan- drifted = abs (actualTick - preferredNewTick) > cSkipTicks config- newTick | drifted = actualTick- | otherwise = preferredNewTick- st' = st {ticks = newTick}- delta = min frameTimespan (logicalNow - aheadOfNow)- if drifted- then writeError $ "skip: " ++ (show (actualTick - ticks st))- else when (delta > 0) $ threadDelay $ fromIntegral delta- checkArc st'- -- The reference time Link uses,- -- is the time the audio for a certain beat hits the speaker.- -- Processing of the nowArc should happen early enough for- -- all events in the nowArc to hit the speaker, but not too early.- -- Processing thus needs to happen a short while before the start- -- of nowArc. How far ahead is controlled by cProcessAhead.- processAhead :: Link.Micros- processAhead = round $ (cProcessAhead config) * 1000000- checkArc :: State -> IO a- checkArc st = do- actions <- swapMVar actionsMV [] - st' <- processActions st actions- let logicalEnd = logicalTime (start st') $ ticks st' + 1- nextArcStartCycle = P.stop $ nowArc st'- ss <- Link.createAndCaptureAppSessionState abletonLink- arcStartTime <- cyclesToTime config ss nextArcStartCycle- Link.destroySessionState ss- if (arcStartTime < logicalEnd)- then processArc st'- else tick st'- processArc :: State -> IO a - processArc st =- do- streamState <- takeMVar stateMV- let logicalEnd = logicalTime (start st) $ ticks st + 1- startCycle = P.stop $ nowArc st- sessionState <- Link.createAndCaptureAppSessionState abletonLink- endCycle <- timeToCycles' config sessionState logicalEnd- let st' = st {nowArc = P.Arc startCycle endCycle}- nowOsc <- O.time- nowLink <- Link.clock abletonLink- let ops = LinkOperations {- timeAtBeat = \beat -> Link.timeAtBeat sessionState beat quantum ,- timeToCycles = timeToCycles' config sessionState,- getTempo = Link.getTempo sessionState,- setTempo = Link.setTempo sessionState,- linkToOscTime = \lt -> addMicrosToOsc (lt - nowLink) nowOsc,- beatToCycles = btc,- cyclesToBeat = ctb- }- let state = TickState {- tickArc = nowArc st',- tickNudge = nudged st'- }- streamState' <- (onTick ac) state ops streamState- Link.commitAndDestroyAppSessionState abletonLink sessionState- putMVar stateMV streamState'- tick st'- btc :: CDouble -> CDouble- btc beat = beat / beatsPerCycle- ctb :: CDouble -> CDouble- ctb cyc = cyc * beatsPerCycle- processActions :: State -> [TempoAction] -> IO State- processActions st [] = return $! st- processActions st actions = do- streamState <- takeMVar stateMV- (st', streamState') <- handleActions st actions streamState- putMVar stateMV streamState'- return $! st'- handleActions :: State -> [TempoAction] -> P.ValueMap -> IO (State, P.ValueMap)- handleActions st [] streamState = return (st, streamState)- handleActions st (SetCycle cyc : otherActions) streamState =- do- (st', streamState') <- handleActions st otherActions streamState- sessionState <- Link.createAndCaptureAppSessionState abletonLink-- now <- Link.clock abletonLink- let startAt = now + processAhead- beat = (fromRational cyc) * (cBeatsPerCycle config)- Link.requestBeatAtTime sessionState beat startAt quantum- Link.commitAndDestroyAppSessionState abletonLink sessionState-- - let st'' = st' {- ticks = 0,- start = now,- nowArc = P.Arc cyc cyc- }-- return (st'', streamState')- handleActions st (SingleTick pat : otherActions) streamState =- do- (st', streamState') <- handleActions st otherActions streamState- -- onSingleTick assumes it runs at beat 0.- -- The best way to achieve that is to use forceBeatAtTime.- -- But using forceBeatAtTime means we can not commit its session state.- -- Another session state, which we will commit,- -- is introduced to keep track of tempo changes.- sessionState <- Link.createAndCaptureAppSessionState abletonLink- zeroedSessionState <- Link.createAndCaptureAppSessionState abletonLink- nowOsc <- O.time- nowLink <- Link.clock abletonLink- Link.forceBeatAtTime zeroedSessionState 0 (nowLink + processAhead) quantum- let ops = LinkOperations {- timeAtBeat = \beat -> Link.timeAtBeat zeroedSessionState beat quantum,- timeToCycles = timeToCycles' config zeroedSessionState,- getTempo = Link.getTempo zeroedSessionState,- setTempo = \bpm micros ->- Link.setTempo zeroedSessionState bpm micros >>- Link.setTempo sessionState bpm micros,- linkToOscTime = \lt -> addMicrosToOsc (lt - nowLink) nowOsc,- beatToCycles = btc,- cyclesToBeat = ctb- }- streamState'' <- (onSingleTick ac) ops streamState' pat- Link.commitAndDestroyAppSessionState abletonLink sessionState- Link.destroySessionState zeroedSessionState- return (st', streamState'')- handleActions st (SetNudge nudge : otherActions) streamState =- do- (st', streamState') <- handleActions st otherActions streamState- let st'' = st' {nudged = nudge}- return (st'', streamState')- handleActions st (StreamReplace k pat : otherActions) streamState =- do- (st', streamState') <- handleActions st otherActions streamState- E.catch (- do- now <- Link.clock abletonLink- sessionState <- Link.createAndCaptureAppSessionState abletonLink- cyc <- timeToCycles' config sessionState now- Link.destroySessionState sessionState- (updatePattern ac) k cyc pat- return (st', streamState')- )- (\(e :: E.SomeException) -> do- hPutStrLn stderr $ "Error in pattern: " ++ show e- return (st', streamState')- )- handleActions st (Transition historyFlag f patId pat : otherActions) streamState =- do- (st', streamState') <- handleActions st otherActions streamState- let- appendPat flag = if flag then (pat:) else id- updatePS (Just playState) = playState {history = (appendPat historyFlag) (history playState)}- updatePS Nothing = PlayState {pattern = P.silence,- mute = False,- solo = False,- history = (appendPat historyFlag) (P.silence:[])- }- transition' pat' = do now <- Link.clock abletonLink- ss <- Link.createAndCaptureAppSessionState abletonLink- c <- timeToCycles' config ss now- return $! f c pat'- pMap <- readMVar mapMV- let playState = updatePS $ Map.lookup (fromID patId) pMap- pat' <- transition' $ appendPat (not historyFlag) (history playState)- let pMap' = Map.insert (fromID patId) (playState {pattern = pat'}) pMap- _ <- swapMVar mapMV pMap'- return (st', streamState')
− src/Sound/Tidal/Time.hs
@@ -1,154 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveFunctor #-}--module Sound.Tidal.Time where--import Control.Applicative-import GHC.Generics-import Control.DeepSeq (NFData)---- | Time is rational-type Time = Rational---- | An arc of time, with a start time (or onset) and a stop time (or offset)-data ArcF a = Arc- { start :: a- , stop :: a- } deriving (Eq, Ord, Functor, Show, Generic)--type Arc = ArcF Time--instance Applicative ArcF where- pure t = Arc t t- (<*>) (Arc sf ef) (Arc sx ex) = Arc (sf sx) (ef ex)--instance NFData a => NFData (ArcF a)--instance Num a => Num (ArcF a) where- negate = fmap negate- (+) = liftA2 (+)- (*) = liftA2 (*)- fromInteger = pure . fromInteger- abs = fmap abs- signum = fmap signum--instance (Fractional a) => Fractional (ArcF a) where- recip = fmap recip- fromRational = pure . fromRational---- * Utility functions - Time---- | The @sam@ (start of cycle) for the given time value.--- Cycles have duration 1, so every integer Time value divides two cycles.-sam :: Time -> Time-sam = fromIntegral . (floor :: Time -> Int)---- | Turns a number into a (rational) time value. An alias for @toRational@.-toTime :: Real a => a -> Rational-toTime = toRational---- | Turns a (rational) time value into another number. An alias for @fromRational@.-fromTime :: Fractional a => Time -> a-fromTime = fromRational---- | The end point of the current cycle (and starting point of the next cycle)-nextSam :: Time -> Time-nextSam = (1+) . sam---- | The position of a time value relative to the start of its cycle.-cyclePos :: Time -> Time-cyclePos t = t - sam t---- * Utility functions - Arc---- | convex hull union-hull :: Arc -> Arc -> Arc-hull (Arc s e) (Arc s' e') = Arc (min s s') (max e e')---- | @subArc i j@ is the timespan that is the intersection of @i@ and @j@.--- intersection--- The definition is a bit fiddly as results might be zero-width, but--- not at the end of an non-zero-width arc - e.g. (0,1) and (1,2) do--- not intersect, but (1,1) (1,1) does.-subArc :: Arc -> Arc -> Maybe Arc-subArc a@(Arc s e) b@(Arc s' e')- | and [s'' == e'', s'' == e, s < e] = Nothing- | and [s'' == e'', s'' == e', s' < e'] = Nothing- | s'' <= e'' = Just (Arc s'' e'')- | otherwise = Nothing- where (Arc s'' e'') = sect a b--subMaybeArc :: Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)-subMaybeArc (Just a) (Just b) = do sa <- subArc a b- return $ Just sa-subMaybeArc _ _ = Just Nothing--- subMaybeArc = liftA2 subArc -- this typechecks, but doesn't work the same way.. hmm---- | Simple intersection of two arcs-sect :: Arc -> Arc -> Arc-sect (Arc s e) (Arc s' e') = Arc (max s s') (min e e')---- | The Arc returned is the cycle that the Time falls within.------ Edge case: If the Time is an integer,--- the Arc claiming it is the one starting at that Time,--- not the previous one ending at that Time.-timeToCycleArc :: Time -> Arc-timeToCycleArc t = Arc (sam t) (sam t + 1)---- | Shifts an Arc to one of equal duration that starts within cycle zero.--- (Note that the output Arc probably does not start *at* Time 0 ----- that only happens when the input Arc starts at an integral Time.)-cycleArc :: Arc -> Arc-cycleArc (Arc s e) = Arc (cyclePos s) (cyclePos s + (e-s))---- | Returns the numbers of the cycles that the input @Arc@ overlaps--- (excluding the input @Arc@'s endpoint, unless it has duration 0 ----- see "Edge cases" below).--- (The "cycle number" of an @Arc@ is equal to its start value.--- Thus, for instance, @cyclesInArc (Arc 0 1.5) == [0,1]@.)------ Edge cases:--- > cyclesInArc $ Arc 0 1.0001 == [0,1]--- > cyclesInArc $ Arc 0 1 == [0] -- the endpoint is excluded--- > cyclesInArc $ Arc 1 1 == [1] -- unless the Arc has duration 0------ PITFALL: Don't be fooled by the name. The output cycles--- are not necessarily completely contained in the input @Arc@,--- but they definitely overlap it,--- and they include every cycle that overlaps it.-cyclesInArc :: Integral a => Arc -> [a]-cyclesInArc (Arc s e)- | s > e = []- | s == e = [floor s]- | otherwise = [floor s .. ceiling e-1]---- | This provides exactly the same information as @cyclesInArc@,--- except that this represents its output as @Arc@s,--- whereas @cyclesInArc@ represents the same information as integral indices.--- (The @Arc@ from 0 to 1 corresponds to the index 0,--- the one from 1 to 2 has index 1, etc.)-cycleArcsInArc :: Arc -> [Arc]-cycleArcsInArc = map (timeToCycleArc . (toTime :: Int -> Time)) . cyclesInArc---- | Splits the given @Arc@ into a list of @Arc@s, at cycle boundaries.-arcCycles :: Arc -> [Arc]-arcCycles (Arc s e) | s >= e = []- | sam s == sam e = [Arc s e]- | otherwise = Arc s (nextSam s) : arcCycles (Arc (nextSam s) e)---- | Like arcCycles, but returns zero-width arcs-arcCyclesZW :: Arc -> [Arc]-arcCyclesZW (Arc s e) | s == e = [Arc s e]- | otherwise = arcCycles (Arc s e)---- | Similar to @fmap@ but time is relative to the cycle (i.e. the--- sam of the start of the arc)-mapCycle :: (Time -> Time) -> Arc -> Arc-mapCycle f (Arc s e) = Arc (sam' + f (s - sam')) (sam' + f (e - sam'))- where sam' = sam s---- | @isIn a t@ is @True@ if @t@ is inside--- the arc represented by @a@.-isIn :: Arc -> Time -> Bool-isIn (Arc s e) t = t >= s && t < e
src/Sound/Tidal/Transition.hs view
@@ -2,22 +2,25 @@ module Sound.Tidal.Transition where -import Prelude hiding ((<*), (*>))--import Control.Concurrent.MVar (modifyMVar_)-+import Control.Concurrent.MVar (readMVar, swapMVar) import qualified Data.Map.Strict as Map -- import Data.Maybe (fromJust) -import Sound.Tidal.Control+import qualified Sound.Tidal.Clock as Clock+import Sound.Tidal.Config (toClockConfig)+import Sound.Tidal.Control (_stut) import Sound.Tidal.Core-import Sound.Tidal.ID+import Sound.Tidal.ID (ID (fromID)) import Sound.Tidal.Params (gain, pan) import Sound.Tidal.Pattern-import Sound.Tidal.Stream-import Sound.Tidal.Tempo as T-import Sound.Tidal.UI (fadeOutFrom, fadeInFrom)+import Sound.Tidal.Stream.Types+ ( PlayState (PlayState, psHistory, psMute, psPattern, psSolo),+ Stream (sClockRef, sConfig, sPMapMV),+ )+-- import Sound.Tidal.Tempo as T+import Sound.Tidal.UI (fadeInFrom, fadeOutFrom) import Sound.Tidal.Utils (enumerate)+import Prelude hiding ((*>), (<*)) {- Transition.hs - A library for handling transitions between patterns@@ -37,166 +40,261 @@ along with this library. If not, see <http://www.gnu.org/licenses/>. -} +type TransitionMapper = Time -> [ControlPattern] -> ControlPattern+ -- Evaluation of pat is forced so exceptions are picked up here, before replacing the existing pattern. -- the "historyFlag" determines if the new pattern should be placed on the history stack or not-transition :: Stream -> Bool -> (Time -> [ControlPattern] -> ControlPattern) -> ID -> ControlPattern -> IO ()-transition stream historyFlag f patId !pat =- modifyMVar_ (sActionsMV stream) (\actions -> return $! (T.Transition historyFlag f patId pat) : actions)+transition :: Stream -> Bool -> TransitionMapper -> ID -> ControlPattern -> IO ()+transition stream historyFlag mapper patId !pat = do+ let appendPat flag = if flag then (pat :) else id+ updatePS (Just playState) = playState {psHistory = appendPat historyFlag (psHistory playState)}+ updatePS Nothing =+ PlayState+ { psPattern = silence,+ psMute = False,+ psSolo = False,+ psHistory = appendPat historyFlag [silence]+ }+ transition' pat' = do+ t <- Clock.getCycleTime (toClockConfig $ sConfig stream) (sClockRef stream)+ return $! mapper t pat'+ pMap <- readMVar (sPMapMV stream)+ let playState = updatePS $ Map.lookup (fromID patId) pMap+ pat' <- transition' $ appendPat (not historyFlag) (psHistory playState)+ let pMap' = Map.insert (fromID patId) (playState {psPattern = pat'}) pMap+ _ <- swapMVar (sPMapMV stream) pMap'+ return () -mortalOverlay :: Time -> Time -> [Pattern a] -> Pattern a-mortalOverlay _ _ [] = silence-mortalOverlay t now (pat:ps) = overlay (pop ps) (playFor s (s+t) pat) where- pop [] = silence- pop (x:_) = x- s = sam (now - fromIntegral (floor now `mod` floor t :: Int)) + sam t+_mortalOverlay :: Time -> Time -> [Pattern a] -> Pattern a+_mortalOverlay _ _ [] = silence+_mortalOverlay t now (pat : ps) = overlay (pop ps) (playFor s (s + t) pat)+ where+ pop [] = silence+ 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- which another function is applied.--}-wash :: (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Time -> Time -> Time -> Time -> [Pattern a] -> Pattern a-wash _ _ _ _ _ _ [] = silence-wash _ _ _ _ _ _ (pat:[]) = pat-wash fout fin delay durin durout now (pat:pat':_) =- stack [(filterWhen (< (now + delay)) pat'),- (filterWhen (between (now + delay) (now + delay + durin)) $ fout pat'),- (filterWhen (between (now + delay + durin) (now + delay + durin + durout)) $ fin pat),- (filterWhen (>= (now + delay + durin + durout)) $ pat)- ]- where- between lo hi x = (x >= lo) && (x < hi)+-- | 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+-- which another function is applied.+_wash :: (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Time -> Time -> Time -> Time -> [Pattern a] -> Pattern a+_wash _ _ _ _ _ _ [] = silence+_wash _ _ _ _ _ _ [pat] = pat+_wash fout fin delay durin durout now (pat : pat' : _) =+ stack+ [ filterWhen (< (now + delay)) pat',+ filterWhen (between (now + delay) (now + delay + durin)) $ fout pat',+ filterWhen (between (now + delay + durin) (now + delay + durin + durout)) $ fin pat,+ filterWhen (>= (now + delay + durin + durout)) pat+ ]+ where+ between lo hi x = (x >= lo) && (x < hi) -washIn :: (Pattern a -> Pattern a) -> Time -> Time -> [Pattern a] -> Pattern a-washIn f durin now pats = wash f id 0 durin 0 now pats+_washIn :: (Pattern a -> Pattern a) -> Time -> Time -> [Pattern a] -> Pattern a+_washIn f durin now pats = _wash f id 0 durin 0 now pats -xfadeIn :: Time -> Time -> [ControlPattern] -> ControlPattern-xfadeIn _ _ [] = silence-xfadeIn _ _ (pat:[]) = pat-xfadeIn t now (pat:pat':_) = overlay (pat |* gain (now `rotR` (_slow t envEqR))) (pat' |* gain (now `rotR` (_slow t (envEq))))+_xfadeIn :: Time -> Time -> [ControlPattern] -> ControlPattern+_xfadeIn _ _ [] = silence+_xfadeIn _ _ [pat] = pat+_xfadeIn t now (pat : pat' : _) = overlay (pat |* gain (now `rotR` _slow t envEqR)) (pat' |* gain (now `rotR` _slow t envEq)) -- | Pans the last n versions of the pattern across the field-histpan :: Int -> Time -> [ControlPattern] -> ControlPattern-histpan _ _ [] = silence-histpan 0 _ _ = silence-histpan n _ ps = stack $ map (\(i,pat) -> pat # pan (pure $ (fromIntegral i) / (fromIntegral n'))) (enumerate ps')- where ps' = take n ps- n' = length ps' -- in case there's fewer patterns than requested+_histpan :: Int -> Time -> [ControlPattern] -> ControlPattern+_histpan _ _ [] = silence+_histpan 0 _ _ = silence+_histpan n _ ps = stack $ map (\(i, pat) -> pat # pan (pure $ fromIntegral i / fromIntegral n')) (enumerate ps')+ where+ ps' = take n ps+ n' = length ps' -- in case there's fewer patterns than requested -- | Just stop for a bit before playing new pattern-wait :: Time -> Time -> [ControlPattern] -> ControlPattern-wait _ _ [] = silence-wait t now (pat:_) = filterWhen (>= (nextSam (now+t-1))) pat+_wait :: Time -> Time -> [ControlPattern] -> ControlPattern+_wait _ _ [] = silence+_wait t now (pat : _) = filterWhen (>= nextSam (now + t - 1)) pat -{- | Just as `wait`, `waitT` stops for a bit and then applies the given transition to the playing pattern+-- | Just as `wait`, `waitT` stops for a bit and then applies the given transition to the playing pattern+--+-- @+-- d1 $ sound "bd"+--+-- t1 (waitT (xfadeIn 8) 4) $ sound "hh*8"+-- @+_waitT :: (Time -> [ControlPattern] -> ControlPattern) -> Time -> Time -> [ControlPattern] -> ControlPattern+_waitT _ _ _ [] = silence+_waitT f t now pats = filterWhen (>= nextSam (now + t - 1)) (f (now + t) pats) -@-d1 $ sound "bd"+-- |+-- Jumps directly into the given pattern, this is essentially the _no transition_-transition.+--+-- Variants of @jump@ provide more useful capabilities, see @jumpIn@ and @jumpMod@+_jump :: Time -> [ControlPattern] -> ControlPattern+_jump = _jumpIn 0 -t1 (waitT (xfadeIn 8) 4) $ sound "hh*8"-@--}-waitT :: (Time -> [ControlPattern] -> ControlPattern) -> Time -> Time -> [ControlPattern] -> ControlPattern-waitT _ _ _ [] = silence-waitT f t now pats = filterWhen (>= (nextSam (now+t-1))) (f (now + t) pats)+-- | Sharp `jump` transition after the specified number of cycles have passed.+--+-- @+-- t1 (jumpIn 2) $ sound "kick(3,8)"+-- @+_jumpIn :: Int -> Time -> [ControlPattern] -> ControlPattern+_jumpIn n = _wash id id (fromIntegral n) 0 0 -{- |-Jumps directly into the given pattern, this is essentially the _no transition_-transition.+-- | Unlike `jumpIn` the variant `jumpIn'` will only transition at cycle boundary (e.g. when the cycle count is an integer).+_jumpIn' :: Int -> Time -> [ControlPattern] -> ControlPattern+_jumpIn' n now = _wash id id (nextSam now - now + fromIntegral n) 0 0 now -Variants of @jump@ provide more useful capabilities, see @jumpIn@ and @jumpMod@--}-jump :: Time -> [ControlPattern] -> ControlPattern-jump = jumpIn 0+-- | Sharp `jump` transition at next cycle boundary where cycle mod n == 0+_jumpMod :: Int -> Time -> [ControlPattern] -> ControlPattern+_jumpMod n now = _jumpIn' ((n - 1) - (floor now `mod` n)) now -{- | Sharp `jump` transition after the specified number of cycles have passed.+-- | Sharp `jump` transition at next cycle boundary where cycle mod n == p+_jumpMod' :: Int -> Int -> Time -> [ControlPattern] -> ControlPattern+_jumpMod' n p now = _jumpIn' ((n - 1) - (floor now `mod` n) + p) now -@-t1 (jumpIn 2) $ sound "kick(3,8)"-@--}-jumpIn :: Int -> Time -> [ControlPattern] -> ControlPattern-jumpIn n = wash id id (fromIntegral n) 0 0+-- | Degrade the new pattern over time until it ends in silence+_mortal :: Time -> Time -> Time -> [ControlPattern] -> ControlPattern+_mortal _ _ _ [] = silence+_mortal lifespan release now (p : _) = overlay (filterWhen (< (now + lifespan)) p) (filterWhen (>= (now + lifespan)) (fadeOutFrom (now + lifespan) release p)) -{- | Unlike `jumpIn` the variant `jumpIn'` will only transition at cycle boundary (e.g. when the cycle count is an integer).--}-jumpIn' :: Int -> Time -> [ControlPattern] -> ControlPattern-jumpIn' n now = wash id id ((nextSam now) - now + (fromIntegral n)) 0 0 now+_interpolate :: Time -> [ControlPattern] -> ControlPattern+_interpolate = _interpolateIn 4 --- | Sharp `jump` transition at next cycle boundary where cycle mod n == 0-jumpMod :: Int -> Time -> [ControlPattern] -> ControlPattern-jumpMod n now = jumpIn' ((n-1) - ((floor now) `mod` n)) now+_interpolateIn :: Time -> Time -> [ControlPattern] -> ControlPattern+_interpolateIn _ _ [] = silence+_interpolateIn _ _ [p] = p+_interpolateIn t now (pat : pat' : _) = f <$> pat' *> pat <* automation+ where+ automation = now `rotR` _slow t envL+ f a b x =+ Map.unionWith+ ( fNum2+ (\a' b' -> floor $ fromIntegral a' * x + fromIntegral b' * (1 - x))+ (\a' b' -> a' * x + b' * (1 - x))+ )+ b+ a --- | Sharp `jump` transition at next cycle boundary where cycle mod n == p-jumpMod' :: Int -> Int -> Time -> [ControlPattern] -> ControlPattern-jumpMod' n p now = Sound.Tidal.Transition.jumpIn' ((n-1) - ((floor now) `mod` n) + p) now+-- |+-- Degrades the current pattern while undegrading the next.+--+-- This is like @xfade@ but not by gain of samples but by randomly removing events from the current pattern and slowly adding back in missing events from the next one.+--+-- @+-- d1 $ sound "bd(3,8)"+--+-- t1 clutch $ sound "[hh*4, odx(3,8)]"+-- @+--+-- @clutch@ takes two cycles for the transition, essentially this is @clutchIn 2@.+_clutch :: Time -> [Pattern a] -> Pattern a+_clutch = _clutchIn 2 --- | Degrade the new pattern over time until it ends in silence-mortal :: Time -> Time -> Time -> [ControlPattern] -> ControlPattern-mortal _ _ _ [] = silence-mortal lifespan release now (p:_) = overlay (filterWhen (<(now+lifespan)) p) (filterWhen (>= (now+lifespan)) (fadeOutFrom (now + lifespan) release p))+-- |+-- Also degrades the current pattern and undegrades the next.+-- To change the number of cycles the transition takes, you can use @clutchIn@ like so:+--+-- @+-- d1 $ sound "bd(5,8)"+--+-- t1 (clutchIn 8) $ sound "[hh*4, odx(3,8)]"+-- @+--+-- will take 8 cycles for the transition.+_clutchIn :: Time -> Time -> [Pattern a] -> Pattern a+_clutchIn _ _ [] = silence+_clutchIn _ _ [p] = p+_clutchIn t now (p : p' : _) = overlay (fadeOutFrom now t p') (fadeInFrom now t p) +-- | same as `anticipate` though it allows you to specify the number of cycles until dropping to the new pattern, e.g.:+--+-- @+-- d1 $ sound "jvbass(3,8)"+--+-- t1 (anticipateIn 4) $ sound "jvbass(5,8)"+-- @+_anticipateIn :: Time -> Time -> [ControlPattern] -> ControlPattern+_anticipateIn t now pats = _washIn (innerJoin . (\pat -> (\v -> _stut 8 0.2 v pat) <$> (now `rotR` _slow t (toRational <$> envLR)))) t now pats -interpolate :: Time -> [ControlPattern] -> ControlPattern-interpolate = interpolateIn 4+-- wash :: (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Time -> Time -> Time -> Time -> [Pattern a] -> Pattern a -interpolateIn :: Time -> Time -> [ControlPattern] -> ControlPattern-interpolateIn _ _ [] = silence-interpolateIn _ _ (p:[]) = p-interpolateIn t now (pat:pat':_) = f <$> pat' *> pat <* automation- where automation = now `rotR` (_slow t envL)- f = (\a b x -> Map.unionWith (fNum2 (\a' b' -> floor $ (fromIntegral a') * x + (fromIntegral b') * (1-x))- (\a' b' -> a' * x + b' * (1-x))- )- b a- )+-- | `anticipate` is an increasing comb filter.+--+-- Build up some tension, culminating in a _drop_ to the new pattern after 8 cycles.+_anticipate :: Time -> [ControlPattern] -> ControlPattern+_anticipate = _anticipateIn 8 -{-|-Degrades the current pattern while undegrading the next.+-- Deprecated aliases+mortalOverlay :: Time -> Time -> [Pattern a] -> Pattern a+mortalOverlay = _mortalOverlay -This is like @xfade@ but not by gain of samples but by randomly removing events from the current pattern and slowly adding back in missing events from the next one.+wash ::+ (Pattern a -> Pattern a) ->+ (Pattern a -> Pattern a) ->+ Time ->+ Time ->+ Time ->+ Time ->+ [Pattern a] ->+ Pattern a+wash = _wash -@-d1 $ sound "bd(3,8)"+washIn ::+ (Pattern a -> Pattern a) ->+ Time ->+ Time ->+ [Pattern a] ->+ Pattern a+washIn = _washIn -t1 clutch $ sound "[hh*4, odx(3,8)]"-@+xfadeIn :: Time -> Time -> [ControlPattern] -> ControlPattern+xfadeIn = _xfadeIn -@clutch@ takes two cycles for the transition, essentially this is @clutchIn 2@.--}-clutch :: Time -> [Pattern a] -> Pattern a-clutch = clutchIn 2+histpan :: Int -> Time -> [ControlPattern] -> ControlPattern+histpan = _histpan -{-|-Also degrades the current pattern and undegrades the next.-To change the number of cycles the transition takes, you can use @clutchIn@ like so:+wait :: Time -> Time -> [ControlPattern] -> ControlPattern+wait = _wait -@-d1 $ sound "bd(5,8)"+waitT ::+ (Time -> [ControlPattern] -> ControlPattern) ->+ Time ->+ Time ->+ [ControlPattern] ->+ ControlPattern+waitT = _waitT -t1 (clutchIn 8) $ sound "[hh*4, odx(3,8)]"-@+jump :: Time -> [ControlPattern] -> ControlPattern+jump = _jump -will take 8 cycles for the transition.--}-clutchIn :: Time -> Time -> [Pattern a] -> Pattern a-clutchIn _ _ [] = silence-clutchIn _ _ (p:[]) = p-clutchIn t now (p:p':_) = overlay (fadeOutFrom now t p') (fadeInFrom now t p)+jumpIn :: Int -> Time -> [ControlPattern] -> ControlPattern+jumpIn = _jumpIn -{-| same as `anticipate` though it allows you to specify the number of cycles until dropping to the new pattern, e.g.:+jumpIn' :: Int -> Time -> [ControlPattern] -> ControlPattern+jumpIn' = _jumpIn' -@-d1 $ sound "jvbass(3,8)"+jumpMod :: Int -> Time -> [ControlPattern] -> ControlPattern+jumpMod = _jumpMod -t1 (anticipateIn 4) $ sound "jvbass(5,8)"-@-}-anticipateIn :: Time -> Time -> [ControlPattern] -> ControlPattern-anticipateIn t now pats = washIn (innerJoin . (\pat -> (\v -> _stut 8 0.2 v pat) <$> (now `rotR` (_slow t $ toRational <$> envLR)))) t now pats+jumpMod' :: Int -> Int -> Time -> [ControlPattern] -> ControlPattern+jumpMod' = _jumpMod' --- wash :: (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Time -> Time -> Time -> Time -> [Pattern a] -> Pattern a+mortal ::+ Time -> Time -> Time -> [ControlPattern] -> ControlPattern+mortal = _mortal -{- | `anticipate` is an increasing comb filter.+interpolate :: Time -> [ControlPattern] -> ControlPattern+interpolate = _interpolate -Build up some tension, culminating in a _drop_ to the new pattern after 8 cycles.--}+interpolateIn ::+ Time -> Time -> [ControlPattern] -> ControlPattern+interpolateIn = _interpolateIn++clutch :: Time -> [Pattern a] -> Pattern a+clutch = _clutch++clutchIn :: Time -> Time -> [Pattern a] -> Pattern a+clutchIn = _clutchIn++anticipateIn :: Time -> Time -> [ControlPattern] -> ControlPattern+anticipateIn = _anticipateIn+ anticipate :: Time -> [ControlPattern] -> ControlPattern-anticipate = anticipateIn 8+anticipate = _anticipate
− src/Sound/Tidal/UI.hs
@@ -1,2900 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}--{-- UI.hs - Tidal's main 'user interface' functions, for transforming- patterns, building on the Core ones.- Copyright (C) 2020, Alex McLean and contributors-- This library is free software: you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this library. If not, see <http://www.gnu.org/licenses/>.--}--{-|- This module provides the main user interface functions, including sources- of randomness and transformations of patterns. All these functions are available- in the context of the TidalCycles REPL.-- Many functions in this module taking 'Pattern' values as arguments have a- corresponding function with an underscore prepended to its name (e.g.- 'degradeBy' and '_degradeBy'). These functions accept plain values, not- 'Pattern's, and are generally intended for those developing or extending Tidal.---}--module Sound.Tidal.UI where--import Prelude hiding ((<*), (*>))--import Data.Char (digitToInt, isDigit, ord)-import Data.Bits (testBit, Bits, xor, shiftL, shiftR)--import Data.Ratio ((%), Ratio)-import Data.Fixed (mod')-import Data.List (sort, sortOn, findIndices, elemIndex, groupBy, transpose, intercalate, findIndex)-import Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe)-import qualified Data.Text as T-import qualified Data.Map.Strict as Map-import Data.Bool (bool)--import Sound.Tidal.Bjorklund (bjorklund)-import Sound.Tidal.Core-import qualified Sound.Tidal.Params as P-import Sound.Tidal.Pattern-import Sound.Tidal.Utils----------------------------------------------------------------------------- * UI---- ** Randomisation---{-|-An implementation of the well-known @xorshift@ random number generator.-Given a seed number, generates a reasonably random number out of it.-This is an efficient algorithm suitable for use in tight loops and used-to implement the below functions, which are used to implement 'rand'.--See George Marsaglia (2003). ["Xorshift RNGs"](https://www.jstatsoft.org/article/view/v008i14),-in Journal of Statistical Software, pages 8–14.---}-xorwise :: Int -> Int-xorwise x =- let a = xor (shiftL x 13) x- b = xor (shiftR a 17) a- in xor (shiftL b 5) b---- stretch 300 cycles over the range of [0,2**29 == 536870912) then apply the xorshift algorithm-timeToIntSeed :: RealFrac a => a -> Int-timeToIntSeed = xorwise . truncate . (* 536870912) . snd . (properFraction :: (RealFrac a => a -> (Int,a))) . (/ 300)--intSeedToRand :: Fractional a => Int -> a-intSeedToRand = (/ 536870912) . realToFrac . (`mod` 536870912)--timeToRand :: (RealFrac a, Fractional b) => a -> b-timeToRand = intSeedToRand . timeToIntSeed--timeToRands :: (RealFrac a, Fractional b) => a -> Int -> [b]-timeToRands t n = timeToRands' (timeToIntSeed t) n--timeToRands' :: Fractional a => Int -> Int -> [a]-timeToRands' seed n- | n <= 0 = []- | otherwise = (intSeedToRand seed) : (timeToRands' (xorwise seed) (n-1))--{-|--@rand@ is an oscillator that generates a continuous pattern of (pseudo-)random-numbers between 0 and 1.--For example, to randomly pan around the stereo field:--> d1 $ sound "bd*8" # pan rand--Or to enjoy a randomised speed from 0.5 to 1.5, add 0.5 to it:--> d1 $ sound "arpy*4" # speed (rand + 0.5)--To make the snares randomly loud and quiet:--> sound "sn sn ~ sn" # gain rand--Numbers coming from this pattern are \'seeded\' by time. So if you reset time-(using 'resetCycles', 'setCycle', or 'cps') the random pattern will emit the-exact same _random_ numbers again.--In cases where you need two different random patterns, you can shift-one of them around to change the time from which the _random_ pattern-is read, note the difference:--> jux (# gain rand) $ sound "sn sn ~ sn" # gain rand--and with the juxed version shifted backwards for 1024 cycles:--> jux (# ((1024 <~) $ gain rand)) $ sound "sn sn ~ sn" # gain rand--}-rand :: Fractional a => Pattern a-rand = Pattern (\(State a@(Arc s e) _) -> [Event (Context []) Nothing a (realToFrac $ (timeToRand ((e + s)/2) :: Double))])---- | Boolean rand - a continuous stream of true\/false values, with a 50\/50 chance.-brand :: Pattern Bool-brand = _brandBy 0.5---- | Boolean rand with probability as input, e.g. @brandBy 0.25@ produces trues 25% of the time.-brandBy :: Pattern Double -> Pattern Bool-brandBy probpat = innerJoin $ (\prob -> _brandBy prob) <$> probpat--_brandBy :: Double -> Pattern Bool-_brandBy prob = fmap (< prob) rand--{- | 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:--@-d1 $ segment 4 $ n (irand 5) # sound "drum"-@--}-irand :: Num a => Pattern Int -> Pattern a-irand = (>>= _irand)--_irand :: Num a => Int -> Pattern a-_irand i = fromIntegral . (floor :: Double -> Int) . (* fromIntegral i) <$> rand--{- | 1D Perlin (smooth) noise, works like 'rand' but smoothly moves between random-values each cycle. @perlinWith@ takes a pattern as the random number generator's-"input" instead of automatically using the cycle count.--> d1 $ s "arpy*32" # cutoff (perlinWith (saw * 4) * 2000)--will generate a smooth random pattern for the cutoff frequency which will-repeat every cycle (because the saw does).--The `perlin` function uses the cycle count as input and can be used much like @rand@.--}-perlinWith :: Fractional a => Pattern Double -> Pattern a-perlinWith p = fmap realToFrac $ (interp) <$> (p-pa) <*> (timeToRand <$> pa) <*> (timeToRand <$> pb) where- pa = (fromIntegral :: Int -> Double) . floor <$> p- pb = (fromIntegral :: Int -> Double) . (+1) . floor <$> p- interp x a b = a + smootherStep x * (b-a)- smootherStep x = 6.0 * x**5 - 15.0 * x**4 + 10.0 * x**3--{- | As 'perlin' with a suitable choice of input pattern (@'sig' 'fromRational'@).-- The @perlin@ function produces a new random value to move to every cycle. If- you want a new random value to be generated more or less frequently, you can use- fast or slow, respectively:-- > d1 $ sound "bd*32" # speed (fast 4 $ perlin + 0.5)- > d1 $ sound "bd*32" # speed (slow 4 $ perlin + 0.5)--}-perlin :: Fractional a => Pattern a-perlin = perlinWith (sig fromRational)--{-| @perlin2With@ is Perlin noise with a 2-dimensional input. This can be-useful for more control over how the randomness repeats (or doesn't).--@-d1- $ s "[supersaw:-12*32]"- # lpf (rangex 60 5000 $ perlin2With (cosine*2) (sine*2))- # lpq 0.3-@--The above will generate a smooth random cutoff pattern that repeats every cycle-without any reversals or discontinuities (because the 2D path is a circle).--See also: `perlin2`, which only needs one input because it uses the cycle count-as the second input.--}-perlin2With :: Pattern Double -> Pattern Double -> Pattern Double-perlin2With x y = (/2) . (+1) $ interp2 <$> xfrac <*> yfrac <*> dota <*> dotb <*> dotc <*> dotd where- fl = fmap ((fromIntegral :: Int -> Double) . floor)- ce = fmap ((fromIntegral :: Int -> Double) . (+1) . floor)- xfrac = x - fl x- yfrac = y - fl y- randAngle a b = 2 * pi * timeToRand (a + 0.0001 * b)- pcos x' y' = cos $ randAngle <$> x' <*> y'- psin x' y' = sin $ randAngle <$> x' <*> y'- dota = pcos (fl x) (fl y) * xfrac + psin (fl x) (fl y) * yfrac- dotb = pcos (ce x) (fl y) * (xfrac - 1) + psin (ce x) (fl y) * yfrac- dotc = pcos (fl x) (ce y) * xfrac + psin (fl x) (ce y) * (yfrac - 1)- dotd = pcos (ce x) (ce y) * (xfrac - 1) + psin (ce x) (ce y) * (yfrac - 1)- interp2 x' y' a b c d = (1.0 - s x') * (1.0 - s y') * a + s x' * (1.0 - s y') * b- + (1.0 - s x') * s y' * c + s x' * s y' * d- s x' = 6.0 * x'**5 - 15.0 * x'**4 + 10.0 * x'**3---- | As 'perlin2' with a suitable choice of input pattern (@'sig' 'fromRational'@).-perlin2 :: Pattern Double -> Pattern Double-perlin2 = perlin2With (sig fromRational)--{- | Randomly picks an element from the given list.--@-sound "superpiano(3,8)" # note (choose ["a", "e", "g", "c"])-@--plays a melody randomly choosing one of the four notes \"a\", \"e\", \"g\", \"c\".--As with all continuous patterns, you have to be careful to give them structure; in this case choose gives you an infinitely detailed stream of random choices.--> choose = 'chooseBy' 'rand'--}-choose :: [a] -> Pattern a-choose = chooseBy rand---{- | Given a pattern of doubles, @chooseBy@ normalizes them so that each-corresponds to an index in the provided list. The returned pattern-contains the corresponding elements in the list.--It is like choose, but instead of selecting elements of the list randomly, it-uses the given pattern to select elements.--@'choose' = chooseBy 'rand'@--The following results in the pattern @"a b c"@:--> chooseBy "0 0.25 0.5" ["a","b","c","d"]--}-chooseBy :: Pattern Double -> [a] -> Pattern a-chooseBy _ [] = silence-chooseBy f xs = (xs !!!) . floor <$> range 0 (fromIntegral $ length xs) f--{- | Like @choose@, but works on an a list of tuples of values and weights--@-sound "superpiano(3,8)" # note (wchoose [("a",1), ("e",0.5), ("g",2), ("c",1)])-@--In the above example, the "a" and "c" notes are twice as likely to-play as the "e" note, and half as likely to play as the "g" note.--> wchoose = 'wchooseBy' 'rand'--}-wchoose :: [(a,Double)] -> Pattern a-wchoose = wchooseBy rand--{- | Given a pattern of probabilities and a list of @(value, weight)@ pairs,-@wchooseBy@ creates a @'Pattern' value@ by choosing values based on those-probabilities and weighted appropriately by the weights in the list of pairs.--}-wchooseBy :: Pattern Double -> [(a,Double)] -> Pattern a-wchooseBy pat pairs = match <$> pat- where- match r = values !! head (findIndices (> (r*total)) cweights)- cweights = scanl1 (+) (map snd pairs)- values = map fst pairs- total = sum $ map snd pairs--{-| @randcat ps@: does a @slowcat@ on the list of patterns @ps@ but- randomises the order in which they are played.-- > d1 $ sound (randcat ["bd*2 sn", "jvbass*3", "drum*2", "ht mt"])--}-randcat :: [Pattern a] -> Pattern a-randcat ps = spread' rotL (_segment 1 $ (% 1) . fromIntegral <$> (_irand (length ps) :: Pattern Int)) (slowcat ps)--{-| As 'randcat', but allowing weighted choice.-- In the following, the first pattern is the most likely and will play about half the time, and the last pattern is the less likely, with only a 10% probability.-- > d1 $ sound- > $ wrandcat- > [ ("bd*2 sn", 5), ("jvbass*3", 2), ("drum*2", 2), ("ht mt", 1) ]--}-wrandcat :: [(Pattern a, Double)] -> Pattern a-wrandcat ps = unwrap $ wchooseBy (segment 1 rand) ps--{- | @degrade@ randomly removes events from a pattern 50% of the time:--> d1 $ slow 2 $ degrade $ sound "[[[feel:5*8,feel*3] feel:3*8], feel*4]"-> # accelerate "-6"-> # speed "2"--The shorthand syntax for @degrade@ is a question mark: @?@. Using @?@-will allow you to randomly remove events from a portion of a pattern:--> d1 $ slow 2 $ sound "bd ~ sn bd ~ bd? [sn bd?] ~"--You can also use @?@ to randomly remove events from entire sub-patterns:--> d1 $ slow 2 $ sound "[[[feel:5*8,feel*3] feel:3*8]?, feel*4]"--}-degrade :: Pattern a -> Pattern a-degrade = _degradeBy 0.5--{- |-Similar to `degrade`, @degradeBy@ allows you to control the percentage of events that-are removed. For example, to remove events 90% of the time:--@-d1 $ slow 2 $ degradeBy 0.9 $ sound "[[[feel:5*8,feel*3] feel:3*8], feel*4]"- # accelerate "-6"- # speed "2"-@--You can also invoke this behavior in the shorthand notation by specifying a percentage, as a-number between 0 and 1, after the question mark:--@-d1 $ s "bd hh?0.8 bd hh?0.4"-@--}-degradeBy :: Pattern Double -> Pattern a -> Pattern a-degradeBy = tParam _degradeBy--_degradeBy :: Double -> Pattern a -> Pattern a-_degradeBy = _degradeByUsing rand---- Useful for manipulating random stream, e.g. to change 'seed'-_degradeByUsing :: Pattern Double -> Double -> Pattern a -> Pattern a-_degradeByUsing prand x p = fmap fst $ filterValues ((> x) . snd) $ (,) <$> p <* prand--{-|-As 'degradeBy', but the pattern of probabilities represents the chances to retain rather-than remove the corresponding element.--}-unDegradeBy :: Pattern Double -> Pattern a -> Pattern a-unDegradeBy = tParam _unDegradeBy--_unDegradeBy :: Double -> Pattern a -> Pattern a-_unDegradeBy x p = fmap fst $ filterValues ((<= x) . snd) $ (,) <$> p <* rand--degradeOverBy :: Int -> Pattern Double -> Pattern a -> Pattern a-degradeOverBy i tx p = unwrap $ (\x -> fmap fst $ filterValues ((> x) . snd) $ (,) <$> p <* fastRepeatCycles i rand) <$> slow (fromIntegral i) tx---{- | Use @sometimesBy@ to apply a given function "sometimes". For example, the-following code results in @density 2@ being applied about 25% of the time:--@-d1 $ sometimesBy 0.25 (density 2) $ sound "bd*8"-@--There are some aliases as well:--@-'sometimes' = sometimesBy 0.5-'often' = sometimesBy 0.75-'rarely' = sometimesBy 0.25-'almostNever' = sometimesBy 0.1-'almostAlways' = sometimesBy 0.9-@--}-sometimesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-sometimesBy x f pat = overlay (degradeBy x pat) (f $ unDegradeBy x pat)--{- | As 'sometimesBy', but applies the given transformation to the pattern in its entirety-before filtering its actual appearances. Less efficient than 'sometimesBy' but may-be useful when the passed pattern transformation depends on properties of the-pattern before probabilities are taken into account.--@-'sometimes'' = sometimesBy' 0.5-'often'' = sometimesBy' 0.75-'rarely'' = sometimesBy' 0.25-'almostNever'' = sometimesBy' 0.1-'almostAlways'' = sometimesBy' 0.9-@--}-sometimesBy' :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-sometimesBy' x f pat = overlay (degradeBy x pat) (unDegradeBy x $ f pat)---- | @sometimes@ is an alias for @'sometimesBy' 0.5@.-sometimes :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-sometimes = sometimesBy 0.5---- | @sometimes'@ is an alias for @'sometimesBy'' 0.5@.-sometimes' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-sometimes' = sometimesBy' 0.5---- | @often@ is an alias for @'sometimesBy' 0.75@.-often :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-often = sometimesBy 0.75---- | @often'@ is an alias for @'sometimesBy'' 0.75@.-often' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-often' = sometimesBy' 0.75---- | @rarely@ is an alias for @'sometimesBy' 0.25@.-rarely :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-rarely = sometimesBy 0.25---- | @rarely'@ is an alias for @'sometimesBy'' 0.25@.-rarely' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-rarely' = sometimesBy' 0.25---- | @almostNever@ is an alias for @'sometimesBy' 0.1@.-almostNever :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-almostNever = sometimesBy 0.1---- | @almostNever'@ is an alias for @'sometimesBy'' 0.1@.-almostNever' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-almostNever' = sometimesBy 0.1---- | @almostAlways@ is an alias for @'sometimesBy' 0.9@.-almostAlways :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-almostAlways = sometimesBy 0.9---- | @almostAlways'@ is an alias for @'sometimesBy'' 0.9@.-almostAlways' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-almostAlways' = sometimesBy' 0.9--{-|-Never apply a transformation, returning the pattern unmodified.--@never = flip const@--}--never :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-never = flip const--{-|-Apply the transformation to the pattern unconditionally.--@always = id@--}-always :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-always = id--{- | @someCyclesBy@ is a cycle-by-cycle version of @'sometimesBy'@.-- For example the following will either distort all of the events in a cycle, or- none of them:-- > d1 $ someCyclesBy 0.5 (# crush 2) $ n "0 1 [~ 2] 3" # sound "arpy"--}-someCyclesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-someCyclesBy pd f pat = innerJoin $ (\d -> _someCyclesBy d f pat) <$> pd--_someCyclesBy :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-_someCyclesBy x = when test- where test c = timeToRand (fromIntegral c :: Double) < x---- | Alias of 'someCyclesBy'.-somecyclesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-somecyclesBy = someCyclesBy---- | @someCycles = 'someCyclesBy' 0.5@-someCycles :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-someCycles = someCyclesBy 0.5---- | Alias of 'someCycles'.-somecycles :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-somecycles = someCycles---- ** Pattern transformations------ $patternTransformations------ Pattern transformations are functions generally of type--- @'Pattern' a -> 'Pattern' a@. This means they take a pattern of any type--- and return a pattern of that type.--{-|-@brak@ makes a pattern sound a bit like a breakbeat. It does this by, every-other cycle, squashing the pattern to fit half a cycle, and offsetting it by a-quarter of a cycle.--@-d1 $ sound (brak "bd sn kurt")-d1 $ brak $ sound "[feel feel:3, hc:3 hc:2 hc:4 ho:1]"-@--}-brak :: Pattern a -> Pattern a-brak = when ((== 1) . (`mod` 2)) (((1%4) `rotR`) . (\x -> fastcat [x, silence]))--{- | Divides a pattern into a given number of subdivisions, plays the subdivisions-in order, but increments the starting subdivision each cycle. The pattern-wraps to the first subdivision after the last subdivision is played.--Example:--@-d1 $ iter 4 $ sound "bd hh sn cp"-@--This will produce the following over four cycles:--@-bd hh sn cp-hh sn cp bd-sn cp bd hh-cp bd hh sn-@--There is also `iter'`, which shifts the pattern in the opposite direction.---}-iter :: Pattern Int -> Pattern c -> Pattern c-iter = tParam _iter--_iter :: Int -> Pattern a -> Pattern a-_iter n p = slowcat $ map (\i -> (fromIntegral i % fromIntegral n) `rotL` p) [0 .. (n-1)]--{- | @iter'@ is the same as @iter@, but decrements the starting-subdivision instead of incrementing it. For example,--@-d1 $ iter' 4 $ sound "bd hh sn cp"-@--produces--@-bd hh sn cp-cp bd hh sn-sn cp bd hh-hh sn cp bd-@--}-iter' :: Pattern Int -> Pattern c -> Pattern c-iter' = tParam _iter'--_iter' :: Int -> Pattern a -> Pattern a-_iter' n p = slowcat $ map (\i -> (fromIntegral i % fromIntegral n) `rotR` p) [0 .. (n-1)]--{- | @palindrome p@ applies @rev@ to @p@ every other cycle, so that the pattern-alternates between forwards and backwards. For example, these are equivalent:--@-d1 $ palindrome $ sound "arpy:0 arpy:1 arpy:2 arpy:3"-d1 $ slow 2 $ sound "arpy:0 arpy:1 arpy:2 arpy:3 arpy:3 arpy:2 arpy:1 arpy:0"-d1 $ every 2 rev $ sound "arpy:0 arpy:1 arpy:2 arpy:3"-@--}-palindrome :: Pattern a -> Pattern a-palindrome p = slowAppend p (rev p)---- | Degrades a pattern over the given time.-fadeOut :: Time -> Pattern a -> Pattern a-fadeOut dur p = innerJoin $ (`_degradeBy` p) <$> _slow dur envL---- | Alternate version to @fadeOut@ where you can provide the time from which the fade starts-fadeOutFrom :: Time -> Time -> Pattern a -> Pattern a-fadeOutFrom from dur p = innerJoin $ (`_degradeBy` p) <$> (from `rotR` _slow dur envL)---- | ’Undegrades’ a pattern over the given time.-fadeIn :: Time -> Pattern a -> Pattern a-fadeIn dur p = innerJoin $ (`_degradeBy` p) <$> _slow dur envLR---- | Alternate version to @fadeIn@ where you can provide the time from--- which the fade in starts-fadeInFrom :: Time -> Time -> Pattern a -> Pattern a-fadeInFrom from dur p = innerJoin $ (`_degradeBy` p) <$> (from `rotR` _slow dur envLR)--{- | The 'spread' function allows you to take a pattern transformation-which takes a parameter, such as `slow`, and provide several-parameters which are switched between. In other words it "spreads" a-function across several values.--Taking a simple high hat loop as an example:--> d1 $ sound "ho ho:2 ho:3 hc"--We can slow it down by different amounts, such as by a half:--> d1 $ slow 2 $ sound "ho ho:2 ho:3 hc"--Or by four thirds (i.e. speeding it up by a third; @4%3@ means four over-three):--> d1 $ slow (4%3) $ sound "ho ho:2 ho:3 hc"--But if we use `spread`, we can make a pattern which alternates between-the two speeds:--> d1 $ spread slow [2,4%3] $ sound "ho ho:2 ho:3 hc"--Note that if you pass @($)@ as the function to spread values over, you-can put functions as the list of values. ('spreadf' is an alias for @spread ($)@.)-For example:--> d1 $ spread ($) [density 2, rev, slow 2, striate 3, (# speed "0.8")]-> $ sound "[bd*2 [~ bd]] [sn future]*2 cp jvbass*4"--Above, the pattern will have these transforms applied to it, one at a time, per cycle:--* cycle 1: @density 2@ - pattern will increase in speed-* cycle 2: @rev@ - pattern will be reversed-* cycle 3: @slow 2@ - pattern will decrease in speed-* cycle 4: @striate 3@ - pattern will be granualized-* cycle 5: @(# speed "0.8")@ - pattern samples will be played back more slowly--After @(# speed "0.8")@, the transforms will repeat and start at @density 2@ again.--}-spread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b-spread f xs p = slowcat $ map (`f` p) xs---- | An alias for 'spread' consistent with 'fastspread'.-slowspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b-slowspread = spread--{- | @fastspread@ works the same as `spread`, but the result is squashed into a single cycle. If you gave four values to @spread@, then the result would seem to speed up by a factor of four. Compare these two:--> d1 $ spread chop [4,64,32,16] $ sound "ho ho:2 ho:3 hc"-> d1 $ fastspread chop [4,64,32,16] $ sound "ho ho:2 ho:3 hc"--There is also `slowspread`, which is an alias of @spread@.--}-fastspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b-fastspread f xs p = fastcat $ map (`f` p) xs--{- | There's a version of this function, `spread'` (pronounced "spread prime"), which takes a /pattern/ of parameters, instead of a list:--> d1 $ spread' slow "2 4%3" $ sound "ho ho:2 ho:3 hc"--This is quite a messy area of Tidal—due to a slight difference of-implementation this sounds completely different! One advantage of-using `spread'` though is that you can provide polyphonic parameters, e.g.:--> d1 $ spread' slow "[2 4%3, 3]" $ sound "ho ho:2 ho:3 hc"--}-spread' :: Monad m => (a -> b -> m c) -> m a -> b -> m c-spread' f vpat pat = vpat >>= \v -> f v pat--{- | @spreadChoose f xs p@ is similar to `slowspread` but picks values from-@xs@ at random, rather than cycling through them in order.--> d1 $ spreadChoose ($) [gap 4, striate 4] $ sound "ho ho:2 ho:3 hc"--}-spreadChoose :: (t -> t1 -> Pattern b) -> [t] -> t1 -> Pattern b-spreadChoose f vs p = do v <- _segment 1 (choose vs)- f v p---- | A shorter alias for 'spreadChoose'.-spreadr :: (t -> t1 -> Pattern b) -> [t] -> t1 -> Pattern b-spreadr = spreadChoose--{-| Decide whether to apply one or another function depending on the result of a test function, which is passed the current cycle as a number.--@-d1 $ ifp ((== 0) . flip mod 2)- (striate 4)- (# coarse "24 48")- $ sound "hh hc"-@--This will apply @'striate' 4@ for every /even/ cycle and apply @# coarse "24 48"@ for every /odd/.--Detail: As you can see the test function is arbitrary and does not rely on-anything Tidal specific. In fact it uses only plain Haskell functionality, that-is: it calculates the modulo of 2 of the current cycle which is either 0 (for-even cycles) or 1. It then compares this value against 0 and returns the result,-which is either @True@ or @False@. This is what the @ifp@ signature's first part-signifies: @(Int -> Bool)@, a function that takes a whole number and returns-either @True@ or @False@.--}-ifp :: (Int -> Bool) -> (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-ifp test f1 f2 p = splitQueries $ p {query = q}- where q a | test (floor $ start $ arc a) = query (f1 p) a- | otherwise = query (f2 p) a---- | @wedge t p p'@ combines patterns @p@ and @p'@ by squashing the--- @p@ into the portion of each cycle given by @t@, and @p'@ into the--- remainer of each cycle.--- > d1 $ wedge (1/4) (sound "bd*2 arpy*3 cp sn*2") (sound "odx [feel future]*2 hh hh")-wedge :: Pattern Time -> Pattern a -> Pattern a -> Pattern a-wedge pt pa pb = innerJoin $ (\t -> _wedge t pa pb) <$> pt--_wedge :: Time -> Pattern a -> Pattern a -> Pattern a-_wedge 0 _ p' = p'-_wedge 1 p _ = p-_wedge t p p' = overlay (_fastGap (1/t) p) (t `rotR` _fastGap (1/(1-t)) p')---{- | @whenmod@ has a similar form and behavior to `every`, but requires an-additional number. It applies the function to the pattern when the-remainder of the current loop number divided by the first parameter-is greater or equal than the second parameter.--For example, the following makes every other block of four loops twice-as dense:--> d1 $ whenmod 8 4 (density 2) (sound "bd sn kurt")--}-whenmod :: Pattern Time -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-whenmod a b f pat = innerJoin $ (\a' b' -> _whenmod a' b' f pat) <$> a <*> b--_whenmod :: Time -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-_whenmod a b = whenT (\t -> ((t `mod'` a) >= b ))---{- |-> superimpose f p = stack [p, f p]--@superimpose@ plays a modified version of a pattern at the same time as the-original pattern, resulting in two patterns being played at the same time. The-following are equivalent:--> d1 $ superimpose (fast 2) $ sound "bd sn [cp ht] hh"-> d1 $ stack [sound "bd sn [cp ht] hh",-> fast 2 $ sound "bd sn [cp ht] hh"-> ]--More examples:--> d1 $ superimpose (density 2) $ sound "bd sn [cp ht] hh"-> d1 $ superimpose ((# speed "2") . (0.125 <~)) $ sound "bd sn cp hh"---}-superimpose :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-superimpose f p = stack [p, f p]--{- | @trunc@ truncates a pattern so that only a fraction of the pattern is played.-The following example plays only the first quarter of the pattern:--> d1 $ trunc 0.25 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2"--You can also pattern the first parameter, for example to cycle through three values, one per cycle:--> d1 $ trunc "<0.75 0.25 1>" $ sound "bd sn:2 [mt rs] hc"--}-trunc :: Pattern Time -> Pattern a -> Pattern a-trunc = tParam _trunc--_trunc :: Time -> Pattern a -> Pattern a-_trunc t = compress (0, t) . zoomArc (Arc 0 t)--{- | @linger@ is similar to `trunc`, in that it truncates a pattern so that-only the first fraction of the pattern is played, but the truncated part of the-pattern loops to fill the remainder of the cycle.--> d1 $ linger 0.25 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2"--For example this repeats the first quarter, so you only hear a single repeating note:--> d1 $ linger 0.25 $ n "0 2 [3 4] 2" # sound "arpy"--or slightly more interesting, applied only every fourth cycle:--> d1 $ every 4 (linger 0.25) $ n "0 2 [3 4] 2" # sound "arpy"--or to a chopped-up sample:--> d1 $ every 2 (linger 0.25) $ loopAt 2 $ chop 8 $ sound "breaks125"--You can also pattern the first parameter, for example to cycle through three-values, one per cycle:--> d1 $ linger "<0.75 0.25 1>" $ sound "bd sn:2 [mt rs] hc"-> d1 $ linger "<0.25 0.5 1>" $ loopAt 2 $ chop 8 $ sound "breaks125"--If you give it a negative number, it will linger on the last part of-the pattern, instead of the start of it. E.g. to linger on the last-quarter:--> d1 $ linger (-0.25) $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2"--}-linger :: Pattern Time -> Pattern a -> Pattern a-linger = tParam _linger--_linger :: Time -> Pattern a -> Pattern a-_linger n p | n < 0 = _fast (1/n) $ zoomArc (Arc (1 + n) 1) p- | otherwise = _fast (1/n) $ zoomArc (Arc 0 n) p--{- |-Use @within@ to apply a function to only a part of a pattern. It takes two-arguments: a start time and an end time, specified as floats between 0 and 1,-which are applied to the relevant pattern. Note that the second argument must be-greater than the first for the function to have any effect.--For example, to apply @'fast' 2@ to only the first half of a pattern:--> d1 $ within (0, 0.5) (fast 2) $ sound "bd*2 sn lt mt hh hh hh hh"--Or, to apply @(# 'speed' "0.5")@ to only the last quarter of a pattern:--> d1 $ within (0.75, 1) (# speed "0.5") $ sound "bd*2 sn lt mt hh hh hh hh"--}-within :: (Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-within (s, e) f p = stack [filterWhen (\t -> cyclePos t >= s && cyclePos t < e) $ f p,- filterWhen (\t -> not $ cyclePos t >= s && cyclePos t < e) p- ]--withinArc :: Arc -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-withinArc (Arc s e) = within (s, e)--{- |-For many cases, @within'@ will function exactly as within.-The difference between the two occurs when applying functions that change the timing of notes such as 'fast' or '<~'.-within first applies the function to all notes in the cycle, then keeps the results in the specified interval, and then combines it with the old cycle (an "apply split combine" paradigm).-within' first keeps notes in the specified interval, then applies the function to these notes, and then combines it with the old cycle (a "split apply combine" paradigm).--For example, whereas using the standard version of within--> d1 $ within (0, 0.25) (fast 2) $ sound "bd hh cp sd"--sounds like:--> d1 $ sound "[bd hh] hh cp sd"--using this alternative version, within'--> d1 $ within' (0, 0.25) (fast 2) $ sound "bd hh cp sd"--sounds like:--> d1 $ sound "[bd bd] hh cp sd"---}-within' :: (Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-within' a@(s, e) f p =- stack [ filterWhen (\t -> cyclePos t >= s && cyclePos t < e) $ compress a $ f $ zoom a p- , filterWhen (\t -> not $ cyclePos t >= s && cyclePos t < e) p- ]--{-|-Reverse the part of the pattern sliced out by the @(start, end)@ pair.--@revArc a = within a rev@--}-revArc :: (Time, Time) -> Pattern a -> Pattern a-revArc a = within a rev--{- | You can use the @euclid@ function to apply a Euclidean algorithm over a-complex pattern, although the structure of that pattern will be lost:--> d1 $ euclid 3 8 $ sound "bd*2 [sn cp]"--In the above, three sounds are picked from the pattern on the right according-to the structure given by the @euclid 3 8@. It ends up picking two @bd@ sounds, a-@cp@ and missing the @sn@ entirely.--A negative first argument provides the inverse of the euclidean pattern.--These types of sequences use "Bjorklund's algorithm", which wasn't made for-music but for an application in nuclear physics, which is exciting. More-exciting still is that it is very similar in structure to the one of the first-known algorithms written in Euclid's book of elements in 300 BC. You can read-more about this in the paper-[The Euclidean Algorithm Generates Traditional Musical Rhythms](http://cgm.cs.mcgill.ca/~godfried/publications/banff.pdf)-by Toussaint. Some examples from this paper are included below,-including rotation as a third parameter in some cases (see 'euclidOff').--+------------+-----------------------------------------------------------------+-| Pattern | Example |-+============+=================================================================+-| (2,5) | A thirteenth century Persian rhythm called Khafif-e-ramal. |-+------------+-----------------------------------------------------------------+-| (3,4) | The archetypal pattern of the Cumbia from Colombia, as well as |-| | a Calypso rhythm from Trinidad. |-+------------+-----------------------------------------------------------------+-| (3,5,2) | Another thirteenth century Persian rhythm by the name of |-| | Khafif-e-ramal, as well as a Rumanian folk-dance rhythm. |-+------------+-----------------------------------------------------------------+-| (3,7) | A Ruchenitza rhythm used in a Bulgarian folk-dance. |-+------------+-----------------------------------------------------------------+-| (3,8) | The Cuban tresillo pattern. |-+------------+-----------------------------------------------------------------+-| (4,7) | Another Ruchenitza Bulgarian folk-dance rhythm. |-+------------+-----------------------------------------------------------------+-| (4,9) | The Aksak rhythm of Turkey. |-+------------+-----------------------------------------------------------------+-| (4,11) | The metric pattern used by Frank Zappa in his piece titled |-| | Outside Now. |-+------------+-----------------------------------------------------------------+-| (5,6) | Yields the York-Samai pattern, a popular Arab rhythm. |-+------------+-----------------------------------------------------------------+-| (5,7) | The Nawakhat pattern, another popular Arab rhythm. |-+------------+-----------------------------------------------------------------+-| (5,8) | The Cuban cinquillo pattern. |-+------------+-----------------------------------------------------------------+-| (5,9) | A popular Arab rhythm called Agsag-Samai. |-+------------+-----------------------------------------------------------------+-| (5,11) | The metric pattern used by Moussorgsky in |-| | Pictures at an Exhibition. |-+------------+-----------------------------------------------------------------+-| (5,12) | The Venda clapping pattern of a South African children’s song. |-+------------+-----------------------------------------------------------------+-| (5,16) | The Bossa-Nova rhythm necklace of Brazil. |-+------------+-----------------------------------------------------------------+-| (7,8) | A typical rhythm played on the Bendir (frame drum). |-+------------+-----------------------------------------------------------------+-| (7,12) | A common West African bell pattern. |-+------------+-----------------------------------------------------------------+-| (7,16,14) | A Samba rhythm necklace from Brazil. |-+------------+-----------------------------------------------------------------+-| (9,16) | A rhythm necklace used in the Central African Republic. |-+------------+-----------------------------------------------------------------+-| (11,24,14) | A rhythm necklace of the Aka Pygmies of Central Africa. |-+------------+-----------------------------------------------------------------+-| (13,24,5) | Another rhythm necklace of the Aka Pygmies of the upper Sangha. |-+------------+-----------------------------------------------------------------+--There was once a shorter alias @e@ for this function. It has been removed, but you-may see references to it in older Tidal code.--}-euclid :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a-euclid = tParam2 _euclid--_euclid :: Int -> Int -> Pattern a -> Pattern a-_euclid n k a | n >= 0 = fastcat $ fmap (bool silence a) $ bjorklund (n,k)- | otherwise = fastcat $ fmap (bool a silence) $ bjorklund (-n,k)--{- |--@euclidFull n k pa pb@ stacks @'euclid' n k pa@ with @'euclidInv' n k pb@. That-is, it plays one pattern on the euclidean rhythm and a different pattern on-the off-beat.--For example, to implement the traditional flamenco rhythm, you could use hard-claps for the former and soft claps for the latter:--> d1 $ euclidFull 3 7 "realclaps" ("realclaps" # gain 0.8)---}-euclidFull :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a-euclidFull n k pa pb = stack [ euclid n k pa, euclidInv n k pb ]---- | Less expressive than 'euclid' due to its constrained types, but may be more efficient.-_euclidBool :: Int -> Int -> Pattern Bool -- TODO: add 'euclidBool'?-_euclidBool n k | n >= 0 = fastFromList $ bjorklund (n,k)- | otherwise = fastFromList $ fmap (not) $ bjorklund (-n,k)--_euclid' :: Int -> Int -> Pattern a -> Pattern a-_euclid' n k p = fastcat $ map (\x -> if x then p else silence) (bjorklund (n,k))--{- |-As 'euclid', but taking a third rotational parameter corresponding to the onset-at which to start the rhythm.--}-euclidOff :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a-euclidOff = tParam3 _euclidOff---- | A shorter alias for 'euclidOff'.-eoff :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a-eoff = euclidOff--_euclidOff :: Int -> Int -> Int -> Pattern a -> Pattern a-_euclidOff _ 0 _ _ = silence-_euclidOff n k s p = (rotL $ fromIntegral s%fromIntegral k) (_euclid n k p)---- | As 'euclidOff', but specialized to 'Bool'. May be more efficient than 'euclidOff'.-euclidOffBool :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern Bool -> Pattern Bool-euclidOffBool = tParam3 _euclidOffBool--_euclidOffBool :: Int -> Int -> Int -> Pattern Bool -> Pattern Bool-_euclidOffBool _ 0 _ _ = silence-_euclidOffBool n k s p = ((fromIntegral s % fromIntegral k) `rotL`) ((\a b -> if b then a else not a) <$> _euclidBool n k <*> p)--distrib :: [Pattern Int] -> Pattern a -> Pattern a-distrib ps p = do p' <- sequence ps- _distrib p' p--_distrib :: [Int] -> Pattern a -> Pattern a-_distrib xs p = boolsToPat (foldr distrib' (replicate (last xs) True) (reverse $ layers xs)) p- where- distrib' :: [Bool] -> [Bool] -> [Bool]- distrib' [] _ = []- distrib' (_:a) [] = False : distrib' a []- distrib' (True:a) (x:b) = x : distrib' a b- distrib' (False:a) b = False : distrib' a b- layers = map bjorklund . (zip<*>tail)- boolsToPat a b' = flip const <$> filterValues (== True) (fastFromList a) <* b'--{-| @euclidInv@ fills in the blanks left by `euclid`, i.e., it inverts the-pattern.--For example, whereas @euclid 3 8 "x"@ produces--> "x ~ ~ x ~ ~ x ~"--@euclidInv 3 8 "x"@ produces--> "~ x x ~ x x ~ x"--As another example, in--> d1 $ stack [ euclid 5 8 $ s "bd"-> , euclidInv 5 8 $ s "hh27"-> ]--the hi-hat event fires on every one of the eight even beats that the bass drum-does not.--}-euclidInv :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a-euclidInv = tParam2 _euclidInv--_euclidInv :: Int -> Int -> Pattern a -> Pattern a-_euclidInv n k a = _euclid (-n) k a--index :: Real b => b -> Pattern b -> Pattern c -> Pattern c-index sz indexpat pat =- spread' (zoom' $ toRational sz) (toRational . (*(1-sz)) <$> indexpat) pat- where- zoom' tSz s = zoomArc (Arc s (s+tSz))--{---- | @prrw f rot (blen, vlen) beatPattern valuePattern@: pattern rotate/replace.-prrw :: (a -> b -> c) -> Int -> (Time, Time) -> Pattern a -> Pattern b -> Pattern c-prrw f rot (blen, vlen) beatPattern valuePattern =- let- ecompare (_,e1,_) (_,e2,_) = compare (fst e1) (fst e2)- beats = sortBy ecompare $ arc beatPattern (0, blen)- values = fmap thd' . sortBy ecompare $ arc valuePattern (0, vlen)- cycles = blen * (fromIntegral $ lcm (length beats) (length values) `div` (length beats))- in- _slow cycles $ stack $ zipWith- (\( _, (start, end), v') v -> (start `rotR`) $ densityGap (1 / (end - start)) $ pure (f v' v))- (sortBy ecompare $ arc (_fast cycles $ beatPattern) (0, blen))- (drop (rot `mod` length values) $ cycle values)---- | @prr rot (blen, vlen) beatPattern valuePattern@: pattern rotate/replace.-prr :: Int -> (Time, Time) -> Pattern String -> Pattern b -> Pattern b-prr = prrw $ flip const--{-|-@preplace (blen, plen) beats values@ combines the timing of @beats@ with the values-of @values@. Other ways of saying this are:-* sequential convolution-* @values@ quantized to @beats@.--Examples:--@-d1 $ sound $ preplace (1,1) "x [~ x] x x" "bd sn"-d1 $ sound $ preplace (1,1) "x(3,8)" "bd sn"-d1 $ sound $ "x(3,8)" <~> "bd sn"-d1 $ sound "[jvbass jvbass:5]*3" |+| (shape $ "1 1 1 1 1" <~> "0.2 0.9")-@--It is assumed the pattern fits into a single cycle. This works well with-pattern literals, but not always with patterns defined elsewhere. In those cases-use @preplace@ and provide desired pattern lengths:-@-let p = slow 2 $ "x x x"--d1 $ sound $ preplace (2,1) p "bd sn"-@--}-preplace :: (Time, Time) -> Pattern String -> Pattern b -> Pattern b-preplace = preplaceWith $ flip const---- | @prep@ is an alias for preplace.-prep :: (Time, Time) -> Pattern String -> Pattern b -> Pattern b-prep = preplace--preplace1 :: Pattern String -> Pattern b -> Pattern b-preplace1 = preplace (1, 1)--preplaceWith :: (a -> b -> c) -> (Time, Time) -> Pattern a -> Pattern b -> Pattern c-preplaceWith f (blen, plen) = prrw f 0 (blen, plen)--prw :: (a -> b -> c) -> (Time, Time) -> Pattern a -> Pattern b -> Pattern c-prw = preplaceWith--preplaceWith1 :: (a -> b -> c) -> Pattern a -> Pattern b -> Pattern c-preplaceWith1 f = prrw f 0 (1, 1)--prw1 :: (a -> b -> c) -> Pattern a -> Pattern b -> Pattern c-prw1 = preplaceWith1--(<~>) :: Pattern String -> Pattern b -> Pattern b-(<~>) = preplace (1, 1)---- | @protate len rot p@ rotates pattern @p@ by @rot@ beats to the left.--- @len@: length of the pattern, in cycles.--- Example: @d1 $ every 4 (protate 2 (-1)) $ slow 2 $ sound "bd hh hh hh"@-protate :: Time -> Int -> Pattern a -> Pattern a-protate len rot p = prrw (flip const) rot (len, len) p p--prot :: Time -> Int -> Pattern a -> Pattern a-prot = protate--prot1 :: Int -> Pattern a -> Pattern a-prot1 = protate 1--{-| The @<<~@ operator rotates a unit pattern to the left, similar to @<~@,-but by events rather than linear time. The timing of the pattern remains constant:--@-d1 $ (1 <<~) $ sound "bd ~ sn hh"--- will become-d1 $ sound "sn ~ hh bd"-@ -}--(<<~) :: Int -> Pattern a -> Pattern a-(<<~) = protate 1---- | @~>>@ is like @<<~@ but for shifting to the right.-(~>>) :: Int -> Pattern a -> Pattern a-(~>>) = (<<~) . (0-)---- | @pequal cycles p1 p2@: quickly test if @p1@ and @p2@ are the same.-pequal :: Ord a => Time -> Pattern a -> Pattern a -> Bool-pequal cycles p1 p2 = (sort $ arc p1 (0, cycles)) == (sort $ arc p2 (0, cycles))--}--{- | @rot n p@ "rotates" the values in a pattern @p@ by @n@ beats to the left,-preserving its structure. For example, in the following, each value will shift-to its neighbour's position one step to the left, so that @b@ takes the place of-@a@, @a@ of @c@, and @c@ of @b@:--> rot 1 "a ~ b c"--The result is equivalent of:--> "b ~ c a"--The first parameter is the number of steps, and may be given as a pattern. For example, in--> d1 $ rot "<0 0 1 3>" $ n "0 ~ 1 2 0 2 ~ 3*2" # sound "drum"--the pattern will not be rotated for the first two cycles, but will rotate it-by one the third cycle, and by three the fourth cycle.--Additional example:--> d1 $ every 4 (rot 2) $ slow 2 $ sound "bd hh hh hh"--}-rot :: Ord a => Pattern Int -> Pattern a -> Pattern a-rot = tParam _rot---- | Calculates a whole cycle, rotates it, then constrains events to the original query arc.-_rot :: Ord a => Int -> Pattern a -> Pattern a-_rot i pat = splitQueries $ pat {query = \st -> f st (query pat (st {arc = wholeCycle (arc st)}))}- where -- TODO maybe events with the same arc (part+whole) should be- -- grouped together in the rotation?- f st es = constrainEvents (arc st) $ shiftValues $ sort $ defragParts es- shiftValues es | i >= 0 =- zipWith (\e s -> e {value = s}) es- (drop i $ cycle $ map value es)- | otherwise =- 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 e =- do- 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 discrete one.--In the following example, the pattern originates from the shape of a sine-wave, a continuous pattern. Without @segment@, the samples will get triggered-at an undefined frequency which may be very high.--> d1 $ n (slow 2 $ segment 16 $ range 0 32 $ sine) # sound "amencutup"--}-segment :: Pattern Time -> Pattern a -> Pattern a-segment = tParam _segment--_segment :: Time -> Pattern a -> Pattern a-_segment n p = _fast n (pure id) <* p---- | @discretise@: the old (deprecated) name for 'segment'-discretise :: Pattern Time -> Pattern a -> Pattern a-discretise = segment---- @fromNote p@: converts a pattern of human-readable pitch names--- into pitch numbers. For example, @"cs2"@ will be parsed as C Sharp--- in the 2nd octave with the result of @11@, and @"b-3"@ as--- @-25@. Pitches can be decorated using:------ * s = Sharp, a half-step above (@"gs-1"@)--- * f = Flat, a half-step below (@"gf-1"@)--- * n = Natural, no decoration (@"g-1" and "gn-1"@ are equivalent)--- * ss = Double sharp, a whole step above (@"gss-1"@)--- * ff = Double flat, a whole step below (@"gff-1"@)------ Note that TidalCycles now assumes that middle C is represented by--- the value 0, rather than the previous value of 60. This function--- is similar to previously available functions @tom@ and @toMIDI@,--- but the default octave is now 0 rather than 5.-{---definition moved to Parse.hs ..--toMIDI :: Pattern String -> Pattern Int-toMIDI p = fromJust <$> (filterValues (isJust) (noteLookup <$> p))- where- noteLookup :: String -> Maybe Int- noteLookup [] = Nothing- noteLookup s | not (last s `elem` ['0' .. '9']) = noteLookup (s ++ "0")- | not (isLetter (s !! 1)) = noteLookup((head s):'n':(tail s))- | otherwise = parse s- parse x = (\a b c -> a+b+c) <$> pc x <*> sym x <*> Just(12*digitToInt (last x))- pc x = lookup (head x) [('c',0),('d',2),('e',4),('f',5),('g',7),('a',9),('b',11)]- sym x = lookup (init (tail x)) [("s",1),("f",-1),("n",0),("ss",2),("ff",-2)]--}---- @tom p@: Alias for @toMIDI@.--- tom = toMIDI---{- | The `fit` function takes a pattern of integer numbers, which are used to select values from the given list. What makes this a bit strange is that only a given number of values are selected each cycle. For example:--> d1 $ sound (fit 3 ["bd", "sn", "arpy", "arpy:1", "casio"] "0 [~ 1] 2 1")--The above fits three samples into the pattern, i.e. for the first cycle this-will be @"bd"@, @"sn"@ and @"arpy"@, giving the result @"bd [~ sn] arpy sn"@-(note that we start counting at zero, so that 0 picks the first value). The-following cycle the /next/ three values in the list will be picked, i.e.-@"arpy:1"@, @"casio"@ and @"bd"@, giving the pattern-@"arpy:1 [~ casio] bd casio"@ (note that the list wraps round here).---}-fit :: Pattern Int -> [a] -> Pattern Int -> Pattern a-fit pint xs p = (tParam func) pint (xs,p)- where func i (xs',p') = _fit i xs' p'--_fit :: Int -> [a] -> Pattern Int -> Pattern a-_fit perCycle xs p = (xs !!!) <$> (p {query = map (\e -> fmap (+ pos e) e) . query p})- where pos e = perCycle * floor (start $ part e)---permstep :: RealFrac b => Int -> [a] -> Pattern b -> Pattern a-permstep nSteps things p = unwrap $ (\n -> fastFromList $ concatMap (\x -> replicate (fst x) (snd x)) $ zip (ps !! floor (n * fromIntegral (length ps - 1))) things) <$> _segment 1 p- where ps = permsort (length things) nSteps- deviance avg xs = sum $ map (abs . (avg-) . fromIntegral) xs- permsort n total = map fst $ sortOn snd $ map (\x -> (x,deviance (fromIntegral total / (fromIntegral n :: Double)) x)) $ perms n total- perms 0 _ = []- perms 1 n = [[n]]- perms n total = concatMap (\x -> map (x:) $ perms (n-1) (total-x)) [1 .. (total-(n-1))]--{-|- @struct a b@ structures pattern @b@ in terms of the pattern of boolean- values @a@. Only @True@ values in the boolean pattern are used.-- The following are equivalent:-- > d1 $ struct ("t ~ t*2 ~") $ sound "cp"- > d1 $ sound "cp ~ cp*2 ~"-- The structure comes from a boolean pattern, i.e. a binary pattern containing- true or false values. Above we only used true values, denoted by @t@. It’s also- possible to include false values with @f@, which @struct@ will simply treat as- silence. For example, this would have the same outcome as the above:-- > d1 $ struct ("t f t*2 f") $ sound "cp"-- These true / false binary patterns become useful when you conditionally- manipulate them, for example, ‘inverting’ the values using 'every' and 'inv':-- > d1 $ struct (every 3 inv "t f t*2 f") $ sound "cp"-- In the above, the boolean values will be ‘inverted’ every third cycle, so that- the structure comes from the @f@s rather than @t@. Note that euclidean patterns- also create true/false values, for example:-- > d1 $ struct (every 3 inv "t(3,8)") $ sound "cp"-- In the above, the euclidean pattern creates @"t f t f t f f t"@ which gets- inverted to @"f t f t f t t f"@ every third cycle. Note that if you prefer you- can use 1 and 0 instead of @t@ and @f@.--}-struct :: Pattern Bool -> Pattern a -> Pattern a-struct ps pv = filterJust $ (\a b -> if a then Just b else Nothing ) <$> ps <* pv---- | @substruct a b@: similar to @struct@, but each event in pattern @a@ gets replaced with pattern @b@, compressed to fit the timespan of the event.-substruct :: Pattern Bool -> Pattern b -> Pattern b-substruct s p = p {query = f}- where f st =- concatMap ((\a' -> queryArc (compressArcTo a' p) a') . wholeOrPart) $ filter value $ query s st--randArcs :: Int -> Pattern [Arc]-randArcs n =- do rs <- mapM (\x -> pure (toRational x / toRational n) <~ choose [1 :: Int,2,3]) [0 .. (n-1)]- let rats = map toRational rs- total = sum rats- pairs = pairUp $ accumulate $ map (/total) rats- return pairs- where pairUp [] = []- pairUp xs = Arc 0 (head xs) : pairUp' xs- pairUp' [] = []- pairUp' [_] = []- pairUp' [a, _] = [Arc a 1]- pairUp' (a:b:xs) = Arc a b: pairUp' (b:xs)----- 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 (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)) $- enumerate $ value $ head $- queryArc (randArcs n) (Arc (sam s) (nextSam s))- (Arc s e) = arc st---- 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 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 _ _ = []--{- | @stripe n p@: repeats pattern @p@ @n@ times per cycle, i.e., the first-parameter gives the number of cycles to operate over. So, it is similar to-@fast@, but with random durations. For example @stripe 2@ will repeat a pattern-twice, over two cycles--In the following example, the start of every third repetition of the @d1@-pattern will match with the clap on the @d2@ pattern.--> d1 $ stripe 3 $ sound "bd sd ~ [mt ht]"-> d2 $ sound "cp"--The repetitions will be contiguous (touching, but not overlapping) and the-durations will add up to a single cycle. @n@ can be supplied as a pattern of-integers.--}-stripe :: Pattern Int -> Pattern a -> Pattern a-stripe = tParam _stripe--_stripe :: Int -> Pattern a -> Pattern a-_stripe = substruct' . randStruct---- | @slowstripe n p@ is the same as @stripe@, but the result is also--- @n@ times slower, so that the mean average duration of the stripes--- is exactly one cycle, and every @n@th stripe starts on a cycle--- boundary (in Indian classical terms, the /sam/).-slowstripe :: Pattern Int -> Pattern a -> Pattern a-slowstripe n = slow (toRational <$> n) . stripe n---- Lindenmayer patterns, these go well with the step sequencer--- general rule parser (strings map to strings)-parseLMRule :: String -> [(String,String)]-parseLMRule s = map (splitOn ':') commaSplit- where splitOn sep str = splitAt (fromJust $ elemIndex sep str)- $ filter (/= sep) str- commaSplit = map T.unpack $ T.splitOn (T.pack ",") $ T.pack s---- specific parser for step sequencer (chars map to string)--- ruleset in form "a:b,b:ab"-parseLMRule' :: String -> [(Char, String)]-parseLMRule' str = map fixer $ parseLMRule str- where fixer (c,r) = (head c, r)--{- | Returns the @n@th iteration of a- [Lindenmayer System](https://en.wikipedia.org/wiki/L-system)- with given start sequence.-- It takes an integer @b@, a Lindenmayer system rule set, and an initiating- string as input in order to generate an L-system tree string of @b@ iterations.- It can be used in conjunction with a step function to convert the generated- string into a playable pattern. For example,-- > d1 $ slow 16- > $ sound- > $ step' ["feel:0", "sn:1", "bd:0"]- > ( take 512- > $ lindenmayer 5 "0:1~~~,1:0~~~2~~~~~0~~~2~,2:2~1~,~:~~1~" "0"- > )-- generates an L-system with initiating string @"0"@ and maps it onto a list- of samples.-- Complex L-system trees with many rules and iterations can sometimes result in unwieldy strings. Using @take n@ to only use the first @n@ elements of the string, along with a 'slow' function, can make the generated values more manageable.---}-lindenmayer :: Int -> String -> String -> String-lindenmayer _ _ [] = []-lindenmayer 1 r (c:cs) = fromMaybe [c] (lookup c $ parseLMRule' r)- ++ lindenmayer 1 r cs-lindenmayer n r s = iterate (lindenmayer 1 r) s !! n--{- | @lindenmayerI@ converts the resulting string into a a list of integers-with @fromIntegral@ applied (so they can be used seamlessly where floats or-rationals are required) -}-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) [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 = [ 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:-->>> 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 (\(State a@(Arc s _) _) ->- queryArc (listToPat $ runMarkov n tp xi (sam s)) a)--{-|-@mask@ takes a boolean pattern and ‘masks’ another pattern with it. That is,-events are only carried over if they match within a ‘true’ event in the binary-pattern, i.e., it removes events from the second pattern that don't start during-an event from the first.--For example, consider this kind of messy rhythm without any rests.--> d1 $ sound (slowcat ["sn*8", "[cp*4 bd*4, hc*5]"]) # n (run 8)--If we apply a mask to it--@-d1 $ s ( mask ("1 1 1 ~ 1 1 ~ 1" :: Pattern Bool)- ( slowcat ["sn*8", "[cp*4 bd*4, bass*5]"] )- )- # n (run 8)-@--Due to the use of `slowcat` here, the same mask is first applied to @"sn*8"@ and-in the next cycle to @"[cp*4 bd*4, hc*5]"@.--You could achieve the same effect by adding rests within the `slowcat` patterns,-but mask allows you to do this more easily. It kind of keeps the rhythmic-structure and you can change the used samples independently, e.g.,--@-d1 $ s ( mask ("1 ~ 1 ~ 1 1 ~ 1")- ( slowcat ["can*8", "[cp*4 sn*4, jvbass*16]"] )- )- # n (run 8)-@--}-mask :: Pattern Bool -> Pattern a -> Pattern a-mask b p = const <$> p <* (filterValues id b)---- TODO: refactor towards union-enclosingArc :: [Arc] -> Arc-enclosingArc [] = Arc 0 1-enclosingArc as = Arc (minimum (map start as)) (maximum (map stop as))--{-|- @stretch@ takes a pattern, and if there’s silences at the start or end of the- current cycle, it will zoom in to avoid them. The following are equivalent:-- > d1 $ note (stretch "~ 0 1 5 8*4 ~") # s "superpiano"- > d1 $ note "0 1 5 8*4" # s "superpiano"-- You can pattern silences on the extremes of a cycle to make changes to the rhythm:-- > d1 $ note (stretch "~ <0 ~> 1 5 8*4 ~") # s "superpiano"--}-stretch :: Pattern a -> Pattern a--- TODO - should that be whole or part?-stretch p = splitQueries $ p {query = q}- where q st = query (zoomArc (cycleArc $ enclosingArc $ map wholeOrPart $ query p (st {arc = Arc (sam s) (nextSam s)})) p) st- where s = start $ arc st--{- | @fit'@ is a generalization of `fit`, where the list is instead constructed-by using another integer pattern to slice up a given pattern. The first argument-is the number of cycles of that latter pattern to use when slicing. It's easier-to understand this with a few examples:--> d1 $ sound (fit' 1 2 "0 1" "1 0" "bd sn")--So what does this do? The first @1@ just tells it to slice up a single cycle of-@"bd sn"@. The @2@ tells it to select two values each cycle, just like the first-argument to @fit@. The next pattern @"0 1"@ is the "from" pattern which tells-it how to slice, which in this case means @"0"@ maps to @"bd"@, and @"1"@ maps-to @"sn"@. The next pattern @"1 0"@ is the "to" pattern, which tells it how to-rearrange those slices. So the final result is the pattern @"sn bd"@.--A more useful example might be something like--> d1 $ fit' 1 4 (run 4) "[0 3*2 2 1 0 3*2 2 [1*8 ~]]/2"-> $ chop 4-> $ (sound "breaks152" # unit "c")--which uses @chop@ to break a single sample into individual pieces, which @fit'@ then puts into a list (using the @run 4@ pattern) and reassembles according to the complicated integer pattern.--}-fit' :: Pattern Time -> Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a-fit' cyc n from to p = squeezeJoin $ _fit n mapMasks to- where mapMasks = [stretch $ mask (const True <$> filterValues (== i) from') p'- | i <- [0..n-1]]- p' = density cyc p- from' = density cyc from--{-|- Treats the given pattern @p@ as having @n@ chunks, and applies the function @f@ to one of those sections per cycle.- Running:- - from left to right if chunk number is positive- - from right to left if chunk number is negative-- > d1 $ chunk 4 (fast 4) $ sound "cp sn arpy [mt lt]"-- The following:-- > d1 $ chunk 4 (# speed 2) $ sound "bd hh sn cp"-- applies @(# speed 2)@ to the uppercased part of the cycle below:-- > BD hh sn cp- > bd HH sn cp- > bd hh SN cp- > bd hh sn CP--}-chunk :: Pattern Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-chunk npat f p = innerJoin $ (\n -> _chunk n f p) <$> npat--_chunk :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-_chunk n f p | n >= 0 = cat [withinArc (Arc (i % fromIntegral n) ((i+1) % fromIntegral n)) f p | i <- [0 .. fromIntegral n - 1]]- | otherwise = do i <- _slow (toRational (-n)) $ rev $ run (fromIntegral (-n))- withinArc (Arc (i % fromIntegral (-n)) ((i+1) % fromIntegral (-n))) f p---- | DEPRECATED, use 'chunk' with negative numbers instead-chunk' :: Integral a1 => Pattern a1 -> (Pattern a2 -> Pattern a2) -> Pattern a2 -> Pattern a2-chunk' npat f p = innerJoin $ (\n -> _chunk' n f p) <$> npat---- | DEPRECATED, use '_chunk' with negative numbers instead-_chunk' :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-_chunk' n f p = _chunk (-n) f p--{-|-@inside@ carries out an operation /inside/ a cycle.-For example, while @rev "0 1 2 3 4 5 6 7"@ is the same as @"7 6 5 4 3 2 1 0"@,-@inside 2 rev "0 1 2 3 4 5 6 7"@ gives @"3 2 1 0 7 6 5 4"@.--What this function is really doing is ‘slowing down’ the pattern by a given-factor, applying the given function to it, and then ‘speeding it up’ by the same-factor. In other words, this:--> inside 2 rev "0 1 2 3 4 5 6 7"--Is doing this:--> fast 2 $ rev $ slow 2 "0 1 2 3 4 5 6 7"--so rather than whole cycles, each half of a cycle is reversed.--}-inside :: Pattern Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a-inside np f p = innerJoin $ (\n -> _inside n f p) <$> np--_inside :: Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a-_inside n f p = _fast n $ f (_slow n p)--{-|-@outside@ is the inverse of the 'inside' function. @outside@ applies its function /outside/ the cycle.-Say you have a pattern that takes 4 cycles to repeat and apply the rev function:--> d1 $ rev $ cat [s "bd bd sn",s "sn sn bd", s"lt lt sd", s "sd sd bd"]--The above generates:--> d1 $ rev $ cat [s "sn bd bd",s "bd sn sn", s "sd lt lt", s "bd sd sd"]--However if you apply @outside@:--> d1 $ outside 4 (rev) $ cat [s "bd bd sn",s "sn sn bd", s"lt lt sd", s "sd sd bd"]--The result is:--> d1 $ rev $ cat [s "bd sd sd", s "sd lt lt", s "sn sn bd", s "bd bd sn"]--Notice that the whole idea has been reversed. What this function is really doing-is ‘speeding up’ the pattern by a given factor, applying the given function to-it, and then ‘slowing it down’ by the same factor. In other words, this:--> d1 $ slow 4 $ rev $ fast 4-> $ cat [s "bd bd sn",s "sn sn bd", s"lt lt sd", s "sd sd bd"]--This compresses the idea into a single cycle before rev operates and then slows it back to the original speed.--}-outside :: Pattern Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a-outside np f p = innerJoin $ (\n -> _outside n f p) <$> np--_outside :: Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a-_outside n = _inside (1/n)--{-|- Takes a pattern and loops only the first cycle of the pattern. For example, the following code will only play the bass drum sample:-- > d1 $ loopFirst $ s "<<bd*4 ht*8> cp*4>"-- This function combines with 'sometimes' to insert events from the first cycle randomly into subsequent cycles of the pattern:-- > d1 $ sometimes loopFirst $ s "<<bd*4 ht*8> cp*4>"--}-loopFirst :: Pattern a -> Pattern a-loopFirst p = splitQueries $ p {query = f}- where f st = map- (\(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)- s = start $ arc st--timeLoop :: Pattern Time -> Pattern a -> Pattern a-timeLoop n = outside n loopFirst--{-|- @seqPLoop@ will keep looping the sequence when it gets to the end:-- > d1 $ qtrigger $ seqPLoop- > [ (0, 12, sound "bd bd*2")- > , (4, 12, sound "hh*2 [sn cp] cp future*4")- > , (8, 12, sound (samples "arpy*8" (run 16)))- > ]--}-seqPLoop :: [(Time, Time, Pattern a)] -> Pattern a-seqPLoop ps = timeLoop (pure $ maxT - minT) $ minT `rotL` seqP ps- where minT = minimum $ map (\(x,_,_) -> x) ps- maxT = maximum $ map (\(_,x,_) -> x) ps--{-|-@toScale@ lets you turn a pattern of notes within a scale (expressed as a-list) to note numbers.--For example:--> toScale [0, 4, 7] "0 1 2 3"--will turn into the pattern @"0 4 7 12"@.--@toScale@ is handy for quickly applying a scale without naming it:--> d1 $ n (toScale [0,2,3,5,7,8,10] "0 1 2 3 4 5 6 7") # sound "superpiano"--This function assumes your scale fits within an octave; if that's not true,-use 'toScale''.--@toScale = toScale' 12@--}-toScale :: Num a => [a] -> Pattern Int -> Pattern a-toScale = toScale' 12--{- | As 'toScale', though allowing scales of arbitrary size.--An example: @toScale' 24 [0,4,7,10,14,17] (run 8)@ turns into @"0 4 7 10 14 17 24 28"@.--}-toScale' :: Num a => Int -> [a] -> Pattern Int -> Pattern a-toScale' _ [] = const silence-toScale' o s = fmap noteInScale- where octave x = x `div` length s- noteInScale x = (s !!! x) + fromIntegral (o * octave x)---{- | @swingBy x n@ divides a cycle into @n@ slices and delays the notes in the- second half of each slice by @x@ fraction of a slice. So if @x@ is 0 it does- nothing, 0.5 delays for half the note duration, and 1 will wrap around to- doing nothing again. The end result is a shuffle or swing-like rhythm. For- example, the following will delay every other @"hh"@ 1/3 of the way to the- next @"hh"@:-- > d1 $ swingBy (1/3) 4 $ sound "hh*8"--}-swingBy :: Pattern Time -> Pattern Time -> Pattern a -> Pattern a-swingBy x n = inside n (withinArc (Arc 0.5 1) (x ~>))--{-|-As 'swingBy', with the cycle division set to ⅓.--}-swing :: Pattern Time -> Pattern a -> Pattern a-swing = swingBy (pure $ 1%3)--{- | @cycleChoose@ is like `choose` but only picks a new item from the list- once each cycle.-- > d1 $ sound "drum ~ drum drum" # n (cycleChoose [0,2,3])--}-cycleChoose :: [a] -> Pattern a-cycleChoose = segment 1 . choose--{- | Internal function used by shuffle and scramble -}-_rearrangeWith :: Pattern Int -> Int -> Pattern a -> Pattern a-_rearrangeWith ipat n pat = innerJoin $ (\i -> _fast nT $ _repeatCycles n $ pats !! i) <$> ipat- where- pats = map (\i -> zoom (fromIntegral i / nT, fromIntegral (i+1) / nT) pat) [0 .. (n-1)]- nT :: Time- nT = fromIntegral n--{- | @shuffle n p@ evenly divides one cycle of the pattern @p@ into @n@ parts,-and returns a random permutation of the parts each cycle. For example,-@shuffle 3 "a b c"@ could return @"a b c"@, @"a c b"@, @"b a c"@, @"b c a"@,-@"c a b"@, or @"c b a"@. But it will /never/ return @"a a a"@, because that-is not a permutation of the parts.--This could also be called “sampling without replacement”.--}-shuffle :: Pattern Int -> Pattern a -> Pattern a-shuffle = tParam _shuffle--_shuffle :: Int -> Pattern a -> Pattern a-_shuffle n = _rearrangeWith (randrun n) n--{- | @scramble n p@ is like 'shuffle' but randomly selects from the parts-of @p@ instead of making permutations.-For example, @scramble 3 "a b c"@ will randomly select 3 parts from-@"a"@ @"b"@ and @"c"@, possibly repeating a single part.--This could also be called “sampling with replacement”.--}-scramble :: Pattern Int -> Pattern a -> Pattern a-scramble = tParam _scramble--_scramble :: Int -> Pattern a -> Pattern a-_scramble n = _rearrangeWith (_segment (fromIntegral n) $ _irand n) n--{-|-@randrun n@ generates a pattern of random integers less than @n@.--The following plays random notes in an octave:--@-d1 $ s "superhammond!12" # n (fromIntegral <$> randrun 13)-@---}-randrun :: Int -> Pattern Int-randrun 0 = silence-randrun n' =- splitQueries $ Pattern (\(State a@(Arc s _) _) -> events a $ sam s)- where events a seed = mapMaybe toEv $ zip arcs shuffled- where shuffled = map snd $ sortOn fst $ zip rs [0 .. (n'-1)]- rs = timeToRands seed n' :: [Double]- 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 (Context []) (Just a') a'' v---- ** Composing patterns--{- | The function @seqP@ allows you to define when-a sound within a list starts and ends. The code below contains three-separate patterns in a `stack`, but each has different start times-(zero cycles, eight cycles, and sixteen cycles, respectively). All-patterns stop after 128 cycles:--@-d1 $ seqP [- (0, 128, sound "bd bd*2"),- (8, 128, sound "hh*2 [sn cp] cp future*4"),- (16, 128, sound (samples "arpy*8" (run 16)))-]-@--}-seqP :: [(Time, Time, Pattern a)] -> Pattern a-seqP ps = stack $ map (\(s, e, p) -> playFor s e (sam s `rotR` p)) ps--{-|-The @ur@ function is designed for longer form composition, by allowing you to-create ‘patterns of patterns’ in a repeating loop. It takes four parameters:-how long the loop will take, a pattern giving the structure of the composition,-a lookup table for named patterns to feed into that structure, and a second-lookup table for named transformations\/effects.--The /ur-/ prefix [comes from German](https://en.wiktionary.org/wiki/ur-#German) and-means /proto-/ or /original/. For a mnemonic device, think of this function as-assembling a set of original patterns (ur-patterns) into a larger, newer whole.--Lets say you had three patterns (called @a@, @b@ and @c@), and that you wanted-to play them four cycles each, over twelve cycles in total. Here is one way to-do it:--@-let pats =- [ ( "a", stack [ n "c4 c5 g4 f4 f5 g4 e5 g4" # s "superpiano" # gain "0.7"- , n "[c3,g4,c4]" # s "superpiano"# gain "0.7"- ]- )- , ( "b", stack [ n "d4 c5 g4 f4 f5 g4 e5 g4" # s "superpiano" # gain "0.7"- , n "[d3,a4,d4]" # s "superpiano"# gain "0.7"- ]- )- , ( "c", stack [ n "f4 c5 g4 f4 f5 g4 e5 g4" # s "superpiano" # gain "0.7"- , n "[f4,c5,f4]" # s "superpiano"# gain "0.7"- ]- )- ]-in-d1 $ ur 12 "a b c" pats []-@--In the above, the fourth parameter is given as an empty list, but that is where-you can put another lookup table, of functions rather than patterns this time.-For example:--@-let- pats = ...- fx = [ ("reverb", ( # (room 0.8 # sz 0.99 # orbit 1)))- , ("faster", fast 2)- ]-in-d1 $ ur 12 "a b:reverb c:faster" pats fx-@--In this example, @b@ has the function applied that’s named as reverb, while @c@-is made to go faster. It’s also possible to schedule multiple patterns at once,-like in the following:--@-let pats = [ ("drums", s "drum cp*2")- , ("melody", s "arpy:2 arpy:3 arpy:5")- , ("craziness", s "cp:4*8" # speed ( sine + 0.5 ))- ]- fx = [("higher", ( # speed 2))]-in-d1 $ ur 8 "[drums, melody] [drums,craziness,melody] melody:higher" pats fx-@--}-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)- where split = wordsBy (==':')- getPat (s:xs) = (match s, transform xs)- -- TODO - check this really can't happen..- getPat _ = error "can't happen?"- match s = fromMaybe silence $ lookup s ps'- ps' = map (fmap (_fast t)) ps- adjust (a, (p, f)) = f a p- transform (x:_) a = transform' x a- transform _ _ = id- transform' str (Arc s e) p = s `rotR` inside (pure $ 1/(e-s)) (matchF str) p- matchF str = fromMaybe id $ lookup str fs- timedValues = withEvent (\(Event c (Just a) a' v) -> Event c (Just a) a' (a,v)) . filterDigital--{- | A simpler version of 'ur' that just provides name-value bindings that are- reflected in the provided pattern.-- @inhabit@ allows you to link patterns to some @String@, or in other words,- to give patterns a name and then call them from within another pattern of- @String@s.-- For example, we can make our own bassdrum, hi-hat and snaredrum kit:-- > do- > let drum = inhabit [ ("bd", s "sine" |- accelerate 1.5)- > , ("hh", s "alphabet:7" # begin 0.7 # hpf 7000)- > , ("sd", s "invaders:3" # speed 12)- > ]- > d1 $ drum "[bd*8?, [~hh]*4, sd(6,16)]"-- @inhabit@ can be very useful when using MIDI controlled drum machines, since you- can give understandable drum names to patterns of notes.--}-inhabit :: [(String, Pattern a)] -> Pattern String -> Pattern a-inhabit ps p = squeezeJoin $ (\s -> fromMaybe silence $ lookup s ps) <$> p--{- | @spaceOut xs p@ repeats a 'Pattern' @p@ at different durations given by the list of time values in @xs@. -}-spaceOut :: [Time] -> Pattern a -> Pattern a-spaceOut xs p = _slow (toRational $ sum xs) $ stack $ map (`compressArc` p) spaceArcs- where markOut :: Time -> [Time] -> [Arc]- markOut _ [] = []- markOut offset (x:xs') = Arc offset (offset+x):markOut (offset+x) xs'- spaceArcs = map (\(Arc a b) -> Arc (a/s) (b/s)) $ markOut 0 xs- s = sum xs--{-| @flatpat@ takes a 'Pattern' of lists and pulls the list elements as- separate 'Event's. For example, the following code uses @flatpat@ in combination with @listToPat@ to create an alternating pattern of chords:-- > d1 $ n (flatpat $ listToPat [[0,4,7],[(-12),(-8),(-5)]])- > # s "superpiano" # sustain 2-- This code is equivalent to:-- > d1 $ n ("[0,4,7] [-12,-8,-5]") # s "superpiano" # sustain 2--}-flatpat :: Pattern [a] -> Pattern a-flatpat p = p {query = concatMap (\(Event c b b' xs) -> map (Event c b b') xs) . query p}--{- | @layer@ takes a list of 'Pattern'-returning functions and a seed element,-stacking the result of applying the seed element to each function in the list.--It allows you to layer up multiple functions on one pattern. For example, the following-will play two versions of the pattern at the same time, one reversed and one at twice-the speed:--> d1 $ layer [rev, fast 2] $ sound "arpy [~ arpy:4]"--The original version of the pattern can be included by using the @id@ function:--> d1 $ layer [id, rev, fast 2] $ sound "arpy [~ arpy:4]"--}-layer :: [a -> Pattern b] -> a -> Pattern b-layer fs p = stack $ map ($ p) fs---- | @arpeggiate@ finds events that share the same timespan, and spreads--- them out during that timespan, so for example @arpeggiate "[bd,sn]"@--- gets turned into @"bd sn"@. Useful for creating arpeggios/broken chords.-arpeggiate :: Pattern a -> Pattern a-arpeggiate = arpWith id---- | Shorthand alias for arpeggiate-arpg :: Pattern a -> Pattern a-arpg = arpeggiate--arpWith :: ([EventF (ArcF Time) a] -> [EventF (ArcF Time) b]) -> Pattern a -> Pattern b-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 c (Just (Arc s e)) a' v) =- do- a'' <- subArc (Arc newS newE) a'- return (Event c (Just $ Arc newS newE) a'' v)- where newS = s + (dur * fromIntegral n)- newE = newS + dur- dur = (e - s) / fromIntegral d- -- TODO ignoring analog events.. Should we just leave them as-is?- shiftIt _ _ _ = Nothing---{-| The @arp@ function takes an additional pattern of arpeggiate modes. For example:--@-d1 $ sound "superpiano" # n (arp "<up down diverge>" "<a'm9'8 e'7sus4'8>")-@--The different arpeggiate modes are:-@-up down updown downup up&down down&up converge-diverge disconverge pinkyup pinkyupdown-thumbup thumbupdown-@--}-arp :: Pattern String -> Pattern a -> Pattern a-arp = tParam _arp--_arp :: String -> Pattern a -> Pattern a-_arp name p = arpWith f p- where f = fromMaybe id $ lookup name arps- arps :: [(String, [a] -> [a])]- arps = [("up", id),- ("down", reverse),- ("updown", \x -> init x ++ init (reverse x)),- ("downup", \x -> init (reverse x) ++ init x),- ("up&down", \x -> x ++ reverse x),- ("down&up", \x -> reverse x ++ x),- ("converge", converge),- ("diverge", reverse . converge),- ("disconverge", \x -> converge x ++ tail (reverse $ converge x)),- ("pinkyup", pinkyup),- ("pinkyupdown", \x -> init (pinkyup x) ++ init (reverse $ pinkyup x)),- ("thumbup", thumbup),- ("thumbupdown", \x -> init (thumbup x) ++ init (reverse $ thumbup x))- ]- converge [] = []- converge (x:xs) = x : converge' xs- converge' [] = []- converge' xs = last xs : converge (init xs)- pinkyup xs = concatMap (:[pinky]) $ init xs- where pinky = last xs- thumbup xs = concatMap (\x -> [thumb,x]) $ tail xs- where thumb = head xs--{- | @rolled@ plays each note of a chord quickly in order, as opposed to-simultaneously; to give a chord a harp-like or strum effect.--Notes are played low to high, and are evenly distributed within (1/4) of the chord event length, as opposed to arp/arpeggiate that spread the notes over the whole event.--@-rolled $ n "c'maj'4" # s "superpiano"-@--@rolled = rolledBy (1/4)@--}-rolled :: Pattern a -> Pattern a-rolled = rolledBy (1/4)--{--As 'rolled', but allows you to specify the length of the roll, i.e., the-fraction of the event that the notes will be spread over. The value in the-passed pattern is the divisor of the cycle length. A negative value will play-the arpeggio in reverse order.--@-rolledBy "<1 -0.5 0.25 -0.125>" $ note "c'maj9" # s "superpiano"-@--}-rolledBy :: Pattern (Ratio Integer) -> Pattern a -> Pattern a-rolledBy pt = tParam rolledWith (segment 1 $ pt)--rolledWith :: Ratio Integer -> Pattern a -> Pattern a-rolledWith t = withEvents aux- where aux es = concatMap (steppityIn) (groupBy (\a b -> whole a == whole b) $ ((isRev t) es))- isRev b = (\x -> if x > 0 then id else reverse ) b- steppityIn xs = mapMaybe (\(n, ev) -> (timeguard n xs ev t)) $ enumerate xs- timeguard _ _ ev 0 = return ev- timeguard n xs ev _ = (shiftIt n (length xs) ev)- shiftIt n d (Event c (Just (Arc s e)) a' v) = do- a'' <- subArc (Arc newS e) a'- return (Event c (Just $ Arc newS e) a'' v)- where newS = s + (dur * fromIntegral n)- dur = ((e - s)) / ((1/ (abs t))*fromIntegral d)- shiftIt _ _ ev = return ev--{- TODO !---- | @fill@ 'fills in' gaps in one pattern with events from another. For example @fill "bd" "cp ~ cp"@ would result in the equivalent of `"~ bd ~"`. This only finds gaps in a resulting pattern, in other words @"[bd ~, sn]"@ doesn't contain any gaps (because @sn@ covers it all), and @"bd ~ ~ sn"@ only contains a single gap that bridges two steps.-fill :: Pattern a -> Pattern a -> Pattern a-fill p' p = struct (splitQueries $ p {query = q}) p'- where- q st = removeTolerance (s,e) $ invert (s-tolerance, e+tolerance) $ query p (st {arc = (s-tolerance, e+tolerance)})- where (s,e) = arc st- invert (s,e) es = map arcToEvent $ foldr remove [(s,e)] (map part es)- remove (s,e) xs = concatMap (remove' (s, e)) xs- remove' (s,e) (s',e') | s > s' && e < e' = [(s',s),(e,e')] -- inside- | s > s' && s < e' = [(s',s)] -- cut off right- | e > s' && e < e' = [(e,e')] -- cut off left- | s <= s' && e >= e' = [] -- swallow- | otherwise = [(s',e')] -- miss- arcToEvent a = ((a,a),"x")- removeTolerance (s,e) es = concatMap (expand) $ map (withPart f) es- where f a = concatMap (remove' (e,e+tolerance)) $ remove' (s-tolerance,s) a- expand ((a,xs),c) = map (\x -> ((a,x),c)) xs- tolerance = 0.01--}--{- | @ply n@ repeats each event @n@ times within its arc.--For example, the following are equivalent:--@-d1 $ ply 3 $ s "bd ~ sn cp"-d1 $ s "[bd bd bd] ~ [sn sn sn] [cp cp cp]"-@--The first parameter may be given as a pattern, so that the following are equivalent:--@-d1 $ ply "2 3" $ s "bd ~ sn cp"-d1 $ s "[bd bd] ~ [sn sn sn] [cp cp cp]"-@--Here is an example of it being used conditionally:--@-d1 $ every 3 (ply 4) $ s "bd ~ sn cp"-@--}-ply :: Pattern Rational -> Pattern a -> Pattern a-ply = tParam _ply--_ply :: Rational -> Pattern a -> Pattern a-_ply n pat = squeezeJoin $ (_fast n . pure) <$> pat---- | As 'ply', but applies a function each time. The applications are compounded.-plyWith :: (Ord t, Num t) => Pattern t -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-plyWith np f p = innerJoin $ (\n -> _plyWith n f p) <$> np--_plyWith :: (Ord t, Num t) => t -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-_plyWith numPat f p = arpeggiate $ compound numPat- where compound n | n <= 1 = p- | otherwise = overlay p (f $ compound $ n-1)--{-| Syncopates a rhythm, shifting (delaying) each event halfway into its arc- (timespan).-- In mini-notation terms, it basically turns every instance of a into @[~ a]@,- e.g., @"a b [c d] e"@ becomes the equivalent of- @"[~ a] [~ b] [[~ c] [~ d]] [~ e]"@.- Every beat then becomes an offbeat, and so the overall effect is to- syncopate a pattern.-- In the following example, you can hear that the piano chords play between the- snare and the bass drum. In 4/4 time, they are playing in the 2 and a half,- and 4 and a half beats:-- > do- > resetCycles- > d1 $ stack [- > press $ n "~ c'maj ~ c'maj" # s "superpiano" # gain 0.9 # pan 0.6,- > s "[bd,clap sd bd sd]" # pan 0.4- > ] # cps (90/60/4)-- In the next example, the C major chord plays before the G major. As the slot- that occupies the C chord is that of one eighth note, it is displaced by press- only a sixteenth note:-- > do- > resetCycles- > d1 $ stack [- > press $ n "~ [c'maj ~] ~ ~" # s "superpiano" # gain 0.9 # pan 0.6,- > press $ n "~ g'maj ~ ~" # s "superpiano" # gain 0.9 # pan 0.4,- > s "[bd,clap sd bd sd]"- > ] # cps (90/60/4)--}-press :: Pattern a -> Pattern a-press = _pressBy 0.5--{-| Like @press@, but allows you to specify the amount in which each event is- shifted as a float from 0 to 1 (exclusive).-- @pressBy 0.5@ is the same as @press@, while @pressBy (1/3)@ shifts each event- by a third of its arc.-- You can pattern the displacement to create interesting rhythmic effects:-- > d1 $ stack [- > s "bd sd bd sd",- > pressBy "<0 0.5>" $ s "co:2*4"- > ]-- > d1 $ stack [- > s "[bd,co sd bd sd]",- > pressBy "<0 0.25 0.5 0.75>" $ s "cp"- > ]--}-pressBy :: Pattern Time -> Pattern a -> Pattern a-pressBy = tParam _pressBy--_pressBy :: Time -> Pattern a -> Pattern a-_pressBy r pat = squeezeJoin $ (compressTo (r,1) . pure) <$> pat--{-- Uses the first (binary) pattern to switch between the following- two patterns. The resulting structure comes from the source patterns, not the- binary pattern. See also `stitch`.-- The following will play the first pattern for the first half of a cycle, and- the second pattern for the other half; it combines two patterns of strings and- passes the result to the sound function:-- > d1 $ sound (sew "t f" "bd*8" "cp*8")-- It’s possible to sew together two control patterns:-- > d1 $ sew "t <f t> <f [f t] t>"- > (n "0 .. 15" # s "future")- > (s "cp:3*16" # speed saw + 1.2)-- You can also use Euclidean rhythm syntax in the boolean sequence:-- > d1 $ sew "t(11,16)"- > (n "0 .. 15" # s "future")- > (s "cp:3*16" # speed sine + 1.5)--}-sew :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a-sew pb a b = overlay (mask pb a) (mask (inv pb) b)--{-| Uses the first (binary) pattern to switch between the following- two patterns. The resulting structure comes from the binary- pattern, not the source patterns. (In 'sew', by contrast, the resulting structure comes from the source patterns.)-- The following uses a euclidean pattern to control CC0:-- > d1 $ ccv (stitch "t(7,16)" 127 0) # ccn 0 # "midi"--}-stitch :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a-stitch pb a b = overlay (struct pb a) (struct (inv pb) b)---- | A binary pattern is used to conditionally apply a function to a--- source pattern. The function is applied when a @True@ value is--- active, and the pattern is let through unchanged when a @False@--- value is active. No events are let through where no binary values--- are active.-while :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-while b f pat = sew b (f pat) pat--{-|-@stutter n t pat@ repeats each event in @pat@ @n@ times, separated by @t@ time (in fractions of a cycle).-It is like 'Sound.Tidal.Control.echo' that doesn't reduce the volume, or 'ply' if you controlled the timing.--> d1 $ stutter 4 (1/16) $ s "bd cp"--is functionally equivalent to--> d1 $ stut 4 1 (1/16) $ s "bd cp"--}-stutter :: Integral i => i -> Time -> Pattern a -> Pattern a-stutter n t p = stack $ map (\i -> (t * fromIntegral i) `rotR` p) [0 .. (n-1)]--{- | The @jux@ function creates strange stereo effects by applying a- function to a pattern, but only in the right-hand channel. For- example, the following reverses the pattern on the righthand side:-- > d1 $ slow 32 $ jux (rev) $ striateBy 32 (1/16) $ sound "bev"-- When passing pattern transforms to functions like @jux@ and 'every',- it's possible to chain multiple transforms together with `.` (function- composition). For example this both reverses and halves the playback speed of- the pattern in the righthand channel:-- > d1 $ slow 32 $ jux ((# speed "0.5") . rev) $ striateBy 32 (1/16) $ sound "bev"--}-jux- :: (Pattern ValueMap -> Pattern ValueMap)- -> Pattern ValueMap -> Pattern ValueMap-jux = juxBy 1-juxcut- :: (Pattern ValueMap -> Pattern ValueMap)- -> Pattern ValueMap -> Pattern ValueMap-juxcut f p = stack [p # P.pan (pure 0) # P.cut (pure (-1)),- f $ p # P.pan (pure 1) # P.cut (pure (-2))- ]--juxcut' :: [t -> Pattern ValueMap] -> t -> Pattern ValueMap-juxcut' fs p = stack $ map (\n -> ((fs !! n) p |+ P.cut (pure $ 1-n)) # P.pan (pure $ fromIntegral n / fromIntegral l)) [0 .. l-1]- where l = length fs--{- | In addition to `jux`, `jux'` allows using a list of pattern- transformations. Resulting patterns from each transformation will be spread via- pan from left to right.-- For example, the following will put @iter 4@ of the pattern to the far left- and `palindrome` to the far right. In the center, the original pattern will- play and the chopped and the reversed version will appear mid left and mid- right respectively.-- > d1 $ jux' [iter 4, chop 16, id, rev, palindrome] $ sound "bd sn"--One could also write:--@-d1 $ stack- [ iter 4 $ sound "bd sn" # pan "0"- , chop 16 $ sound "bd sn" # pan "0.25"- , sound "bd sn" # pan "0.5"- , rev $ sound "bd sn" # pan "0.75"- , palindrome $ sound "bd sn" # pan "1"- ]-@---}-jux' :: [t -> Pattern ValueMap] -> t -> Pattern ValueMap-jux' fs p = stack $ map (\n -> (fs !! n) p |+ P.pan (pure $ fromIntegral n / fromIntegral l)) [0 .. l-1]- where l = length fs---- | Multichannel variant of `jux`, /not sure what it does/-jux4- :: (Pattern ValueMap -> Pattern ValueMap)- -> Pattern ValueMap -> Pattern ValueMap-jux4 f p = stack [p # P.pan (pure (5/8)), f $ p # P.pan (pure (1/8))]--{- |-With `jux`, the original and effected versions of the pattern are-panned hard left and right (i.e., panned at 0 and 1). This can be a-bit much, especially when listening on headphones. The variant @juxBy@-has an additional parameter, which brings the channel closer to the-centre. For example:--> d1 $ juxBy 0.5 (fast 2) $ sound "bd sn:1"--In the above, the two versions of the pattern would be panned at 0.25-and 0.75, rather than 0 and 1.--}-juxBy- :: Pattern Double- -> (Pattern ValueMap -> Pattern ValueMap)- -> Pattern ValueMap- -> Pattern ValueMap-juxBy n f p = stack [p |+ P.pan 0.5 |- P.pan (n/2), f $ p |+ P.pan 0.5 |+ P.pan (n/2)]--{- |-Given a sample's directory name and number, this generates a string-suitable to pass to 'Data.String.fromString' to create a 'Pattern String'.-'samples' is a 'Pattern'-compatible interface to this function.--@pick name n = name ++ ":" ++ show n@--}-pick :: String -> Int -> String-pick name n = name ++ ":" ++ show n--{- |-Given a pattern of sample directory names and a of pattern indices-create a pattern of strings corresponding to the sample at each-name-index pair.--An example:--> samples "jvbass [~ latibro] [jvbass [latibro jvbass]]"-> ((1%2) `rotL` slow 6 "[1 6 8 7 3]")--The type signature is more general here, but you can consider this-to be a function of type @Pattern String -> Pattern Int -> Pattern String@.--@samples = liftA2 pick@--}-samples :: Applicative f => f String -> f Int -> f String-samples p p' = pick <$> p <*> p'--{- |-Equivalent to 'samples', though the sample specifier pattern-(the @f Int@) will be evaluated first. Not a large difference-in the majority of cases.--}-samples' :: Applicative f => f String -> f Int -> f String-samples' p p' = flip pick <$> p' <*> p--{--scrumple :: Time -> Pattern a -> Pattern a -> Pattern a-scrumple o p p' = p'' -- overlay p (o `rotR` p'')- where p'' = Pattern $ \a -> concatMap- (\((s,d), vs) -> map (\x -> ((s,d),- snd x- )- )- (arc p' (s,s))- ) (arc p a)--}--{-- As 'spread', but specialized so that the list contains functions returning patterns.--@spreadf = 'spread' ($)@--}-spreadf :: [a -> Pattern b] -> a -> Pattern b-spreadf = spread ($)--stackwith :: Unionable a => Pattern a -> [Pattern a] -> Pattern a-stackwith p ps | null ps = silence- | otherwise = stack $ map (\(i, p') -> p' # ((fromIntegral i % l) `rotL` p)) (zip [0::Int ..] ps)- where l = fromIntegral $ length ps--{--cross f p p' = Pattern $ \t -> concat [filter flt $ arc p t,- filter (not . flt) $ arc p' t- ]-] where flt = f . cyclePos . fst . fst--}--{- | `range` will take a pattern which goes from 0 to 1 (like `sine`), and range it to a different range - between the first and second arguments. In the below example, `range 1 1.5` shifts the range of `sine1` from 0 - 1 to 1 - 1.5.--> d1 $ jux (iter 4) $ sound "arpy arpy:2*2"-> |+ speed (slow 4 $ range 1 1.5 sine1)--The above is equivalent to:--> d1 $ jux (iter 4) $ sound "arpy arpy:2*2"-> |+ speed (slow 4 $ sine1 * 0.5 + 1)--}-range :: Num a => Pattern a -> Pattern a -> Pattern a -> Pattern a-range fromP toP p = (\from to v -> ((v * (to-from)) + from)) <$> fromP *> toP *> p--_range :: (Functor f, Num b) => b -> b -> f b -> f b-_range from to p = (+ from) . (* (to-from)) <$> p--{- | `rangex` is an exponential version of `range`, good for using with-frequencies. For example, @range 20 2000 "0.5"@ will give @1010@ - halfway-between @20@ and @2000@. But @rangex 20 2000 0.5@ will give @200@ - halfway-between on a logarithmic scale. This usually sounds better if you’re using the-numbers as pitch frequencies. Since rangex uses logarithms, don’t try to scale-things to zero or less.--}-rangex :: (Functor f, Floating b) => b -> b -> f b -> f b-rangex from to p = exp <$> _range (log from) (log to) p--{-|- @off@ is similar to 'superimpose', in that it applies a function to a pattern- and layers up the results on top of the original pattern. The difference- is that @off@ takes an extra pattern being a time (in cycles) to shift the- transformed version of the pattern by.-- The following plays a pattern on top of itself, but offset by an eighth of a- cycle, with a distorting bitcrush effect applied:-- > d1 $ off 0.125 (# crush 2) $ sound "bd [~ sn:2] mt lt*2"-- The following makes arpeggios by adding offset patterns that are shifted up- the scale:-- > d1 $ slow 2- > $ n (off 0.25 (+12)- > $ off 0.125 (+7)- > $ slow 2 "c(3,8) a(3,8,2) f(3,8) e(3,8,4)")- > # sound "superpiano"--}-off :: Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-off tp f p = innerJoin $ (\tv -> _off tv f p) <$> tp--_off :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-_off t f p = superimpose (f . (t `rotR`)) p--offadd :: Num a => Pattern Time -> Pattern a -> Pattern a -> Pattern a-offadd tp pn p = off tp (+pn) p--{- |- @step@ acts as a kind of simple step-sequencer using strings. For example,- @step "sn" "x x 12"@ is equivalent to the pattern of strings given by @"sn ~- sn ~ sn:1 sn:2 ~"@. @step@ substitutes the given string for each @x@, for each number- it substitutes the string followed by a colon and the number, and for everything- else it puts in a rest.-- In other words, @step@ generates a pattern of strings in exactly the syntax you’d want for selecting samples and that can be fed directly into the 's' function.-- > d1 $ s (step "sn" "x x 12 ")--}-step :: String -> String -> Pattern String-step s cs = fastcat $ map f cs- where f c | c == 'x' = pure s- | isDigit c = pure $ s ++ ":" ++ [c]- | otherwise = silence--{- | @steps@ is like @step@ but it takes a list of pairs, like step would, and- it plays them all simultaneously.-- > d1 $ s (steps [("cp","x x x x x x"),("bd", "xxxx")])--}-steps :: [(String, String)] -> Pattern String-steps = stack . map (uncurry step)--{- | like `step`, but allows you to specify an array of strings to use for @0,1,2...@- For example,-- > d1 $ s (step' ["superpiano","supermandolin"] "0 1 000 1")- > # sustain 4 # n 0-- is equivalent to-- > d1 $ s "superpiano ~ supermandolin ~ superpiano!3 ~ supermandolin"- > # sustain 4 # n 0--}-step' :: [String] -> String -> Pattern String-step' ss cs = fastcat $ map f cs- where f c | c == 'x' = pure $ head ss- | isDigit c = pure $ ss !! digitToInt c- | otherwise = silence----- | Deprecated backwards-compatible alias for 'ghostWith'.-ghost'' :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-ghost'' = ghostWith--{-| Like 'ghost'', but a user-supplied function describes how to alter the pattern.-- In this example, ghost notes are applied to the snare hit, but these notes will- be louder, not quieter, and the sample will have its beginning slightly cut:-- > d1 $ slow 2- > $ ghostWith (1/16) ((|*| gain 1.1) . (|> begin 0.05))- > $ sound "sn"---}-ghostWith :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-ghostWith a f p = superimpose (((a*2.5) `rotR`) . f) $ superimpose (((a*1.5) `rotR`) . f) p--{--@ghost' t pat@ Adds quieter, pitch-shifted, copies of an event @t@ cycles after events in @pat@, emulating ghost notes that are common in drumming patterns.--The following creates a kick snare pattern with ghost notes applied to the snare hit:--> d1 $ stack [ ghost' 0.125 $ sound "~ sn", sound "bd*2 [~ bd]" ]--}-ghost' :: Time -> Pattern ValueMap -> Pattern ValueMap-ghost' a p = ghostWith a ((|*| P.gain (pure 0.7)) . (|> P.end (pure 0.2)) . (|*| P.speed (pure 1.25))) p--{-| As 'ghost'', but with the copies set to appear one-eighth of a cycle afterwards.--@ghost = ghost' 0.125@--The following creates a kick snare pattern with ghost notes applied to the snare hit:--> d1 $ stack [ ghost $ sound "~ sn", sound "bd*2 [~ bd]" ]--}-ghost :: Pattern ValueMap -> Pattern ValueMap-ghost = ghost' 0.125--{- | A more literal weaving than the `weave` function. Given @tabby threads p1 p@,- parameters representing the threads per cycle and the patterns to weave, and- this function will weave them together using a plain (aka ’tabby’) weave,- with a simple over/under structure- -}-tabby :: Int -> Pattern a -> Pattern a -> Pattern a-tabby nInt p p' = stack [maskedWarp,- maskedWeft- ]- where- n = fromIntegral nInt- weft = concatMap (const [[0..n-1], reverse [0..n-1]]) [0 .. (n `div` 2) - 1]- warp = transpose weft- thread xs p'' = _slow (n%1) $ fastcat $ map (\i -> zoomArc (Arc (i%n) ((i+1)%n)) p'') (concat xs)- weftP = thread weft p'- warpP = thread warp p- maskedWeft = mask (every 2 rev $ _fast (n % 2) $ fastCat [silence, pure True]) weftP- maskedWarp = mask (every 2 rev $ _fast (n % 2) $ fastCat [pure True, silence]) warpP---- | Chooses from a list of patterns, using a pattern of floats (from 0 to 1).-select :: Pattern Double -> [Pattern a] -> Pattern a-select = tParam _select--_select :: Double -> [Pattern a] -> Pattern a-_select f ps = ps !! floor (max 0 (min 1 f) * fromIntegral (length ps - 1))---- | Chooses from a list of functions, using a pattern of floats (from 0 to 1).-selectF :: Pattern Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a-selectF pf ps p = innerJoin $ (\f -> _selectF f ps p) <$> pf--_selectF :: Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a-_selectF f ps p = (ps !! floor (max 0 (min 0.999999 f) * fromIntegral (length ps))) p---- | Chooses from a list of functions, using a pattern of integers.-pickF :: Pattern Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a-pickF pInt fs pat = innerJoin $ (\i -> _pickF i fs pat) <$> pInt--_pickF :: Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a-_pickF i fs p = (fs !!! i) p--{- | @contrast f f' p p'@ splits the control pattern @p'@ in two, applying- the function @f@ to one and @f'@ to the other. This depends on- whether events in @p'@ contain values matching with those in @p@.- For example, in-- > contrast (# crush 3) (# vowel "a") (n "1") $ n "0 1" # s "bd sn" # speed 3-- the first event will have the vowel effect applied and the second will have- the crush applied.-- @contrast@ is like an if-else-statement over patterns. For @contrast t f p@- you can think of @t@ as the true branch, @f@ as the false branch, and @p@ as- the test.-- You can use any control pattern as a test of equality, e.g., @n "<0 1>", speed- "0.5"@, or things like that. This lets you choose specific properties of the- pattern you’re transforming for testing, like in the following example,-- > d1 $ contrast (|+ n 12) (|- n 12) (n "c") $ n (run 4) # s "superpiano"-- where every note that isn’t middle-c will be shifted down an octave but- middle-c will be shifted up to c5.-- Since the test given to contrast is also a pattern, you can do things like have- it alternate between options:-- > d1 $ contrast (|+ n 12) (|- n 12) (s "<superpiano superchip>")- > $ s "superpiano superchip" # n 0-- If you listen to this you’ll hear that which instrument is shifted up and which- instrument is shifted down alternates between cycles.--}-contrast :: (ControlPattern -> ControlPattern) -> (ControlPattern -> ControlPattern)- -> ControlPattern -> ControlPattern -> ControlPattern-contrast = contrastBy (==)--{-|- @contrastBy@ is contrastBy is the general version of 'contrast', in which you can specify an abritrary boolean function that will be used to compare the control patterns.-- > d2 $ contrastBy (>=) (|+ n 12) (|- n 12) (n "2") $ n "0 1 2 [3 4]" # s "superpiano"--}-contrastBy :: (a -> Value -> Bool)- -> (ControlPattern -> Pattern b)- -> (ControlPattern -> Pattern b)- -> Pattern (Map.Map String a)- -> Pattern (Map.Map String Value)- -> Pattern b-contrastBy comp f f' p p' = overlay (f matched) (f' unmatched)- where matches = matchManyToOne (flip $ Map.isSubmapOfBy comp) p p'- matched :: ControlPattern- matched = filterJust $ (\(t, a) -> if t then Just a else Nothing) <$> matches- unmatched :: ControlPattern- unmatched = filterJust $ (\(t, a) -> if not t then Just a else Nothing) <$> matches--contrastRange- :: (ControlPattern -> Pattern a)- -> (ControlPattern -> Pattern a)- -> Pattern (Map.Map String (Value, Value))- -> ControlPattern- -> Pattern a-contrastRange = contrastBy f- where f (VI s, VI e) (VI v) = v >= s && v <= e- f (VF s, VF e) (VF v) = v >= s && v <= e- f (VN s, VN e) (VN v) = v >= s && v <= e- f (VS s, VS e) (VS v) = v == s && v == e- f _ _ = False--{- |- The @fix@ function applies another function to matching events in a pattern of- controls. @fix@ is 'contrast' where the false-branching function is set to the- identity 'id'. It is like 'contrast', but one function is given and applied to- events with matching controls.-- For example, the following only adds the 'crush' control when the @n@ control- is set to either 1 or 4:-- > d1 $ slow 2- > $ fix (# crush 3) (n "[1,4]")- > $ n "0 1 2 3 4 5 6"- > # sound "arpy"-- You can be quite specific; for example, the following applies the function- @'hurry' 2@ to sample 1 of the drum sample set, and leaves the rest as they are:-- > fix (hurry 2) (s "drum" # n "1")--}-fix :: (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern-fix f = contrast f id---- | Like 'contrast', but one function is given, and applied to events with--- controls which don't match. @unfix@ is 'fix' but only applies when the--- testing pattern is /not/ a match.-unfix :: (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern-unfix = contrast id--{-|- The @fixRange@ function isn’t very user-friendly at the moment, but you can- create a @fix@ variant with a range condition. Any value of a 'ControlPattern'- wich matches the values will apply the passed function.-- > d1 $ ( fixRange ( (# distort 1) . (# gain 0.8) )- > ( pure $ Map.singleton "note" ((VN 0, VN 7)) )- > )- > $ s "superpiano"- > <| note "1 12 7 11"--}-fixRange :: (ControlPattern -> Pattern ValueMap)- -> Pattern (Map.Map String (Value, Value))- -> ControlPattern- -> ControlPattern-fixRange f = contrastRange f id--unfixRange :: (ControlPattern -> Pattern ValueMap)- -> Pattern (Map.Map String (Value, Value))- -> ControlPattern- -> ControlPattern-unfixRange = contrastRange id--{- | @quantise@ limits values in a Pattern (or other Functor) to @n@ equally spaced-divisions of 1.--It is useful for rounding a collection of numbers to some particular base-fraction. For example,--> quantise 5 [0, 1.3 ,2.6,3.2,4.7,5]--It will round all the values to the nearest @(1/5)=0.2@ and thus will output-the list @[0.0,1.2,2.6,3.2,4.8,5.0]@. You can use this function to force a-continuous pattern like sine into specific values. In the following example:--> d1 $ s "superchip*8" # n (quantise 1 $ range (-10) (10) $ slow 8 $ cosine)-> # release (quantise 5 $ slow 8 $ sine + 0.1)--all the releases selected be rounded to the nearest @0.1@ and the notes selected-to the nearest @1@.--@quantise@ with fractional inputs does the consistent thing: @quantise 0.5@-rounds values to the nearest @2@, @quantise 0.25@ rounds the nearest @4@, etc.--}-quantise :: (Functor f, RealFrac b) => b -> f b -> f b-quantise n = fmap ((/n) . (fromIntegral :: RealFrac b => Int -> b) . round . (*n))---- | As 'quantise', but uses 'Prelude.floor' to calculate divisions.-qfloor :: (Functor f, RealFrac b) => b -> f b -> f b-qfloor n = fmap ((/n) . (fromIntegral :: RealFrac b => Int -> b) . floor . (*n))---- | As 'quantise', but uses 'Prelude.ceiling' to calculate divisions.-qceiling :: (Functor f, RealFrac b) => b -> f b -> f b-qceiling n = fmap ((/n) . (fromIntegral :: RealFrac b => Int -> b) . ceiling . (*n))---- | An alias for 'quantise'.-qround :: (Functor f, RealFrac b) => b -> f b -> f b-qround = quantise---- | Inverts all the values in a boolean pattern-inv :: Functor f => f Bool -> f Bool-inv = (not <$>)---- | Serialises a pattern so there's only one event playing at any one--- time, making it /monophonic/. Events which start/end earlier are given priority.-mono :: Pattern a -> Pattern a-mono p = Pattern $ \(State a cm) -> flatten $ query p (State a cm) where- flatten :: [Event a] -> [Event a]- flatten = mapMaybe constrainPart . truncateOverlaps . sortOn whole- truncateOverlaps [] = []- truncateOverlaps (e:es) = e : truncateOverlaps (mapMaybe (snip e) es)- -- TODO - decide what to do about analog events..- snip a b | start (wholeOrPart b) >= stop (wholeOrPart a) = Just b- | stop (wholeOrPart b) <= stop (wholeOrPart a) = Nothing- | otherwise = Just b {whole = Just $ Arc (stop $ wholeOrPart a) (stop $ wholeOrPart b)}- constrainPart :: Event a -> Maybe (Event a)- constrainPart e = do a <- subArc (wholeOrPart e) (part e)- return $ e {part = a}--{-|-@smooth@ receives a pattern of numbers and linearly goes from one to the next, passing through all of them. As time is cycle-based, after reaching the last number in the pattern, it will smoothly go to the first one again.--> d1 $ sound "bd*4" # pan (slow 4 $ smooth "0 1 0.5 1")--This sound will pan gradually from left to right, then to the center, then to the right again, and finally comes back to the left.--}---- serialize the given pattern--- find the middle of the query's arc and use that to query the serialized pattern. We should get either no events or a single event back--- if we don't get any events, return nothing--- if we get an event, get the stop of its arc, and use that to query the serialized pattern, to see if there's an adjoining event--- if there isn't, return the event as-is.--- if there is, check where we are in the 'whole' of the event, and use that to tween between the values of the event and the next event--- smooth :: Pattern Double -> Pattern Double---- TODO - test this with analog events-smooth :: Fractional a => Pattern a -> Pattern a-smooth p = Pattern $ \st@(State a cm) -> tween st a $ query monoP (State (midArc a) cm)- where- midArc a = Arc (mid (start a, stop a)) (mid (start a, stop a))- tween _ _ [] = []- tween st queryA (e:_) = maybe [e {whole = Just queryA, part = queryA}] (tween' queryA) (nextV st)- where aStop = Arc (wholeStop e) (wholeStop e)- nextEs st' = query monoP (st' {arc = aStop})- nextV st' | null (nextEs st') = Nothing- | otherwise = Just $ value (head (nextEs st'))- tween' queryA' v =- [ Event- { context = context e,- whole = Just queryA'- , part = queryA'- , value = value e + ((v - value e) * pc)}- ]- pc | delta' (wholeOrPart e) == 0 = 0- | otherwise = fromRational $ (eventPartStart e - wholeStart e) / delta' (wholeOrPart e)- delta' a = stop a - start a- monoP = mono p---- | Looks up values from a list of tuples, in order to swap values in the given pattern-swap :: Eq a => [(a, b)] -> Pattern a -> Pattern b-swap things p = filterJust $ (`lookup` things) <$> p--{-|- @snowball@ takes a function that can combine patterns (like '+'),- a function that transforms a pattern (like 'slow'),- a depth, and a starting pattern,- it will then transform the pattern and combine it with the last transformation until the depth is reached.- This is like putting an effect (like a filter) in the feedback of a delay line; each echo is more affected.-- > d1 $ note ( scale "hexDorian"- > $ snowball 8 (+) (slow 2 . rev) "0 ~ . -1 . 5 3 4 . ~ -2"- > )- > # s "gtr"--}-snowball :: Int -> (Pattern a -> Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-snowball depth combinationFunction f pattern = cat $ take depth $ scanl combinationFunction pattern $ drop 1 $ iterate f pattern--{- |- Applies a function to a pattern and cats the resulting pattern, then continues- applying the function until the depth is reached this can be used to create- a pattern that wanders away from the original pattern by continually adding- random numbers.-- > d1 $ note ( scale "hexDorian" mutateBy (+ (range -1 1 $ irand 2)) 8- > $ "0 1 . 2 3 4"- > )- > # s "gtr"--}-soak :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-soak depth f pattern = cat $ take depth $ iterate f pattern---- | @construct n p@ breaks @p@ into pieces and then reassembles them--- so that it fits into @n@ steps.-deconstruct :: Int -> Pattern String -> String-deconstruct n p = intercalate " " $ map showStep $ toList p- where- showStep :: [String] -> String- showStep [] = "~"- showStep [x] = x- showStep xs = "[" ++ (intercalate ", " xs) ++ "]"- toList :: Pattern a -> [[a]]- toList pat = map (\(s,e) -> map value $ queryArc (_segment n' pat) (Arc s e)) arcs- where breaks = [0, (1/n') ..]- arcs = zip (take n breaks) (drop 1 breaks)- n' = fromIntegral n--{- | @bite n ipat pat@ slices a pattern @pat@ into @n@ pieces, then uses the- @ipat@ pattern of integers to index into those slices. So @bite 4 "0 2*2" (run- 8)@ is the same as @"[0 1] [4 5]*2"@.-- I.e., it allows you to slice each cycle into a given number of equal sized- bits, and then pattern those bits by number. It’s similar to @slice@, but is- for slicing up patterns, rather than samples. The following slices the pattern- into four bits, and then plays those bits in turn:-- > d1 $ bite 4 "0 1 2 3" $ n "0 .. 7" # sound "arpy"-- Of course that doesn’t actually change anything, but then you can reorder those bits:-- > d1 $ bite 4 "2 0 1 3" $ n "0 .. 7" # sound "arpy"-- The slices bits of pattern will be squeezed or contracted to fit:-- > d1 $ bite 4 "2 [0 3] 1*4 1" $ n "0 .. 7" # sound "arpy"--}-bite :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a-bite npat ipat pat = innerJoin $ (\n -> _bite n ipat pat) <$> npat--_bite :: Int -> Pattern Int -> Pattern a -> Pattern a-_bite n ipat pat = squeezeJoin $ zoompat <$> ipat- where zoompat i = zoom (i'/(fromIntegral n), (i'+1)/(fromIntegral n)) pat- where i' = fromIntegral $ i `mod` n---- | Chooses from a list of patterns, using a pattern of integers.-squeeze :: Pattern Int -> [Pattern a] -> Pattern a-squeeze _ [] = silence-squeeze ipat pats = squeezeJoin $ (pats !!!) <$> ipat--squeezeJoinUp :: Pattern (ControlPattern) -> ControlPattern-squeezeJoinUp pp = pp {query = q}- where q st = concatMap (f st) (query (filterDigital pp) st)- 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 co oWhole oPart (Event ci (Just iWhole) iPart v) =- do w' <- subArc oWhole iWhole- p' <- subArc oPart iPart- 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)- where zoompat i = zoom (i'/(fromIntegral n), (i'+1)/(fromIntegral n)) (pat)- where i' = fromIntegral $ i `mod` n--{-|- @chew@ works the same as 'bite', but speeds up\/slows down playback of sounds as- well as squeezing\/contracting the slices of the provided pattern. Compare:-- > d1 $ 'bite' 4 "0 1*2 2*2 [~ 3]" $ n "0 .. 7" # sound "drum"- > d1 $ chew 4 "0 1*2 2*2 [~ 3]" $ n "0 .. 7" # sound "drum"--}---- TODO maybe _chew could pattern the first parameter directly..-chew :: Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern-chew npat ipat pat = innerJoin $ (\n -> _chew n ipat pat) <$> npat--__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 :: Int -> Pattern Int -> Pattern Bool-_binaryN n p = squeezeJoin $ _binary n <$> p--binaryN :: Pattern Int -> Pattern Int -> Pattern Bool-binaryN n p = tParam _binaryN n p--binary :: Pattern Int -> Pattern Bool-binary = binaryN 8--ascii :: Pattern String -> Pattern Bool-ascii p = squeezeJoin $ (listToPat . concatMap (__binary 8 . ord)) <$> p--{- | Given a start point and a duration (both specified in cycles), this- generates a control pattern that makes a sound begin at the start- point and last the duration.-- The following are equivalent:-- > d1 $ slow 2 $ s "bev" # grain 0.2 0.1 # legato 1- > d1 $ slow 2 $ s "bev" # begin 0.2 # end 0.3 # legato 1-- @grain@ is defined as:-- > grain s d = 'Sound.Tidal.Params.begin' s # 'Sound.Tidal.Params.end' (s+d)--}-grain :: Pattern Double -> Pattern Double -> ControlPattern-grain s w = P.begin b # P.end e- where b = s- e = s + w---- | For specifying a boolean pattern according to a list of offsets--- (aka inter-onset intervals). For example @necklace 12 [4,2]@ is--- the same as "t f f f t f t f f f t f". That is, 12 steps per cycle,--- with true values alternating between every 4 and every 2 steps.-necklace :: Rational -> [Int] -> Pattern Bool-necklace perCycle xs = _slow ((toRational $ sum xs) / perCycle) $ listToPat $ list xs- where list :: [Int] -> [Bool]- list [] = []- list (x:xs') = (True:(replicate (x-1) False)) ++ list xs'
− src/Sound/Tidal/Utils.hs
@@ -1,103 +0,0 @@-module Sound.Tidal.Utils where--{-- Utils.hs - A library of handy Haskell utility functions- Copyright (C) 2020, Alex McLean and contributors-- This library is free software: you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this library. If not, see <http://www.gnu.org/licenses/>.--}--import Data.List (delete)-import System.IO (hPutStrLn, stderr)--writeError :: String -> IO ()-writeError = hPutStrLn stderr--mapBoth :: (a -> a) -> (a,a) -> (a,a)-mapBoth f (a,b) = (f a, f b)--mapPartTimes :: (a -> a) -> ((a,a),(a,a)) -> ((a,a),(a,a))-mapPartTimes f = mapBoth (mapBoth f)--mapFst :: (a -> b) -> (a, c) -> (b, c)-mapFst f (x,y) = (f x,y)--mapSnd :: (a -> b) -> (c, a) -> (c, b)-mapSnd f (x,y) = (x,f y)--delta :: Num a => (a, a) -> a-delta (a,b) = b-a---- | The midpoint of two values-mid :: Fractional a => (a,a) -> a-mid (a,b) = a + ((b - a) / 2)--removeCommon :: Eq a => [a] -> [a] -> ([a],[a])-removeCommon [] bs = ([],bs)-removeCommon as [] = (as,[])-removeCommon (a:as) bs | a `elem` bs = removeCommon as (delete a bs)- | otherwise = (a:as',bs')- where (as',bs') = removeCommon as bs--readMaybe :: (Read a) => String -> Maybe a-readMaybe s = case [x | (x,t) <- reads s, ("","") <- lex t] of- [x] -> Just x- _ -> Nothing--{- | like `!!` selects @n@th element from xs, but wraps over at the end of @xs@-->>> map ((!!!) [1,3,5]) [0,1,2,3,4,5]-[1,3,5,1,3,5]--}-(!!!) :: [a] -> Int -> a-(!!!) xs n = xs !! (n `mod` length xs)---{- | Safer version of !! --}-nth :: Int -> [a] -> Maybe a-nth _ [] = Nothing-nth 0 (x : _) = Just x-nth n (_ : xs) = nth (n - 1) xs--accumulate :: Num t => [t] -> [t]-accumulate [] = []-accumulate (x:xs) = scanl (+) x xs--{- | enumerate a list of things-->>> enumerate ["foo","bar","baz"]-[(1,"foo"), (2,"bar"), (3,"baz")]--}-enumerate :: [a] -> [(Int, a)]-enumerate = zip [0..]--{- | split given list of @a@ by given single a, e.g.-->>> wordsBy (== ':') "bd:3"-["bd", "3"]--}-wordsBy :: (a -> Bool) -> [a] -> [[a]]-wordsBy p s = case dropWhile p s of- [] -> []- s':rest -> (s':w) : wordsBy p (drop 1 s'')- where (w, s'') = break p rest--matchMaybe :: Maybe a -> Maybe a -> Maybe a-matchMaybe Nothing y = y-matchMaybe x _ = x---- Available in Data.Either, but only since 4.10-fromRight :: b -> Either a b -> b-fromRight _ (Right b) = b-fromRight b _ = b
src/Sound/Tidal/Version.hs view
@@ -21,12 +21,12 @@ -} tidal_version :: String-tidal_version = "1.9.5"+tidal_version = "1.10.0" tidal_status :: IO ()-tidal_status = tidal_status_string >>= putStrLn +tidal_status = tidal_status_string >>= putStrLn tidal_status_string :: IO String-tidal_status_string = do datadir <- getDataDir- return $ "[TidalCycles version " ++ tidal_version ++ "]\nInstalled in " ++ datadir-+tidal_status_string = do+ datadir <- getDataDir+ return $ "[TidalCycles version " ++ tidal_version ++ "]\nInstalled in " ++ datadir
− test/Sound/Tidal/ChordsTest.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Sound.Tidal.ChordsTest where--import TestUtils-import Test.Microspec--import Prelude hiding ((<*), (*>))--import Sound.Tidal.Pattern--run :: Microspec ()-run =- describe "Sound.Tidal.Chords" $ do- describe "chord" $ do- describe "chord length adjustments" $ do- it "can remove notes from the end of the list when length given is less than the standard chord length" $ do- compareP (Arc 0 1)- ("'major'1")- ("[0]" :: Pattern Note)- it "can do nothing when the length given is the same as the standard chord length" $ do- compareP (Arc 0 1)- ("'major'3")- ("[0, 4, 7]" :: Pattern Note)- it "can append chord notes at higher octaves to the list when length given is greater than the standard chord length" $ do- compareP (Arc 0 1)- ("'major'5")- ("[0, 4, 7, 12, 16]" :: Pattern Note)- describe "open voiced chords" $ do- it "can subtract 12 from the first and third element of a list, and sort them in ascending numerical order" $ do- compareP (Arc 0 1)- ("'major'o")- ("[-12, -5, 4]" :: Pattern Note)- it "not crash if chord length is < 3" $ do- compareP (Arc 0 1)- ("'five'o")- ("[0, 7]" :: Pattern Note)- describe "chord inversions" $ do- it "can add 12 to the first element of a list, and sort in ascending numeric order (1st inversion)" $ do- compareP (Arc 0 1)- ("'major'i")- ("[4, 7, 12]" :: Pattern Note)- it "can add 12 to the first two elements of a list, and sort in ascending numeric order (2nd inversion)" $ do- compareP (Arc 0 1)- ("'major'ii")- ("[7, 12, 16]" :: Pattern Note)- it "can add 12 to the first three elements of a list, and sort in ascending numeric order (3rd inversion)" $ do- compareP (Arc 0 1)- ("'major'iii")- ("[12, 16, 19]" :: Pattern Note)- describe "edge cases" $ do- it "gracefully handle an inversion when there are more inversions than notes in the chord (4th inversion of a 3 note chord)" $ do- compareP (Arc 0 1)- ("'major'iiii")- ("[16, 19, 24]" :: Pattern Note)
− test/Sound/Tidal/ControlTest.hs
@@ -1,49 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Sound.Tidal.ControlTest where--import TestUtils-import Test.Microspec--import Prelude hiding ((<*), (*>))--import Sound.Tidal.Control-import Sound.Tidal.Core-import Sound.Tidal.Params-import Sound.Tidal.Pattern--run :: Microspec ()-run =- describe "Sound.Tidal.Control" $ do-- describe "echo" $ do- it "should echo the event by the specified time and multiply the gain factor" $ do- comparePD (Arc 0 1)- (echo 3 0.2 0.5 $ s "bd" # gain "1")- (stack [- rotR 0 $ s "bd" # gain 1,- rotR 0.2 $ s "bd" # gain 0.5,- rotR 0.4 $ s "bd" # gain 0.25- ])-- describe "echoWith" $ do- it "should echo the event by the specified time and apply the specified function" $ do- comparePD (Arc 0 1)- (echoWith 3 0.25 (|* speed 2) $ s "bd" # speed "1")- (stack [- rotR 0 $ s "bd" # speed 1,- rotR 0.25 $ s "bd" # speed 2,- rotR 0.5 $ s "bd" # speed 4- ])-- describe "stutWith" $ do- it "can mimic stut" $ do- comparePD (Arc 0 1)- (filterOnsets $ stutWith 4 0.25 (# gain 1) $ sound "bd")- (filterOnsets $ stut 4 1 0.25 $ sound "bd")- - describe "splice" $ do- it "can beatslice" $ do- comparePD (Arc 0 1)- (splice "4 8" "0 1" $ sound "bev")- (begin "0 0.125" # end "0.25 0.25" # speed "0.5 0.25" # sound "bev" # unit "c")
− test/Sound/Tidal/CoreTest.hs
@@ -1,332 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Sound.Tidal.CoreTest where--import Data.List (sort)-import Data.Ratio-import qualified Data.Map as Map-import Sound.Tidal.Context-import Test.Microspec-import TestUtils-import Prelude hiding ((*>), (<*))--run :: Microspec ()-run =- describe "Sound.Tidal.Core" $ do- describe "Elemental patterns" $ do- let sampleOf :: Pattern Double -> Rational -> Double- sampleOf pat t = (value . head) $ query pat (State (Arc t t) Map.empty)- describe "are in range [0, 1]" $ do- let inNormalRange pat t = (y >= 0) && (y <= 1)- where y = sampleOf pat t- it "sine" $ inNormalRange sine- it "cosine" $ inNormalRange cosine- it "saw" $ inNormalRange saw- it "isaw" $ inNormalRange isaw- it "tri" $ inNormalRange tri- it "square" $ inNormalRange square- describe "have correctly-scaled bipolar variants" $ do- let areCorrectlyScaled pat pat2 t = (y * 2 - 1) ~== y2- where y = sampleOf pat t- y2 = sampleOf pat2 t- it "sine" $ areCorrectlyScaled sine sine2- it "cosine" $ areCorrectlyScaled cosine cosine2- it "saw" $ areCorrectlyScaled saw saw2- it "isaw" $ areCorrectlyScaled isaw isaw2- it "tri" $ areCorrectlyScaled tri tri2- it "square" $ areCorrectlyScaled square square2- - describe "append" $- it "can switch between the cycles from two pures" $ do- queryArc (append (pure "a") (pure "b")) (Arc 0 5)- `shouldBe` fmap- toEvent- [ (((0, 1), (0, 1)), "a" :: String),- (((1, 2), (1, 2)), "b"),- (((2, 3), (2, 3)), "a"),- (((3, 4), (3, 4)), "b"),- (((4, 5), (4, 5)), "a")- ]-- describe "cat" $ do- it "can switch between the cycles from three pures" $ do- queryArc (cat [pure "a", pure "b", pure "c"]) (Arc 0 5)- `shouldBe` fmap- toEvent- [ (((0, 1), (0, 1)), "a" :: String),- (((1, 2), (1, 2)), "b"),- (((2, 3), (2, 3)), "c"),- (((3, 4), (3, 4)), "a"),- (((4, 5), (4, 5)), "b")- ]- it "can extract nested revs" $- let a = "1 2 3" :: Pattern Int- b = "4 5 6" :: Pattern Int- c = "7 8 9" :: Pattern Int- in comparePD- (Arc 0 10)- (rev $ cat [a, b, c])- (cat [rev a, rev b, rev c])-- describe "fastCat" $ do- it "can switch between the cycles from three pures inside one cycle" $ do- it "1" $- queryArc (fastCat [pure "a", pure "b", pure "c"]) (Arc 0 1)- `shouldBe` fmap- toEvent- [ (((0, 1 / 3), (0, 1 / 3)), "a" :: String),- (((1 / 3, 2 / 3), (1 / 3, 2 / 3)), "b"),- (((2 / 3, 1), (2 / 3, 1)), "c")- ]- it "5/3" $- queryArc (fastCat [pure "a", pure "b", pure "c"]) (Arc 0 (5 / 3))- `shouldBe` fmap- toEvent- [ (((0, 1 / 3), (0, 1 / 3)), "a" :: String),- (((1 / 3, 2 / 3), (1 / 3, 2 / 3)), "b"),- (((2 / 3, 1), (2 / 3, 1)), "c"),- (((1, 4 / 3), (1, 4 / 3)), "a"),- (((4 / 3, 5 / 3), (4 / 3, 5 / 3)), "b")- ]- it "works with zero-length queries" $ do- it "0" $- queryArc (fastCat [pure "a", pure "b"]) (Arc 0 0)- `shouldBe` fmap toEvent [(((0, 0.5), (0, 0)), "a" :: String)]- it "1/3" $- queryArc (fastCat [pure "a", pure "b"]) (Arc (1 % 3) (1 % 3))- `shouldBe` fmap toEvent [(((0, 0.5), (1 % 3, 1 % 3)), "a" :: String)]-- describe "rev" $ do- it "mirrors events" $ do- let forward = fastCat [fastCat [pure 7, pure 8], pure 9] :: Pattern Int- backward = fastCat [pure 9, fastCat [pure 8, pure 7]]- -- sort the events into time order to compare them- sort (queryArc (rev forward) (Arc 0 1)) `shouldBe` sort (queryArc backward (Arc 0 1))-- it "returns the original if you reverse it twice" $ do- let x = fastCat [fastCat [pure 7, pure 8], pure 9] :: Pattern Int- queryArc (rev $ rev x) (Arc 0 5) `shouldBe` queryArc x (Arc 0 5)-- describe "|>|" $ do- let a = "[1, 1] [2,2] 3" :: Pattern Int- b = "4 [5, 5] 6 7" :: Pattern Int- c = "7 8 9 10" :: Pattern Int- d = "7 [8, 9] 10 11" :: Pattern Int- it "creates silence when" $ do- it "first argument silent" $- comparePD- (Arc 0 1)- (silence |>| a)- silence- it "second argument silent" $- comparePD- (Arc 0 1)- (a |>| silence)- silence- it "creates the same pattern when left argument has the same structure" $- comparePD- (Arc 0 1)- (b |>| a)- (d |>| a)- it "can extract rev from first argument" $- comparePD- (Arc 0 1)- (rev a |>| b)- (rev (a |>| rev b))- it "is assiociative" $- comparePD- (Arc 0 1)- ((a |>| b) |>| c)- (a |>| (b |>| c))- it "is commutative in all arguments except the rightmost" $- comparePD- (Arc 0 1)- (a |>| b |>| c)- (b |>| a |>| c)-- describe "stack" $ do- let a = "1 2 3" :: Pattern Int- b = "4 5 6" :: Pattern Int- c = "7 8 9" :: Pattern Int- it "is neutral with silence" $- comparePD- (Arc 0 1)- (stack [a, silence])- a- it "can create silence" $- comparePD- (Arc 0 1)- (stack [] :: Pattern Int)- silence- it "follows commutative laws" $- comparePD- (Arc 0 1)- (stack [a, b])- (stack [b, a])- it "follows assiociative laws" $- comparePD- (Arc 0 1)- (stack [a, stack [b, c]])- (stack [stack [a, b], c])- it "can extract nested revs" $- comparePD- (Arc 0 1)- (rev $ stack [a, b, c])- (stack [rev a, rev b, rev c])-- describe "fast" $ do- let x = "1 2 3" :: Pattern Time- y = "4 5 6" :: Pattern Time- it "is neutral with speedup 1" $- comparePD- (Arc 0 1)- (fast 1 x)- x- it "mutes, when there is" $ do- it "silence in first argument" $- comparePD- (Arc 0 1)- (fast silence x)- silence- it "silence in second argument" $- comparePD- (Arc 0 1)- (fast x silence :: Pattern Time)- silence- it "speedup by 0" $- comparePD- (Arc 0 1)- (fast 0 x)- silence- it "is reciprocal to slow" $- comparePD- (Arc 0 1)- (fast 2 x)- (slow (fromRational $ 1 % 2) x)- it "can be reversed by reciprocal speedup" $- comparePD- (Arc 0 1)- (fast 2 $ fast (fromRational $ 1 % 2) x)- x- it "preserves structure" $- comparePD- (Arc 0 1)- (fast x (stack [y, y]))- (fast (stack [x, x]) y)-- describe "slow" $ do- let x = "1 2 3" :: Pattern Time- y = "4 5 6" :: Pattern Time- it "is neutral with slowdown 1" $- comparePD- (Arc 0 10)- (slow 1 x)- x- it "mutes, when there is" $ do- it "silence in first argument" $- comparePD- (Arc 0 10)- (slow silence x)- silence- it "silence in second argument" $- comparePD- (Arc 0 10)- (slow x silence :: Pattern Time)- silence- it "speedup by 0" $- comparePD- (Arc 0 10)- (slow 0 x)- silence- it "is reciprocal to fast" $- comparePD- (Arc 0 10)- (slow 2 x)- (fast (fromRational $ 1 % 2) x)- it "can be reversed by reciprocal slowdown" $- comparePD- (Arc 0 10)- (slow 2 $ slow (fromRational $ 1 % 2) x)- x- it "preserves structure" $- comparePD- (Arc 0 1)- (slow x (stack [y, y]))- (slow (stack [x, x]) y)-- describe "compress" $ do- it "squashes cycles to the start of a cycle" $ do- let p = compress (0, 0.5) $ fastCat [pure 7, pure 8] :: Pattern Int- queryArc p (Arc 0 1)- `shouldBe` fmap- toEvent- [ (((0, 0.25), (0, 0.25)), 7),- (((0.25, 0.5), (0.25, 0.5)), 8)- ]- it "squashes cycles to the end of a cycle" $ do- let p = compress (0.5, 1) $ fastCat [pure 7, pure 8] :: Pattern Int- queryArc p (Arc 0 1)- `shouldBe` fmap- toEvent- [ (((0.5, 0.75), (0.5, 0.75)), 7 :: Int),- (((0.75, 1), (0.75, 1)), 8)- ]- it "squashes cycles to the middle of a cycle" $ do- let p = compress (0.25, 0.75) $ fastCat [pure 7, pure 8]- queryArc p (Arc 0 1)- `shouldBe` fmap- toEvent- [ (((0.25, 0.5), (0.25, 0.5)), 7 :: Int),- (((0.5, 0.75), (0.5, 0.75)), 8)- ]-- describe "saw" $ do- it "goes from 0 up to 1 every cycle" $ do- it "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 (Context []) Nothing (Arc 0.25 0.25) 0.25 :: Event Double]- it "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 (Context []) Nothing (Arc 0.75 0.75) 0.75 :: Event Double]- it "can be added to" $- map value (queryArc ((+ 1) <$> saw) (Arc 0.5 0.5)) `shouldBe` [1.5 :: Float]- it "works on the left of <*>" $- queryArc ((+) <$> saw <*> pure 3) (Arc 0 1)- `shouldBe` [Event (Context []) Nothing (Arc 0 1) 3.5 :: Event Double]- it "works on the right of <*>" $- queryArc (fast 4 (pure (+ 3)) <*> saw) (Arc 0 1)- `shouldBe` [ 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 (Context []) Nothing (Arc 0 1) 0.5 :: Event Double]- it "works with half cycles" $- queryArc (rev saw) (Arc 0 0.5)- `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 (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" $- comparePD- (Arc 0 1)- (struct "t*8" (tri :: Pattern Double))- "0.125 0.375 0.625 0.875 0.875 0.625 0.375 0.125"- it "can be added to" $- comparePD- (Arc 0 1)- (struct "t*8" $ (tri :: Pattern Double) + 1)- "1.125 1.375 1.625 1.875 1.875 1.625 1.375 1.125"- describe "every" $- it "`every n id` doesn't change the pattern's structure" $ do- comparePD- (Arc 0 4)- (every 2 id "x/2" :: Pattern String)- "x/2"
− test/Sound/Tidal/ExceptionsTest.hs
@@ -1,66 +0,0 @@-{-# LANGUAGE OverloadedStrings, CPP #-}--module Sound.Tidal.ExceptionsTest where--import Test.Microspec-import Control.Exception-import Control.DeepSeq-import Data.Typeable ()-import Prelude hiding ((<*), (*>))--import Sound.Tidal.Pattern--run :: Microspec ()-run =- describe "NFData, forcing and catching exceptions" $ do- describe "instance NFData (Pattern a)" $ do- it "rnf forces argument" $ do- evaluate (rnf (Pattern undefined :: Pattern ()))- `shouldThrow` anyException----- copied from http://hackage.haskell.org/package/hspec-expectations-0.8.2/docs/src/Test-Hspec-Expectations.html#shouldThrow--shouldThrow :: (Exception e) => IO a -> Selector e -> Microspec ()-action `shouldThrow` p = prop "shouldThrow" $ monadicIO $ do- r <- Test.Microspec.run $ try action- case r of- Right _ ->- -- "finished normally, but should throw exception: " ++ exceptionType- Test.Microspec.assert False- Left e ->- -- "threw exception that did not meet expectation")- Test.Microspec.assert $ p e- where- -- a string repsentation of the expected exception's type- {-- exceptionType = (show . typeOf . instanceOf) p- where- instanceOf :: Selector a -> a- instanceOf _ = error "Test.Hspec.Expectations.shouldThrow: broken Typeable instance"- -}---- |--- A @Selector@ is a predicate; it can simultaneously constrain the type and--- value of an exception.--type Selector a = (a -> Bool)--anyException :: Selector SomeException-anyException = const True--anyErrorCall :: Selector ErrorCall-anyErrorCall = const True--errorCall :: String -> Selector ErrorCall-#if MIN_VERSION_base(4,9,0)-errorCall s (ErrorCallWithLocation msg _) = s == msg-#else-errorCall s (ErrorCall msg) = s == msg-#endif--anyIOException :: Selector IOException-anyIOException = const True--anyArithException :: Selector ArithException-anyArithException = const True
− test/Sound/Tidal/ParamsTest.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Sound.Tidal.ParamsTest where--import Test.Microspec-import TestUtils-import Sound.Tidal.Core-import Sound.Tidal.Params-import Sound.Tidal.Pattern--run :: Microspec ()-run =- describe "Sound.Tidal.Params" $ do- describe "VF params" $ do- it "should parse fractional ratio" $ do- compareP (Arc 0 1)- (sound "bd" # delay "e")- (sound "bd" # delay (1/8))-- it "should parse correctly floating point number" $ do- compareP (Arc 0 1)- (sound "bd" # delay "0.5")- (sound "bd" # delay (1/2))-- describe "VN params" $ do- it "should parse note value" $ do- compareP (Arc 0 1)- (sound "bd" # note "e")- (sound "bd" # note 4)-- it "should parse n value" $ do- compareP (Arc 0 1)- (sound "bd" # n "e")- (sound "bd" # n 4)-- it "should parse correctly floating point number" $ do- compareP (Arc 0 1)- (sound "bd" # note "0.5")- (sound "bd" # note (1/2))-
− test/Sound/Tidal/ParseTest.hs
@@ -1,254 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Sound.Tidal.ParseTest where--import Test.Microspec-import TestUtils-import Control.Exception--import Prelude hiding ((<*), (*>))--import Sound.Tidal.ExceptionsTest (shouldThrow, anyException)-import Sound.Tidal.Core-import Sound.Tidal.Pattern-import Sound.Tidal.UI (_degradeBy)--run :: Microspec ()-run =- describe "Sound.Tidal.Parse" $ do- describe "parseBP_E" $ do- it "can parse strings" $ do- compareP (Arc 0 12)- ("a b c" :: Pattern String)- (fastCat ["a", "b", "c"])- it "can parse ints" $ do- compareP (Arc 0 2)- ("0 1 2 3 4 5 6 7 8 0 10 20 30 40 50" :: Pattern Int)- (fastCat $ map (pure . read) $ words "0 1 2 3 4 5 6 7 8 0 10 20 30 40 50")- it "can parse pattern groups" $ do- compareP (Arc 0 1)- ("[bd sd] hh" :: Pattern String)- (fastCat ["bd sd", "hh"])- it "can parse pattern groups shorthand " $ do- compareP (Arc 0 1)- ("bd sd . hh hh hh" :: Pattern String)- ("[bd sd] [hh hh hh]")- it "can alternate with <>" $ do- compareP (Arc 0 2)- ("a <b c>" :: Pattern String)- (cat [fastCat ["a", "b"], fastCat ["a", "c"]])- it "can slow with /" $ do- compareP (Arc 0 2)- ("a/2" :: Pattern String)- (slow 2 $ "a")- it "can speed up with *" $ do- compareP (Arc 0 2)- ("a*8" :: Pattern String)- (fast 8 "a")- it "can elongate with _" $ do- compareP (Arc 0 2)- ("a _ _ b _" :: Pattern String)- (timeCat [(3,"a"), (2,"b")])- it "can replicate with !" $ do- compareP (Arc 0 2)- ("a! b" :: Pattern String)- (fastCat ["a", "a", "b"])- it "can replicate with ! inside {}" $ do- compareP (Arc 0 2)- ("{a a}%2" :: Pattern String)- ("{a !}%2" :: Pattern String)- it "can replicate with ! and number" $ do- compareP (Arc 0 2)- ("a!3 b" :: Pattern String)- (fastCat ["a", "a", "a", "b"])- it "can degrade with ?" $ do- compareP (Arc 0 1)- ("a?" :: Pattern String)- (degradeByDefault "a")- it "can degrade with ? and number" $ do- compareP (Arc 0 1)- ("a?0.2" :: Pattern String)- (_degradeBy 0.2 "a")- it "can degrade with ? for double patterns" $ do- compareP (Arc 0 1)- ("0.4 0.5? 0.6" :: Pattern Double)- (fastcat[0.4, degradeByDefault 0.5, 0.6])- it "can handle ? on replicated value" $ do- compareP (Arc 0 1)- ("a!8?" :: Pattern String)- ("[a!8]?" :: Pattern String)- it "can handle ? on streched value" $ do- compareP (Arc 0 1)- ("a*4@0.25?" :: Pattern String)- ("[a*4@0.25]?" :: Pattern String)- it "can stretch with @" $ do- comparePD (Arc 0 1)- ("a@2 b" :: Pattern String)- (timeCat [(2, "a"),(1,"b")])- it "can do polymeter with {}" $ do- 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 parse .. with doubles" $ do- compareP (Arc 0 2)- ("0.0 .. 8.0" :: Pattern Double)- ("0 1 2 3 4 5 6 7 8")- it "can parse .. with doubles, without spaces" $ do- compareP (Arc 0 2)- ("0.0..8.0" :: Pattern Double)- ("0 1 2 3 4 5 6 7 8")- it "can parse .. with notes" $ do- compareP (Arc 0 2)- ("0.0 .. 8.0" :: Pattern Note)- ("0 1 2 3 4 5 6 7 8")- it "can parse .. with notes, without spaces" $ do- compareP (Arc 0 2)- ("0..8" :: Pattern Note)- ("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 handle ratio shortands on a fraction" $ do- compareP (Arc 0 1)- ("1%3t" :: Pattern Rational)- ("1%9" :: Pattern Rational)- it "can handle ratio shortands on a floating point number" $ do- compareP (Arc 0 1)- ("3.33t" :: Pattern Double)- ("1.11" :: Pattern Double)- it "cannot handle fractional with floating point numerator or denominator" $ do- evaluate ("1.2%5.3" :: Pattern Time)- `shouldThrow` anyException- it "can parse a chord" $ do- compareP (Arc 0 2)- ("'major" :: Pattern Int)- ("[0,4,7]")- it "can parse two chords" $ do- compareP (Arc 0 2)- ("'major 'minor" :: Pattern Int)- ("[0,4,7] [0,3,7]")- it "can parse c chords" $ do- compareP (Arc 0 2)- ("'major 'minor 'dim7" :: Pattern Int)- ("c'major c'minor c'dim7")- it "can parse various chords" $ do- compareP (Arc 0 2)- ("c'major e'minor f'dim7" :: Pattern Int)- ("c e f" + "'major 'minor 'dim7")- it "can parse note chords" $ do- compareP (Arc 0 2)- ("c'major c'minor" :: Pattern Note)- ("'major 'minor")- it "can invert chords" $ do- compareP (Arc 0 2)- ("c'major'i" :: Pattern Note)- ("[4,7,12]")- it "can invert chords using a number" $ do- compareP (Arc 0 2)- ("c'major'i2" :: Pattern Note)- ("[7,12,16]")- it "spread chords over a range" $ do- compareP (Arc 0 2)- ("c'major'5 e'min7'5" :: Pattern Note)- ("[0,4,7,12,16] [4,7,11,14,16]")- it "can open chords" $ do- compareP (Arc 0 2)- ("c'major'o" :: Pattern Note)- ("[-12,-5,4]")- it "can drop notes in a chord" $ do- compareP (Arc 0 2)- ("c'major'd1" :: Pattern Note)- ("[-5,0,4]")- it "can apply multiple modifiers" $ do- compareP (Arc 0 2)- ("c'major'i'5" :: Pattern Note)- ("[4,7,12,16,19]")- it "can pattern modifiers" $ do- compareP (Arc 0 2)- ("c'major'<i 5>" :: Pattern Note)- ("<[4,7,12] [0,4,7,12,16]>")- it "can pattern chord names" $ do- compareP (Arc 0 2)- ("c'<major minor>'i" :: Pattern Note)- ("<[4,7,12] [3,7,12]>")- it "can pattern chord notes" $ do- compareP (Arc 0 2)- ("<c e>'<major minor>'i" :: Pattern Note)- ("<[4,7,12] [7,11,16]>")- it "handle trailing and leading whitespaces" $ do- compareP (Arc 0 1)- (" bd " :: Pattern String)- ("bd" :: Pattern String)- it "can parse negative ratio shorthands" $ do- compareP (Arc 0 1)- ("h -h" :: Pattern Double)- ("0.5 -0.5" :: Pattern Double)- it "can parse multiplied ratio shorthands" $ do- compareP (Arc 0 1)- ("3h -2q 1.5q" :: Pattern Double)- ("1.5 -0.5 0.375" :: Pattern Double)- it "can parse exponential notation value for pattern double" $ do- compareP (Arc 0 1)- ("1e3" :: Pattern Double)- ("1000" :: Pattern Double)- it "can parse negative exponential notation value for pattern double" $ do- compareP (Arc 0 1)- ("400e-3" :: Pattern Double)- ("0.4" :: Pattern Double)- it "can parse ratio shortand on exponential notation value" $ do- compareP (Arc 0 1)- ("4e2q" :: Pattern Double)- ("100" :: Pattern Double)- it "can parse euclid pattern" $ do- compareP (Arc 0 1)- ("bd(3,8,1)" :: Pattern String)- ("~ ~ bd ~ ~ bd ~ bd")- it "can parse euclid bool pattern" $ do- compareP (Arc 0 1)- ("t(3,8,1)" :: Pattern Bool)- ("f f t f f t f t")- it "doesn't crash on zeroes (1)" $ do- compareP (Arc 0 2)- ("cp/0" :: Pattern String)- (silence)- it "doesn't crash on zeroes (2)" $ do- compareP (Arc 0 2)- ("cp(5,0)" :: Pattern String)- (silence)- it "doesn't crash on zeroes (3)" $ do- compareP (Arc 0 2)- ("cp(5,c)" :: Pattern String)- (silence)- it "can't parse a floating point number as int" $ do- evaluate ("1.5" :: Pattern Int)- `shouldThrow` anyException- it "can correctly parse multiplied boolean patterns 1" $ do- compareP (Arc 0 1)- ("t*2 t*3" :: Pattern Bool)- ("1*2 1*3" :: Pattern Bool)- it "can correctly parse multiplied boolean patterns 2" $ do- compareP (Arc 0 1)- ("t*2t t" :: Pattern Bool)- ("1*2%3 1" :: Pattern Bool)- where degradeByDefault = _degradeBy 0.5
− test/Sound/Tidal/PatternTest.hs
@@ -1,547 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Sound.Tidal.PatternTest where--import Test.Microspec-import TestUtils--import Prelude hiding ((*>), (<*))--import Data.Ratio--import Sound.Tidal.Core-import Sound.Tidal.Pattern-import Sound.Tidal.UI--import qualified Data.Map.Strict as Map--run :: Microspec ()-run =- describe "Sound.Tidal.Pattern" $ do- describe "Arc" $ do- it "Arc is a Functor: Apply a given function to the start and end values of an Arc" $ do- let res = fmap (+1) (Arc 3 5)- property $ ((Arc 4 6) :: Arc) === res-- {-- describe "Event" $ do- it "(Bifunctor) first: Apply a function to the Arc elements: whole and part" $ do- let res = Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event (Context []) Int- f = (+1)- property $- first f res ===- Event (Context []) (Just $ Arc 2 3) (Arc 4 5) 5- it "(Bifunctor) second: Apply a function to the event element" $ do- let res = Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event (Context []) Int- f = (+1)- property $- second f res ===- 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 (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 (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 (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 (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 (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 (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 (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 (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 (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" $- queryArc (pure "a") (Arc 0 0)- `shouldBe` fmap toEvent [(((0,1), (0,0)), "a" :: String)]- it "1/3" $- queryArc (pure "a") (Arc (1%3) (1%3))- `shouldBe` fmap toEvent [(((0,1), (1%3,1%3)), "a" :: String)]-- describe "_fastGap" $ do- it "copes with cross-cycle queries" $ do- (queryArc(_fastGap 2 $ fastCat [pure "a", pure "b"]) (Arc 0.5 1.5))- `shouldBe`- [(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))- `shouldBe` []-- describe "<*>" $ do- it "can apply a pattern of values to a pattern of values" $ do- queryArc ((pure (+1)) <*> (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0,1), (0,1)), 4 :: Int)]- it "can take structure from the left" $ do- queryArc ((fastCat [pure (+1), pure (+2)]) <*> (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent- [(((0,0.5), (0,0.5)), 4 :: Int),- (((0.5,1), (0.5,1)), 5)- ]- it "can take structure from the right" $ do- queryArc (pure (+1) <*> (fastCat [pure 7, pure 8])) (Arc 0 1) `shouldBe` fmap toEvent- [(((0,0.5), (0,0.5)), 8 :: Int),- (((0.5,1), (0.5,1)), 9)- ]- it "can take structure from the both sides" $ do- it "one" $- queryArc ((fastCat [pure (+1), pure (+2)]) <*> (fastCat [pure 7, pure 8])) (Arc 0 1)- `shouldBe` fmap toEvent- [(((0,0.5), (0,0.5)), 8 :: Int),- (((0.5,1), (0.5,1)), 10)- ]- it "two" $- queryArc ((fastCat [pure (+1), pure (+2), pure (+3)]) <*> (fastCat [pure 7, pure 8])) (Arc 0 1)- `shouldBe` fmap toEvent- [ (((0%1, 1%3), (0%1, 1%3)), 8 :: Int),- (((1%3, 1%2), (1%3, 1%2)), 9),- (((1%2, 2%3), (1%2, 2%3)), 10),- (((2%3, 1%1), (2%3, 1%1)), 11)- ]- it "obeys pure id <*> v = v" $ do- let v = (fastCat [fastCat [pure 7, pure 8], pure 9]) :: Pattern Int- queryArc ((pure id <*> v)) (Arc 0 5) `shouldBe` queryArc v (Arc 0 5)-- it "obeys pure f <*> pure x = pure (f x)" $ do- let f = (+3)- x = 7 :: Int- queryArc (pure f <*> pure x) (Arc 0 5) `shouldBe` queryArc (pure (f x)) (Arc 0 5)-- it "obeys u <*> pure y = pure ($ y) <*> u" $ do- let u = fastCat [pure (+7), pure (+8)]- y = 6 :: Int- queryArc (u <*> pure y) (Arc 0 5) `shouldBe` queryArc (pure ($ y) <*> u) (Arc 0 5)-- it "obeys pure (.) <*> u <*> v <*> w = u <*> (v <*> w)" $ do- let u = (fastCat [pure (+7), pure (+8)]) :: Pattern (Int -> Int)- v = fastCat [pure (+3), pure (+4), pure (+5)]- w = fastCat [pure 1, pure 2]- queryArc (pure (.) <*> u <*> v <*> w) (Arc 0 5) `shouldBe` queryArc (u <*> (v <*> w)) (Arc 0 5)-- describe "<*" $ do- it "can apply a pattern of values to a pattern of functions" $ do- queryArc ((pure (+1)) <* (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent- [(((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,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- it "works within cycles" $ queryArc ((pure (+1)) *> (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0,1), (0,1)), 4 :: Int)]- it "works across cycles" $ queryArc ((pure (+1)) *> (slow 2 $ pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0,2), (0,1)), 4 :: Int)]- it "doesn't take structure from the left" $ do- queryArc (pure (+1) *> (fastCat [pure 7, pure 8])) (Arc 0 1)- `shouldBe` fmap toEvent- [(((0,0.5), (0,0.5)), 8 :: Int),- (((0.5,1), (0.5,1)), 9 :: Int)- ]-- describe "arcCycles" $ do- it "leaves a unit cycle intact" $ do- it "(0,1)" $ arcCycles (Arc 0 1) `shouldBe` [(Arc 0 1)]- it "(3,4)" $ arcCycles (Arc 3 4) `shouldBe` [(Arc 3 4)]- it "splits a cycle at cycle boundaries" $ do- it "(0,1.1)" $ arcCycles (Arc 0 1.1) `shouldBe` [(Arc 0 1),(Arc 1 1.1)]- it "(1,2,1)" $ arcCycles (Arc 1 2.1) `shouldBe` [(Arc 1 2),(Arc 2 2.1)]- it "(3 + (1%3),5.1)" $- arcCycles (Arc (3 + (1%3)) 5.1) `shouldBe` [(Arc (3+(1%3)) 4),(Arc 4 5),(Arc 5 5.1)]-- describe "unwrap" $ do- it "preserves inner structure" $ do- it "one" $- (queryArc (unwrap $ pure (fastCat [pure "a", pure ("b" :: String)])) (Arc 0 1))- `shouldBe` (queryArc (fastCat [pure "a", pure "b"]) (Arc 0 1))- it "two" $- (queryArc (unwrap $ pure (fastCat [pure "a", pure "b", fastCat [pure "c", pure ("d" :: String)]])) (Arc 0 1))- `shouldBe` (queryArc (fastCat [pure "a", pure "b", fastCat [pure "c", pure "d"]]) (Arc 0 1))- it "preserves outer structure" $ do- it "one" $- (queryArc (unwrap $ fastCat [pure $ pure "a", pure $ pure ("b" :: String)]) (Arc 0 1))- `shouldBe` (queryArc (fastCat [pure "a", pure "b"]) (Arc 0 1))- it "two" $- (queryArc (unwrap $ fastCat [pure $ pure "a", pure $ pure "b", fastCat [pure $ pure "c", pure $ pure ("d" :: String)]]) (Arc 0 1))- `shouldBe` (queryArc (fastCat [pure "a", pure "b", fastCat [pure "c", pure "d"]]) (Arc 0 1))- it "gives events whole/part timespans that are an intersection of that of inner and outer events" $ do- let a = fastCat [pure "a", pure "b"]- b = fastCat [pure "c", pure "d", pure "e"]- pp = fastCat [pure a, pure b]- queryArc (unwrap pp) (Arc 0 1)- `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- it "compresses cycles to fit outer 'whole' timearc of event" $ do- let a = fastCat [pure "a", pure "b"]- b = fastCat [pure "c", pure "d", pure "e"]- pp = fastCat [pure a, pure b]- queryArc (squeezeJoin pp) (Arc 0 1)- `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")- ]- it "preserves cycle number of inner patterns" $ do- (map value $ queryArc (squeezeJoin (pure $ struct "1" $ (sig $ id))) (Arc 3 4))- `shouldBe` [3.5]-- describe ">>=" $ do- it "can apply functions to patterns" $ do- let p = fastCat [pure 7, pure 8] :: Pattern Int- p' = do x <- p- return $ x + 1- (queryArc p' (Arc 0 1)) `shouldBe` (queryArc ((+1) <$> p) (Arc 0 1))-- it "can add two patterns together" $ do- let p1 = fastCat [pure 7, pure 8, pure 9] :: Pattern Int- p2 = fastCat [pure 4, fastCat [pure 5, pure 6]]- p' = do x <- p1- y <- p2- return $ x + y- compareP (Arc 0 1) p' ((+) <$> p1 <*> p2)-- it "conforms to (return v) >>= f = f v" $ do- let f x = pure $ x + 10- v = 5 :: Int- compareP (Arc 0 5) ((return v) >>= f) (f v)- it "conforms to m >>= return ≡ m" $ do- let m = fastCat [pure "a", fastCat [pure "b", pure ("c" :: String)]]- compareP (Arc 0 1) (m >>= return) m- -- it "conforms to (m >>= f) >>= g ≡ m >>= ( \x -> (f x >>= g) )" $ do- -- let m = fastCat [pure "a", fastCat [pure "b", pure "c"]]-- describe "rotR" $ do- it "works over two cycles" $- property $ comparePD (Arc 0 2) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String))- it "works over one cycle" $- property $ compareP (Arc 0 1) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String))- it "works with zero width queries" $- property $ compareP (Arc 0 0) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String))-- describe "comparePD" $ do- it "allows split events to be compared" $- property $ comparePD (Arc 0 2)- (splitQueries $ _slow 2 $ pure ("a" :: String))- (_slow 2 $ pure "a")-- describe "controlI" $ do- it "can retrieve values from state" $- (query (pure 3 + cF_ "hello") $ State (Arc 0 1) (Map.singleton "hello" (VF 0.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 (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 (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 (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 (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 (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 (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 (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 (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) - property $ False === eventHasOnset ev-- describe "sam" $ do- it "start of a cycle, round down time value" $ do- let res = sam (3.4 :: Time)- property $ (3.0 :: Time) === res-- describe "nextSam" $ do- it "the end point of the current cycle, and start of the next" $ do- let res = nextSam (3.4 :: Time)- property $ (4.0 :: Time) === res-- describe "arcCycles" $ do - it "if start time is greater than end time return empty list" $ do - let res = arcCycles (Arc 2.3 2.1)- property $ [] === res - it "if start time is equal to end time return empty list" $ do - let res = arcCycles (Arc 3 3)- property $ [] === res- it "if start and end time round down to same value return list of (start, end)" $ do- let res = arcCycles (Arc 2.1 2.3) - property $ [(Arc 2.1 2.3)] === res- it "if start time is less than end time and start time does not round down to same value as end time" $ do- let res = arcCycles (Arc 2.1 3.3)- property $ [(Arc 2.1 3.0), (Arc 3.0 3.3)] === res-- describe "arcCyclesZW" $ do- it "if start and end time are equal return list of (start, end)" $ do- let res = arcCyclesZW (Arc 2.5 2.5)- property $ [(Arc 2.5 2.5)] === res- it "if start and end time are not equal call arcCycles (start, end) with same rules as above" $ do- let res = arcCyclesZW (Arc 2.3 2.1)- property $ [] === res- it "if start time is less than end time" $ do- let res = arcCyclesZW (Arc 2.1 2.3)- property $ [(Arc 2.1 2.3)] === res- it "if start time is greater than end time" $ do- let res = arcCyclesZW (Arc 2.1 3.3)- property $ [(Arc 2.1 3.0), (Arc 3.0 3.3)] === res-- describe "mapCycle" $ do- it "Apply a function to the Arc values minus the start value rounded down (sam'), adding both results to sam' to obtain the new Arc value" $ do- let res = mapCycle (*2) (Arc 3.3 5)- property $ ((Arc 3.6 7.0) :: Arc) === res-- describe "toTime" $ do- it "Convert a number of type Real to a Time value of type Rational, Int test" $ do- let res = toTime (3 :: Int)- property $ (3 % 1 :: Time) === res- it "Convert a number of type Double to a Time value of type Rational" $ do- let res = toTime (3.2 :: Double)- property $ (3602879701896397 % 1125899906842624 :: Time) === res-- describe "cyclePos" $ do- it "Subtract a Time value from its value rounded down (the start of the cycle)" $ do- let res = cyclePos 2.6- property $ (0.6 :: Time) === res- it "If no difference between a given Time and the start of the cycle" $ do- let res = cyclePos 2- property $ (0.0 :: Time) === res-- describe "isIn" $ do- it "Check given Time is inside a given Arc value, Time is greater than start and less than end Arc values" $ do- let res = isIn (Arc 2.0 2.8) 2.5- property $ True === res- it "Given Time is equal to the Arc start value" $ do- let res = isIn (Arc 2.0 2.8) 2.0- property $ True === res- it "Given Time is less than the Arc start value" $ do- let res = isIn (Arc 2.0 2.8) 1.4- property $ False === res- it "Given Time is greater than the Arc end value" $ do- let res = isIn (Arc 2.0 2.8) 3.2- property $ False === res-- 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 (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 (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 (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 (Context []) (Just $ Arc 3.1 3.5) (Arc 4.0 4.6) (5 :: Int))- property $ False === res-- describe "subArc" $ do- it "Checks if an Arc is within another, returns Just (max $ (fst a1) (fst a2), min $ (snd a1) (snd a2)) if so, otherwise Nothing" $ do - let res = subArc (Arc 2.1 2.4) (Arc 2.4 2.8)- property $ Nothing === res- it "if max (fst arc1) (fst arc2) <= min (snd arc1) (snd arc2) return Just (max (fst arc1) (fst arc2), min...)" $ do- let res = subArc (Arc 2 2.8) (Arc 2.4 2.9)- property $ Just (Arc 2.4 2.8) === res-- describe "timeToCycleArc" $ do- it "given a Time value return the Arc in which it resides" $ do- let res = timeToCycleArc 2.2 - property $ (Arc 2.0 3.0) === res-- describe "cyclesInArc" $ do - it "Return a list of cycles in a given arc, if start is greater than end return empty list" $ do - let res = cyclesInArc (Arc 2.4 2.2)- property $ ([] :: [Int]) === res- it "If start value of Arc is equal to end value return list with start value rounded down" $ do- let res = cyclesInArc (Arc 2.4 2.4)- property $ ([2] :: [Int]) === res- it "if start of Arc is less than end return list of start rounded down to end rounded up minus one" $ do- let res = cyclesInArc (Arc 2.2 4.5)- property $ ([2,3,4] :: [Int]) === res -- describe "cycleArcsInArc" $ do- it "generates a list of Arcs based on the cycles found within a given a Arc" $ do- let res = cycleArcsInArc (Arc 2.2 4.5) - property $ [(Arc 2.0 3.0), (Arc 3.0 4.0), (Arc 4.0 5.0)] === res-- describe "isAdjacent" $ do- it "if the given Events are adjacent parts of the same whole" $ do - 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 (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 (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 (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 - it "if empty list with no events return empty list" $ do - let res = defragParts ([] :: [Event Int]) - property $ [] === res- it "if list consists of only one Event return it as is" $ do - 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 (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 (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 "sect" $ do - it "take two Arcs and return - Arc (max of two starts) (min of two ends)" $ do- let res = sect (Arc 2.2 3) (Arc 2 2.9)- property $ Arc 2.2 2.9 == res-- describe "hull" $ do - it "take two Arcs anre return - Arc (min of two starts) (max of two ends)" $ do- let res = hull (Arc 2.2 3) (Arc 2 2.9) - property $ Arc 2 3 == res-- describe "withResultArc" $ do - it "apply given function to the Arcs" $ do- 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)]-- describe "applyFIS" $ do - it "apply Float function when value of type VF" $ do - let res = applyFIS (+1) (+1) (++ "1") (VF 1)- property $ (VF 2.0) === res- it "apply Int function when value of type VI" $ do - let res = applyFIS (+1) (+1) (++ "1") (VI 1)- property $ (VI 2) === res- it "apply String function when value of type VS" $ do- let res = applyFIS (+1) (+1) (++ "1") (VS "1")- property $ (VS "11") === res -- describe "fNum2" $ do- it "apply Int function for two Int values" $ do - let res = fNum2 (+) (+) (VI 2) (VI 3)- property $ (VI 5) === res - it "apply float function when given two float values" $ do - let res = fNum2 (+) (+) (VF 2) (VF 3)- property $ (VF 5.0) === res - it "apply float function when one float and one int value given" $ do- let res = fNum2 (+) (+) (VF 2) (VI 3) - property $ (VF 5.0) === res -- describe "getI" $ do - it "get Just value when Int value is supplied" $ do- let res = getI (VI 3)- property $ (Just 3) === res- it "get floored value when float value is supplied" $ do- let res = getI (VF 3.5)- property $ (Just 3) === res- it "get if String value is supplied" $ do- let res = getI (VS "3")- property $ Nothing === res-- describe "getF" $ do - it "get Just value when Float value is supplied" $ do- let res = getF (VF 3)- property $ (Just 3.0) === res- it "get converted value if Int value is supplied" $ do- let res = getF (VI 3)- property $ (Just 3.0) === res-- describe "getS" $ do - it "get Just value when String value is supplied" $ do- let res = getS (VS "Tidal")- property $ (Just "Tidal") === res- it "get Nothing if Int value is not supplied" $ do- let res = getS (VI 3) - property $ Nothing === res-- describe "filterValues" $ do - it "remove Events above given threshold" $ do - let fil = filterValues (<2) $ fastCat [pure 1, pure 2, pure 3] :: Pattern Time - let res = queryArc fil (Arc 0.5 1.5)- property $ fmap toEvent [(((1, 4%3), (1, 4%3)), 1%1)] === res-- it "remove Events below given threshold" $ do - let fil = filterValues (>2) $ fastCat [pure 1, pure 2, pure 3] :: Pattern Time - let res = queryArc fil (Arc 0.5 1.5)- property $ fmap toEvent [(((2%3, 1), (2%3, 1)), 3%1)] === res-- describe "filterWhen" $ do - it "filter below 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 $ [] === res-- it "filter above given threshold" $ do - 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-- describe "compressArc" $ do- it "return empty if start time is greater than end time" $ do - let res = queryArc (compressArc (Arc 0.8 0.1) (fast "1 2" "3 4" :: Pattern Time) ) (Arc 1 2)- property $ [] === res-- it "return empty if start time or end time are greater than 1" $ do - let res = queryArc (compressArc (Arc 0.1 2) (fast "1 2" "3 4" :: Pattern Time)) (Arc 1 2)- property $ [] === res-- it "return empty if start or end are less than zero" $ do- let res = queryArc (compressArc (Arc (-0.8) 0.1) (fast "1 2" "3 4" :: Pattern Time)) (Arc 1 2)- property $ [] === res- - it "otherwise compress difference between start and end values of Arc" $ do- let p = fast "1 2" "3 4" :: Pattern Time- 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 (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 (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 (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 0.5)) "x")
− test/Sound/Tidal/ScalesTest.hs
@@ -1,318 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Sound.Tidal.ScalesTest where--import TestUtils-import Test.Microspec--import Prelude hiding ((<*), (*>))--import Sound.Tidal.Scales-import Sound.Tidal.Pattern--run :: Microspec ()-run =- describe "Sound.Tidal.Scales" $ do- describe "scale" $ do- describe "5 note scales" $ do- let twoOctavesOf5NoteScale = "0 1 2 3 4 5 6 7 8 9"- it "can transform notes correctly over 2 octaves - minPent" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "minPent" twoOctavesOf5NoteScale)- ("0 3 5 7 10 12 15 17 19 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - majPent" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "majPent" twoOctavesOf5NoteScale)- ("0 2 4 7 9 12 14 16 19 21"::Pattern Rational)- it "can transform notes correctly over 2 octaves - ritusen" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "ritusen" twoOctavesOf5NoteScale)- ("0 2 5 7 9 12 14 17 19 21"::Pattern Rational)- it "can transform notes correctly over 2 octaves - egyptian" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "egyptian" twoOctavesOf5NoteScale)- ("0 2 5 7 10 12 14 17 19 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - kumai" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "kumai" twoOctavesOf5NoteScale)- ("0 2 3 7 9 12 14 15 19 21"::Pattern Rational)- it "can transform notes correctly over 2 octaves - hirajoshi" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "hirajoshi" twoOctavesOf5NoteScale)- ("0 2 3 7 8 12 14 15 19 20"::Pattern Rational)- it "can transform notes correctly over 2 octaves - iwato" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "iwato" twoOctavesOf5NoteScale)- ("0 1 5 6 10 12 13 17 18 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - chinese" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "chinese" twoOctavesOf5NoteScale)- ("0 4 6 7 11 12 16 18 19 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - indian" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "indian" twoOctavesOf5NoteScale)- ("0 4 5 7 10 12 16 17 19 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - pelog" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "pelog" twoOctavesOf5NoteScale)- ("0 1 3 7 8 12 13 15 19 20"::Pattern Rational)- it "can transform notes correctly over 2 octaves - prometheus" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "prometheus" twoOctavesOf5NoteScale)- ("0 2 4 6 11 12 14 16 18 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - scriabin" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "scriabin" twoOctavesOf5NoteScale)- ("0 1 4 7 9 12 13 16 19 21"::Pattern Rational)- it "can transform notes correctly over 2 octaves - gong" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "gong" twoOctavesOf5NoteScale)- ("0 2 4 7 9 12 14 16 19 21"::Pattern Rational)- it "can transform notes correctly over 2 octaves - shang" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "shang" twoOctavesOf5NoteScale)- ("0 2 5 7 10 12 14 17 19 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - jiao" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "jiao" twoOctavesOf5NoteScale)- ("0 3 5 8 10 12 15 17 20 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - zhi" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "zhi" twoOctavesOf5NoteScale)- ("0 2 5 7 9 12 14 17 19 21"::Pattern Rational)- it "can transform notes correctly over 2 octaves - yu" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "yu" twoOctavesOf5NoteScale)- ("0 3 5 7 10 12 15 17 19 22"::Pattern Rational)- describe "6 note scales" $ do- let twoOctavesOf6NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11"- it "can transform notes correctly over 2 octaves - whole" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "whole" twoOctavesOf6NoteScale)- ("0 2 4 6 8 10 12 14 16 18 20 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - wholetone" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "wholetone" twoOctavesOf6NoteScale)- (Sound.Tidal.Scales.scale "whole" twoOctavesOf6NoteScale :: Pattern Rational)- it "can transform notes correctly over 2 octaves - augmented" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "augmented" twoOctavesOf6NoteScale)- ("0 3 4 7 8 11 12 15 16 19 20 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - augmented2" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "augmented2" twoOctavesOf6NoteScale)- ("0 1 4 5 8 9 12 13 16 17 20 21"::Pattern Rational)- it "can transform notes correctly over 2 octaves - hexMajor7" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "hexMajor7" twoOctavesOf6NoteScale)- ("0 2 4 7 9 11 12 14 16 19 21 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - hexPhrygian" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "hexPhrygian" twoOctavesOf6NoteScale)- ("0 1 3 5 8 10 12 13 15 17 20 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - hexDorian" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "hexDorian" twoOctavesOf6NoteScale)- ("0 2 3 5 7 10 12 14 15 17 19 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - hexSus" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "hexSus" twoOctavesOf6NoteScale)- ("0 2 5 7 9 10 12 14 17 19 21 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - hexMajor6" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "hexMajor6" twoOctavesOf6NoteScale)- ("0 2 4 5 7 9 12 14 16 17 19 21"::Pattern Rational)- it "can transform notes correctly over 2 octaves - hexAeolian" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "hexAeolian" twoOctavesOf6NoteScale)- ("0 3 5 7 8 10 12 15 17 19 20 22"::Pattern Rational)- describe "7 note scales" $ do- let twoOctavesOf7NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13"- it "can transform notes correctly over 2 octaves - major" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "major" twoOctavesOf7NoteScale)- ("0 2 4 5 7 9 11 12 14 16 17 19 21 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - ionian" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "ionian" twoOctavesOf7NoteScale)- (Sound.Tidal.Scales.scale "major" twoOctavesOf7NoteScale :: Pattern Rational)- it "can transform notes correctly over 2 octaves - dorian" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "dorian" twoOctavesOf7NoteScale)- ("0 2 3 5 7 9 10 12 14 15 17 19 21 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - aeolian" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale)- ("0 2 3 5 7 8 10 12 14 15 17 19 20 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - aeolian" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale)- (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale::Pattern Rational)- it "can transform notes correctly over 2 octaves - minor" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale)- (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale::Pattern Rational)- it "can transform notes correctly over 2 octaves - locrian" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "locrian" twoOctavesOf7NoteScale)- ("0 1 3 5 6 8 10 12 13 15 17 18 20 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - harmonicMinor" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "harmonicMinor" twoOctavesOf7NoteScale)- ("0 2 3 5 7 8 11 12 14 15 17 19 20 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - harmonicMajor" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "harmonicMajor" twoOctavesOf7NoteScale)- ("0 2 4 5 7 8 11 12 14 16 17 19 20 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - melodicMinor" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "melodicMinor" twoOctavesOf7NoteScale)- ("0 2 3 5 7 9 11 12 14 15 17 19 21 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - melodicMinorDesc" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "melodicMinorDesc" twoOctavesOf7NoteScale)- (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale::Pattern Rational)- it "can transform notes correctly over 2 octaves - melodicMajor" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale)- ("0 2 4 5 7 8 10 12 14 16 17 19 20 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - bartok" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "bartok" twoOctavesOf7NoteScale)- (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale::Pattern Rational)- it "can transform notes correctly over 2 octaves - hindu" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "hindu" twoOctavesOf7NoteScale)- (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale::Pattern Rational)- it "can transform notes correctly over 2 octaves - todi" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "todi" twoOctavesOf7NoteScale)- ("0 1 3 6 7 8 11 12 13 15 18 19 20 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - purvi" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "purvi" twoOctavesOf7NoteScale)- ("0 1 4 6 7 8 11 12 13 16 18 19 20 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - marva" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "marva" twoOctavesOf7NoteScale)- ("0 1 4 6 7 9 11 12 13 16 18 19 21 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - bhairav" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "bhairav" twoOctavesOf7NoteScale)- ("0 1 4 5 7 8 11 12 13 16 17 19 20 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - ahirbhairav" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "ahirbhairav" twoOctavesOf7NoteScale)- ("0 1 4 5 7 9 10 12 13 16 17 19 21 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - superLocrian" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "superLocrian" twoOctavesOf7NoteScale)- ("0 1 3 4 6 8 10 12 13 15 16 18 20 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - romanianMinor" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "romanianMinor" twoOctavesOf7NoteScale)- ("0 2 3 6 7 9 10 12 14 15 18 19 21 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - hungarianMinor" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "hungarianMinor" twoOctavesOf7NoteScale)- ("0 2 3 6 7 8 11 12 14 15 18 19 20 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - neapolitanMinor" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "neapolitanMinor" twoOctavesOf7NoteScale)- ("0 1 3 5 7 8 11 12 13 15 17 19 20 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - enigmatic" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "enigmatic" twoOctavesOf7NoteScale)- ("0 1 4 6 8 10 11 12 13 16 18 20 22 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - spanish" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "spanish" twoOctavesOf7NoteScale)- ("0 1 4 5 7 8 10 12 13 16 17 19 20 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - leadingWhole" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "leadingWhole" twoOctavesOf7NoteScale)- ("0 2 4 6 8 10 11 12 14 16 18 20 22 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - lydianMinor" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "lydianMinor" twoOctavesOf7NoteScale)- ("0 2 4 6 7 8 10 12 14 16 18 19 20 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - neapolitanMajor" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "neapolitanMajor" twoOctavesOf7NoteScale)- ("0 1 3 5 7 9 11 12 13 15 17 19 21 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - locrianMajor" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "locrianMajor" twoOctavesOf7NoteScale)- ("0 2 4 5 6 8 10 12 14 16 17 18 20 22"::Pattern Rational)- describe "8 note scales" $ do- let twoOctavesOf8NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15"- it "can transform notes correctly over 2 octaves - diminished" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale)- ("0 1 3 4 6 7 9 10 12 13 15 16 18 19 21 22"::Pattern Rational)- it "can transform notes correctly over 2 octaves - octatonic" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "octatonic" twoOctavesOf8NoteScale)- (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale::Pattern Rational)- it "can transform notes correctly over 2 octaves - diminished2" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "diminished2" twoOctavesOf8NoteScale)- ("0 2 3 5 6 8 9 11 12 14 15 17 18 20 21 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - octatonic2" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "octatonic2" twoOctavesOf8NoteScale)- (Sound.Tidal.Scales.scale "diminished2" twoOctavesOf8NoteScale::Pattern Rational)- describe "modes of limited transposition" $ do- let twoOctavesOf6NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11"- let twoOctavesOf8NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15"- let twoOctavesOf9NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17"- let twoOctavesOf10NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19"- it "can transform notes correctly over 2 octaves - messiaen1" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "messiaen1" twoOctavesOf6NoteScale)- (Sound.Tidal.Scales.scale "wholetone" twoOctavesOf6NoteScale::Pattern Rational)- it "can transform notes correctly over 2 octaves - messiaen2" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "messiaen2" twoOctavesOf8NoteScale)- (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale::Pattern Rational)- it "can transform notes correctly over 2 octaves - messiaen3" $ do- -- tone, semitone, semitone, tone, semitone, semitone, tone, semitone, semitone- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "messiaen3" twoOctavesOf9NoteScale)- ("0 2 3 4 6 7 8 10 11 12 14 15 16 18 19 20 22 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - messiaen4" $ do- -- semitone, semitone, minor third, semitone, semitone, semitone, minor third, semitone- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "messiaen4" twoOctavesOf8NoteScale)- ("0 1 2 5 6 7 8 11 12 13 14 17 18 19 20 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - messiaen5" $ do- -- semitone, major third, semitone, semitone, major third, semitone- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "messiaen5" twoOctavesOf6NoteScale)- ("0 1 5 6 7 11 12 13 17 18 19 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - messiaen6" $ do- -- tone, tone, semitone, semitone, tone, tone, semitone, semitone- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "messiaen6" twoOctavesOf8NoteScale)- ("0 2 4 5 6 8 10 11 12 14 16 17 18 20 22 23"::Pattern Rational)- it "can transform notes correctly over 2 octaves - messiaen7" $ do- -- semitone, semitone, semitone, tone, semitone, semitone, semitone, semitone, tone, semitone- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "messiaen7" twoOctavesOf10NoteScale)- ("0 1 2 3 5 6 7 8 9 11 12 13 14 15 17 18 19 20 21 23"::Pattern Rational)- describe "12 note scales" $ do- let twoOctavesOf12NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23"- it "can transform notes correctly over 2 octaves - chromatic" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "chromatic" twoOctavesOf12NoteScale)- ("0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23"::Pattern Rational)- describe "edge cases" $ do- it "responds to unknown scales by mapping to octaves" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "ergaerv" "0 1 2 3 4")- ("0 12 24 36 48"::Pattern Rational)- it "correctly maps negative numbers" $ do- compareP (Arc 0 1)- (Sound.Tidal.Scales.scale "major" "0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13")- ("0 -1 -3 -5 -7 -8 -10 -12 -13 -15 -17 -19 -20 -22 "::Pattern Rational)-
test/Sound/Tidal/StreamTest.hs view
@@ -2,19 +2,19 @@ module Sound.Tidal.StreamTest where -import Test.Microspec-import Sound.Tidal.Stream-import Sound.Tidal.Pattern-import qualified Sound.Osc.Fd as O import qualified Data.Map.Strict as M+import qualified Sound.Osc.Fd as O+import Sound.Tidal.Pattern+import Sound.Tidal.Stream+import Test.Hspec -run :: Microspec ()+run :: Spec run = describe "Sound.Tidal.Stream" $ do describe "toDatum" $ do it "should convert VN to osc float" $ do toDatum (VN (Note 3.5)) `shouldBe` O.float (3.5 :: Double)- + describe "substitutePath" $ do -- ValueMap let state = M.fromList [("sound", VS "sn"), ("n", VI 8)]@@ -24,7 +24,7 @@ substitutePath "/{sound}/{n}/vol" state `shouldBe` Just "/sn/8/vol" it "should return Nothing if a param is not present" $ do substitutePath "/{sound}/{inst}" state `shouldBe` Nothing- + describe "getString" $ do it "should return Nothing for missing params" $ do getString M.empty "s" `shouldBe` Nothing
− test/Sound/Tidal/UITest.hs
@@ -1,433 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Sound.Tidal.UITest where--import TestUtils-import Test.Microspec--import Prelude hiding ((<*), (*>))--import qualified Data.Map.Strict as Map---- import Sound.Tidal.Pattern-import Sound.Tidal.Control-import Sound.Tidal.Core-import Sound.Tidal.Params-import Sound.Tidal.ParseBP-import Sound.Tidal.Pattern-import Sound.Tidal.UI--run :: Microspec ()-run =- describe "Sound.Tidal.UI" $ do- describe "_chop" $ do- it "can chop in two bits" $ do- compareP (Arc 0 1)- (_chop 2 $ s (pure "a"))- (begin (fastcat [pure 0, pure 0.5]) # end (fastcat [pure 0.5, pure 1]) # (s (pure "a")))- it "can be slowed" $ do- compareP (Arc 0 1)- (slow 2 $ _chop 2 $ s (pure "a"))- (begin (pure 0) # end (pure 0.5) # (s (pure "a")))- it "can chop a chop" $- property $ compareTol (Arc 0 1) (_chop 6 $ s $ pure "a") (_chop 2 $ _chop 3 $ s $ pure "a")-- describe "segment" $ do- it "can turn a single event into multiple events" $ do- compareP (Arc 0 3)- (segment 4 "x")- ("x*4" :: Pattern String)- it "can turn a continuous pattern into multiple discrete events" $ do- compareP (Arc 0 3)- (segment 4 saw)- ("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)- {-- -- 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 "rolledBy" $ do- it "shifts each start of events in a list correctly" $ do- let- overTimeSpan = (Arc 0 1)- testMe = rolledBy "0.5" $ n ("[0,1,2,3]")- expectedResult = n "[0, ~ 1@7, ~@2 2@6, ~@3 3@5]"- in- compareP overTimeSpan testMe expectedResult- it "shifts each start of events in a list correctly in reverse order" $ do- let- overTimeSpan = (Arc 0 1)- testMe = rolledBy "-0.5" $ n ("[0,1,2,3]")- expectedResult = n "[3, ~ 2@7, ~@2 1@6, ~@3 0@5]"- in- compareP overTimeSpan testMe expectedResult- it "trims the result pattern if it becomes larger than the original pattern" $ do- let- overTimeSpan = (Arc 0 1)- testMe = rolledBy "1.5" $ n ("[0,1,2]")- expectedResult = n "[0, ~ 1]"- in- compareP overTimeSpan testMe expectedResult- it "does nothing for continous functions" $ do- let- overTimeSpan = (Arc 0 1)- testMe = n (rolledBy "0.25" (irand 0) |+ "[0,12]")- expectedResult = n (irand 0) |+ n "[0, 12]"- in- compareP overTimeSpan testMe expectedResult- it "does nothing when passing zero as time value" $ do- let- overTimeSpan = (Arc 0 1)- testMe = n (rolledBy "0" "[0,1,2,3]")- expectedResult = n "[0,1,2,3]"- in- compareP overTimeSpan testMe expectedResult--- describe "sometimesBy" $ do- it "does nothing when set at 0% probability" $ do- let- overTimeSpan = (Arc 0 1)- testMe = sometimesBy 0 (rev) (ps "bd*2 hh sn")- expectedResult = ps "bd*2 hh sn"- in- compareP overTimeSpan testMe expectedResult-- it "applies the 'rev' function when set at 100% probability" $ do- let- overTimeSpan = (Arc 0 1)- testMe = sometimesBy 1 (rev) (ps "bd*2 hh cp")- expectedResult = ps "cp hh bd*2"- in- compareP overTimeSpan testMe expectedResult-- describe "sometimesBy'" $ do- it "does nothing when set at 0% probability -- using const" $ do- let- overTimeSpan = (Arc 0 2)- testMe = sometimesBy' 0 (const $ s "cp") (s "bd*8")- expectedResult = s "bd*8"- in- compareP overTimeSpan testMe expectedResult-- 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 (Context []) Nothing (Arc 0 0) (0 :: Float)]- it "at 1/4 of a cycle" $- (queryArc rand (Arc 0.25 0.25)) `shouldBe`- [Event (Context []) Nothing (Arc 0.25 0.25) (0.6295689214020967:: Float)]- it "at 3/4 of a cycle" $- (queryArc rand (Arc 0.75 0.75)) `shouldBe`- [Event (Context []) Nothing (Arc 0.75 0.75) (0.20052618719637394 :: Float)]-- describe "irand" $ do- it "generates a (pseudo-random) integer between zero & i" $ do- it "at the start of a cycle" $- (queryArc (irand 10) (Arc 0 0)) `shouldBe` [Event (Context []) Nothing (Arc 0 0) (0 :: Int)]- it "at 1/4 of a cycle" $- (queryArc (irand 10) (Arc 0.25 0.25)) `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (6 :: Int)]- it "is patternable" $- (queryArc (irand "10 2") (Arc 0 1)) `shouldBe` [- Event (Context [((1,1),(3,1))]) Nothing (Arc 0 0.5) (6 :: Int), Event (Context [((4,1),(5,1))]) Nothing (Arc 0.5 1) (0 :: Int)- ]-- 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 (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 (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 (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 (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 (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 (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 (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 (Context []) Nothing (Arc 0.5 0.5) (10 :: Float)]-- describe "rot" $ do- it "rotates values in a pattern irrespective of structure" $- property $ comparePD (Arc 0 2)- (rot 1 "a ~ b c" :: Pattern String)- ( "b ~ c a" :: Pattern String)- it "works with negative values" $- property $ comparePD (Arc 0 2)- (rot (-1) "a ~ b c" :: Pattern String)- ( "c ~ a b" :: Pattern String)- it "works with complex patterns" $- property $ comparePD (Arc 0 2)- (rot (1) "a ~ [b [c ~ d]] [e <f g>]" :: Pattern String)- ( "b ~ [c [d ~ e]] [<f g> a]" :: Pattern String)-- describe "ply" $ do- it "can ply chords" $ do- compareP (Arc 0 1)- (ply 3 "[0,1] [3,4,5] 6")- ("[0,1]*3 [3,4,5]*3 6*3" :: Pattern Int)- it "can pattern the ply factor" $ do- compareP (Arc 0 1)- (ply "3 4 5" "[0,1] [3,4,5] 6")- ("[0,1]*3 [3,4,5]*4 6*5" :: Pattern Int)- describe "press" $ do- it "can syncopate a pattern" $ do- compareP (Arc 0 1)- (press "a b [c d] e")- ("[~ a] [~ b] [[~ c] [~ d]] [~ e]" :: Pattern String)- describe "pressBy" $ do- it "can syncopate a pattern by a given amount" $ do- compareP (Arc 0 1)- (pressBy (1/3) "a b [~ c]")- ("[~ a@2] [~ b@2] [~ [~ c@2]]" :: Pattern String)- describe "fix" $ do- it "can apply functions conditionally" $ do- compareP (Arc 0 1)- (fix (|+ n 1) (s "sn") (s "bd sn cp" # n 1))- (s "bd sn cp" # n "1 2 1")- it "works with complex matches" $ do- compareP (Arc 0 1)- (fix (|+ n 2) (s "sn" # n 2) (s "bd sn*4 cp" # n "1 2"))- (s "bd sn*4 cp" # n "1 [1 4] 2")- it "leaves unmatched controls in place" $ do- compareP (Arc 0 1)- (fix (|+ n 2) (s "sn" # n 2) (s "bd sn*4 cp" # n "1 2" # speed (sine + 1)))- (s "bd sn*4 cp" # n "1 [1 4] 2" # speed (sine + 1))- it "ignores silence" $ do- compareP (Arc 0 1)- (fix (|+ n 2) (silence) $ s "bd sn*4 cp" # n "1 2" # speed (sine + 1))- (s "bd sn*4 cp" # n "1 2" # speed (sine + 1))- it "treats polyphony as 'or'" $ do- compareP (Arc 0 1)- (fix (# crush 2) (n "[1,2]") $ s "bd sn" # n "1 2")- (s "bd sn" # n "1 2" # crush 2)-- describe "unfix" $ do- it "does the opposite of fix" $ do- compareP (Arc 0 1)- (unfix (|+ n 2) (s "sn" # n 2) (s "bd sn*4 cp" # n "1 2" # speed (sine + 1)))- (s "bd sn*4 cp" # n "3 [3 2] 4" # speed (sine + 1))-- describe "contrast" $ do- it "does both fix and unfix" $ do- compareP (Arc 0 1)- (contrast (|+ n 2) (|+ n 10) (s "sn" # n 2) (s "bd sn*4 cp" # n "1 2" # speed (sine + 1)))- (s "bd sn*4 cp" # n "11 [11 4] 12" # speed (sine + 1))-- describe "contrastRange" $ do- it "matches using a pattern of ranges" $ do- compareP (Arc 0 1)- (contrastRange (# crush 3) (# crush 0) (pure $ Map.singleton "n" $ (VN 0, VN 3)) $ s "bd" >| n "1 4")- (s "bd" >| n "1 4" >| crush "3 0")-- describe "euclidFull" $ do- it "can match against silence" $ do- compareP (Arc 0 1)- (euclidFull 3 8 "bd" silence)- ("bd(3,8)" :: Pattern String)-- describe "snowball" $ do- let testPattern = ("1 2 3 4"::Pattern Int)- it "acummulates a transform version of a pattern and appends the result - addition" $ do- compareP (Arc 0 1)- (snowball 3 (+) (slow 2) (testPattern))- (cat [testPattern,(testPattern+(slow 2 testPattern)),((testPattern+(slow 2 testPattern))+slow 2 (testPattern+(slow 2 testPattern)))])-- describe "soak" $ do- it "applies a transform and then appends the result -- addition" $ do- compareP (Arc 0 3)- (soak 3 (+ 1) "4 ~ 0 1")- (cat ["4 ~ 0 1"::Pattern Int,"5 ~ 1 2"::Pattern Int,"6 ~ 2 3"::Pattern Int])- it "applies a transform and then appends the result -- slow" $ do- compareP (Arc 0 7)- (soak 3 (slow 2) "4 ~ 0 1")- (cat ["4 ~ 0 1"::Pattern Int, slow 2 "4 ~ 0 1"::Pattern Int, slow 4 "4 ~ 0 1"::Pattern Int])- it "applies a transform and then appends the result -- addition patterns" $ do- compareP (Arc 0 3)- (soak 3 (+ "1 2 3") "1 1")- (cat ["1 1"::Pattern Int,"2 [3 3] 4"::Pattern Int,"3 [5 5] 7"::Pattern Int])-- describe "euclid" $ do- it "matches examples in Toussaint's paper" $ do- sequence_ $ map (\(a,b) -> it b $ compareP (Arc 0 1) a (parseBP_E b))- ([(euclid 1 2 "x", "x ~"),- (euclid 1 3 "x", "x ~ ~"),- (euclid 1 4 "x", "x ~ ~ ~"),- (euclid 4 12 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~"),- (euclid 2 5 "x", "x ~ x ~ ~"),- -- (euclid 3 4 "x", "x ~ x x"), -- Toussaint is wrong..- (euclid 3 4 "x", "x x x ~"), -- correction- (euclid 3 5 "x", "x ~ x ~ x"),- (euclid 3 7 "x", "x ~ x ~ x ~ ~"),- (euclid 3 8 "x", "x ~ ~ x ~ ~ x ~"),- (euclid 4 7 "x", "x ~ x ~ x ~ x"),- (euclid 4 9 "x", "x ~ x ~ x ~ x ~ ~"),- (euclid 4 11 "x", "x ~ ~ x ~ ~ x ~ ~ x ~"),- -- (euclid 5 6 "x", "x ~ x x x x"), -- Toussaint is wrong..- (euclid 5 6 "x", "x x x x x ~"), -- correction- (euclid 5 7 "x", "x ~ x x ~ x x"),- (euclid 5 8 "x", "x ~ x x ~ x x ~"),- (euclid 5 9 "x", "x ~ x ~ x ~ x ~ x"),- (euclid 5 11 "x", "x ~ x ~ x ~ x ~ x ~ ~"),- (euclid 5 12 "x", "x ~ ~ x ~ x ~ ~ x ~ x ~"),- -- (euclid 5 16 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~ x ~ ~ ~ ~"), -- Toussaint is wrong..- (euclid 5 16 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~ x ~ ~ ~"), -- correction- -- (euclid 7 8 "x", "x ~ x x x x x x"), -- Toussaint is wrong..- (euclid 7 8 "x", "x x x x x x x ~"), -- Correction- (euclid 7 12 "x", "x ~ x x ~ x ~ x x ~ x ~"),- (euclid 7 16 "x", "x ~ ~ x ~ x ~ x ~ ~ x ~ x ~ x ~"),- (euclid 9 16 "x", "x ~ x x ~ x ~ x ~ x x ~ x ~ x ~"),- (euclid 11 24 "x", "x ~ ~ x ~ x ~ x ~ x ~ x ~ ~ x ~ x ~ x ~ x ~ x ~"),- (euclid 13 24 "x", "x ~ x x ~ x ~ x ~ x ~ x ~ x x ~ x ~ x ~ x ~ x ~")- ] :: [(Pattern String, String)])- it "can be called with a negative first value to give the inverse" $ do- compareP (Arc 0 1)- (euclid (-3) 8 ("bd" :: Pattern String))- (euclidInv 3 8 ("bd" :: Pattern String))- it "can be called with a negative first value to give the inverse (patternable)" $ do- compareP (Arc 0 1)- (euclid (-3) 8 ("bd" :: Pattern String))- ("bd(-3,8)" :: Pattern String)--- describe "wedge" $ do- it "should not freeze tidal amount is 1" $ do- compareP (Arc 0 1)- (wedge (1) (s "ho ho:2 ho:3 hc") (rev $ s "ho ho:2 ho:3 hc"))- (s "ho ho:2 ho:3 hc")- it "should not freeze tidal amount is 0" $ do- compareP (Arc 0 1)- (wedge (0) (s "ho ho:2 ho:3 hc") (rev $ s "ho ho:2 ho:3 hc"))- (rev $ s "ho ho:2 ho:3 hc")-- describe "bite" $ do- it "can slice a pattern into bits" $ do- compareP (Arc 0 4)- (bite 4 "0 2*2" (Sound.Tidal.Core.run 8))- ("[0 1] [4 5]*2" :: Pattern Int)- it "can slice a pattern into patternable bits number" $ do- compareP (Arc 0 4)- (bite "8 4" "0 2*2" (Sound.Tidal.Core.run 8))- ("[0] [4 5]*2" :: Pattern Int)-- describe "chooseBy" $ do- it "chooses from elements based on closest scaled double value" $ do- compareP (Arc 0 4)- (("0"::Pattern Int) |+ chooseBy ((/ 4)$(sig fromRational)) [0,1,2,3])- ("<0 1 2 3>"::Pattern Int)- it "never gets an index out of bounds" $ do- compareP (Arc 0 4)- ("0" |+ chooseBy (sig fromRational) [0,1,2,3])- ("2"::Pattern Int)-- describe "arpeggiate" $ do- it "can arpeggiate" $ do- compareP (Arc 0 1)- (arpeggiate ("[bd, sn] [hh:1, cp]" :: Pattern String))- ("bd sn hh:1 cp" :: Pattern String)- it "can arpeggiate" $ do- compareP (Arc 0 4)- (arpeggiate $ "[0,0] [0,0]")- ("0 0 0 0" :: Pattern Int)- it "can arpeggiate a 'sped up' pattern" $ do- compareP (Arc 0 4)- (arpeggiate $ "[0,0]*2")- ("0 0 0 0" :: Pattern Int)-- describe "chunk" $ do- it "can chunk a rev pattern" $ do- compareP (Arc 0 4)- (chunk 2 (rev) $ ("a b c d" :: Pattern String))- (slow 2 $ "d c c d a b b a" :: Pattern String)- it "can chunk a fast pattern" $ do- compareP (Arc 0 4)- (chunk 2 (fast 2) $ "a b" :: Pattern String)- (slow 2 $ "a b b _ a _ a b" :: Pattern String)- it "should chunk backward with a negative number" $ do- compareP (Arc 0 4)- (chunk (-2) (rev) $ ("a b c d" :: Pattern String))- (slow 2 $ "a b b a d c c d" :: Pattern String)-- describe "binary" $ do- it "converts a number to a pattern of boolean" $ do- compareP (Arc 0 1)- (binary "128")- ("t f f f f f f f" :: Pattern Bool)-- describe "binaryN" $ do- it "converts a number to a pattern of boolean of specified length" $ do- compareP (Arc 0 1)- (binaryN 4 "8")- ("t f f f" :: Pattern Bool)- it "converts a number to a pattern of boolean of specified patternable length" $ do- compareP (Arc 0 2)- (binaryN "<4 8>" "8")- (cat ["t f f f", "f f f f t f f f"] :: Pattern Bool)-- describe "off" $ do- it "superimposes and shifts pattern" $ do- compareP (Arc 0 1)- (off "-e" id $ s "0")- (superimpose ("e" <~) $ s "0")-- describe "loopFirst" $ do- it "plays the first cycle" $ do- compareP (Arc 0 1)- (loopFirst $ rotL 3 $ slow 8 $ "0 .. 7" :: Pattern Int)- ("3")-- describe "loopCycles" $ do- it "plays the first n cycles" $ do- compareP (Arc 0 1)- (loopFirst $ rotL 3 $ slow 8 $ "0 .. 7" :: Pattern Int)- ("3")-- describe "timeLoop" $ do- it "can loop time" $ do- compareP (Arc 0 1)- ((3 <~) $ (timeLoop 3 $ sound "<a b c d>"))- (sound "a")-- describe "timeLoop" $ do- it "can pattern time" $ do- compareP (Arc 0 1)- ((1 <~) $ timeLoop "<2 1>" $ sound "b")- (sound "b")-- describe "necklace" $ do- it "can specify rhythm by IOI" $ do- compareP (Arc 0 1)- (necklace 12 [4,2])- ("t f f f t f t f f f t f")-- describe "quantise" $ do- it "can quantise notes" $ do- compareP (Arc 0 1)- (segment 2 $ quantise 1 $ sine :: Pattern Note)- ("1 0" :: Pattern Note)
− test/Sound/Tidal/UtilsTest.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Sound.Tidal.UtilsTest where--import Test.Microspec--import Prelude hiding ((<*), (*>))--import Sound.Tidal.Utils--run :: Microspec ()-run =- describe "Sound.Tidal.Utils" $ do- describe "delta" $ do- it "subtracts the second element of a tuple from the first" $ do- property $ delta (3,10) === (7 :: Int)- - describe "applies function to both elements of tuple" $ do- let res = mapBoth (+1) (2,5) - property $ ((3,6) :: (Int, Int)) === res-- describe "apply function to first element of tuple" $ do- let res = mapFst (+1) (2, 5) - property $ ((3, 5) :: (Int, Int)) === res-- describe "apply function to second element of tuple" $ do- let res = mapSnd (+1) (2, 5)- property $ ((2, 6) :: (Int, Int)) === res- - describe "return midpoint between first and second tuple value" $ do- let res = mid (2, 5)- property $ (3.5 :: Double) === res-- describe "return of two lists, with unique values to each list" $ do- let res = removeCommon [1,2,5,7,12,16] [2,3,4,5,15,16]- property $ (([1,7,12],[3,4,15]) :: ([Int], [Int])) === res-- describe "wrap around indexing" $ do- let res = (!!!) [1..5] 7- property $ (3 :: Int) === res-- describe "safe list indexing" $ do - let res = nth 2 ([] :: [Int])- property $ Nothing === res-- describe "list accumulation with given list elements" $ do- let res = accumulate ([1..5] :: [Int])- property $ [1,3,6,10,15] === res -- describe "index elements in list" $ do- let res = enumerate ['a', 'b', 'c']- property $ [(0,'a'),(1,'b'),(2,'c')] === res-- describe "split list by given pred" $ do - let res = wordsBy (== ':') "bd:3"- property $ ["bd", "3"] === res
test/Test.hs view
@@ -1,29 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Microspec--import Sound.Tidal.CoreTest-import Sound.Tidal.ParamsTest-import Sound.Tidal.ParseTest-import Sound.Tidal.PatternTest-import Sound.Tidal.ControlTest-import Sound.Tidal.ScalesTest-import Sound.Tidal.ChordsTest import Sound.Tidal.StreamTest-import Sound.Tidal.UITest-import Sound.Tidal.UtilsTest-import Sound.Tidal.ExceptionsTest+import Test.Hspec main :: IO ()-main = microspec $ do- Sound.Tidal.CoreTest.run- Sound.Tidal.ParseTest.run- Sound.Tidal.ParamsTest.run- Sound.Tidal.PatternTest.run- Sound.Tidal.ControlTest.run- Sound.Tidal.ScalesTest.run- Sound.Tidal.ChordsTest.run+main = hspec $ do Sound.Tidal.StreamTest.run- Sound.Tidal.UITest.run- Sound.Tidal.UtilsTest.run- Sound.Tidal.ExceptionsTest.run
test/TestUtils.hs view
@@ -1,56 +1,71 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-} module TestUtils where -import Test.Microspec--import Prelude hiding ((<*), (*>))- import Data.List (sort)--import Sound.Tidal.Context- import qualified Data.Map.Strict as Map+import Sound.Tidal.ParseBP (parseBP_E)+import Sound.Tidal.Pattern+ ( Arc,+ ArcF (Arc),+ Context (Context),+ ControlPattern,+ Event,+ EventF (Event, value),+ Pattern,+ Value (VF, VI, VR, VS),+ ValueMap,+ defragParts,+ queryArc,+ setContext,+ )+import Sound.Tidal.Show ()+import Test.Hspec (Expectation, shouldBe)+import Prelude hiding ((*>), (<*)) class TolerantEq a where- (~==) :: a -> a -> Bool+ (~==) :: a -> a -> Bool instance TolerantEq Double where+ (~==) :: Double -> Double -> Bool a ~== b = abs (a - b) < 0.000001 instance TolerantEq Value where- (VS a) ~== (VS b) = a == b- (VI a) ~== (VI b) = a == b- (VR a) ~== (VR b) = a == b- (VF a) ~== (VF b) = abs (a - b) < 0.000001- _ ~== _ = False+ (~==) :: Value -> Value -> Bool+ (VS a) ~== (VS b) = a == b+ (VI a) ~== (VI b) = a == b+ (VR a) ~== (VR b) = a == b+ (VF a) ~== (VF b) = abs (a - b) < 0.000001+ _ ~== _ = False -instance TolerantEq a => TolerantEq [a] where+instance (TolerantEq a) => TolerantEq [a] where+ (~==) :: (TolerantEq a) => [a] -> [a] -> Bool as ~== bs = (length as == length bs) && all (uncurry (~==)) (zip as bs) instance TolerantEq ValueMap where+ (~==) :: ValueMap -> ValueMap -> Bool a ~== b = Map.differenceWith (\a' b' -> if a' ~== b' then Nothing else Just a') a b == Map.empty instance TolerantEq (Event ValueMap) where+ (~==) :: Event ValueMap -> Event ValueMap -> Bool (Event _ w p x) ~== (Event _ w' p' x') = w == w' && p == p' && x ~== x' -- | Compare the events of two patterns using the given arc-compareP :: (Ord a, Show a) => Arc -> Pattern a -> Pattern a -> Property+compareP :: (Ord a, Show a) => Arc -> Pattern a -> Pattern a -> Expectation compareP a p p' =- (sort $ queryArc (stripContext p) a)- `shouldBe`- (sort $ queryArc (stripContext p') a)+ sort (queryArc (stripContext p) a)+ `shouldBe` sort (queryArc (stripContext p') a) -- | Like @compareP@, but tries to 'defragment' the events-comparePD :: (Ord a, Show a) => Arc -> Pattern a -> Pattern a -> Property+comparePD :: (Ord a, Show a) => Arc -> Pattern a -> Pattern a -> Expectation comparePD a p p' =- (sort $ defragParts $ queryArc (stripContext p) a)- `shouldBe`- (sort $ defragParts $ queryArc (stripContext p') a)+ sort (defragParts $ queryArc (stripContext p) a)+ `shouldBe` sort (defragParts $ queryArc (stripContext p') a) -- | Like @compareP@, but for control patterns, with some tolerance for floating point error compareTol :: Arc -> ControlPattern -> ControlPattern -> Bool-compareTol a p p' = (sort $ queryArc (stripContext p) a) ~== (sort $ queryArc (stripContext 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@@ -58,3 +73,6 @@ stripContext :: Pattern a -> Pattern a stripContext = setContext $ Context []++firstCycleValues :: Pattern a -> [a]+firstCycleValues pat = map value $ queryArc pat (Arc 0 1)
test/dontcrash.hs view
@@ -1,15 +1,12 @@--- | test cases collected from some "Crash bugs"--{-# language OverloadedStrings #-}+-- \| test cases collected from some "Crash bugs"+{-# LANGUAGE OverloadedStrings #-} import Control.Concurrent (threadDelay) import Control.Monad (forM_)- import Sound.Tidal.Context - main = do- tidal <- startTidal (superdirtTarget {oLatency = 0.1, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig {cFrameTimespan = 1/20})+ tidal <- startTidal (superdirtTarget {oLatency = 0.1, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig) let p = streamReplace tidal d1 = p 1 . (|< orbit 0) @@ -17,30 +14,31 @@ -- interspersed with a simple pattern. -- The test is whether we hear that simple pattern each time, -- indicating that the Tidal main loop is still usable.- let go ps = forM_ (zip [0::Int ..] ps) $ \ (k,p) -> do- let wait s = threadDelay $ s * 10^6+ let go ps = forM_ (zip [0 :: Int ..] ps) $ \(k, p) -> do+ let wait s = threadDelay $ s * 10 ^ 6 simple = s "[bd*4, 808cy*8]" putStrLn $ "--- playing test pattern " ++ show k ++ " -----"- d1 $ p ; wait 2+ d1 $ p+ wait 2 putStrLn $ "---------------- playing simple pattern"- d1 $ simple ; wait 2-- go [ "cr"-- -- https://github.com/tidalcycles/Tidal/issues/606#issue-563234396- , gain (unwrap $ fmap (["1", "0."]!!) $ "{0 0@7 0 1@7}%16") # s "harmor" # midichan 11-- -- https://github.com/tidalcycles/Tidal/issues/606#issuecomment-598776256- , superimpose (hurry "<0.5 2?") $ sound "bd"+ d1 $ simple+ wait 2 - -- https://github.com/tidalcycles/Tidal/issues/477#issue-411754641- , let mkpat name pattern = (name,pattern)- mkfx name fx = (name,fx)- structure = cat [- "kicks@8 [kicks,snares]@7 kicks:backrush"- , "[kicks@3 [kicks@3 kicks(3,8,1):r]]@4 [kicks]@4 [kicks]@7 kicks:r"- ]- pats = [ mkpat "kicks" $ sometimes ghost $ s "bd(<4 5 3 6>,16,<0 1 0 3>)" ]- fx = [ mkfx "r" (# speed "-1") ]+ go+ [ "cr",+ -- https://github.com/tidalcycles/Tidal/issues/606#issue-563234396+ gain (unwrap $ fmap (["1", "0."] !!) $ "{0 0@7 0 1@7}%16") # s "harmor" # midichan 11,+ -- https://github.com/tidalcycles/Tidal/issues/606#issuecomment-598776256+ superimpose (hurry "<0.5 2?") $ sound "bd",+ -- https://github.com/tidalcycles/Tidal/issues/477#issue-411754641+ let mkpat name pattern = (name, pattern)+ mkfx name fx = (name, fx)+ structure =+ cat+ [ "kicks@8 [kicks,snares]@7 kicks:backrush",+ "[kicks@3 [kicks@3 kicks(3,8,1):r]]@4 [kicks]@4 [kicks]@7 kicks:r"+ ]+ pats = [mkpat "kicks" $ sometimes ghost $ s "bd(<4 5 3 6>,16,<0 1 0 3>)"]+ fx = [mkfx "r" (# speed "-1")] in ur 16 structure pats fx- ]+ ]
tidal.cabal view
@@ -1,19 +1,19 @@ cabal-version: 2.0 name: tidal-version: 1.9.5+version: 1.10.0 synopsis: Pattern language for improvised music description: Tidal is a domain specific language for live coding patterns. homepage: http://tidalcycles.org/ license: GPL-3 license-file: LICENSE author: Alex McLean-maintainer: Alex McLean <alex@slab.org>, Mike Hodnick <mike.hodnick@gmail.com>+maintainer: Alex McLean <alex@slab.org>, Matthew Kaney, Martin Gius Stability: Experimental-Copyright: (c) Alex McLean and other contributors, 2021+Copyright: (c) Alex McLean and other contributors, 2025 category: Sound build-type: Simple-tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1, GHC == 9.0.1+tested-with: GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.4.8, GHC == 9.8.2 data-files: BootTidal.hs Extra-source-files: README.md CHANGELOG.md tidal.el@@ -27,47 +27,41 @@ autogen-modules: Paths_tidal - Exposed-modules: Sound.Tidal.Bjorklund- Sound.Tidal.Chords+ Exposed-modules: + Sound.Tidal.Boot Sound.Tidal.Config- Sound.Tidal.Control Sound.Tidal.Context- Sound.Tidal.Core Sound.Tidal.ID- Sound.Tidal.Params- Sound.Tidal.ParseBP- Sound.Tidal.Pattern- Sound.Tidal.Scales Sound.Tidal.Safe.Context Sound.Tidal.Safe.Boot- Sound.Tidal.Show- Sound.Tidal.Simple Sound.Tidal.Stream- Sound.Tidal.StreamTypes- Sound.Tidal.Tempo- Sound.Tidal.Time+ Sound.Tidal.Stream.Listen+ Sound.Tidal.Stream.Main+ Sound.Tidal.Stream.Process+ Sound.Tidal.Stream.Target+ Sound.Tidal.Stream.Types+ Sound.Tidal.Stream.UI Sound.Tidal.Transition- Sound.Tidal.UI- Sound.Tidal.Utils Sound.Tidal.Version Paths_tidal Build-depends: base >=4.8 && <5- , containers < 0.8+ , containers < 0.9 , colour < 2.4- , hosc >= 0.20 && < 0.21+ , hosc >= 0.21 && < 0.22 , text < 2.2 , parsec >= 3.1.12 && < 3.2- , network < 3.2+ , network < 3.3 , transformers >= 0.5 && < 0.7 , bytestring < 0.13 , clock < 0.9- , deepseq >= 1.1.0.0+ , deepseq >=1.1.0.0 && < 1.7 , primitive < 0.10- , random < 1.3+ , random < 1.4 , exceptions < 0.11- , mtl >= 2.2- , tidal-link == 1.0.3+ , mtl >= 2.2 && < 2.4+ , tidal-link >= 1.1 && < 1.2+ , tidal-core == 1.10 test-suite tests type: exitcode-stdio-1.0@@ -75,26 +69,18 @@ hs-source-dirs: test ghc-options: -Wall- other-modules: Sound.Tidal.ControlTest- Sound.Tidal.CoreTest- Sound.Tidal.ParamsTest- Sound.Tidal.ParseTest- Sound.Tidal.PatternTest- Sound.Tidal.ScalesTest- Sound.Tidal.ChordsTest+ other-modules: Sound.Tidal.StreamTest- Sound.Tidal.UITest- Sound.Tidal.UtilsTest- Sound.Tidal.ExceptionsTest TestUtils build-depends:- base ==4.*- , microspec >= 0.2.0.1- , hosc >= 0.20 && < 0.21- , containers- , parsec- , tidal- , deepseq+ base >=4 && <5,+ hspec >=2.11.9,+ hosc >=0.21 && <0.22,+ containers,+ parsec,+ tidal,+ tidal-core,+ deepseq default-language: Haskell2010 @@ -103,7 +89,10 @@ type: exitcode-stdio-1.0 main-is: dontcrash.hs hs-source-dirs: test- build-depends: base, tidal+ build-depends: base,+ tidal,+ tidal-core+ default-language: Haskell2010 benchmark bench-speed@@ -115,9 +104,11 @@ Tidal.UIB Tidal.Inputs build-depends:- base == 4.*- , criterion >= 1.6.3.0- , tidal+ base >=4 && <5,+ criterion >=1.6.3.0,+ tidal,+ tidal-core+ ghc-options: -Wall default-language: Haskell2010@@ -129,9 +120,11 @@ other-modules: Tidal.UIB Tidal.Inputs build-depends:- base == 4.*- , weigh- , tidal+ base >=4 && <5,+ weigh,+ tidal,+ tidal-core+ ghc-options: -Wall default-language: Haskell2010
tidal.el view
@@ -240,9 +240,9 @@ ;; Generate the functions `tidal-run-d1' and `tidal-stop-d1' (tidal-create-runner "d1") -;; This generates tidal-run-* and tidal-stop-* functions for d1 to d9.+;; This generates tidal-run-* and tidal-stop-* functions for d1 to d10. (mapc #'tidal-create-runner- '("d1" "d2" "d3" "d4" "d5" "d6" "d7" "d8" "d9"))+ '("d1" "d2" "d3" "d4" "d5" "d6" "d7" "d8" "d9" "d10")) (defun tidal-run-region () "Place the region in a do block and compile."@@ -264,6 +264,11 @@ (interactive) (tidal-send-string "main")) +(defun tidal-hush ()+ "Stop all the patterns currently running."+ (interactive)+ (tidal-send-string "hush"))+ (defun tidal-interrupt-haskell () "Interrupt running process." (interactive)@@ -287,6 +292,7 @@ (define-key map [?\C-c ?\C-l] 'tidal-load-buffer) (define-key map [?\C-c ?\C-i] 'tidal-interrupt-haskell) (define-key map [?\C-c ?\C-m] 'tidal-run-main)+ (define-key map [?\C-c ?\C-h] 'tidal-hush) (define-key map [?\C-c ?\C-1] 'tidal-run-d1) (define-key map [?\C-c ?\C-2] 'tidal-run-d2) (define-key map [?\C-c ?\C-3] 'tidal-run-d3)@@ -296,6 +302,7 @@ (define-key map [?\C-c ?\C-7] 'tidal-run-d7) (define-key map [?\C-c ?\C-8] 'tidal-run-d8) (define-key map [?\C-c ?\C-9] 'tidal-run-d9)+ (define-key map [?\C-c ?\C-0] 'tidal-run-d10) (define-key map [?\C-v ?\C-1] 'tidal-stop-d1) (define-key map [?\C-v ?\C-2] 'tidal-stop-d2) (define-key map [?\C-v ?\C-3] 'tidal-stop-d3)@@ -304,7 +311,8 @@ (define-key map [?\C-v ?\C-6] 'tidal-stop-d6) (define-key map [?\C-v ?\C-7] 'tidal-stop-d7) (define-key map [?\C-v ?\C-8] 'tidal-stop-d8)- (define-key map [?\C-v ?\C-9] 'tidal-stop-d9))+ (define-key map [?\C-v ?\C-9] 'tidal-stop-d9)+ (define-key map [?\C-c ?\C-0] 'tidal-stop-d10)) (defun tidal-turn-on-keybindings () "Haskell Tidal keybindings in the local map."@@ -318,6 +326,7 @@ (local-set-key [?\C-c ?\C-l] 'tidal-load-buffer) (local-set-key [?\C-c ?\C-i] 'tidal-interrupt-haskell) (local-set-key [?\C-c ?\C-m] 'tidal-run-main)+ (local-set-key [?\C-c ?\C-h] 'tidal-hush) (local-set-key [?\C-c ?\C-1] 'tidal-run-d1) (local-set-key [?\C-c ?\C-2] 'tidal-run-d2) (local-set-key [?\C-c ?\C-3] 'tidal-run-d3)@@ -327,6 +336,7 @@ (local-set-key [?\C-c ?\C-7] 'tidal-run-d7) (local-set-key [?\C-c ?\C-8] 'tidal-run-d8) (local-set-key [?\C-c ?\C-9] 'tidal-run-d9)+ (local-set-key [?\C-c ?\C-0] 'tidal-run-d10) (local-set-key [?\C-v ?\C-1] 'tidal-stop-d1) (local-set-key [?\C-v ?\C-2] 'tidal-stop-d2) (local-set-key [?\C-v ?\C-3] 'tidal-stop-d3)@@ -335,7 +345,8 @@ (local-set-key [?\C-v ?\C-6] 'tidal-stop-d6) (local-set-key [?\C-v ?\C-7] 'tidal-stop-d7) (local-set-key [?\C-v ?\C-8] 'tidal-stop-d8)- (local-set-key [?\C-v ?\C-9] 'tidal-stop-d9))+ (local-set-key [?\C-v ?\C-9] 'tidal-stop-d9)+ (local-set-key [?\C-v ?\C-0] 'tidal-stop-d10)) (defun tidal-mode-menu (map) "Haskell Tidal menu MAP."