tidal 1.4.9 → 1.10.3
raw patch · 55 files changed
Files
- BootTidal.hs +17/−62
- CHANGELOG.md +468/−62
- README.md +8/−12
- Setup.hs +1/−0
- bench/Memory/Main.hs +5/−5
- bench/Memory/Tidal/Inputs.hs +69/−40
- bench/Memory/Tidal/UIB.hs +18/−13
- bench/Speed/Main.hs +6/−6
- bench/Speed/Tidal/CoreB.hs +69/−36
- bench/Speed/Tidal/Inputs.hs +57/−36
- bench/Speed/Tidal/PatternB.hs +48/−24
- bench/Speed/Tidal/UIB.hs +25/−16
- src/Sound/Tidal/Bjorklund.hs +0/−34
- src/Sound/Tidal/Boot.hs +396/−0
- src/Sound/Tidal/Carabiner.hs +0/−65
- src/Sound/Tidal/Chords.hs +0/−187
- src/Sound/Tidal/Config.hs +73/−20
- src/Sound/Tidal/Context.hs +19/−5
- src/Sound/Tidal/Control.hs +0/−717
- src/Sound/Tidal/Core.hs +0/−426
- src/Sound/Tidal/EspGrid.hs +0/−54
- src/Sound/Tidal/ID.hs +40/−0
- src/Sound/Tidal/Params.hs +0/−753
- src/Sound/Tidal/ParseBP.hs +0/−512
- src/Sound/Tidal/Pattern.hs +0/−774
- src/Sound/Tidal/Safe/Boot.hs +171/−0
- src/Sound/Tidal/Safe/Context.hs +125/−0
- src/Sound/Tidal/Scales.hs +0/−275
- src/Sound/Tidal/Show.hs +0/−203
- src/Sound/Tidal/Simple.hs +0/−50
- src/Sound/Tidal/Stream.hs +31/−478
- 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 +229/−0
- src/Sound/Tidal/Stream/Types.hs +83/−0
- src/Sound/Tidal/Stream/UI.hs +150/−0
- src/Sound/Tidal/Tempo.hs +0/−218
- src/Sound/Tidal/Transition.hs +249/−147
- src/Sound/Tidal/UI.hs +0/−1887
- src/Sound/Tidal/Utils.hs +0/−97
- src/Sound/Tidal/Version.hs +29/−1
- test/Sound/Tidal/ControlTest.hs +0/−23
- test/Sound/Tidal/CoreTest.hs +0/−141
- test/Sound/Tidal/ParseTest.hs +0/−126
- test/Sound/Tidal/PatternTest.hs +0/−556
- test/Sound/Tidal/ScalesTest.hs +0/−318
- test/Sound/Tidal/StreamTest.hs +36/−0
- test/Sound/Tidal/UITest.hs +0/−279
- test/Sound/Tidal/UtilsTest.hs +0/−56
- test/Test.hs +4/−17
- test/TestUtils.hs +57/−13
- test/dontcrash.hs +47/−0
- tidal.cabal +73/−68
- tidal.el +173/−265
BootTidal.hs view
@@ -1,72 +1,27 @@-:set -XOverloadedStrings+:set -fno-warn-orphans -Wno-type-defaults -XMultiParamTypeClasses -XOverloadedStrings :set prompt "" -import Sound.Tidal.Context+-- Import all the boot functions and aliases.+import Sound.Tidal.Boot -import System.IO (hSetEncoding, stdout, utf8)+default (Rational, Integer, Double, Pattern String) -hSetEncoding stdout utf8+-- Create a Tidal Stream with the default settings.+-- To customize these settings, use 'mkTidalWith' instead+tidalInst <- mkTidal --- total latency = oLatency + cFrameTimespan-tidal <- startTidal (superdirtTarget {oLatency = 0.1, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig {cFrameTimespan = 1/20})+-- tidalInst <- mkTidalWith [(superdirtTarget { oLatency = 0.01 }, [superdirtShape])] (defaultConfig {cFrameTimespan = 1/50, cProcessAhead = 1/20}) -:{-let p = streamReplace tidal- hush = streamHush tidal- list = streamList tidal- mute = streamMute tidal- unmute = streamUnmute tidal- solo = streamSolo tidal- unsolo = streamUnsolo tidal- once = streamOnce tidal- first = streamFirst tidal- asap = once- nudgeAll = streamNudgeAll tidal- all = streamAll tidal- resetCycles = streamResetCycles tidal- setcps = asap . cps- xfade i = transition tidal True (Sound.Tidal.Transition.xfadeIn 4) i- xfadeIn i t = transition tidal True (Sound.Tidal.Transition.xfadeIn t) i- histpan i t = transition tidal True (Sound.Tidal.Transition.histpan t) i- wait i t = transition tidal True (Sound.Tidal.Transition.wait t) i- waitT i f t = transition tidal True (Sound.Tidal.Transition.waitT f t) i- jump i = transition tidal True (Sound.Tidal.Transition.jump) i- jumpIn i t = transition tidal True (Sound.Tidal.Transition.jumpIn t) i- jumpIn' i t = transition tidal True (Sound.Tidal.Transition.jumpIn' t) i- jumpMod i t = transition tidal True (Sound.Tidal.Transition.jumpMod t) i- mortal i lifespan release = transition tidal True (Sound.Tidal.Transition.mortal lifespan release) i- interpolate i = transition tidal True (Sound.Tidal.Transition.interpolate) i- interpolateIn i t = transition tidal True (Sound.Tidal.Transition.interpolateIn t) i- clutch i = transition tidal True (Sound.Tidal.Transition.clutch) i- clutchIn i t = transition tidal True (Sound.Tidal.Transition.clutchIn t) i- anticipate i = transition tidal True (Sound.Tidal.Transition.anticipate) i- anticipateIn i t = transition tidal True (Sound.Tidal.Transition.anticipateIn t) i- forId i t = transition tidal False (Sound.Tidal.Transition.mortalOverlay t) i- 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-:}+-- This orphan instance makes the boot aliases work!+-- It has to go after you define 'tidalInst'.+instance Tidally where tidal = tidalInst -:{-let setI = streamSetI tidal- setF = streamSetF tidal- setS = streamSetS tidal- setR = streamSetR tidal- setB = streamSetB tidal-:}+-- `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 prompt "tidal> " :set prompt-cont ""
CHANGELOG.md view
@@ -1,35 +1,463 @@+ # TidalCycles log of changes +## 1.10.3 - Stranded++### What's Changed++* Revert link upgrade, due to windows build errors #1253++## 1.10.2 - Fairisle++### What's Changed++* Compatibility with ghc 9.6+ @yaxu https://codeberg.org/uzu/tidal/pulls/1249+* Fix 'into' for patterning subpatterns, adding 'chunkinto' for chunking into subpatterns @yaxu https://codeberg.org/uzu/tidal/pulls/1247+* Add 'revv' for reversing whole patterns rather than cycle-by-cycle @yaxu https://codeberg.org/uzu/tidal/pulls/1247+* Emacs plugin fixes, thanks @bokonist https://codeberg.org/uzu/tidal/pulls/1242+* Add _fromNote for raw string parsing, thanks @pulu https://codeberg.org/uzu/tidal/pulls/1235+* Add tidal-mondo notation! Thanks @TristanCacqueray https://codeberg.org/uzu/tidal/pulls/1233+* Fix runMarkov, thanks @jwaldmann https://codeberg.org/uzu/tidal/pulls/1232+* Add midi-related params to tidal-parse, thanks @TristanCacqueray https://codeberg.org/uzu/tidal/pulls/1225+* Reinstate 'required' alias for Nothing, used in defining OSC target defs @yaxu https://codeberg.org/uzu/tidal/pulls/1226 +* Add 'polymeter' stepwise function, with 'pm' alias ++## 1.10.1 - Dundee++### What's Changed++* Moved to codeberg ! https://codeberg.org/uzu/tidal/+* Added `ribbon`, `unjoin` and `into` by @yaxu in https://codeberg.org/uzu/tidal/pulls/1213+* Fix regression in v1.10.0, where running patterns would be unnecessarily reverted by @yaxu in https://codeberg.org/uzu/tidal/pulls/1223++## 1.10.0 - waffle++The code name 'waffle' comes from the bonkers three-dimensional fabric that appears from a surprisingly simple two-dimensional weave structure. [More info](https://www.ashford.co.nz/waffle-weave/)++++### What's Changed++This v1.10.0 release has been a bit delayed so is a bumper feast of tweaks, features, bugfixes and tidying.. If your PR missed the boat don't worry we'll do them more often from now and v1.10.1 will come soon!++#### Interface changes+* add muting with `_` for p and d1-16 by @geikha in https://github.com/tidalcycles/Tidal/pull/1082+* Add `getbpm` and `setbpm` to boot functions by @matthewkaney in https://github.com/tidalcycles/Tidal/pull/1083++#### New language features+* Add capital-M aliases for major chords by @rrrnld in https://github.com/tidalcycles/Tidal/pull/1077+* Step-oriented functionality by @yaxu in https://github.com/tidalcycles/Tidal/pull/1072+* Patterned tactus WIP by @yaxu in https://github.com/tidalcycles/Tidal/pull/1111+*`normal` signal for normally-distributed random numbers from #1055 by @patrickt (backported by @sss-create in https://github.com/tidalcycles/Tidal/pull/1101)+* Remove patterned tactus by @yaxu in https://github.com/tidalcycles/Tidal/pull/1201+* `beat` function for "step sequencer" style rhythm notation. (Backported from Strudel) by @geikha in https://github.com/tidalcycles/Tidal/pull/1109 and https://github.com/tidalcycles/Tidal/pull/1134+* Introduces two function families for introducing chromaticism in melodies by @aherrou in https://github.com/tidalcycles/Tidal/pull/1097+* clip as alias for legato by @sss-create in https://github.com/tidalcycles/Tidal/pull/1158+* Stepwise functions continued by @yaxu in https://github.com/tidalcycles/Tidal/pull/1152+* pattern weights for chooseby functions by @yaxu in https://github.com/tidalcycles/Tidal/pull/1173+* sample rand signal on onset, start rand pattern at 0.5 by @yaxu in https://github.com/tidalcycles/Tidal/pull/1176+* add bank param by @yaxu in https://github.com/tidalcycles/Tidal/pull/1190+* add stepalt by @yaxu in https://github.com/tidalcycles/Tidal/pull/1200++#### Experimental tap tempo utility+* Tap tempo WIP, bring feedforward into tidal monorepo, fix `nudgeAll` by @yaxu in https://github.com/tidalcycles/Tidal/pull/1191+* Tap tempo utility updates by @yaxu in https://github.com/tidalcycles/Tidal/pull/1196++#### Mini-notation changes+* Support `-` for rests/gaps in mininotation by @yaxu in https://github.com/tidalcycles/Tidal/pull/1087+* fixed: Parser errors for new rest symbol #1091 by @sss-create in https://github.com/tidalcycles/Tidal/pull/1113+* Toplevel ',' and '|'. by @sss-create in https://github.com/tidalcycles/Tidal/pull/1149++#### OSC listener+* #1035 added setcps and other controls to OSC Listener by @sss-create in https://github.com/tidalcycles/Tidal/pull/1102++#### Boot/config changes+* Cherry pick new Boot changes by @ejconlon and adjust to incorporate recent changes by @matthewkaney in https://github.com/tidalcycles/Tidal/pull/1081+* added a commented enable link line in BootTidal.hs by @sss-create in https://github.com/tidalcycles/Tidal/pull/1147+* link and clock setter functions by @sss-create in https://github.com/tidalcycles/Tidal/pull/1162++#### Bug fixes+* fix(slice): support `slice 1 _` by @grddavies in https://github.com/tidalcycles/Tidal/pull/1086+* doTick: use exception-safe modifyMVar_ instead of takeMVar/putMVar by @ahihi in https://github.com/tidalcycles/Tidal/pull/1100+* Fix off-by-one error in striateBy by @yaxu in https://github.com/tidalcycles/Tidal/pull/1106+* timeToRands non-zero bug by @sss-create in https://github.com/tidalcycles/Tidal/pull/1142+* Bugfix for squeezeJoin and dependencies including bite by @yaxu in https://github.com/tidalcycles/Tidal/pull/1145+* [breaking change] sample signals at query onsets instead of midpoint by @yaxu in https://github.com/tidalcycles/Tidal/pull/1148+* Fix 1068 novector by @jwaldmann in https://github.com/tidalcycles/Tidal/pull/1187+* fix for plyWith: tweak type defaults, turn off related warning by @yaxu in https://github.com/tidalcycles/Tidal/pull/1195++#### Emacs plugin+* Hush function and keybindings by @marcora in #1012 (backported by @sss-create in https://github.com/tidalcycles/Tidal/pull/1101)+* remove extra paren in tidal.el by @jezcope in https://github.com/tidalcycles/Tidal/pull/1110++#### Source code reorganisation+* replace Tempo module by an ableton-link synched clock that comes with tidal-link by @polymorphicengine in https://github.com/tidalcycles/Tidal/pull/1059+* simplify the clock logic by removing LinkOperations by @polymorphicengine in https://github.com/tidalcycles/Tidal/pull/1090+* ableton link as submodule by @sss-create in https://github.com/tidalcycles/Tidal/pull/1119+* Split controller OSC off from SuperDirt handshake OSC (Redux for 1.9) by @matthewkaney in https://github.com/tidalcycles/Tidal/pull/1051+* Extract Core Functionalities into tidal-core Package by @eilseq in https://github.com/tidalcycles/Tidal/pull/1155+* Tidal core prerelease by @yaxu in https://github.com/tidalcycles/Tidal/pull/1156+* Migrate from Microspec to Hspec by @sss-create in https://github.com/tidalcycles/Tidal/pull/1157+* Reinstate transitions by @yaxu in https://github.com/tidalcycles/Tidal/pull/1188+* Recombine configuration by @yaxu in https://github.com/tidalcycles/Tidal/pull/1203++#### Tidal-parse updates+* Enable Tidal-Parse FFI for Cross-Language Integration by @eilseq in https://github.com/tidalcycles/Tidal/pull/1143+* Add rolled and rolledBy to tidal-parse by @TristanCacqueray in https://github.com/tidalcycles/Tidal/pull/1199++#### Other maintenance+* bump upper bounds of network dependency to 3.3 by @yaxu in https://github.com/tidalcycles/Tidal/pull/1080+* more efficient sew by @yaxu in https://github.com/tidalcycles/Tidal/pull/1078, https://github.com/tidalcycles/Tidal/pull/1088+* Bump actions/download-artifact from 2 to 4.1.7 in /.github/workflows by @dependabot in https://github.com/tidalcycles/Tidal/pull/1096+* flake.nix: update nixpkgs and remove temporary hosc input by @ahihi in https://github.com/tidalcycles/Tidal/pull/1098+* CI pipeline repair by @sss-create in https://github.com/tidalcycles/Tidal/pull/1104+* hosc-0.21 support by @sss-create in https://github.com/tidalcycles/Tidal/pull/1105+* dependency bumper by @yaxu in https://github.com/tidalcycles/Tidal/pull/1117+* Bumping random by @github-actions in https://github.com/tidalcycles/Tidal/pull/1118+* renamed linktest executable by @sss-create in https://github.com/tidalcycles/Tidal/pull/1107+* Bump upper bounds by @yaxu in https://github.com/tidalcycles/Tidal/pull/1115+* Fix upload artifact by @yaxu in https://github.com/tidalcycles/Tidal/pull/1120+* delint by @yaxu in https://github.com/tidalcycles/Tidal/pull/1131+* Clean warnings by @yaxu in https://github.com/tidalcycles/Tidal/pull/1133+* substitue 'tail' with 'drop 1' by @sss-create in https://github.com/tidalcycles/Tidal/pull/1141+* change link version and bounds to conform to the PVP by @polymorphicengine in https://github.com/tidalcycles/Tidal/pull/1140+* update some out of date contributing info by @yaxu in https://github.com/tidalcycles/Tidal/pull/1154+* Delint by @yaxu in https://github.com/tidalcycles/Tidal/pull/1163+* fix warnings by @yaxu in https://github.com/tidalcycles/Tidal/pull/1175+* delint benchmarks by @yaxu in https://github.com/tidalcycles/Tidal/pull/1177+* import IsString from a portable module by @claudeha in https://github.com/tidalcycles/Tidal/pull/1204++### New Contributors <3+* @grddavies made their first contribution in https://github.com/tidalcycles/Tidal/pull/1086+* @dependabot made their first contribution in https://github.com/tidalcycles/Tidal/pull/1096+* @jezcope made their first contribution in https://github.com/tidalcycles/Tidal/pull/1110+* @github-actions made their first contribution in https://github.com/tidalcycles/Tidal/pull/1118+* @aherrou made their first contribution in https://github.com/tidalcycles/Tidal/pull/1097+* @eilseq made their first contribution in https://github.com/tidalcycles/Tidal/pull/1143+* @rrrnld made their first contribution in https://github.com/tidalcycles/Tidal/pull/1077+* @ejconlon made their first contribution in https://github.com/tidalcycles/Tidal/pull/1081+* @patrickt made their first contribution in #1055+* @marcora made their first contribution in #1012+* @TristanCacqueray made their first contribution in https://github.com/tidalcycles/Tidal/pull/1199+* @claudeha made their first contribution in https://github.com/tidalcycles/Tidal/pull/1204++**Full Changelog**: https://github.com/tidalcycles/Tidal/compare/v1.9.5...v1.10.0++## 1.9.5 - Sashiko++### What's Changed+* avoid loading stream module in other modules, so hint wont crash by @polymorphicengine in https://codeberg.org/uzu/Tidal/pull/1019+* change streamGetnow to factor in the processAhead and also destroy the sessionstate by @polymorphicengine in https://codeberg.org/uzu/Tidal/pull/1025+* fix minor7sharp9 chord (the 9th wasn't sharp) by @cleary in https://codeberg.org/uzu/Tidal/pull/1036+* add metatune param, now against 1.9-dev by @ahihi in https://codeberg.org/uzu/Tidal/pull/1046+* Build fixes for Tidal 1.9 by @mindofmatthew in https://codeberg.org/uzu/Tidal/pull/1052+* Update link 1.9 dev by @yaxu in https://codeberg.org/uzu/Tidal/pull/1058+* More build fixes by @mindofmatthew in https://codeberg.org/uzu/Tidal/pull/1062+* Consolidate site docs into source docs, and some docs editing by @trespaul in https://codeberg.org/uzu/Tidal/pull/1070+* Fix negative numbers not working for boolean euclids by @geikha in https://codeberg.org/uzu/Tidal/pull/1063++### New Contributors+* @ahihi made their first contribution in https://codeberg.org/uzu/Tidal/pull/1046+* @trespaul made their first contribution in https://codeberg.org/uzu/Tidal/pull/1070+* @geikha made their first contribution in https://codeberg.org/uzu/Tidal/pull/1063++**Full Changelog**: https://codeberg.org/uzu/Tidal/compare/v1.9.4...v1.9.5++## 1.9.4 - Stitch++### What's Changed+* fix #986 by @jwaldmann in https://codeberg.org/uzu/Tidal/pull/987+* fix #988 by @jwaldmann in https://codeberg.org/uzu/Tidal/pull/989+* Tidal listener update and rework by @polymorphicengine in https://codeberg.org/uzu/Tidal/pull/996+* ci: update GitHub actions by @SpencerIsGiddy in https://codeberg.org/uzu/Tidal/pull/994+* Fix markup errors in and add to Sound.Tidal.UI documentation. by @patrickt in https://codeberg.org/uzu/Tidal/pull/992+* reset and restart by @yaxu in https://codeberg.org/uzu/Tidal/pull/997+* Add extractN and extend getN by @thgrund in https://codeberg.org/uzu/Tidal/pull/999++### New Contributors+* @SpencerIsGiddy made their first contribution in https://codeberg.org/uzu/Tidal/pull/994+* @patrickt made their first contribution in https://codeberg.org/uzu/Tidal/pull/992++**Full Changelog**: https://codeberg.org/uzu/Tidal/compare/v1.9.3...v1.9.4++## 1.9.3 - Kolam++### What's Changed+* fix for squeezejoin by @yaxu in https://codeberg.org/uzu/Tidal/pull/950+* tidal.el fix silencer by @zzkt in https://codeberg.org/uzu/Tidal/pull/955+* add accelerate to nobus and fix typo for begin by @yaxu in https://codeberg.org/uzu/Tidal/pull/956+* Fix warnings by @Zalastax in https://codeberg.org/uzu/Tidal/pull/962+* Add a Nix Flake for building and developing Tidal by @mitchmindtree in https://codeberg.org/uzu/Tidal/pull/963+* Make distrib only take structure from the euclid by @yaxu in https://codeberg.org/uzu/Tidal/pull/961+* Fix build by @yaxu in https://codeberg.org/uzu/Tidal/pull/965+* Fix resetCycles skipping and lateness by @Zalastax in https://codeberg.org/uzu/Tidal/pull/966+* Add setCycle by @Zalastax in https://codeberg.org/uzu/Tidal/pull/969+* CHANGELOG gardening by @mindofmatthew in https://codeberg.org/uzu/Tidal/pull/971+* Comments for some state functions by @JeffreyBenjaminBrown in https://codeberg.org/uzu/Tidal/pull/973+* Comments on time, and haddock fixes by @JeffreyBenjaminBrown in https://codeberg.org/uzu/Tidal/pull/974+* Fix warning about type constraint by @mindofmatthew in https://codeberg.org/uzu/Tidal/pull/977+* Fix squeeze join by @yaxu in https://codeberg.org/uzu/Tidal/pull/975+* `trigger` and friends without pattern IDs by @mindofmatthew in https://codeberg.org/uzu/Tidal/pull/970+* Rename ghost'' to ghostWith by @Zalastax in https://codeberg.org/uzu/Tidal/pull/967+* Added minor major seventh chord by @jqueraltmo in https://codeberg.org/uzu/Tidal/pull/978+* support for hosc-0.20 by @yaxu in https://codeberg.org/uzu/Tidal/pull/981++### New Contributors+* @mitchmindtree made their first contribution in https://codeberg.org/uzu/Tidal/pull/963+* @jqueraltmo made their first contribution in https://codeberg.org/uzu/Tidal/pull/978++**Full Changelog**: https://codeberg.org/uzu/Tidal/compare/v1.9.2...v1.9.3++## 1.9.2 - Siteswap c+Same with 1.9.1, but now with new tidal-link version 1.0.1++## 1.9.1 - Siteswap b+A quick release to set specific tidal-link version 1.0 in tidal.cabal. Stack+seems to want this.++## 1.9.0 - Siteswap++### What's Changed++#### General enhancements+* Rename linux binary name by @ndr-brt in https://codeberg.org/uzu/Tidal/pull/911+* Fix echo by @ndr-brt in https://codeberg.org/uzu/Tidal/pull/910+* If first argument of euclid is negative, apply euclidInv by @polymorphicengine in https://codeberg.org/uzu/Tidal/pull/916+* Add squeeze operators (`||+`, `*||`, etc) by @yaxu in https://codeberg.org/uzu/Tidal/pull/919+* Make chunk reverse direction with negative number by @ndr-brt in https://codeberg.org/uzu/Tidal/pull/918+* overhaul of the chord parser by @polymorphicengine in https://codeberg.org/uzu/Tidal/pull/931++#### New ableton link support+* Use ableton link for scheduling by @Zalastax in https://codeberg.org/uzu/Tidal/pull/898+* tidal-link: add link source files to extra-source-files, fixes #924 by @yaxu in https://codeberg.org/uzu/Tidal/pull/925+* Use target latency in all send modes by @Zalastax in https://codeberg.org/uzu/Tidal/pull/927+* Rename cCyclesPerBeat -> cBeatsPerCycle by @Zalastax in https://codeberg.org/uzu/Tidal/pull/939++#### Emacs plugin updates+* formatting fixes in tidal.el by @zzkt in https://codeberg.org/uzu/Tidal/pull/932+* a window-excursion for tidal.el by @zzkt in https://codeberg.org/uzu/Tidal/pull/933+* autoloads for tidal.el by @zzkt in https://codeberg.org/uzu/Tidal/pull/934+* avoid race in loading bootscript during restart by @zzkt in https://codeberg.org/uzu/Tidal/pull/937++#### Tidal-parse (estuary) updates+* Various updates to tidal-parse by @dktr0 in https://codeberg.org/uzu/Tidal/pull/913 and https://codeberg.org/uzu/Tidal/pull/941++#### Maintenance+* Increase upper bounds of text dependency by @yaxu in https://codeberg.org/uzu/Tidal/pull/948+* Use system-cxx-std-lib by @Zalastax in https://codeberg.org/uzu/Tidal/pull/944+* Use c++ extra library for MacOS by @giuseppelillo in https://codeberg.org/uzu/Tidal/pull/946++### New Contributors+* @Zalastax made their first contribution in https://codeberg.org/uzu/Tidal/pull/898+* @zzkt made their first contribution in https://codeberg.org/uzu/Tidal/pull/932+* @giuseppelillo made their first contribution in https://codeberg.org/uzu/Tidal/pull/946++**Full Changelog**: https://codeberg.org/uzu/Tidal/compare/v1.8.0...v1.9.0++## 1.8.1 - Sanquhar b+* Removed executable from tidal.cabal file (while latest ghc on windows fails to build it)++## 1.8.0 - Sanquhar+* move tidal-listener code by @polymorphicengine in #885+* Fix a typo incurred (I assume) by a filename change. by @JeffreyBenjaminBrown in #886+* Hide contexts from Events per default by @polymorphicengine in #887+* Allow sending/receiving of broadcasted OSC control messages by @yaxu in #894+* tidal-listener: Add minimal install notes by @gamar3is in #895+* Add rolled function with variants by @thgrund in #820+* Valuable instance for Note by @yaxu in #899+* Add parsers for ints and floats that don't consume trailing whitespace by @polymorphicengine in #900+* Introduce echo and echoWith, deprecate stut and stutWith by @ndr-brt in #904+* tidal-listener: Optional WITH_GHC environment variable by @mindofmatthew in #903++Commit list: https://codeberg.org/uzu/Tidal/compare/1.7.10...v1.8.0++## 1.7.10 - Tama b+* Derive RealFrac for Note by @ndr-brt in https://codeberg.org/uzu/Tidal/pull/876+* Add timescale and timewin control params by @yaxu in https://codeberg.org/uzu/Tidal/pull/878+* deriving typeclass memberships for ID by @polymorphicengine in https://codeberg.org/uzu/Tidal/pull/879+* Adds the jumpMod' transition by @th-four in https://codeberg.org/uzu/Tidal/pull/881+* Import safe-tidal-cli ghci simulator as tidal binary by @yaxu in https://codeberg.org/uzu/Tidal/pull/880+* Tweaks to tidal binary, and add to linux workflow by @yaxu in https://codeberg.org/uzu/Tidal/pull/882+* add tidal ghci replacement to macos and windows workflows by @yaxu in https://codeberg.org/uzu/Tidal/pull/883++## 1.7.9 - Tama++### What's Changed+* Show lists of values by @polymorphicengine in https://codeberg.org/uzu/Tidal/pull/838+* Port listener wiki content as README by @ndr-brt in https://codeberg.org/uzu/Tidal/pull/851+* Chords - consistent naming cont'd by @cleary in https://codeberg.org/uzu/Tidal/pull/840+* Formalise pattern IDs by @mindofmatthew in https://codeberg.org/uzu/Tidal/pull/807+* Switch to non-blocking pMap updates for transitions by @bgold-cosmos in https://codeberg.org/uzu/Tidal/pull/858+* Add listener build workflows by @ndr-brt in https://codeberg.org/uzu/Tidal/pull/852+* Fix tidal-listener install process by @ndr-brt in https://codeberg.org/uzu/Tidal/pull/861+* Fix mod by @bgold-cosmos in https://codeberg.org/uzu/Tidal/pull/860+* Fix stack ci using last lts resolver by @ndr-brt in https://codeberg.org/uzu/Tidal/pull/862+* Make Pattern instance Monoid by @fbous in https://codeberg.org/uzu/Tidal/pull/865+* Added OSC playback control for silencing individual patterns by @njanssen in https://codeberg.org/uzu/Tidal/pull/863+* Use better show instances for notes & rationals by @mindofmatthew in https://codeberg.org/uzu/Tidal/pull/857+* tidal-listener: Separate build from release by @ndr-brt in https://codeberg.org/uzu/Tidal/pull/866+* Exponential double by @ndr-brt in https://codeberg.org/uzu/Tidal/pull/871+* Comments by @JeffreyBenjaminBrown in https://codeberg.org/uzu/Tidal/pull/877+* Fix for classic dirt support by @yaxu https://codeberg.org/uzu/Tidal/commit/15b5b8b91af08ebad39efe2a7e0712b21f606ca4+* New alias `number` for `n` by @yaxu https://codeberg.org/uzu/Tidal/commit/ac0be63d686ab37f7b2dcd440d4bd8f3898453e8+* Allow "0..8" to be parsed as a range of doubles in mininotation by @yaxu https://codeberg.org/uzu/Tidal/commit/55f8ad9b0091b43fdd364eced25bc9c655d157cc+* Bugfix for `timeLoop` by @yaxu in https://codeberg.org/uzu/Tidal/commit/29f28ed637a7c17ad2b22558d097a694da604e2d+* Retire pre ghc 8.4 support by @yaxu +* Pattern first parameter of `wedge` by @yaxu+* Allow `|**|` et al to work on control patterns by @yaxu in https://codeberg.org/uzu/Tidal/commit/7142775c2039cae4cde9bdd6f68b3e0cbae2de9d+* Add alias `timecat` for timeCat` by @yaxu in https://codeberg.org/uzu/Tidal/commit/363889bdc963d9357daf1893d18ab9dfc33ca5ac++### New Contributors+* @fbous made their first contribution in https://codeberg.org/uzu/Tidal/pull/865+* @njanssen made their first contribution in https://codeberg.org/uzu/Tidal/pull/863+* @JeffreyBenjaminBrown made their first contribution in https://codeberg.org/uzu/Tidal/pull/877++**Full Changelog**: https://codeberg.org/uzu/Tidal/compare/1.7.8...1.7.9++## 1.7.8 - Ayatakedai+* Add pattern id to patterns as _id_, and send it with /code/highlights++## 1.7.7 - Caramel wafer+* Support hosc 0.19 in test suite @yaxu++## 1.7.6 - Tunnocks+* Fix dot shorthand in int patterns so floating point numbers raise an error @ndr-brt+* Support factors in ratio shorthand for rational patterns @ndr-brt+* support hosc 0.19 @yaxu++## 1.7.5 - Dalbeattie+* Minor change to _splice so that it respects if the speed parameter was already declared @onthepeakofnormal+* Some tests for chords @cleary+* Remove direct semigroups dependency @yaxu+* Derive functor for pattern @yaxu+* Handle negative ratio shorthands for rationals @ndr_brt+* drawLine - draw non-events with periods @yaxu+* Parse chord without root note @yaxu+* Fix clock sharing between tidal processes @yaxu++## 1.7.4 - Symonds Yat b+* Fixes for bipolar waveforms (sine2, etc) @mindofmatthew+* More playback controls for OSC API @mindofmatthew+* Disable bus variants for MIDI controls @mindofmatthew++## 1.7.3 - Symonds Yat+* Signed ratio shorthands now supported @ndr_brt+* OSC API - mute/unmute stream @mindofmatthew+* improve performance of playFor/seqP @yaxu+* Expand tests with autodiscovered laws @RSWilli+* Add `getState` to BootTidal @mindofmatthew+* add fadeTime / fadeInTime / fadeOutTime params for grain envelopes @yaxu+* Fix for nrpnn and nrpnv params @yaxu+* Disable busses for MIDI parameters @mindofmatthew+ +## 1.7.2 - IKLECTIK c+* tidal-parse additions and improved errors, haskellish dependency fix @dktr0+* spring cleaning and delinting, recreated Time.hs, renamed ControlMap toValueMAp @yaxu+* start of [major refactoring of chords](https://club.tidalcycles.org/t/rfc-working-on-making-chord-naming-chordlist-more-consistent/2717/56) @cleary+* fix `.` mininotation operator @zudov+* stateful event parameters, for counting @yaxu+* Move some stuff from BootTidal.hs to the tidal library, to reduce dependencies there @yaxu++## 1.7.1 - IKLECTIK b+* Fix stack build @yaxu+* Add tidal_status command @yaxu+* Add cVerbose config setting (default on) @yaxu+* Fix for emacs plugin @jwaldmann+* Snowball bugfix @yaxu+* Migrate to github actions, tested against additional ghc versions @ndr_brt+* Fix mininotation bug - allow leading/trailing spaces @ndr_brt+* Make linger work with negative numbers (to linger on end of cycle rather than start) @yaxu+* Friendlier startup messages @yaxu+* Compatibility with ghc 9.0.1 @yaxu++## 1.7 - IKLECTIK+* Added drum aliases from GM2 percussion spec to `drum` function @lvm+* `getcps` helper function now in BootTidal.hs @yaxu+* `getnow` helper function back in BootTidal.hs (returns current cycle) @bgold-cosmos+* Developments towards tidal api, @yaxu et al+* `coarse` parameter is now floating point @lwlsn+* `irand` parameter now patternable @ndr-brt+* `note` now produces its own type to avoid conflicts between parsing note names and duration shorthands @ndr-brt+* Numerous tidal-parse improvements and additions @dktr0 et al+* `grain` function for combining begin and end (in terms of begin and duration) @khoparzi+* Added missing pB and pR functions @thgrund+* Emacs plugin bugfixes @jwaldmann+* `binaryN` parameters now fully patternable @ndr-brt+* `press` and `pressBy` functions for syncopation @yaxu+* `bite`'s first parameter is now patternable @ndr-brt+* Most SuperDirt control/effect parameters can now be modified while a sound is playing, using 'bus' functions. @telefon + @yaxu+* Sound.Tidal.Params is now generated by a script in bin/generate-params.hs @yaxu+* `qtrigger` is now an alias for `ctrigger`, which now quantises to the _next_ cycle (via ceiling) @thgund / @yaxu+* There is now also `ftrigger` and `rtrigger` for floor (previous) and round (nearest) cycle+* `whenmod`'s first two parameters are now rationals, and patternable. @th-four / @yaxu+* `brand` and `brandBy` for continuous patterns of boolean values @yaxu+* Two-way protocol between Tidal and SuperDirt, initially to receive available busses @telefon / @yaxu+* bipolar waveforms - sine2, square2, tri2, saw2, cosine2 @yaxu+ ++## 1.6.1 - We are not DJs+* Patternise first parameter of chunk @lwlsn+* Patternise fit parameter @bgold-cosmos+* Increase upper bounds of random @yaxu+* Switch travis to ubuntu bionic @yaxu++## 1.6.0 - Keep live coding live+* Rollback to previous pattern on parse error @jwaldmann+* Increased strictness to catch parse errors earlier @jwaldmann @yaxu+* Support for superdirt 'panic' @yaxu+* Increase hosc upper bounds to admin 0.18+* New function 'splat' @yaxu+* `quantise` now uses round, add qfloor, qceiling variants and qround alis @lwlsn+* Add ghc 8.8.3 to travis @jwaldmann+* Switch `substruct` to use binary pattern @yaxu++## 1.5.2 - Rivelin+* Fix streamAll++## 1.5.1 - Blacka Moor+* Bugfix splice++## 1.5.0 - Active travel+* Export drawLineSz @mxmxyz+* tidal-parse additions (bite, splice, pickF, select, squeeze; fixed slice) @dktr0+* New, more efficient pseudorandom number generator @dktr0+* Pattern first someCyclesBy param @bgold-cosmos+* Refactored, more flexible OSC targetting @yaxu+* Simplify tidal-boot-script in tidal.el @jamagin+* Support state substitution in mininotation #530 @yaxu+* Pattern first parameter of splice #656 @yaxu+* Pattern first parameter of chew @yaxu+* add 'x' fraction alias for 1/6 @yaxu+* add dfb alias for delayfeedback param, dt for delaytime @yaxu+* add unmuteAll and only to BootTidal.hs @yaxu+ ## 1.4.9 - Housebound spirit- * Simplify 'show'ing of patterns @yaxu- * New `draw` function for drawing a pattern of single characters as a text-based diagram,- with friends `drawLine` and `drawLineSz` for drawing multiple cycles @yaxu- * Fixes and expansions of ratio aliases - s should be a sixteenth @mxmxyz, w is now 1, f is now 0.2- * Simplify definition of `accumulate` using scanl @benjwadams- * The first parameter of `someCyclesBy` is now patternable @bgold-cosmos+* Simplify 'show'ing of patterns @yaxu+* New `draw` function for drawing a pattern of single characters as a text-based diagram, with friends `drawLine` and `drawLineSz` for drawing multiple cycles @yaxu+* Fixes and expansions of ratio aliases - s should be a sixteenth @mxmxyz, w is now 1, f is now 0.2+* Simplify definition of `accumulate` using scanl @benjwadams+* The first parameter of `someCyclesBy` is now patternable @bgold-cosmos ## 1.4.8 - Limerick- * Add ratio shorthand to floating point patterns @yaxu- * Support fractional scales, add Arabic scales @quakehead- * Additions to tidal-parse including support from overgain, overshape adn rot @dktr0- * Move prompt-cont setting to end of BootTidal.hs (older versions of Haskell crash out at this point) @ndr-brt-## 1.4.7 - Bleep+* Add ratio shorthand to floating point patterns @yaxu+* Support fractional scales, add Arabic scales @quakehead+* Additions to tidal-parse including support from overgain, overshape adn rot @dktr0+* Move prompt-cont setting to end of BootTidal.hs (older versions of Haskell crash out at this point) @ndr-brt - * Fix BootTidal.hs - make loadable in atom @bgold-cosmos- * More additions to tidal-parse @dktr0+## 1.4.7 - Bleep+* Fix BootTidal.hs - make loadable in atom @bgold-cosmos+* More additions to tidal-parse @dktr0 ## 1.4.6 - Megatron-- * Experimental ratio shorthand ref #573 @yaxu- * Store mininotation source location(s) in events ref #245 @yaxu- * Add more things to tidal-parse @dktr0 @yaxu- * Separate out haskell parser from tidal-parse into new hackage module called 'haskellish' @dktr0- * Support patterning polyrhythmic % steps in mininotation @yaxu- * Fixes to emacs plugin (tidal.el) @xmacex- * New parameters for freq, overgain, overshape, and missing midi params including the new nrpn ones @yaxu+* Experimental ratio shorthand ref #573 @yaxu+* Store mininotation source location(s) in events ref #245 @yaxu+* Add more things to tidal-parse @dktr0 @yaxu+* Separate out haskell parser from tidal-parse into new hackage module called 'haskellish' @dktr0+* Support patterning polyrhythmic % steps in mininotation @yaxu+* Fixes to emacs plugin (tidal.el) @xmacex+* New parameters for freq, overgain, overshape, and missing midi params including the new nrpn ones @yaxu ## 1.4.5 - Porter Brook- * Mini notation - `@` (and its alias `_`) now accepts rational relative durations. E.g. `a b@0.5 c d` to make `b` have a half step (that would be the same as `a@2 b c@2 c@d`). This can also be patterned `a b@<0.5 2> c d` @yaxu #435 * Experimental `reset` function - stick in a pattern so it acts as though the cycle number was reset to 0, from the next cycle @yaxu * Bugfix for setR in BootTidal.hs @yaxu@@ -42,7 +470,6 @@ * Many tidal-parse updates @dktr0 ## 1.4.4 - Chee Dale- * wrandcat (weighted randcat) @yaxu * MIDI Sysex support #558 @yaxu * Elements in an Open Sound Control path address can now be patterned #557@@ -52,39 +479,31 @@ * Add power pattern operators |**, **| and |**| @yaxu ## 1.4.3 - Stanage Edge- * Fix for xfade / xfadein transition * New function plyWith ## 1.4.2 - Higger Tor- * Fix for 'nudge' ## 1.4.1 - Carl Wark- * improvements to handling of cps changes @yaxu #501 * fix for parameter patterning in 'range' @yaxu #547 ## 1.4.0 - Padley Gorge- * fix representation to handle continuous and analog events properly @yaxu ## 1.3.0 - rolled back to 1.1.2 ## 1.2.0 - Hunters Bar- * Simplify <* and *>, removing any distinction between analogue and digital patterns ## 1.1.2 - Eccy Road- * Usability fix for `binary` / `binaryN` (use squeezeJoin on input pattern) ## 1.1.1 - Chelsea Park- * Usability fixes for `binary` / `binaryN` / `ascii` @yaxu ## 1.1.0 - Brincliffe Edge- * `binary` and `ascii` functions for playing with bit patterns @yaxu * support chord inversions in chord parser @bgold-cosmos * skip ticks when system clock jumps @yaxu@@ -103,7 +522,6 @@ * minitidal refactor, support for parsing more of tidal, tests @dktr0 ## 1.0.14 - IICON- * 'chew' - like bite, but speeds playback rate up and down * variable probability for ? in mini notation * chooseBy takes modulo of index to avoid out of bounds errors@@ -111,32 +529,29 @@ * Fix dependencies for parsec/colour ## 1.0.13 - 🐝⌛️🦋 #2- * Simplify espgrid support - @yaxu ## 1.0.12 - 🐝⌛️🦋- * Fix ESPGrid support - @dktr0 * Add 'snowball' function - @XiNNiW ## 1.0.11 - Cros Bríde- 2019-04-17 Alex McLean <alex@slab.org>- * Add `bite` function for slicing patterns (rather than samples)- * Tweak tidal.el to attempt to infer location of default BootTidal.hs- * Skip time (forward or backward) if the reference clock jumps suddenly- * Fix `fit` - @bgold-cosmos- * Remove 'asap'- * Add cB for boolean control input- * `pickF` for choosing between functions with a pattern of integers- * `select` for choosing between list of patterns with a floating point pattern- * `squeeze` for choosing between list of patterns with a pattern of integers, where patterns are squeezed into the integer event duration- * `splice` for choosing between slices of a pattern, where the slices are squeezed into event duration- * Ord and Eq instances for value type @bgold-cosmos- * `trigger` - support for resetting envelopes on evaluation- * Support for rational event values- * Tweak how `*>` and `<*` deal with analog patterns- * Caribiner link bridge support+* Add `bite` function for slicing patterns (rather than samples)+* Tweak tidal.el to attempt to infer location of default BootTidal.hs+* Skip time (forward or backward) if the reference clock jumps suddenly+* Fix `fit` - @bgold-cosmos+* Remove 'asap'+* Add cB for boolean control input+* `pickF` for choosing between functions with a pattern of integers+* `select` for choosing between list of patterns with a floating point pattern+* `squeeze` for choosing between list of patterns with a pattern of integers, where patterns are squeezed into the integer event duration+* `splice` for choosing between slices of a pattern, where the slices are squeezed into event duration+* Ord and Eq instances for value type @bgold-cosmos+* `trigger` - support for resetting envelopes on evaluation+* Support for rational event values+* Tweak how `*>` and `<*` deal with analog patterns+* Caribiner link bridge support ## 1.0.10 - This machine also kills fascists * Add exports to Sound.Tidal.Scales for `getScale` and `scaleTable`@@ -150,10 +565,8 @@ * `djf` control ready for new superdirt dj filter @yaxu * `getScale` for handrolling/adding scales to `scale` function * Add `djf` control for upcoming superdirt dj filter @yaxu -## 1.0.8 (trying to get back to doing these, -## see also https://tidalcycles.org/index.php/Changes_in_Tidal_1.0.x -## for earlier stuff)-+## 1.0.8 (trying to get back to doing these)+**See also https://tidalcycles.org/index.php/Changes_in_Tidal_1.0.x for earlier stuff)** * Add 'to', 'toArg' and 'from' controls for new superdirt routing experiments - @telephon * Fixes for squeezeJoin (nee unwrap') - @bgold-cosmos * Simplify `cycleChoose`, it is now properly discrete (one event per cycle) - @yaxu@@ -170,9 +583,8 @@ * fix for `sometimesBy` - @yaxu ## 0.9.10 (and earlier missing versions from this log)- * arpg, a function to arpeggiate-* within', an alternate within with a different approach to time, following discussion here https://github.com/tidalcycles/Tidal/issues/313+* within', an alternate within with a different approach to time, following discussion here https://codeberg.org/uzu/Tidal/issues/313 * sine et al are now generalised so can be used as double or rational patterns * New Sound.Tidal.Simple module with a range of simple transformations (faster, slower, higher, lower, mute, etc) * slice upgraded to take a pattern of slice indexes@@ -187,7 +599,6 @@ ## 0.9.7 ### Enhancements- * The `note` pattern parameter is no longer an alias for `midinote`, but an independent parameter for supercollider to handle (in a manner similar to `up`)@@ -195,14 +606,12 @@ ## 0.9.6 ### Enhancements- * Added `chord` for chord patterns and `scaleP` for scale patterns * The `n` pattern parameter is now floating point ## 0.9.5 ### Enhancements- * Added `hurry` which both speeds up the sound and the pattern by the given amount. * Added `stripe` which repeats a pattern a given number of times per cycle, with random but contiguous durations.@@ -216,14 +625,12 @@ ## 0.9.4 ### Fixes- * Swapped `-` for `..` in ranges as quick fix for issue with parsing negative numbers * Removed overloaded list thingie for now, unsure whether it's worth the dependency ## 0.9.3 ### Enhancements- * The sequence parser can now expand ranges, e.g. `"0-3 4-2"` is equivalent to `"[0 1 2 3] [4 3 2]"` * Sequences can now be described using list syntax, for example `sound ["bd", "sn"]` is equivalent to `sound "bd sn"`. They *aren't* lists though, so you can't for example do `sound (["bd", "sn"] ++ ["arpy", "cp"])` -- but can do `sound (append ["bd", "sn"] ["arpy", "cp"])`@@ -234,6 +641,5 @@ * The start of automatic testing for a holy bug-free future ### Fixes- * Fixed bug that was causing events to double up or get lost, e.g. where `rev` was combined with certain other functions.
README.md view
@@ -1,17 +1,13 @@ -Tidal [](https://travis-ci.org/tidalcycles/Tidal)-=====--Language for live coding of pattern--For documentation, mailing list and more info see here:- https://tidalcycles.org/+# Tidal <a href="https://codeberg.org/uzu/tidal/LICENSE"><img alt="License" src="https://img.shields.io/github/license/tidalcycles/Tidal"></a> -You can help speed up Tidal development by sending coffee here:- https://ko-fi.com/yaxulive#+[](https://doi.org/10.5281/zenodo.592191)+ +[Uzu language](https://uzu.lurk.org/) for live coding algorithmic patterns -(c) Alex McLean and contributors, 2019+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://codeberg.org/uzu/tidal/activity/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
@@ -1,38 +1,64 @@ {-# LANGUAGE OverloadedStrings #-} -module Tidal.Inputs where +module Tidal.Inputs where -import Sound.Tidal.Pattern-import Sound.Tidal.Core-import Sound.Tidal.ParseBP-import Sound.Tidal.Core+import Sound.Tidal.Control (stut')+import Sound.Tidal.Core (cF, fromList, (#), (|*|)) import Sound.Tidal.Params-import Sound.Tidal.Control-import Sound.Tidal.UI-import Weigh + ( 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] +columns :: Weigh ()+columns = setColumns [Case, Allocated, Max, Live, GCs] -{- Pattern inputs -} -xs3 = [1..10^3]-xs4 = [1..10^4]-xs5 = [1..10^5]-xs6 = [1..10^6]+{- Pattern inputs -}+xs3 :: [Time]+xs3 = [1 .. 10000] -xsA = [500000..1500000]+xs4 :: [Time]+xs4 = [1 .. 100000] +xs5 :: [Time]+xs5 = [1 .. 1000000]++xs6 :: [Time]+xs6 = [1 .. 10000000]++xsA :: [Time]+xsA = [500000 .. 1500000]+ catPattSmall :: [Pattern Time] catPattSmall = pure <$> xs3 catPattMed :: [Pattern Time]-catPattMed = pure <$> xs4 +catPattMed = pure <$> xs4 catPattMedB :: [Pattern Time] catPattMedB = pure <$> xs5 catPattBig :: [Pattern Time]-catPattBig = pure <$> xs6 +catPattBig = pure <$> xs6 timeCatMed :: [(Time, Pattern Time)] timeCatMed = zip xs5 catPattMed@@ -41,43 +67,46 @@ timeCatBig = zip xs6 catPattBig appendBig :: [Pattern Time]-appendBig = pure <$> xsA +appendBig = pure <$> xsA pattApp1 :: Pattern [Time]-pattApp1 = sequence catPattBig +pattApp1 = sequence catPattBig pattApp2 :: Pattern [Time] pattApp2 = sequence appendBig {- Arc Inputs -}-arcFunc :: Arc -> Arc -arcFunc (Arc s e) = Arc (s * 2) (e * 4) +arcFunc :: Arc -> Arc+arcFunc (Arc st en) = Arc (st * 2) (en * 4) -wqaMed = fromList xs5 +wqaMed :: Pattern Time+wqaMed = fromList xs5++wqaBig :: Pattern Time wqaBig = fromList xs6 -{- fix inputs -} -fixArg1 :: ControlPattern +{- fix inputs -}+fixArg1 :: ControlPattern fixArg1 = pF "cc64" 1 fixArg2 :: ControlPattern fixArg2 =- fix ( # crush 4 ) (pF "cc65" 1)- $ fix ( stut' 4 (0.125/4) ( + up "1" )) (pF "cc66" 1)- $ fix ( |*| speed "-1" ) (pF "cc67" 1)- $ fix ( (# delaytime 0.125).(# delay 0.5)) (pF "cc68" 1)- $ fix ( # coarse 12) (pF "cc69" 1)- $ s "[808bd:1(3,8), dr(7,8)]"- # pF "cc64" (cF 0 "64")- # pF "cc65" (cF 0 "65")- # pF "cc66" (cF 0 "66")- # pF "cc67" (cF 0 "67")- # pF "cc68" (cF 0 "68")- # pF "cc69" (cF 0 "69")+ fix (# crush 4) (pF "cc65" 1) $+ fix (stut' 4 (0.125 / 4) (+ up "1")) (pF "cc66" 1) $+ fix (|*| speed "-1") (pF "cc67" 1) $+ fix ((# delaytime 0.125) . (# delay 0.5)) (pF "cc68" 1) $+ fix (# coarse 12) (pF "cc69" 1) $+ s "[808bd:1(3,8), dr(7,8)]"+ # pF "cc64" (cF 0 "64")+ # pF "cc65" (cF 0 "65")+ # pF "cc66" (cF 0 "66")+ # pF "cc67" (cF 0 "67")+ # pF "cc68" (cF 0 "68")+ # pF "cc69" (cF 0 "69") {- Euclid inputs -}-ecA1 :: [Pattern Int] -ecA1 = [1, 10^5]+ecA1 :: [Pattern Int]+ecA1 = [1, 1000000] -ecA2 :: Pattern String +ecA2 :: Pattern String ecA2 = "x"
bench/Memory/Tidal/UIB.hs view
@@ -1,20 +1,25 @@-module Tidal.UIB where +module Tidal.UIB where -import Weigh -import Tidal.Inputs -import Sound.Tidal.UI-import Sound.Tidal.Core+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
@@ -1,34 +1,54 @@ {-# LANGUAGE OverloadedStrings #-} -module Tidal.Inputs where +module Tidal.Inputs where -import Sound.Tidal.Pattern-import Sound.Tidal.Core-import Sound.Tidal.ParseBP-import Sound.Tidal.Core+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,+ )+import Sound.Tidal.ParseBP ()+import Sound.Tidal.Pattern+ ( Arc,+ ArcF (Arc),+ ControlPattern,+ Pattern,+ Time,+ )+import Sound.Tidal.UI (fix) -{- Pattern inputs -} -xs3 = [1..10^3]-xs4 = [1..10^4]-xs5 = [1..10^5]-xs6 = [1..10^6]+{- Pattern inputs -}+xs3 :: [Time]+xs3 = [1 .. 10000] -xsA = [500000..1500000]+xs4 :: [Time]+xs4 = [1 .. 100000] +xs5 :: [Time]+xs5 = [1 .. 1000000]++xs6 :: [Time]+xs6 = [1 .. 10000000]++xsA :: [Time]+xsA = [500000 .. 1500000]+ catPattSmall :: [Pattern Time] catPattSmall = pure <$> xs3 catPattMed :: [Pattern Time]-catPattMed = pure <$> xs4 +catPattMed = pure <$> xs4 catPattMedB :: [Pattern Time] catPattMedB = pure <$> xs5 catPattBig :: [Pattern Time]-catPattBig = pure <$> xs6 +catPattBig = pure <$> xs6 timeCatMed :: [(Time, Pattern Time)] timeCatMed = zip xs5 catPattMed@@ -37,46 +57,47 @@ timeCatBig = zip xs6 catPattBig appendBig :: [Pattern Time]-appendBig = pure <$> xsA +appendBig = pure <$> xsA pattApp1 :: Pattern [Time]-pattApp1 = sequence catPattBig +pattApp1 = sequence catPattBig pattApp2 :: Pattern [Time] pattApp2 = sequence appendBig {- Arc Inputs -}-arcFunc :: Arc -> Arc -arcFunc (Arc s e) = Arc (s * 2) (e * 4) +arcFunc :: Arc -> Arc+arcFunc (Arc st en) = Arc (st * 2) (en * 4) wqaMed :: Pattern Time-wqaMed = fromList xs5 +wqaMed = fromList xs5 wqaBig :: Pattern Time wqaBig = fromList xs6 -{- fix inputs -} -fixArg1 :: ControlPattern +{- fix inputs -}+fixArg1 :: ControlPattern fixArg1 = pF "cc64" 1 fixArg2 :: ControlPattern fixArg2 =- fix ( # crush 4 ) (pF "cc65" 1)- $ fix ( stut' 4 (0.125/4) ( + up "1" )) (pF "cc66" 1)- $ fix ( |*| speed "-1" ) (pF "cc67" 1)- $ fix ( (# delaytime 0.125).(# delay 0.5)) (pF "cc68" 1)- $ fix ( # coarse 12) (pF "cc69" 1)- $ s "[808bd:1(3,8), dr(7,8)]"- # pF "cc64" (cF 0 "64")- # pF "cc65" (cF 0 "65")- # pF "cc66" (cF 0 "66")- # pF "cc67" (cF 0 "67")- # pF "cc68" (cF 0 "68")- # pF "cc69" (cF 0 "69")+ fix (# crush 4) (pF "cc65" 1)+ -- fix ( stut' 4 (0.125/4) ( + up "1" )) (pF "cc66" 1)+ $+ fix (|*| speed "-1") (pF "cc67" 1) $+ fix ((# delaytime 0.125) . (# delay 0.5)) (pF "cc68" 1) $+ fix (# coarse 12) (pF "cc69" 1) $+ s "[808bd:1(3,8), dr(7,8)]"+ # pF "cc64" (cF 0 "64")+ # pF "cc65" (cF 0 "65")+ # pF "cc66" (cF 0 "66")+ # pF "cc67" (cF 0 "67")+ # pF "cc68" (cF 0 "68")+ # pF "cc69" (cF 0 "69") {- Euclid inputs -}-ecA1 :: [Pattern Int] +ecA1 :: [Pattern Int] ecA1 = [1, 100] -ecA2 :: Pattern String +ecA2 :: Pattern String ecA2 = "x"
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,23 +1,32 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} -module Tidal.UIB where +module Tidal.UIB where -import Criterion.Main-import Tidal.Inputs-import Sound.Tidal.Core-import Sound.Tidal.UI +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,34 +0,0 @@-module Sound.Tidal.Bjorklund (bjorklund) where---- The below is (c) Rohan Drape, taken from the hmt library and--- distributed here under the terms of the GNU Public Licence. 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/Carabiner.hs
@@ -1,65 +0,0 @@-{-# OPTIONS_GHC -fno-warn-dodgy-imports -fno-warn-name-shadowing #-}-module Sound.Tidal.Carabiner where--import Network.Socket hiding (send, sendTo, recv, recvFrom)-import Network.Socket.ByteString (send, recv)-import qualified Data.ByteString.Char8 as B8-import Control.Concurrent (forkIO, takeMVar, putMVar)-import qualified Sound.Tidal.Stream as S-import Sound.Tidal.Tempo-import System.Clock-import Text.Read (readMaybe)-import Control.Monad (when, forever)-import Data.Maybe (isJust, fromJust)-import qualified Sound.OSC.FD as O--carabiner :: S.Stream -> Int -> Double -> IO Socket-carabiner tidal bpc latency = do sock <- client tidal bpc latency "127.0.0.1" 17000- sendMsg sock "status\n"- return sock--client :: S.Stream -> Int -> Double -> String -> Int -> IO Socket-client tidal bpc latency host port = withSocketsDo $- do addrInfo <- getAddrInfo Nothing (Just host) (Just $ show port)- let serverAddr = head addrInfo- sock <- socket (addrFamily serverAddr) Stream defaultProtocol- connect sock (addrAddress serverAddr)- _ <- forkIO $ listener tidal bpc latency sock- -- sendMsg sock "status\n"- -- threadDelay 10000000- return sock--listener :: S.Stream -> Int -> Double -> Socket -> IO ()-listener tidal bpc latency sock =- forever $ do rMsg <- recv sock 1024- let msg = B8.unpack rMsg- (name:_:ws) = words msg- pairs = pairs' ws- pairs' (a:b:xs) = (a,b):(pairs' xs)- pairs' _ = []- act tidal bpc latency name pairs--act :: S.Stream -> Int -> Double -> String -> [(String, String)] -> IO ()-act tidal bpc latency "status" pairs- = do let start = (lookup ":start" pairs >>= readMaybe) :: Maybe Integer- bpm = (lookup ":bpm" pairs >>= readMaybe) :: Maybe Double- beat = (lookup ":beat" pairs >>= readMaybe) :: Maybe Double- when (and [isJust start, isJust bpm, isJust beat]) $ do- nowM <- getTime Monotonic- nowO <- O.time- let m = (fromIntegral $ sec nowM) + ((fromIntegral $ nsec nowM)/1000000000)- d = nowO - m- start' = ((fromIntegral $ fromJust start) / 1000000)- startO = start' + d- -- cyc = toRational $ (fromJust beat) / (fromIntegral bpc)- tempo <- takeMVar (S.sTempoMV tidal)- let tempo' = tempo {atTime = startO + latency,- atCycle = 0,- cps = ((fromJust bpm) / 60) / (fromIntegral bpc)- }- putMVar (S.sTempoMV tidal) $ tempo'-act _ _ _ name _ = putStr $ "Unhandled thingie " ++ name--sendMsg :: Socket -> String -> IO ()-sendMsg sock msg = do _ <- send sock $ B8.pack msg- return ()
− src/Sound/Tidal/Chords.hs
@@ -1,187 +0,0 @@-module Sound.Tidal.Chords where--import Data.Maybe--import Sound.Tidal.Pattern--major :: Num a => [a]-major = [0,4,7]-minor :: Num a => [a]-minor = [0,3,7]-major7 :: Num a => [a]-major7 = [0,4,7,11]-dom7 :: Num a => [a]-dom7 = [0,4,7,10]-minor7 :: Num a => [a]-minor7 = [0,3,7,10]-aug :: Num a => [a]-aug = [0,4,8]-dim :: Num a => [a]-dim = [0,3,6]-dim7 :: Num a => [a]-dim7 = [0,3,6,9]-one :: Num a => [a]-one = [0]-five :: Num a => [a]-five = [0,7]-plus :: Num a => [a]-plus = [0,4,8]-sharp5 :: Num a => [a]-sharp5 = [0,4,8]-msharp5 :: Num a => [a]-msharp5 = [0,3,8]-sus2 :: Num a => [a]-sus2 = [0,2,7]-sus4 :: Num a => [a]-sus4 = [0,5,7]-six :: Num a => [a]-six = [0,4,7,9]-m6 :: Num a => [a]-m6 = [0,3,7,9]-sevenSus2 :: Num a => [a]-sevenSus2 = [0,2,7,10]-sevenSus4 :: Num a => [a]-sevenSus4 = [0,5,7,10]-sevenFlat5 :: Num a => [a]-sevenFlat5 = [0,4,6,10]-m7flat5 :: Num a => [a]-m7flat5 = [0,3,6,10]-sevenSharp5 :: Num a => [a]-sevenSharp5 = [0,4,8,10]-m7sharp5 :: Num a => [a]-m7sharp5 = [0,3,8,10]-nine :: Num a => [a]-nine = [0,4,7,10,14]-m9 :: Num a => [a]-m9 = [0,3,7,10,14]-m7sharp9 :: Num a => [a]-m7sharp9 = [0,3,7,10,14]-maj9 :: Num a => [a]-maj9 = [0,4,7,11,14]-nineSus4 :: Num a => [a]-nineSus4 = [0,5,7,10,14]-sixby9 :: Num a => [a]-sixby9 = [0,4,7,9,14]-m6by9 :: Num a => [a]-m6by9 = [0,3,9,7,14]-sevenFlat9 :: Num a => [a]-sevenFlat9 = [0,4,7,10,13]-m7flat9 :: Num a => [a]-m7flat9 = [0,3,7,10,13]-sevenFlat10 :: Num a => [a]-sevenFlat10 = [0,4,7,10,15]-nineSharp5 :: Num a => [a]-nineSharp5 = [0,1,13]-m9sharp5 :: Num a => [a]-m9sharp5 = [0,1,14]-sevenSharp5flat9 :: Num a => [a]-sevenSharp5flat9 = [0,4,8,10,13]-m7sharp5flat9 :: Num a => [a]-m7sharp5flat9 = [0,3,8,10,13]-eleven :: Num a => [a]-eleven = [0,4,7,10,14,17]-m11 :: Num a => [a]-m11 = [0,3,7,10,14,17]-maj11 :: Num a => [a]-maj11 = [0,4,7,11,14,17]-elevenSharp :: Num a => [a]-elevenSharp = [0,4,7,10,14,18]-m11sharp :: Num a => [a]-m11sharp = [0,3,7,10,14,18]-thirteen :: Num a => [a]-thirteen = [0,4,7,10,14,17,21]-m13 :: Num a => [a]-m13 = [0,3,7,10,14,17,21]---- | @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--chordTable :: Num a => [(String, [a])]-chordTable = [("major", major),- ("maj", major),- ("minor", minor),- ("min", minor),- ("aug", aug),- ("dim", dim),- ("major7", major7),- ("maj7", major7),- ("dom7", dom7),- ("minor7", minor7),- ("min7", minor7),- ("dim7", dim7),- ("one", one),- ("1", one),- ("five", five),- ("5", five),- ("plus", plus),- ("sharp5", sharp5),- ("msharp5", msharp5),- ("sus2", sus2),- ("sus4", sus4),- ("six", six),- ("6", six),- ("m6", m6),- ("sevenSus2", sevenSus2),- ("7sus2", sevenSus2),- ("sevenSus4", sevenSus4),- ("7sus4", sevenSus4),- ("sevenFlat5", sevenFlat5),- ("7f5", sevenFlat5),- ("m7flat5", m7flat5),- ("m7f5", m7flat5),- ("sevenSharp5", sevenSharp5),- ("7s5", sevenSharp5),- ("m7sharp5", m7sharp5),- ("m7s5", m7sharp5),- ("nine", nine),- ("m9", m9),- ("m7sharp9", m7sharp9),- ("m7s9", m7sharp9),- ("maj9", maj9),- ("nineSus4", nineSus4),- ("ninesus4", nineSus4),- ("9sus4", nineSus4),- ("sixby9", sixby9),- ("6by9", sixby9),- ("m6by9", m6by9),- ("sevenFlat9", sevenFlat9),- ("7f9", sevenFlat9),- ("m7flat9", m7flat9),- ("m7f9", m7flat9),- ("sevenFlat10", sevenFlat10),- ("7f10", sevenFlat10),- ("nineSharp5", nineSharp5),- ("9s5", nineSharp5),- ("m9sharp5", m9sharp5),- ("m9s5", m9sharp5),- ("sevenSharp5flat9", sevenSharp5flat9),- ("7s5f9", sevenSharp5flat9),- ("m7sharp5flat9", m7sharp5flat9),- ("eleven", eleven),- ("11", eleven),- ("m11", m11),- ("maj11", maj11),- ("elevenSharp", elevenSharp),- ("11s", elevenSharp),- ("m11sharp", m11sharp),- ("m11s", m11sharp),- ("thirteen", thirteen),- ("13", thirteen),- ("m13", m13)- ]--chordL :: Num a => Pattern String -> Pattern [a]-chordL p = (\name -> fromMaybe [] $ lookup name chordTable) <$> p--chordList :: String-chordList = unwords $ map fst (chordTable :: [(String, [Int])])-
src/Sound/Tidal/Config.hs view
@@ -1,25 +1,78 @@ module Sound.Tidal.Config where +import Control.Monad (when)+import Data.Int (Int64)+import Foreign.C (CDouble)+import qualified Sound.Tidal.Clock as Clock -data Config = Config {cCtrlListen :: Bool,- cCtrlAddr :: String,- cCtrlPort :: Int,- cFrameTimespan :: Double,- cTempoAddr :: String,- cTempoPort :: Int,- cTempoClientPort :: Int,- cSendParts :: Bool,- cSkipTicks :: Int- }+{-+ Config.hs - For default Tidal configuration 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/>.+-}++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,- cFrameTimespan = 1/20,- cTempoAddr = "127.0.0.1",- cTempoPort = 9160,- cTempoClientPort = 0, -- choose at random- cSendParts = False,- cSkipTicks = 10- }+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
@@ -1,11 +1,24 @@ module Sound.Tidal.Context (module C) where -import Prelude hiding ((<*), (*>))+{-+ Context.hs - For exposing the core TidalCycles libraries+ Copyright (C) 2020, Alex McLean and contributors -import Data.Ratio as C+ 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. -import Sound.Tidal.Carabiner as C-import Sound.Tidal.Config as C+ 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.Ratio as C import Sound.Tidal.Control as C import Sound.Tidal.Core as C import Sound.Tidal.Params as C@@ -14,8 +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 Sound.Tidal.EspGrid as C+import Prelude hiding (all, drop, take, (*>), (<*))
− src/Sound/Tidal/Control.hs
@@ -1,717 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings, FlexibleContexts #-}--module Sound.Tidal.Control where--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.UI-import qualified Sound.Tidal.Params as P-import Sound.Tidal.Utils-import Sound.Tidal.ParseBP (Parseable, Enumerable, parseBP_E)--{- | `spin` will "spin" a 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 works best 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` granualizes every sample in place as it is played, turning a pattern of samples into a pattern of sample parts. 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]"-@--}--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 ControlMap -> [Event ControlMap]- 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 -> ControlMap -> Int -> (Int, (Arc, Arc)) -> Event ControlMap- chomp c v n' (i, (w,p')) = Event c (Just w) p' (Map.insert "begin" (VF b') $ Map.insert "end" (VF e') v)- where b = fromMaybe 0 $ do v' <- Map.lookup "begin" v- getF v'- e = fromMaybe 1 $ do v' <- Map.lookup "end" v- 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, for example:--@-d1 $ striate 3 $ sound "ho ho:2 ho:3 hc"-@--This plays the loop the given number of times, but triggering-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, etc..-With the highhat samples in the above example it sounds a bit like-reverb, but it isn't really.--You can also use striate with very long samples, to cut it 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) -> ControlMap -> ControlMap-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` uses the `begin` and `end` parameters-internally. This means that if you're using `striate` (or `striateBy`)-you probably shouldn't also specify `begin` or `end`. -}-striateBy :: Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern-striateBy = tParam2 _striateBy---- Old name for striateBy, here as a deprecated alias for now.-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 a function smoothly over an array of different patterns. It uses an `OscPattern` to-apply the function at different levels to each pattern, creating a weaving effect.--@-d1 $ weave 3 (shape $ sine1) [sound "bd [sn drum:2*2] bd*2 [sn drum:1]", sound "arpy*8 ~"]-@--}-weave :: Time -> ControlPattern -> [ControlPattern] -> ControlPattern-weave t p ps = weave' t p (map (#) ps)---{- | `weaveWith` is similar in that it blends functions at the same time at different amounts over a pattern:--@-d1 $ weaveWith 3 (sound "bd [sn drum:2*2] bd*2 [sn drum:1]") [density 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 $ map (\(i, f) -> (fromIntegral i % l) `rotL` _fast t (f (_slow t p))) (zip [0 :: Int ..] fs)- where l = fromIntegral $ length fs--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 :: 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 :: Pattern Int -> ControlPattern -> ControlPattern-randslice = tParam $ \n p -> innerJoin $ (\i -> _slice n i p) <$> irand n--{- |-`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"-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 :: 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 ControlMap-smash n xs p = slowcat $ map (`slow` p') xs- where p' = striate n p--{- | an altenative form to `smash` is `smash'` which will use `chop` instead of `striate`.--}-smash' :: Int -> [Pattern Time] -> ControlPattern -> Pattern ControlMap-smash' n xs p = slowcat $ map (`slow` p') xs- where p' = _chop n p---{- | Stut applies a type of delay to a pattern. It has three parameters,-which could be called depth, feedback and time. Depth is an integer-and the others floating point. This adds a bit of echo:--@-d1 $ stut 4 0.5 0.2 $ 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 $ stut 4 0.5 (-0.2) $ sound "bd sn"-@--}--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 -)--{- | Instead of just decreasing volume to produce echoes, @stut'@ allows to apply a function for each step and overlays the result delayed by the given time.--@-d1 $ stut' 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.--}-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---- | The old name for stutWith-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--_trigger :: Show a => Bool -> a -> Pattern b -> Pattern b-_trigger quant k pat = pat {query = q}- where q st = query ((offset st) ~> pat) st- f | quant = (fromIntegral :: Int -> Rational) . round- | otherwise = id- offset st = fromMaybe (pure 0) $ do p <- Map.lookup ctrl (controls st)- return $ ((f . fromMaybe 0 . getR) <$> p)- ctrl = "_t_" ++ show k--trigger :: Show a => a -> Pattern b -> Pattern b-trigger = _trigger False--qtrigger :: Show a => a -> Pattern b -> Pattern b-qtrigger = _trigger True--qt :: Show a => a -> Pattern b -> Pattern b-qt = qtrigger--reset :: Show a => a -> Pattern b -> Pattern b-reset k pat = pat {query = q}- where q st = query ((offset st) ~> (when (<=0) (const silence) pat)) st- f = (fromIntegral :: Int -> Rational) . floor- offset st = fromMaybe (pure 0) $ do p <- Map.lookup ctrl (controls st)- return $ ((f . fromMaybe 0 . getR) <$> p)- ctrl = "_t_" ++ show k--_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) $ Map.lookup s m) a--_cX_ :: (Value -> Maybe a) -> String -> Pattern a-_cX_ f s = Pattern $ \(State a m) -> queryArc (maybe silence (_getP_ f) $ 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--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--cP :: (Enumerable a, Parseable a) => String -> Pattern a-cP s = innerJoin $ parseBP_E <$> (_cX_ getS s)---- 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"--splice :: Int -> Pattern Int -> ControlPattern -> Pattern (Map.Map String Value)-splice bits ipat pat = withEvent f (slice (pure bits) ipat pat) # P.unit "c"- where f ev = ev {value = Map.insert "speed" (VF d) (value ev)}- where d = sz / (fromRational $ (wholeStop ev) - (wholeStart ev))- sz = 1/(fromIntegral bits)
− src/Sound/Tidal/Core.hs
@@ -1,426 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns #-}--module Sound.Tidal.Core where--import Prelude hiding ((<*), (*>))--import Data.Fixed (mod')-import qualified Data.Map.Strict as Map--import Sound.Tidal.Pattern---- ** Elemental patterns---- | An empty pattern-silence :: Pattern a-silence = empty---- | Takes a function from time to values, and turns it into a 'Pattern'.-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@ returns a 'Pattern' of continuous 'Fractional' 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---- | @cosine@ is a synonym for @0.25 ~> sine@.-cosine :: Fractional a => Pattern a-cosine = 0.25 `rotR` sine---- | @saw@ is the equivalent of 'sine' for (ascending) sawtooth waves.-saw :: (Fractional a, Real a) => Pattern a-saw = sig $ \t -> mod' (fromRational t) 1---- | @isaw@ is the equivalent of 'sine' for inverse (descending) sawtooth waves.-isaw :: (Fractional a, Real a) => Pattern a-isaw = (1-) <$> saw---- | @tri@ is the equivalent of 'sine' for triangular waves.-tri :: (Fractional a, Real a) => Pattern a-tri = fastAppend saw isaw---- | @square@ is the equivalent of 'sine' for square waves.-square :: (Fractional a) => Pattern a-square = sig $- \t -> fromIntegral ((floor $ mod' (fromRational t :: Double) 1 * 2) :: 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 ControlMap 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--(|++|) :: Applicative a => a String -> a String -> a String-a |++| b = (++) <$> a <*> b-(|++ ) :: Pattern String -> Pattern String -> Pattern String-a |++ b = (++) <$> a <* b-( ++|) :: Pattern String -> Pattern String -> Pattern String-a ++| b = (++) <$> a *> b--(|/|) :: (Applicative a, Fractional b) => a b -> a b -> a b-a |/| b = (/) <$> a <*> b-(|/ ) :: Fractional a => Pattern a -> Pattern a -> Pattern a-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--(|-|) :: (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--(|%|) :: (Applicative a, Real b) => a b -> a b -> a b-a |%| b = mod' <$> a <*> b-(|% ) :: Real a => Pattern a -> Pattern a -> Pattern a-a |% b = mod' <$> a <* b-( %|) :: Real a => Pattern a -> Pattern a -> Pattern a-a %| b = mod' <$> 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--(|>|) :: (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--(|<|) :: (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---- 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.-fromList :: [a] -> Pattern a-fromList = cat . map pure---- | Turns a list of values into a pattern, playing one of them per cycle.-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.-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.-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]---- | From @1@ for the first cycle, successively adds a number until it gets up to @n@-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-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.-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-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.-fastCat :: [Pattern a] -> Pattern a-fastCat ps = _fast (toTime $ length ps) $ cat ps--fastcat :: [Pattern a] -> Pattern a-fastcat = fastCat---- | Similar to @fastCat@, but each pattern is given a relative duration-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'---- | 'overlay' combines two 'Pattern's into a new pattern, so that--- their events are combined over time. -overlay :: Pattern a -> Pattern a -> Pattern a-overlay !p !p' = Pattern $ \st -> query p st ++ query p' st---- | An infix alias of @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.-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---- | Speed up a pattern by the given time pattern-fast :: Pattern Time -> Pattern a -> Pattern a-fast = tParam _fast---- | Slow down a pattern by the factors in the given time pattern, 'squeezing'--- the pattern to fit the slot given in the time pattern-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 r p | r == 0 = silence- | r < 0 = rev $ _fast (negate r) p- | otherwise = withResultTime (/ r) $ withQueryTime (* r) p---- | Slow down a pattern by the given time pattern-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---- | Slow down a pattern by the factors in the given time pattern, 'squeezing'--- the pattern to fit the slot given in the time pattern-slowSqueeze :: Pattern Time -> Pattern a -> Pattern a-slowSqueeze = tParamSqueeze _slow---- | An alias for @slow@-sparsity :: Pattern Time -> Pattern a -> Pattern a-sparsity = slow---- | @rev p@ returns @p@ with the event positions in each cycle--- reversed (or mirrored).-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))--{- | 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 this pattern:--@-d1 $ sound "hh*3 [sn bd]*2"-@--}-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. 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 :: (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 :: 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.-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'@ is like @every n f@ with an offset of @o@ cycles-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@.-foldEvery :: [Int] -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-foldEvery ns f p = foldr (`_every` f) p ns--{-|-Only `when` the given test function returns `True` the given pattern-transformation is applied. 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.-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
− src/Sound/Tidal/EspGrid.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-} - -module Sound.Tidal.EspGrid (tidalEspGridLink,cpsEsp,espgrid) where - -import Control.Concurrent.MVar -import Control.Concurrent (forkIO,threadDelay) -import Control.Monad (forever) -import Control.Exception -import Sound.OSC.FD -import Sound.Tidal.Tempo -import Sound.Tidal.Stream (Stream, sTempoMV) - -parseEspTempo :: [Datum] -> Maybe (Tempo -> Tempo) -parseEspTempo d = do - on :: Integer <- datum_integral (d!!0) - bpm <- datum_floating (d!!1) - t1 :: Integer <- datum_integral (d!!2) - t2 <- datum_integral (d!!3) - n :: Integer <- datum_integral (d!!4) - let nanos = (t1*1000000000) + t2 - return $ \t -> t { - atTime = ut_to_ntpr $ realToFrac nanos / 1000000000, - atCycle = fromIntegral n, - cps = bpm/60, - paused = on == 0 - } - -changeTempo :: MVar Tempo -> Packet -> IO () -changeTempo t (Packet_Message msg) = - case parseEspTempo (messageDatum msg) of - Just f -> modifyMVarMasked_ t $ \t0 -> return (f t0) - Nothing -> putStrLn "Warning: Unable to parse message from EspGrid as Tempo" -changeTempo _ _ = putStrLn "Serious error: Can only process Packet_Message" - -tidalEspGridLink :: MVar Tempo -> IO () -tidalEspGridLink _ = putStrLn "Function no longer supported, please use 'espgrid tidal' to connect to ESPgrid instead." - -espgrid :: Stream -> IO () -espgrid st = do - let t = sTempoMV st - socket <- openUDP "127.0.0.1" 5510 - _ <- forkIO $ forever $ do - (do - sendMessage socket $ Message "/esp/tempo/q" [] - response <- waitAddress socket "/esp/tempo/r" - Sound.Tidal.EspGrid.changeTempo t response - threadDelay 200000) - `catch` (\e -> putStrLn $ "exception caught in tidalEspGridLink: " ++ show (e :: SomeException)) - return () - -cpsEsp :: Real t => t -> IO () -cpsEsp t = do - socket <- openUDP "127.0.0.1" 5510 - sendMessage socket $ Message "/esp/beat/tempo" [float (t*60)]
+ src/Sound/Tidal/ID.hs view
@@ -0,0 +1,40 @@+module Sound.Tidal.ID (ID (..)) where++{-+ ID.hs - Polymorphic pattern identifiers+ 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 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)++noOv :: String -> a+noOv meth = error $ meth ++ ": not supported for ids"++instance Num ID where+ fromInteger = ID . show+ (+) = noOv "+"+ (*) = noOv "*"+ abs = noOv "abs"+ signum = noOv "signum"+ (-) = noOv "-"++instance IsString ID where+ fromString = ID
− src/Sound/Tidal/Params.hs
@@ -1,753 +0,0 @@-module Sound.Tidal.Params where--import qualified Data.Map.Strict as Map--import Sound.Tidal.Pattern-import Sound.Tidal.Utils-import Data.Maybe (fromMaybe)-import Data.Word (Word8)---- | group multiple params into one-grp :: [String -> ControlMap] -> 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 -> ControlMap-mF name v = fromMaybe Map.empty $ do f <- readMaybe v- return $ Map.singleton name (VF f)--mI :: String -> String -> ControlMap-mI name v = fromMaybe Map.empty $ do i <- readMaybe v- return $ Map.singleton name (VI i)--mS :: String -> String -> ControlMap-mS name v = Map.singleton name (VS v)---- | Grouped params--sound :: Pattern String -> ControlPattern-sound = grp [mS "s", mF "n"]--s :: Pattern String -> ControlPattern-s = sound--cc :: Pattern String -> ControlPattern-cc = grp [mF "ccn", mF "ccv"]--nrpn :: Pattern String -> ControlPattern-nrpn = grp [mI "nrpn", mI "val"]---- | Singular params--pF :: String -> Pattern Double -> ControlPattern-pF name = fmap (Map.singleton name . VF)--pI :: String -> Pattern Int -> ControlPattern-pI name = fmap (Map.singleton name . VI)--pS :: String -> Pattern String -> ControlPattern-pS name = fmap (Map.singleton name . VS)--pX :: String -> Pattern [Word8] -> ControlPattern-pX name = fmap (Map.singleton name . VX)---- | patterns for internal sound routing-toArg :: Pattern String -> ControlPattern-toArg = pS "toArg"--from :: Pattern Double -> ControlPattern-from = pF "from"--to :: Pattern Double -> ControlPattern-to = pF "to"---- | a pattern of numbers that speed up (or slow down) samples while they play.-accelerate :: Pattern Double -> ControlPattern-accelerate = pF "accelerate"----- | Amplitude; like @gain@, but linear.-amp :: Pattern Double -> ControlPattern-amp = pF "amp"---- | a pattern of numbers to specify the attack time (in seconds) of an envelope applied to each sample. Only takes effect if `release` is also specified.-attack :: Pattern Double -> ControlPattern-attack = pF "attack"---- | a pattern of numbers from 0 to 1. Sets the center frequency of the band-pass filter.-bandf :: Pattern Double -> ControlPattern-bandf = pF "bandf"---- | a pattern of numbers from 0 to 1. Sets the q-factor of the band-pass filter.y-bandq :: Pattern Double -> ControlPattern-bandq = pF "bandq"--{- | a pattern of numbers from 0 to 1. Skips the beginning of each sample, e.g. `0.25` to cut off the first quarter from each sample.--Using `begin "-1"` combined with `cut "-1"` means that when the sample cuts itself it will begin playback from where the previous one left off, so it will sound like one seamless sample. This allows you to apply a synth param across a long sample in a way similar to `chop`:--@-cps 0.5--d1 $ sound "breaks125*8" # unit "c" # begin "-1" # cut "-1" # coarse "1 2 4 8 16 32 64 128"-@--This will play the `breaks125` sample and apply the changing `coarse` parameter over the sample. Compare to:--@-d1 $ (chop 8 $ sounds "breaks125") # unit "c" # coarse "1 2 4 8 16 32 64 128"-@--which performs a similar effect, but due to differences in implementation sounds different.--}-begin, legato, clhatdecay, crush :: Pattern Double -> ControlPattern-channel, coarse :: Pattern Int -> ControlPattern-begin = pF "begin"--- | choose the physical channel the pattern is sent to, this is super dirt specific-channel = pI "channel"----legato controls the amount of overlap between two adjacent synth sounds-legato = pF "legato"--clhatdecay = pF "clhatdecay"--- | 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 = pI "coarse"--- | bit crushing, a pattern of numbers from 1 (for drastic reduction in bit-depth) to 16 (for barely no reduction).-crush = pF "crush"-{- |-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.--@-d1 $ stack [- sound "bd",- sound "~ [~ [ho:2 hc/2]]" # cut "1"- ]-@--This will mute the open hi-hat every second cycle when the closed one is played.--Using `cut` with negative values will only cut the same sample. This is useful to cut very long samples--@-d1 $ sound "[bev, [ho:3](3,8)]" # cut "-1"-@--Using `cut "0"` is effectively _no_ cutgroup.--}-cut :: Pattern Int -> ControlPattern-cut = pI "cut"---- | a pattern of numbers from 0 to 1. Applies the cutoff frequency of the low-pass filter.-cutoff :: Pattern Double -> ControlPattern-cutoff = pF "cutoff"--cutoffegint :: Pattern Double -> ControlPattern-cutoffegint = pF "cutoffegint"--decay :: Pattern Double -> ControlPattern-decay = pF "decay"--- | a pattern of numbers from 0 to 1. Sets the level of the delay signal.-delay :: Pattern Double -> ControlPattern-delay = pF "delay"--- | a pattern of numbers from 0 to 1. Sets the amount of delay feedback.-delayfeedback :: Pattern Double -> ControlPattern-delayfeedback = pF "delayfeedback"--- | a pattern of numbers from 0 to 1. Sets the length of the delay.-delaytime :: Pattern Double -> ControlPattern-delaytime = pF "delaytime"-detune :: Pattern Double -> ControlPattern-detune = pF "detune"---- DJ filter-djf :: Pattern Double -> ControlPattern-djf = pF "djf"---- | 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"-{- the same as `begin`, but cuts the end off samples, shortening them;- e.g. `0.75` to cut off the last quarter of each sample.--}-end :: Pattern Double -> ControlPattern-end = pF "end"--freq :: Pattern Double -> ControlPattern-freq = pF "freq"---- | a pattern of numbers that specify volume. Values less than 1 make--- the sound quieter. Values greater than 1 make the sound louder. For--- the linear equivalent, see @amp@.-gain :: Pattern Double -> ControlPattern-gain = pF "gain"--gate :: Pattern Double -> ControlPattern-gate = pF "gate"-hatgrain :: Pattern Double -> ControlPattern-hatgrain = pF "hatgrain"--- | a pattern of numbers from 0 to 1. Applies the cutoff frequency of the high-pass filter.-hcutoff :: Pattern Double -> ControlPattern-hcutoff = pF "hcutoff"--- | 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"--- | a pattern of numbers from 0 to 1. Applies the resonance of the high-pass filter.-hresonance :: Pattern Double -> ControlPattern-hresonance = pF "hresonance"-kriole :: Pattern Int -> ControlPattern-kriole = pI "kriole"-lagogo :: Pattern Double -> ControlPattern-lagogo = pF "lagogo"-lclap :: Pattern Double -> ControlPattern-lclap = pF "lclap"-lclaves :: Pattern Double -> ControlPattern-lclaves = pF "lclaves"-lclhat :: Pattern Double -> ControlPattern-lclhat = pF "lclhat"-lcrash :: Pattern Double -> ControlPattern-lcrash = pF "lcrash"-leslie :: Pattern Double -> ControlPattern-leslie = pF "leslie"-lrate :: Pattern Double -> ControlPattern-lrate = pF "lrate"-lsize :: Pattern Double -> ControlPattern-lsize = pF "lsize"-lfo :: Pattern Double -> ControlPattern-lfo = pF "lfo"-lfocutoffint :: Pattern Double -> ControlPattern-lfocutoffint = pF "lfocutoffint"-lfodelay :: Pattern Double -> ControlPattern-lfodelay = pF "lfodelay"-lfoint :: Pattern Double -> ControlPattern-lfoint = pF "lfoint"-lfopitchint :: Pattern Double -> ControlPattern-lfopitchint = pF "lfopitchint"-lfoshape :: Pattern Double -> ControlPattern-lfoshape = pF "lfoshape"-lfosync :: Pattern Double -> ControlPattern-lfosync = pF "lfosync"-lhitom :: Pattern Double -> ControlPattern-lhitom = pF "lhitom"-lkick :: Pattern Double -> ControlPattern-lkick = pF "lkick"-llotom :: Pattern Double -> ControlPattern-llotom = pF "llotom"-{- | 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"--- | loops the sample (from `begin` to `end`) the specified number of times.-loop :: Pattern Double -> ControlPattern-loop = pF "loop"-lophat :: Pattern Double -> ControlPattern-lophat = pF "lophat"-lsnare :: Pattern Double -> ControlPattern-lsnare = pF "lsnare"--- | specifies the sample or note number to be used-n :: Pattern Double -> ControlPattern-n = pF "n"-note :: Pattern Double -> ControlPattern-note = pF "note"-{- |-Pushes things forward (or backwards within built-in latency) in time. Allows for nice things like _swing_ feeling:--@-d1 $ stack [- sound "bd bd/4",- sound "hh(5,8)"- ] # nudge "[0 0.04]*4"-@----pitch model -}--degree, mtranspose, ctranspose, harmonic, stepsPerOctave, octaveRatio :: Pattern Double -> ControlPattern-degree = pF "degree"-mtranspose = pF "mtranspose"-ctranspose = pF "ctranspose"-harmonic = pF "ctranspose"-stepsPerOctave = pF "stepsPerOctave"-octaveRatio = pF "octaveRatio"-----Low values will give a more _human_ feeling, high values might result in quite the contrary.--nudge :: Pattern Double -> ControlPattern-nudge = pF "nudge"-octave :: Pattern Int -> ControlPattern-octave = pI "octave"-offset :: Pattern Double -> ControlPattern-offset = pF "offset"-ophatdecay :: Pattern Double -> ControlPattern-ophatdecay = pF "ophatdecay"-{- | 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"--overgain :: Pattern Double -> ControlPattern-overgain = pF "overgain"--overshape :: Pattern Double -> ControlPattern-overshape = pF "overshape"---- | a pattern of numbers between 0 and 1, from left to right (assuming stereo), once round a circle (assuming multichannel)-pan :: Pattern Double -> ControlPattern-pan = pF "pan"--- | 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 "span"--- | a pattern of numbers between 0.0 and 1.0, which controls the multichannel spread range (multichannel only)-pansplay :: Pattern Double -> ControlPattern-pansplay = pF "splay"--- | 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"--- | 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 "orientation"--pitch1 :: Pattern Double -> ControlPattern-pitch1 = pF "pitch1"-pitch2 :: Pattern Double -> ControlPattern-pitch2 = pF "pitch2"-pitch3 :: Pattern Double -> ControlPattern-pitch3 = pF "pitch3"-portamento :: Pattern Double -> ControlPattern-portamento = pF "portamento"--- | used in SuperDirt softsynths as a control rate or "speed"-rate :: Pattern Double -> ControlPattern-rate = pF "rate"--- | a pattern of numbers to specify the release time (in seconds) of an envelope applied to each sample. Only takes effect if `attack` is also specified.-release :: Pattern Double -> ControlPattern-release = pF "release"--- | a pattern of numbers from 0 to 1. Specifies the resonance of the low-pass filter.-resonance :: Pattern Double -> ControlPattern-resonance = pF "resonance"--- | a pattern of numbers from 0 to 1. Sets the level of reverb.-room :: Pattern Double -> ControlPattern-room = pF "room"-sagogo :: Pattern Double -> ControlPattern-sagogo = pF "sagogo"-sclap :: Pattern Double -> ControlPattern-sclap = pF "sclap"-sclaves :: Pattern Double -> ControlPattern-sclaves = pF "sclaves"-scrash :: Pattern Double -> ControlPattern-scrash = pF "scrash"-semitone :: Pattern Double -> ControlPattern-semitone = pF "semitone"--- | 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"--- | 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"-slide :: Pattern Double -> ControlPattern-slide = pF "slide"--- | a pattern of numbers which changes the speed of sample playback, i.e. a cheap way of changing pitch. Negative values will play the sample backwards!-speed :: Pattern Double -> ControlPattern-speed = pF "speed"-squiz :: Pattern Double -> ControlPattern-squiz = pF "squiz"--- | a pattern of strings. Selects the sample to be played.-s' :: Pattern String -> ControlPattern-s' = pS "s"-stutterdepth :: Pattern Double -> ControlPattern-stutterdepth = pF "stutterdepth"-stuttertime :: Pattern Double -> ControlPattern-stuttertime = pF "stuttertime"-sustain :: Pattern Double -> ControlPattern-sustain = pF "sustain"-tomdecay :: Pattern Double -> ControlPattern-tomdecay = pF "tomdecay"-{- | used in conjunction with `speed`, 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`.--}-unit :: Pattern String -> ControlPattern-unit = pS "unit"-velocity :: Pattern Double -> ControlPattern-velocity = pF "velocity"-vcfegint :: Pattern Double -> ControlPattern-vcfegint = pF "vcfegint"-vcoegint :: Pattern Double -> ControlPattern-vcoegint = pF "vcoegint"-voice :: Pattern Double -> ControlPattern-voice = pF "voice"--- | 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"-waveloss :: Pattern Double -> ControlPattern-waveloss = pF "waveloss"---- MIDI-specific params--dur :: Pattern Double -> ControlPattern-dur = pF "dur"-modwheel :: Pattern Double -> ControlPattern-modwheel = pF "modwheel"-expression :: Pattern Double -> ControlPattern-expression = pF "expression"-sustainpedal :: Pattern Double -> ControlPattern-sustainpedal = pF "sustainpedal"---- Tremolo Audio DSP effect | params are "tremolorate" and "tremolodepth"-tremolorate, tremolodepth :: Pattern Double -> ControlPattern-tremolorate = pF "tremolorate"-tremolodepth = pF "tremolodepth"---- Phaser Audio DSP effect | params are "phaserrate" and "phaserdepth"-phaserrate, phaserdepth :: Pattern Double -> ControlPattern-phaserrate = pF "phaserrate"-phaserdepth = pF "phaserdepth"---- More SuperDirt effects--- frequency shifter-fshift, fshiftphase, fshiftnote :: Pattern Double -> ControlPattern-fshift = pF "fshift"-fshiftphase = pF "fshiftphase"-fshiftnote = pF "fshiftnote"--- triode (tube distortion)-triode :: Pattern Double -> ControlPattern-triode = pF "triode"--- krush (like Sonic Pi's shape/bass enhancer)-krush, kcutoff :: Pattern Double -> ControlPattern-krush = pF "krush"-kcutoff = pF "kcutoff"--- octer (like Sonic Pi's octaver effect)-octer, octersub, octersubsub :: Pattern Double -> ControlPattern-octer = pF "octer"-octersub = pF "octersub"-octersubsub = pF "octersubsub"--- ring modulation-ring, ringf, ringdf :: Pattern Double -> ControlPattern-ring = pF "ring"-ringf = pF "ringf"-ringdf = pF "ringdf"--- noisy fuzzy distortion-distort :: Pattern Double -> ControlPattern-distort = pF "distort"---- Spectral freeze-freeze :: Pattern Double -> ControlPattern-freeze = pF "freeze"---- Spectral delay-xsdelay :: Pattern Double -> ControlPattern-xsdelay = pF "xsdelay"--tsdelay :: Pattern Double -> ControlPattern-tsdelay = pF "tsdelay"---- Spectral conform-real :: Pattern Double -> ControlPattern-real = pF "real"--imag :: Pattern Double -> ControlPattern-imag = pF "imag"---- Spectral enhance-enhance :: Pattern Double -> ControlPattern-enhance = pF "enhance"--partials :: Pattern Double -> ControlPattern-partials = pF "partials"---- Spectral comb-comb :: Pattern Double -> ControlPattern-comb = pF "comb"---- Spectral smear-smear :: Pattern Double -> ControlPattern-smear = pF "smear"---- Spectral scramble-scram :: Pattern Double -> ControlPattern-scram = pF "scram"---- Spectral binshift-binshift :: Pattern Double -> ControlPattern-binshift = pF "binshift"---- High pass sort of spectral filter-hbrick :: Pattern Double -> ControlPattern-hbrick = pF "hbrick"---- Low pass sort of spectral filter-lbrick :: Pattern Double -> ControlPattern-lbrick = pF "lbrick"---- aliases-att, bpf, bpq, chdecay, ctf, ctfg, delayfb, delayt, det, gat, hg, hpf, hpq, lag, lbd, lch, lcl, lcp, lcr, lfoc, lfoi- , lfop, lht, llt, loh, lpf, lpq, lsn, ohdecay, phasdp, phasr, pit1, pit2, pit3, por, rel, sz, sag, scl, scp- , scr, sld, std, stt, sus, tdecay, tremdp, tremr, vcf, vco, voi- :: Pattern Double -> ControlPattern-att = attack-bpf = bandf-bpq = bandq-chdecay = clhatdecay-ctf = cutoff-ctfg = cutoffegint-delayfb = delayfeedback-delayt = delaytime-det = detune-gat = gate-hg = hatgrain-hpf = hcutoff-hpq = hresonance-lag = lagogo-lbd = lkick-lch = lclhat-lcl = lclaves-lcp = lclap-lcr = lcrash-lfoc = lfocutoffint-lfoi = lfoint-lfop = lfopitchint-lht = lhitom-llt = llotom-loh = lophat-lpf = cutoff-lpq = resonance-lsn = lsnare-ohdecay = ophatdecay-phasdp = phaserdepth-phasr = phaserrate-pit1 = pitch1-pit2 = pitch2-pit3 = pitch3-por = portamento-rel = release-sag = sagogo-scl = sclaves-scp = sclap-scr = scrash-sz = size-sld = slide-std = stutterdepth-stt = stuttertime-sus = sustain-tdecay = tomdecay-tremdp = tremolodepth-tremr = tremolorate-vcf = vcfegint-vco = vcoegint-voi = voice--midinote :: Pattern Double -> ControlPattern-midinote = note . (subtract 60 <$>)--drum :: Pattern String -> ControlPattern-drum = n . (subtract 60 . drumN <$>)--drumN :: Num a => String -> a-drumN "bd" = 36-drumN "sn" = 38-drumN "lt" = 43-drumN "ht" = 50-drumN "ch" = 42-drumN "oh" = 46-drumN "cp" = 39-drumN "cl" = 75-drumN "ag" = 67-drumN "cr" = 49-drumN _ = 0----- SuperDirt MIDI Params--array :: Pattern [Word8] -> ControlPattern-array = pX "array"-midichan :: Pattern Double -> ControlPattern-midichan = pF "midichan"-control :: Pattern Double -> ControlPattern-control = pF "control"--ccn :: Pattern Double -> ControlPattern-ccn = pF "ccn"-ccv :: Pattern Double -> ControlPattern-ccv = pF "ccv"--polyTouch :: Pattern Double -> ControlPattern-polyTouch = pF "polyTouch"--midibend :: Pattern Double -> ControlPattern-midibend = pF "midibend"--miditouch :: Pattern Double -> ControlPattern-miditouch = pF "miditouch"--nrpnn :: Pattern Int -> ControlPattern-nrpnn = pI "nrpn"-nrpnv :: Pattern Int -> ControlPattern-nrpnv = pI "val"--ctlNum :: Pattern Double -> ControlPattern-ctlNum = pF "ctlNum"--frameRate :: Pattern Double -> ControlPattern-frameRate = pF "frameRate"-frames :: Pattern Double -> ControlPattern-frames = pF "frames"-hours :: Pattern Double -> ControlPattern-hours = pF "hours"--midicmd :: Pattern String -> ControlPattern-midicmd = pS "midicmd"-command :: Pattern String -> ControlPattern-command = midicmd--minutes :: Pattern Double -> ControlPattern-minutes = pF "minutes"-progNum :: Pattern Double -> ControlPattern-progNum = pF "progNum"-seconds :: Pattern Double -> ControlPattern-seconds = pF "seconds"-songPtr :: Pattern Double -> ControlPattern-songPtr = pF "songPtr"-uid :: Pattern Double -> ControlPattern-uid = pF "uid"-val :: Pattern Double -> ControlPattern-val = pF "val"--{- | `up` is now an alias of `note`. -}-up :: Pattern Double -> ControlPattern-up = note--cps :: Pattern Double -> ControlPattern-cps = pF "cps"---- generic names for mapping to e.g. midi controls-button0 :: Pattern Double -> ControlPattern-button0 = pF "button0"-button1 :: Pattern Double -> ControlPattern-button1 = pF "button1"-button2 :: Pattern Double -> ControlPattern-button2 = pF "button2"-button3 :: Pattern Double -> ControlPattern-button3 = pF "button3"-button4 :: Pattern Double -> ControlPattern-button4 = pF "button4"-button5 :: Pattern Double -> ControlPattern-button5 = pF "button5"-button6 :: Pattern Double -> ControlPattern-button6 = pF "button6"-button7 :: Pattern Double -> ControlPattern-button7 = pF "button7"-button8 :: Pattern Double -> ControlPattern-button8 = pF "button8"-button9 :: Pattern Double -> ControlPattern-button9 = pF "button9"-button10 :: Pattern Double -> ControlPattern-button10 = pF "button10"-button11 :: Pattern Double -> ControlPattern-button11 = pF "button11"-button12 :: Pattern Double -> ControlPattern-button12 = pF "button12"-button13 :: Pattern Double -> ControlPattern-button13 = pF "button13"-button14 :: Pattern Double -> ControlPattern-button14 = pF "button14"-button15 :: Pattern Double -> ControlPattern-button15 = pF "button15"-button16 :: Pattern Double -> ControlPattern-button16 = pF "button16"-button17 :: Pattern Double -> ControlPattern-button17 = pF "button17"-button18 :: Pattern Double -> ControlPattern-button18 = pF "button18"-button19 :: Pattern Double -> ControlPattern-button19 = pF "button19"-button20 :: Pattern Double -> ControlPattern-button20 = pF "button20"-button21 :: Pattern Double -> ControlPattern-button21 = pF "button21"-button22 :: Pattern Double -> ControlPattern-button22 = pF "button22"-button23 :: Pattern Double -> ControlPattern-button23 = pF "button23"-button24 :: Pattern Double -> ControlPattern-button24 = pF "button24"-button25 :: Pattern Double -> ControlPattern-button25 = pF "button25"-button26 :: Pattern Double -> ControlPattern-button26 = pF "button26"-button27 :: Pattern Double -> ControlPattern-button27 = pF "button27"-button28 :: Pattern Double -> ControlPattern-button28 = pF "button28"-button29 :: Pattern Double -> ControlPattern-button29 = pF "button29"-button30 :: Pattern Double -> ControlPattern-button30 = pF "button30"-button31 :: Pattern Double -> ControlPattern-button31 = pF "button31"--slider0 :: Pattern Double -> ControlPattern-slider0 = pF "slider0"-slider1 :: Pattern Double -> ControlPattern-slider1 = pF "slider1"-slider2 :: Pattern Double -> ControlPattern-slider2 = pF "slider2"-slider3 :: Pattern Double -> ControlPattern-slider3 = pF "slider3"-slider4 :: Pattern Double -> ControlPattern-slider4 = pF "slider4"-slider5 :: Pattern Double -> ControlPattern-slider5 = pF "slider5"-slider6 :: Pattern Double -> ControlPattern-slider6 = pF "slider6"-slider7 :: Pattern Double -> ControlPattern-slider7 = pF "slider7"-slider8 :: Pattern Double -> ControlPattern-slider8 = pF "slider8"-slider9 :: Pattern Double -> ControlPattern-slider9 = pF "slider9"-slider10 :: Pattern Double -> ControlPattern-slider10 = pF "slider10"-slider11 :: Pattern Double -> ControlPattern-slider11 = pF "slider11"-slider12 :: Pattern Double -> ControlPattern-slider12 = pF "slider12"-slider13 :: Pattern Double -> ControlPattern-slider13 = pF "slider13"-slider14 :: Pattern Double -> ControlPattern-slider14 = pF "slider14"-slider15 :: Pattern Double -> ControlPattern-slider15 = pF "slider15"-slider16 :: Pattern Double -> ControlPattern-slider16 = pF "slider16"-slider17 :: Pattern Double -> ControlPattern-slider17 = pF "slider17"-slider18 :: Pattern Double -> ControlPattern-slider18 = pF "slider18"-slider19 :: Pattern Double -> ControlPattern-slider19 = pF "slider19"-slider20 :: Pattern Double -> ControlPattern-slider20 = pF "slider20"-slider21 :: Pattern Double -> ControlPattern-slider21 = pF "slider21"-slider22 :: Pattern Double -> ControlPattern-slider22 = pF "slider22"-slider23 :: Pattern Double -> ControlPattern-slider23 = pF "slider23"-slider24 :: Pattern Double -> ControlPattern-slider24 = pF "slider24"-slider25 :: Pattern Double -> ControlPattern-slider25 = pF "slider25"-slider26 :: Pattern Double -> ControlPattern-slider26 = pF "slider26"-slider27 :: Pattern Double -> ControlPattern-slider27 = pF "slider27"-slider28 :: Pattern Double -> ControlPattern-slider28 = pF "slider28"-slider29 :: Pattern Double -> ControlPattern-slider29 = pF "slider29"-slider30 :: Pattern Double -> ControlPattern-slider30 = pF "slider30"-slider31 :: Pattern Double -> ControlPattern-slider31 = pF "slider31"
− src/Sound/Tidal/ParseBP.hs
@@ -1,512 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-unused-do-bind #-}--module Sound.Tidal.ParseBP where--import Control.Applicative ((<$>), (<*>), pure)-import qualified Control.Exception as E-import Data.Colour-import Data.Colour.Names-import Data.Functor.Identity (Identity)-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 (chordTable)--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 = TPat_Atom (Maybe ((Int, Int), (Int, Int))) a- | TPat_Fast (TPat Time) (TPat a)- | TPat_Slow (TPat Time) (TPat a)- | TPat_DegradeBy Int Double (TPat a)- | TPat_CycleChoose Int [TPat a]- | TPat_Euclid (TPat Int) (TPat Int) (TPat Int) (TPat a)- | TPat_Stack [TPat a]- | TPat_Polyrhythm (Maybe (TPat Rational)) [TPat a]- | TPat_Seq [TPat a]- | TPat_Silence- | TPat_Foot- | TPat_Elongate Rational (TPat a)- | TPat_Repeat Int (TPat a)- | TPat_EnumFromTo (TPat a) (TPat a)- deriving (Show)--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 = fromMaybe base_first (toPat <$> mSteprate)- base_first | null pats = pure 0- | otherwise = pure $ fst $ head pats- TPat_Seq xs -> snd $ resolve_seq xs- _ -> 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)--{--durations :: [TPat a] -> [(Int, TPat a)]-durations [] = []-durations (TPat_Elongate n : xs) = (n, TPat_Silence) : durations xs-durations (a : TPat_Elongate n : xs) = (n+1,a) : durations xs-durations (a:xs) = (1,a) : durations xs--}--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 = parseRhythm tPatParser--class Parseable a where- tPatParser :: MyParser (TPat a)- doEuclid :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a- -- toEuclid :: a ->--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--instance Enumerable Double where- fromTo = enumFromTo'- fromThenTo = enumFromThenTo'--instance Parseable String where- tPatParser = pVocable- doEuclid = euclidOff--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--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--instance Enumerable Int where- fromTo = enumFromTo'- fromThenTo = enumFromThenTo'--instance Parseable Integer where- tPatParser = pIntegral- doEuclid = euclidOff--instance Enumerable Integer where- fromTo = enumFromTo'- fromThenTo = enumFromThenTo'--instance Parseable Rational where- tPatParser = pRational- doEuclid = euclidOff--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----instance (Parseable a, Pattern p) => IsString (p a) where--- fromString = p :: String -> p a--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 = do s <- sign- num <- naturalOrFloat- return (case num of- Right x -> applySign s x- Left x -> fromIntegral $ applySign s x- )--parseRhythm :: Parseable a => MyParser (TPat a) -> String -> Either ParseError (TPat a)-parseRhythm f = runParser (pSequence f' Prelude.<* eof) (0 :: Int) ""- where f' = do f- <|> do symbol "~" <?> "rest"- return TPat_Silence--pSequence :: Parseable a => MyParser (TPat a) -> GenParser Char Int (TPat a)-pSequence f = do spaces -- TODO is this needed?- -- d <- pFast- s <- many $ do a <- pPart f- spaces- do try $ symbol ".."- b <- pPart f- return $ TPat_EnumFromTo a b- <|> do rs <- many1 $ do oneOf "@_"- r <- ((subtract 1) <$> pRatio) <|> return 1- spaces- return $ r- return $ TPat_Elongate (1 + sum rs) a- <|> do es <- many1 $ do char '!'- n <- (((subtract 1) . read) <$> many1 digit) <|> return 1- spaces- return n- return $ TPat_Repeat (1 + sum es) a- <|> return a- <|> do symbol "."- return TPat_Foot- return $ 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'') = (\(a,b) -> (pat:a,b)) $ takeFoot pats''---pSingle :: MyParser (TPat a) -> MyParser (TPat a)-pSingle f = f >>= pRand >>= pMult--pPart :: Parseable a => MyParser (TPat a) -> MyParser (TPat a)-pPart f = do pt <- (pSingle f <|> pPolyIn f <|> pPolyOut f) >>= pE >>= pRand- spaces -- TODO is this needed?- return pt--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 ","- spaces -- TODO needed?- return $ TPat_Stack (s:ss)- chooseTail s = do symbol "|"- ss <- pSequence f `sepBy` symbol "|"- spaces -- TODO needed?- 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 ",")- spaces -- TODO needed?- 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 ",")- spaces -- TODO needed/wanted?- 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 = wrapPos $ do f <- choice [intOrFloat, parseNote] <?> "float"- do c <- parseChord- return $ TPat_Stack $ map ((TPat_Atom Nothing) . (+f)) c- <|> return (TPat_Atom Nothing f)- <|>- do c <- parseChord- return $ TPat_Stack $ map (TPat_Atom Nothing) c- <|>- do r <- pRatioChar- return $ TPat_Atom Nothing r--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- i <- choice [integer, parseNote]- return $ applySign s $ fromIntegral i--parseInt :: MyParser Int-parseInt = do s <- sign- i <- integer- return $ applySign s $ fromIntegral i--pIntegral :: Integral a => MyParser (TPat a)-pIntegral = wrapPos $ do i <- parseIntNote- do c <- parseChord- return $ TPat_Stack $ map ((TPat_Atom Nothing) . (+i)) c- <|> return (TPat_Atom Nothing i)- <|>- do c <- parseChord- return $ TPat_Stack $ map (TPat_Atom Nothing) c--parseChord :: (Enum a, Num a) => MyParser [a]-parseChord = do char '\''- name <- many1 $ letter <|> digit- let chord = fromMaybe [0] $ lookup name chordTable- do char '\''- notFollowedBy space <?> "chord range or 'i'"- let n = length chord- i <- option n (fromIntegral <$> integer)- j <- length <$> many (char 'i')- let chord' = take i $ drop j $ concatMap (\x -> map (+ x) chord) [0,12..]- return chord'- <|> return chord--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 = either (const 0) id . 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)--pRatio :: MyParser Rational-pRatio = do s <- sign- n <- read <$> many1 digit- result <- do char '%'- d <- decimal- return (n%d)- <|>- do char '.'- frac <- many1 digit- -- A hack, but not sure if doing this- -- numerically would be any faster..- return (toRational ((read $ show n ++ "." ++ frac) :: Double))- <|>- return (n%1)- c <- (pRatioChar <|> return 1)- return $ applySign s (result * c)- <|> pRatioChar--pRatioChar :: Fractional a => MyParser a-pRatioChar = do char 'w'- return $ 1- <|> do char 'h'- return $ 0.5- <|> do char 'q'- return $ 0.25- <|> do char 'e'- return $ 0.125- <|> do char 's'- return $ 0.0625- <|> do char 't'- return $ 1/3- <|> do char 'f'- return $ 0.2--pRational :: MyParser (TPat Rational)-pRational = wrapPos $ (TPat_Atom Nothing) <$> pRatio-
− src/Sound/Tidal/Pattern.hs
@@ -1,774 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-}-{-# LANGUAGE DeriveFunctor #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Sound.Tidal.Pattern where--import Prelude hiding ((<*), (*>))--import Control.Applicative (liftA2)---import Data.Bifunctor (Bifunctor(..))-import Data.Data (Data) -- toConstr-import Data.List (delete, findIndex, sort)-import qualified Data.Map.Strict as Map-import Data.Maybe (isJust, fromJust, catMaybes, mapMaybe)-import Data.Typeable (Typeable)-import Control.DeepSeq (NFData(rnf))-import Data.Word (Word8)----------------------------------------------------------------------------- * Types---- | Time is rational-type Time = Rational ---- | The 'sam' (start of cycle) for the given time value-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---- | 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---- | 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)--type Arc = ArcF Time--instance NFData a => - NFData (ArcF a) where - rnf (Arc s e) = rnf s `seq` rnf e--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--sect :: Arc -> Arc -> Arc-sect (Arc s e) (Arc s' e') = Arc (max s s') (min e e')---- | 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--instance Applicative ArcF where- pure t = Arc t t- (<*>) (Arc sf ef) (Arc sx ex) = Arc (sf sx) (ef ex)---- | The arc of the whole cycle that the given time value falls within-timeToCycleArc :: Time -> Arc-timeToCycleArc t = Arc (sam t) (sam t + 1)---- | Shifts an arc to the equivalent one that starts during cycle zero-cycleArc :: Arc -> Arc-cycleArc (Arc s e) = Arc (cyclePos s) (cyclePos s + (e-s))---- | A list of cycle numbers which are included in the given arc-cyclesInArc :: Integral a => Arc -> [a]-cyclesInArc (Arc s e)- | s > e = []- | s == e = [floor s]- | otherwise = [floor s .. ceiling e-1]---- | A list of arcs of the whole cycles which are included in the given arc-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--data Context = Context {contextPosition :: [((Int, Int), (Int, Int))]}- deriving (Eq, Ord)--instance NFData Context where - rnf (Context c) = rnf c--combineContexts :: [Context] -> Context-combineContexts = Context . concatMap contextPosition--setContext :: Context -> Pattern a -> Pattern a-setContext c pat = withEvents (map (\e -> e {context = c})) pat--withContext :: (Context -> Context) -> Pattern a -> Pattern a-withContext f pat = withEvents (map (\e -> e {context = f $ context e})) pat--deltaContext :: Int -> Int -> Pattern a -> Pattern a-deltaContext column line pat = withEvents (map (\e -> e {context = f $ context e})) pat- where f :: Context -> Context- f (Context xs) = Context $ map (\((bx,by), (ex,ey)) -> ((bx+column,by+line), (ex+column,ey+line))) xs---- | An event is a value that's active during a timespan. If a whole--- is present, the part should be equal to or fit inside it.-data EventF a b = Event- { context :: Context- , whole :: Maybe a- , part :: a- , value :: b- } deriving (Eq, Ord, Functor)--type Event a = EventF (ArcF Time) a--instance (NFData a, NFData b) => - NFData (EventF a b) where - rnf (Event c w p v) = rnf c `seq` rnf w `seq` rnf p `seq` rnf v--{-instance Bifunctor EventF where- bimap f g (Event w p e) = Event (f w) (f p) (g e)--}---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)---- | Compares two lists of events, attempting to combine fragmented events in the process--- for a 'truer' compare-compareDefrag :: (Ord a) => [Event a] -> [Event a] -> Bool-compareDefrag as bs = sort (defragParts as) == sort (defragParts bs)---- | 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---- | an Arc and some named control values-data State = State {arc :: Arc,- controls :: StateMap- }---- | A function that represents events taking place over time-type Query a = (State -> [Event a])---- | A datatype that's basically a query-data Pattern a = Pattern {query :: Query a}--data Value = VS { svalue :: String }- | VF { fvalue :: Double }- | VR { rvalue :: Rational }- | VI { ivalue :: Int }- | VB { bvalue :: Bool }- | VX { xvalue :: [Word8] } -- Used for OSC 'blobs'- deriving (Typeable,Data)--class Valuable a where- toValue :: a -> Value--instance NFData Value where - rnf (VS s) = rnf s - rnf (VF f) = rnf f - rnf (VR r) = rnf r - rnf (VI i) = rnf i - rnf (VB b) = rnf b- rnf (VX xs) = rnf xs--instance Valuable String where- toValue = VS-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 [Word8] where- toValue a = VX 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- (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 (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--type StateMap = Map.Map String (Pattern Value)-type ControlMap = Map.Map String Value-type ControlPattern = Pattern ControlMap----------------------------------------------------------------------------- * Instances--instance NFData a => - NFData (Pattern a) where - rnf (Pattern q) = rnf $ \s -> q s--instance Functor Pattern where- -- | apply a function to all the values in a pattern- fmap f p = p {query = fmap (fmap f) . query p}--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)})--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-- (<*>) = applyPatToPatBoth--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 (\ef -> withFX ef ex) (query (filterDigital pf) $ st {arc = fPart}) -- digital- matchX _ = error "can't happen"- withFX ef ex = do whole' <- subMaybeArc (whole ef) (whole ex)- part' <- subArc (part ef) (part ex)- return (Event (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 (\ef -> withFX ef ex) (query pf $ st {arc = wholeOrPart ex})- withFX ef ex = do let whole' = whole ex- part' <- subArc (part ef) (part ex)- return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex))----- | 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--infixl 4 <*, *>--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 (compressArc (cycleArc $ 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)--noOv :: String -> a-noOv meth = error $ meth ++ ": not supported for patterns"--class TolerantEq a where- (~==) :: a -> a -> Bool--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--instance TolerantEq ControlMap where- a ~== b = Map.differenceWith (\a' b' -> if a' ~== b' then Nothing else Just a') a b == Map.empty--instance TolerantEq (Event ControlMap) where- (Event _ w p x) ~== (Event _ w' p' x') = w == w' && p == p' && x ~== x'--instance TolerantEq a => TolerantEq [a] where- as ~== bs = (length as == length bs) && all (uncurry (~==)) (zip as bs)---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 (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 ControlMap 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 ControlMap where- recip = fmap (applyFIS recip id id)- fromRational = Map.singleton "speed" . VF . fromRational----------------------------------------------------------------------------- * Internal functions--empty :: Pattern a-empty = Pattern {query = const []}--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 p = p {query = query p . (\(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 = withQueryArc (\(Arc s e) -> Arc (f s) (f e))---- | @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 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)---- | 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 _ (VI i ) = VI $ f i-applyFIS _ _ f (VS s ) = VS $ f s-applyFIS _ _ _ v = v---- | Apply one of two functions to a Value, depending on its type (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 (VI a) (VF b) = VF $ fFloat (fromIntegral a) b-fNum2 _ fFloat (VF a) (VI b) = VF $ fFloat a (fromIntegral b)-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--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--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))--_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-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-rotR :: Time -> Pattern a -> Pattern a-rotR t = rotL (negate t)---- ** 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 in to a pattern of values,--- dropping the events of 'Nothing'.-filterJust :: Pattern (Maybe a) -> Pattern a-filterJust p = fromJust <$> filterValues isJust p---- formerly known as playWhen-filterWhen :: (Time -> Bool) -> Pattern a -> Pattern a-filterWhen test p = p {query = filter (test . wholeStart) . query p}--filterOnsets :: Pattern a -> Pattern a-filterOnsets p = p {query = filter (\e -> eventPartStart e == wholeStart e) . query (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 = filterWhen (\t -> (t >= s) && (t < e))---- ** 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---- | 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) (map value $ as'), x)- where as' = as $ start $ wholeOrPart ex- as s = query pa $ fQuery s- fQuery s = st {arc = Arc s s}
+ src/Sound/Tidal/Safe/Boot.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-+ Safe/Boot.hs - as in BootTidal but in the Op monad+ Copyright (C) 2021 Johannes Waldmann and contributors++ Forked from:+ https://github.com/jwaldmann/safe-tidal-cli/++ 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/>.+-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}++module Sound.Tidal.Safe.Boot where++import Sound.Tidal.Safe.Context+import qualified Sound.Tidal.Transition++-- everyone is missing the tidal :: Stream argument+-- 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:+--+-- > 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++-- |+-- 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++-- * Transitions++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++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
@@ -0,0 +1,125 @@+{-+ Safe/Context.hs - wraps UI functions+ Copyright (C) 2021 Johannes Waldmann and contributors++ Forked from:+ https://github.com/jwaldmann/safe-tidal-cli/++ 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/>.+-}+{-# 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 (..),+ )+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+import Sound.Tidal.ParseBP as C+import Sound.Tidal.Pattern as C+import Sound.Tidal.Scales as C+import Sound.Tidal.Simple 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++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++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,275 +0,0 @@-module Sound.Tidal.Scales (scale, scaleList, scaleTable, getScale) where--import Prelude hiding ((<*), (*>))-import Data.Maybe-import Sound.Tidal.Pattern-import Sound.Tidal.Utils---- 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]-----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]-----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]-----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]--scale :: Fractional a => Pattern String -> Pattern Int -> Pattern a-scale = getScale scaleTable--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)--scaleList :: String-scaleList = unwords $ map fst (scaleTable :: [(String, [Rational])])--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,203 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RecordWildCards #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Sound.Tidal.Show (show, showAll, draw, drawLine) where--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)--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))) ' ')- ++ fst ev- ++ snd 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 show $ sortOn part $ queryArc p a--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 (VR r) = show r ++ "r"- show (VB b) = show b- show (VX xs) = show xs--instance {-# OVERLAPPING #-} Show ControlMap 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 = show (context e) ++ ((\(a,b) -> a ++ b) $ 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]) $ map part $ filter eventHasOnset $ queryArc pat (Arc 0 1)- where eventSteps xs = foldr lcm 1 $ map denominator 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 (\(a,b) -> a ++ b) 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 ((\x -> ('|':x)) .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,50 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Sound.Tidal.Simple where--import Sound.Tidal.Control (chop, hurry)-import Sound.Tidal.Core ((#), (|*), (<~), silence, rev)-import Sound.Tidal.Params (crush, gain, pan, speed, s)-import Sound.Tidal.ParseBP (parseBP_E)-import Sound.Tidal.Pattern (ControlPattern)-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,483 +1,36 @@-{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}--module Sound.Tidal.Stream where--import Control.Applicative ((<|>))-import Control.Concurrent.MVar-import Control.Concurrent-import qualified Data.Map.Strict as Map-import Data.Maybe (fromJust, fromMaybe, isJust, catMaybes)-import qualified Control.Exception as E--- import Control.Monad.Reader--- import Control.Monad.Except--- import qualified Data.Bifunctor as BF--- import qualified Data.Bool as B--- import qualified Data.Char as C-import System.IO (hPutStrLn, stderr)--import qualified Sound.OSC.FD as O--import Sound.Tidal.Config-import Sound.Tidal.Core (stack, silence)-import Sound.Tidal.Pattern-import qualified Sound.Tidal.Tempo as T--- import qualified Sound.OSC.Datum as O-import Data.List (sortOn)-import System.Random (getStdRandom, randomR)-import Sound.Tidal.Show ()--data TimeStamp = BundleStamp | MessageStamp | NoStamp- deriving (Eq, Show)--data Stream = Stream {sConfig :: Config,- sInput :: MVar StateMap,- sOutput :: MVar ControlPattern,- sListenTid :: Maybe ThreadId,- sPMapMV :: MVar PlayMap,- sTempoMV :: MVar T.Tempo,- sGlobalFMV :: MVar (ControlPattern -> ControlPattern),- sCxs :: [Cx]- }--type PatId = String--data Cx = Cx {cxTarget :: OSCTarget,- cxUDP :: O.UDP- }--data OSCTarget = OSCTarget {oName :: String,- oAddress :: String,- oPort :: Int,- oPath :: String,- oShape :: Maybe [(String, Maybe Value)],- oLatency :: Double,- oPreamble :: [O.Datum],- oTimestamp :: TimeStamp- }- deriving Show--superdirtTarget :: OSCTarget-superdirtTarget = OSCTarget {oName = "SuperDirt",- oAddress = "127.0.0.1",- oPort = 57120,- oPath = "/play2",- oShape = Nothing,- oLatency = 0.02,- oPreamble = [],- oTimestamp = BundleStamp- }--dirtTarget :: OSCTarget-dirtTarget = OSCTarget {oName = "Dirt",- oAddress = "127.0.0.1",- oPort = 7771,- oPath = "/play",- oShape = Just [("sec", Just $ VI 0),- ("usec", Just $ VI 0),- ("cps", Just $ VF 0),- ("s", Nothing),- ("offset", Just $ VF 0),- ("begin", Just $ VF 0),- ("end", Just $ VF 1),- ("speed", Just $ VF 1),- ("pan", Just $ VF 0.5),- ("velocity", Just $ VF 0.5),- ("vowel", Just $ VS ""),- ("cutoff", Just $ VF 0),- ("resonance", Just $ VF 0),- ("accelerate", Just $ VF 0),- ("shape", Just $ VF 0),- ("kriole", Just $ VI 0),- ("gain", Just $ VF 1),- ("cut", Just $ VI 0),- ("delay", Just $ VF 0),- ("delaytime", Just $ VF (-1)),- ("delayfeedback", Just $ VF (-1)),- ("crush", Just $ VF 0),- ("coarse", Just $ VI 0),- ("hcutoff", Just $ VF 0),- ("hresonance", Just $ VF 0),- ("bandf", Just $ VF 0),- ("bandq", Just $ VF 0),- ("unit", Just $ VS "rate"),- ("loop", Just $ VF 0),- ("n", Just $ VF 0),- ("attack", Just $ VF (-1)),- ("hold", Just $ VF 0),- ("release", Just $ VF (-1)),- ("orbit", Just $ VI 0),- ("id", Just $ VI 0)- ],- oLatency = 0.02,- oPreamble = [],- oTimestamp = MessageStamp- }--startStream :: Config -> MVar StateMap -> [OSCTarget] -> IO (MVar ControlPattern, MVar T.Tempo, [Cx])-startStream config sMapMV targets- = do cxs <- mapM (\target -> do u <- O.openUDP (oAddress target) (oPort target)- return $ Cx {cxUDP = u,- cxTarget = target- }- ) targets- pMV <- newMVar empty- (tempoMV, _) <- T.clocked config $ onTick config sMapMV pMV cxs- return $ (pMV, tempoMV, cxs)---data PlayState = PlayState {pattern :: ControlPattern,- mute :: Bool,- solo :: Bool,- history :: [ControlPattern]- }- deriving Show--type PlayMap = Map.Map PatId PlayState--toDatum :: Value -> O.Datum-toDatum (VF 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--toData :: OSCTarget -> Event ControlMap -> Maybe [O.Datum]-toData target e- | isJust (oShape target) = fmap (fmap toDatum) $ sequence $ map (\(n,v) -> Map.lookup n (value e) <|> v) (fromJust $ oShape target)- | otherwise = Just $ concatMap (\(n,v) -> [O.string n, toDatum v]) $ Map.toList $ value e--substitutePath :: String -> ControlMap -> String-substitutePath path cm = parse path- where parse [] = []- parse ('{':xs) = parseWord xs- parse (x:xs) = x:(parse xs)- parseWord xs | b == [] = getString cm a- | otherwise = getString cm a ++ parse (tail b)- where (a,b) = break (== '}') xs--getString :: ControlMap -> String -> String-getString cm s = fromMaybe "" $ do v <- Map.lookup s cm- return $ simpleShow v- where simpleShow :: Value -> String- simpleShow (VS str) = str- simpleShow (VI i) = show i- simpleShow (VF f) = show f- simpleShow (VR r) = show r- simpleShow (VB b) = show b- simpleShow (VX xs) = show xs--toMessage :: Config -> Double -> OSCTarget -> T.Tempo -> Event (Map.Map String Value) -> Maybe O.Message-toMessage config t target tempo e = do vs <- toData target addExtra- return $ O.Message (substitutePath (oPath target) (value e)) $ oPreamble target ++ vs- where on = sched tempo $ start $ wholeOrPart e- off = sched tempo $ stop $ wholeOrPart e- cm = value e- identifier = ((if (start $ wholeOrPart e) == (start $ part e) then "X" else ">")- ++ show (start $ wholeOrPart e)- ++ "-"- ++ show (stop $ wholeOrPart e)- ++ "-"- ++ getString cm "n"- ++ "-"- ++ getString cm "note"- ++ "-"- ++ getString cm "s"- )- delta = off - on- messageStamp = oTimestamp target == MessageStamp- -- If there is already cps in the event, the union will preserve that.- addExtra = (\v -> (Map.union v $ Map.fromList (extra messageStamp)- )) <$> e- addIdentifier | cSendParts config = (("id", VS identifier):)- | otherwise = id- extra False = addIdentifier [("cps", (VF $ T.cps tempo)),- ("delta", VF delta),- ("cycle", VF (fromRational $ start $ wholeOrPart e))- ]- extra True = timestamp ++ (extra False)- timestamp = [("sec", VI sec),- ("usec", VI usec)- ]- ut = O.ntpr_to_ut t- sec = floor ut- usec = floor $ 1000000 * (ut - (fromIntegral sec))--doCps :: MVar T.Tempo -> (Double, Maybe Value) -> IO ()-doCps tempoMV (d, Just (VF cps)) = do _ <- forkIO $ do threadDelay $ floor $ d * 1000000- -- hack to stop things from stopping !- _ <- T.setCps tempoMV (max 0.00001 cps)- return ()- return ()-doCps _ _ = return ()--onTick :: Config -> MVar StateMap -> MVar ControlPattern -> [Cx] -> MVar T.Tempo -> T.State -> IO ()-onTick config sMapMV pMV cxs tempoMV st =- do p <- readMVar pMV- sMap <- readMVar sMapMV- tempo <- takeMVar tempoMV- let frameEnd = snd $ T.nowTimespan st- sMap' = Map.insert "_cps" (pure $ VF $ T.cps tempo) sMap- es = sortOn (start . part) $ filterOns $ query p (State {arc = T.nowArc st, controls = sMap'})- filterOns | cSendParts config = id- | otherwise = filter eventHasOnset- -- there should always be a whole (due to the eventHasOnset filter)- on e tempo'' = (sched tempo'' $ start $ wholeOrPart e)- eventNudge e = fromJust $ getF $ fromMaybe (VF 0) $ Map.lookup "nudge" $ value e- processCps :: T.Tempo -> [Event ControlMap] -> ([(T.Tempo, Event ControlMap)], T.Tempo)- processCps t [] = ([], t)- -- If an event has a tempo change, that affects the following- -- events..- processCps t (e:evs) = (((t', e):es'), t'')- where cps' = do x <- Map.lookup "cps" $ value e- getF x- t' = (maybe t (\newCps -> T.changeTempo' t newCps (eventPartStart e)) cps')- (es', t'') = processCps t' evs- latency target = oLatency target + cFrameTimespan config + T.nudged tempo- (tes, tempo') = processCps tempo es- mapM_ (\(Cx target udp) -> (do let ms = catMaybes $ map (\(t, e) -> do let nudge = eventNudge e- let onset = on e t- m <- toMessage config (onset + nudge + latency target) target tempo e- -- drop events that have gone out of frame (due to tempo- -- changes during the frame)- if (onset < frameEnd)- then Just (onset + nudge, m)- else Nothing- ) tes- E.catch (mapM_ (send target (latency target) udp) ms)- )- (\(e ::E.SomeException)- -> putStrLn $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e- )- ) cxs- putMVar tempoMV tempo'- return ()--send :: O.Transport t => OSCTarget -> Double -> t -> (Double, O.Message) -> IO ()-send target latency u (time, m)- | oTimestamp target == BundleStamp = O.sendBundle u $ O.Bundle (time + latency) [m]- | oTimestamp target == MessageStamp = O.sendMessage u m- | otherwise = do _ <- forkIO $ do now <- O.time- threadDelay $ floor $ ((time+latency) - now) * 1000000- O.sendMessage u m- return ()--sched :: T.Tempo -> Rational -> Double-sched tempo c = ((fromRational $ c - (T.atCycle tempo)) / T.cps tempo) + (T.atTime tempo)---- Interaction--streamNudgeAll :: Stream -> Double -> IO ()-streamNudgeAll s nudge = do tempo <- takeMVar $ sTempoMV s- putMVar (sTempoMV s) $ tempo {T.nudged = nudge}--streamResetCycles :: Stream -> IO ()-streamResetCycles s = do _ <- T.resetCycles (sTempoMV s)- return ()--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 _ _ True _)) = k ++ " - solo\n"- showKV True (k, _) = "(" ++ k ++ ")\n"- showKV False (k, (PlayState _ 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 :: Show a => Stream -> a -> ControlPattern -> IO ()-streamReplace s k !pat- = E.catch (do let x = queryArc pat (Arc 0 0)- tempo <- readMVar $ sTempoMV s- input <- takeMVar $ sInput s- -- put change time in control input- now <- O.time- let cyc = T.timeToCycles tempo now- putMVar (sInput s) $- Map.insert ("_t_all") (pure $ VR cyc) $ Map.insert ("_t_" ++ show k) (pure $ VR cyc) input- -- update the pattern itself- pMap <- seq x $ takeMVar $ sPMapMV s- let playState = updatePS $ Map.lookup (show k) pMap- putMVar (sPMapMV s) $ Map.insert (show k) playState pMap- calcOutput s- return ()- )- (\(e :: E.SomeException) -> hPutStrLn stderr $ "Error in pattern: " ++ show e- )- where updatePS (Just playState) = do playState {pattern = pat, history = pat:(history playState)}- updatePS Nothing = PlayState pat False False [pat]--streamMute :: Show a => Stream -> a -> IO ()-streamMute s k = withPatId s (show k) (\x -> x {mute = True})--streamMutes :: Show a => Stream -> [a] -> IO ()-streamMutes s ks = withPatIds s (map show ks) (\x -> x {mute = True})--streamUnmute :: Show a => Stream -> a -> IO ()-streamUnmute s k = withPatId s (show k) (\x -> x {mute = False})--streamSolo :: Show a => Stream -> a -> IO ()-streamSolo s k = withPatId s (show k) (\x -> x {solo = True})--streamUnsolo :: Show a => Stream -> a -> IO ()-streamUnsolo s k = withPatId s (show k) (\x -> x {solo = False})--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 st p- = do sMap <- readMVar (sInput st)- tempo <- readMVar (sTempoMV st)- now <- O.time- let fakeTempo = T.Tempo {T.cps = T.cps tempo,- T.atCycle = 0,- T.atTime = now,- T.paused = False,- T.nudged = 0- }- sMap' = Map.insert "_cps" (pure $ VF $ T.cps tempo) sMap- es = filter eventHasOnset $ query p (State {arc = (Arc 0 1),- controls = sMap'- }- )- -- there should always be a whole (due to the eventHasOnset filter)- at e = sched fakeTempo $ start $ wholeOrPart e- -- there should always be a whole (due to the eventHasOnset filter)- on e = sched tempo $ start $ wholeOrPart e- cpsChanges = map (\e -> (on e - now, Map.lookup "cps" $ value e)) es- config = sConfig st- messages target =- catMaybes $ map (\e -> do m <- toMessage config (at e + (oLatency target)) target fakeTempo e- return $ (at e, m)- ) es- mapM_ (\(Cx target udp) ->- E.catch (mapM_ (send target (oLatency target) udp) (messages target))- (\(e ::E.SomeException)- -> putStrLn $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e- )- ) (sCxs st)- mapM_ (doCps $ sTempoMV st) cpsChanges- return ()--withPatId :: Stream -> PatId -> (PlayState -> PlayState) -> IO ()-withPatId s k f = withPatIds s [k] f--withPatIds :: Stream -> [PatId] -> (PlayState -> PlayState) -> IO ()-withPatIds s ks f- = do playMap <- takeMVar $ sPMapMV s- let pMap' = foldr (Map.update (\x -> Just $ f x)) playMap ks- putMVar (sPMapMV s) pMap'- calcOutput s- return ()---- TODO - is there a race condition here?-streamMuteAll :: Stream -> IO ()-streamMuteAll s = do modifyMVar_ (sOutput s) $ return . const silence- modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = True})--streamHush :: Stream -> IO ()-streamHush s = do modifyMVar_ (sOutput s) $ return . const silence- modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {pattern = silence, history = silence:history x})--streamUnmuteAll :: Stream -> IO ()-streamUnmuteAll s = do modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = False})- calcOutput s---streamAll :: Stream -> (ControlPattern -> ControlPattern) -> IO ()-streamAll s f = do _ <- swapMVar (sGlobalFMV s) f- calcOutput s--streamSet :: Valuable a => Stream -> String -> Pattern a -> IO ()-streamSet s k pat = do sMap <- takeMVar $ sInput s- let pat' = toValue <$> pat- sMap' = Map.insert k pat' sMap- putMVar (sInput 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--calcOutput :: Stream -> IO ()-calcOutput s = do pMap <- readMVar $ sPMapMV s- globalF <- (readMVar $ sGlobalFMV s)- _ <- swapMVar (sOutput s) $ globalF $ toPat $ pMap- return ()- where toPat pMap =- stack $ map pattern $ filter (\pState -> if hasSolo pMap- then solo pState- else not (mute pState)- ) (Map.elems pMap)--startTidal :: OSCTarget -> Config -> IO Stream-startTidal target config = startMulti [target] config--startMulti :: [OSCTarget] -> Config -> IO Stream-startMulti targets config =- do sMapMV <- newMVar (Map.empty :: StateMap)- listenTid <- ctrlListen sMapMV config- (pMV, tempoMV, cxs) <- startStream config sMapMV targets- pMapMV <- newMVar Map.empty- globalFMV <- newMVar id- return $ Stream {sConfig = config,- sInput = sMapMV,- sListenTid = listenTid,- sOutput = pMV,- sPMapMV = pMapMV,- sTempoMV = tempoMV,- sGlobalFMV = globalFMV,- sCxs = cxs- }+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 -ctrlListen :: MVar StateMap -> Config -> IO (Maybe ThreadId)-ctrlListen sMapMV c- | cCtrlListen c = do putStrLn $ "Listening for controls on " ++ cCtrlAddr c ++ ":" ++ show (cCtrlPort c)- catchAny run (\_ -> do putStrLn $ "Control listen failed. Perhaps there's already another tidal instance listening on that port?"- return Nothing- )- | otherwise = return Nothing- where- run = do sock <- O.udpServer (cCtrlAddr c) (cCtrlPort c)- tid <- forkIO $ loop sock- return $ Just tid- loop sock = do ms <- O.recvMessages sock- mapM_ act ms- loop sock- act (O.Message x (O.Int32 k:v:[]))- = act (O.Message x [O.string $ show k,v])- act (O.Message _ (O.ASCII_String k:v@(O.Float _):[]))- = add (O.ascii_to_string k) (VF $ fromJust $ O.datum_floating v)- act (O.Message _ (O.ASCII_String k:O.ASCII_String v:[]))- = add (O.ascii_to_string k) (VS $ O.ascii_to_string v)- act (O.Message _ (O.ASCII_String k:O.Int32 v:[]))- = add (O.ascii_to_string k) (VI $ fromIntegral v)- act m = putStrLn $ "Unhandled OSC: " ++ show m- add :: String -> Value -> IO ()- add k v = do sMap <- takeMVar sMapMV- putMVar sMapMV $ Map.insert k (pure v) sMap- return ()- catchAny :: IO a -> (E.SomeException -> IO a) -> IO a- catchAny = E.catch+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 - 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+ 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/>.+-}
+ 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,229 @@+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++required :: Maybe Value+required = Nothing
+ 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,150 @@+{-# 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"++-- Evaluation of pat is forced so exceptions are picked up here, before replacing the existing pattern.+streamReplace :: Stream -> ID -> ControlPattern -> IO ()+streamReplace stream k !pat = do+ t <- Clock.getCycleTime (toClockConfig $ sConfig stream) (sClockRef 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/Tempo.hs
@@ -1,218 +0,0 @@-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-orphans #-}-{-# LANGUAGE RecordWildCards #-}--module Sound.Tidal.Tempo where--import Control.Concurrent.MVar-import qualified Sound.Tidal.Pattern as P-import qualified Sound.OSC.FD as O-import qualified Network.Socket as N-import Control.Concurrent (forkIO, ThreadId, threadDelay)-import Control.Monad (forever, when, foldM)-import Data.List (nub)-import qualified Control.Exception as E-import Sound.Tidal.Config-import Sound.Tidal.Utils (writeError)--instance Show O.UDP where- show _ = "-unshowable-"--data Tempo = Tempo {atTime :: O.Time,- atCycle :: Rational,- cps :: O.Time,- paused :: Bool,- nudged :: Double,- localUDP :: O.UDP,- remoteAddr :: N.SockAddr,- synched :: Bool- }- deriving Show--data State = State {ticks :: Int,- start :: O.Time,- nowTimespan :: (O.Time, O.Time),- nowArc :: P.Arc,- starting :: Bool- }--changeTempo :: MVar Tempo -> (O.Time -> Tempo -> Tempo) -> IO Tempo-changeTempo tempoMV f = do t <- O.time- tempo <- takeMVar tempoMV- let tempo' = f t $ tempo- sendTempo tempo'- putMVar tempoMV tempo'- return tempo'--changeTempo' :: Tempo -> O.Time -> Rational -> Tempo-changeTempo' tempo newCps cyc = tempo {atTime = cyclesToTime tempo cyc,- cps = newCps,- atCycle = cyc- }--resetCycles :: MVar Tempo -> IO Tempo-resetCycles tempoMV = changeTempo tempoMV (\t tempo -> tempo {atTime = t, atCycle = 0})--setCps :: MVar Tempo -> O.Time -> IO Tempo-setCps tempoMV newCps = changeTempo tempoMV (\t tempo -> tempo {atTime = t,- atCycle = timeToCycles tempo t,- cps = newCps- })--defaultCps :: O.Time-defaultCps = 0.5625- -defaultTempo :: O.Time -> O.UDP -> N.SockAddr -> Tempo-defaultTempo t local remote = Tempo {atTime = t,- atCycle = 0,- cps = defaultCps,- paused = False,- nudged = 0,- localUDP = local,- remoteAddr = remote,- synched = False- }---- | Returns the given time in terms of--- cycles relative to metrical grid of a given Tempo-timeToCycles :: Tempo -> O.Time -> Rational-timeToCycles tempo t = atCycle tempo + toRational cycleDelta- where delta = t - atTime tempo- cycleDelta = realToFrac (cps tempo) * delta--cyclesToTime :: Tempo -> Rational -> O.Time-cyclesToTime tempo cyc = atTime tempo + (fromRational timeDelta)- where cycleDelta = cyc - atCycle tempo- timeDelta = cycleDelta / (toRational $ cps tempo)--{--getCurrentCycle :: MVar Tempo -> IO Rational-getCurrentCycle t = (readMVar t) >>= (cyclesNow) >>= (return . toRational)--}--clocked :: Config -> (MVar Tempo -> State -> IO ()) -> IO (MVar Tempo, [ThreadId])-clocked config callback- = do s <- O.time- -- TODO - do something with thread id- _ <- serverListen config- (tempoMV, listenTid) <- clientListen config s- let st = State {ticks = 0,- start = s,- nowTimespan = (s, s + frameTimespan),- nowArc = P.Arc 0 0,- starting = True- }- clockTid <- forkIO $ loop tempoMV st- return (tempoMV, [listenTid, clockTid])- where frameTimespan :: Double- frameTimespan = cFrameTimespan config- loop tempoMV st =- do -- putStrLn $ show $ nowArc ts- tempo <- readMVar tempoMV - t <- O.time- let logicalT ticks' = start st + fromIntegral ticks' * frameTimespan- logicalNow = logicalT $ ticks st + 1- -- Wait maximum of two frames- delta = min (frameTimespan * 2) (logicalNow - t)- e = timeToCycles tempo logicalNow- s = if starting st && synched tempo- then timeToCycles tempo (logicalT $ ticks st)- else P.stop $ nowArc st- when (t < logicalNow) $ threadDelay (floor $ delta * 1000000)- t' <- O.time- let actualTick = floor $ (t' - start st) / frameTimespan- -- reset ticks if ahead/behind by skipTicks or more- ahead = (abs $ actualTick - ticks st) > (cSkipTicks config)- newTick | ahead = actualTick- | otherwise = (ticks st) + 1- st' = st {ticks = newTick,- nowArc = P.Arc s e,- nowTimespan = (logicalNow, logicalNow + frameTimespan),- starting = not (synched tempo)- }- when ahead $ writeError $ "skip: " ++ show (actualTick - ticks st)- callback tempoMV st'- {-putStrLn ("actual tick: " ++ show actualTick- ++ " old tick: " ++ show (ticks st)- ++ " new tick: " ++ show newTick- )-}- loop tempoMV st'--clientListen :: Config -> O.Time -> IO (MVar Tempo, ThreadId)-clientListen config s =- do -- Listen on random port- let tempoClientPort = cTempoClientPort config- hostname = cTempoAddr config- port = cTempoPort config- (remote_addr:_) <- N.getAddrInfo Nothing (Just hostname) Nothing- local <- O.udpServer "0.0.0.0" tempoClientPort- let (N.SockAddrInet _ a) = N.addrAddress remote_addr- remote = N.SockAddrInet (fromIntegral port) a- t = defaultTempo s local remote- -- Send to clock port from same port that's listened to- O.sendTo local (O.p_message "/hello" []) remote- -- Make tempo mvar- tempoMV <- newMVar t- -- Listen to tempo changes- tempoChild <- forkIO $ listenTempo local tempoMV- return (tempoMV, tempoChild)--sendTempo :: Tempo -> IO ()-sendTempo tempo = O.sendTo (localUDP tempo) (O.p_bundle (atTime tempo) [m]) (remoteAddr tempo)- where m = O.Message "/transmit/cps/cycle" [O.Float $ fromRational $ atCycle tempo,- O.Float $ realToFrac $ cps tempo,- O.Int32 $ if paused tempo then 1 else 0- ]- -listenTempo :: O.UDP -> MVar Tempo -> IO ()-listenTempo udp tempoMV = forever $ do pkt <- O.recvPacket udp- act Nothing pkt- return ()- where act _ (O.Packet_Bundle (O.Bundle ts ms)) = mapM_ (act (Just ts) . O.Packet_Message) ms- act (Just ts) (O.Packet_Message (O.Message "/cps/cycle" [O.Float atCycle',- O.Float cps',- O.Int32 paused'- ]- )- ) =- do tempo <- takeMVar tempoMV- putMVar tempoMV $ tempo {atTime = ts,- atCycle = realToFrac atCycle',- cps = realToFrac cps',- paused = paused' == 1,- synched = True- }- act _ pkt = writeError $ "Unknown packet (client): " ++ show pkt--serverListen :: Config -> IO (Maybe ThreadId)-serverListen config = catchAny run (\_ -> return Nothing) -- probably just already running)- where run = do let port = cTempoPort config- -- iNADDR_ANY deprecated - what's the right way to do this?- udp <- O.udpServer "0.0.0.0" port- cpsMessage <- defaultCpsMessage- tid <- forkIO $ loop udp ([], cpsMessage)- return $ Just tid- loop udp (cs, msg) = do (pkt,c) <- O.recvFrom udp- (cs', msg') <- act udp c Nothing (cs,msg) pkt- loop udp (cs', msg')- act :: O.UDP -> N.SockAddr -> Maybe O.Time -> ([N.SockAddr], O.Packet) -> O.Packet -> IO ([N.SockAddr], O.Packet)- act udp c _ (cs,msg) (O.Packet_Bundle (O.Bundle ts ms)) = foldM (act udp c (Just ts)) (cs,msg) $ map O.Packet_Message ms- act udp c _ (cs,msg) (O.Packet_Message (O.Message "/hello" []))- = do O.sendTo udp msg c - return (nub (c:cs),msg)- act udp _ (Just ts) (cs,_) (O.Packet_Message (O.Message "/transmit/cps/cycle" params)) =- do let path' = "/cps/cycle"- msg' = O.p_bundle ts [O.Message path' params]- mapM_ (O.sendTo udp msg') cs- return (cs, msg')- act _ x _ (cs,msg) pkt = do writeError $ "Unknown packet (serv): " ++ show pkt ++ " / " ++ (show x)- return (cs,msg)- catchAny :: IO a -> (E.SomeException -> IO a) -> IO a- catchAny = E.catch- defaultCpsMessage = do ts <- O.time- return $ O.p_bundle ts [O.Message "/cps/cycle" [O.Float $ 0,- O.Float $ realToFrac $ defaultCps,- O.Int32 0- ]- ]--
src/Sound/Tidal/Transition.hs view
@@ -2,197 +2,299 @@ module Sound.Tidal.Transition where -import Prelude hiding ((<*), (*>))--import Control.Concurrent.MVar (readMVar, takeMVar, putMVar)--import qualified Sound.OSC.FD as O+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 (ID (fromID)) import Sound.Tidal.Params (gain, pan) import Sound.Tidal.Pattern-import Sound.Tidal.Stream-import Sound.Tidal.Tempo (timeToCycles)-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+ 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/>.+-}++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 :: Show a => Stream -> Bool -> (Time -> [ControlPattern] -> ControlPattern) -> a -> ControlPattern -> IO ()-transition stream historyFlag f patId !pat =- do pMap <- takeMVar (sPMapMV stream)- let playState = updatePS $ Map.lookup (show patId) pMap- pat' <- transition' $ appendPat (not historyFlag) (history playState)- let pMap' = Map.insert (show patId) (playState {pattern = pat'}) pMap- putMVar (sPMapMV stream) pMap'- calcOutput stream- return ()- where- appendPat flag = if flag then (pat:) else id- updatePS (Just playState) = playState {history = (appendPat historyFlag) (history playState)}- updatePS Nothing = PlayState {pattern = silence,- mute = False,- solo = False,- history = (appendPat historyFlag) (silence:[])- }- transition' pat' = do tempo <- readMVar $ sTempoMV stream- now <- O.time- let c = timeToCycles tempo now- return $ f c pat'+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 --- | 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))+-- |+-- 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 +-- |+-- 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) -interpolate :: Time -> [ControlPattern] -> ControlPattern-interpolate = interpolateIn 4+-- | 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 -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- )+-- wash :: (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Time -> Time -> Time -> Time -> [Pattern a] -> Pattern a -{-|-Degrades the current pattern while undegrading the next.+-- | `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 -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.+-- Deprecated aliases+mortalOverlay :: Time -> Time -> [Pattern a] -> Pattern a+mortalOverlay = _mortalOverlay -@-d1 $ sound "bd(3,8)"+wash ::+ (Pattern a -> Pattern a) ->+ (Pattern a -> Pattern a) ->+ Time ->+ Time ->+ Time ->+ Time ->+ [Pattern a] ->+ Pattern a+wash = _wash -t1 clutch $ sound "[hh*4, odx(3,8)]"-@+washIn ::+ (Pattern a -> Pattern a) ->+ Time ->+ Time ->+ [Pattern a] ->+ Pattern a+washIn = _washIn -@clutch@ takes two cycles for the transition, essentially this is @clutchIn 2@.--}-clutch :: Time -> [Pattern a] -> Pattern a-clutch = clutchIn 2+xfadeIn :: Time -> Time -> [ControlPattern] -> ControlPattern+xfadeIn = _xfadeIn -{-|-Also degrades the current pattern and undegrades the next.-To change the number of cycles the transition takes, you can use @clutchIn@ like so:+histpan :: Int -> Time -> [ControlPattern] -> ControlPattern+histpan = _histpan -@-d1 $ sound "bd(5,8)"+wait :: Time -> Time -> [ControlPattern] -> ControlPattern+wait = _wait -t1 (clutchIn 8) $ sound "[hh*4, odx(3,8)]"-@+waitT ::+ (Time -> [ControlPattern] -> ControlPattern) ->+ Time ->+ Time ->+ [ControlPattern] ->+ ControlPattern+waitT = _waitT -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)+jump :: Time -> [ControlPattern] -> ControlPattern+jump = _jump -{-| 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)"+jumpIn' :: Int -> Time -> [ControlPattern] -> ControlPattern+jumpIn' = _jumpIn' -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 -> Time -> [ControlPattern] -> ControlPattern+jumpMod = _jumpMod --- wash :: (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Time -> Time -> Time -> Time -> [Pattern a] -> Pattern a+jumpMod' :: Int -> Int -> Time -> [ControlPattern] -> ControlPattern+jumpMod' = _jumpMod' -{- | `anticipate` is an increasing comb filter.+mortal ::+ Time -> Time -> Time -> [ControlPattern] -> ControlPattern+mortal = _mortal -Build up some tension, culminating in a _drop_ to the new pattern after 8 cycles.--}+interpolate :: Time -> [ControlPattern] -> ControlPattern+interpolate = _interpolate++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,1887 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}--module Sound.Tidal.UI where--import Prelude hiding ((<*), (*>))--import Data.Char (digitToInt, isDigit, ord)-import Data.Bits (testBit, Bits)--- import System.Random (randoms, mkStdGen)-import System.Random.MWC-import Control.Monad.ST-import Control.Monad.Primitive (PrimState, PrimMonad)-import qualified Data.Vector as V-import Data.Word (Word32)-import Data.Ratio ((%),numerator,denominator)-import Data.List (sort, sortOn, findIndices, elemIndex, groupBy, transpose, intercalate, 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-timeToSeed :: (PrimMonad m, Real a) => a -> m (Gen (PrimState m))-timeToSeed x = do- let x' = toRational (x*x) / 1000000- let n' = fromIntegral $ numerator x'- let d' = fromIntegral $ denominator x'- initialize (V.fromList [n',d'] :: V.Vector Word32)--timeToRand :: RealFrac a => a -> Double-timeToRand x = runST $ do seed <- timeToSeed x- uniform seed--timeToRands :: RealFrac a => a -> Int -> [Double]-timeToRands x n = V.toList $ runST $ do seed <- timeToSeed x- uniformVector seed n--{-|--`rand` generates a continuous pattern of (pseudo-)random numbers between `0` and `1`.--@-sound "bd*8" # pan rand-@--pans bass drums randomly--@-sound "sn sn ~ sn" # gain rand-@--makes the snares' randomly loud and quiet.--Numbers coming from this pattern are 'seeded' by time. So if you reset-time (via `cps (-1)`, then `cps 1.1` or whatever cps you want to-restart with) 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)])--{- | 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 => 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 RNG'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 :: Pattern Double -> Pattern Double-perlinWith p = 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--perlin :: Pattern Double-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-@-will generate a smooth random cutoff pattern that repeats every cycle without-any reversals or discontinuities (because the 2D path is a circle).-`perlin2` 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--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\".--}-choose :: [a] -> Pattern a-choose = chooseBy rand--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 :: [(a,Double)] -> Pattern a-wchoose = wchooseBy rand--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--{- |-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"-@---}--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--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 p = overlay (degradeBy x p) (unDegradeBy x $ f p)---- | @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---- | @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---- | @almostAlways@ is an alias for sometimesBy 0.9-almostAlways :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-almostAlways = sometimesBy 0.9--never :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-never = flip const--always :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-always = id--{- | @someCyclesBy@ is a cycle-by-cycle version of @sometimesBy@. It has a-`someCycles = someCyclesBy 0.5` alias -}-someCyclesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-someCyclesBy pd f p = do {d <- pd; _someCyclesBy d f p}--_someCyclesBy :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-_someCyclesBy x = when test- where test c = timeToRand (fromIntegral c :: Double) < x--somecyclesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-somecyclesBy = someCyclesBy--someCycles :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-someCycles = someCyclesBy 0.5--somecycles :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a-somecycles = someCycles--{- | `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----{- | (The above means that `brak` is a function from patterns of any type,-to a pattern of the same type.)--Make a pattern sound a bit like a breakbeat--Example:--@-d1 $ sound (brak "bd sn kurt")-@--}-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.-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.-palindrome :: Pattern a -> Pattern a-palindrome p = slowAppend p (rev p)---- | 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---- | 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. 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--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. It has a-shorter alias `spreadr`.--}-spreadChoose :: (t -> t1 -> Pattern b) -> [t] -> t1 -> Pattern b-spreadChoose f vs p = do v <- _segment 1 (choose vs)- f v p--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 that 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 aply `# 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.-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. 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 :: Int -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-whenmod a b = Sound.Tidal.Core.when (\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.--@-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"-@--}-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` but the truncated part of the pattern loops until the end of the cycle--@-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 = _fast (1/n) $ zoomArc (Arc 0 n) p--{- |-Use `within` to apply a function to only a part of a pattern. For example, to-apply `density 2` to only the first half of a pattern:--@-d1 $ within (0, 0.5) (density 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- ]--revArc :: (Time, Time) -> Pattern a -> Pattern a-revArc a = within a rev--{- | You can use the @e@ function to apply a Euclidean algorithm over a-complex pattern, although the structure of that pattern will be lost:--@-d1 $ e 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 `e 3 8`. It ends up picking two `bd` sounds, a-`cp` and missing the `sn` entirely.--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 in some cases.--@-- (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.-@--}-euclid :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a-euclid = tParam2 _euclid--_euclid :: Int -> Int -> Pattern a -> Pattern a-_euclid n k a = fastcat $ fmap (bool silence a) $ bjorklund (n,k)---- _euclid :: Int -> Int -> Pattern a -> Pattern a--- _euclid n k p = flip const <$> filterValues (== True) (fastFromList $ bjorklund (n,k)) <*> p--{- | `euclidfull n k pa pb` stacks @e n k pa@ with @einv n k pb@ -}-euclidFull :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a---euclidFull pn pk pa pb = innerJoin $ (\n k -> _euclidFull n k pa pb) <$> pn <*> pk-euclidFull n k pa pb = stack [ euclid n k pa, euclidInv n k pb ]--_euclidBool :: Int -> Int -> Pattern Bool-_euclidBool n k = fastFromList $ bjorklund (n,k)--{-_euclidFull :: Int -> Int -> Pattern a -> Pattern a -> Pattern a- _euclidFull n k p p' = pickbool <$> _euclidBool n k <*> p <*> p'- where pickbool True a _ = a- pickbool False _ b = b--}------ euclid' :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a--- euclid' = tParam2 _euclidq'--_euclid' :: Int -> Int -> Pattern a -> Pattern a-_euclid' n k p = fastcat $ map (\x -> if x then p else silence) (bjorklund (n,k))--euclidOff :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a-euclidOff = tParam3 _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)--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 `e`- -- @e 3 8 "x"@ -> @"x ~ ~ x ~ ~ x ~"@-- @euclidInv 3 8 "x"@ -> @"~ x x ~ x x ~ x"@--}-euclidInv :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a-euclidInv = tParam2 _euclidInv--_euclidInv :: Int -> Int -> Pattern a -> Pattern a---_euclidInv n k p = flip const <$> filterValues (== False) (fastFromList $ bjorklund (n,k)) <*> p-_euclidInv n k a = fastcat $ fmap (bool a silence) $ bjorklund (n,k)--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.--- 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.-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---- | @randcat ps@: does a @slowcat@ on the list of patterns @ps@ but--- randomises the order in which they are played.-randcat :: [Pattern a] -> Pattern a-randcat ps = spread' rotL (_segment 1 $ (%1) . fromIntegral <$> (irand (length ps) :: Pattern Int)) (slowcat ps)--wrandcat :: [(Pattern a, Double)] -> Pattern a-wrandcat ps = unwrap $ wchooseBy (segment 1 rand) ps---- @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 :: 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.-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 String -> Pattern b -> Pattern b-substruct s p = p {query = f}- where f st =- concatMap ((\a' -> queryArc (compressArcTo a' p) a') . fromJust . whole) $ filter isDigital $ (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. So--- similar to @fast@, but with random durations. The repetitions will--- be continguous (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@: 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.--for example:--@-lindenmayer 1 "a:b,b:ab" "ab" -> "bab"-@--}-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:-@-tidal> markovPat 8 1 [[3,5,2], [4,4,2], [0,1,0]]--(0>⅛)|1-(⅛>¼)|2-(¼>⅜)|1-(⅜>½)|1-(½>⅝)|2-(⅝>¾)|1-(¾>⅞)|1-(⅞>1)|0-@ -}-markovPat :: Pattern Int -> Pattern Int -> [[Double]] -> Pattern Int-markovPat = tParam2 _markovPat--_markovPat :: Int -> Int -> [[Double]] -> Pattern Int-_markovPat n xi tp = splitQueries $ Pattern (\(State a@(Arc s _) _) -> - queryArc (listToPat $ runMarkov n tp xi (sam s)) a)--{-|-Removes events from second pattern that don't start during an event from first.--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)--{--mask :: Pattern Bool -> Pattern b -> Pattern b--- TODO - should that be part or whole?-mask pa pb = pb {query = \st -> concat [filterOns (subArc (arc st) $ part i) (query pb st) | i <- query pa st]}- where filterOns Nothing _ = []- filterOns (Just a) es = filter (onsetIn a) es--}---- | TODO: refactor towards union-enclosingArc :: [Arc] -> Arc-enclosingArc [] = Arc 0 1-enclosingArc as = Arc (minimum (map start as)) (maximum (map stop as))--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--{-| @chunk n f p@ 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.--@-d1 $ chunk 4 (density 4) $ sound "cp sn arpy [mt lt]"-@--}-chunk :: Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-chunk n f p = cat [withinArc (Arc (i % fromIntegral n) ((i+1) % fromIntegral n)) f p | i <- [0 .. fromIntegral n - 1]]--{--chunk n f p = do i <- _slow (toRational n) $ run (fromIntegral n)- within (i%(fromIntegral n),(i+)1%(fromIntegral n)) f p--}---- deprecated (renamed to chunk)-runWith :: Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-runWith = chunk--{-| @chunk'@ works much the same as `chunk`, but runs from right to left.--}-chunk' :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-chunk' n f p = do i <- _slow (toRational n) $ rev $ run (fromIntegral n)- withinArc (Arc (i % fromIntegral n) ((i+)1 % fromIntegral n)) f p---- deprecated (renamed to chunk')-runWith' :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-runWith' = chunk'--inside :: Pattern Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a-inside n f p = density n $ f (slow n p)--outside :: Pattern Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a-outside n = inside (1/n)--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 :: [(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"`. It assumes your scale fits within an octave;-to change this use `toScale' size`. 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)--toScale :: Num a => [a] -> Pattern Int -> Pattern a-toScale = toScale' 12--{- | `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 . @swing@ is an alias-for `swingBy (1%3)`--}-swingBy :: Pattern Time -> Pattern Time -> Pattern a -> Pattern a-swingBy x n = inside n (withinArc (Arc 0.5 1) (x ~>))--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 -}-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.--}-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.--}-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 :: 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'- 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--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--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 Events-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 Pattern of lists and pulls the list elements as--- separate Events-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--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---{- 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--}---- Repeats each event @n@ times within its arc-ply :: Pattern Int -> Pattern a -> Pattern a-ply = tParam _ply--_ply :: Int -> Pattern a -> Pattern a-_ply n p = arpeggiate $ stack (replicate n p)---- Like 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)---- | 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@.-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. See also @sew@.-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 :: Integral i => i -> Time -> Pattern a -> Pattern a-stutter n t p = stack $ map (\i -> (t * fromIntegral i) `rotR` p) [0 .. (n-1)]--echo, triple, quad, double :: Time -> Pattern a -> Pattern a-echo = stutter (2 :: Int)-triple = stutter (3 :: Int)-quad = stutter (4 :: Int)-double = echo--{- | 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](#jux) and [every](#every),-it's possible to chain multiple transforms together with `.`, 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 ControlMap -> Pattern ControlMap)- -> Pattern ControlMap -> Pattern ControlMap-jux = juxBy 1-juxcut- :: (Pattern ControlMap -> Pattern ControlMap)- -> Pattern ControlMap -> Pattern ControlMap-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 ControlMap] -> t -> Pattern ControlMap-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 transform. resulting patterns from each transformation will be spread via pan from left to right.--For example:--@-d1 $ jux' [iter 4, chop 16, id, rev, palindrome] $ sound "bd sn"-@--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 mid left mid right the chopped and the reversed version will appear.--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 ControlMap] -> t -> Pattern ControlMap-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 ControlMap -> Pattern ControlMap)- -> Pattern ControlMap -> Pattern ControlMap-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 (density 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 ControlMap -> Pattern ControlMap)- -> Pattern ControlMap- -> Pattern ControlMap-juxBy n f p = stack [p |+ P.pan 0.5 |- P.pan (n/2), f $ p |+ P.pan 0.5 |+ P.pan (n/2)]--pick :: String -> Int -> String-pick name n = name ++ ":" ++ show n---- samples "jvbass [~ latibro] [jvbass [latibro jvbass]]" ((1%2) `rotL` slow 6 "[1 6 8 7 3]")--samples :: Applicative f => f String -> f Int -> f String-samples p p' = pick <$> p <*> p'--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)--}--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)-@--}--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. Do *not* use negative numbers or zero as arguments! -}-rangex :: (Functor f, Floating b) => b -> b -> f b -> f b-rangex from to p = exp <$> _range (log from) (log to) p--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 sequencing-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 :: [(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...-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---ghost'' :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-ghost'' a f p = superimpose (((a*2.5) `rotR`) . f) $ superimpose (((a*1.5) `rotR`) . f) p--ghost' :: Time -> Pattern ControlMap -> Pattern ControlMap-ghost' a p = ghost'' a ((|*| P.gain (pure 0.7)) . (|> P.end (pure 0.2)) . (|*| P.speed (pure 1.25))) p--ghost :: Pattern ControlMap -> Pattern ControlMap-ghost = ghost' 0.125--{- |- tabby - A more literal weaving than the `weave` function, give number- of 'threads' per cycle and two patterns, 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 between a list of patterns, using a pattern of floats (from 0-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 between a list of functions, using a pattern of floats (from 0-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 between 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 p f f' p'@ splits controlpattern @p'@ in two, applying--- the function @f@ to one and @f'@ to the other. This depends on--- whether events in it contains values matching with those in @p@.--- For example in @contrast (n "1") (# crush 3) (# vowel "a") $ 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 :: (ControlPattern -> ControlPattern) -> (ControlPattern -> ControlPattern)- -> ControlPattern -> ControlPattern -> ControlPattern-contrast = contrastBy (==)--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 (VS s, VS e) (VS v) = v == s && v == e- f _ _ = False---- | Like @contrast@, but one function is given, and applied to events with matching controls.-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 :: (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern-unfix = contrast id--fixRange :: (ControlPattern -> Pattern ControlMap)- -> Pattern (Map.Map String (Value, Value))- -> ControlPattern- -> Pattern ControlMap-fixRange f = contrastRange f id--unfixRange :: (ControlPattern -> Pattern ControlMap)- -> Pattern (Map.Map String (Value, Value))- -> ControlPattern- -> Pattern ControlMap-unfixRange = contrastRange id---- | limit values in a Pattern (or other Functor) to n equally spaced--- divisions of 1.-quantise :: (Functor f, RealFrac b) => b -> f b -> f b-quantise n = fmap ((/n) . (fromIntegral :: RealFrac b => Int -> b) . floor . (*n))---- | 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}---- 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 |- 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 effected- d1 $ note (scale "hexDorian" $ snowball (+) (slow 2 . rev) 8 "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 $ iterate f pattern--{- @soak@ | - 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--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"`.--}--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--{- @squeeze@ ipat pats | uses a pattern of integers to index into a list of patterns.--}-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--__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--binary :: Pattern Int -> Pattern Bool-binary = binaryN 8--ascii :: Pattern String -> Pattern Bool-ascii p = squeezeJoin $ (listToPat . concatMap (__binary 8 . ord)) <$> p
− src/Sound/Tidal/Utils.hs
@@ -1,97 +0,0 @@-module Sound.Tidal.Utils where--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---- A hack to add to the source code context for mini-notation, so--- events know where they are within a whole tidal pattern-deltaMini :: String -> String-deltaMini = outside 0 0- where outside :: Int -> Int -> String -> String- outside _ _ [] = []- outside column line ('"':xs) = ("(deltaContext "- ++ show column- ++ " "- ++ show line- ++ " \""- ++ inside (column+1) line xs- )- outside _ line ('\n':xs) = '\n':(outside 0 (line+1) xs)- outside column line (x:xs) = x:(outside (column+1) line xs)- inside :: Int -> Int -> String -> String- inside _ _ [] = []- inside column line ('"':xs) = '"':')':(outside (column+1) line xs)- inside _ line ('\n':xs) = '\n':(inside 0 (line+1) xs)- inside column line (x:xs) = x:(inside (column+1) line xs)
src/Sound/Tidal/Version.hs view
@@ -1,4 +1,32 @@ module Sound.Tidal.Version where +import Paths_tidal++{-+ Version.hs - For giving the current tidal version.+ 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/>.+-}+ tidal_version :: String-tidal_version = "1.4.9"+tidal_version = "1.10.1"++tidal_status :: IO ()+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
− test/Sound/Tidal/ControlTest.hs
@@ -1,23 +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 "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")-
− test/Sound/Tidal/CoreTest.hs
@@ -1,141 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Sound.Tidal.CoreTest where--import TestUtils-import Test.Microspec--import Prelude hiding ((<*), (*>))--import Data.Ratio-import Data.List (sort)--import Sound.Tidal.Context--run :: Microspec ()-run =- describe "Sound.Tidal.Core" $ do- describe "append" $ do- 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")- ]-- 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 "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" $ do- (map value $ queryArc ((+1) <$> saw) (Arc 0.5 0.5)) `shouldBe` [1.5 :: Float]- it "works on the left of <*>" $ do- (queryArc ((+) <$> saw <*> pure 3) (Arc 0 1))- `shouldBe` [Event (Context []) Nothing (Arc 0 1) 3.5 :: Event Double]- it "works on the right of <*>" $ do- (queryArc ((fast 4 $ pure (+3)) <*> saw) (Arc 0 1))- `shouldBe` - [Event (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" $ do- 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" $ do- 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" $ do- 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/ParseTest.hs
@@ -1,126 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Sound.Tidal.ParseTest where--import TestUtils-import Test.Microspec--import Prelude hiding ((<*), (*>))--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 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 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 handle repeats (!) and durations (@) with <>" $ do- compareP (Arc 0 31)- ("<a!3 b ! c@5>" :: Pattern String)- (slow 10 "[a a a b b] c")- it "can handle repeats (!) and durations (@) with <> (with ints)" $ do- compareP (Arc 0 31)- ("<1!3 2 ! 3@5>" :: Pattern Int)- (slow 10 "[1 1 1 2 2] 3")- it "can handle fractional durations" $ do- compareP (Arc 0 2)- ("a@0.5 b@1%6 b@1%6 b@1%6" :: Pattern String)- ("a b*3")- it "can handle fractional durations (with rationals)" $ do- compareP (Arc 0 2)- ("1%3@0.5 3%4@1%6 3%4@1%6 3%4@1%6" :: Pattern Rational)- ("1%3 0.75*3")- it "can parse a chord" $ do- compareP (Arc 0 2)- ("'major" :: Pattern Int)- ("[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 "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)- where degradeByDefault = _degradeBy 0.5
− test/Sound/Tidal/PatternTest.hs
@@ -1,556 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Sound.Tidal.PatternTest where--import Test.Microspec-import TestUtils--import Prelude hiding ((*>), (<*))--import Data.Ratio--import Sound.Tidal.Control-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")- ]-- 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" (pure $ 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 "compareDefrag" $ do - it "compare list with Events with empty list of Events" $ do- let res = compareDefrag [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int), Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (5 :: Int)] []- property $ False === res - it "compare lists containing same Events but of different length" $ do - let res = compareDefrag [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int), Event (Context []) (Just $ Arc 1 2) (Arc 4 3) 5] [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)]- property $ True === res- it "compare lists of same length with same Events" $ do - let res = compareDefrag [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)]- property $ True === res -- describe "sect" $ do - 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 Nothing 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
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}++module Sound.Tidal.StreamTest where++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 :: 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)]+ it "should return same string if no params are specified" $ do+ substitutePath "/s_new" state `shouldBe` Just "/s_new"+ it "should substitute values for params if present" $ do+ 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+ it "should work for strings" $ do+ getString (M.singleton "s" (VS "sn")) "s" `shouldBe` Just "sn"+ it "should work for params with fallback expressions" $ do+ getString (M.singleton "s" (VS "sn")) "s=bd" `shouldBe` Just "sn"+ it "should work for missing params with fallback expressions" $ do+ getString M.empty "s=bd" `shouldBe` Just "bd"
− test/Sound/Tidal/UITest.hs
@@ -1,279 +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 "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 "does nothing when set at 0% probability -- 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-- 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 "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.5000844 :: 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.8587171 :: 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.7277789 :: Float)]-- describe "range" $ do- describe "scales a pattern to the supplied range" $ do- describe "from 3 to 4" $ do- it "at the start of a cycle" $- (queryArc (Sound.Tidal.UI.range 3 4 saw) (Arc 0 0)) `shouldBe` - [Event (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 "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" $ (VF 0, VF 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)])-- 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)-- 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)
− 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,21 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Microspec--import Sound.Tidal.CoreTest-import Sound.Tidal.ParseTest-import Sound.Tidal.PatternTest-import Sound.Tidal.ControlTest-import Sound.Tidal.ScalesTest-import Sound.Tidal.UITest-import Sound.Tidal.UtilsTest+import Sound.Tidal.StreamTest+import Test.Hspec main :: IO ()-main = microspec $ do- Sound.Tidal.CoreTest.run- Sound.Tidal.ParseTest.run- Sound.Tidal.PatternTest.run- Sound.Tidal.ControlTest.run- Sound.Tidal.ScalesTest.run- Sound.Tidal.UITest.run- Sound.Tidal.UtilsTest.run+main = hspec $ do+ Sound.Tidal.StreamTest.run
test/TestUtils.hs view
@@ -1,30 +1,71 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-} module TestUtils where -import Test.Microspec+import Data.List (sort)+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 ((*>), (<*)) -import Prelude hiding ((<*), (*>))+class TolerantEq a where+ (~==) :: a -> a -> Bool -import Data.List (sort)+instance TolerantEq Double where+ (~==) :: Double -> Double -> Bool+ a ~== b = abs (a - b) < 0.000001 -import Sound.Tidal.Context+instance TolerantEq Value where+ (~==) :: 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 -import qualified Data.Map.Strict as Map+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 a p p' = (sort $ query (stripContext p) $ State a Map.empty) `shouldBe` (sort $ query (stripContext p') $ State a Map.empty)+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) -- | Like @compareP@, but tries to 'defragment' the events-comparePD :: (Ord a) => Arc -> Pattern a -> Pattern a -> Bool-comparePD a p p' = compareDefrag es es'- where es = query (stripContext p) (State a Map.empty)- es' = query (stripContext p') (State a Map.empty)+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) -- | 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@@ -32,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
@@ -0,0 +1,47 @@+-- \| 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)+ let p = streamReplace tidal+ d1 = p 1 . (|< orbit 0)++ -- This will execute patterns-that-crash-tidal one after another,+ -- 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+ simple = s "[bd*4, 808cy*8]"+ putStrLn $ "--- playing test pattern " ++ show k ++ " -----"+ d1 $ p+ wait 2+ putStrLn $ "---------------- playing simple pattern"+ d1 $ simple+ wait 2++ go+ [ "cr",+ -- https://codeberg.org/uzu/tidal/issues/606#issue-563234396+ gain (unwrap $ fmap (["1", "0."] !!) $ "{0 0@7 0 1@7}%16") # s "harmor" # midichan 11,+ + -- The following test is disabled, as it's no longer triggered at 'pattern time', ref https://codeberg.org/uzu/tidal/issues/1221#issuecomment-5791100+ -- https://codeberg.org/uzu/tidal/issues/606#issuecomment-598776256+ -- superimpose (hurry "<0.5 2?") $ sound "bd",++ -- https://codeberg.org/uzu/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,24 +1,23 @@+cabal-version: 2.0+ name: tidal-version: 1.4.9+version: 1.10.3 synopsis: Pattern language for improvised music--- description:+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) Tidal contributors, 2019+Copyright: (c) Alex McLean and other contributors, 2025 category: Sound build-type: Simple-cabal-version: >=1.10-tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3+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 -Description: Tidal is a domain specific language for live coding pattern.- library ghc-options: -Wall hs-source-dirs:@@ -26,50 +25,43 @@ default-language: Haskell2010 - Exposed-modules: Sound.Tidal.Bjorklund- Sound.Tidal.Carabiner- Sound.Tidal.Chords+ autogen-modules: Paths_tidal++ Exposed-modules: + Sound.Tidal.Boot Sound.Tidal.Config- Sound.Tidal.Control Sound.Tidal.Context- Sound.Tidal.Core- Sound.Tidal.Params- Sound.Tidal.ParseBP- Sound.Tidal.Pattern- Sound.Tidal.Scales- Sound.Tidal.Show- Sound.Tidal.Simple+ Sound.Tidal.ID+ Sound.Tidal.Safe.Context+ Sound.Tidal.Safe.Boot Sound.Tidal.Stream- Sound.Tidal.Tempo+ 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- Sound.Tidal.EspGrid- -- Sound.Tidal.Light- -- Sound.Tidal.TH+ Paths_tidal Build-depends: base >=4.8 && <5- , containers < 0.7+ , containers < 0.9 , colour < 2.4- , hosc >= 0.17 && < 0.18- , text < 1.3+ , hosc >= 0.21 && < 0.22+ , text < 2.2 , parsec >= 3.1.12 && < 3.2- , network < 3.2- , mwc-random < 0.15- , vector < 0.13- , bifunctors < 5.6- , transformers >= 0.5 && < 0.5.7- , bytestring < 0.11+ , network < 3.3+ , transformers >= 0.5 && < 0.7+ , bytestring < 0.13 , clock < 0.9- , deepseq >= 1.1.0.0- , primitive < 0.8- , random < 1.2- -- , serialport- -- , hashable-- if !impl(ghc >= 8.4.1)- build-depends: semigroups >= 0.18 && < 0.20+ , deepseq >=1.1.0.0 && < 1.7+ , primitive < 0.10+ , random < 1.4+ , exceptions < 0.11+ , mtl >= 2.2 && < 2.4+ , tidal-link >= 1.2 && < 1.3+ , tidal-core == 1.10.2 test-suite tests type: exitcode-stdio-1.0@@ -77,53 +69,66 @@ hs-source-dirs: test ghc-options: -Wall- other-modules: Sound.Tidal.ControlTest- Sound.Tidal.CoreTest- Sound.Tidal.ParseTest- Sound.Tidal.PatternTest- Sound.Tidal.ScalesTest- Sound.Tidal.UITest- Sound.Tidal.UtilsTest+ other-modules:+ Sound.Tidal.StreamTest TestUtils build-depends:- base ==4.*- , microspec >= 0.2.0.1- , containers- , parsec- , tidal+ base >=4 && <5,+ hspec >=2.11.9,+ hosc >=0.21 && <0.22,+ containers,+ parsec,+ tidal,+ tidal-core,+ deepseq default-language: Haskell2010 +-- not useful for automation since it requires running sclang+test-suite dontcrash+ type: exitcode-stdio-1.0+ main-is: dontcrash.hs+ hs-source-dirs: test+ build-depends: base,+ tidal,+ tidal-core++ default-language: Haskell2010+ benchmark bench-speed type: exitcode-stdio-1.0- main-is: Main.hs + main-is: Main.hs hs-source-dirs: bench/Speed other-modules: Tidal.PatternB Tidal.CoreB Tidal.UIB Tidal.Inputs- build-depends: - base == 4.*- , criterion- , tidal- ghc-options: -Wall -O2+ build-depends:+ base >=4 && <5,+ criterion >=1.6.3.0,+ tidal,+ tidal-core + ghc-options: -Wall+ default-language: Haskell2010 benchmark bench-memory type: exitcode-stdio-1.0- main-is: Main.hs - hs-source-dirs: bench/Memory + main-is: Main.hs+ hs-source-dirs: bench/Memory other-modules: Tidal.UIB- Tidal.Inputs + Tidal.Inputs build-depends:- base == 4.*- , weigh- , tidal- ghc-options: -Wall -O2+ base >=4 && <5,+ weigh,+ tidal,+ tidal-core + ghc-options: -Wall+ default-language: Haskell2010 source-repository head type: git- location: https://github.com/tidalcycles/Tidal+ location: https://codeberg.org/uzu/tidal
tidal.el view
@@ -1,13 +1,13 @@ ;;; tidal.el --- Interact with TidalCycles for live coding patterns -*- lexical-binding: t; -*- -;; Copyright (C) 2012 alex@slab.org+;; Copyright (C) 2025 alex@slab.org ;; Copyright (C) 2006-2008 rohan drape (hsc3.el) ;; Author: alex@slab.org-;; Homepage: https://github.com/tidalcycles/Tidal-;; Version: 0+;; Homepage: https://codeberg.org/uzu/tidal+;; Version: 0.0.1 ;; Keywords: tools-;; Package-Requires: ((haskell-mode "16") (emacs "24"))+;; Package-Requires: ((haskell-mode "16") (emacs "25.1")) ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by@@ -33,7 +33,6 @@ ;;; Code: - (require 'scheme) (require 'comint) (require 'thingatpt)@@ -63,22 +62,16 @@ (cond ((string-equal system-type "windows-nt") '(("path" . "echo off && for /f %a in ('ghc-pkg latest tidal') do (for /f \"tokens=2\" %i in ('ghc-pkg describe %a ^| findstr data-dir') do (echo %i))")- ("separator" . "\\")- ))+ ("separator" . "\\"))) ((or (string-equal system-type "darwin") (string-equal system-type "gnu/linux"))- '(("path" . "ghc-pkg field -f ~/.cabal/store/ghc-$(ghc --numeric-version)/package.db tidal data-dir")- ("separator" . "/")- ))- )- ))+ '(("path" . "echo -n data-dir: && ghc -e 'import Paths_tidal' -e 'getDataDir>>=putStr' 2>/dev/null")+ ("separator" . "/") ))))) (concat (string-trim (cadr (split-string (shell-command-to-string (cdr (assoc "path" filepath))) ":"))) (cdr (assoc "separator" filepath))- "BootTidal.hs")- )- "*Full path to BootTidal.hs (inferred by introspecting ghc-pkg package db)."-)+ "BootTidal.hs"))+ "*Full path to BootTidal.hs (inferred by introspecting ghc-pkg package db).") (defvar tidal-literate-p t@@ -90,7 +83,7 @@ (make-variable-buffer-local 'tidal-literate-p) (defun tidal-unlit (s)- "Remove bird literate marks in S."+ "Remove bird literate markup in S." (replace-regexp-in-string "^> " "" s)) (defun tidal-intersperse (e l)@@ -98,32 +91,40 @@ (when l (cons e (cons (car l) (tidal-intersperse e (cdr l)))))) +;;;###autoload (defun tidal-start-haskell () "Start haskell." (interactive)- (if (comint-check-proc tidal-buffer)- (error "A tidal process is already running")- (apply- 'make-comint- "tidal"- tidal-interpreter- nil- tidal-interpreter-arguments)- (tidal-see-output))- (tidal-send-string (concat ":script " tidal-boot-script-path))-)+ (save-window-excursion+ (if (comint-check-proc tidal-buffer)+ (when (yes-or-no-p+ "A tidal process is already running. Do you want to restart it? ")+ (tidal-restart-haskell))+ (apply+ 'make-comint-in-buffer+ "tidal"+ tidal-buffer+ tidal-interpreter+ nil+ tidal-interpreter-arguments)+ (tidal-see-output)+ (tidal-send-string (concat ":script " tidal-boot-script-path))))+ (switch-to-buffer-other-window tidal-buffer)) +;;;###autoload+(defalias 'run-tidal #'tidal-start-haskell+ "Start tidal in the haskell interpreter.")+ (defun tidal-see-output () "Show haskell output." (interactive) (when (comint-check-proc tidal-buffer) (delete-other-windows)- (split-window-vertically) (with-current-buffer tidal-buffer (let ((window (display-buffer (current-buffer))))- (goto-char (point-max))- (save-selected-window- (set-window-point window (point-max)))))))+ (goto-char (point-max))+ (save-selected-window+ (set-window-point window (point-max))))))) (defun tidal-quit-haskell () "Quit haskell."@@ -131,6 +132,13 @@ (kill-buffer tidal-buffer) (delete-other-windows)) +(defun tidal-restart-haskell ()+ "Restart haskell."+ (interactive)+ (let ((kill-buffer-query-functions nil))+ (tidal-quit-haskell))+ (tidal-start-haskell))+ (defun tidal-chunk-string (n s) "Split a string S into chunks of N characters." (let* ((l (length s))@@ -141,49 +149,47 @@ (cons c (tidal-chunk-string n (substring s n)))))) (defun tidal-send-string (s)+ "Send string S to tidal." (if (comint-check-proc tidal-buffer) (let ((cs (tidal-chunk-string 64 (concat s "\n")))) (mapcar (lambda (c) (comint-send-string tidal-buffer c)) cs))- (error "no tidal process running?")))+ (error "No tidal process running?"))) (defun tidal-transform-and-store (f s)- "Transform example text into compilable form."+ "Transform text into compilable form (Using file F and string S)." (with-temp-file f (mapc (lambda (module)- (insert (concat module "\n")))- tidal-modules)+ (insert (concat module "\n")))+ tidal-modules) (insert "main = do\n") (insert (if tidal-literate-p (tidal-unlit s) s)))) (defun tidal-get-now ()- "Store the current cycle position in a variable called 'now'."+ "Store the current cycle position in a tidal variable called `now'." (interactive) (tidal-send-string "now' <- getNow") (tidal-send-string "let now = nextSam now'") (tidal-send-string "let retrig = (now `rotR`)") (tidal-send-string "let fadeOut n = spread' (_degradeBy) (retrig $ slow n $ envL)")- (tidal-send-string "let fadeIn n = spread' (_degradeBy) (retrig $ slow n $ (1-) <$> envL)")-- )+ (tidal-send-string "let fadeIn n = spread' (_degradeBy) (retrig $ slow n $ (1-) <$> envL)")) (defun tidal-run-line () "Send the current line to the interpreter." (interactive)- ;(tidal-get-now)+ ;;(tidal-get-now) (let* ((s (buffer-substring (line-beginning-position)- (line-end-position)))- (s* (if tidal-literate-p- (tidal-unlit s)- s)))+ (line-end-position)))+ (s* (if tidal-literate-p+ (tidal-unlit s)+ s))) (tidal-send-string s*)) (pulse-momentary-highlight-one-line (point))- (forward-line)- )+ (forward-line)) (defun tidal-eval-multiple-lines () "Eval the current region in the interpreter as a single line."- ;(tidal-get-now)+ ;;(tidal-get-now) (mark-paragraph) (let* ((s (buffer-substring-no-properties (region-beginning) (region-end)))@@ -194,158 +200,49 @@ (tidal-send-string s*) (tidal-send-string ":}") (mark-paragraph)- (pulse-momentary-highlight-region (mark) (point))- )- )+ (pulse-momentary-highlight-region (mark) (point)))) (defun tidal-run-multiple-lines () "Send the current region to the interpreter as a single line." (interactive) (if (>= emacs-major-version 25) (save-mark-and-excursion- (tidal-eval-multiple-lines))+ (tidal-eval-multiple-lines)) (save-excursion- (tidal-eval-multiple-lines))- )- )--(defun tidal-run-d1 ()- "Send the first instance of d1 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d1" nil nil 1)- (tidal-run-multiple-lines)- )--(defun tidal-run-d2 ()- "Send the d2 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d2" nil nil 1)- (tidal-run-multiple-lines)- )--(defun tidal-run-d3 ()- "Send the d3 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d3" nil nil 1)- (tidal-run-multiple-lines)- )--(defun tidal-run-d4 ()- "Send the d4 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d4" nil nil 1)- (tidal-run-multiple-lines)- )-(defun tidal-run-d5 ()- "Send the d5 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d5" nil nil 1)- (tidal-run-multiple-lines)- )-(defun tidal-run-d6 ()- "Send the d6 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d6" nil nil 1)- (tidal-run-multiple-lines)- )-(defun tidal-run-d7 ()- "Send the d7 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d7" nil nil 1)- (tidal-run-multiple-lines)- )-(defun tidal-run-d8 ()- "Send the d9 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d8" nil nil 1)- (tidal-run-multiple-lines)- )-(defun tidal-run-d9 ()- "Send the d9 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d9" nil nil 1)- (tidal-run-multiple-lines)- )---(defun tidal-stop-d1 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d1]")- (tidal-send-string ":}")- )--(defun tidal-stop-d2 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d2]")- (tidal-send-string ":}")- )-(defun tidal-stop-d3 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d3]")- (tidal-send-string ":}")- )+ (tidal-eval-multiple-lines)))) +(defmacro tidal-create-runner-run (name)+ "Macro to generate `d1' style pattern runners with NAME."+ (let ((run-fname (intern (concat "tidal-run-" name))))+ `(defun ,run-fname ()+ ,(format "Send the %s interpreter as a single line." name)+ (interactive)+ (goto-char 0)+ (search-forward ,name nil nil 1)+ (tidal-run-multiple-lines)))) -(defun tidal-stop-d4 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d4]")- (tidal-send-string ":}")- )+(defmacro tidal-create-runner-stop (name)+ "Macro to generate `d1' style pattern runners with NAME."+ (let ((stop-fname (intern (concat "tidal-stop-" name))))+ `(defun ,stop-fname ()+ ,(format "Send %s $ silence as a single line." name)+ (interactive)+ (tidal-send-string ":{")+ (tidal-send-string (concat " mapM_ ($ silence) [" ,name "]"))+ (tidal-send-string ":}")))) -(defun tidal-stop-d5 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d5]")- (tidal-send-string ":}")- )-(defun tidal-stop-d6 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d6]")- (tidal-send-string ":}")- )+(defun tidal-create-runner (name)+ "Generate `d1' style pattern runners with NAME.+Two functions will be created, `tidal-run-NAME' and `tidal-stop-NAME'"+ (eval `(tidal-create-runner-run ,name))+ (eval `(tidal-create-runner-stop ,name))) -(defun tidal-stop-d7 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d7]")- (tidal-send-string ":}")- )+;; Generate the functions `tidal-run-d1' and `tidal-stop-d1'+(tidal-create-runner "d1") -(defun tidal-stop-d8 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d8]")- (tidal-send-string ":}")- )-(defun tidal-stop-d9 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d9]")- (tidal-send-string ":}")- )+;; 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" "d10")) (defun tidal-run-region () "Place the region in a do block and compile."@@ -367,104 +264,116 @@ (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) (if (comint-check-proc tidal-buffer) (with-current-buffer tidal-buffer- (interrupt-process (get-buffer-process (current-buffer))))- (error "no tidal process running?")))+ (interrupt-process (get-buffer-process (current-buffer))))+ (error "No tidal process running?"))) (defvar tidal-mode-map nil "Tidal keymap.") (defun tidal-mode-keybindings (map)- "Haskell Tidal keybindings."- (define-key map [?\C-c ?\C-s] 'tidal-start-haskell)- (define-key map [?\C-c ?\C-v] 'tidal-see-output)- (define-key map [?\C-c ?\C-q] 'tidal-quit-haskell)- (define-key map [?\C-c ?\C-c] 'tidal-run-line)- (define-key map [?\C-c ?\C-e] 'tidal-run-multiple-lines)- (define-key map (kbd "<C-return>") 'tidal-run-multiple-lines)- (define-key map [?\C-c ?\C-r] 'tidal-run-region)- (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-1] 'tidal-run-d1)- (define-key map [?\C-c ?\C-2] 'tidal-run-d2)- (define-key map [?\C-c ?\C-3] 'tidal-run-d3)- (define-key map [?\C-c ?\C-4] 'tidal-run-d4)- (define-key map [?\C-c ?\C-5] 'tidal-run-d5)- (define-key map [?\C-c ?\C-6] 'tidal-run-d6)- (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-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)- (define-key map [?\C-v ?\C-4] 'tidal-stop-d4)- (define-key map [?\C-v ?\C-5] 'tidal-stop-d5)- (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))+ "Haskell Tidal keybindings MAP."+ (keymap-set map "C-c C-s" #'tidal-start-haskell)+ (keymap-set map "C-c C-v" #'tidal-see-output)+ (keymap-set map "C-c C-q" #'tidal-quit-haskell)+ (keymap-set map "C-c C-c" #'tidal-run-line)+ (keymap-set map "C-c C-e" #'tidal-run-multiple-lines)+ (keymap-set map "C-<return>" #'tidal-run-multiple-lines)+ (keymap-set map "C-c C-r" #'tidal-run-region)+ (keymap-set map "C-c C-l" #'tidal-load-buffer)+ (keymap-set map "C-c C-i" #'tidal-interrupt-haskell)+ (keymap-set map "C-c C-m" #'tidal-run-main)+ (keymap-set map "C-c C-h" #'tidal-hush)+ (keymap-set map "C-c C-1" #'tidal-run-d1)+ (keymap-set map "C-c C-2" #'tidal-run-d2)+ (keymap-set map "C-c C-3" #'tidal-run-d3)+ (keymap-set map "C-c C-4" #'tidal-run-d4)+ (keymap-set map "C-c C-5" #'tidal-run-d5)+ (keymap-set map "C-c C-6" #'tidal-run-d6)+ (keymap-set map "C-c C-7" #'tidal-run-d7)+ (keymap-set map "C-c C-8" #'tidal-run-d8)+ (keymap-set map "C-c C-9" #'tidal-run-d9)+ (keymap-set map "C-c C-0" #'tidal-run-d10)+ (keymap-set map "C-v C-1" #'tidal-stop-d1)+ (keymap-set map "C-v C-2" #'tidal-stop-d2)+ (keymap-set map "C-v C-3" #'tidal-stop-d3)+ (keymap-set map "C-v C-4" #'tidal-stop-d4)+ (keymap-set map "C-v C-5" #'tidal-stop-d5)+ (keymap-set map "C-v C-6" #'tidal-stop-d6)+ (keymap-set map "C-v C-7" #'tidal-stop-d7)+ (keymap-set map "C-v C-8" #'tidal-stop-d8)+ (keymap-set map "C-v C-9" #'tidal-stop-d9)+ (keymap-set map "C-c C-0" #'tidal-stop-d10)) -(defun turn-on-tidal-keybindings ()+(defun tidal-turn-on-keybindings () "Haskell Tidal keybindings in the local map."- (local-set-key [?\C-c ?\C-s] 'tidal-start-haskell)- (local-set-key [?\C-c ?\C-v] 'tidal-see-output)- (local-set-key [?\C-c ?\C-q] 'tidal-quit-haskell)- (local-set-key [?\C-c ?\C-c] 'tidal-run-line)- (local-set-key [?\C-c ?\C-e] 'tidal-run-multiple-lines)- (local-set-key (kbd "<C-return>") 'tidal-run-multiple-lines)- (local-set-key [?\C-c ?\C-r] 'tidal-run-region)- (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-1] 'tidal-run-d1)- (local-set-key [?\C-c ?\C-2] 'tidal-run-d2)- (local-set-key [?\C-c ?\C-3] 'tidal-run-d3)- (local-set-key [?\C-c ?\C-4] 'tidal-run-d4)- (local-set-key [?\C-c ?\C-5] 'tidal-run-d5)- (local-set-key [?\C-c ?\C-6] 'tidal-run-d6)- (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-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)- (local-set-key [?\C-v ?\C-4] 'tidal-stop-d4)- (local-set-key [?\C-v ?\C-5] 'tidal-stop-d5)- (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))+ (keymap-local-set "C-c C-s" #'tidal-start-haskell)+ (keymap-local-set "C-c C-v" #'tidal-see-output)+ (keymap-local-set "C-c C-q" #'tidal-quit-haskell)+ (keymap-local-set "C-c C-c" #'tidal-run-line)+ (keymap-local-set "C-c C-e" #'tidal-run-multiple-lines)+ (keymap-local-set "C-<return>" #'tidal-run-multiple-lines)+ (keymap-local-set "C-c C-r" #'tidal-run-region)+ (keymap-local-set "C-c C-l" #'tidal-load-buffer)+ (keymap-local-set "C-c C-i" #'tidal-interrupt-haskell)+ (keymap-local-set "C-c C-m" #'tidal-run-main)+ (keymap-local-set "C-c C-h" #'tidal-hush)+ (keymap-local-set "C-c C-1" #'tidal-run-d1)+ (keymap-local-set "C-c C-2" #'tidal-run-d2)+ (keymap-local-set "C-c C-3" #'tidal-run-d3)+ (keymap-local-set "C-c C-4" #'tidal-run-d4)+ (keymap-local-set "C-c C-5" #'tidal-run-d5)+ (keymap-local-set "C-c C-6" #'tidal-run-d6)+ (keymap-local-set "C-c C-7" #'tidal-run-d7)+ (keymap-local-set "C-c C-8" #'tidal-run-d8)+ (keymap-local-set "C-c C-9" #'tidal-run-d9)+ (keymap-local-set "C-c C-0" #'tidal-run-d10)+ (keymap-local-set "C-v C-1" #'tidal-stop-d1)+ (keymap-local-set "C-v C-2" #'tidal-stop-d2)+ (keymap-local-set "C-v C-3" #'tidal-stop-d3)+ (keymap-local-set "C-v C-4" #'tidal-stop-d4)+ (keymap-local-set "C-v C-5" #'tidal-stop-d5)+ (keymap-local-set "C-v C-6" #'tidal-stop-d6)+ (keymap-local-set "C-v C-7" #'tidal-stop-d7)+ (keymap-local-set "C-v C-8" #'tidal-stop-d8)+ (keymap-local-set "C-v C-9" #'tidal-stop-d9)+ (keymap-local-set "C-v C-0" #'tidal-stop-d10)) (defun tidal-mode-menu (map)- "Haskell Tidal menu."+ "Haskell Tidal menu MAP." (define-key map [menu-bar tidal]- (cons "Haskell-Tidal" (make-sparse-keymap "Haskell-Tidal")))+ (cons "Haskell-Tidal" (make-sparse-keymap "Haskell-Tidal"))) (define-key map [menu-bar tidal help]- (cons "Help" (make-sparse-keymap "Help")))+ (cons "Help" (make-sparse-keymap "Help"))) (define-key map [menu-bar tidal expression]- (cons "Expression" (make-sparse-keymap "Expression")))+ (cons "Expression" (make-sparse-keymap "Expression"))) (define-key map [menu-bar tidal expression load-buffer]- '("Load buffer" . tidal-load-buffer))+ '("Load buffer" . tidal-load-buffer)) (define-key map [menu-bar tidal expression run-main]- '("Run main" . tidal-run-main))+ '("Run main" . tidal-run-main)) (define-key map [menu-bar tidal expression run-region]- '("Run region" . tidal-run-region))+ '("Run region" . tidal-run-region)) (define-key map [menu-bar tidal expression run-multiple-lines]- '("Run multiple lines" . tidal-run-multiple-lines))+ '("Run multiple lines" . tidal-run-multiple-lines)) (define-key map [menu-bar tidal expression run-line]- '("Run line" . tidal-run-line))+ '("Run line" . tidal-run-line)) (define-key map [menu-bar tidal haskell]- (cons "Haskell" (make-sparse-keymap "Haskell")))+ (cons "Haskell" (make-sparse-keymap "Haskell"))) (define-key map [menu-bar tidal haskell quit-haskell]- '("Quit haskell" . tidal-quit-haskell))+ '("Quit haskell" . tidal-quit-haskell)) (define-key map [menu-bar tidal haskell see-output]- '("See output" . tidal-see-output))+ '("See output" . tidal-see-output)) (define-key map [menu-bar tidal haskell start-haskell]- '("Start haskell" . tidal-start-haskell)))+ '("Start haskell" . tidal-start-haskell))) (unless tidal-mode-map (let ((map (make-sparse-keymap "Haskell-Tidal")))@@ -485,9 +394,7 @@ (turn-on-font-lock)) ;;;###autoload-(add-to-list 'auto-mode-alist '("\\.ltidal$" . literate-tidal-mode))-;;(add-to-list 'load-path "/usr/share/emacs/site-lisp/haskell-mode/") ;required by olig1905 on linux-;;(require 'haskell-mode) ;required by olig1905 on linux+(add-to-list 'auto-mode-alist '("\\.ltidal\\'" . literate-tidal-mode)) ;;;###autoload (define-derived-mode@@ -495,13 +402,14 @@ haskell-mode "Haskell Tidal" "Major mode for interacting with an inferior haskell process."+ :after-hook (interactive-haskell-mode -1) (set (make-local-variable 'paragraph-start) "\f\\|[ \t]*$") (set (make-local-variable 'paragraph-separate) "[ \t\f]*$") (setq tidal-literate-p nil) (turn-on-font-lock)) ;;;###autoload-(add-to-list 'auto-mode-alist '("\\.tidal$" . tidal-mode))+(add-to-list 'auto-mode-alist '("\\.tidal\\'" . tidal-mode)) (provide 'tidal) ;;; tidal.el ends here