tidal 0.9.10 → 1.10.3
raw patch · 57 files changed
Files
- BootTidal.hs +27/−0
- CHANGELOG.md +596/−6
- LICENSE +2/−3
- README.md +8/−9
- Setup.hs +1/−0
- Sound/Tidal/Bjorklund.hs +0/−34
- Sound/Tidal/Chords.hs +0/−166
- Sound/Tidal/Context.hs +0/−27
- Sound/Tidal/Dirt.hs +0/−390
- Sound/Tidal/EspGrid.hs +0/−114
- Sound/Tidal/MultiMode.hs +0/−106
- Sound/Tidal/OscStream.hs +0/−91
- Sound/Tidal/Params.hs +0/−391
- Sound/Tidal/Parse.hs +0/−436
- Sound/Tidal/Pattern.hs +0/−1752
- Sound/Tidal/Scales.hs +0/−224
- Sound/Tidal/Sieve.hs +0/−100
- Sound/Tidal/Simple.hs +0/−39
- Sound/Tidal/Strategies.hs +0/−421
- Sound/Tidal/Stream.hs +0/−329
- Sound/Tidal/SuperCollider.hs +0/−36
- Sound/Tidal/Tempo.hs +0/−341
- Sound/Tidal/Time.hs +0/−117
- Sound/Tidal/Transition.hs +0/−129
- Sound/Tidal/Utils.hs +0/−104
- Sound/Tidal/Version.hs +0/−4
- bench/Memory/Main.hs +10/−0
- bench/Memory/Tidal/Inputs.hs +112/−0
- bench/Memory/Tidal/UIB.hs +25/−0
- bench/Speed/Main.hs +22/−0
- bench/Speed/Tidal/CoreB.hs +83/−0
- bench/Speed/Tidal/Inputs.hs +103/−0
- bench/Speed/Tidal/PatternB.hs +69/−0
- bench/Speed/Tidal/UIB.hs +32/−0
- doc/tidal.md +0/−2
- src/Sound/Tidal/Boot.hs +396/−0
- src/Sound/Tidal/Config.hs +78/−0
- src/Sound/Tidal/Context.hs +35/−0
- src/Sound/Tidal/ID.hs +40/−0
- src/Sound/Tidal/Safe/Boot.hs +171/−0
- src/Sound/Tidal/Safe/Context.hs +125/−0
- src/Sound/Tidal/Stream.hs +36/−0
- 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/Transition.hs +300/−0
- src/Sound/Tidal/Version.hs +32/−0
- test/Sound/Tidal/StreamTest.hs +36/−0
- test/Test.hs +8/−0
- test/TestUtils.hs +78/−0
- test/dontcrash.hs +47/−0
- tests/test.hs +0/−47
- tidal.cabal +111/−62
- tidal.el +186/−287
+ BootTidal.hs view
@@ -0,0 +1,27 @@+:set -fno-warn-orphans -Wno-type-defaults -XMultiParamTypeClasses -XOverloadedStrings+:set prompt ""++-- Import all the boot functions and aliases.+import Sound.Tidal.Boot++default (Rational, Integer, Double, Pattern String)++-- Create a Tidal Stream with the default settings.+-- To customize these settings, use 'mkTidalWith' instead+tidalInst <- mkTidal++-- tidalInst <- mkTidalWith [(superdirtTarget { oLatency = 0.01 }, [superdirtShape])] (defaultConfig {cFrameTimespan = 1/50, cProcessAhead = 1/20})++-- This orphan instance makes the boot aliases work!+-- It has to go after you define 'tidalInst'.+instance Tidally where tidal = tidalInst++-- `enableLink` and `disableLink` can be used to toggle synchronisation using the Link protocol.+-- Uncomment the next line to enable Link on startup.+-- enableLink++-- You can also add your own aliases in this file. For example:+-- fastsquizzed pat = fast 2 $ pat # squiz 1.5++:set prompt "tidal> "+:set prompt-cont ""
CHANGELOG.md view
@@ -1,9 +1,604 @@+ # 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++## 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+* 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++## 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+* Mini notation - `!`, `@` and `_` now work properly within `{}` and `<>`, e.g. `<a b ! c!3 d>` will repeat every 7 cycles @yaxu #369 #248+* Mini notation - `@` and `_` are now aliases for each other, e.g. `a_3` is the same as `a@3` as are `_` and `@` @yaxu #369+* Frame skipping on clock jumps now configurable @yaxu #567+* Sync between tidal instances now works straight away, without having to setcps @yaxu #569+* New `while` function for applying a function selectively according to a binary pattern @yaxu+* Lowercases aliases `slowappend` and `fastappend` for `slowAppend` and `fastAppend` respectively @yaxu+* 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+* 'once' now chooses a random cycle to play. To get the old behaviour of playing the first cycle, use 'first' @yaxu #476+* Make random choices in mini-notation behave independently @yaxu #560+* Add [a|b|c] syntax to mini notation for randomly choosing between subsequences @yaxu #555+* 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+* fix crash bugs in mini notation parser and grp @yaxu+* new stitch function @yaxu+* |++, ++| and |++| for combining patterns of strings by concatenation @yaxu+* send best effort of a sound id to dirt / superdirt if sendParts is on, allowing parameter adjustment of previously triggered sound (without chopping) @yaxu+* qtrigger - quantise trigger to nearest cycle @yaxu+* add setI, setF et al to BootTidal.hs for setting state variables @yaxu+* BootTidal.hs now sends d1 .. d12 to orbits 0 .. 11 respectively @yaxu+* markov chain support with runMarkov and markovPat @bgold-cosmos+* simplify / fix mask and sew @yaxu+* Adjust <* and *> (and therefore |+, +| etc) to be closer to <*>, explanation here: https://penelope.hypotheses.org/1722 @yaxu+* extract minitidal into its own package tidal-parse (using cabal multipackages), renaming to Sound.Tidal.Parse @yaxu @dktr0+* benchmarking @nini-faroux+* minitidal refactor, support for parsing more of tidal, tests @dktr0++## 1.0.14 - IICON+* 'chew' - like bite, but speeds playback rate up and down+* variable probability for ? in mini notation+* chooseBy takes modulo of index to avoid out of bounds errors+* 'rate' control param+* 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++## 1.0.10 - This machine also kills fascists+* Add exports to Sound.Tidal.Scales for `getScale` and `scaleTable`++## 1.0.9 - This machine kills fascists+* sec and msec functions for converting from seconds to cycles (for stut etc) @yaxu+* template haskell upper bounds @yaxu+* fix for multi-laptop sync/tempo sharing @yaxu+* fix toScale so it doesn't break on empty lists @bgold-cosmos+* `deconstruct` function for displaying patterns stepwise @yaxu+* `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)**+* 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+* The return of `<>`, `infix alias for overlay` - @yaxu+* Fix for `wedge` to allow 0 and 1 as first parameter - @XiNNiW+* Support for new spectral fx - @madskjeldgaard+* Fix for _euclidInv - @dktr0+* `chordList` for listing chords - @XiNNiW+* new function `soak` - @XiNNiW+* tempo fixes - @bgold-cosmos+* miniTidal developments - @dktr0+* potentially more efficient euclidean patternings - @dktr0+* unit tests for euclid - @yaxu+* 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://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+* espgrid support+* lindenmayerI+* sew function, for binary switching between two patterns+* somecycles alias for someCycles+* ply function, for repeating each event in a pattern a given number+ of times within their original timespan+* patternify juxBy, e, e', einv, efull, eoff+ ## 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`)@@ -11,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.@@ -32,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"])`@@ -50,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.
LICENSE view
@@ -76,7 +76,7 @@ "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks.- + "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations.@@ -509,7 +509,7 @@ covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid.- + If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties@@ -672,4 +672,3 @@ the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read <http://www.gnu.org/philosophy/why-not-lgpl.html>.-
README.md view
@@ -1,14 +1,13 @@ -Tidal [](https://travis-ci.org/tidalcycles/Tidal)-=====--Language for live coding of pattern+# Tidal <a href="https://codeberg.org/uzu/tidal/LICENSE"><img alt="License" src="https://img.shields.io/github/license/tidalcycles/Tidal"></a> -For documentation, mailing list and more info see here:- https://tidalcycles.org/+[](https://doi.org/10.5281/zenodo.592191)+ +[Uzu language](https://uzu.lurk.org/) for live coding algorithmic patterns -(c) Alex McLean and contributors, 2016+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
− 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'
− Sound/Tidal/Chords.hs
@@ -1,166 +0,0 @@-module Sound.Tidal.Chords where--import Sound.Tidal.Pattern-import Data.Maybe-import Control.Applicative--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]-evelenSharp :: Num a => [a]-evelenSharp = [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),- ("minor", minor),- ("major7", major7),- ("dom7", dom7),- ("minor7", minor7),- ("aug", aug),- ("dim", dim),- ("dim7", dim7),- ("one", one),- ("five", five),- ("plus", plus),- ("sharp5", sharp5),- ("msharp5", msharp5),- ("sus2", sus2),- ("sus4", sus4),- ("six", six),- ("m6", m6),- ("sevenSus2", sevenSus2),- ("sevenSus4", sevenSus4),- ("sevenFlat5", sevenFlat5),- ("m7flat5", m7flat5),- ("sevenSharp5", sevenSharp5),- ("m7sharp5", m7sharp5),- ("nine", nine),- ("m9", m9),- ("m7sharp9", m7sharp9),- ("maj9", maj9),- ("nineSus4", nineSus4),- ("sixby9", sixby9),- ("m6by9", m6by9),- ("sevenFlat9", sevenFlat9),- ("m7flat9", m7flat9),- ("sevenFlat10", sevenFlat10),- ("nineSharp5", nineSharp5),- ("m9sharp5", m9sharp5),- ("sevenSharp5flat9", sevenSharp5flat9),- ("m7sharp5flat9", m7sharp5flat9),- ("eleven", eleven),- ("m11", m11),- ("maj11", maj11),- ("evelenSharp", evelenSharp),- ("m11sharp", m11sharp),- ("thirteen", thirteen),- ("m13", m13)- ]--chordL :: Num a => Pattern String -> Pattern [a]-chordL p = (\name -> fromMaybe [] $ lookup name chordTable) <$> p---- | @chord p@ turns a pattern of chord names into a pattern of--- numbers, representing note value offsets for the chords-chord :: Num a => Pattern String -> Pattern a-chord p = flatpat $ chordL p---- | @arpg p@ turns a pattern of chord names into a pattern of arpeggios--- of the those chords respectively-arpg :: Num a => Pattern String -> Pattern a-arpg p = breakUp $ chord p
− Sound/Tidal/Context.hs
@@ -1,27 +0,0 @@-module Sound.Tidal.Context (module C) where--import Control.Concurrent as C-import Data.List as C-import Control.Applicative as C-import Data.Ratio as C-import Data.Monoid as C-import Sound.Tidal.Parse as C-import Sound.Tidal.Pattern as C--- import Sound.Tidal.PatternList as C-import Sound.Tidal.Stream as C-import Sound.Tidal.Dirt as C-import Sound.Tidal.Strategies as C-import Sound.Tidal.Tempo as C-import Sound.Tidal.Time as C-import Sound.Tidal.Sieve as C-import Sound.Tidal.SuperCollider as C-import Sound.Tidal.Params as C-import Sound.Tidal.Transition as C-import Sound.Tidal.EspGrid as C-import Sound.Tidal.MultiMode as C-import Sound.Tidal.Version as C-import Sound.Tidal.Chords as C (chord)-import Sound.Tidal.Scales as C (scaleP)--import qualified Sound.Tidal.Scales as C.Scales-import qualified Sound.Tidal.Chords as C.Chords
− Sound/Tidal/Dirt.hs
@@ -1,390 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-module Sound.Tidal.Dirt where--import Sound.OSC.Datum (Datum)-import qualified Data.Map as Map-import Control.Applicative-import Control.Concurrent.MVar---import Visual-import Data.Colour.SRGB-import Data.Colour.Names-import Data.Hashable-import Data.Bits-import Data.Maybe-import Data.Fixed-import Data.Ratio-import Data.List (elemIndex, sort)--import Sound.Tidal.Stream-import Sound.Tidal.OscStream-import Sound.Tidal.Pattern-import Sound.Tidal.Parse-import Sound.Tidal.Params-import Sound.Tidal.Time-import Sound.Tidal.Tempo-import Sound.Tidal.Transition (transition, wash)-import Sound.Tidal.Utils (enumerate, fst')--dirt :: Shape-dirt = Shape { params = [ s_p,- offset_p,- begin_p,- end_p,- speed_p,- pan_p,- velocity_p,- vowel_p,- cutoff_p,- resonance_p,- accelerate_p,- shape_p,- kriole_p,- gain_p,- cut_p,- delay_p,- delaytime_p,- delayfeedback_p,- crush_p,- coarse_p,- hcutoff_p,- hresonance_p,- bandf_p,- bandq_p,- unit_p,- loop_p,- n_p,- attack_p,- hold_p,- release_p,- orbit_p- ],- cpsStamp = True,- latency = 0.3- }--dirtSlang = OscSlang {- path = "/play",- timestamp = MessageStamp,- namedParams = False,- preamble = []- }--superDirtSlang = dirtSlang { timestamp = BundleStamp, path = "/play2", namedParams = True }--superDirtBackend port = do- s <- makeConnection "127.0.0.1" port superDirtSlang- return $ Backend s (\_ _ _ -> return ())--superDirtState port = do- backend <- superDirtBackend port- Sound.Tidal.Stream.state backend dirt--dirtBackend = do- s <- makeConnection "127.0.0.1" 7771 dirtSlang- return $ Backend s (\_ _ _ -> return ())---- dirtstart name = start "127.0.0.1" 7771 dirt--dirtStream = do- backend <- dirtBackend- stream backend dirt--dirtState = do- backend <- dirtBackend- Sound.Tidal.Stream.state backend dirt--dirtSetters :: IO Time -> IO (ParamPattern -> IO (), (Time -> [ParamPattern] -> ParamPattern) -> ParamPattern -> IO ())-dirtSetters getNow = do ds <- dirtState- return (setter ds, transition getNow ds)--superDirtSetters :: IO Time -> IO (ParamPattern -> IO (), (Time -> [ParamPattern] -> ParamPattern) -> ParamPattern -> IO ())-superDirtSetters getNow = do ds <- superDirtState 57120- return (setter ds, transition getNow ds)---superDirts :: [Int] -> IO [(ParamPattern -> IO (), (Time -> [ParamPattern] -> ParamPattern) -> ParamPattern -> IO ())]-superDirts ports = do (_, getNow) <- cpsUtils- states <- mapM (superDirtState) ports- return $ map (\state -> (setter state, transition getNow state)) states---- -- disused parameter..-dirtstream _ = dirtStream---- doubledirt = do remote <- stream "178.77.72.138" 7777 dirt--- local <- stream "192.168.0.102" 7771 dirt--- return $ \p -> do remote p--- local p--- return ()---dirtToColour :: ParamPattern -> Pattern ColourD---dirtToColour p = s--- where s = fmap (\x -> maybe black (datumToColour) (Map.lookup (param dirt "s") x)) p-dirtToColour = fmap (stringToColour . show)--showToColour :: Show a => a -> ColourD-showToColour = stringToColour . show--datumToColour :: Value -> ColourD-datumToColour = showToColour--stringToColour :: String -> ColourD-stringToColour s = sRGB (r/256) (g/256) (b/256)- where i = (hash s) `mod` 16777216- r = fromIntegral $ (i .&. 0xFF0000) `shiftR` 16;- g = fromIntegral $ (i .&. 0x00FF00) `shiftR` 8;- b = fromIntegral $ (i .&. 0x0000FF);--{--visualcallback :: IO (ParamPattern -> IO ())-visualcallback = do t <- ticker- mv <- startVis t- let f p = do let p' = dirtToColour p- swapMVar mv p'- return ()- return f--}----dirtyvisualstream name = do cb <- visualcallback--- streamcallback cb "127.0.0.1" "127.0.0.1" name "127.0.0.1" 7771 dirt--pick :: String -> Int -> String-pick name n = name ++ ":" ++ (show n)--{- | 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 -> ParamPattern -> ParamPattern-striate = temporalParam _striate--_striate :: Int -> ParamPattern -> ParamPattern-_striate n p = fastcat $ map (\x -> off (fromIntegral x) p) [0 .. n-1]- where off i p = p- # begin (atom (fromIntegral i / fromIntegral n))- # end (atom (fromIntegral (i+1) / fromIntegral n))--{-|-The `striate'` function is a variant of `striate` with an extra-parameter, which specifies the length of each part. The `striate'`-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 $ striate' 32 (1/16) $ sound "bev"-@--Note that `striate` uses the `begin` and `end` parameters-internally. This means that if you're using `striate` (or `striate'`)-you probably shouldn't also specify `begin` or `end`. -}-striate' :: Pattern Int -> Pattern Double -> ParamPattern -> ParamPattern-striate' = temporalParam2 _striate'--_striate' :: Int -> Double -> ParamPattern -> ParamPattern-_striate' n f p = fastcat $ map (\x -> off (fromIntegral x) p) [0 .. n-1]- where off i p = p # begin (atom (slot * i) :: Pattern Double) # end (atom ((slot * i) + f) :: Pattern Double)- slot = (1 - f) / (fromIntegral n)--{- | like `striate`, but with an offset to the begin and end values -}-striateO :: Pattern Int -> Pattern Double -> ParamPattern -> ParamPattern-striateO = temporalParam2 _striateO--_striateO :: Int -> Double -> ParamPattern -> ParamPattern-_striateO n o p = _striate n p |+| begin (atom o :: Pattern Double) |+| end (atom o :: Pattern Double)--{- | Just like `striate`, but also loops each sample chunk a number of times specified in the second argument.-The primed version is just like `striate'`, 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 -> ParamPattern -> ParamPattern-striateL = temporalParam2 _striateL--striateL' :: Pattern Int -> Pattern Double -> Pattern Int -> ParamPattern -> ParamPattern-striateL' = temporalParam3 _striateL'--_striateL :: Int -> Int -> ParamPattern -> ParamPattern-_striateL n l p = _striate n p # loop (atom $ fromIntegral l)-_striateL' n f l p = _striate' n f p # loop (atom $ fromIntegral l)--metronome = _slow 2 $ sound (p "[odx, [hh]*8]")--{-|-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 (fadeOut' now t p') (fadeIn' now t 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--{- | crossfades between old and new pattern over given number of cycles, e.g.:--@-d1 $ sound "bd sn"--t1 (xfadeIn 16) $ sound "jvbass*3"-@--Will fade over 16 cycles from "bd sn" to "jvbass*3"--}-xfadeIn :: Time -> Time -> [ParamPattern] -> ParamPattern-xfadeIn _ _ [] = silence-xfadeIn _ _ (p:[]) = p-xfadeIn t now (p:p':_) = overlay (p |*| gain (now `rotR` (_slow t envEqR))) (p' |*| gain (now `rotR` (_slow t (envEq))))--{- |-Crossfade between old and new pattern over the next two cycles.--@-d1 $ sound "bd sn"--t1 xfade $ sound "can*3"-@--`xfade` is built with `xfadeIn` in this case taking two cycles for the fade.--}-xfade :: Time -> [ParamPattern] -> ParamPattern-xfade = xfadeIn 2--{- | 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 -> ParamPattern -> ParamPattern-stut = temporalParam3 _stut--_stut :: Integer -> Double -> Rational -> ParamPattern -> ParamPattern-_stut steps feedback time p = stack (p:(map (\x -> (((x%steps)*time) `rotR` (p |*| gain (pure $ scale (fromIntegral x))))) [1..(steps-1)]))- where scale x- = ((+feedback) . (*(1-feedback)) . (/(fromIntegral steps)) . ((fromIntegral steps)-)) x--{- | 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.--}-stut' :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-stut' n t f p = unwrap $ (\a b -> _stut' a b f p) <$> n <*> t--_stut' :: (Num n, Ord n) => n -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-_stut' steps steptime f p | steps <= 0 = p- | otherwise = overlay (f (steptime `rotR` _stut' (steps-1) steptime f p)) p--{- | @durPattern@ takes a pattern and returns the length of events in that-pattern as a new pattern. For example the result of `durPattern "[a ~] b"`-would be `"[0.25 ~] 0.5"`.--}--durPattern :: Pattern a -> Pattern Time-durPattern p = Pattern $ \a -> map eventLengthEvent $ arc p a- where eventLengthEvent (a1@(s1,e1), a2, x) = (a1, a2, e1-s1)--{- | @durPattern'@ is similar to @durPattern@, but does some lookahead to try-to find the length of time to the *next* event. For example, the result of-`durPattern' "[a ~] b"` would be `"[0.5 ~] 0.5"`.--}--durPattern' :: Pattern a -> Pattern Time-durPattern' p = Pattern $ \a@(s,e) -> map (eventDurToNext (arc p (s,e+1))) (arc p a)- where eventDurToNext evs ev@(a1,a2,x) = (a1, a2, (nextNum (t ev) (mt evs)) - (t ev))- t = fst . fst'- mt = (map fst) . (map fst')- nextNum a = head . sort . filter (\x -> x >a)--{- | @stutx@ is like @stut'@ but will limit the number of repeats using the -duration of the original sound. This usually prevents overlapping "stutters"-from subsequent sounds.--}--stutx :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-stutx n t f p = stut' (liftA2 min n (fmap floor $ durPattern' p / (t+0.001))) t f p--{-| same as `anticipate` though it allows you to specify the number of cycles until dropping to the new pattern, e.g.:--@-d1 $ sound "jvbass(3,8)"--t1 (anticipateIn 4) $ sound "jvbass(5,8)"-@-}-anticipateIn :: Time -> Time -> [ParamPattern] -> ParamPattern-anticipateIn t now = wash (spread' (_stut 8 0.2) (now `rotR` (_slow t $ (toRational . (1-)) <$> envL))) t now--{- | `anticipate` is an increasing comb filter.--Build up some tension, culminating in a _drop_ to the new pattern after 8 cycles.--}-anticipate :: Time -> [ParamPattern] -> ParamPattern-anticipate = anticipateIn 8--{- | Copies the @n@ parameter to the @orbit@ parameter, so different sound variants or notes go to different orbits in SuperDirt. -}-nToOrbit = copyParam n_p orbit_p--{- | Maps the sample or synth names to different @orbit@s, using indexes from the given list. E.g. @soundToOrbit ["bd", "sn", "cp"] $ sound "bd [cp sn]"@ would cause the bd, sn and cp smamples to be sent to orbit 0, 1, 2 respectively.-}-soundToOrbit :: [String] -> ParamPattern -> ParamPattern-soundToOrbit sounds p = follow s_p orbit_p ((\s -> fromMaybe 0 $ elemIndex s sounds) <$>) p
− Sound/Tidal/EspGrid.hs
@@ -1,114 +0,0 @@-module Sound.Tidal.EspGrid where - -import Control.Concurrent.MVar -import Control.Concurrent -import Control.Monad (forever) -import Control.Monad.Loops (iterateM_) -import Sound.OSC.FD -import Data.Time.Clock -import Data.Time.Clock.POSIX -import Data.Time.Calendar (fromGregorian) - -import Sound.Tidal.Tempo -import Sound.Tidal.Time as T -import Sound.Tidal.Stream -import Sound.Tidal.Dirt -import Sound.Tidal.Transition (transition) -import Sound.Tidal.Pattern (silence) - -parseEspTempo :: [Datum] -> Maybe Tempo -parseEspTempo d = do - on <- datum_integral (d!!0) - bpm <- datum_floating (d!!1) - t1 <- datum_integral (d!!2) - t2 <- datum_integral (d!!3) - n <- datum_integral (d!!4) - let nanos = (t1*1000000000) + t2 - let utc = posixSecondsToUTCTime ((realToFrac nanos)/1000000000) - return (Tempo utc (fromIntegral n) (bpm/60) (on==0) 0.04) - -changeTempo :: MVar Tempo -> Packet -> IO () -changeTempo mvar (Packet_Message msg) = do - case parseEspTempo (messageDatum msg) of - Just t -> tryTakeMVar mvar >> putMVar mvar t - Nothing -> putStrLn "Unable to parse message as Tempo" -changeTempo _ _ = putStrLn "Can only process Packet_Message" - -getTempo :: MVar Tempo -> IO Tempo -getTempo = readMVar - -runClientEsp :: IO (MVar Tempo,MVar Double) -runClientEsp = do - mTempo <- newEmptyMVar - mCps <- newEmptyMVar - socket <- openUDP "127.0.0.1" 5510 - forkIO $ forever $ do - sendOSC socket $ Message "/esp/tempo/q" [] - response <- waitAddress socket "/esp/tempo/r" - changeTempo mTempo response - threadDelay 100000 - return (mTempo, mCps) - -sendEspTempo :: Real t => t -> IO () -sendEspTempo t = do - socket <- openUDP "127.0.0.1" 5510 - sendOSC socket $ Message "/esp/beat/tempo" [float (t*60)] - -cpsUtilsEsp :: IO (Double -> IO (), IO Rational, IO Tempo) -cpsUtilsEsp = do - (mTempo,mCps) <- runClientEsp - return (sendEspTempo,getCurrentBeat mTempo,getTempo mTempo) - -clockedTickEsp :: Int -> (Tempo -> Int -> IO ()) -> IO () -clockedTickEsp tpb callback = do - (mTempo, _) <- runClientEsp - nowBeat <- getCurrentBeat mTempo - let nextTick = ceiling (nowBeat * (fromIntegral tpb)) - iterateM_ (clockedTickLoopEsp tpb callback mTempo) nextTick - -clockedTickLoopEsp :: Int -> (Tempo -> Int -> IO ()) -> MVar Tempo -> Int -> IO Int -clockedTickLoopEsp tpb callback mTempo tick = do - tempo <- readMVar mTempo - if (paused tempo) - then do -- TODO - do this via blocking read on the mvar somehow rather than polling - let pause = 0.01 - threadDelay $ floor (pause * 1000000) - return $ if cps tempo < 0 then 0 else tick -- reset tick to 0 if cps is negative - else do - now <- getCurrentTime - let beatsFromAtToTick = fromIntegral tick / fromIntegral tpb - beat tempo - delayUntilTick = beatsFromAtToTick / cps tempo - realToFrac (diffUTCTime now (at tempo)) - threadDelay $ floor (delayUntilTick * 1000000) - callback tempo tick - return $ tick + 1 - -streamEsp :: Backend a -> Shape -> IO (ParamPattern -> IO ()) -streamEsp backend shape = do - patternM <- newMVar silence - forkIO $ clockedTickEsp ticksPerCycle (onTick backend shape patternM) - return $ \p -> do swapMVar patternM p - return () - -dirtStreamEsp :: IO (ParamPattern -> IO ()) -dirtStreamEsp = do - backend <- dirtBackend - streamEsp backend dirt - -stateEsp :: Backend a -> Shape -> IO (MVar (ParamPattern, [ParamPattern])) -stateEsp backend shape = do - patternsM <- newMVar (silence, []) - let ot = (onTick' backend shape patternsM) :: Tempo -> Int -> IO () - forkIO $ clockedTickEsp ticksPerCycle ot - return patternsM - -dirtSettersEsp :: IO T.Time -> IO (ParamPattern -> IO (), (T.Time -> [ParamPattern] -> ParamPattern) -> ParamPattern -> IO ()) -dirtSettersEsp getNow = do - backend <- dirtBackend - ds <- stateEsp backend dirt - return (setter ds, transition getNow ds) - -superDirtSettersEsp :: IO T.Time -> IO (ParamPattern -> IO (), (T.Time -> [ParamPattern] -> ParamPattern) -> ParamPattern -> IO ()) -superDirtSettersEsp getNow = do - backend <- superDirtBackend 57120 - ds <- stateEsp backend dirt - return (setter ds, transition getNow ds)
− Sound/Tidal/MultiMode.hs
@@ -1,106 +0,0 @@-module Sound.Tidal.MultiMode where - -import Control.Concurrent.MVar -import Control.Concurrent -import Control.Monad (forever) -import Control.Monad.Loops (iterateM_) -import Sound.OSC.FD -import Data.Time.Clock -import Data.Time.Clock.POSIX -import Data.Time.Calendar (fromGregorian) - -import Sound.Tidal.Tempo -import Sound.Tidal.Time as T -import Sound.Tidal.Stream -import Sound.Tidal.Dirt -import Sound.Tidal.EspGrid -import Sound.Tidal.Transition (transition) -import Sound.Tidal.Pattern (silence) - -data StreamType = Dirt | SuperDirt - -data SyncType = NoSync | Esp - -initializeStreamType :: IO (MVar StreamType) -initializeStreamType = newMVar SuperDirt - -changeStreamType :: MVar StreamType -> StreamType -> IO (IO StreamType) -changeStreamType mvar t = return (swapMVar mvar t) - -initializeSyncType :: IO (MVar SyncType) -initializeSyncType = newMVar NoSync - -changeSyncType :: MVar SyncType -> SyncType -> IO (IO SyncType) -changeSyncType mvar t = return (swapMVar mvar t) - -type CpsUtils = (Double -> IO(), IO Rational) - -multiModeCpsUtils :: CpsUtils -> CpsUtils -> MVar SyncType -> IO CpsUtils -multiModeCpsUtils (cpsNone,getNowNone) (cpsEsp,getNowEsp) mSync = return (cps,getNow) - where cps x = do s <- readMVar mSync - case s of NoSync -> cpsNone x - Esp -> cpsEsp x - getNow = do s <- readMVar mSync - case s of NoSync -> getNowNone - Esp -> getNowEsp - -multiModeSetters :: IO Rational -> IO Rational -> MVar SyncType -> MVar StreamType -> IO (ParamPattern -> IO ()) -multiModeSetters getNowNone getNowEsp mSync mStream = do - (classicDirt,tClassic) <- dirtSetters getNowNone - (espDirt,tEsp) <- dirtSettersEsp getNowEsp - (superDirt,tSuper) <- superDirtSetters getNowNone - (espSuperDirt,tEspSuper) <- superDirtSettersEsp getNowEsp - let f NoSync Dirt p = do classicDirt p - espDirt silence - superDirt silence - espSuperDirt silence - f Esp Dirt p = do espDirt p - classicDirt silence - superDirt silence - espSuperDirt silence - f NoSync SuperDirt p = do superDirt p - classicDirt silence - espDirt silence - espSuperDirt silence - f Esp SuperDirt p = do espSuperDirt p - classicDirt silence - espDirt silence - superDirt silence - return $ \p -> readMVar mSync >>= \s -> readMVar mStream >>= \t -> f s t p - -{- - -Example of using the above definitions: -(note: if using Atom, evaluate each of the lines below one by one using shift-Enter) - -syncType <- initializeSyncType -nosync <- changeSyncType syncType NoSync -esp <- changeSyncType syncType Esp -(cpsNone,getNowNone) <- cpsUtils -(cpsEsp,getNowEsp,getTempoEsp) <- cpsUtilsEsp -(cps,getNow) <- multiModeCpsUtils (cpsNone,getNowNone) (cpsEsp,getNowEsp) syncType - -streamType <- initializeStreamType -classicDirt <- changeStreamType streamType Dirt -superDirt <- changeStreamType streamType SuperDirt -d1 <- multiModeSetters getNowNone getNowEsp syncType streamType -d2 <- multiModeSetters getNowNone getNowEsp syncType streamType -d3 <- multiModeSetters getNowNone getNowEsp syncType streamType -d4 <- multiModeSetters getNowNone getNowEsp syncType streamType -d5 <- multiModeSetters getNowNone getNowEsp syncType streamType -d6 <- multiModeSetters getNowNone getNowEsp syncType streamType -d7 <- multiModeSetters getNowNone getNowEsp syncType streamType -d8 <- multiModeSetters getNowNone getNowEsp syncType streamType -d9 <- multiModeSetters getNowNone getNowEsp syncType streamType -d10 <- multiModeSetters getNowNone getNowEsp syncType streamType - -let bps x = cps (x/2) -let hush = mapM_ ($ silence) [d1,d2,d3,d4,d5,d6,d7,d8,d9,d10] -let solo = (>>) hush - -then you can evaluate "classicDirt" to switch to classic Dirt -and "superDirt" to switch back to SuperDirt (the default) -and "esp" to turn on EspGrid-aware synchronization -and "nosync" to switch off EspGrid-aware synchronization (the default) -(switching between sync types is only noticeable after the next time a pattern is redefined right now) --}
− Sound/Tidal/OscStream.hs
@@ -1,91 +0,0 @@-module Sound.Tidal.OscStream where--import qualified Data.Map as Map-import Data.Maybe-import Sound.Tidal.Tempo (Tempo, cps)-import Sound.Tidal.Stream-import Sound.Tidal.Utils-import GHC.Float (float2Double, double2Float)-import Sound.OSC.FD-import Sound.OSC.Datum-import Sound.Tidal.Params--data TimeStamp = BundleStamp | MessageStamp | NoStamp- deriving Eq--data OscSlang = OscSlang {path :: String,- timestamp :: TimeStamp,- namedParams :: Bool,- preamble :: [Datum]- }--type OscMap = Map.Map Param Datum--toOscDatum :: Value -> Datum-toOscDatum (VF x) = float x-toOscDatum (VI x) = int32 x-toOscDatum (VS x) = string x--toOscMap :: ParamMap -> OscMap-toOscMap m = Map.map (toOscDatum) m---- constructs and sends an Osc Message according to the given slang--- and other params - this is essentially the same as the former--- toMessage in Stream.hs--send- :: (Integral a) =>- UDP- -> OscSlang- -> Shape- -> Tempo- -> a- -> (Double,- Double,- OscMap)- -> IO ()-send s slang shape change tick (on, off, m) = osc- where- osc | timestamp slang == BundleStamp =- sendOSC s $ Bundle (ut_to_ntpr logicalOnset) [Message (path slang) oscdata]- | timestamp slang == MessageStamp =- sendOSC s $ Message (path slang) ((int32 sec):(int32 usec):oscdata)- | otherwise =- doAt logicalOnset $ sendOSC s $ Message (path slang) oscdata- oscPreamble = cpsPrefix ++ preamble slang- oscdata | namedParams slang = oscPreamble ++ (concatMap (\(k, v) -> [string (name k), v] )- $ Map.assocs m)- | otherwise = oscPreamble ++ (catMaybes $ map (\x -> Map.lookup x m) (params shape))- cpsPrefix | cpsStamp shape && namedParams slang = [string "cps",- float (cps change),- string "delta",- float (logicalOffset- - logicalOnset),- string "cycle", float cycle- ]- | cpsStamp shape = [float (cps change)]- | otherwise = []- cycle = (on + fromIntegral tick) / (fromIntegral ticksPerCycle)- _parameterise ds = mergelists (map (string . name) (params shape)) ds- usec = floor $ 1000000 * (logicalOnset - (fromIntegral sec))- sec = floor logicalOnset- logicalOnset = logicalOnset' change tick on ((latency shape) + nudge)- logicalOffset = logicalOnset' change tick off ((latency shape) + nudge)- nudge = maybe 0 (toF) (Map.lookup nudge_p (m :: OscMap))- toF (Float f) = float2Double f- toF _ = 0---- type OscMap = Map.Map Param (Maybe Datum)- --- Returns a function that will convert a generic ParamMap into a specific Osc message and send it over UDP to the supplied server--- messages will be built according to the given OscSlang-makeConnection :: String -> Int -> OscSlang -> IO (ToMessageFunc)-makeConnection address port slang = do- s <- openUDP address port- return (\ shape change tick (on,off,m) -> do- let m' = if (namedParams slang) then (Just m) else (applyShape' shape m)- -- this might result in Nothing, make sure we do this first- m'' <- fmap (toOscMap) m'- -- to allow us to simplify `send` (no `do`)- return $ send s slang shape change tick (on,off,m'')- )
− Sound/Tidal/Params.hs
@@ -1,391 +0,0 @@-module Sound.Tidal.Params where--import Sound.Tidal.Stream-import Sound.Tidal.Pattern-import qualified Data.Map as Map-import Sound.Tidal.Utils-import Control.Applicative---- | group multiple params into one-grp :: [Param] -> Pattern String -> ParamPattern-grp [] _ = silence-grp params p = (fmap lookupPattern p)- where lookupPattern :: String -> ParamMap- lookupPattern s = Map.fromList $ map (\(param,s') -> toPV param s') $ zip params $ (split s)- split s = wordsBy (==':') s- toPV :: Param -> String -> (Param, Value)- toPV param@(S _ _) s = (param, (VS s))- toPV param@(F _ _) s = (param, (VF $ read s))- toPV param@(I _ _) s = (param, (VI $ read s))-{- |--A pattern of strings representing sounds or synth notes.--Internally, `sound` or its shorter alias `s` is a combination of the samplebank name and number when used with samples, or synth name and note number when used with a synthesiser. For example `bd:2` specifies the third sample (not the second as you might expect, because we start counting at zero) in the `bd` sample folder.--*Internally, `sound`/`s` is a combination of two parameters, the-hidden parameter `s'` which specifies the samplebank or synth, and the-`n` parameter which specifies the sample or note number. For example:--@-d1 $ sound "bd:2 sn:0"-@--is essentially the same as:--@-d1 $ s' "bd sn" # n "2 0"-@--`n` is therefore useful when you want to pattern the sample or note-number separately from the samplebank or synth. For example:--@-d1 $ n "0 5 ~ 2" # sound "drum"-@--is equivalent to:--@-d1 $ sound "drum:0 drum:5 ~ drum:2"-@--}-sound :: Pattern String -> ParamPattern-sound = grp [s_p, n_p]-s = sound--pF name defaultV = (make' VF param, param)- where param = F name defaultV-pI name defaultV = (make' VI param, param)- where param = I name defaultV-pS name defaultV = (make' VS param, param)- where param = S name defaultV--- | a pattern of numbers that speed up (or slow down) samples while they play.-(accelerate, accelerate_p) = pF "accelerate" (Just 0)--- | 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, attack_p) = pF "attack" (Just (-1))--- | a pattern of numbers from 0 to 1. Sets the center frequency of the band-pass filter.-(bandf, bandf_p) = pF "bandf" (Just 0)--- | a pattern of numbers from 0 to 1. Sets the q-factor of the band-pass filter.y-(bandq, bandq_p) = pF "bandq" (Just 0)-{- | 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_p, channel_p, legato_p, clhatdecay_p, coarse_p, crush_p :: Param-begin, legato, clhatdecay, crush :: Pattern Double -> ParamPattern-channel, coarse :: Pattern Int -> ParamPattern-(begin, begin_p) = pF "begin" (Just 0)--- | choose the physical channel the pattern is sent to, this is super dirt specific-(channel, channel_p) = pI "channel" Nothing----legato controls the amount of overlap between two adjacent synth sounds-(legato, legato_p) = pF "legato" (Just 1)--(clhatdecay, clhatdecay_p) = pF "clhatdecay" (Just 0)--- | 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, coarse_p) = pI "coarse" (Just 0)--- | bit crushing, a pattern of numbers from 1 (for drastic reduction in bit-depth) to 16 (for barely no reduction).-(crush, crush_p) = pF "crush" (Just 0)-{- |-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, cut_p) = pI "cut" (Just 0)--- | a pattern of numbers from 0 to 1. Applies the cutoff frequency of the low-pass filter.-(cutoff, cutoff_p) = pF "cutoff" (Just 0)-(cutoffegint, cutoffegint_p) = pF "cutoffegint" (Just 0)-(decay, decay_p) = pF "decay" (Just 0)--- | a pattern of numbers from 0 to 1. Sets the level of the delay signal.-(delay, delay_p) = pF "delay" (Just 0)--- | a pattern of numbers from 0 to 1. Sets the amount of delay feedback.-(delayfeedback, delayfeedback_p) = pF "delayfeedback" (Just (-1))--- | a pattern of numbers from 0 to 1. Sets the length of the delay.-(delaytime, delaytime_p) = pF "delaytime" (Just (-1))-(detune, detune_p) = pF "detune" (Just 0)--- | when set to `1` will disable all reverb for this pattern. See `room` and `size` for more information about reverb.-(dry, dry_p) = pF "dry" (Just 0)-{- 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, end_p) = pF "end" (Just 1)--- | a pattern of numbers that specify volume. Values less than 1 make the sound quieter. Values greater than 1 make the sound louder.-(gain, gain_p) = pF "gain" (Just 1)-(gate, gate_p) = pF "gate" (Just 0)-(hatgrain, hatgrain_p) = pF "hatgrain" (Just 0)--- | a pattern of numbers from 0 to 1. Applies the cutoff frequency of the high-pass filter.-(hcutoff, hcutoff_p) = pF "hcutoff" (Just 0)--- | 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, hold_p) = pF "hold" (Just 0)--- | a pattern of numbers from 0 to 1. Applies the resonance of the high-pass filter.-(hresonance, hresonance_p) = pF "hresonance" (Just 0)-(kriole, kriole_p) = pI "kriole" (Just 0)-(lagogo, lagogo_p) = pF "lagogo" (Just 0)-(lclap, lclap_p) = pF "lclap" (Just 0)-(lclaves, lclaves_p) = pF "lclaves" (Just 0)-(lclhat, lclhat_p) = pF "lclhat" (Just 0)-(lcrash, lcrash_p) = pF "lcrash" (Just 0)-(leslie, leslie_p) = pF "leslie" (Just 0)-(lrate, lrate_p) = pF "lrate" (Just 0)-(lsize, lsize_p) = pF "lsize" (Just 0) -(lfo, lfo_p) = pF "lfo" (Just 0)-(lfocutoffint, lfocutoffint_p) = pF "lfocutoffint" (Just 0)-(lfodelay, lfodelay_p) = pF "lfodelay" (Just 0)-(lfoint, lfoint_p) = pF "lfoint" (Just 0)-(lfopitchint, lfopitchint_p) = pF "lfopitchint" (Just 0)-(lfoshape, lfoshape_p) = pF "lfoshape" (Just 0)-(lfosync, lfosync_p) = pF "lfosync" (Just 0)-(lhitom, lhitom_p) = pF "lhitom" (Just 0)-(lkick, lkick_p) = pF "lkick" (Just 0)-(llotom, llotom_p) = pF "llotom" (Just 0)-{- | 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, lock_p) = pF "lock" (Just 0)--- | loops the sample (from `begin` to `end`) the specified number of times.-(loop, loop_p) = pF "loop" (Just 1)-(lophat, lophat_p) = pF "lophat" (Just 0)-(lsnare, lsnare_p) = pF "lsnare" (Just 0)--- | specifies the sample or note number to be used-(n, n_p) = pF "n" (Just 0)-(note, note_p) = pF "note" (Just 0)-{- |-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 -> ParamPattern-degree_p, mtranspose_p, ctranspose_p, harmonic_p, stepsPerOctave_p, octaveRatio_p :: Param-(degree, degree_p) = pF "degree" Nothing-(mtranspose, mtranspose_p) = pF "mtranspose" Nothing-(ctranspose, ctranspose_p) = pF "ctranspose" Nothing-(harmonic, harmonic_p) = pF "ctranspose" Nothing-(stepsPerOctave, stepsPerOctave_p) = pF "stepsPerOctave" Nothing-(octaveRatio, octaveRatio_p) = pF "octaveRatio" Nothing-----Low values will give a more _human_ feeling, high values might result in quite the contrary.--(nudge, nudge_p) = pF "nudge" (Just 0)-(octave, octave_p) = pI "octave" (Just 3)-(offset, offset_p) = pF "offset" (Just 0)-(ophatdecay, ophatdecay_p) = pF "ophatdecay" (Just 0)-{- | 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, orbit_p) = pI "orbit" (Just 0)--- | a pattern of numbers between 0 and 1, from left to right (assuming stereo), once round a circle (assuming multichannel)-(pan, pan_p) = pF "pan" (Just 0.5)--- | a pattern of numbers between -inf and inf, which controls how much multichannel output is fanned out (negative is backwards ordering)-(panspan, panspan_p) = pF "span" (Just 1.0)--- | a pattern of numbers between 0.0 and 1.0, which controls the multichannel spread range (multichannel only)-(pansplay, pansplay_p) = pF "splay" (Just 1.0)--- | a pattern of numbers between 0.0 and inf, which controls how much each channel is distributed over neighbours (multichannel only)-(panwidth, panwidth_p) = pF "panwidth" (Just 2.0)--- | 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, panorient_p) = pF "orientation" (Just 0.5)--(pitch1, pitch1_p) = pF "pitch1" (Just 0)-(pitch2, pitch2_p) = pF "pitch2" (Just 0)-(pitch3, pitch3_p) = pF "pitch3" (Just 0)-(portamento, portamento_p) = pF "portamento" (Just 0)--- | 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, release_p) = pF "release" (Just (-1))--- | a pattern of numbers from 0 to 1. Specifies the resonance of the low-pass filter.-(resonance, resonance_p) = pF "resonance" (Just 0)--- | a pattern of numbers from 0 to 1. Sets the level of reverb.-(room, room_p) = pF "room" Nothing-(sagogo, sagogo_p) = pF "sagogo" (Just 0)-(sclap, sclap_p) = pF "sclap" (Just 0)-(sclaves, sclaves_p) = pF "sclaves" (Just 0)-(scrash, scrash_p) = pF "scrash" (Just 0)-(semitone, semitone_p) = pF "semitone" (Just 0)--- | wave shaping distortion, a pattern of numbers from 0 for no distortion up to 1 for loads of distortion.-(shape, shape_p) = pF "shape" (Just 0)--- | a pattern of numbers from 0 to 1. Sets the perceptual size (reverb time) of the `room` to be used in reverb.-(size, size_p) = pF "size" Nothing-(slide, slide_p) = pF "slide" (Just 0)--- | 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, speed_p) = pF "speed" (Just 1)--- | a pattern of strings. Selects the sample to be played.-(s', s_p) = pS "s" Nothing-(stutterdepth, stutterdepth_p) = pF "stutterdepth" (Just 0)-(stuttertime, stuttertime_p) = pF "stuttertime" (Just 0)-(sustain, sustain_p) = pF "sustain" (Just 0)-(tomdecay, tomdecay_p) = pF "tomdecay" (Just 0)-{- | 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, unit_p) = pS "unit" (Just "rate")-(velocity, velocity_p) = pF "velocity" (Just 0.5)-(vcfegint, vcfegint_p) = pF "vcfegint" (Just 0)-(vcoegint, vcoegint_p) = pF "vcoegint" (Just 0)-(voice, voice_p) = pF "voice" (Just 0)--- | 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, vowel_p) = pS "vowel" (Just "")---- MIDI-specific params--(dur,dur_p) = pF "dur" (Just 0.05)-(modwheel,modwheel_p) = pF "modwheel" (Just 0)-(expression,expression_p) = pF "expression" (Just 1)-(sustainpedal,sustainpedal_p) = pF "sustainpedal" (Just 0)---- Tremolo Audio DSP effect | params are "tremolorate" and "tremolodepth"-tremolorate, tremolodepth :: Pattern Double -> ParamPattern-tremolorate_p, tremolodepth_p :: Param-(tremolorate,tremolorate_p) = pF "tremolorate" (Just 1)-(tremolodepth,tremolodepth_p) = pF "tremolodepth" (Just 0.5)---- Phaser Audio DSP effect | params are "phaserrate" and "phaserdepth"-phaserrate, phaserdepth :: Pattern Double -> ParamPattern-phaserrate_p, phaserdepth_p :: Param-(phaserrate,phaserrate_p) = pF "phaserrate" (Just 1)-(phaserdepth,phaserdepth_p) = pF "phaserdepth" (Just 0.5)---- aliases-att, chdecay, ctf, ctfg, delayfb, delayt, lbd, lch, lcl, lcp, lcr, lfoc, lfoi- , lfop, lht, llt, loh, lsn, ohdecay, phasdp, phasr, pit1, pit2, pit3, por, sag, scl, scp- , scr, sld, std, stt, sus, tdecay, tremdp, tremr, vcf, vco, voi- :: Pattern Double -> ParamPattern-att = attack-bpf = bandf-bpf_p = bandf_p-bpq = bandq-bpq_p = bandq_p-chdecay = clhatdecay-ctf = cutoff-ctfg = cutoffegint-delayfb = delayfeedback-delayt = delaytime-det = detune-gat = gate-hg = hatgrain-hpf = hcutoff-hpf_p = hcutoff_p-hpq = hresonance-hpq_p = hresonance_p-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-lpf_p = cutoff_p-lpq = resonance-lpq_p = resonance_p-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 -> ParamPattern-midinote = note . ((subtract 60) <$>)--drum :: Pattern String -> ParamPattern-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, array_p) = pF "array" Nothing-(midichan, midichan_p) = pF "midichan" Nothing-(control, control_p) = pF "control" Nothing--(ccn, ccn_p) = pF "ccn" Nothing-(ccv, ccv_p) = pF "ccv" Nothing-cc = grp [ccn_p, ccv_p]--(ctlNum, ctlNum_p) = pF "ctlNum" Nothing--(frameRate, frameRate_p) = pF "frameRate" Nothing-(frames, frames_p) = pF "frames" Nothing-(hours, hours_p) = pF "hours" Nothing--(midicmd, midicmd_p) = pS "midicmd" Nothing-command = midicmd--(minutes, minutes_p) = pF "minutes" Nothing-(progNum, progNum_p) = pF "progNum" Nothing-(seconds, seconds_p) = pF "seconds" Nothing-(songPtr, songPtr_p) = pF "songPtr" Nothing-(uid, uid_p) = pF "uid" Nothing-(val, val_p) = pF "val" Nothing
− Sound/Tidal/Parse.hs
@@ -1,436 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, CPP #-}-{-# LANGUAGE LambdaCase #-}--module Sound.Tidal.Parse where--import Text.ParserCombinators.Parsec-import qualified Text.ParserCombinators.Parsec.Token as P-import Text.ParserCombinators.Parsec.Language ( haskellDef )-import Data.Ratio-import Data.Colour-import Data.Colour.Names-import Data.Colour.SRGB-import GHC.Exts( IsString(..) )--- import Data.Monoid--- import qualified Data.Semigroup as Sem-import Control.Exception as E-import Control.Applicative ((<$>), (<*>), pure)-import Data.Maybe-import Data.List--import Sound.Tidal.Pattern-import Sound.Tidal.Time (Arc, Time)--{--#ifdef TIDAL_SEMIGROUP-import qualified Data.Semigroup as Sem-#endif--}---- | AST representation of patterns--data TPat a = TPat_Atom a- | TPat_Density (TPat Time) (TPat a)- | TPat_Slow (TPat Time) (TPat a)- | TPat_Zoom Arc (TPat a)- | TPat_DegradeBy Double (TPat a)- | TPat_Silence- | TPat_Foot- | TPat_Elongate Int- | TPat_EnumFromTo (TPat a) (TPat a)- | TPat_Cat [TPat a]- | TPat_TimeCat [TPat a]- | TPat_Overlay (TPat a) (TPat a)- | TPat_ShiftL Time (TPat a)- -- TPat_E Int Int (TPat a)- | TPat_pE (TPat Int) (TPat Int) (TPat Integer) (TPat a)- deriving (Show)--{--#ifdef TIDAL_SEMIGROUP-instance Sem.Semigroup (TPat a) where- (<>) = TPat_Overlay--instance Parseable a => Monoid (TPat a) where- mempty = TPat_Silence- mappend = (<>)-#else-instance Parseable a => Monoid (TPat a) where- mempty = TPat_Silence- mappend = TPat_Overlay-#endif--}--toPat :: Enumerable a => TPat a -> Pattern a-toPat = \case- TPat_Atom x -> atom x- TPat_Density t x -> density (toPat t) $ toPat x- TPat_Slow t x -> slow (toPat t) $ toPat x- TPat_Zoom arc x -> zoom arc $ toPat x- TPat_DegradeBy amt x -> _degradeBy amt $ toPat x- TPat_Silence -> silence- TPat_Cat xs -> fastcat $ map toPat xs- TPat_TimeCat xs -> timeCat $ map (\(n, p) -> (toRational n, toPat p)) $ durations xs- TPat_Overlay x0 x1 -> overlay (toPat x0) (toPat x1)- TPat_ShiftL t x -> t `rotL` toPat x- TPat_pE n k s thing ->- unwrap $ _eoff <$> toPat n <*> toPat k <*> toPat s <*> pure (toPat thing)- TPat_Foot -> error "Can't happen, feet (.'s) only used internally.."- TPat_EnumFromTo a b -> unwrap $ fromTo <$> (toPat a) <*> (toPat b)- -- TPat_EnumFromThenTo a b c -> unwrap $ fromThenTo <$> (toPat a) <*> (toPat b) <*> (toPat c)--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)--p :: (Enumerable a, Parseable a) => String -> Pattern a-p = toPat . parseTPat--class Parseable a where- parseTPat :: String -> TPat a--class Enumerable a where- fromTo :: a -> a -> Pattern a- fromThenTo :: a -> a -> a -> Pattern a--instance Parseable Double where- parseTPat = parseRhythm pDouble-instance Enumerable Double where- fromTo a b = enumFromTo' a b- fromThenTo a b c = enumFromThenTo' a b c--instance Parseable String where- parseTPat = parseRhythm pVocable-instance Enumerable String where- fromTo a b = listToPat [a,b]- fromThenTo a b c = listToPat [a,b,c]--instance Parseable Bool where- parseTPat = parseRhythm pBool-instance Enumerable Bool where- fromTo a b = listToPat [a,b]- fromThenTo a b c = listToPat [a,b,c]--instance Parseable Int where- parseTPat = parseRhythm pIntegral-instance Enumerable Int where- fromTo a b = enumFromTo' a b- fromThenTo a b c = enumFromThenTo' a b c--instance Parseable Integer where- parseTPat s = parseRhythm pIntegral s-instance Enumerable Integer where- fromTo a b = enumFromTo' a b- fromThenTo a b c = enumFromThenTo' a b c--instance Parseable Rational where- parseTPat = parseRhythm pRational-instance Enumerable Rational where- fromTo a b = enumFromTo' a b- fromThenTo a b c = enumFromThenTo' a b c--enumFromTo' a b | a > b = listToPat $ reverse $ enumFromTo b a- | otherwise = listToPat $ enumFromTo a b--enumFromThenTo' a b c | a > c = listToPat $ reverse $ enumFromThenTo c (c + (a-b)) a- | otherwise = listToPat $ enumFromThenTo a b c--type ColourD = Colour Double --instance Parseable ColourD where- parseTPat = parseRhythm pColour-instance Enumerable ColourD where- fromTo a b = listToPat [a,b]- fromThenTo a b c = listToPat [a,b,c]--instance (Enumerable a, Parseable a) => IsString (Pattern a) where- fromString = toPat . parseTPat----instance (Parseable a, Pattern p) => IsString (p a) where--- fromString = p :: String -> p a--lexer = P.makeTokenParser haskellDef--braces, brackets, parens, angles:: Parser a -> Parser a-braces = P.braces lexer-brackets = P.brackets lexer-parens = P.parens lexer-angles = P.angles lexer--symbol :: String -> Parser String-symbol = P.symbol lexer--natural, integer :: Parser Integer-natural = P.natural lexer-integer = P.integer lexer--float :: Parser Double-float = P.float lexer--naturalOrFloat :: Parser (Either Integer Double)-naturalOrFloat = P.naturalOrFloat lexer--data Sign = Positive | Negative--applySign :: Num a => Sign -> a -> a-applySign Positive = id-applySign Negative = negate--sign :: Parser Sign-sign = do char '-'- return Negative- <|> do char '+'- return Positive- <|> return Positive--intOrFloat :: Parser Double-intOrFloat = do s <- sign- num <- naturalOrFloat- return (case num of- Right x -> applySign s x- Left x -> fromIntegral $ applySign s x- )--r :: (Enumerable a, Parseable a) => String -> Pattern a -> IO (Pattern a)-r s orig = do E.handle - (\err -> do putStrLn (show (err :: E.SomeException))- return orig - )- (return $ p s)--parseRhythm :: Parseable a => Parser (TPat a) -> String -> TPat a-parseRhythm f input = either (const TPat_Silence) id $ parse (pSequence f') "" input- where f' = f- <|> do symbol "~" <?> "rest"- return TPat_Silence--pSequenceN :: Parseable a => Parser (TPat a) -> GenParser Char () (Int, TPat a)-pSequenceN f = do spaces- -- d <- pDensity- ps <- many $ do a <- pPart f- do Text.ParserCombinators.Parsec.try $ symbol ".."- b <- pPart f- return [TPat_EnumFromTo (TPat_Cat a) (TPat_Cat b)]- <|> return a- <|> do symbol "."- return [TPat_Foot]- <|> do es <- many1 (symbol "_")- return [TPat_Elongate (length es)]- let ps' = TPat_Cat $ map elongate $ splitFeet $ concat ps- return (length ps, ps')--elongate xs | any (isElongate) xs = TPat_TimeCat xs- | otherwise = TPat_Cat xs- where isElongate (TPat_Elongate _) = True- isElongate _ = False-{--expandEnum :: Parseable t => Maybe (TPat t) -> [TPat t] -> [TPat t]-expandEnum a [] = [a]-expandEnum (Just a) (TPat_Enum:b:ps) = (TPat_EnumFromTo a b) : (expandEnum Nothing ps)--- ignore ..s in other places-expandEnum a (TPat_Enum:ps) = expandEnum a ps-expandEnum (Just a) (b:ps) = a:(expandEnum b (Just c) ps)-expandEnum Nothing (c:ps) = expandEnum (Just c) ps--}---- could use splitOn here but `TPat a` isn't a member of `EQ`..-splitFeet :: [TPat t] -> [[TPat t]]-splitFeet [] = []-splitFeet ps = foot:(splitFeet ps')- where (foot, ps') = takeFoot ps- takeFoot [] = ([], [])- takeFoot (TPat_Foot:ps) = ([], ps)- takeFoot (p:ps) = (\(a,b) -> (p:a,b)) $ takeFoot ps--pSequence :: Parseable a => Parser (TPat a) -> GenParser Char () (TPat a)-pSequence f = do (_, p) <- pSequenceN f- return p--pSingle :: Parseable a => Parser (TPat a) -> Parser (TPat a)-pSingle f = f >>= pRand >>= pMult--pPart :: Parseable a => Parser (TPat a) -> Parser [TPat a]-pPart f = do part <- pSingle f <|> pPolyIn f <|> pPolyOut f- part <- pE part- part <- pRand part- spaces- parts <- pStretch part- <|> pReplicate part- spaces- return $ parts--pPolyIn :: Parseable a => Parser (TPat a) -> Parser (TPat a)-pPolyIn f = do ps <- brackets (pSequence f `sepBy` symbol ",")- spaces- pMult $ foldr TPat_Overlay TPat_Silence ps--pPolyOut :: Parseable a => Parser (TPat a) -> Parser (TPat a)-pPolyOut f = do ps <- braces (pSequenceN f `sepBy` symbol ",")- spaces- base <- do char '%'- spaces- i <- integer <?> "integer"- return $ Just (fromIntegral i)- <|> return Nothing- pMult $ foldr TPat_Overlay TPat_Silence $ scale base ps- <|>- do ps <- angles (pSequenceN f `sepBy` symbol ",")- spaces- pMult $ foldr TPat_Overlay TPat_Silence $ scale (Just 1) ps- where scale _ [] = []- scale base (ps@((n,_):_)) = map (\(n',p) -> TPat_Density (TPat_Atom $ fromIntegral (fromMaybe n base)/ fromIntegral n') p) ps--pString :: Parser (String)-pString = do c <- (letter <|> oneOf "0123456789") <?> "charnum"- cs <- many (letter <|> oneOf "0123456789:.-_") <?> "string"- return (c:cs)--pVocable :: Parser (TPat String)-pVocable = do v <- pString- return $ TPat_Atom v--pDouble :: Parser (TPat Double)-pDouble = do f <- choice [intOrFloat, parseNote] <?> "float"- return $ TPat_Atom f--pBool :: Parser (TPat Bool)-pBool = do oneOf "t1"- return $ TPat_Atom True- <|>- do oneOf "f0"- return $ TPat_Atom False--parseIntNote :: Integral i => Parser i-parseIntNote = do s <- sign- i <- choice [integer, parseNote]- return $ applySign s $ fromIntegral i--parseInt :: Parser Int-parseInt = do s <- sign- i <- integer- return $ applySign s $ fromIntegral i--pIntegral :: Parseable a => Integral a => Parser (TPat a)-pIntegral = TPat_Atom <$> parseIntNote--parseNote :: Num a => Parser 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 :: Parser 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 :: Parser Integer- noteModifier = choice [char 's' >> return 1,- char 'f' >> return (-1),- char 'n' >> return 0- ]--fromNote :: Num a => Pattern String -> Pattern a-fromNote p = (\s -> either (const 0) id $ parse parseNote "" s) <$> p--pColour :: Parser (TPat ColourD)-pColour = do name <- many1 letter <?> "colour name"- colour <- readColourName name <?> "known colour"- return $ TPat_Atom colour--pMult :: Parseable a => TPat a -> Parser (TPat a)-pMult thing = do char '*'- spaces- r <- (pRational <|> pPolyIn pRational <|> pPolyOut pRational)- return $ TPat_Density r thing- <|>- do char '/'- spaces- r <- (pRational <|> pPolyIn pRational <|> pPolyOut pRational)- return $ TPat_Slow r thing- <|>- return thing----pRand :: Parseable a => TPat a -> Parser (TPat a)-pRand thing = do char '?'- spaces- return $ TPat_DegradeBy 0.5 thing- <|> return thing--pE :: Parseable a => TPat a -> Parser (TPat a)-pE thing = do (n,k,s) <- parens (pair)- pure $ TPat_pE n k s thing- <|> return thing- where pair :: Parser (TPat Int, TPat Int, TPat Integer)- pair = do a <- pSequence pIntegral- spaces- symbol ","- spaces- b <- pSequence pIntegral- c <- do symbol ","- spaces- pSequence pIntegral- <|> return (TPat_Atom 0)- return (a, b, c)--eoff :: Pattern Int -> Pattern Int -> Pattern Integer -> Pattern a -> Pattern a-eoff = temporalParam3 _eoff--_eoff :: Int -> Int -> Integer -> Pattern a -> Pattern a-_eoff n k s p = ((s%(fromIntegral k)) `rotL`) (_e n k p)- -- TPat_ShiftL (s%(fromIntegral k)) (TPat_E n k p)--pReplicate :: Parseable a => TPat a -> Parser [TPat a]-pReplicate thing =- do extras <- many $ do char '!'- -- if a number is given (without a space)slow 2 $ fast- -- replicate that number of times- n <- ((read <$> many1 digit) <|> return 2)- spaces- thing' <- pRand thing- -- -1 because we already have parsed the original one- return $ replicate (fromIntegral (n-1)) thing'- return (thing:concat extras)---pStretch :: Parseable a => TPat a -> Parser [TPat a]-pStretch thing =- do char '@'- n <- ((read <$> many1 digit) <|> return 1)- return $ map (\x -> TPat_Zoom (x%n,(x+1)%n) thing) [0 .. (n-1)]--pRatio :: Parser (Rational)-pRatio = do s <- sign- n <- natural- result <- do char '%'- d <- natural- return (n%d)- <|>- do char '.'- s <- many1 digit- -- A hack, but not sure if doing this- -- numerically would be any faster..- return (toRational $ ((read $ show n ++ "." ++ s) :: Double))- <|>- return (n%1)- return $ applySign s result--pRational :: Parser (TPat Rational)-pRational = do r <- pRatio- return $ TPat_Atom r--{--pDensity :: Parser (Rational)-pDensity = angles (pRatio <?> "ratio")- <|>- return (1 % 1)--}
− Sound/Tidal/Pattern.hs
@@ -1,1752 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, CPP #-}-{-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-name-shadowing #-}--module Sound.Tidal.Pattern where--import Control.Applicative--- import Data.Monoid-import Data.Fixed-import Data.List-import Data.Maybe-import Data.Ord-import Data.Ratio--- import Debug.Trace-import Data.Typeable-import Data.Function-import System.Random.Mersenne.Pure64-import Data.Char (digitToInt)-import qualified Data.Text as T--import Sound.Tidal.Time-import Sound.Tidal.Utils-import Sound.Tidal.Bjorklund--import Text.Show.Functions ()-import qualified Control.Exception as E--{--#ifdef TIDAL_SEMIGROUP-import qualified Data.Semigroup as Sem-#endif--}---- | The pattern datatype, a function from a time @Arc@ to @Event@--- values. For discrete patterns, this returns the events which are--- active during that time. For continuous patterns, events with--- values for the midpoint of the given @Arc@ is returned.-newtype Pattern a = Pattern {arc :: Arc -> [Event a]}- deriving Typeable--noOv :: String -> a-noOv meth = error $ meth ++ ": No overloading"--instance Eq (Pattern a) where- (==) = noOv "(==)"--instance Ord a => Ord (Pattern a) where- min = liftA2 min- max = liftA2 max--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---- | @show (p :: Pattern)@ returns a text string representing the--- event values active during the first cycle of the given pattern.-instance (Show a) => Show (Pattern a) where- show p@(Pattern _) = unwords $ map showEvent $ arc p (0, 1)---- | converts a ratio into human readable string, e.g. @1/3@-showTime :: (Show a, Integral a) => Ratio a -> String-showTime t | denominator t == 1 = show (numerator t)- | otherwise = show (numerator t) ++ ('/':show (denominator t))---- | converts a time arc into human readable string, e.g. @1/3 3/4@-showArc :: Arc -> String-showArc a = (showTime $ fst a) ++ (' ':showTime (snd a))---- | converts an event into human readable string, e.g. @("bd" 1/4 2/3)@-showEvent :: (Show a) => Event a -> String-showEvent e@(_, b, v) = concat[on, show v, off,- (' ':showArc b),- "\n"- ]- where on | hasOnset e = ""- | otherwise = ".."- off | hasOffset e = ""- | otherwise = ".."--instance Functor Pattern where- fmap f (Pattern a) = Pattern $ fmap (fmap (mapThd' f)) a---- | @pure a@ returns a pattern with an event with value @a@, which--- has a duration of one cycle, and repeats every cycle.-instance Applicative Pattern where- pure x = Pattern $ \(s, e) -> map- (\t -> ((t%1, (t+1)%1),- (t%1, (t+1)%1),- x- )- )- [floor s .. ((ceiling e) - 1)]- (Pattern fs) <*> (Pattern xs) =- Pattern $ \a -> concatMap applyX (fs a)- where applyX ((s,e), (s', e'), f) =- map (\(_, _, x) -> ((s,e), (s', e'), f x))- (filter- (\(_, a', _) -> isIn a' s)- (xs (s',e'))- )--{--#ifdef TIDAL_SEMIGROUP--- | @mappend@ a.k.a. @<>@ is a synonym for @overlay@.-instance Sem.Semigroup (Pattern a) where- (<>) = overlay--instance Monoid (Pattern a) where- mempty = silence- mappend = (<>)--#else--- | @mempty@ is a synonym for @silence@.-instance Monoid (Pattern a) where- mempty = silence- mappend = overlay-#endif--}--instance Monad Pattern where- return = pure-- p >>= f = unwrap (f <$> p)--unwrap :: Pattern (Pattern a) -> Pattern a-unwrap p = Pattern $ \a -> concatMap (\(_, outerPart, p') -> mapMaybe (munge outerPart) $ arc p' a) (arc p a)- where munge a (whole,part,v) = do part' <- subArc a part- return (whole, part',v)----- | @atom@ is a synonym for @pure@.-atom :: a -> Pattern a-atom = pure---- | @silence@ returns a pattern with no events.-silence :: Pattern a-silence = Pattern $ const []---- | @withQueryArc f p@ returns a new @Pattern@ with function @f@--- applied to the @Arc@ values passed to the original @Pattern@ @p@.-withQueryArc :: (Arc -> Arc) -> Pattern a -> Pattern a-withQueryArc f p = Pattern $ \a -> arc p (f a)---- | @withQueryTime f p@ returns a new @Pattern@ with function @f@--- applied to the both the start and end @Time@ of the @Arc@ passed to--- @Pattern@ @p@.-withQueryTime :: (Time -> Time) -> Pattern a -> Pattern a-withQueryTime = withQueryArc . mapArc---- | @withResultArc f p@ returns a new @Pattern@ with function @f@--- applied to the @Arc@ values in the events returned from the--- original @Pattern@ @p@.-withResultArc :: (Arc -> Arc) -> Pattern a -> Pattern a-withResultArc f p = Pattern $ \a -> mapArcs f $ arc p a---- | @withResultTime f p@ returns a new @Pattern@ with function @f@--- applied to the both the start and end @Time@ of the @Arc@ values in--- the events returned from the original @Pattern@ @p@.-withResultTime :: (Time -> Time) -> Pattern a -> Pattern a-withResultTime = withResultArc . mapArc---- | @withEvent f p@ returns a new @Pattern@ with events mapped over--- function @f@.-withEvent :: (Event a -> Event b) -> Pattern a -> Pattern b-withEvent f p = Pattern $ \a -> map f $ arc p a---- | @timedValues p@ returns a new @Pattern@ where values are turned--- into tuples of @Arc@ and value.-timedValues :: Pattern a -> Pattern (Arc, a)-timedValues = withEvent (\(a,a',v) -> (a,a',(a,v)))---- | @overlay@ combines two @Pattern@s into a new pattern, so that--- their events are combined over time. This is the same as the infix--- operator `<>`.-overlay :: Pattern a -> Pattern a -> Pattern a-overlay p p' = Pattern $ \a -> (arc p a) ++ (arc p' a)---- | @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---- | @append@ combines two patterns @Pattern@s into a new pattern, so--- that the events of the second pattern are appended to those of the--- first pattern, within a single cycle--append :: Pattern a -> Pattern a -> Pattern a-append a b = fastcat [a,b]---- | @append'@ does the same as @append@, but over two cycles, so that--- the cycles alternate between the two patterns.-append' :: Pattern a -> Pattern a -> Pattern a-append' a b = slowcat [a,b]---- | @fastcat@ returns a new pattern which interlaces the cycles of the--- given patterns, within a single cycle. It's the equivalent of--- @append@, but with a list of patterns.-fastcat :: [Pattern a] -> Pattern a-fastcat ps = _density (fromIntegral $ length ps) $ slowcat ps--splitAtSam :: Pattern a -> Pattern a-splitAtSam p =- splitQueries $ Pattern $ \(s,e) -> mapSnds' (trimArc (sam s)) $ arc p (s,e)- where trimArc s' (s,e) = (max s' s, min (s'+1) e)---- | @slowcat@ does the same as @fastcat@, but maintaining the duration of--- the original patterns. It is the equivalent of @append'@, but with--- a list of patterns.--slowcat :: [Pattern a] -> Pattern a-slowcat [] = silence-slowcat ps = splitQueries $ Pattern f- where ps' = map splitAtSam ps- l = length ps'- f (s,e) = arc (withResultTime (+offset) p) (s',e')- where p = ps' !! n- r = (floor s) :: Int- n = (r `mod` l) :: Int- offset = (fromIntegral $ r - ((r - n) `div` l)) :: Time- (s', e') = (s-offset, e-offset)---- | @cat@ is an alias of @slowcat@-cat :: [Pattern a] -> Pattern a-cat = slowcat---- | @listToPat@ turns the given list of values to a Pattern, which--- cycles through the list.-listToPat :: [a] -> Pattern a-listToPat = fastcat . map atom--patToList :: Pattern a -> [a]-patToList p = map thd' $ sortBy (\a b -> compare (snd' a) (snd' b)) $ filter ((\x -> x >= 0 && x < 1) . fst . snd' ) (arc p (0,1))---- | @maybeListToPat@ is similar to @listToPat@, but allows values to--- be optional using the @Maybe@ type, so that @Nothing@ results in--- gaps in the pattern.-maybeListToPat :: [Maybe a] -> Pattern a-maybeListToPat = fastcat . map f- where f Nothing = silence- f (Just x) = atom x---- | @run@ @n@ returns a pattern representing a cycle of numbers from @0@ to @n-1@.-run :: (Enum a, Num a) => Pattern a -> Pattern a-run tp = tp >>= _run--_run :: (Enum a, Num a) => a -> Pattern a-_run n = listToPat [0 .. n-1]--scan :: (Enum a, Num a) => Pattern a -> Pattern a-scan tp = tp >>= _scan--_scan :: (Enum a, Num a) => a -> Pattern a-_scan n = slowcat $ map _run [1 .. n]--temporalParam :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c)-temporalParam f tv p = unwrap $ (`f` p) <$> tv--temporalParam2 :: (a -> b -> Pattern c -> Pattern d) -> (Pattern a -> Pattern b -> Pattern c -> Pattern d)-temporalParam2 f a b p = unwrap $ (\x y -> f x y p) <$> a <*> b--temporalParam3 :: (a -> b -> c -> Pattern d -> Pattern e) -> (Pattern a -> Pattern b -> Pattern c -> Pattern d -> Pattern e)-temporalParam3 f a b c p = unwrap $ (\x y z -> f x y z p) <$> a <*> b <*> c--temporalParam' :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c)-temporalParam' f tv p = unwrap' $ (`f` p) <$> tv--temporalParam2' :: (a -> b -> Pattern c -> Pattern d) -> (Pattern a -> Pattern b -> Pattern c -> Pattern d)-temporalParam2' f a b p = unwrap' $ (\x y -> f x y p) <$> a <*> b--temporalParam3' :: (a -> b -> c -> Pattern d -> Pattern e) -> (Pattern a -> Pattern b -> Pattern c -> Pattern d -> Pattern e)-temporalParam3' f a b c p = unwrap' $ (\x y z -> f x y z p) <$> a <*> b <*> c---- | @fast@ (also known as @density@) returns the given pattern with speed--- (or density) increased by the given @Time@ factor. Therefore @fast 2 p@--- will return a pattern that is twice as fast, and @fast (1/3) p@--- will return one three times as slow.-fast :: Pattern Time -> Pattern a -> Pattern a-fast = temporalParam _density--_fast :: Time -> Pattern a -> Pattern a-_fast = _density--fast' :: Pattern Time -> Pattern a -> Pattern a-fast' = temporalParam' _density---- | @density@ is an alias of @fast@. @fast@ is quicker to type, but--- @density@ is its old name so is used in a lot of examples.-density :: Pattern Time -> Pattern a -> Pattern a-density = fast--_density :: Time -> Pattern a -> Pattern a-_density r p | r == 0 = silence- | r < 0 = rev $ _density (negate r) p- | otherwise = withResultTime (/ r) $ withQueryTime (* r) p---- | @fastGap@ (also known as @densityGap@ 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).-fastGap :: Time -> Pattern a -> Pattern a-fastGap 0 _ = silence-fastGap r p = splitQueries $ withResultArc (\(s,e) -> (sam s + ((s - sam s)/r), (sam s + ((e - sam s)/r)))) $ Pattern (\a -> arc p $ mapArc (\t -> sam t + (min 1 (r * cyclePos t))) a)--densityGap :: Time -> Pattern a -> Pattern a-densityGap = fastGap---- | @slow@ does the opposite of @fast@, i.e. @slow 2 p@ will return a--- pattern that is half the speed.-slow :: Pattern Time -> Pattern a -> Pattern a-slow = temporalParam _slow--sparsity :: Pattern Time -> Pattern a -> Pattern a-sparsity = slow--slow' :: Pattern Time -> Pattern a -> Pattern a-slow' = temporalParam' _slow--_slow :: Time -> Pattern a -> Pattern a-_slow t p = _density (1/t) p---- | The @<~@ operator shifts (or rotates) a pattern to the left (or--- counter-clockwise) by the given @Time@ value. For example--- @(1%16) <~ p@ will return a pattern with all the events moved--- one 16th of a cycle to the left.-rotL :: Time -> Pattern a -> Pattern a-rotL t p = withResultTime (subtract t) $ withQueryTime (+ t) p--(<~) :: Pattern Time -> Pattern a -> Pattern a-(<~) = temporalParam rotL---- | The @~>@ operator does the same as @<~@ but shifts events to the--- right (or clockwise) rather than to the left.-rotR :: Time -> Pattern a -> Pattern a-rotR = rotL . (0-)--(~>) :: Pattern Time -> Pattern a -> Pattern a-(~>) = temporalParam rotR--{- | (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 = temporalParam _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' = temporalParam _iter'--_iter' :: Int -> Pattern a -> Pattern a-_iter' n p = slowcat $ map (\i -> ((fromIntegral i)%(fromIntegral n)) `rotR` p) [0 .. (n-1)]---- | @rev p@ returns @p@ with the event positions in each cycle--- reversed (or mirrored).-rev :: Pattern a -> Pattern a-rev p = splitQueries $ Pattern $ \a -> map makeWholeAbsolute $ mapSnds' (mirrorArc (mid a)) $ map makeWholeRelative (arc p (mirrorArc (mid a) a))- where makeWholeRelative ((s,e), part@(s',e'), v) = ((s'-s, e-e'), part, v)- makeWholeAbsolute ((s,e), part@(s',e'), v) = ((s'-e,e'+s), part, v)- mid (s,_) = (sam s) + 0.5---- | @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 = append' p (rev p)--{-|-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 $ Pattern apply- where apply a | test (floor $ fst a) = (arc $ f p) a- | otherwise = (arc p) a--whenT :: (Time -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-whenT test f p = splitQueries $ Pattern apply- where apply a | test (fst a) = (arc $ f p) a- | otherwise = (arc p) a--playWhen :: (Time -> Bool) -> Pattern a -> Pattern a-playWhen test (Pattern f) = Pattern $ (filter (\e -> test (eventOnset e))) . f--playFor :: Time -> Time -> Pattern a -> Pattern a-playFor s e = playWhen (\t -> and [t >= s, t < e])--{- | 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---- | @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 = tp >>= \t -> _every t f p--_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 f = when ((== o) . (`mod` n)) f---- | @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 ($) p (map (\x -> _every x f) ns)---- | @sig f@ takes a function from time to values, and turns it into a--- @Pattern@.-sig :: (Time -> a) -> Pattern a-sig f = Pattern f'- where f' (s,e) | s > e = []- | otherwise = [((s,e), (s,e), f s)]---- | @sinewave@ returns a @Pattern@ of continuous @Fractional@ values following a--- sinewave with frequency of one cycle, and amplitude from 0 to 1.-sinewave :: Fractional a => Pattern a-sinewave = sig $ \t -> ((sin_rat $ pi * 2 * (fromRational t)) + 1) / 2- where sin_rat = fromRational . toRational . sin---- | @sine@ is a synonym for @sinewave@.-sine :: Fractional a => Pattern a-sine = sinewave---- | @sine@ is a synonym for @0.25 ~> sine@.-cosine :: Fractional a => Pattern a-cosine = 0.25 ~> sine---- | @sineAmp d@ returns @sinewave@ with its amplitude offset by @d@.--- Deprecated, as these days you can simply do e.g. (sine + 0.5)-sineAmp :: Fractional a => a -> Pattern a-sineAmp offset = (+ offset) <$> sinewave1---- | @sawwave@ is the equivalent of @sinewave@ for (ascending) sawtooth waves.-sawwave :: (Fractional a, Real a) => Pattern a-sawwave = sig $ \t -> mod' (fromRational t) 1---- | @saw@ is a synonym for @sawwave@.-saw :: (Fractional a, Real a) => Pattern a-saw = sawwave---- | @triwave@ is the equivalent of @sinewave@ for triangular waves.-triwave :: (Fractional a, Real a) => Pattern a-triwave = append sawwave1 (rev sawwave1)---- | @tri@ is a synonym for @triwave@.-tri :: (Fractional a, Real a) => Pattern a-tri = triwave---- | @squarewave1@ is the equivalent of @sinewave@ for square waves.-squarewave :: (Fractional a, Real a) => Pattern a-squarewave = sig $- \t -> fromIntegral $ ((floor $ (mod' (fromRational t :: Double) 1) * 2) :: Integer)---- | @square@ is a synonym for @squarewave@.-square :: (Fractional a, Real a) => Pattern a-square = squarewave---- deprecated..-sinewave1 :: Fractional a => Pattern a-sinewave1 = sinewave-sine1 :: Fractional a => Pattern a-sine1 = sinewave-sinerat = sine-ratsine = sine-sinerat1 = sine-sineAmp1 :: Fractional a => a -> Pattern a-sineAmp1 = sineAmp-sawwave1 :: (Fractional a, Real a) => Pattern a-sawwave1 = sawwave-saw1 :: (Fractional a, Real a) => Pattern a-saw1 = sawwave-sawrat = saw-sawrat1 = saw-triwave1 :: (Fractional a, Real a) => Pattern a-triwave1 = triwave-tri1 :: (Fractional a, Real a) => Pattern a-tri1 = triwave-trirat = tri-trirat1 = tri-squarewave1 :: (Fractional a, Real a) => Pattern a-squarewave1 = squarewave-square1 :: (Fractional a, Real a) => Pattern a-square1 = square---- | @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' 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)))--fadeOut :: Time -> Pattern a -> Pattern a-fadeOut n = spread' (_degradeBy) (_slow n $ envL)---- Alternate versions where you can provide the time from which the fade starts-fadeOut' :: Time -> Time -> Pattern a -> Pattern a-fadeOut' from dur p = spread' (_degradeBy) (from `rotR` _slow dur envL) p---- The 1 <~ is so fade ins and outs have different degredations-fadeIn' :: Time -> Time -> Pattern a -> Pattern a-fadeIn' from dur p = spread' (\n p -> 1 `rotL` _degradeBy n p) (from `rotR` _slow dur ((1-) <$> envL)) p--fadeIn :: Time -> Pattern a -> Pattern a-fadeIn n = spread' (_degradeBy) (_slow n $ (1-) <$> envL)--{- | (The above is difficult to describe, if you don't understand Haskell,-just ignore it and read the below..)--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 (\x -> f x 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 <- _discretise 1 (choose vs)- f v p--spreadr :: (t -> t1 -> Pattern b) -> [t] -> t1 -> Pattern b-spreadr = spreadChoose--filterValues :: (a -> Bool) -> Pattern a -> Pattern a-filterValues f (Pattern x) = Pattern $ (filter (f . thd')) . x--filterJust :: Pattern (Maybe a) -> Pattern a-filterJust p = fromJust <$> (filterValues (isJust) p)---- Filter out events that have had their onsets cut off-filterOnsets :: Pattern a -> Pattern a-filterOnsets (Pattern f) =- Pattern $ (filter (\e -> eventOnset e >= eventStart e)) . f---- Filter events which have onsets, which are within the given range--- TODO - what about < e ??-filterStartInRange :: Pattern a -> Pattern a-filterStartInRange (Pattern f) =- Pattern $ \(s,e) -> filter ((isIn (s,e)) . eventOnset) $ f (s,e)--filterOnsetsInRange :: Pattern a -> Pattern a-filterOnsetsInRange = filterOnsets . filterStartInRange---- Samples some events from a pattern, returning a list of onsets--- (relative to the given arc), deltas (durations) and values.-seqToRelOnsetDeltas :: Arc -> Pattern a -> [(Double, Double, a)]-seqToRelOnsetDeltas (s, e) p = map (\((s', e'), _, x) -> (fromRational $ (s'-s) / (e-s), fromRational $ (e'-s) / (e-s), x)) $ arc (filterOnsetsInRange p) (s, e)--segment :: Pattern a -> Pattern [a]-segment p = Pattern $ \(s,e) -> filter (\(_,(s',e'),_) -> s' < e && e' > s) $ groupByTime (segment' (arc p (s,e)))--segment' :: [Event a] -> [Event a]-segment' es = foldr split es pts- where pts = nub $ points es--split :: Time -> [Event a] -> [Event a]-split _ [] = []-split t ((ev@(a,(s,e), v)):es) | t > s && t < e = (a,(s,t),v):(a,(t,e),v):(split t es)- | otherwise = ev:split t es--points :: [Event a] -> [Time]-points [] = []-points ((_,(s,e), _):es) = s:e:(points es)--groupByTime :: [Event a] -> [Event [a]]-groupByTime es = map mrg $ groupBy ((==) `on` snd') $ sortBy (compare `on` snd') es- where mrg es@((a, a', _):_) = (a, a', map thd' es)- mrg _ = error "groupByTime"---{-| 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 $ Pattern apply- where apply a | test (floor $ fst a) = (arc $ f1 p) a- | otherwise = (arc $ f2 p) a--{-|--`rand` generates a continuous pattern of (pseudo-)random, floating point numbers between `0` and `1`.--@-d1 $ sound "bd*8" # pan rand-@--pans bass drums randomly--@-d1 $ sound "sn sn ~ sn" # gain rand-@--makes the snares' randomly loud and quiet.--Numbers coming from this pattern are random, but dependent on time. So if you reset time via `cps (-1)` 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:--@-d1 $ jux (|+| gain rand) $ sound "sn sn ~ sn" # gain rand-@--and with the juxed version shifted backwards for 1024 cycles:--@-d1 $ jux (|+| ((1024 <~) $ gain rand)) $ sound "sn sn ~ sn" # gain rand-@--}-rand :: Pattern Double-rand = Pattern $ \a -> [(a, a, timeToRand $ (midPoint a))]--timeToRand :: RealFrac r => r -> Double-timeToRand t = fst $ randomDouble $ pureMT $ floor $ (*1000000) t--{- | 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 $ n (irand 5) # sound "drum"-@--}-irand :: Num a => Int -> Pattern a-irand i = (fromIntegral . (floor :: Double -> Int) . (* (fromIntegral i))) <$> rand--{- | Randomly picks an element from the given list--@-d1 $ sound (samples "xx(3,8)" (tom $ choose ["a", "e", "g", "c"]))-@--plays a melody randomly choosing one of the four notes \"a\", \"e\", \"g\", \"c\".--}-choose :: [a] -> Pattern a-choose [] = E.throw (E.ErrorCall "Empty list. Nothing to choose from.")-choose xs = (xs !!) <$> (irand $ length xs)--{- |-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 = temporalParam _degradeBy--_degradeBy :: Double -> Pattern a -> Pattern a-_degradeBy x p = fmap fst $ filterValues ((> x) . snd) $ (,) <$> p <*> rand--unDegradeBy :: Pattern Double -> Pattern a -> Pattern a-unDegradeBy = temporalParam _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 <*> repeatCycles 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 :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-sometimesBy x f p = overlay (_degradeBy x p) (f $ _unDegradeBy x 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 :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-someCyclesBy x = when (test x)- where test x c = (timeToRand (fromIntegral c :: Double)) < x--somecyclesBy :: 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---- | @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 t p p' = overlay (densityGap (1/t) p) (t `rotR` densityGap (1/(1-t)) p')--timeCat :: [(Time, Pattern a)] -> Pattern a-timeCat tps = stack $ map (\(s,e,p) -> compress (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)--{- | @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.Pattern.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]---- | @splitQueries p@ wraps `p` to ensure that it does not get--- queries that span arcs. For example `arc 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 = Pattern $ \a -> concatMap (arc p) $ arcCycles a--{- | @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 = temporalParam _trunc--_trunc :: Time -> Pattern a -> Pattern a-_trunc t = compress (0,t) . zoom (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 = temporalParam _linger--_linger :: Time -> Pattern a -> Pattern a-_linger n p = _density (1/n) $ zoom (0,n) p--{- | Plays a portion of a pattern, specified by a beginning and end arc of 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 :: Arc -> Pattern a -> Pattern a-zoom (s,e) p = splitQueries $ withResultArc (mapCycle ((/d) . (subtract s))) $ withQueryArc (mapCycle ((+s) . (*d))) p- where d = e-s--compress :: Arc -> Pattern a -> Pattern a-compress (s,e) p | s >= e = silence- | otherwise = s `rotR` densityGap (1/(e-s)) p--sliceArc :: Arc -> Pattern a -> Pattern a-sliceArc a@(s,e) p | s >= e = silence- | otherwise = compress a $ zoom a 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 :: Arc -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-within (s,e) f p = stack [playWhen (\t -> cyclePos t >= s && cyclePos t < e) $ f p,- playWhen (\t -> not $ cyclePos t >= s && cyclePos t < e) $ p- ]--{- |-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' :: Arc -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-within' (s,e) f p = stack [playWhen (\t -> cyclePos t >= s && cyclePos t < e) $ compress (s,e) $ f $ zoom (s,e) $ p, - playWhen (\t -> not $ cyclePos t >= s && cyclePos t < e) $ p - ]---revArc :: Arc -> 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.-@--}-e :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a-e = temporalParam2 _e--_e :: Int -> Int -> Pattern a -> Pattern a-_e n k p = (flip const) <$> (filterValues (== True) $ listToPat $ bjorklund (n,k)) <*> p--e' :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a-e' = temporalParam2 _e'--_e' :: Int -> Int -> Pattern a -> Pattern a-_e' n k p = fastcat $ map (\x -> if x then p else silence) (bjorklund (n,k))---distrib :: [Pattern Int] -> Pattern a -> Pattern a-distrib steps p = do steps' <- sequence steps- _distrib steps' 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 p p' = (flip const) <$> (filterValues (== True) $ listToPat $ p) <*> p'--{- | `einv` fills in the blanks left by `e`- -- @e 3 8 "x"@ -> @"x ~ ~ x ~ ~ x ~"@-- @einv 3 8 "x"@ -> @"~ x x ~ x x ~ x"@--}-einv :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a-einv = temporalParam2 _einv--_einv :: Int -> Int -> Pattern a -> Pattern a-_einv n k p = (flip const) <$> (filterValues (== False) $ listToPat $ bjorklund (n,k)) <*> p--{- | `efull n k pa pb` stacks @e n k pa@ with @einv n k pb@ -}-efull :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a-efull n k pa pb = stack [ e n k pa, einv n k pb ]--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' sz start = zoom (start, start+sz)---- | @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 (_density 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))---- | @discretise n p@: 'samples' the pattern @p@ at a rate of @n@--- events per cycle. Useful for turning a continuous pattern into a--- discrete one.-discretise :: Time -> Pattern a -> Pattern a-discretise = _discretise--discretise' :: Pattern Time -> Pattern a -> Pattern a-discretise' n p = (density n $ atom (id)) <*> p--_discretise :: Time -> Pattern a -> Pattern a-_discretise n p = (_density n $ atom (id)) <*> p---- | @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) (_discretise 1 $ ((%1) . fromIntegral) <$> (irand (length ps) :: Pattern Int)) (slowcat 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 !!!) <$> (Pattern $ \a -> map ((\e -> (mapThd' (+ (cyclePos perCycle e)) e))) (arc p a))- where cyclePos perCycle e = perCycle * (floor $ eventStart e)--permstep :: RealFrac b => Int -> [a] -> Pattern b -> Pattern a-permstep steps things p = unwrap $ (\n -> listToPat $ concatMap (\x -> replicate (fst x) (snd x)) $ zip (ps !! (floor (n * (fromIntegral $ (length ps - 1))))) things) <$> (_discretise 1 p)- where ps = permsort (length things) steps- deviance avg xs = sum $ map (abs . (avg-) . fromIntegral) xs- permsort n total = map fst $ sortBy (comparing 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 @a@.-struct :: Pattern String -> Pattern a -> Pattern a-struct ps pv = (flip const) <$> 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 = Pattern $ f- where f a = concatMap (\a' -> arc (compressTo a' p) a') $ (map fst' $ arc s a)--compressTo :: Arc -> Pattern a -> Pattern a-compressTo (s,e) p = compress (cyclePos s, e-(sam s)) p--randArcs :: Int -> Pattern [Arc]-randArcs n =- do rs <- mapM (\x -> (pure $ (toRational x)/(toRational n)) <~ choose [1,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 = (0,head xs):(pairUp' xs)- pairUp' [] = []- pairUp' (_:[]) = []- pairUp' (a:_:[]) = [(a,1)]- pairUp' (a:b:xs) = (a,b):(pairUp' (b:xs))--randStruct :: Int -> Pattern Int-randStruct n = splitQueries $ Pattern f- where f (s,e) = mapSnds' fromJust $ filter (\(_,x,_) -> isJust x) $ as- where as = map (\(n, (s',e')) -> ((s' + sam s, e' + sam s),- subArc (s,e) (s' + sam s, e' + sam s),- n- )- ) $ enumerate $ thd' $ head $ arc (randArcs n) (sam s, nextSam s)--substruct' :: Pattern Int -> Pattern a -> Pattern a-substruct' s p = Pattern $ \a -> concatMap (\(a', _, i) -> arc (compressTo a' (inside (pure $ 1/toRational(length (arc s (sam (fst a), nextSam (fst a))))) (rotR (toRational i)) p)) a') (arc s a)---- | @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 = temporalParam _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 s)- where splitOn sep str = splitAt (fromJust $ elemIndex sep str)- $ filter (/= sep) str- commaSplit s = 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 n r s = fmap fromIntegral $ fmap digitToInt $ lindenmayer n r s---- support for fit'-unwrap' :: Pattern (Pattern a) -> Pattern a-unwrap' pp = Pattern $ \a -> arc (stack $ map scalep (arc pp a)) a- where scalep ev = compress (fst' ev) $ thd' ev--{-|-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" :: Pattern Bool)- (slowcat ["can*8", "[cp*4 sn*4, jvbass*16]"] ))- # n (run 8)-@--Detail: It is currently needed to explicitly _tell_ Tidal that the mask itself is a `Pattern Bool` as it cannot infer this by itself, otherwise it will complain as it does not know how to interpret your input.--}-mask :: Pattern a -> Pattern b -> Pattern b-mask pa pb = Pattern $ \a -> concat [filterOns (subArc a $ eventArc i) (arc pb a) | i <- arc pa a]- where filterOns Nothing _ = []- filterOns (Just arc) es = filter (onsetIn arc) es--enclosingArc :: [Arc] -> Arc-enclosingArc [] = (0,1)-enclosingArc as = (minimum (map fst as), maximum (map snd as))--stretch :: Pattern a -> Pattern a-stretch p = splitQueries $ Pattern $ \a@(s,_e) -> arc- (zoom (enclosingArc $ map eventArc $ arc p (sam s,nextSam s)) p)- a--{- | `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 = unwrap' $ fit n (mapMasks n from' p') to- where mapMasks n from p = [stretch $ mask (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 :: Integer -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-chunk n f p = cat [within (i%(fromIntegral n),(i+1)%(fromIntegral n)) f p | i <- [0..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 :: Integer -> (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)- within (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 $ Pattern f- where f a@(s,_) = mapSnds' plus $ mapFsts' plus $ arc p (minus a)- where minus = mapArc (subtract (sam s))- plus = mapArc (+ (sam s))--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 fst' ps- maxT = maximum $ map snd' 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' 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 (within (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 xs = Pattern $ \(s,e) -> [((s,e),(s,e), xs!!(floor $ (dlen xs)*(ctrand s) ))]- where dlen xs = fromIntegral $ length xs- ctrand s = (timeToRand :: Time -> Double) $ fromIntegral $ (floor :: Time -> Int) $ sam s--{- | `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::Int -> Pattern a -> Pattern a-shuffle n = fit' 1 n (_run n) (randpat n)- where randpat n = Pattern $ \(s,e) -> arc (p n $ sam s) (s,e)- p n c = listToPat $ map snd $ sort $ zip- [timeToRand (c+i/n') | i <- [0..n'-1]] [0..n-1]- n' :: Time- n' = fromIntegral 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::Int -> Pattern a -> Pattern a-scramble n = fit' 1 n (_run n) (_density (fromIntegral n) $- liftA2 (+) (pure 0) $ irand n)--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 s = wordsBy (==':') s- getPat (s:xs) = (match s, transform xs)- match s = fromMaybe silence $ lookup s ps'- ps' = map (fmap (_density t)) ps- adjust (a, (p, f)) = f a p- transform (x:_) a = transform' x a- transform _ _ = id- transform' str (s,e) p = s `rotR` (inside (pure $ 1/(e-s)) (matchF str) p)- matchF str = fromMaybe id $ lookup str fs--inhabit :: [(String, Pattern a)] -> Pattern String -> Pattern a-inhabit ps p = unwrap' $ (\s -> fromMaybe silence $ lookup s ps) <$> p--repeatCycles :: Int -> Pattern a -> Pattern a-repeatCycles n p = fastcat (replicate n 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 (\a -> compress a p) $ spaceArcs xs- where markOut :: Time -> [Time] -> [(Time, Time)]- markOut _ [] = []- markOut offset (x:xs) = (offset,offset+x):(markOut (offset+x) xs)- spaceArcs xs = map (\(a,b) -> (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 = Pattern $ \a -> (concatMap (\(b,b',xs) -> map (\x -> (b,b',x)) xs) $ arc p a)---- | @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---- | @breakUp@ finds events that share the same timespan, and spreads them out during that timespan, so for example @breakUp "[bd,sn]"@ gets turned into @"bd sn"@-breakUp :: Pattern a -> Pattern a-breakUp p = Pattern $ \a -> munge $ arc p a- where munge es = concatMap spreadOut (groupBy (\a b -> fst' a == fst' b) es)- spreadOut xs = mapMaybe (\(n, x) -> shiftIt n (length xs) x) $ enumerate xs- shiftIt n d ((s,e), a', v) = do a'' <- subArc (newS, newE) a'- return ((newS, newE), a'', v)- where newS = s + (dur*(fromIntegral n))- newE = newS + dur- dur = (e - s) / (fromIntegral d)---- | @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 $ Pattern (f p)) p'- where- f p (s,e) = removeTolerance (s,e) $ invert (s-tolerance, e+tolerance) $ arc p (s-tolerance, e+tolerance)- invert (s,e) es = map arcToEvent $ foldr remove [(s,e)] (map snd' 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) $ mapSnds' 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 = temporalParam _ply--_ply :: Int -> Pattern a -> Pattern a-_ply n p = breakUp $ stack (replicate n p)---- Uses the first (binary) pattern to switch between the following two--- patterns. -sew :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a-sew stitch p1 p2 = overlay (const <$> p1 <*> a) (const <$> p2 <*> b)- where a = filterValues (id) stitch- b = filterValues (not . id) stitch
− Sound/Tidal/Scales.hs
@@ -1,224 +0,0 @@-module Sound.Tidal.Scales where--import Data.Maybe--import Sound.Tidal.Pattern-import Sound.Tidal.Utils-import Control.Applicative---- five notes scales-minPent :: Num a => [a]-minPent = [0,3,5,7,10]-majPent :: Num a => [a]-majPent = [0,2,4,7,9]---- another mode of major pentatonic-ritusen :: Num a => [a]-ritusen = [0,2,5,7,9]---- another mode of major pentatonic-egyptian :: Num a => [a]-egyptian = [0,2,5,7,10]-----kumai :: Num a => [a]-kumai = [0,2,3,7,9]-hirajoshi :: Num a => [a]-hirajoshi = [0,2,3,7,8]-iwato :: Num a => [a]-iwato = [0,1,5,6,10]-chinese :: Num a => [a]-chinese = [0,4,6,7,11]-indian :: Num a => [a]-indian = [0,4,5,7,10]-pelog :: Num a => [a]-pelog = [0,1,3,7,8]-----prometheus :: Num a => [a]-prometheus = [0,2,4,6,11]-scriabin :: Num a => [a]-scriabin = [0,1,4,7,9]---- han chinese pentatonic scales-gong :: Num a => [a]-gong = [0,2,4,7,9]-shang :: Num a => [a]-shang = [0,2,5,7,10]-jiao :: Num a => [a]-jiao = [0,3,5,8,10]-zhi :: Num a => [a]-zhi = [0,2,5,7,9]-yu :: Num a => [a]-yu = [0,3,5,7,10]---- 6 note scales-whole :: Num a => [a]-whole = [0,2,4,6,8,10]-augmented :: Num a => [a]-augmented = [0,3,4,7,8,11]-augmented2 :: Num a => [a]-augmented2 = [0,1,4,5,8,9]---- hexatonic modes with no tritone-hexMajor7 :: Num a => [a]-hexMajor7 = [0,2,4,7,9,11]-hexDorian :: Num a => [a]-hexDorian = [0,2,3,5,7,10]-hexPhrygian :: Num a => [a]-hexPhrygian = [0,1,3,5,8,10]-hexSus :: Num a => [a]-hexSus = [0,2,5,7,9,10]-hexMajor6 :: Num a => [a]-hexMajor6 = [0,2,4,5,7,9]-hexAeolian :: Num a => [a]-hexAeolian = [0,3,5,7,8,10]---- 7 note scales-major :: Num a => [a]-major = [0,2,4,5,7,9,11]-ionian :: Num a => [a]-ionian = [0,2,4,5,7,9,11]-dorian :: Num a => [a]-dorian = [0,2,3,5,7,9,10]-phrygian :: Num a => [a]-phrygian = [0,1,3,5,7,8,10]-lydian :: Num a => [a]-lydian = [0,2,4,6,7,9,11]-mixolydian :: Num a => [a]-mixolydian = [0,2,4,5,7,9,10]-aeolian :: Num a => [a]-aeolian = [0,2,3,5,7,8,10]-minor :: Num a => [a]-minor = [0,2,3,5,7,8,10]-locrian :: Num a => [a]-locrian = [0,1,3,5,6,8,10]-harmonicMinor :: Num a => [a]-harmonicMinor = [0,2,3,5,7,8,11]-harmonicMajor :: Num a => [a]-harmonicMajor = [0,2,4,5,7,8,11]-melodicMinor :: Num a => [a]-melodicMinor = [0,2,3,5,7,9,11]-melodicMinorDesc :: Num a => [a]-melodicMinorDesc = [0,2,3,5,7,8,10]-melodicMajor :: Num a => [a]-melodicMajor = [0,2,4,5,7,8,10]-bartok :: Num a => [a]-bartok = [0,2,4,5,7,8,10]-hindu :: Num a => [a]-hindu = [0,2,4,5,7,8,10]---- raga modes-todi :: Num a => [a]-todi = [0,1,3,6,7,8,11]-purvi :: Num a => [a]-purvi = [0,1,4,6,7,8,11]-marva :: Num a => [a]-marva = [0,1,4,6,7,9,11]-bhairav :: Num a => [a]-bhairav = [0,1,4,5,7,8,11]-ahirbhairav :: Num a => [a]-ahirbhairav = [0,1,4,5,7,9,10]-----superLocrian :: Num a => [a]-superLocrian = [0,1,3,4,6,8,10]-romanianMinor :: Num a => [a]-romanianMinor = [0,2,3,6,7,9,10]-hungarianMinor :: Num a => [a]-hungarianMinor = [0,2,3,6,7,8,11]-neapolitanMinor :: Num a => [a]-neapolitanMinor = [0,1,3,5,7,8,11]-enigmatic :: Num a => [a]-enigmatic = [0,1,4,6,8,10,11]-spanish :: Num a => [a]-spanish = [0,1,4,5,7,8,10]---- modes of whole tones with added note ->-leadingWhole :: Num a => [a]-leadingWhole = [0,2,4,6,8,10,11]-lydianMinor :: Num a => [a]-lydianMinor = [0,2,4,6,7,8,10]-neapolitanMajor :: Num a => [a]-neapolitanMajor = [0,1,3,5,7,9,11]-locrianMajor :: Num a => [a]-locrianMajor = [0,2,4,5,6,8,10]---- 8 note scales-diminished :: Num a => [a]-diminished = [0,1,3,4,6,7,9,10]-diminished2 :: Num a => [a]-diminished2 = [0,2,3,5,6,8,9,11]---- 12 note scales-chromatic :: Num a => [a]-chromatic = [0,1,2,3,4,5,6,7,8,9,10,11]--scaleP :: Num a => Pattern String -> Pattern Int -> Pattern a-scaleP sp p = (\n scaleName -> noteInScale (fromMaybe [0] $ lookup scaleName scaleTable) n) <$> p <*> sp- where octave s x = x `div` length s- noteInScale s x = (s !!! x) + (fromIntegral $ 12 * octave s x)--scaleTable :: Num 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),- ("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),- ("diminished2", diminished2),- ("chromatic", chromatic)- ]-
− Sound/Tidal/Sieve.hs
@@ -1,100 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-name-shadowing #-}--module Sound.Tidal.Sieve where--import Control.Applicative-import Data.Monoid--import Sound.Tidal.Parse-import Sound.Tidal.Pattern-import Sound.Tidal.Strategies-import Sound.Tidal.Time---- The 'Sieve' datatype, which represents a Xenakis sieve.--- (for an overview, see www.mitpressjournals.org/doi/pdf/10.1162/0148926054094396)--data Sieve a = Sieve {sieveAt :: Int -> a}--instance Functor Sieve where- fmap f s = Sieve $ \i -> f (sieveAt s i)--instance Applicative Sieve where- pure b = Sieve $ \i -> b- a <*> b = Sieve $ \i -> (sieveAt a i) (sieveAt b i)---- | The basic notation for and constructor of a boolean 'Sieve' is @m\@\@n@,--- which represents all integers whose modulo with @m@ is equal to @n@-infixl 9 @@ -(@@) :: Int -> Int -> Sieve Bool -m @@ i = Sieve $ \j -> (j `mod` m) == i---- If Haskell's logic operators had been defined on a type class, we could--- declare Sieve to be an instance, but they haven't so here we are---- | @not'@ gives the complement of a sieve-not' :: Applicative f => f Bool -> f Bool-not' = fmap not---- | @#||#@ gives the union (logical OR) of two sieves-infixl 2 #||#-(#||#) :: Applicative f => f Bool -> f Bool -> f Bool-(#||#) = liftA2 (||)---- | @#&&#@ gives the intersection (logical AND) of two sieves-infixl 3 #&&#-(#&&#) :: Applicative f => f Bool -> f Bool -> f Bool-(#&&#) = liftA2 (&&)---- | `#^^#` gives the exclusive disjunction (logical XOR) of two sieves-infixl 2 #^^#-(#^^#) :: Applicative f => f Bool -> f Bool -> f Bool-(#^^#) x y = (x #&&# not' y) #||# (y #&&# not' x)---- | @sieveToList n@ returns a list of the values of the sieve for each--- nonnegative integer less than @n@ --- For example: @sieveToList 10 $ 3\@\@1@ returns --- `[False, True, False, False, True, False, False, True, False, False]`-sieveToList :: Int -> Sieve a -> [a]-sieveToList n s = map (sieveAt s) [0..n-1]---- | @sieveToString n@ represents the sieve as a character string, where--- @-@ represents False and @x@ represents True-sieveToString :: Int -> Sieve Bool -> [Char]-sieveToString n s = map b2c $ sieveToList n s- where b2c b | b == True = 'x' | otherwise = '-'---- | @sieveToInts n@ returns a list of nonnegative integers less than @n@--- where the sieve is True-sieveToInts :: Int -> Sieve Bool -> [Int]-sieveToInts n s = map snd $ filter fst $ zip (sieveToList n s) [0..n-1]---- | @sieveToPat n@ returns a pattern where the cycle is divided into @n@--- beats, and there is an event whenever the matching beat number is in the--- sieve--- For example: @sieveToPat 8 $ 3\@\@1@ returns @"~ x ~ ~ x ~ ~ x"@-sieveToPat :: Int -> Sieve Bool -> Pattern String-sieveToPat n s = p $ concatMap b2s $ sieveToList n s where- b2s b | b == True = "x " | otherwise = "~ "---- | @stepSieve n str@ works like 'sieveToPat' but uses @str@ in the pattern--- instead of @x@-stepSieve :: Int -> String -> Sieve Bool -> Pattern String-stepSieve n str sieve = step str (sieveToString n sieve)---- | @slowstepSieve t@ is shorthand for applying @slow t@ to the result of--- `stepSieve`-slowstepSieve :: Pattern Time -> Int -> String -> Sieve Bool -> Pattern String-slowstepSieve t n str sieve = slow t $ stepSieve n str sieve---- | @scaleSieve n@ uses 'sieveToInts' to turn a sieve into a list of--- integers, and then uses that with the @toScale@ function to--- turn a pattern of numbers into a pattern of notes in the scale.--- For example: @scaleSieve 8 (3\@\@1) "0 1 2 1"@ first converts the sieve--- to the scale @[1, 4, 7]@ and then uses that with @toScale@ to return the--- pattern @"1 4 7 4"@-scaleSieve :: Int -> Sieve Bool -> Pattern Int -> Pattern Int-scaleSieve n sieve = toScale (sieveToInts n sieve)--instance Show (Sieve Bool) where - show = sieveToString 32
− Sound/Tidal/Simple.hs
@@ -1,39 +0,0 @@-module Sound.Tidal.Simple where--import Sound.Tidal.Context--crunch :: ParamPattern -> ParamPattern-crunch = (# crush 3)--scratch :: ParamPattern -> ParamPattern-scratch = rev . chop 32--louder :: ParamPattern -> ParamPattern-louder = (|*| gain 1.2)--quieter :: ParamPattern -> ParamPattern-quieter = (|*| gain 0.8)--mute :: ParamPattern -> ParamPattern-mute = const silence--jump :: ParamPattern -> ParamPattern-jump = (0.25 <~)--left :: ParamPattern -> ParamPattern-left = (# pan 0)--right :: ParamPattern -> ParamPattern-right = (# pan 1)--higher :: ParamPattern -> ParamPattern-higher = (|*| speed 1.5)--lower :: ParamPattern -> ParamPattern-lower = (|*| speed 0.75)--faster :: ParamPattern -> ParamPattern-faster = hurry 2--slower :: ParamPattern -> ParamPattern-slower = hurry 0.5
− Sound/Tidal/Strategies.hs
@@ -1,421 +0,0 @@-{-# OPTIONS_GHC -XNoMonomorphismRestriction -XOverloadedStrings #-}--module Sound.Tidal.Strategies where--import Data.Ratio-import Control.Applicative-import qualified Data.Map as Map-import qualified Data.Char as Char-import Data.Fixed-import Data.Maybe--import Sound.Tidal.Dirt-import Sound.Tidal.Pattern-import Sound.Tidal.Stream-import Sound.Tidal.Time-import Sound.Tidal.Utils-import Sound.Tidal.Params-import Sound.Tidal.Parse-import Data.List (transpose)--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-triple = stutter 3-quad = stutter 4-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) $ striate' 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) $ striate' 32 (1/16) $ sound "bev"-@--}-jux = juxBy 1-juxcut f p = stack [p # pan (pure 0) # cut (pure (-1)),- f $ p # pan (pure 1) # cut (pure (-2))- ]--juxcut' fs p = stack $ map (\n -> ((fs !! n) p |+| cut (pure $ 1-n)) # 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' fs p = stack $ map (\n -> ((fs !! n) p) |+| pan (pure $ fromIntegral n / fromIntegral l)) [0 .. l-1]- where l = length fs---- | Multichannel variant of `jux`, _not sure what it does_-jux4 f p = stack [p # pan (pure (5/8)), f $ 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 n f p = stack [p |+| pan 0.5 |-| pan (n/2), f $ p |+| pan 0.5 |+| pan (n/2)]--{- | 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 n xs p = slowcat $ map (\n -> slow n p') xs- where p' = striate n p--{- | an altenative form to `smash` is `smash'` which will use `chop` instead of `striate`.--}-smash' n xs p = slowcat $ map (\n -> slow n p') xs- where p' = _chop n p---- 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)--}----rev :: Pattern a -> Pattern a---rev p = Pattern $ \a -> concatMap--- (\a' -> mapFsts mirrorArc $--- (arc p (mirrorArc a')))--- (arcCycles a)----spreadf :: [Pattern a -> Pattern b] -> Pattern a -> Pattern b-spreadf ts p = spread ($)--{- | `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 -> ParamPattern -> ParamPattern-spin = temporalParam _spin--_spin :: Int -> ParamPattern -> ParamPattern-_spin copies p =- stack $ map (\n -> let offset = toInteger n % toInteger copies in- offset `rotL` p- # pan (pure $ fromRational offset)- )- [0 .. (copies - 1)]--{-stripe :: Arc -> Pattern a -> Pattern a-stripe (stripeS, stripeE) p = slow t $ Pattern $ \a -> concatMap f $ arcCycles a- where f a = mapFsts (stretch . stripe') $ arc p (stripe' a)- trunc' (s,e) = (min s ((sam s) + t), min e ((sam s) + t))- stretch (s,e) = (sam s + ((s - sam s) / t), sam s + ((e - sam s) / t))--}--sawwave4, sinewave4, rand4 :: Pattern Double-sawwave4 = ((*4) <$> sawwave1)-sinewave4 = ((*4) <$> sinewave1)-rand4 = ((*4) <$> rand)--stackwith p ps | null ps = silence- | otherwise = stack $ map (\(i, p') -> p' # (((fromIntegral i) % l) `rotL` p)) (zip [0 ..] 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--}--{- | `scale` will take a pattern which goes from 0 to 1 (like `sine1`), and scale it to a different range - between the first and second arguments. In the below example, `scale 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 $ scale 1 1.5 sine1)-@--}-scale :: (Functor f, Num b) => b -> b -> f b -> f b-scale from to p = ((+ from) . (* (to-from))) <$> p--{- | `scalex` is an exponential version of `scale`, good for using with-frequencies. Do *not* use negative numbers or zero as arguments! -}-scalex :: (Functor f, Floating b) => b -> b -> f b -> f b-scalex from to p = exp <$> scale (log from) (log to) p--{- | `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 -> ParamPattern -> ParamPattern-chop = temporalParam _chop--_chop :: Int -> ParamPattern -> ParamPattern-_chop n p = Pattern $ \queryA -> concatMap (f queryA) $ arcCycles queryA- where f queryA a = concatMap (chopEvent queryA) (arc p a)- chopEvent (queryS, queryE) (a,_a',v) = map (newEvent v) $ filter (\(_, (s,e)) -> not $ or [e < queryS, s >= queryE]) (enumerate $ chopArc a n)- newEvent :: ParamMap -> (Int, Arc) -> Event ParamMap- newEvent v (i, a) = (a,a,Map.insert (param dirt "end") (VF ((fromIntegral $ i+1)/(fromIntegral n))) $ Map.insert (param dirt "begin") (VF ((fromIntegral i)/(fromIntegral n))) v)---{- | `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 -> ParamPattern -> ParamPattern-gap = temporalParam _gap--_gap :: Int -> ParamPattern -> ParamPattern-_gap n p = Pattern $ \queryA -> concatMap (f queryA) $ arcCycles queryA- where f queryA a = concatMap (chopEvent queryA) (arc p a)- chopEvent (queryS, queryE) (a,_a',v) = map (newEvent v) $ filter (\(_, (s,e)) -> not $ or [e < queryS, s >= queryE]) (enumerate $ everyOther $ chopArc a n)- newEvent :: ParamMap -> (Int, Arc) -> Event ParamMap- newEvent v (i, a) = (a,a,Map.insert (param dirt "end") (VF ((fromIntegral $ i+1)/(fromIntegral n))) $ Map.insert (param dirt "begin") (VF ((fromIntegral i)/(fromIntegral n))) v)- everyOther (x:_:xs) = x:everyOther xs- everyOther xs = xs--chopArc :: Arc -> Int -> [Arc]-chopArc (s, e) n = map (\i -> ((s + (e-s)*(fromIntegral i/fromIntegral n)), s + (e-s)*((fromIntegral $ i+1)/fromIntegral n))) [0 .. n-1]-{--normEv :: Event a -> Event a -> Event a-normEv ev@(_, (s,e), _) ev'@(_, (s',e'), _)- | not on && not off = [] -- shouldn't happen- | on && off = splitEv ev'- | not on && s' > sam s = []- | not off && e' < nextSam s = [(fst' ev, mapSnd' (mapSnd (min $ nextSam s)) ev, thd' ev)]- where on = onsetIn (sam s, nextSam s) ev- off = offsetIn (sam s, nextSam s) ev- eplitEv--}---mapCycleEvents :: Pattern a -> ([Event a] -> [Event a]) -> Pattern a---mapCycleEvents p f = splitQueries $ Pattern $ \(s,e) -> filter (\ev -> isJust $ subArc (s,e) (eventArc ev)) $ f $ arc p (sam s, nextSam s)----off :: Time -> Pattern a -> Pattern a---off t p = mapCycleEvents p (mapArcs (mapSnd wrappedPlus . mapFst wrappedPlus))--- where wrapAtCycle f t' = sam t' + cyclePos (f t')--- wrappedPlus = wrapAtCycle (+t)---en :: [(Int, Int)] -> Pattern String -> Pattern String-en ns p = stack $ map (\(i, (k, n)) -> _e k n (samples p (pure i))) $ enumerate ns--{- |-`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 :: Rational -> ParamPattern -> [ParamPattern] -> ParamPattern-weave t p ps = weave' t p (map (\x -> (x #)) ps)---{- | `weave'` is similar in that it blends functions at the same time at different amounts over a pattern:--@-d1 $ weave' 3 (sound "bd [sn drum:2*2] bd*2 [sn drum:1]") [density 2, (# speed "0.5"), chop 16]-@--}-weave' :: Rational -> Pattern a -> [Pattern a -> Pattern a] -> Pattern a-weave' t p fs | l == 0 = silence- | otherwise = _slow t $ stack $ map (\(i, f) -> (fromIntegral i % l) `rotL` (_density t $ f (_slow t p))) (zip [0 ..] fs)- where l = fromIntegral $ length fs--{- |-(A function that takes two OscPatterns, and blends them together into-a new OscPattern. An OscPattern 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 :: ParamPattern -> ParamPattern -> ParamPattern-interlace a b = weave 16 (shape $ ((* 0.9) <$> sinewave1)) [a, b]---- | Step sequencing-step :: String -> String -> Pattern String-step s steps = fastcat $ map f steps- where f c | c == 'x' = atom s- | Char.isDigit c = atom $ s ++ ":" ++ [c]- | otherwise = silence--steps :: [(String, String)] -> Pattern String-steps = stack . map (\(a,b) -> step a b)---- | like `step`, but allows you to specify an array of strings to use for 0,1,2...-step' :: [String] -> String -> Pattern String-step' ss steps = fastcat $ map f steps- where f c | c == 'x' = atom $ head ss- | Char.isDigit c = atom $ ss!!(Char.digitToInt c)- | otherwise = silence--off :: Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-off tp f p = unwrap $ (\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--{- | `up` does a poor man's pitchshift by semitones via `speed`.--You can easily produce melodies from a single sample with up:--@-d1 # up "0 5 4 12" # sound "arpy"-@--This will play the _arpy_ sample four times a cycle in the original pitch, pitched by 5 semitones, by 4 and then by an octave.--}-up :: Pattern Double -> ParamPattern-up = speed . ((1.059466**) <$>)--ghost'' a f p = superimpose (((a*2.5) `rotR`) . f) $ superimpose (((a*1.5) `rotR`) . f) $ p-ghost' a p = ghost'' 0.125 ((|*| gain (pure 0.7)) . (|=| end (pure 0.2)) . (|*| speed (pure 1.25))) p-ghost p = ghost' 0.125 p---slice :: Pattern Int -> Pattern Int -> ParamPattern -> ParamPattern-slice pi pn p = begin b # end e # p- where b = (\i n -> (div' i n)) <$> pi <*> pn- e = (\i n -> (div' i n) + (div' 1 n)) <$> pi <*> pn- div' a b = fromIntegral (a `mod` b) / fromIntegral b--_slice :: Int -> Int -> ParamPattern -> ParamPattern-_slice i n p =- p- # begin (pure $ fromIntegral i / fromIntegral n)- # end (pure $ fromIntegral (i+1) / fromIntegral n)--randslice :: Int -> ParamPattern -> ParamPattern-randslice n p = unwrap $ (\i -> _slice i n 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 -> ParamPattern -> ParamPattern-loopAt n p = slow n p |*| speed (fromRational <$> (1/n)) # unit (pure "c")---{- |- 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 n p p' = stack [maskedWarp n p,- maskedWeft n p'- ]- where- weft n = concatMap (\x -> [[0..n-1],(reverse [0..n-1])]) [0 .. (n `div` 2) - 1]- warp = transpose . weft- thread xs n p = _slow (n%1) $ fastcat $ map (\i -> zoom (i%n,(i+1)%n) p) (concat xs)- weftP n p = thread (weft n) n p- warpP n p = thread (warp n) n p- maskedWeft n p = Sound.Tidal.Pattern.mask (every 2 rev $ _density ((n)%2) "~ 1" :: Pattern Int) $ weftP n p- maskedWarp n p = mask (every 2 rev $ _density ((n)%2) "1 ~" :: Pattern Int) $ warpP n p--hurry :: Pattern Rational -> ParamPattern -> ParamPattern-hurry x = (|*| speed (fromRational <$> x)) . fast x
− Sound/Tidal/Stream.hs
@@ -1,329 +0,0 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, RankNTypes, NoMonomorphismRestriction, DeriveDataTypeable #-}--module Sound.Tidal.Stream where--import Data.Maybe-import Control.Applicative-import Control.Concurrent-import Control.Concurrent.MVar-import Control.Exception as E-import Data.Time (getCurrentTime)-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)-import Data.Ratio-import Data.Typeable-import Sound.Tidal.Pattern-import qualified Sound.Tidal.Parse as P-import Sound.Tidal.Tempo (Tempo, logicalTime, clockedTick,cps)-import Sound.Tidal.Utils-import qualified Sound.Tidal.Time as T-import System.IO (stderr, hPutStrLn)--import qualified Data.Map.Strict as Map--type ToMessageFunc = Shape -> Tempo -> Int -> (Double, Double, ParamMap) -> Maybe (IO ())--data Backend a = Backend {- toMessage :: ToMessageFunc,- flush :: Shape -> Tempo -> Int -> IO ()- }--data Param = S {name :: String, sDefault :: Maybe String}- | F {name :: String, fDefault :: Maybe Double}- | I {name :: String, iDefault :: Maybe Int}- deriving Typeable--instance Eq Param where- a == b = name a == name b--instance Ord Param where- compare a b = compare (name a) (name b)-instance Show Param where- show p = name p---data Shape = Shape {params :: [Param],- latency :: Double,- cpsStamp :: Bool}---data Value = VS { svalue :: String } | VF { fvalue :: Double } | VI { ivalue :: Int }- deriving (Eq,Ord,Typeable)--instance Show Value where- show (VS s) = s- show (VF f) = show f- show (VI i) = show i--class ParamType a where- fromV :: Value -> Maybe a- toV :: a -> Value--instance ParamType String where- fromV (VS s) = Just s- fromV _ = Nothing- toV s = VS s--instance ParamType Double where- fromV (VF f) = Just f- fromV _ = Nothing- toV f = VF f--instance ParamType Int where- fromV (VI i) = Just i- fromV _ = Nothing- toV i = VI i--type ParamMap = Map.Map Param Value--type ParamPattern = Pattern ParamMap--ticksPerCycle = 8--defaultValue :: Param -> Value-defaultValue (S _ (Just x)) = VS x-defaultValue (I _ (Just x)) = VI x-defaultValue (F _ (Just x)) = VF x--hasDefault :: Param -> Bool-hasDefault (S _ Nothing) = False-hasDefault (I _ Nothing) = False-hasDefault (F _ Nothing) = False-hasDefault _ = True--defaulted :: Shape -> [Param]-defaulted = filter hasDefault . params--defaultMap :: Shape -> ParamMap-defaultMap s- = Map.fromList $ map (\x -> (x, defaultValue x)) (defaulted s)--required :: Shape -> [Param]-required = filter (not . hasDefault) . params--hasRequired :: Shape -> ParamMap -> Bool-hasRequired s m = isSubset (required s) (Map.keys m)--isSubset :: (Eq a) => [a] -> [a] -> Bool-isSubset xs ys = all (\x -> elem x ys) xs---doAt t action = do _ <- forkIO $ do- now <- getCurrentTime- let nowf = realToFrac $ utcTimeToPOSIXSeconds now- threadDelay $ floor $ (t - nowf) * 1000000- action- return ()--logicalOnset' change tick o offset = logicalNow + (logicalPeriod * o) + offset- where- tpc = fromIntegral ticksPerCycle- cycleD = ((fromIntegral tick) / tpc) :: Double- logicalNow = logicalTime change cycleD- logicalPeriod = (logicalTime change (cycleD + (1/tpc))) - logicalNow---applyShape' :: Shape -> ParamMap -> Maybe ParamMap-applyShape' s m | hasRequired s m = Just $ Map.union m (defaultMap s)- | otherwise = Nothing--start :: Backend a -> Shape -> IO (MVar (ParamPattern))-start backend shape- = do patternM <- newMVar silence- let ot = (onTick backend shape patternM) :: Tempo -> Int -> IO ()- forkIO $ clockedTick ticksPerCycle ot- return patternM---- variant of start where history of patterns is available-state :: Backend a -> Shape -> IO (MVar (ParamPattern, [ParamPattern]))-state backend shape- = do patternsM <- newMVar (silence, [])- let ot = (onTick' backend shape patternsM) :: Tempo -> Int -> IO ()- forkIO $ clockedTick ticksPerCycle ot- return patternsM--stream :: Backend a -> Shape -> IO (ParamPattern -> IO ())-stream backend shape- = do patternM <- start backend shape- return $ \p -> do swapMVar patternM p- return ()--streamcallback :: (ParamPattern -> IO ()) -> Backend a -> Shape -> IO (ParamPattern -> IO ())-streamcallback callback backend shape- = do f <- stream backend shape- let f' p = do callback p- f p- return f'--onTick :: Backend a -> Shape -> MVar (ParamPattern) -> Tempo -> Int -> IO ()-onTick backend shape patternM change ticks- = do p <- readMVar patternM- let ticks' = (fromIntegral ticks) :: Integer- a = ticks' % ticksPerCycle- b = (ticks' + 1) % ticksPerCycle- messages = mapMaybe- (toMessage backend shape change ticks)- (seqToRelOnsetDeltas (a, b) p)- E.catch (sequence_ messages) (\msg -> hPutStrLn stderr $ "failed " ++ show (msg :: E.SomeException))- flush backend shape change ticks- return ()---- Variant where mutable variable contains list as history of the patterns-onTick' :: Backend a -> Shape -> MVar (ParamPattern, [ParamPattern]) -> Tempo -> Int -> IO ()-onTick' backend shape patternsM change ticks- = do ps <- readMVar patternsM- let ticks' = (fromIntegral ticks) :: Integer- toM = (toMessage backend)- a = ticks' % ticksPerCycle- b = (ticks' + 1) % ticksPerCycle- messages = mapMaybe- (toM shape change ticks)- (seqToRelOnsetDeltas (a, b) $ fst ps)- E.catch (sequence_ messages) (\msg -> putStrLn $ "oops " ++ show (msg :: E.SomeException))- flush backend shape change ticks- return ()--make :: (a -> Value) -> Shape -> String -> Pattern a -> ParamPattern-make toValue s nm p = fmap (\x -> Map.singleton nParam (defaultV x)) p- where nParam = param s nm- defaultV a = toValue a- --defaultV Nothing = defaultValue nParam--make' :: ParamType a => (a -> Value) -> Param -> Pattern a -> ParamPattern-make' toValue par p = fmap (\x -> Map.singleton par (toValue x)) p--makeP :: ParamType a => Param -> Pattern a -> ParamPattern-makeP par p = coerce par $ fmap (\x -> Map.singleton par (toV x)) p--makeS = make VS--makeF :: Shape -> String -> Pattern Double -> ParamPattern-makeF = make VF--makeI :: Shape -> String -> Pattern Int -> ParamPattern-makeI = make VI--param :: Shape -> String -> Param-param shape n = head $ filter (\x -> name x == n) (params shape)--merge :: ParamPattern -> ParamPattern -> ParamPattern-merge x y = (flip Map.union) <$> x <*> y--infixl 1 |=|-(|=|) :: ParamPattern -> ParamPattern -> ParamPattern-(|=|) = merge--infixl 1 #-(#) = (|=|)--mergeWith op x y = (Map.unionWithKey op) <$> x <*> y--mergeWith- :: (Ord k, Applicative f) =>- (k -> a -> a -> a)- -> f (Map.Map k a) -> f (Map.Map k a) -> f (Map.Map k a)--mergeNumWith intOp floatOp = mergeWith f- where f (F _ _) (VF a) (VF b) = VF $ floatOp a b- f (I _ _) (VI a) (VI b) = VI $ intOp a b- f _ _ b = b--mergePlus = mergeWith f- where f (F _ _) (VF a) (VF b) = VF $ a + b- f (I _ _) (VI a) (VI b) = VI $ a + b- f (S _ _) (VS a) (VS b) = VS $ a ++ b- f _ _ b = b--infixl 1 |*|-(|*|) :: ParamPattern -> ParamPattern -> ParamPattern-(|*|) = mergeNumWith (*) (*)--infixl 1 |+|-(|+|) :: ParamPattern -> ParamPattern -> ParamPattern-(|+|) = mergePlus--infixl 1 |-|-(|-|) :: ParamPattern -> ParamPattern -> ParamPattern-(|-|) = mergeNumWith (-) (-)--infixl 1 |/|-(|/|) :: ParamPattern -> ParamPattern -> ParamPattern-(|/|) = mergeNumWith (div) (/)--{- | These are shorthand for merging lists of patterns with @#@, @|*|@, @|+|@,-or @|/|@. Sometimes this saves a little typing and can improve readability-when passing things into other functions. As an example, instead of writing-@-d1 $ sometimes ((|*| speed "2") . (|*| cutoff "2") . (|*| shape "1.5")) $ sound "arpy*4" # cutoff "350" # shape "0.3"-@-you can write-@-d1 $ sometimes (*** [speed "2", cutoff "2", shape "1.5"]) $ sound "arpy*4" ### [cutoff "350", shape "0.3"]-@--}-(###) = foldl (#)-(***) = foldl (|*|)-(+++) = foldl (|+|)-(///) = foldl (|/|)--setter :: MVar (a, [a]) -> a -> IO ()-setter ds p = do ps <- takeMVar ds- putMVar ds $ (p, p:snd ps)- return ()--{- | Copies values from one parameter to another. Used by @nToOrbit@ in @Sound.Tidal.Dirt@. -}--copyParam:: Param -> Param -> ParamPattern -> ParamPattern-copyParam fromParam toParam pat = f <$> pat- where f m = maybe m (updateValue m) (Map.lookup fromParam m)- updateValue m v = Map.union m (Map.fromList [(toParam,v)])--get :: ParamType a => Param -> ParamPattern -> Pattern a-get param p = filterJust $ fromV <$> (filterJust $ Map.lookup param <$> p)--getI :: Param -> ParamPattern -> Pattern Int-getI = get-getF :: Param -> ParamPattern -> Pattern Double-getF = get-getS :: Param -> ParamPattern -> Pattern String-getS = get--with :: (ParamType a) => Param -> (Pattern a -> Pattern a) -> ParamPattern -> ParamPattern-with param f p = p # (makeP param) ((\x -> f (get param x)) p)-withI :: Param -> (Pattern Int -> Pattern Int) -> ParamPattern -> ParamPattern-withI = with-withF :: Param -> (Pattern Double -> Pattern Double) -> ParamPattern -> ParamPattern-withF = with-withS :: Param -> (Pattern String -> Pattern String) -> ParamPattern -> ParamPattern-withS = with--follow :: (ParamType a, ParamType b) => Param -> Param -> (Pattern a -> Pattern b) -> ParamPattern -> ParamPattern-follow source dest f p = p # (makeP dest $ f (get source p))---- follow :: ParamType a => Param -> (Pattern a -> ParamPattern) -> ParamPattern -> ParamPattern--- follow source dest p = p # (dest $ get source p)--follow' :: ParamType a => Param -> Param -> (Pattern a -> Pattern a) -> ParamPattern -> ParamPattern-follow' source dest f p = p # (makeP dest $ f (get source p))--followI :: Param -> Param -> (Pattern Int -> Pattern Int) -> ParamPattern -> ParamPattern-followI = follow'-followF :: Param -> Param -> (Pattern Double -> Pattern Double) -> ParamPattern -> ParamPattern-followF = follow'-followS :: Param -> Param -> (Pattern String -> Pattern String) -> ParamPattern -> ParamPattern-followS = follow'---- with :: ParamType a => Param -> (Pattern a -> Pattern a) -> ParamPattern -> ParamPattern--- with source f p = p # (makeP source $ f (get source p))-coerce :: Param -> ParamPattern -> ParamPattern-coerce par@(S _ _) p = (Map.update f par) <$> p- where f (VS s) = Just (VS s)- f (VI i) = Just (VS $ show i)- f (VF f) = Just (VS $ show f)-coerce par@(I _ _) p = (Map.update f par) <$> p- where f (VS s) = Just (VI $ read s)- f (VI i) = Just (VI i)- f (VF f) = Just (VI $ floor f)-coerce par@(F _ _) p = (Map.update f par) <$> p- where f (VS s) = Just (VF $ read s)- f (VI i) = Just (VF $ fromIntegral i)- f (VF f) = Just (VF f)
− Sound/Tidal/SuperCollider.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}--module Sound.Tidal.SuperCollider where--import Sound.Tidal.Stream-import Sound.Tidal.Pattern-import Sound.Tidal.Parse-import Sound.OSC.Datum-import Sound.Tidal.OscStream--supercollider :: [Param] -> Double -> Shape-supercollider ps l = Shape {- params = ps,- cpsStamp = False,- latency = l- }--scSlang :: String -> OscSlang-scSlang n = OscSlang {- -- The OSC path- path = "/s_new",- preamble = [string n, int32 (-1), int32 1, int32 1],- namedParams = True,- timestamp = BundleStamp- }--scBackend :: String -> IO (Backend a)-scBackend n = do- s <- makeConnection "127.0.0.1" 57110 (scSlang n)- return $ Backend s (\_ _ _ -> return ())--scStream :: String -> [Param] -> Double -> IO (ParamPattern -> IO (), Shape)-scStream n ps l = do let shape = (supercollider ps l)- backend <- scBackend n- sc <- stream backend shape- return (sc, shape)
− Sound/Tidal/Tempo.hs
@@ -1,341 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Sound.Tidal.Tempo where--import Data.Time (getCurrentTime, UTCTime, NominalDiffTime, diffUTCTime, addUTCTime)-import Data.Time.Clock.POSIX-import Control.Applicative ((<$>), (<*>))-import Control.Monad (forM_, forever, void)---import Control.Monad.IO.Class (liftIO)-import Control.Concurrent (forkIO, threadDelay)-import Control.Concurrent.MVar-import Control.Monad.Trans (liftIO)-import Data.Maybe (fromMaybe, maybe, isJust, fromJust)-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import Data.Unique-import qualified Network.WebSockets as WS-import qualified Control.Exception as E-import Safe (readNote)-import System.Environment (lookupEnv)-import qualified System.IO.Error as Error-import GHC.Conc.Sync (ThreadId)-import Sound.OSC.Datum.Datem-import Sound.OSC.FD--import Sound.Tidal.Utils--data Tempo = Tempo {at :: UTCTime, beat :: Double, cps :: Double, paused :: Bool, clockLatency :: Double}--type ClientState = [TConnection]--data ServerMode = Master- | Slave UDP--instance Show ServerMode where- show Master = "Master"- show _ = "Slave"--data TConnection = TConnection Unique WS.Connection--wsConn :: TConnection -> WS.Connection-wsConn (TConnection _ c) = c--instance Eq TConnection where- TConnection a _ == TConnection b _ = a == b--instance Show Tempo where- show x = show (at x) ++ "," ++ show (beat x) ++ "," ++ show (cps x) ++ "," ++ show (paused x) ++ "," ++ (show $ clockLatency x)--getLatency :: IO Double-getLatency =- maybe 0.04 (readNote "latency parse") <$> lookupEnv "TIDAL_CLOCK_LATENCY"--getClockIp :: IO String-getClockIp = fromMaybe "127.0.0.1" <$> lookupEnv "TIDAL_TEMPO_IP"--getServerPort :: IO Int-getServerPort =- maybe 9160 (readNote "port parse") <$> lookupEnv "TIDAL_TEMPO_PORT"--getMasterPort :: IO Int-getMasterPort =- maybe 6042 (readNote "port parse") <$> lookupEnv "TIDAL_MASTER_PORT"--getSlavePort :: IO Int-getSlavePort =- maybe 6043 (readNote "port parse") <$> lookupEnv "TIDAL_SLAVE_PORT"--readTempo :: String -> Tempo-readTempo x = Tempo (read a) (read b) (read c) (read d) (read e)- where (a:b:c:d:e:_) = wordsBy (== ',') x---- given a Tempo and a cycle position (aka "a beat")--- returns the POSIX time of that cycle position (aka beat)-logicalTime :: Tempo -> Double -> Double-logicalTime t b = changeT + timeDelta- where beatDelta = b - (beat t)- timeDelta = beatDelta / (cps t)- changeT = realToFrac $ utcTimeToPOSIXSeconds $ at t----- beatNow: accesses a clock and returns the time now in terms of--- beats relative to metrical grid of a given Tempo-beatNow :: Tempo -> IO (Double)-beatNow t = do now <- getCurrentTime- let delta = realToFrac $ diffUTCTime now (at t)- let beatDelta = cps t * delta- return $ beat t + beatDelta---- getCurrentBeat: given current Tempo grid, gets the current beat-getCurrentBeat :: MVar Tempo -> IO Rational-getCurrentBeat t = (readMVar t) >>= (beatNow) >>= (return . toRational)--clientApp :: MVar Tempo -> MVar Double -> MVar Double -> WS.ClientApp ()-clientApp mTempo mCps mNudge conn = do- liftIO $ forkIO $ sendCps conn mCps- liftIO $ forkIO $ sendNudge conn mNudge- forever loop- where- loop = do- msg <- WS.receiveData conn- let s = T.unpack msg- let tempo = readTempo $ s- old <- liftIO $ tryTakeMVar mTempo- -- putStrLn $ "from: " ++ show old- -- putStrLn $ "to: " ++ show tempo- liftIO $ putMVar mTempo tempo--sendTempo :: [WS.Connection] -> Tempo -> IO ()-sendTempo conns t = mapM_ (\conn -> WS.sendTextData conn (T.pack $ show t)) conns--sendCps :: WS.Connection -> MVar Double -> IO ()-sendCps conn mCps = forever $ do cps <- takeMVar mCps- let m = "cps " ++ (show cps)- WS.sendTextData conn (T.pack m)--sendNudge :: WS.Connection -> MVar Double -> IO ()-sendNudge conn mNudge = forever $ do nudge <- takeMVar mNudge- let m = "nudge " ++ (show nudge)- WS.sendTextData conn (T.pack m)--connectClient :: Bool -> String -> MVar Tempo -> MVar Double -> MVar Double -> IO ()-connectClient secondTry ip mTempo mCps mNudge = do- let errMsg = "Failed to connect to tidal server. Try specifying a " ++- "different port (default is 9160) setting the " ++- "environment variable TIDAL_TEMPO_PORT"- serverPort <- getServerPort- WS.runClient ip serverPort "/tempo" (clientApp mTempo mCps mNudge) `E.catch`- \(_ :: E.SomeException) -> do- case secondTry of- True -> error errMsg- _ -> do- res <- E.try (void startServer)- case res of- Left (_ :: E.SomeException) -> error errMsg- Right _ -> do- threadDelay 500000- connectClient True ip mTempo mCps mNudge--runClient :: IO ((MVar Tempo, MVar Double, MVar Double))-runClient =- do clockip <- getClockIp- mTempo <- newEmptyMVar- mCps <- newEmptyMVar- mNudge <- newEmptyMVar- forkIO $ connectClient False clockip mTempo mCps mNudge- return (mTempo, mCps, mNudge)--cpsUtils' :: IO ((Double -> IO (), (Double -> IO ()), IO Rational))-cpsUtils' = do (mTempo, mCps, mNudge) <- runClient- let cpsSetter = putMVar mCps- nudger = putMVar mNudge- currentTime = do tempo <- readMVar mTempo- now <- beatNow tempo- return $ toRational now- return (cpsSetter, nudger, currentTime)---- backward compatibility-cpsUtils = do (cpsSetter, _, currentTime) <- cpsUtils'- return (cpsSetter, currentTime)---- Backwards compatibility-bpsUtils :: IO ((Double -> IO (), IO (Rational)))-bpsUtils = cpsUtils--cpsSetter :: IO (Double -> IO ())-cpsSetter = do (f, _) <- cpsUtils- return f--clocked :: (Tempo -> Int -> IO ()) -> IO ()-clocked = clockedTick 1- -clockedTick :: Int -> (Tempo -> Int -> IO ()) -> IO ()-clockedTick tpb callback =- do (mTempo, _, mCps) <- runClient- t <- readMVar mTempo- now <- getCurrentTime- let delta = realToFrac $ diffUTCTime now (at t)- beatDelta = cps t * delta- nowBeat = beat t + beatDelta- nextTick = ceiling (nowBeat * (fromIntegral tpb))- -- next4 = nextBeat + (4 - (nextBeat `mod` 4))- loop mTempo nextTick- where loop mTempo tick =- do tempo <- readMVar mTempo- tick' <- doTick tempo tick- loop mTempo tick'- doTick tempo tick | paused tempo =- do let pause = 0.01- -- TODO - do this via blocking read on the mvar somehow- -- rather than polling- threadDelay $ floor (pause * 1000000)- -- reset tick to 0 if cps is negative- return $ if cps tempo < 0 then 0 else tick- | otherwise =- do now <- getCurrentTime- let tps = (fromIntegral tpb) * cps tempo- delta = realToFrac $ diffUTCTime now (at tempo)- actualTick = ((fromIntegral tpb) * beat tempo) + (tps * delta)- -- only wait by up to two ticks- tickDelta = min 2 $ (fromIntegral tick) - actualTick- delay = tickDelta / tps- -- putStrLn $ "tick delta: " ++ show tickDelta- --putStrLn ("Delay: " ++ show delay ++ "s Beat: " ++ show (beat tempo))- threadDelay $ floor (delay * 1000000)- callback tempo tick- -- putStrLn $ "hmm diff: " ++ show (abs $ (floor actualTick) - tick)- let newTick | (abs $ (floor actualTick) - tick) > 4 = floor actualTick- | otherwise = tick + 1- return $ newTick--updateTempo :: Tempo -> Double -> IO (Tempo)-updateTempo t cps'- | paused t == True && cps' > 0 =- -- unpause- do now <- getCurrentTime- return $ t {at = addUTCTime (realToFrac $ clockLatency t) now, cps = cps', paused = False}- | otherwise =- do now <- getCurrentTime- let delta = realToFrac $ diffUTCTime now (at t)- beat' = (beat t) + ((cps t) * delta)- beat'' = if cps' < 0 then 0 else beat'- return $ t {at = now, beat = beat'', cps = cps', paused = (cps' <= 0)}--nudgeTempo :: Tempo -> Double -> Tempo-nudgeTempo t secs = t {at = addUTCTime (realToFrac secs) (at t)}--removeClient :: TConnection -> ClientState -> ClientState-removeClient client = filter (/= client)--broadcast :: Text -> ClientState -> IO ()-broadcast message clients = do- -- T.putStrLn message- forM_ clients $ \conn -> WS.sendTextData (wsConn conn) $ message--startServer :: IO (ThreadId)-startServer = do- serverPort <- getServerPort- start <- getCurrentTime- l <- getLatency- tempoState <- newMVar (Tempo start 0 1 False l)- clientState <- newMVar []- serverState <- newMVar Master- --liftIO $ oscBridge clientState- liftIO $ slave serverState clientState- forkIO $ WS.runServer "0.0.0.0" serverPort $ serverApp tempoState serverState clientState--serverApp :: MVar Tempo -> MVar ServerMode -> MVar ClientState -> WS.ServerApp-serverApp tempoState serverState clientState pending = do- conn <- TConnection <$> newUnique <*> WS.acceptRequest pending- tempo <- liftIO $ readMVar tempoState- liftIO $ WS.sendTextData (wsConn conn) $ T.pack $ show tempo- clients <- liftIO $ readMVar clientState- liftIO $ modifyMVar_ clientState $ return . (conn:)- serverLoop conn tempoState serverState clientState--slave :: MVar ServerMode -> MVar ClientState -> IO ()-slave serverState clientState =- do slavePort <- getSlavePort- slaveSock <- udpServer "127.0.0.1" (fromIntegral slavePort)- _ <- forkIO $ loop slaveSock- return ()- where loop slaveSock =- do ms <- recvMessages slaveSock- mapM_ (\m -> slaveAct (messageAddress m) serverState clientState m) ms- loop slaveSock--slaveAct :: String -> MVar ServerMode -> MVar ClientState -> Message -> IO ()-slaveAct "/tempo" serverState clientState m- | isJust t = do clients <- readMVar clientState- setSlave serverState- sendTempo (map wsConn clients) (fromJust t)- | otherwise = return ()- where t = do beat' <- datum_floating $ (messageDatum m) !! 2- cps' <- datum_floating $ (messageDatum m) !! 3- return $ Tempo {at = ut,- beat = beat',- cps = cps',- paused = False,- clockLatency = 0- }- ut = addUTCTime (realToFrac $ dsec) ut_epoch- sec = fromJust $ datum_int32 $ (messageDatum m) !! 0- usec = fromJust $ datum_int32 $ (messageDatum m) !! 1- dsec = ((fromIntegral sec) + ((fromIntegral usec) / 1000000)) :: Double--setSlave :: MVar ServerMode -> IO ()-setSlave serverState = do s <- takeMVar serverState- s' <- updateState s- putMVar serverState s'- return ()- where updateState Master = do putStrLn "Slaving tempo.."- masterPort <- getMasterPort- sock <- openUDP "127.0.0.1" (fromIntegral masterPort)- return (Slave sock)- -- already slaving..- updateState s = return s- -serverLoop :: TConnection -> MVar Tempo -> MVar ServerMode -> MVar ClientState -> IO ()-serverLoop conn tempoState serverState clientState = E.handle catchDisconnect $- forever $ do- msg <- WS.receiveData $ wsConn conn- --liftIO $ updateTempo tempoState $ maybeRead $ T.unpack msg- mode <- readMVar serverState- serverAct (T.unpack msg) mode tempoState clientState- -- - --tempo <- liftIO $ readMVar tempoState- -- liftIO $ readMVar clientState >>= broadcast (T.pack $ show tempo)- where- catchDisconnect e = case E.fromException e of- Just WS.ConnectionClosed -> liftIO $ modifyMVar_ clientState $ \s -> do- let s' = removeClient conn s- return s'- _ -> return ()--serverAct :: String -> ServerMode -> MVar Tempo -> MVar ClientState -> IO ()-serverAct ('c':'p':'s':' ':n) mode tempoState clientState = setCps (read n) mode tempoState clientState-serverAct ('n':'u':'d':'g':'e':' ':n) mode tempoState clientState = setNudge (read n) mode tempoState clientState-serverAct s _ _ _ = do putStrLn $ "tempo server received unknown message " ++ s- return ()--setCps :: Double -> ServerMode -> MVar Tempo -> MVar ClientState -> IO ()-setCps n Master tempoState clientState = do tempo <- takeMVar tempoState- tempo' <- updateTempo tempo (n :: Double)- clients <- readMVar clientState- sendTempo (map wsConn clients) (tempo')- putMVar tempoState tempo'- return ()- -setCps n (Slave sock) tempoState clientState = sendOSC sock $ Message "/cps" [Float (realToFrac n)]---setNudge :: Double -> ServerMode -> MVar Tempo -> MVar ClientState -> IO ()-setNudge n Master tempoState clientState = do tempo <- takeMVar tempoState- let tempo' = nudgeTempo tempo n- clients <- readMVar clientState- sendTempo (map wsConn clients) (tempo')- putMVar tempoState tempo'- return ()- -setNudge n (Slave sock) tempoState clientState = sendOSC sock $ Message "/nudge" [Float (realToFrac n)]
− Sound/Tidal/Time.hs
@@ -1,117 +0,0 @@-{-|-Module: Time-Description: Defines core data types and functions for handling tidal's concept of time in `Arc`s & `Event`s--}-module Sound.Tidal.Time where--import Sound.Tidal.Utils-import Data.Ratio---- | Time is represented by a rational number. Each natural number--- represents both the start of the next rhythmic cycle, and the end--- of the previous one. Rational numbers are used so that subdivisions--- of each cycle can be accurately represented.-type Time = Rational---- | @(s,e) :: Arc@ represents a time interval with a start and end value.--- @ { t : s <= t && t < e } @-type Arc = (Time, Time)---- | An Event is a value that occurs during the period given by the--- first @Arc@. The second one indicates the event's "domain of--- influence". These will often be the same, but many temporal--- transformations, such as rotation and scaling time, may result in--- arcs being split or truncated. In such cases, the first arc is--- preserved, but the second arc reflects the portion of the event--- which is relevant.-type Event a = (Arc, Arc, a)---- | The starting point of the current cycle. A cycle occurs from each--- natural number to the next, so this is equivalent to @floor@.-sam :: Time -> Time-sam = fromIntegral . floor---- | 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---- | @isIn a t@ is @True@ if @t@ is inside--- the arc represented by @a@.-isIn :: Arc -> Time -> Bool-isIn (s,e) t = t >= s && t < e---- | Splits the given @Arc@ into a list of @Arc@s, at cycle boundaries.-arcCycles :: Arc -> [Arc]-arcCycles (s,e) | s >= e = []- | sam s == sam e = [(s,e)]- | otherwise = (s, nextSam s) : (arcCycles (nextSam s, e))---- | Splits the given @Arc@ into a list of @Arc@s, at cycle boundaries, but wrapping the arcs within the same cycle.-arcCycles' :: Arc -> [Arc]-arcCycles' (s,e) | s >= e = []- | sam s == sam e = [(s,e)]- | otherwise = (s, nextSam s) : (arcCycles' ((nextSam s) - 1, e - 1))----- | @subArc i j@ is the arc that is the intersection of @i@ and @j@.-subArc :: Arc -> Arc -> Maybe Arc-subArc (s, e) (s',e') | s'' < e'' = Just (s'', e'')- | otherwise = Nothing- where s'' = max s s'- e'' = min e e'---- | Map the given function over both the start and end @Time@ values--- of the given @Arc@.-mapArc :: (Time -> Time) -> Arc -> Arc-mapArc f (s,e) = (f s, f e)---- | Similar to @mapArc@ but time is relative to the cycle (i.e. the--- sam of the start of the arc)-mapCycle :: (Time -> Time) -> Arc -> Arc-mapCycle f (s,e) = (sam' + (f $ s - sam'), sam' + (f $ e - sam'))- where sam' = sam s---- | Returns the `mirror image' of an @Arc@ around the given point intime, used by @Sound.Tidal.Pattern.rev@.-mirrorArc :: Time -> Arc -> Arc-mirrorArc mid (s, e) = (mid - (e-mid), mid+(mid-s))---- | The start time of the given @Event@-eventStart :: Event a -> Time-eventStart = fst . snd'---- | The original onset of the given @Event@-eventOnset :: Event a -> Time-eventOnset = fst . fst'---- | The original offset of the given @Event@-eventOffset :: Event a -> Time-eventOffset = snd . fst'---- | The arc of the given @Event@-eventArc :: Event a -> Arc-eventArc = snd'---- | The midpoint of an @Arc@-midPoint :: Arc -> Time-midPoint (s,e) = s + ((e - s) / 2)---- | `True` if an `Event`'s first and second `Arc`'s start times match-hasOnset :: Event a -> Bool-hasOnset ((s,_), (s',_), _) = s == s'---- | `True` if an `Event`'s first and second `Arc`'s end times match-hasOffset :: Event a -> Bool-hasOffset ((_,e), (_,e'), _) = e == e'---- | `True` if an `Event`'s starts is within given `Arc`-onsetIn :: Arc -> Event a -> Bool-onsetIn a e = isIn a (eventOnset e)---- | `True` if an `Event`'s ends is within given `Arc`-offsetIn :: Arc -> Event a -> Bool-offsetIn a e = isIn a (eventOffset e)
− Sound/Tidal/Transition.hs
@@ -1,129 +0,0 @@-module Sound.Tidal.Transition where--import Sound.Tidal.Stream-import Sound.Tidal.Pattern-import Sound.Tidal.Time-import Sound.Tidal.Params-import Sound.Tidal.Utils--import Control.Concurrent.MVar-import Control.Applicative-import Data.Maybe--import qualified Data.Map.Strict as Map-import Data.Monoid--transition :: (IO Time) -> MVar (ParamPattern, [ParamPattern]) -> (Time -> [ParamPattern] -> ParamPattern) -> ParamPattern -> IO ()-transition getNow mv f p =- do now <- getNow- ps <- takeMVar mv- let p' = f now (p:snd ps)- -- don't put the transition in history, only- -- the target pattern, or things get overcomplex- -- (transitions of transitions)- putMVar mv (p', (p:snd ps))- return ()---- | Pans the last n versions of the pattern across the field-histpan :: Int -> Time -> [ParamPattern] -> ParamPattern-histpan _ _ [] = silence-histpan 0 _ _ = silence-histpan n _ ps = stack $ map (\(i,p) -> p # pan (atom $ (fromIntegral i) / (fromIntegral n'))) (enumerate ps')- where ps' = take n ps- n' = length ps' -- in case there's fewer patterns than requested--{-|-A generalization of `wash`. 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.--}-superwash :: (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Time -> Time -> Time -> Time -> [Pattern a] -> Pattern a-superwash _ _ _ _ _ _ [] = silence-superwash _ _ _ _ _ _ (p:[]) = p-superwash fout fin delay durin durout now (p:p':_) =- stack [(playWhen (< (now + delay)) p'),- (playWhen (between (now + delay) (now + delay + durin)) $ fout p'),- (playWhen (between (now + delay + durin) (now + delay + durin + durout)) $ fin p),- (playWhen (>= (now + delay + durin + durout)) $ p)- ]- where- between lo hi x = (x >= lo) && (x < hi)--{-|-Wash away the current pattern by applying a function to it over time, then switching over to the next.--@-d1 $ sound "feel ! feel:1 feel:2"--t1 (wash (chop 8) 4) $ sound "feel*4 [feel:2 sn:2]"-@--Note that `chop 8` is applied to `sound "feel ! feel:1 feel:2"` for 4 cycles and then the whole pattern is replaced by `sound "feel*4 [feel:2 sn:2]`--}-wash :: (Pattern a -> Pattern a) -> Time -> Time -> [Pattern a] -> Pattern a-wash _ _ _ [] = silence-wash _ _ _ (p:[]) = p-wash f t now (p:p':_) = overlay (playWhen (< (now + t)) $ f p') (playWhen (>= (now + t)) p)----- | Just stop for a bit before playing new pattern-wait :: Time -> Time -> [ParamPattern] -> ParamPattern-wait _ _ [] = silence-wait t now (p:_) = playWhen (>= (nextSam (now+t-1))) p--{- | Just as `wait`, `wait'` stops for a bit and then applies the given transition to the playing pattern--@-d1 $ sound "bd"--t1 (wait' (xfadeIn 8) 4) $ sound "hh*8"-@--}-wait' :: (Time -> [ParamPattern] -> ParamPattern) -> Time -> Time -> [ParamPattern] -> ParamPattern-wait' _ t _ [] = silence-wait' f t now ps@(p:_) = playWhen (>= (nextSam (now+t-1))) (f (now + t) ps)---{- |-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 -> [ParamPattern] -> ParamPattern-jump = jumpIn 0--{- | Sharp `jump` transition after the specified number of cycles have passed.--@-t1 (jumpIn 2) $ sound "kick(3,8)"-@--}-jumpIn :: Int -> Time -> [ParamPattern] -> ParamPattern-jumpIn n = superwash id id (fromIntegral n) 0 0--{- | Unlike `jumpIn` the variant `jumpIn'` will only transition at cycle boundary (e.g. when the cycle count is an integer).--}-jumpIn' :: Int -> Time -> [ParamPattern] -> ParamPattern-jumpIn' n now = superwash id id ((nextSam now) - now + (fromIntegral n)) 0 0 now---- | Sharp `jump` transition at next cycle boundary where cycle mod n == 0-jumpMod :: Int -> Time -> [ParamPattern] -> ParamPattern-jumpMod n now = jumpIn ((n-1) - ((floor now) `mod` n)) now---- | Degrade the new pattern over time until it ends in silence-mortal :: Time -> Time -> Time -> [ParamPattern] -> ParamPattern-mortal _ _ _ [] = silence-mortal lifespan release now (p:_) = overlay (playWhen (<(now+lifespan)) p) (playWhen (>= (now+lifespan)) (fadeOut' (now + lifespan) release p))--combineV :: (Value -> Value -> Value) -> ParamMap -> ParamMap -> ParamMap-combineV f a b = Map.mapWithKey pairUp a- where pairUp k v | Map.notMember k b = v- | otherwise = f v (fromJust $ Map.lookup k b)--mixNums v (VF a) (VF b) = VF $ (a * v) + (b * (1-v))-mixNums v (VI a) (VI b) = VI $ floor $ (fromIntegral a * v) + (fromIntegral b * (1-v))-mixNums v _ b = b--interpolateIn :: Time -> Time -> [ParamPattern] -> ParamPattern-interpolateIn _ _ [] = silence-interpolateIn _ _ (p:[]) = p-interpolateIn t now (p:p':_) = do n <- now `rotR` (_slow t envL)- combineV (mixNums n) <$> p <*> p'
− Sound/Tidal/Utils.hs
@@ -1,104 +0,0 @@-{-|-Module: Utils-Description: Helper functions not directly specific to Tidal--}-module Sound.Tidal.Utils where--import Data.Maybe (listToMaybe)--{- | enumerate a list of things-->>> enumerate ["foo","bar","baz"]-[(1,"foo"), (2,"bar"), (3,"baz")]--}-enumerate :: [a] -> [(Int, a)]-enumerate = zip [0..]---- | apply @f@ to the first element of a tuple-mapFst :: (a -> b) -> (a, c) -> (b, c)-mapFst f (x,y) = (f x,y)---- | apply function to the first value of each tuple in given list-mapFsts :: (a -> b) -> [(a, c)] -> [(b, c)]-mapFsts = map . mapFst---- | apply @f@ to the second element of a tuple-mapSnd :: (a -> b) -> (c, a) -> (c, b)-mapSnd f (x,y) = (x,f y)---- | apply function to the second value of each tuple in given list-mapSnds :: (a -> b) -> [(c, a)] -> [(c, b)]-mapSnds = fmap . mapSnd---{- | 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--maybeRead :: String -> Maybe Double-maybeRead = fmap fst . listToMaybe . reads---- | shorthand for first element of triple-fst' (a, _, _) = a--- | shorthand for second element of triple-snd' (_, b, _) = b--- | shorthand for third element of triple-thd' (_, _, c) = c---- | apply @f@ to the first element of a triple-mapFst' :: (a -> x) -> (a, b, c) -> (x, b, c)-mapFst' f (x,y,z) = (f x,y,z)---- | apply @f@ to the second element of a triple-mapSnd' :: (b -> x) -> (a, b, c) -> (a, x, c)-mapSnd' f (x,y,z) = (x,f y,z)---- | apply @f@ to the third element of a triple-mapThd' :: (c -> x) -> (a, b, c) -> (a, b, x)-mapThd' f (x,y,z) = (x,y,f z)---- | apply function to the second value of each triple in given list-mapFsts' :: (a -> x) -> [(a, b, c)] -> [(x, b, c)]-mapFsts' = fmap . mapFst'---- | apply function to the second value of each triple in given list-mapSnds' :: (b -> x) -> [(a, b, c)] -> [(a, x, c)]-mapSnds' = fmap . mapSnd'---- | apply function to the third value of each triple in given list-mapThds' :: (c -> x) -> [(a, b, c)] -> [(a, b, x)]-mapThds' = fmap . mapThd'---- | map @f@ over a given list of arcs-mapArcs :: (a -> a) -> [(a, a, x)] -> [(a, a, x)]-mapArcs f = (mapFsts' f) . (mapSnds' f)--{- | combines two lists by interleaving them-->>> mergelists [1,2,3] [9,8,7]-[1,9,2,8,3,7]--}-mergelists :: [a] -> [a] -> [a]-mergelists xs [] = xs-mergelists [] ys = ys-mergelists (x:xs) (y:ys) = x : y : mergelists xs ys--{- | 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)--accumulate :: Num t => [t] -> [t]-accumulate = accumulate' 0- where accumulate' _ [] = []- accumulate' n (a:xs) = (n+a):(accumulate' (n+a) xs)
− Sound/Tidal/Version.hs
@@ -1,4 +0,0 @@--module Sound.Tidal.Version where--tidal_version = "0.9.10"
+ bench/Memory/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import Tidal.UIB+import Weigh++main :: IO ()+main =+ mainWith $ do+ euclidB+ fixB
+ bench/Memory/Tidal/Inputs.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}++module Tidal.Inputs where++import Sound.Tidal.Control (stut')+import Sound.Tidal.Core (cF, fromList, (#), (|*|))+import Sound.Tidal.Params+ ( coarse,+ crush,+ delay,+ delaytime,+ pF,+ s,+ speed,+ up,+ )+import Sound.Tidal.ParseBP ()+import Sound.Tidal.Pattern+ ( Arc,+ ArcF (Arc),+ ControlPattern,+ Pattern,+ Time,+ )+import Sound.Tidal.UI (fix)+import Weigh+ ( Column (Allocated, Case, GCs, Live, Max),+ Weigh,+ setColumns,+ )++columns :: Weigh ()+columns = setColumns [Case, Allocated, Max, Live, GCs]++{- Pattern inputs -}+xs3 :: [Time]+xs3 = [1 .. 10000]++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++catPattMedB :: [Pattern Time]+catPattMedB = pure <$> xs5++catPattBig :: [Pattern Time]+catPattBig = pure <$> xs6++timeCatMed :: [(Time, Pattern Time)]+timeCatMed = zip xs5 catPattMed++timeCatBig :: [(Time, Pattern Time)]+timeCatBig = zip xs6 catPattBig++appendBig :: [Pattern Time]+appendBig = pure <$> xsA++pattApp1 :: Pattern [Time]+pattApp1 = sequence catPattBig++pattApp2 :: Pattern [Time]+pattApp2 = sequence appendBig++{- Arc Inputs -}+arcFunc :: Arc -> Arc+arcFunc (Arc st en) = Arc (st * 2) (en * 4)++wqaMed :: Pattern Time+wqaMed = fromList xs5++wqaBig :: Pattern Time+wqaBig = fromList xs6++{- fix inputs -}+fixArg1 :: ControlPattern+fixArg1 = pF "cc64" 1++fixArg2 :: ControlPattern+fixArg2 =+ fix (# crush 4) (pF "cc65" 1) $+ fix (stut' 4 (0.125 / 4) (+ up "1")) (pF "cc66" 1) $+ fix (|*| speed "-1") (pF "cc67" 1) $+ fix ((# delaytime 0.125) . (# delay 0.5)) (pF "cc68" 1) $+ fix (# coarse 12) (pF "cc69" 1) $+ s "[808bd:1(3,8), dr(7,8)]"+ # pF "cc64" (cF 0 "64")+ # pF "cc65" (cF 0 "65")+ # pF "cc66" (cF 0 "66")+ # pF "cc67" (cF 0 "67")+ # pF "cc68" (cF 0 "68")+ # pF "cc69" (cF 0 "69")++{- Euclid inputs -}+ecA1 :: [Pattern Int]+ecA1 = [1, 1000000]++ecA2 :: Pattern String+ecA2 = "x"
+ bench/Memory/Tidal/UIB.hs view
@@ -0,0 +1,25 @@+module Tidal.UIB where++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 =+ 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) (ecA1 !! 1)) ecA2+ func "euclidFull" (euclidFull (head ecA1) (ecA1 !! 1) ecA2) ecA2+ func "euclidBool" (_euclidBool 1) 100000
+ bench/Speed/Main.hs view
@@ -0,0 +1,22 @@+module Main where++import Criterion.Main+import Tidal.CoreB+import Tidal.PatternB+import Tidal.UIB++patternBs :: [IO ()]+patternBs = defaultMain <$> [withQueryTimeB, withQueryArcB, withResultArcB, withQueryTimeB, subArcB]++coreBs :: [IO ()]+coreBs = defaultMain <$> [fromListB, stackB, appendB, concatB, _fastB]++uiBs :: [IO ()]+uiBs = defaultMain <$> [euclidB, fixB]++main :: IO ()+main = do+ _ <- sequence coreBs+ _ <- sequence patternBs+ _ <- sequence uiBs+ return ()
+ bench/Speed/Tidal/CoreB.hs view
@@ -0,0 +1,83 @@+module Tidal.CoreB where++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+ ( 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 :: 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+ ]+ ]++fromListB :: [Benchmark]+fromListB =+ [ bgroup+ "fromList"+ [ bench "fromList" $ whnf fromList xs6,+ bench "fromList nf" $ nf fromList xs6,+ bench "fastFromList 10^3" $ whnf fastFromList xs3,+ bench "fastFromList 10^4" $ whnf fastFromList xs4,+ bench "fastFromList 10^5" $ whnf fastFromList xs5,+ bench "fastFromList 10^6" $ whnf fastFromList xs6,+ bench "fastFromList 10^6 nf" $ nf fastFromList xs6+ ]+ ]++appendB :: [Benchmark]+appendB =+ [ bgroup+ "append"+ [ bench "append" $ whnf (append pattApp1) pattApp2,+ bench "fastAppend" $ whnf (fastAppend pattApp1) pattApp2+ ]+ ]++stackB :: [Benchmark]+stackB =+ [ bgroup+ "stack"+ [ bench "overlay" $ whnf (overlay pattApp1) pattApp2,+ bench "stack" $ whnf stack catPattBig+ ]+ ]
+ bench/Speed/Tidal/Inputs.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}++module Tidal.Inputs where++import Sound.Tidal.Core (cF, fromList, (#), (|*|))+import Sound.Tidal.Params+ ( coarse,+ crush,+ delay,+ delaytime,+ pF,+ s,+ speed,+ )+import Sound.Tidal.ParseBP ()+import Sound.Tidal.Pattern+ ( Arc,+ ArcF (Arc),+ ControlPattern,+ Pattern,+ Time,+ )+import Sound.Tidal.UI (fix)++{- Pattern inputs -}+xs3 :: [Time]+xs3 = [1 .. 10000]++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++catPattMedB :: [Pattern Time]+catPattMedB = pure <$> xs5++catPattBig :: [Pattern Time]+catPattBig = pure <$> xs6++timeCatMed :: [(Time, Pattern Time)]+timeCatMed = zip xs5 catPattMed++timeCatBig :: [(Time, Pattern Time)]+timeCatBig = zip xs6 catPattBig++appendBig :: [Pattern Time]+appendBig = pure <$> xsA++pattApp1 :: Pattern [Time]+pattApp1 = sequence catPattBig++pattApp2 :: Pattern [Time]+pattApp2 = sequence appendBig++{- Arc Inputs -}+arcFunc :: Arc -> Arc+arcFunc (Arc st en) = Arc (st * 2) (en * 4)++wqaMed :: Pattern Time+wqaMed = fromList xs5++wqaBig :: Pattern Time+wqaBig = fromList xs6++{- fix inputs -}+fixArg1 :: ControlPattern+fixArg1 = pF "cc64" 1++fixArg2 :: ControlPattern+fixArg2 =+ fix (# crush 4) (pF "cc65" 1)+ -- fix ( stut' 4 (0.125/4) ( + up "1" )) (pF "cc66" 1)+ $+ fix (|*| speed "-1") (pF "cc67" 1) $+ fix ((# delaytime 0.125) . (# delay 0.5)) (pF "cc68" 1) $+ fix (# coarse 12) (pF "cc69" 1) $+ s "[808bd:1(3,8), dr(7,8)]"+ # pF "cc64" (cF 0 "64")+ # pF "cc65" (cF 0 "65")+ # pF "cc66" (cF 0 "66")+ # pF "cc67" (cF 0 "67")+ # pF "cc68" (cF 0 "68")+ # pF "cc69" (cF 0 "69")++{- Euclid inputs -}+ecA1 :: [Pattern Int]+ecA1 = [1, 100]++ecA2 :: Pattern String+ecA2 = "x"
+ bench/Speed/Tidal/PatternB.hs view
@@ -0,0 +1,69 @@+module Tidal.PatternB where++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 :: 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)+ ]+ ]++withResultArcB :: [Benchmark]+withResultArcB =+ [ bgroup+ "withResultArc"+ [ bench "wqa med" $ whnf (withResultArc arcFunc) wqaMed,+ bench "wqa big" $ whnf (withResultArc arcFunc) wqaBig+ ]+ ]++withQueryArcB :: [Benchmark]+withQueryArcB =+ [ bgroup+ "withQueryArc"+ [ bench "wqa med" $ whnf (withQueryArc arcFunc) wqaMed,+ bench "wqa big" $ whnf (withQueryArc arcFunc) wqaBig+ ]+ ]++subArcB :: [Benchmark]+subArcB =+ [ bgroup+ "subArc"+ [ bench "intersecting" $ whnf (subArc arc1) arc2,+ bench "non-intersecting" $ whnf (subArc arc3) arc4+ ]+ ]++sectB :: Benchmark+sectB = bench "sect" $ whnf (sect arc1) arc2++hullB :: Benchmark+hullB = bench "hull" $ whnf (hull arc1) arc2
+ bench/Speed/Tidal/UIB.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}++module Tidal.UIB where++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+ ]+ ]++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+ ]+ ]
− doc/tidal.md
@@ -1,2 +0,0 @@-Documentation has now moved to the Tidal website:- http://tidal.lurk.org/
+ 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/Config.hs view
@@ -0,0 +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++{-+ 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,+ 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
@@ -0,0 +1,35 @@+module Sound.Tidal.Context (module C) where++{-+ Context.hs - For exposing the core TidalCycles libraries+ Copyright (C) 2020, Alex McLean and contributors++ This library is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This library is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this library. If not, see <http://www.gnu.org/licenses/>.+-}++import Data.Ratio 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.Show as C+import Sound.Tidal.Simple as C+import Sound.Tidal.Stepwise as C+import Sound.Tidal.Stream as C+import Sound.Tidal.Transition as C+import Sound.Tidal.UI as C+import Sound.Tidal.Version as C+import Prelude hiding (all, drop, take, (*>), (<*))
+ src/Sound/Tidal/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/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/Stream.hs view
@@ -0,0 +1,36 @@+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++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/Transition.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE BangPatterns #-}++module Sound.Tidal.Transition where++import Control.Concurrent.MVar (readMVar, swapMVar)+import qualified Data.Map.Strict as Map+-- import Data.Maybe (fromJust)++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.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 :: 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++-- | 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++_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++-- | 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++-- | 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)++-- |+-- 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++-- | 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++-- | 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++-- | 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 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++-- | 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))++_interpolate :: Time -> [ControlPattern] -> ControlPattern+_interpolate = _interpolateIn 4++_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++-- |+-- 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)++-- | 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++-- wash :: (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Time -> Time -> Time -> Time -> [Pattern a] -> Pattern a++-- | `anticipate` is an increasing comb filter.+--+-- Build up some tension, culminating in a _drop_ to the new pattern after 8 cycles.+_anticipate :: Time -> [ControlPattern] -> ControlPattern+_anticipate = _anticipateIn 8++-- Deprecated aliases+mortalOverlay :: Time -> Time -> [Pattern a] -> Pattern a+mortalOverlay = _mortalOverlay++wash ::+ (Pattern a -> Pattern a) ->+ (Pattern a -> Pattern a) ->+ Time ->+ Time ->+ Time ->+ Time ->+ [Pattern a] ->+ Pattern a+wash = _wash++washIn ::+ (Pattern a -> Pattern a) ->+ Time ->+ Time ->+ [Pattern a] ->+ Pattern a+washIn = _washIn++xfadeIn :: Time -> Time -> [ControlPattern] -> ControlPattern+xfadeIn = _xfadeIn++histpan :: Int -> Time -> [ControlPattern] -> ControlPattern+histpan = _histpan++wait :: Time -> Time -> [ControlPattern] -> ControlPattern+wait = _wait++waitT ::+ (Time -> [ControlPattern] -> ControlPattern) ->+ Time ->+ Time ->+ [ControlPattern] ->+ ControlPattern+waitT = _waitT++jump :: Time -> [ControlPattern] -> ControlPattern+jump = _jump++jumpIn :: Int -> Time -> [ControlPattern] -> ControlPattern+jumpIn = _jumpIn++jumpIn' :: Int -> Time -> [ControlPattern] -> ControlPattern+jumpIn' = _jumpIn'++jumpMod :: Int -> Time -> [ControlPattern] -> ControlPattern+jumpMod = _jumpMod++jumpMod' :: Int -> Int -> Time -> [ControlPattern] -> ControlPattern+jumpMod' = _jumpMod'++mortal ::+ Time -> Time -> Time -> [ControlPattern] -> ControlPattern+mortal = _mortal++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 = _anticipate
+ src/Sound/Tidal/Version.hs view
@@ -0,0 +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.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/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/Test.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}++import Sound.Tidal.StreamTest+import Test.Hspec++main :: IO ()+main = hspec $ do+ Sound.Tidal.StreamTest.run
+ test/TestUtils.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}++module TestUtils where++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 ((*>), (<*))++class TolerantEq a where+ (~==) :: a -> a -> Bool++instance TolerantEq Double where+ (~==) :: Double -> Double -> Bool+ a ~== b = abs (a - b) < 0.000001++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++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 -> 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, 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)++-- | Utility to create a pattern from a String+ps :: String -> Pattern String+ps = parseBP_E++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+ ]
− tests/test.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--import Test.Tasty--- import Test.Tasty.SmallCheck as SC--- import Test.Tasty.QuickCheck as QC-import Test.Tasty.HUnit--import Data.List-import Data.Ord--import Sound.Tidal.Context--main = defaultMain tests--tests :: TestTree-tests = testGroup "Tests" [basic1,- parser1- -- patternsOfPatterns- ]--basic1 = testGroup "fast / slow"- [- testCase "silence" $ same16 (fast 1.1 silence) (silence :: Pattern Double),- testCase "fast" $ same16 silence (silence :: Pattern Double),- testCase "fast2" $ same16 "bd*128" (rep 128 "bd")- ]--parser1 = testGroup "subpatterns"- [- testCase "square" $ same16 ("bd sn" :: Pattern String) ("[bd sn]" :: Pattern String)- ]--patternsOfPatterns =- testGroup "patterns of patterns"- [- testCase "decimal density" $ same16 (_discretise 0.25 saw) (discretise 0.25 saw)- ]--rep :: Int -> String -> Pattern String-rep n v = p $ intercalate " " $ take n $ repeat v--sameN :: (Eq a, Show a) => String -> Time -> Pattern a -> Pattern a -> Assertion-sameN s n a b = assertEqual s (arc a (0,n)) (arc b (0,n))--same16 :: (Eq a, Show a) => Pattern a -> Pattern a -> Assertion-same16 = sameN "for 16 cycles," 16-
tidal.cabal view
@@ -1,85 +1,134 @@+cabal-version: 2.0+ name: tidal-version: 0.9.10+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, 2017+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.1, GHC == 8.4.1--Extra-source-files: README.md CHANGELOG.md tidal.el doc/tidal.md+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 -Description: Tidal is a domain specific language for live coding pattern.+Extra-source-files: README.md CHANGELOG.md tidal.el library- if impl(ghc == 8.4.1)- cpp-options: -DTIDAL_SEMIGROUP+ ghc-options: -Wall+ hs-source-dirs:+ src default-language: Haskell2010 - Exposed-modules: Sound.Tidal.Bjorklund- Sound.Tidal.Strategies- Sound.Tidal.Dirt- Sound.Tidal.Pattern- Sound.Tidal.Stream- Sound.Tidal.OscStream- Sound.Tidal.Parse- Sound.Tidal.Tempo- Sound.Tidal.Time+ autogen-modules: Paths_tidal++ Exposed-modules: + Sound.Tidal.Boot+ Sound.Tidal.Config Sound.Tidal.Context- Sound.Tidal.Utils- Sound.Tidal.SuperCollider- Sound.Tidal.Params+ Sound.Tidal.ID+ Sound.Tidal.Safe.Context+ Sound.Tidal.Safe.Boot+ Sound.Tidal.Stream+ 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.EspGrid- Sound.Tidal.MultiMode- Sound.Tidal.Scales- Sound.Tidal.Chords- Sound.Tidal.Sieve Sound.Tidal.Version- Sound.Tidal.Simple- -- Sound.Tidal.PatternList-+ Paths_tidal Build-depends:- base < 5- , containers- , hashable- , colour- , hosc >= 0.16- , text- , mersenne-random-pure64- , time- , parsec- , safe- , websockets > 0.8- , mtl >= 2.1- , monad-loops+ base >=4.8 && <5+ , containers < 0.9+ , colour < 2.4+ , hosc >= 0.21 && < 0.22+ , text < 2.2+ , parsec >= 3.1.12 && < 3.2+ , network < 3.3+ , transformers >= 0.5 && < 0.7+ , bytestring < 0.13+ , clock < 0.9+ , 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 - if !impl(ghc >= 8.4.1)- build-depends: semigroups == 0.18.*+test-suite tests+ type: exitcode-stdio-1.0+ main-is: Test.hs+ hs-source-dirs:+ test+ ghc-options: -Wall+ other-modules:+ Sound.Tidal.StreamTest+ TestUtils+ build-depends:+ base >=4 && <5,+ hspec >=2.11.9,+ hosc >=0.21 && <0.22,+ containers,+ parsec,+ tidal,+ tidal-core,+ deepseq -source-repository head- type: git- location: https://github.com/tidalcycles/Tidal+ default-language: Haskell2010 -test-suite test- default-language:- Haskell2010- type:- exitcode-stdio-1.0- hs-source-dirs:- tests- main-is:- test.hs+-- 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+ hs-source-dirs: bench/Speed+ other-modules: Tidal.PatternB+ Tidal.CoreB+ Tidal.UIB+ Tidal.Inputs build-depends:- base >= 4 && < 5- , tasty - , tasty-hunit- , tidal+ 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+ other-modules: Tidal.UIB+ Tidal.Inputs+ build-depends:+ base >=4 && <5,+ weigh,+ tidal,+ tidal-core++ ghc-options: -Wall++ default-language: Haskell2010++source-repository head+ type: git+ 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,13 +33,13 @@ ;;; Code: - (require 'scheme) (require 'comint) (require 'thingatpt) (require 'find-lisp) (require 'pulse) (require 'haskell-mode)+(require 'subr-x) (defvar tidal-buffer "*tidal*"@@ -54,10 +54,25 @@ "*The version of tidal interpreter as a string.") (defvar tidal-interpreter-arguments- (list "-XOverloadedStrings"- )+ () "*Arguments to the haskell interpreter (default=none).") +(defvar tidal-boot-script-path+ (let ((filepath+ (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" . "\\")))+ ((or (string-equal system-type "darwin") (string-equal system-type "gnu/linux"))+ '(("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).")+ (defvar tidal-literate-p t "*Flag to indicate if we are in literate mode (default=t).")@@ -68,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)@@ -76,63 +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 ":set prompt \"\"")- (if (string< tidal-interpreter-version "8.2.0")- (tidal-send-string ":set prompt2 \"\"")- (tidal-send-string ":set prompt-cont \"\""))- (tidal-send-string ":module Sound.Tidal.Context")- (tidal-send-string "import qualified Sound.Tidal.Scales as Scales")- (tidal-send-string "import qualified Sound.Tidal.Chords as Chords")- (tidal-send-string "(cps, nudger, getNow) <- cpsUtils'")- (tidal-send-string "(d1,t1) <- superDirtSetters getNow")- (tidal-send-string "(d2,t2) <- superDirtSetters getNow")- (tidal-send-string "(d3,t3) <- superDirtSetters getNow")- (tidal-send-string "(d4,t4) <- superDirtSetters getNow")- (tidal-send-string "(d5,t5) <- superDirtSetters getNow")- (tidal-send-string "(d6,t6) <- superDirtSetters getNow")- (tidal-send-string "(d7,t7) <- superDirtSetters getNow")- (tidal-send-string "(d8,t8) <- superDirtSetters getNow")- (tidal-send-string "(d9,t9) <- superDirtSetters getNow")- (tidal-send-string "(d10,t10) <- superDirtSetters getNow")- (tidal-send-string "(c1,ct1) <- dirtSetters getNow")- (tidal-send-string "(c2,ct2) <- dirtSetters getNow")- (tidal-send-string "(c3,ct3) <- dirtSetters getNow")- (tidal-send-string "(c4,ct4) <- dirtSetters getNow")- (tidal-send-string "(c5,ct5) <- dirtSetters getNow")- (tidal-send-string "(c6,ct6) <- dirtSetters getNow")- (tidal-send-string "(c7,ct7) <- dirtSetters getNow")- (tidal-send-string "(c8,ct8) <- dirtSetters getNow")- (tidal-send-string "(c9,ct9) <- dirtSetters getNow")- (tidal-send-string "(c10,ct10) <- dirtSetters getNow")- (tidal-send-string "let bps x = cps (x/2)")- (tidal-send-string "let hush = mapM_ ($ silence) [c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,d1,d2,d3,d4,d5,d6,d7,d8,d9,d10]")- (tidal-send-string "let solo = (>>) hush")- (tidal-send-string ":set prompt \"tidal> \"")-)+ (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."@@ -140,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))@@ -150,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)))@@ -203,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."@@ -376,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")))@@ -494,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@@ -504,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