tidal 0.8 → 1.10.3
raw patch · 48 files changed
Files
- BootTidal.hs +27/−0
- CHANGELOG.md +645/−0
- LICENSE +2/−3
- README.md +8/−8
- Setup.hs +1/−0
- Sound/Tidal/Context.hs +0/−17
- Sound/Tidal/Dirt.hs +0/−299
- Sound/Tidal/OscStream.hs +0/−71
- Sound/Tidal/Params.hs +0/−280
- Sound/Tidal/Parse.hs +0/−272
- Sound/Tidal/Pattern.hs +0/−1068
- Sound/Tidal/Strategies.hs +0/−369
- Sound/Tidal/Stream.hs +0/−224
- Sound/Tidal/SuperCollider.hs +0/−33
- Sound/Tidal/Tempo.hs +0/−256
- Sound/Tidal/Time.hs +0/−117
- Sound/Tidal/Transition.hs +0/−85
- Sound/Tidal/Utils.hs +0/−107
- 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
- tidal.cabal +120/−21
- tidal.el +246/−308
+ 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
@@ -0,0 +1,645 @@++# 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`)+ +## 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.+* Added continuous function `cosine`+* Turned more pattern transformation parameters into patterns - spread', striateX, every', inside, outside, swing+* Added experimental datatype for Xenakis sieves+* Correctly parse negative rationals+* Added `breakUp` that finds events that share the same timespan, and spreads them out during that timespan, so for example (breakUp "[bd,sn]") gets turned into the "bd sn"+* Added `fill` which 'fills in' gaps in one pattern with events from another. ++## 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"])`+* New function `linger`, e.g. `linger (1/4)` will only play the first quarter of the given pattern, four times to fill the cycle. +* `discretise` now takes time value as its first parameter, not a pattern of time, which was causing problems and needs some careful thought.+* a `rel` alias for the `release` parameter, to match the `att` alias for `attack`+* `_fast` alias for `_density`+* 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,13 +1,13 @@-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:- http://tidal.lurk.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/Context.hs
@@ -1,17 +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.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.SuperCollider as C-import Sound.Tidal.Params as C-import Sound.Tidal.Transition as C
− Sound/Tidal/Dirt.hs
@@ -1,299 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-module Sound.Tidal.Dirt where--import Sound.OSC.FD (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 System.Process--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)--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- ],- cpsStamp = True,- latency = 0.04- }--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) <- bpsUtils- 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 (maybe black datumToColour) (Map.lookup (param dirt "sound") x)) p--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 :: Int -> ParamPattern -> ParamPattern-striate n p = cat $ 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' :: Int -> Double -> ParamPattern -> ParamPattern-striate' n f p = cat $ 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)--{- | _not sure what this does_, variant of `striate` -}-striateO :: ParamPattern -> Int -> Double -> ParamPattern-striateO p n o = cat $ map (\x -> off (fromIntegral x) p) [0 .. n-1]- where off i p = p # begin ((atom $ (fromIntegral i / fromIntegral n) + o) :: Pattern Double) # end ((atom $ (fromIntegral (i+1) / fromIntegral n) + 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 :: 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]")--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)--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 ~> (slow t envEqR))) (p' |*| gain (now ~> (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 :: Integer -> Double -> Rational -> ParamPattern -> ParamPattern-stut steps feedback time p = stack (p:(map (\x -> (((x%steps)*time) ~> (p |*| gain (pure $ scale (fromIntegral x))))) [1..(steps-1)]))- where scale x- = ((+feedback) . (*(1-feedback)) . (/(fromIntegral steps)) . ((fromIntegral steps)-)) x--{- | _not sure what this does_, variant of `stut`--}-stut' :: Integer -> Time -> (ParamPattern -> ParamPattern) -> ParamPattern -> ParamPattern-stut' steps steptime f p | steps <= 0 = p- | otherwise = overlay (f (steptime ~> stut' (steps-1) steptime f p)) 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 ~> (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
− Sound/Tidal/OscStream.hs
@@ -1,71 +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 (Maybe Datum)--toOscDatum :: Value -> Maybe Datum-toOscDatum (VF x) = Just $ float x-toOscDatum (VI x) = Just $ int32 x-toOscDatum (VS x) = Just $ string x--toOscMap :: ParamMap -> OscMap-toOscMap m = Map.map (toOscDatum) (Map.mapMaybe (id) 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 s slang shape change tick (o, 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, Just v) -> [string (name k), v] )- $ filter (isJust . snd) $ Map.assocs m)- | otherwise = oscPreamble ++ (catMaybes $ mapMaybe (\x -> Map.lookup x m) (params shape))- cpsPrefix | cpsStamp shape && namedParams slang = [string "cps", float (cps change)]- | cpsStamp shape = [float (cps change)]- | otherwise = []- parameterise ds = mergelists (map (string . name) (params shape)) ds- usec = floor $ 1000000 * (logicalOnset - (fromIntegral sec))- sec = floor logicalOnset- logicalOnset = logicalOnset' change tick o ((latency shape) + nudge)- nudge = maybe 0 (toF) (Map.lookup nudge_p m)- toF (Just (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 (o,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 (o,m'')- )
− Sound/Tidal/Params.hs
@@ -1,280 +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--make' :: (a -> Value) -> Param -> Pattern a -> ParamPattern-make' toValue par p = fmap (\x -> Map.singleton par (defaultV x)) p- where defaultV a = Just $ toValue a---- | 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, Maybe Value)- toPV param@(S _ _) s = (param, (Just $ VS s))- toPV param@(F _ _) s = (param, (Just $ VF $ read s))- toPV param@(I _ _) s = (param, (Just $ VI $ read s))-{- |--a pattern of strings representing sound sample names (required).--`sound` is a combination of the `s` and `n` parameters to allow specifying both sample name and sample variation in one:--@-d1 $ sound "bd:2 sn:0"-@--is essentially the same as:--@-d1 $ s "bd sn" # n "2 0"-@--}-sound :: Pattern String -> ParamPattern-sound = grp [s_p, n_p]--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.-(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, 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-(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)-(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) = pI "loop" (Just 1)-(lophat, lophat_p) = pF "lophat" (Just 0)-(lsnare, lsnare_p) = pF "lsnare" (Just 0)--- | specifies the sample variation to be used-(n, n_p) = pI "n" (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"-@--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).-(pan, pan_p) = pF "pan" (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 from 0 to 1, which changes the speed of sample playback, i.e. a cheap way of changing pitch-(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)--- | only accepts a value of "c". Used in conjunction with `speed`, it time-stretches a sample to fit in a cycle.-(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)---- aliases-att = attack-chdecay = clhatdecay-ctf = cutoff-ctfg = cutoffegint-delayfb = delayfeedback-delayt = delaytime-det = detune-gat = gate_p-hg = hatgrain-lag = lagogo-lbd = lkick-lch = lclhat-lcl = lclaves-lcp = lclap-lcr = lcrash-lfoc = lfocutoffint-lfoi = lfoint-lfop = lfopitchint-lht = lhitom-llt = llotom-loh = lophat-lsn = lsnare-ohdecay = ophatdecay-pit1 = pitch1-pit2 = pitch2-pit3 = pitch3-por = portamento-sag = sagogo-scl = sclaves-scp = sclap-scr = scrash-sld = slide-std = stutterdepth-stt = stuttertime-sus = sustain-tdecay = tomdecay-vcf = vcfegint-vco = vcoegint-voi = voice--note = n-midinote = n . ((subtract 60) <$>)--drum = n . (drumN <$>)--drumN :: String -> Int-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
− Sound/Tidal/Parse.hs
@@ -1,272 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, OverlappingInstances, IncoherentInstances, FlexibleInstances #-}--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 Control.Exception as E-import Control.Applicative ((<$>), (<*>))-import Data.Maybe-import Data.List--import Sound.Tidal.Pattern--class Parseable a where- p :: String -> Pattern a--instance Parseable Double where- p = parseRhythm pDouble--instance Parseable String where- p = parseRhythm pVocable--instance Parseable Bool where- p = parseRhythm pBool--instance Parseable Int where- p = parseRhythm pInt--instance Parseable Integer where- p = (fromIntegral <$>) <$> parseRhythm pInt--instance Parseable Rational where- p = parseRhythm pRational--type ColourD = Colour Double--instance Parseable ColourD where- p = parseRhythm pColour--instance (Parseable a) => IsString (Pattern a) where- fromString = p----instance (Parseable a, Pattern p) => IsString (p a) where--- fromString = p :: String -> p a--lexer = P.makeTokenParser haskellDef-braces = P.braces lexer-brackets = P.brackets lexer-parens = P.parens lexer-angles = P.angles lexer-symbol = P.symbol lexer-natural = P.natural lexer-integer = P.integer lexer-float = P.float lexer-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 (Either Integer Double)-intOrFloat = do s <- sign- num <- naturalOrFloat- return (case num of- Right x -> Right (applySign s x)- Left x -> Left (applySign s x)- )--r :: 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 :: Parser (Pattern a) -> String -> (Pattern a)-parseRhythm f input = either (const silence) id $ parse (pSequence f') "" input- where f' = f- <|> do symbol "~" <?> "rest"- return silence--pSequenceN :: Parser (Pattern a) -> GenParser Char () (Int, Pattern a)-pSequenceN f = do spaces- d <- pDensity- ps <- many $ pPart f- return $ (length ps, density d $ cat $ concat ps)- -pSequence :: Parser (Pattern a) -> GenParser Char () (Pattern a)-pSequence f = do (_, p) <- pSequenceN f- return p--pSingle :: Parser (Pattern a) -> Parser (Pattern a)-pSingle f = f >>= pRand >>= pMult--pPart :: Parser (Pattern a) -> Parser ([Pattern a])-pPart f = do -- part <- parens (pSequence f) <|> pSingle f <|> pPolyIn f <|> pPolyOut f- part <- pSingle f <|> pPolyIn f <|> pPolyOut f- part <- pE part- part <- pRand part- spaces- parts <- pStretch part- <|> pReplicate part- spaces- return $ parts--pPolyIn :: Parser (Pattern a) -> Parser (Pattern a)-pPolyIn f = do ps <- brackets (pSequence f `sepBy` symbol ",")- spaces- pMult $ mconcat ps--pPolyOut :: Parser (Pattern a) -> Parser (Pattern 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 $ mconcat $ scale base ps- where scale _ [] = []- scale base (ps@((n,_):_)) = map (\(n',p) -> density (fromIntegral (fromMaybe n base)/ fromIntegral n') p) ps--pString :: Parser (String)-pString = many1 (letter <|> oneOf "0123456789:.-_") <?> "string"--pVocable :: Parser (Pattern String)-pVocable = do v <- pString- return $ atom v--pDouble :: Parser (Pattern Double)-pDouble = do nf <- intOrFloat <?> "float"- let f = either fromIntegral id nf- return $ atom f--pBool :: Parser (Pattern Bool)-pBool = do oneOf "t1"- return $ atom True- <|>- do oneOf "f0"- return $ atom False--parseIntNote :: Parser Int-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--pInt :: Parser (Pattern Int)-pInt = do i <- parseIntNote- return $ atom i--parseNote :: Integral 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 = 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 = choice [char 's' >> return 1,- char 'f' >> return (-1),- char 'n' >> return 0- ]--fromNote :: Integral c => Pattern String -> Pattern c-fromNote p = (\s -> either (const 0) id $ parse parseNote "" s) <$> p--pColour :: Parser (Pattern ColourD)-pColour = do name <- many1 letter <?> "colour name"- colour <- readColourName name <?> "known colour"- return $ atom colour--pMult :: Pattern a -> Parser (Pattern a)-pMult thing = do char '*'- spaces- r <- pRatio- return $ density r thing- <|>- do char '/'- spaces- r <- pRatio- return $ slow r thing- <|>- return thing----pRand :: Pattern a -> Parser (Pattern a)-pRand thing = do char '?'- spaces- return $ degrade thing- <|> return thing--pE :: Pattern a -> Parser (Pattern a)-pE thing = do (n,k,s) <- parens (pair)- return $ unwrap $ eoff <$> n <*> k <*> s <*> atom thing- <|> return thing- where pair = do a <- pSequence pInt- spaces- symbol ","- spaces- b <- pSequence pInt- c <- do symbol ","- spaces- pSequence pInt- <|> return (atom 0)- return (fromIntegral <$> a, fromIntegral <$> b, fromIntegral <$> c)- eoff n k s p = ((s%(fromIntegral k)) <~) (e n k p)- --pReplicate :: Pattern a -> Parser ([Pattern a])-pReplicate thing =- do extras <- many $ do char '!'- -- if a number is given (without a space)- -- replicate that number of times- n <- ((read <$> many1 digit) <|> return 1)- spaces- thing' <- pRand thing- return $ replicate (fromIntegral n) thing'- return (thing:concat extras)---pStretch :: Pattern a -> Parser ([Pattern a])-pStretch thing =- do char '@'- n <- ((read <$> many1 digit) <|> return 1)- return $ map (\x -> zoom (x%n,(x+1)%n) thing) [0 .. (n-1)]--pRatio :: Parser (Rational)-pRatio = do n <- natural <?> "numerator"- d <- do oneOf "/%"- natural <?> "denominator"- <|>- return 1- return $ n % d--pRational :: Parser (Pattern Rational)-pRational = do r <- pRatio- return $ atom r--pDensity :: Parser (Rational)-pDensity = angles (pRatio <?> "ratio")- <|>- return (1 % 1)-
− Sound/Tidal/Pattern.hs
@@ -1,1068 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--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-import qualified Data.Text as T--import Music.Theory.Bjorklund--import Sound.Tidal.Time-import Sound.Tidal.Utils---- | 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.-data Pattern a = Pattern {arc :: Arc -> [Event a]}- deriving Typeable---- | @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 _) = intercalate " " $ 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 = concat[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 (a, b, v) | a == b = concat["(",show v,- (' ':showArc a),- ")"- ]- | otherwise = show v--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'))- )---- | @mempty@ is a synonym for @silence@.--- | @mappend@ is a synonym for @overlay@.-instance Monoid (Pattern a) where- mempty = silence- mappend = overlay--instance Monad Pattern where- return = pure- -- Pattern a -> (a -> Pattern b) -> Pattern b- -- Pattern Char -> (Char -> Pattern String) -> Pattern String- - p >>= f = unwrap (f <$> p)-{-Pattern (\a -> concatMap- (\((s,e), (s',e'), x) -> map (\ev -> ((s,e), (s',e'), thd' ev)) $- filter- (\(a', _, _) -> isIn a' s)- (arc (f x) (s,e))- )- (arc p a)- )--}--- join x = x >>= id----- Take a pattern, and function from elements in the pattern to another pattern,--- and then return that pattern---bind :: Pattern a -> (a -> Pattern b) -> Pattern b---bind p f =---- this is actually join-unwrap :: Pattern (Pattern a) -> Pattern a-unwrap p = Pattern $ \a -> concatMap ((\p' -> arc p' a) . thd') (arc p a)---- | @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---- | @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 ps = foldr overlay silence ps---- | @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 = cat [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 = slow 2 $ cat [a,b]---- | @cat@ 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.-cat :: [Pattern a] -> Pattern a-cat 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 @cat@, 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)---- | @listToPat@ turns the given list of values to a Pattern, which--- cycles through the list.-listToPat :: [a] -> Pattern a-listToPat = cat . map atom---- | @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 = cat . 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 n = listToPat [0 .. n-1]-scan n = cat $ map run [1 .. n]---- | @density@ returns the given pattern with density increased by the--- given @Time@ factor. Therefore @density 2 p@ will return a pattern--- that is twice as fast, and @density (1%3) p@ will return one three--- times as slow.-density :: Time -> Pattern a -> Pattern a-density 0 p = silence-density 1 p = p-density r p = withResultTime (/ r) $ withQueryTime (* r) p----- | @densityGap@ is similar to @density@ but maintains its cyclic--- alignment. For example, @densityGap 2 p@ would squash the events in--- pattern @p@ into the first half of each cycle (and the second--- halves would be empty).-densityGap :: Time -> Pattern a -> Pattern a-densityGap 0 p = silence-densityGap 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)---- | @slow@ does the opposite of @density@, i.e. @slow 2 p@ will--- return a pattern that is half the speed.-slow :: Time -> Pattern a -> Pattern a-slow 0 = id-slow t = density (1/t)---- | 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.-(<~) :: Time -> Pattern a -> Pattern a-(<~) t p = withResultTime (subtract t) $ withQueryTime (+ t) p---- | The @~>@ operator does the same as @~>@ but shifts events to the--- right (or clockwise) rather than to the left.-(~>) :: Time -> Pattern a -> Pattern a-(~>) = (<~) . (0-)--{- | (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) ~>) . (\x -> cat [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 :: Int -> Pattern a -> Pattern a-iter n p = slowcat $ map (\i -> ((fromIntegral i)%(fromIntegral n)) <~ p) [0 .. n]--iter' :: Int -> Pattern a -> Pattern a-iter' n p = slowcat $ map (\i -> ((fromIntegral i)%(fromIntegral n)) ~> p) [0 .. n]---- | @rev p@ returns @p@ with the event positions in each cycle--- reversed (or mirrored).-rev :: Pattern a -> Pattern a-rev p = splitQueries $ Pattern $ \a -> mapArcs mirrorArc (arc p (mirrorArc a))---- | @palindrome p@ applies @rev@ to @p@ every other cycle, so that--- the pattern alternates between forwards and backwards.-palindrome p = append' p (rev p)---- | @when test f p@ applies the function @f@ to @p@, but in a way--- which only affects cycles where the @test@ function applied to the--- cycle number returns @True@.-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])--{- | There is a similar function named `seqP` which 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 = stack . (map (\(s, e, p) -> playFor s e ((sam s) ~> p)))---- | @every n f p@ applies the function @f@ to @p@, but only affects--- every @n@ cycles.-every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-every 0 f p = p-every n f p = when ((== 0) . (`mod` n)) f p---- | @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 @Double@ values following a--- sinewave with frequency of one cycle, and amplitude from -1 to 1.-sinewave :: Pattern Double-sinewave = sig $ \t -> sin $ pi * 2 * (fromRational t)--- | @sine@ is a synonym for @sinewave.-sine = sinewave--- | @sinerat@ is equivalent to @sinewave@ for @Rational@ values,--- suitable for use as @Time@ offsets.-sinerat = fmap toRational sine-ratsine = sinerat---- | @sinewave1@ is equivalent to @sinewave@, but with amplitude from 0 to 1.-sinewave1 :: Pattern Double-sinewave1 = fmap ((/ 2) . (+ 1)) sinewave---- | @sine1@ is a synonym for @sinewave1@.-sine1 = sinewave1---- | @sinerat1@ is equivalent to @sinerat@, but with amplitude from 0 to 1.-sinerat1 = fmap toRational sine1---- | @sineAmp1 d@ returns @sinewave1@ with its amplitude offset by @d@.-sineAmp1 :: Double -> Pattern Double-sineAmp1 offset = (+ offset) <$> sinewave1---- | @sawwave@ is the equivalent of @sinewave@ for sawtooth waves.-sawwave :: Pattern Double-sawwave = ((subtract 1) . (* 2)) <$> sawwave1---- | @saw@ is a synonym for @sawwave@.-saw = sawwave---- | @sawrat@ is the same as @sawwave@ but returns @Rational@ values--- suitable for use as @Time@ offsets.-sawrat = fmap toRational saw--sawwave1 :: Pattern Double-sawwave1 = sig $ \t -> mod' (fromRational t) 1-saw1 = sawwave1-sawrat1 = fmap toRational saw1---- | @triwave@ is the equivalent of @sinewave@ for triangular waves.-triwave :: Pattern Double-triwave = ((subtract 1) . (* 2)) <$> triwave1---- | @tri@ is a synonym for @triwave@.-tri = triwave---- | @trirat@ is the same as @triwave@ but returns @Rational@ values--- suitable for use as @Time@ offsets.-trirat = fmap toRational tri--triwave1 :: Pattern Double-triwave1 = append sawwave1 (rev sawwave1)--tri1 = triwave1-trirat1 = fmap toRational tri1---- todo - triangular waves again--squarewave1 :: Pattern Double-squarewave1 = sig $- \t -> fromIntegral $ floor $ (mod' (fromRational t) 1) * 2-square1 = squarewave1--squarewave :: Pattern Double-squarewave = ((subtract 1) . (* 2)) <$> squarewave1-square = squarewave---- | @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 = 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 ~> 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 <~ degradeBy n p) (from ~> 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 read the description and examples..)--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"-@---}-spread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b-spread f xs p = cat $ map (\x -> f x p) xs--{- | `slowspread` takes a list of pattern transforms and applies them one at a time, per cycle, -then repeats.--Example:--@-d1 $ slowspread ($) [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.--}-slowspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b-slowspread f xs p = slowcat $ 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' :: (a -> Pattern b -> Pattern c) -> Pattern a -> Pattern b -> Pattern c-spread' f timepat pat =- Pattern $ \r -> concatMap (\(_,r', x) -> (arc (f x pat) r')) (rs r)- where rs r = arc (filterOnsetsInRange timepat) r--filterValues :: (a -> Bool) -> Pattern a -> Pattern a-filterValues f (Pattern x) = Pattern $ (filter (f . thd')) . x---- 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-filterStartInRange :: Pattern a -> Pattern a-filterStartInRange (Pattern f) =- Pattern $ \(s,e) -> filter ((>= s) . eventOnset) $ f (s,e)--filterOnsetsInRange = filterOnsets . filterStartInRange--seqToRelOnsets :: Arc -> Pattern a -> [(Double, a)]-seqToRelOnsets (s, e) p = map (\((s', _), _, x) -> (fromRational $ (s'-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)--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 t = fst $ randomDouble $ pureMT $ floor $ (*1000000) t--{- | Just like `rand` but for integers, `irand n` generates a pattern of (pseudo-)random integers between `0` to `n-1` inclusive. Notably used to pick a random-samples from a folder:--@-d1 $ sound (samples "drum*4" (irand 5))-@--}-irand :: Int -> Pattern Int-irand i = (floor . (* (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 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 :: Double -> Pattern a -> Pattern a-degradeBy x p = unMaybe $ (\a f -> toMaybe (f > x) a) <$> p <*> rand- where toMaybe False _ = Nothing- toMaybe True a = Just a- unMaybe = (fromJust <$>) . filterValues isJust--unDegradeBy :: Double -> Pattern a -> Pattern a-unDegradeBy x p = unMaybe $ (\a f -> toMaybe (f <= x) a) <$> p <*> rand- where toMaybe False _ = Nothing- toMaybe True a = Just a- unMaybe = (fromJust <$>) . filterValues isJust--{- | 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 = sometimesBy 0.5-often = sometimesBy 0.75-rarely = sometimesBy 0.25-almostNever = sometimesBy 0.1-almostAlways = sometimesBy 0.9--{- | `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 ~> densityGap (1/(1-t)) p')--{- | `whenmod` has a similar form and behavior to `every`, but requires an -additional number. Applies the function to the pattern, when the-remainder of the current loop number divided by the first parameter,-is less 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 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--{- | Truncates a pattern so that only a fraction of the pattern is played. -The following example plays only the first three quarters of the pattern:--@-d1 $ trunc 0.75 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2"-@--}-trunc :: Time -> Pattern a -> Pattern a-trunc t p = slow t $ splitQueries $ p'- where p' = Pattern $ \a -> mapArcs (stretch . trunc') $ arc p (trunc' 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))--{- | 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 a@(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 a@(s,e) p | s >= e = silence- | otherwise = s ~> 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 [sliceArc (0,s) p,- compress (s,e) $ f $ zoom (s,e) p,- sliceArc (e,1) p- ]--revArc a = within a rev--e :: Int -> Int -> Pattern a -> Pattern a-e n k p = (flip const) <$> (filterValues (== True) $ listToPat $ bjorklund (n,k)) <*> p--e' :: Int -> Int -> Pattern a -> Pattern a-e' n k p = cat $ map (\x -> if x then p else silence) (bjorklund (n,k))---index :: Real b => b -> Pattern b -> Pattern c -> Pattern c-index sz indexpat pat = spread' (zoom' $ toRational sz) (toRational . (*(1-sz)) <$> indexpat) pat- where zoom' sz start = zoom (start, start+sz)---- | @prr 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 ~>) $ 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 a -> 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 @prr@ and provide desired pattern lengths:-@-let p = slow 2 $ "x x x"--d1 $ sound $ prr 0 (2,1) p "bd sn"-@--}-preplace :: (Time, Time) -> Pattern a -> Pattern b -> Pattern b-preplace = preplaceWith $ flip const--prep = preplace--preplace1 :: Pattern a -> Pattern b -> Pattern b-preplace1 = prr 0 (1, 1)--preplaceWith :: (a -> b -> c) -> (Time, Time) -> Pattern a -> Pattern b -> Pattern c-preplaceWith f (blen, plen) = prrw f 0 (blen, plen)--prw = preplaceWith--preplaceWith1 :: (a -> b -> c) -> Pattern a -> Pattern b -> Pattern c-preplaceWith1 f = prrw f 0 (1, 1)--prw1 = preplaceWith1--(<~>) :: Pattern a -> 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 = prr rot (len, len) p p--prot = protate-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--(~>>) :: 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 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' (<~) (discretise 1 $ ((%1) . fromIntegral) <$> irand (length ps)) (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) 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---- 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:--~~~~{haskell}--lindenmayer 1 "a:b,b:ab" "ab" -> "bab"--~~~~--}-lindenmayer :: Int -> String -> String -> String-lindenmayer n r [] = []-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---- 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 pattern b that don't start during an event from pattern a-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 es = []- 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' 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--{- `runWith n f p` treats the given pattern `p` as having `n` sections, and applies the function `f` to one of those sections per cycle, running from left to right.--@-d1 $ runWith 4 (density 4) $ sound "cp sn arpy [mt lt]"-@--}-runWith :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-runWith n f p = do i <- slow (toRational n) $ run (fromIntegral n)- within (i%(fromIntegral n),(i+)1%(fromIntegral n)) f p---{- `runWith'` works much the same as `runWith`, but runs from right to left.- -}-runWith' :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-runWith' n f p = do i <- slow (toRational n) $ rev $ run (fromIntegral n)- within (i%(fromIntegral n),(i+)1%(fromIntegral n)) f p
− Sound/Tidal/Strategies.hs
@@ -1,369 +0,0 @@-{-# OPTIONS_GHC -XNoMonomorphismRestriction #-}--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--stutter n t p = stack $ map (\i -> (t * (fromIntegral i)) ~> p) [0 .. (n-1)]--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))- ]--{- | 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 (pure $ 0.5 - (n/2)), f $ p |+| pan (pure $ 0.5 + (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) <~ 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 ~> 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 :: Int -> ParamPattern -> ParamPattern-spin copies p =- stack $ map (\n -> let offset = toInteger n % toInteger copies in- offset <~ 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 = ((*4) <$> sawwave1)-sinewave4 = ((*4) <$> sinewave1)-rand4 = ((*4) <$> rand)--stackwith p ps | null ps = silence- | otherwise = stack $ map (\(i, p') -> p' # (((fromIntegral i) % l) <~ 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--}--inside n f p = density n $ f (slow n p)---{- | `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--{- | `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 :: 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") (Just $ VF ((fromIntegral $ i+1)/(fromIntegral n))) $ Map.insert (param dirt "begin") (Just $ 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 :: 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") (Just $ VF ((fromIntegral $ i+1)/(fromIntegral n))) $ Map.insert (param dirt "begin") (Just $ VF ((fromIntegral i)/(fromIntegral n))) v)- everyOther (x:(y: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) <~ (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 = cat $ map f steps- where f c | c == 'x' = atom s- | c >= '0' && c <= '9' = 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 = cat $ map f steps- where f c | c == 'x' = atom $ ss!!0- | c >= '0' && c <= '9' = atom $ ss!!(Char.digitToInt c)- | otherwise = silence--off :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-off t f p = superimpose (f . (t ~>)) p--offadd :: Num a => Time -> a -> Pattern a -> Pattern a-offadd t n p = off t ((+n) <$>) 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) ~>) . f) $ superimpose (((a*1.5) ~>) . 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 :: 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 :: Time -> ParamPattern -> ParamPattern-loopAt n p = slow n p |*| speed (pure $ fromRational $ 1/n) # unit (pure "c")
− Sound/Tidal/Stream.hs
@@ -1,224 +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, clocked,clockedTick,cps)-import Sound.Tidal.Utils-import qualified Sound.Tidal.Time as T--import qualified Data.Map as Map--type ToMessageFunc = Shape -> Tempo -> Int -> (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 (Show,Eq,Ord,Typeable)--type ParamMap = Map.Map Param (Maybe Value)--type ParamPattern = Pattern ParamMap- -ticksPerCycle = 8--defaultValue :: Param -> Maybe Value-defaultValue (S _ (Just x)) = Just $ VS x-defaultValue (I _ (Just x)) = Just $ VI x-defaultValue (F _ (Just x)) = Just $ VF x-defaultValue _ = Nothing--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 (Map.filter (\x -> x /= Nothing) 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)- (seqToRelOnsets (a, b) p)- E.catch (sequence_ messages) (\msg -> putStrLn $ "oops " ++ 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)- (seqToRelOnsets (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 = Just $ toValue a- --defaultV Nothing = defaultValue nParam--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--(#) = (|=|)--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 _ _) (Just (VF a)) (Just (VF b)) = Just (VF $ floatOp a b)- f (I _ _) (Just (VI a)) (Just (VI b)) = Just (VI $ intOp a b)- f _ _ b = b--mergePlus = mergeWith f- where f (F _ _) (Just (VF a)) (Just (VF b)) = Just (VF $ a + b)- f (I _ _) (Just (VI a)) (Just (VI b)) = Just (VI $ a + b)- f (S _ _) (Just (VS a)) (Just (VS b)) = Just (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) (/)--setter :: MVar (a, [a]) -> a -> IO ()-setter ds p = do ps <- takeMVar ds- putMVar ds $ (p, p:snd ps)- return ()-
− Sound/Tidal/SuperCollider.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}--module Sound.Tidal.SuperCollider where--import Sound.Tidal.Stream-import Sound.Tidal.Pattern-import Sound.Tidal.Parse-import Sound.OSC.FD-import Sound.Tidal.OscStream--supercollider :: [Param] -> Double -> Shape-supercollider ps l = Shape {- params = ps,- cpsStamp = False,- latency = l- }--scSlang n = OscSlang {- -- The OSC path- path = "/s_new",- preamble = [string n, int32 (-1), int32 1, int32 1],- namedParams = True,- timestamp = BundleStamp- }--scBackend n = do- s <- makeConnection "127.0.0.1" 57110 (scSlang n)- return $ Backend s (\_ _ _ -> return ())--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,256 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Sound.Tidal.Tempo where--import Data.Time (getCurrentTime, UTCTime, NominalDiffTime, diffUTCTime, addUTCTime)-import Data.Time.Clock.POSIX-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.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Network.WebSockets as WS-import qualified Control.Exception as E-import qualified System.IO.Error as Error-import GHC.Conc.Sync (ThreadId)-import System.Environment (getEnv)--import Sound.Tidal.Utils--data Tempo = Tempo {at :: UTCTime, beat :: Double, cps :: Double, paused :: Bool, clockLatency :: Double}--type ClientState = [WS.Connection]--instance Eq WS.Connection--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 = fmap (read) (getEnvDefault "0.04" "TIDAL_CLOCK_LATENCY")--getClockIp :: IO String-getClockIp = getEnvDefault "127.0.0.1" "TIDAL_TEMPO_IP"--getServerPort :: IO Int-getServerPort = fmap read (getEnvDefault "9160" "TIDAL_TEMPO_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--logicalTime :: Tempo -> Double -> Double-logicalTime t b = changeT + timeDelta- where beatDelta = b - (beat t)- timeDelta = beatDelta / (cps t)- changeT = realToFrac $ utcTimeToPOSIXSeconds $ at t--tempoMVar :: IO (MVar (Tempo))-tempoMVar = do now <- getCurrentTime- l <- getLatency- mv <- newMVar (Tempo now 0 0.5 False l)- forkIO $ clocked $ f mv- return mv- where f mv change _ = do swapMVar mv change- return ()--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--clientApp :: MVar Tempo -> MVar Double -> WS.ClientApp ()-clientApp mTempo mCps conn = do- --sink <- WS.getSink- liftIO $ forkIO $ sendCps conn mTempo mCps- forever loop- where- loop = do- msg <- WS.receiveData conn- let s = T.unpack msg- let tempo = readTempo $ s- --putStrLn $ "to: " ++ show tempo- liftIO $ tryTakeMVar mTempo- liftIO $ putMVar mTempo tempo--sendCps :: WS.Connection -> MVar Tempo -> MVar Double -> IO ()-sendCps conn mTempo mCps = forever $ do- cps <- takeMVar mCps- t <- readMVar mTempo- t' <- updateTempo t cps- WS.sendTextData conn (T.pack $ show t')--connectClient :: Bool -> String -> MVar Tempo -> MVar Double -> IO ()-connectClient secondTry ip mTempo mCps = 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) `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--runClient :: IO ((MVar Tempo, MVar Double))-runClient = - do clockip <- getClockIp- mTempo <- newEmptyMVar - mCps <- newEmptyMVar - forkIO $ connectClient False clockip mTempo mCps- return (mTempo, mCps)--cpsUtils :: IO ((Double -> IO (), IO (Rational)))-cpsUtils = do (mTempo, mCps) <- runClient- let cpsSetter b = putMVar mCps b- currentTime = do tempo <- readMVar mTempo- now <- beatNow tempo- return $ toRational now- 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--{--clocked 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- nextBeat = ceiling nowBeat- -- next4 = nextBeat + (4 - (nextBeat `mod` 4))- loop mTempo nextBeat- where loop mTempo b = - do t <- readMVar mTempo- b' <- doSlice t b- loop mTempo $ b'- -- wait an eighth of a cycle if we're paused- doSlice t b | paused t = threadDelay $ floor ((0.125 / cps t) * 1000000)- | otherwise =- do now <- getCurrentTime- let delta = realToFrac $ diffUTCTime now (at t)- actualBeat = (beat t) + ((cps t) * delta)- beatDelta = (fromIntegral b) - actualBeat- delay = beatDelta / (cps t)- threadDelay $ floor (delay * 1000000)- callback t b- return $ b + 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)- tickDelta = (fromIntegral tick) - actualTick- delay = tickDelta / tps- --putStrLn ("Delay: " ++ show delay ++ "s Beat: " ++ show (beat tempo))- threadDelay $ floor (delay * 1000000)- callback tempo tick- return $ tick + 1----updateTempo :: MVar Tempo -> Maybe Double -> IO ()---updateTempo mt Nothing = return ()---updateTempo mt (Just cps') = do t <- takeMVar mt--- now <- getCurrentTime--- let delta = realToFrac $ diffUTCTime now (at t)--- beat' = (beat t) + ((cps t) * delta)--- putMVar mt $ Tempo now beat' cps' (paused t)---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)}--addClient client clients = client : clients- -removeClient :: WS.Connection -> ClientState -> ClientState-removeClient client = filter (/= client)--broadcast :: Text -> ClientState -> IO ()-broadcast message clients = do- -- T.putStrLn message- forM_ clients $ \conn -> WS.sendTextData conn $ message--startServer :: IO (ThreadId)-startServer = do- serverPort <- getServerPort- start <- getCurrentTime- l <- getLatency- tempoState <- newMVar (Tempo start 0 1 False l)- clientState <- newMVar []- forkIO $ WS.runServer "0.0.0.0" serverPort $ serverApp tempoState clientState--serverApp :: MVar Tempo -> MVar ClientState -> WS.ServerApp-serverApp tempoState clientState pending = do- conn <- WS.acceptRequest pending- tempo <- liftIO $ readMVar tempoState- liftIO $ WS.sendTextData conn $ T.pack $ show tempo- clients <- liftIO $ readMVar clientState- liftIO $ modifyMVar_ clientState $ \s -> return $ addClient conn s- serverLoop conn tempoState clientState--serverLoop :: WS.Connection -> MVar Tempo -> MVar ClientState -> IO ()-serverLoop conn tempoState clientState = E.handle catchDisconnect $ - forever $ do- msg <- WS.receiveData conn- --liftIO $ updateTempo tempoState $ maybeRead $ T.unpack msg- liftIO $ readMVar clientState >>= broadcast msg- --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 ()-
− 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@, used by @Sound.Tidal.Pattern.rev@.-mirrorArc :: Arc -> Arc-mirrorArc (s, e) = (sam s + (nextSam s - e), nextSam s - (s - sam 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,85 +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.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---- generalizing wash to use pattern transformers on fadeout, fadein, and delay--- to start of transition-superwash :: (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Time -> Time -> Time -> [Pattern a] -> Pattern a-superwash _ _ _ _ _ [] = silence-superwash _ _ _ _ _ (p:[]) = p-superwash fout fin delay dur now (p:p':_) =- (playWhen (< (now + delay)) p') <>- (playWhen (between (now + delay) (now + delay + dur)) $ fout p') <>- (playWhen (>= (now + delay + dur)) $ fin p)- where- between lo hi x = (x >= lo) && (x < hi)--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 t _ [] = silence-wait t now (p:_) = playWhen (>= (nextSam (now+t-1))) p--{- |-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--{- | 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 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 goes to nothing-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))
− Sound/Tidal/Utils.hs
@@ -1,107 +0,0 @@-{-|-Module: Utils-Description: Helper functions not directly specific to Tidal--}-module Sound.Tidal.Utils where--import System.Environment (getEnv)-import Data.Maybe (listToMaybe)-import Control.Exception--{- | 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)---- | return environment variable @var@'s value or @defValue@-getEnvDefault :: String -> String -> IO String-getEnvDefault defValue var = do- res <- try . getEnv $ var- return $ either (const defValue) id (res :: Either IOException String)--{- | 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)
+ 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+ ]
tidal.cabal view
@@ -1,35 +1,134 @@+cabal-version: 2.0+ name: tidal-version: 0.8+version: 1.10.3 synopsis: Pattern language for improvised music--- description:-homepage: http://tidal.lurk.org/+description: Tidal is a domain specific language for live coding patterns.+homepage: http://tidalcycles.org/ license: GPL-3 license-file: LICENSE author: Alex McLean-maintainer: Alex McLean <alex@slab.org>, Mike Hodnick <mike.hodnick@gmail.com>+maintainer: Alex McLean <alex@slab.org>, Matthew Kaney, Martin Gius Stability: Experimental-Copyright: (c) Alex McLean and other contributors, 2016+Copyright: (c) Alex McLean and other contributors, 2025 category: Sound build-type: Simple-cabal-version: >=1.4--Extra-source-files: README.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- Exposed-modules: Sound.Tidal.Strategies- Sound.Tidal.Dirt- Sound.Tidal.Pattern- Sound.Tidal.Stream- Sound.Tidal.OscStream- Sound.Tidal.Parse- Sound.Tidal.Tempo- Sound.Tidal.Time+ ghc-options: -Wall+ hs-source-dirs:+ src++ default-language: Haskell2010++ 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.Version+ Paths_tidal+ Build-depends:+ 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 - Build-depends: base < 5, process, parsec, hosc > 0.13, hashable, colour, containers, time, websockets > 0.8, text, mtl >=2.1, transformers, mersenne-random-pure64,binary, bytestring, hmt+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++ default-language: Haskell2010++-- not useful for automation since it requires running sclang+test-suite dontcrash+ type: exitcode-stdio-1.0+ main-is: dontcrash.hs+ hs-source-dirs: test+ build-depends: base,+ tidal,+ tidal-core++ default-language: Haskell2010++benchmark bench-speed+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench/Speed+ other-modules: Tidal.PatternB+ Tidal.CoreB+ Tidal.UIB+ Tidal.Inputs+ build-depends:+ base >=4 && <5,+ criterion >=1.6.3.0,+ tidal,+ tidal-core++ ghc-options: -Wall++ default-language: Haskell2010++benchmark bench-memory+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench/Memory+ 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,6 +1,29 @@-;; tidal.el - (c) alex@slab.org, 20012, based heavily on...-;; hsc3.el - (c) rohan drape, 2006-2008+;;; tidal.el --- Interact with TidalCycles for live coding patterns -*- lexical-binding: t; -*- +;; Copyright (C) 2025 alex@slab.org+;; Copyright (C) 2006-2008 rohan drape (hsc3.el)++;; Author: alex@slab.org+;; Homepage: https://codeberg.org/uzu/tidal+;; Version: 0.0.1+;; Keywords: tools+;; 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+;; the Free Software Foundation, either version 3 of the License, or+;; (at your option) any later version.++;; This program 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 program. If not, see <https://www.gnu.org/licenses/>.++;;; Commentary:+ ;; notes from hsc3: ;; This mode is implemented as a derivation of `haskell' mode, ;; indentation and font locking is courtesy that mode. The@@ -8,11 +31,15 @@ ;; point acquisition is courtesy `thingatpt'. The directory search ;; facilities are courtesy `find-lisp'. +;;; Code:+ (require 'scheme) (require 'comint) (require 'thingatpt) (require 'find-lisp) (require 'pulse)+(require 'haskell-mode)+(require 'subr-x) (defvar tidal-buffer "*tidal*"@@ -22,78 +49,82 @@ "ghci" "*The haskell interpeter to use (default=ghci).") +(defvar tidal-interpreter-version+ (substring (shell-command-to-string (concat tidal-interpreter " --numeric-version")) 0 -1)+ "*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).") +(defvar tidal-modules nil+ "Additional module imports. See `tidal-run-region'.")+ (make-variable-buffer-local 'tidal-literate-p) (defun tidal-unlit (s)- "Remove bird literate marks"+ "Remove bird literate markup in S." (replace-regexp-in-string "^> " "" s)) (defun tidal-intersperse (e l)- (if (null l)- '()+ "Insert E between every element of list L."+ (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 \"\"")- (tidal-send-string ":module Sound.Tidal.Context")- (tidal-send-string "(cps, getNow) <- bpsUtils")- (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."@@ -101,224 +132,117 @@ (kill-buffer tidal-buffer) (delete-other-windows)) -(defun tidal-help ()- "Lookup up the name at point in the Help files."+(defun tidal-restart-haskell ()+ "Restart haskell." (interactive)- (mapc (lambda (filename)- (find-file-other-window filename))- (find-lisp-find-files tidal-help-directory- (concat "^"- (thing-at-point 'symbol)- "\\.help\\.lhs"))))+ (let ((kill-buffer-query-functions nil))+ (tidal-quit-haskell))+ (tidal-start-haskell)) -(defun chunk-string (n s)- "Split a string into chunks of 'n' characters."+(defun tidal-chunk-string (n s)+ "Split a string S into chunks of N characters." (let* ((l (length s)) (m (min l n)) (c (substring s 0 m))) (if (<= l n) (list c)- (cons c (chunk-string n (substring s n))))))+ (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 (chunk-string 64 (concat s "\n"))))+ (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 ~>)")- (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 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)")) (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))- (next-line)- )+ (forward-line)) +(defun tidal-eval-multiple-lines ()+ "Eval the current region in the interpreter as a single line."+ ;;(tidal-get-now)+ (mark-paragraph)+ (let* ((s (buffer-substring-no-properties (region-beginning)+ (region-end)))+ (s* (if tidal-literate-p+ (tidal-unlit s)+ s)))+ (tidal-send-string ":{")+ (tidal-send-string s*)+ (tidal-send-string ":}")+ (mark-paragraph)+ (pulse-momentary-highlight-region (mark) (point))))+ (defun tidal-run-multiple-lines () "Send the current region to the interpreter as a single line." (interactive)- (tidal-get-now)- (save-excursion- (mark-paragraph)- (let* ((s (buffer-substring-no-properties (region-beginning)- (region-end)))- (s* (if tidal-literate-p- (tidal-unlit s)- s)))- (tidal-send-string ":{")- (tidal-send-string s*)- (tidal-send-string ":}")- (mark-paragraph)- (pulse-momentary-highlight-region (mark) (point))- )- ;(tidal-send-string (replace-regexp-in-string "\n" " " s*))- )- )--(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 ":}")- )+ (if (>= emacs-major-version 25)+ (save-mark-and-excursion+ (tidal-eval-multiple-lines))+ (save-excursion+ (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."@@ -340,114 +264,124 @@ (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-h] 'tidal-help)- (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-h] 'tidal-help)- (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))) -(if tidal-mode-map- ()+(unless tidal-mode-map (let ((map (make-sparse-keymap "Haskell-Tidal"))) (tidal-mode-keybindings map) (tidal-mode-menu map) (setq tidal-mode-map map))) +;;;###autoload (define-derived-mode literate-tidal-mode tidal-mode@@ -459,19 +393,23 @@ (setq haskell-literate 'bird) (turn-on-font-lock)) -(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+;;;###autoload+(add-to-list 'auto-mode-alist '("\\.ltidal\\'" . literate-tidal-mode))++;;;###autoload (define-derived-mode tidal-mode 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)) -(add-to-list 'auto-mode-alist '("\\.tidal$" . tidal-mode))+;;;###autoload+(add-to-list 'auto-mode-alist '("\\.tidal\\'" . tidal-mode)) (provide 'tidal)+;;; tidal.el ends here