tidal-1.5.2/0000755000000000000000000000000007346545000011005 5ustar0000000000000000tidal-1.5.2/BootTidal.hs0000644000000000000000000000525307346545000013227 0ustar0000000000000000:set -XOverloadedStrings :set prompt "" import Sound.Tidal.Context import System.IO (hSetEncoding, stdout, utf8) hSetEncoding stdout utf8 -- total latency = oLatency + cFrameTimespan tidal <- startTidal (superdirtTarget {oLatency = 0.1, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig {cFrameTimespan = 1/20}) :{ let only = (hush >>) p = streamReplace tidal hush = streamHush tidal list = streamList tidal mute = streamMute tidal unmute = streamUnmute tidal unmuteAll = streamUnmuteAll tidal solo = streamSolo tidal unsolo = streamUnsolo tidal once = streamOnce tidal first = streamFirst tidal asap = once nudgeAll = streamNudgeAll tidal all = streamAll tidal resetCycles = streamResetCycles tidal setcps = asap . cps xfade i = transition tidal True (Sound.Tidal.Transition.xfadeIn 4) i xfadeIn i t = transition tidal True (Sound.Tidal.Transition.xfadeIn t) i histpan i t = transition tidal True (Sound.Tidal.Transition.histpan t) i wait i t = transition tidal True (Sound.Tidal.Transition.wait t) i waitT i f t = transition tidal True (Sound.Tidal.Transition.waitT f t) i jump i = transition tidal True (Sound.Tidal.Transition.jump) i jumpIn i t = transition tidal True (Sound.Tidal.Transition.jumpIn t) i jumpIn' i t = transition tidal True (Sound.Tidal.Transition.jumpIn' t) i jumpMod i t = transition tidal True (Sound.Tidal.Transition.jumpMod t) i mortal i lifespan release = transition tidal True (Sound.Tidal.Transition.mortal lifespan release) i interpolate i = transition tidal True (Sound.Tidal.Transition.interpolate) i interpolateIn i t = transition tidal True (Sound.Tidal.Transition.interpolateIn t) i clutch i = transition tidal True (Sound.Tidal.Transition.clutch) i clutchIn i t = transition tidal True (Sound.Tidal.Transition.clutchIn t) i anticipate i = transition tidal True (Sound.Tidal.Transition.anticipate) i anticipateIn i t = transition tidal True (Sound.Tidal.Transition.anticipateIn t) i forId i t = transition tidal False (Sound.Tidal.Transition.mortalOverlay t) i d1 = p 1 . (|< orbit 0) d2 = p 2 . (|< orbit 1) d3 = p 3 . (|< orbit 2) d4 = p 4 . (|< orbit 3) d5 = p 5 . (|< orbit 4) d6 = p 6 . (|< orbit 5) d7 = p 7 . (|< orbit 6) d8 = p 8 . (|< orbit 7) d9 = p 9 . (|< orbit 8) d10 = p 10 . (|< orbit 9) d11 = p 11 . (|< orbit 10) d12 = p 12 . (|< orbit 11) d13 = p 13 d14 = p 14 d15 = p 15 d16 = p 16 :} :{ let setI = streamSetI tidal setF = streamSetF tidal setS = streamSetS tidal setR = streamSetR tidal setB = streamSetB tidal :} :set prompt "tidal> " :set prompt-cont "" tidal-1.5.2/CHANGELOG.md0000755000000000000000000002635607346545000012635 0ustar0000000000000000# TidalCycles log of changes ## 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. `` 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 * 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://github.com/tidalcycles/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. tidal-1.5.2/LICENSE0000644000000000000000000010444207346545000012017 0ustar0000000000000000 GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "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. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the 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 receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 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 . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with 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 . tidal-1.5.2/README.md0000755000000000000000000000070307346545000012267 0ustar0000000000000000 Tidal [![Build Status](https://travis-ci.org/tidalcycles/Tidal.svg)](https://travis-ci.org/tidalcycles/Tidal) ===== Language for live coding of pattern For documentation, mailing list and more info see here: https://tidalcycles.org/ You can help speed up Tidal development by sending coffee here: https://ko-fi.com/yaxulive# (c) Alex McLean and contributors, 2019 Distributed under the terms of the GNU Public license version 3 (or later). tidal-1.5.2/Setup.hs0000644000000000000000000000005607346545000012442 0ustar0000000000000000import Distribution.Simple main = defaultMain tidal-1.5.2/bench/Memory/0000755000000000000000000000000007346545000013334 5ustar0000000000000000tidal-1.5.2/bench/Memory/Main.hs0000644000000000000000000000016107346545000014552 0ustar0000000000000000module Main where import Weigh import Tidal.UIB main :: IO () main = mainWith $ do euclidB fixB tidal-1.5.2/bench/Memory/Tidal/0000755000000000000000000000000007346545000014371 5ustar0000000000000000tidal-1.5.2/bench/Memory/Tidal/Inputs.hs0000644000000000000000000000335007346545000016210 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Tidal.Inputs where import Sound.Tidal.Pattern import Sound.Tidal.Core import Sound.Tidal.ParseBP import Sound.Tidal.Core import Sound.Tidal.Params import Sound.Tidal.Control import Sound.Tidal.UI import Weigh columns :: Weigh () columns = setColumns [Case, Allocated, Max, Live, GCs] {- Pattern inputs -} xs3 = [1..10^3] xs4 = [1..10^4] xs5 = [1..10^5] xs6 = [1..10^6] xsA = [500000..1500000] catPattSmall :: [Pattern Time] catPattSmall = pure <$> xs3 catPattMed :: [Pattern Time] catPattMed = pure <$> xs4 catPattMedB :: [Pattern Time] catPattMedB = pure <$> xs5 catPattBig :: [Pattern Time] catPattBig = pure <$> xs6 timeCatMed :: [(Time, Pattern Time)] timeCatMed = zip xs5 catPattMed timeCatBig :: [(Time, Pattern Time)] timeCatBig = zip xs6 catPattBig appendBig :: [Pattern Time] appendBig = pure <$> xsA pattApp1 :: Pattern [Time] pattApp1 = sequence catPattBig pattApp2 :: Pattern [Time] pattApp2 = sequence appendBig {- Arc Inputs -} arcFunc :: Arc -> Arc arcFunc (Arc s e) = Arc (s * 2) (e * 4) wqaMed = fromList xs5 wqaBig = fromList xs6 {- fix inputs -} fixArg1 :: ControlPattern fixArg1 = pF "cc64" 1 fixArg2 :: ControlPattern fixArg2 = fix ( # crush 4 ) (pF "cc65" 1) $ fix ( stut' 4 (0.125/4) ( + up "1" )) (pF "cc66" 1) $ fix ( |*| speed "-1" ) (pF "cc67" 1) $ fix ( (# delaytime 0.125).(# delay 0.5)) (pF "cc68" 1) $ fix ( # coarse 12) (pF "cc69" 1) $ s "[808bd:1(3,8), dr(7,8)]" # pF "cc64" (cF 0 "64") # pF "cc65" (cF 0 "65") # pF "cc66" (cF 0 "66") # pF "cc67" (cF 0 "67") # pF "cc68" (cF 0 "68") #  pF "cc69" (cF 0 "69") {- Euclid inputs -} ecA1 :: [Pattern Int] ecA1 = [1, 10^5] ecA2 :: Pattern String ecA2 = "x" tidal-1.5.2/bench/Memory/Tidal/UIB.hs0000644000000000000000000000073507346545000015351 0ustar0000000000000000module Tidal.UIB where import Weigh import Tidal.Inputs import Sound.Tidal.UI import Sound.Tidal.Core fixB :: Weigh () fixB = wgroup "fix weigh" $ do columns func "fix 1" (fix (fast 2) fixArg1) fixArg2 euclidB :: Weigh () euclidB = wgroup "euclid" $ do columns func "euclid" (euclid (head ecA1) (head $ drop 1 ecA1)) ecA2 func "euclidFull" (euclidFull (head ecA1) (head $ drop 1 ecA1) ecA2) ecA2 func "euclidBool" (_euclidBool 1) 100000 tidal-1.5.2/bench/Speed/0000755000000000000000000000000007346545000013124 5ustar0000000000000000tidal-1.5.2/bench/Speed/Main.hs0000644000000000000000000000074007346545000014345 0ustar0000000000000000module Main where import Criterion.Main import Tidal.PatternB import Tidal.CoreB import Tidal.UIB patternBs :: [IO ()] patternBs = defaultMain <$> [withQueryTimeB, withQueryArcB, withResultArcB, withQueryTimeB, subArcB] coreBs :: [IO ()] coreBs = defaultMain <$> [fromListB, stackB, appendB, concatB, _fastB] uiBs :: [IO ()] uiBs = defaultMain <$> [euclidB, fixB] main :: IO () main = do _ <- sequence coreBs _ <- sequence patternBs _ <- sequence uiBs return () tidal-1.5.2/bench/Speed/Tidal/0000755000000000000000000000000007346545000014161 5ustar0000000000000000tidal-1.5.2/bench/Speed/Tidal/CoreB.hs0000644000000000000000000000266007346545000015513 0ustar0000000000000000module Tidal.CoreB where import Criterion.Main import Tidal.Inputs import Sound.Tidal.Pattern import Sound.Tidal.Core _fastB :: [Benchmark] _fastB = [ bgroup "_fast" [ bench "_fast < 0" $ whnf (_fast (-2)) pattApp2 , bench "_fast > 0" $ whnf (_fast (toTime $ 10^6)) (cat catPattBig) ] ] concatB :: [Benchmark] concatB = [ bgroup "concat" [ bench "fastCat 10^3" $ whnf fastCat catPattSmall , bench "fastCat 10^4" $ whnf fastCat catPattMed , bench "fastCat 10^5" $ whnf fastCat catPattMedB , bench "fastCat 10^6" $ whnf fastCat catPattBig , bench "timeCat 10^5" $ whnf timeCat timeCatMed , bench "timeCat 10^6" $ whnf timeCat timeCatBig ] ] fromListB :: [Benchmark] fromListB = [ bgroup "fromList" [ bench "fromList" $ whnf fromList xs6 , bench "fromList nf" $ nf fromList xs6 , bench "fastFromList 10^3" $ whnf fastFromList xs3 , bench "fastFromList 10^4" $ whnf fastFromList xs4 , bench "fastFromList 10^5" $ whnf fastFromList xs5 , bench "fastFromList 10^6" $ whnf fastFromList xs6 , bench "fastFromList 10^6 nf" $ nf fastFromList xs6 ] ] appendB :: [Benchmark] appendB = [ bgroup "append" [ bench "append" $ whnf (append pattApp1) pattApp2 , bench "fastAppend" $ whnf (fastAppend pattApp1) pattApp2 ] ] stackB :: [Benchmark] stackB = [ bgroup "stack" [ bench "overlay" $ whnf (overlay pattApp1) pattApp2 , bench "stack" $ whnf stack catPattBig ] ] tidal-1.5.2/bench/Speed/Tidal/Inputs.hs0000644000000000000000000000327207346545000016003 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Tidal.Inputs where import Sound.Tidal.Pattern import Sound.Tidal.Core import Sound.Tidal.ParseBP import Sound.Tidal.Core import Sound.Tidal.Params import Sound.Tidal.Control import Sound.Tidal.UI {- Pattern inputs -} xs3 = [1..10^3] xs4 = [1..10^4] xs5 = [1..10^5] xs6 = [1..10^6] xsA = [500000..1500000] catPattSmall :: [Pattern Time] catPattSmall = pure <$> xs3 catPattMed :: [Pattern Time] catPattMed = pure <$> xs4 catPattMedB :: [Pattern Time] catPattMedB = pure <$> xs5 catPattBig :: [Pattern Time] catPattBig = pure <$> xs6 timeCatMed :: [(Time, Pattern Time)] timeCatMed = zip xs5 catPattMed timeCatBig :: [(Time, Pattern Time)] timeCatBig = zip xs6 catPattBig appendBig :: [Pattern Time] appendBig = pure <$> xsA pattApp1 :: Pattern [Time] pattApp1 = sequence catPattBig pattApp2 :: Pattern [Time] pattApp2 = sequence appendBig {- Arc Inputs -} arcFunc :: Arc -> Arc arcFunc (Arc s e) = Arc (s * 2) (e * 4) wqaMed :: Pattern Time wqaMed = fromList xs5 wqaBig :: Pattern Time wqaBig = fromList xs6 {- fix inputs -} fixArg1 :: ControlPattern fixArg1 = pF "cc64" 1 fixArg2 :: ControlPattern fixArg2 = fix ( # crush 4 ) (pF "cc65" 1) $ fix ( stut' 4 (0.125/4) ( + up "1" )) (pF "cc66" 1) $ fix ( |*| speed "-1" ) (pF "cc67" 1) $ fix ( (# delaytime 0.125).(# delay 0.5)) (pF "cc68" 1) $ fix ( # coarse 12) (pF "cc69" 1) $ s "[808bd:1(3,8), dr(7,8)]" # pF "cc64" (cF 0 "64") # pF "cc65" (cF 0 "65") # pF "cc66" (cF 0 "66") # pF "cc67" (cF 0 "67") # pF "cc68" (cF 0 "68") #  pF "cc69" (cF 0 "69") {- Euclid inputs -} ecA1 :: [Pattern Int] ecA1 = [1, 100] ecA2 :: Pattern String ecA2 = "x" tidal-1.5.2/bench/Speed/Tidal/PatternB.hs0000644000000000000000000000211407346545000016232 0ustar0000000000000000module Tidal.PatternB where import Criterion.Main import Tidal.Inputs import Sound.Tidal.Pattern arc1 = Arc 3 5 arc2 = Arc 4 6 arc3 = Arc 0 1 arc4 = Arc 1 2 withQueryTimeB :: [Benchmark] withQueryTimeB = [ bgroup "withQueryTime" [ bench "wqt whnf" $ whnf withQueryTime (*2) , bench "wqt2 whnf" $ whnf withQueryTime (+1) , bench "wqt nf" $ nf withQueryTime (*2) ] ] withResultArcB :: [Benchmark] withResultArcB = [ bgroup "withResultArc" [ bench "wqa med" $ whnf (withResultArc arcFunc) wqaMed , bench "wqa big" $ whnf (withResultArc arcFunc) wqaBig ] ] withQueryArcB :: [Benchmark] withQueryArcB = [ bgroup "withQueryArc" [ bench "wqa med" $ whnf (withQueryArc arcFunc) wqaMed , bench "wqa big" $ whnf (withQueryArc arcFunc) wqaBig ] ] subArcB :: [Benchmark] subArcB = [ bgroup "subArc" [ bench "intersecting" $ whnf (subArc arc1) arc2 , bench "non-intersecting" $ whnf (subArc arc3) arc4 ] ] sectB :: Benchmark sectB = bench "sect" $ whnf (sect arc1) arc2 hullB :: Benchmark hullB = bench "hull" $ whnf (hull arc1) arc2 tidal-1.5.2/bench/Speed/Tidal/UIB.hs0000644000000000000000000000113407346545000015133 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Tidal.UIB where import Criterion.Main import Tidal.Inputs import Sound.Tidal.Core import Sound.Tidal.UI fixB :: [Benchmark] fixB = [ bgroup "fix" [ bench "fix whnf" $ whnf (fix (fast 2) fixArg1) fixArg2 , bench "fix nf" $ nf (fix (fast 2) fixArg1) fixArg2 ] ] euclidB :: [Benchmark] euclidB = [ bgroup "euclid" [ bench "euclid" $ whnf (euclid (head ecA1) (head $ drop 1 ecA1)) ecA2 , bench "euclidFull" $ whnf (euclidFull (head ecA1) (head $ drop 1 ecA1) ecA2) ecA2 , bench "euclidBool" $ whnf (_euclidBool 1) 100000] ] tidal-1.5.2/src/Sound/Tidal/0000755000000000000000000000000007346545000013721 5ustar0000000000000000tidal-1.5.2/src/Sound/Tidal/Bjorklund.hs0000644000000000000000000000200107346545000016200 0ustar0000000000000000module Sound.Tidal.Bjorklund (bjorklund) where -- The below is (c) Rohan Drape, taken from the hmt library and -- distributed here under the terms of the GNU Public Licence. Tidal -- used to just include the library but removed for now due to -- dependency problems.. We could however likely benefit from other -- parts of the library.. type STEP a = ((Int,Int),([[a]],[[a]])) left :: STEP a -> STEP a left ((i,j),(xs,ys)) = let (xs',xs'') = splitAt j xs in ((j,i-j),(zipWith (++) xs' ys,xs'')) right :: STEP a -> STEP a right ((i,j),(xs,ys)) = let (ys',ys'') = splitAt i ys in ((i,j-i),(zipWith (++) xs ys',ys'')) bjorklund' :: STEP a -> STEP a bjorklund' (n,x) = let (i,j) = n in if min i j <= 1 then (n,x) else bjorklund' (if i > j then left (n,x) else right (n,x)) bjorklund :: (Int,Int) -> [Bool] bjorklund (i,j') = let j = j' - i x = replicate i [True] y = replicate j [False] (_,(x',y')) = bjorklund' ((i,j),(x,y)) in concat x' ++ concat y' tidal-1.5.2/src/Sound/Tidal/Carabiner.hs0000644000000000000000000000567107346545000016154 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-dodgy-imports -fno-warn-name-shadowing #-} module Sound.Tidal.Carabiner where import Network.Socket hiding (send, sendTo, recv, recvFrom) import Network.Socket.ByteString (send, recv) import qualified Data.ByteString.Char8 as B8 import Control.Concurrent (forkIO, takeMVar, putMVar) import qualified Sound.Tidal.Stream as S import Sound.Tidal.Tempo import System.Clock import Text.Read (readMaybe) import Control.Monad (when, forever) import Data.Maybe (isJust, fromJust) import qualified Sound.OSC.FD as O carabiner :: S.Stream -> Int -> Double -> IO Socket carabiner tidal bpc latency = do sock <- client tidal bpc latency "127.0.0.1" 17000 sendMsg sock "status\n" return sock client :: S.Stream -> Int -> Double -> String -> Int -> IO Socket client tidal bpc latency host port = withSocketsDo $ do addrInfo <- getAddrInfo Nothing (Just host) (Just $ show port) let serverAddr = head addrInfo sock <- socket (addrFamily serverAddr) Stream defaultProtocol connect sock (addrAddress serverAddr) _ <- forkIO $ listener tidal bpc latency sock -- sendMsg sock "status\n" -- threadDelay 10000000 return sock listener :: S.Stream -> Int -> Double -> Socket -> IO () listener tidal bpc latency sock = forever $ do rMsg <- recv sock 1024 let msg = B8.unpack rMsg (name:_:ws) = words msg pairs = pairs' ws pairs' (a:b:xs) = (a,b):(pairs' xs) pairs' _ = [] act tidal bpc latency name pairs act :: S.Stream -> Int -> Double -> String -> [(String, String)] -> IO () act tidal bpc latency "status" pairs = do let start = (lookup ":start" pairs >>= readMaybe) :: Maybe Integer bpm = (lookup ":bpm" pairs >>= readMaybe) :: Maybe Double beat = (lookup ":beat" pairs >>= readMaybe) :: Maybe Double when (and [isJust start, isJust bpm, isJust beat]) $ do nowM <- getTime Monotonic nowO <- O.time let m = (fromIntegral $ sec nowM) + ((fromIntegral $ nsec nowM)/1000000000) d = nowO - m start' = ((fromIntegral $ fromJust start) / 1000000) startO = start' + d -- cyc = toRational $ (fromJust beat) / (fromIntegral bpc) tempo <- takeMVar (S.sTempoMV tidal) let tempo' = tempo {atTime = startO + latency, atCycle = 0, cps = ((fromJust bpm) / 60) / (fromIntegral bpc) } putMVar (S.sTempoMV tidal) $ tempo' act _ _ _ name _ = putStr $ "Unhandled thingie " ++ name sendMsg :: Socket -> String -> IO () sendMsg sock msg = do _ <- send sock $ B8.pack msg return () tidal-1.5.2/src/Sound/Tidal/Chords.hs0000644000000000000000000001243007346545000015477 0ustar0000000000000000module Sound.Tidal.Chords where import Data.Maybe import Sound.Tidal.Pattern major :: Num a => [a] major = [0,4,7] minor :: Num a => [a] minor = [0,3,7] major7 :: Num a => [a] major7 = [0,4,7,11] dom7 :: Num a => [a] dom7 = [0,4,7,10] minor7 :: Num a => [a] minor7 = [0,3,7,10] aug :: Num a => [a] aug = [0,4,8] dim :: Num a => [a] dim = [0,3,6] dim7 :: Num a => [a] dim7 = [0,3,6,9] one :: Num a => [a] one = [0] five :: Num a => [a] five = [0,7] plus :: Num a => [a] plus = [0,4,8] sharp5 :: Num a => [a] sharp5 = [0,4,8] msharp5 :: Num a => [a] msharp5 = [0,3,8] sus2 :: Num a => [a] sus2 = [0,2,7] sus4 :: Num a => [a] sus4 = [0,5,7] six :: Num a => [a] six = [0,4,7,9] m6 :: Num a => [a] m6 = [0,3,7,9] sevenSus2 :: Num a => [a] sevenSus2 = [0,2,7,10] sevenSus4 :: Num a => [a] sevenSus4 = [0,5,7,10] sevenFlat5 :: Num a => [a] sevenFlat5 = [0,4,6,10] m7flat5 :: Num a => [a] m7flat5 = [0,3,6,10] sevenSharp5 :: Num a => [a] sevenSharp5 = [0,4,8,10] m7sharp5 :: Num a => [a] m7sharp5 = [0,3,8,10] nine :: Num a => [a] nine = [0,4,7,10,14] m9 :: Num a => [a] m9 = [0,3,7,10,14] m7sharp9 :: Num a => [a] m7sharp9 = [0,3,7,10,14] maj9 :: Num a => [a] maj9 = [0,4,7,11,14] nineSus4 :: Num a => [a] nineSus4 = [0,5,7,10,14] sixby9 :: Num a => [a] sixby9 = [0,4,7,9,14] m6by9 :: Num a => [a] m6by9 = [0,3,9,7,14] sevenFlat9 :: Num a => [a] sevenFlat9 = [0,4,7,10,13] m7flat9 :: Num a => [a] m7flat9 = [0,3,7,10,13] sevenFlat10 :: Num a => [a] sevenFlat10 = [0,4,7,10,15] nineSharp5 :: Num a => [a] nineSharp5 = [0,1,13] m9sharp5 :: Num a => [a] m9sharp5 = [0,1,14] sevenSharp5flat9 :: Num a => [a] sevenSharp5flat9 = [0,4,8,10,13] m7sharp5flat9 :: Num a => [a] m7sharp5flat9 = [0,3,8,10,13] eleven :: Num a => [a] eleven = [0,4,7,10,14,17] m11 :: Num a => [a] m11 = [0,3,7,10,14,17] maj11 :: Num a => [a] maj11 = [0,4,7,11,14,17] elevenSharp :: Num a => [a] elevenSharp = [0,4,7,10,14,18] m11sharp :: Num a => [a] m11sharp = [0,3,7,10,14,18] thirteen :: Num a => [a] thirteen = [0,4,7,10,14,17,21] m13 :: Num a => [a] m13 = [0,3,7,10,14,17,21] -- | @chordate cs m n@ selects the @n@th "chord" (a chord is a list of Ints) -- from a list of chords @cs@ and transposes it by @m@ -- chordate :: Num b => [[b]] -> b -> Int -> [b] -- chordate cs m n = map (+m) $ cs!!n -- | @enchord chords pn pc@ turns every note in the note pattern @pn@ into -- a chord, selecting from the chord lists @chords@ using the index pattern -- @pc@. For example, @Chords.enchord [Chords.major Chords.minor] "c g" "0 1"@ -- will create a pattern of a C-major chord followed by a G-minor chord. -- enchord :: Num a => [[a]] -> Pattern a -> Pattern Int -> Pattern a -- enchord chords pn pc = flatpat $ (chordate chords) <$> pn <*> pc chordTable :: Num a => [(String, [a])] chordTable = [("major", major), ("maj", major), ("minor", minor), ("min", minor), ("aug", aug), ("dim", dim), ("major7", major7), ("maj7", major7), ("dom7", dom7), ("minor7", minor7), ("min7", minor7), ("dim7", dim7), ("one", one), ("1", one), ("five", five), ("5", five), ("plus", plus), ("sharp5", sharp5), ("msharp5", msharp5), ("sus2", sus2), ("sus4", sus4), ("six", six), ("6", six), ("m6", m6), ("sevenSus2", sevenSus2), ("7sus2", sevenSus2), ("sevenSus4", sevenSus4), ("7sus4", sevenSus4), ("sevenFlat5", sevenFlat5), ("7f5", sevenFlat5), ("m7flat5", m7flat5), ("m7f5", m7flat5), ("sevenSharp5", sevenSharp5), ("7s5", sevenSharp5), ("m7sharp5", m7sharp5), ("m7s5", m7sharp5), ("nine", nine), ("m9", m9), ("m7sharp9", m7sharp9), ("m7s9", m7sharp9), ("maj9", maj9), ("nineSus4", nineSus4), ("ninesus4", nineSus4), ("9sus4", nineSus4), ("sixby9", sixby9), ("6by9", sixby9), ("m6by9", m6by9), ("sevenFlat9", sevenFlat9), ("7f9", sevenFlat9), ("m7flat9", m7flat9), ("m7f9", m7flat9), ("sevenFlat10", sevenFlat10), ("7f10", sevenFlat10), ("nineSharp5", nineSharp5), ("9s5", nineSharp5), ("m9sharp5", m9sharp5), ("m9s5", m9sharp5), ("sevenSharp5flat9", sevenSharp5flat9), ("7s5f9", sevenSharp5flat9), ("m7sharp5flat9", m7sharp5flat9), ("eleven", eleven), ("11", eleven), ("m11", m11), ("maj11", maj11), ("elevenSharp", elevenSharp), ("11s", elevenSharp), ("m11sharp", m11sharp), ("m11s", m11sharp), ("thirteen", thirteen), ("13", thirteen), ("m13", m13) ] chordL :: Num a => Pattern String -> Pattern [a] chordL p = (\name -> fromMaybe [] $ lookup name chordTable) <$> p chordList :: String chordList = unwords $ map fst (chordTable :: [(String, [Int])]) tidal-1.5.2/src/Sound/Tidal/Config.hs0000644000000000000000000000162707346545000015470 0ustar0000000000000000module Sound.Tidal.Config where data Config = Config {cCtrlListen :: Bool, cCtrlAddr :: String, cCtrlPort :: Int, cFrameTimespan :: Double, cTempoAddr :: String, cTempoPort :: Int, cTempoClientPort :: Int, cSendParts :: Bool, cSkipTicks :: Int } defaultConfig :: Config defaultConfig = Config {cCtrlListen = True, cCtrlAddr ="127.0.0.1", cCtrlPort = 6010, cFrameTimespan = 1/20, cTempoAddr = "127.0.0.1", cTempoPort = 9160, cTempoClientPort = 0, -- choose at random cSendParts = False, cSkipTicks = 10 } tidal-1.5.2/src/Sound/Tidal/Context.hs0000644000000000000000000000107607346545000015705 0ustar0000000000000000module Sound.Tidal.Context (module C) where import Prelude hiding ((<*), (*>)) import Data.Ratio as C import Sound.Tidal.Carabiner as C import Sound.Tidal.Config as C import Sound.Tidal.Control as C import Sound.Tidal.Core as C import Sound.Tidal.Params as C 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.Stream as C import Sound.Tidal.Transition as C import Sound.Tidal.UI as C import Sound.Tidal.Version as C import Sound.Tidal.EspGrid as C tidal-1.5.2/src/Sound/Tidal/Control.hs0000644000000000000000000003550107346545000015701 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings, FlexibleContexts #-} module Sound.Tidal.Control where import Prelude hiding ((<*), (*>)) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isJust, fromJust) import Data.Ratio import Sound.Tidal.Pattern import Sound.Tidal.Core import Sound.Tidal.UI import qualified Sound.Tidal.Params as P import Sound.Tidal.Utils {- | `spin` will "spin" a layer up a pattern the given number of times, with each successive layer offset in time by an additional `1/n` of a cycle, and panned by an additional `1/n`. The result is a pattern that seems to spin around. This function works best on multichannel systems. @ d1 $ slow 3 $ spin 4 $ sound "drum*3 tabla:4 [arpy:2 ~ arpy] [can:2 can:3]" @ -} spin :: Pattern Int -> ControlPattern -> ControlPattern spin = tParam _spin _spin :: Int -> ControlPattern -> ControlPattern _spin copies p = stack $ map (\i -> let offset = toInteger i % toInteger copies in offset `rotL` p # P.pan (pure $ fromRational offset) ) [0 .. (copies - 1)] {- | `chop` granualizes every sample in place as it is played, turning a pattern of samples into a pattern of sample parts. Use an integer value to specify how many granules each sample is chopped into: @ d1 $ chop 16 $ sound "arpy arp feel*4 arpy*4" @ Different values of `chop` can yield very different results, depending on the samples used: @ d1 $ chop 16 $ sound (samples "arpy*8" (run 16)) d1 $ chop 32 $ sound (samples "arpy*8" (run 16)) d1 $ chop 256 $ sound "bd*4 [sn cp] [hh future]*2 [cp feel]" @ -} chop :: Pattern Int -> ControlPattern -> ControlPattern chop = tParam _chop chopArc :: Arc -> Int -> [Arc] chopArc (Arc s e) n = map (\i -> Arc (s + (e-s)*(fromIntegral i/fromIntegral n)) (s + (e-s)*(fromIntegral (i+1) / fromIntegral n))) [0 .. n-1] _chop :: Int -> ControlPattern -> ControlPattern _chop n = withEvents (concatMap chopEvent) where -- for each part, chopEvent :: Event ControlMap -> [Event ControlMap] chopEvent (Event c (Just w) p' v) = map (chomp c v (length $ chopArc w n)) $ arcs w p' -- ignoring 'analog' events (those without wholes), chopEvent _ = [] -- cut whole into n bits, and number them arcs w' p' = numberedArcs p' $ chopArc w' n -- each bit is a new whole, with part that's the intersection of old part and new whole -- (discard new parts that don't intersect with the old part) numberedArcs :: Arc -> [Arc] -> [(Int, (Arc, Arc))] numberedArcs p' as = map ((fromJust <$>) <$>) $ filter (isJust . snd . snd) $ enumerate $ map (\a -> (a, subArc p' a)) as -- begin set to i/n, end set to i+1/n -- if the old event had a begin and end, then multiply the new -- begin and end values by the old difference (end-begin), and -- add the old begin chomp :: Context -> ControlMap -> Int -> (Int, (Arc, Arc)) -> Event ControlMap chomp c v n' (i, (w,p')) = Event c (Just w) p' (Map.insert "begin" (VF b') $ Map.insert "end" (VF e') v) where b = fromMaybe 0 $ do v' <- Map.lookup "begin" v getF v' e = fromMaybe 1 $ do v' <- Map.lookup "end" v getF v' d = e-b b' = ((fromIntegral i/fromIntegral n') * d) + b e' = ((fromIntegral (i+1) / fromIntegral n') * d) + b {- -- A simpler definition than the above, but this version doesn't chop -- with multiple chops, and only works with a single 'pure' event.. _chop' :: Int -> ControlPattern -> ControlPattern _chop' n p = begin (fromList begins) # end (fromList ends) # p where step = 1/(fromIntegral n) begins = [0,step .. (1-step)] ends = (tail begins) ++ [1] -} {- | Striate is a kind of granulator, for example: @ d1 $ striate 3 $ sound "ho ho:2 ho:3 hc" @ This plays the loop the given number of times, but triggering progressive portions of each sample. So in this case it plays the loop three times, the first time playing the first third of each sample, then the second time playing the second third of each sample, etc.. With the highhat samples in the above example it sounds a bit like reverb, but it isn't really. You can also use striate with very long samples, to cut it into short chunks and pattern those chunks. This is where things get towards granular synthesis. The following cuts a sample into 128 parts, plays it over 8 cycles and manipulates those parts by reversing and rotating the loops. @ d1 $ slow 8 $ striate 128 $ sound "bev" @ -} striate :: Pattern Int -> ControlPattern -> ControlPattern striate = tParam _striate _striate :: Int -> ControlPattern -> ControlPattern _striate n p = fastcat $ map offset [0 .. n-1] where offset i = mergePlayRange (fromIntegral i / fromIntegral n, fromIntegral (i+1) / fromIntegral n) <$> p mergePlayRange :: (Double, Double) -> ControlMap -> ControlMap mergePlayRange (b,e) cm = Map.insert "begin" (VF $ (b*d')+b') $ Map.insert "end" (VF $ (e*d')+b') cm where b' = fromMaybe 0 $ Map.lookup "begin" cm >>= getF e' = fromMaybe 1 $ Map.lookup "end" cm >>= getF d' = e' - b' {-| The `striateBy` function is a variant of `striate` with an extra parameter, which specifies the length of each part. The `striateBy` function still scans across the sample over a single cycle, but if each bit is longer, it creates a sort of stuttering effect. For example the following will cut the bev sample into 32 parts, but each will be 1/16th of a sample long: @ d1 $ slow 32 $ striateBy 32 (1/16) $ sound "bev" @ Note that `striate` uses the `begin` and `end` parameters internally. This means that if you're using `striate` (or `striateBy`) you probably shouldn't also specify `begin` or `end`. -} striateBy :: Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern striateBy = tParam2 _striateBy -- Old name for striateBy, here as a deprecated alias for now. striate' :: Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern striate' = striateBy _striateBy :: Int -> Double -> ControlPattern -> ControlPattern _striateBy n f p = fastcat $ map (offset . fromIntegral) [0 .. n-1] where offset i = p # P.begin (pure (slot * i) :: Pattern Double) # P.end (pure ((slot * i) + f) :: Pattern Double) slot = (1 - f) / fromIntegral n {- | `gap` is similar to `chop` in that it granualizes every sample in place as it is played, but every other grain is silent. Use an integer value to specify how many granules each sample is chopped into: @ d1 $ gap 8 $ sound "jvbass" d1 $ gap 16 $ sound "[jvbass drum:4]" @-} gap :: Pattern Int -> ControlPattern -> ControlPattern gap = tParam _gap _gap :: Int -> ControlPattern -> ControlPattern _gap n p = _fast (toRational n) (cat [pure 1, silence]) |>| _chop n p {- | `weave` applies a function smoothly over an array of different patterns. It uses an `OscPattern` to apply the function at different levels to each pattern, creating a weaving effect. @ d1 $ weave 3 (shape $ sine1) [sound "bd [sn drum:2*2] bd*2 [sn drum:1]", sound "arpy*8 ~"] @ -} weave :: Time -> ControlPattern -> [ControlPattern] -> ControlPattern weave t p ps = weave' t p (map (#) ps) {- | `weaveWith` is similar in that it blends functions at the same time at different amounts over a pattern: @ d1 $ weaveWith 3 (sound "bd [sn drum:2*2] bd*2 [sn drum:1]") [density 2, (# speed "0.5"), chop 16] @ -} weaveWith :: Time -> Pattern a -> [Pattern a -> Pattern a] -> Pattern a weaveWith t p fs | l == 0 = silence | otherwise = _slow t $ stack $ map (\(i, f) -> (fromIntegral i % l) `rotL` _fast t (f (_slow t p))) (zip [0 :: Int ..] fs) where l = fromIntegral $ length fs weave' :: Time -> Pattern a -> [Pattern a -> Pattern a] -> Pattern a weave' = weaveWith {- | (A function that takes two ControlPatterns, and blends them together into a new ControlPattern. An ControlPattern is basically a pattern of messages to a synthesiser.) Shifts between the two given patterns, using distortion. Example: @ d1 $ interlace (sound "bd sn kurt") (every 3 rev $ sound "bd sn:2") @ -} interlace :: ControlPattern -> ControlPattern -> ControlPattern interlace a b = weave 16 (P.shape (sine * 0.9)) [a, b] {- {- | Just like `striate`, but also loops each sample chunk a number of times specified in the second argument. The primed version is just like `striateBy`, where the loop count is the third argument. For example: @ d1 $ striateL' 3 0.125 4 $ sound "feel sn:2" @ Like `striate`, these use the `begin` and `end` parameters internally, as well as the `loop` parameter for these versions. -} striateL :: Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern striateL = tParam2 _striateL striateL' :: Pattern Int -> Pattern Double -> Pattern Int -> ControlPattern -> ControlPattern striateL' = tParam3 _striateL' _striateL :: Int -> Int -> ControlPattern -> ControlPattern _striateL n l p = _striate n p # loop (pure $ fromIntegral l) _striateL' n f l p = _striateBy n f p # loop (pure $ fromIntegral l) en :: [(Int, Int)] -> Pattern String -> Pattern String en ns p = stack $ map (\(i, (k, n)) -> _e k n (samples p (pure i))) $ enumerate ns -} slice :: Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern slice pN pI p = P.begin b # P.end e # p where b = div' <$> pI <* pN e = (\i n -> div' i n + div' 1 n) <$> pI <* pN div' num den = fromIntegral (num `mod` den) / fromIntegral den _slice :: Int -> Int -> ControlPattern -> ControlPattern _slice n i p = p # P.begin (pure $ fromIntegral i / fromIntegral n) # P.end (pure $ fromIntegral (i+1) / fromIntegral n) randslice :: Pattern Int -> ControlPattern -> ControlPattern randslice = tParam $ \n p -> innerJoin $ (\i -> _slice n i p) <$> irand n _splice :: Int -> Pattern Int -> ControlPattern -> Pattern (Map.Map String Value) _splice bits ipat pat = withEvent f (slice (pure bits) ipat pat) # P.unit (pure "c") where f ev = ev {value = Map.insert "speed" (VF d) (value ev)} where d = sz / (fromRational $ (wholeStop ev) - (wholeStart ev)) sz = 1/(fromIntegral bits) splice :: Pattern Int -> Pattern Int -> ControlPattern -> Pattern (Map.Map String Value) splice bitpat ipat pat = innerJoin $ (\bits -> _splice bits ipat pat) <$> bitpat {- | `loopAt` makes a sample fit the given number of cycles. Internally, it works by setting the `unit` parameter to "c", changing the playback speed of the sample with the `speed` parameter, and setting setting the `density` of the pattern to match. @ d1 $ loopAt 4 $ sound "breaks125" d1 $ juxBy 0.6 (|* speed "2") $ slowspread (loopAt) [4,6,2,3] $ chop 12 $ sound "fm:14" @ -} loopAt :: Pattern Time -> ControlPattern -> ControlPattern loopAt n p = slow n p |* P.speed (fromRational <$> (1/n)) # P.unit (pure "c") hurry :: Pattern Rational -> ControlPattern -> ControlPattern hurry x = (|* P.speed (fromRational <$> x)) . fast x {- | Smash is a combination of `spread` and `striate` - it cuts the samples into the given number of bits, and then cuts between playing the loop at different speeds according to the values in the list. So this: @ d1 $ smash 3 [2,3,4] $ sound "ho ho:2 ho:3 hc" @ Is a bit like this: @ d1 $ spread (slow) [2,3,4] $ striate 3 $ sound "ho ho:2 ho:3 hc" @ This is quite dancehall: @ d1 $ (spread' slow "1%4 2 1 3" $ spread (striate) [2,3,4,1] $ sound "sn:2 sid:3 cp sid:4") # speed "[1 2 1 1]/2" @ -} smash :: Pattern Int -> [Pattern Time] -> ControlPattern -> Pattern ControlMap smash n xs p = slowcat $ map (`slow` p') xs where p' = striate n p {- | an altenative form to `smash` is `smash'` which will use `chop` instead of `striate`. -} smash' :: Int -> [Pattern Time] -> ControlPattern -> Pattern ControlMap smash' n xs p = slowcat $ map (`slow` p') xs where p' = _chop n p {- | Stut applies a type of delay to a pattern. It has three parameters, which could be called depth, feedback and time. Depth is an integer and the others floating point. This adds a bit of echo: @ d1 $ stut 4 0.5 0.2 $ sound "bd sn" @ The above results in 4 echos, each one 50% quieter than the last, with 1/5th of a cycle between them. It is possible to reverse the echo: @ d1 $ stut 4 0.5 (-0.2) $ sound "bd sn" @ -} stut :: Pattern Integer -> Pattern Double -> Pattern Rational -> ControlPattern -> ControlPattern stut = tParam3 _stut _stut :: Integer -> Double -> Rational -> ControlPattern -> ControlPattern _stut count feedback steptime p = stack (p:map (\x -> ((x%1)*steptime) `rotR` (p |* P.gain (pure $ scalegain (fromIntegral x)))) [1..(count-1)]) where scalegain = (+feedback) . (*(1-feedback)) . (/ fromIntegral count) . (fromIntegral count -) {- | Instead of just decreasing volume to produce echoes, @stut'@ allows to apply a function for each step and overlays the result delayed by the given time. @ d1 $ stut' 2 (1%3) (# vowel "{a e i o u}%2") $ sound "bd sn" @ In this case there are two _overlays_ delayed by 1/3 of a cycle, where each has the @vowel@ filter applied. -} stutWith :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a stutWith n t f p = innerJoin $ (\a b -> _stutWith a b f p) <$> n <* t _stutWith :: (Num n, Ord n) => n -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a _stutWith count steptime f p | count <= 1 = p | otherwise = overlay (f (steptime `rotR` _stutWith (count-1) steptime f p)) p -- | The old name for stutWith stut' :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a stut' = stutWith -- | Turns a pattern of seconds into a pattern of (rational) cycle durations sec :: Fractional a => Pattern a -> Pattern a sec p = (realToFrac <$> cF 1 "_cps") *| p -- | Turns a pattern of milliseconds into a pattern of (rational) -- cycle durations, according to the current cps. msec :: Fractional a => Pattern a -> Pattern a msec p = ((realToFrac . (/1000)) <$> cF 1 "_cps") *| p _trigger :: Show a => Bool -> a -> Pattern b -> Pattern b _trigger quant k pat = pat {query = q} where q st = query ((offset st) ~> pat) st f | quant = (fromIntegral :: Int -> Rational) . round | otherwise = id offset st = fromMaybe (pure 0) $ do p <- Map.lookup ctrl (controls st) return $ ((f . fromMaybe 0 . getR) <$> p) ctrl = "_t_" ++ show k trigger :: Show a => a -> Pattern b -> Pattern b trigger = _trigger False qtrigger :: Show a => a -> Pattern b -> Pattern b qtrigger = _trigger True qt :: Show a => a -> Pattern b -> Pattern b qt = qtrigger reset :: Show a => a -> Pattern b -> Pattern b reset k pat = pat {query = q} where q st = query ((offset st) ~> (when (<=0) (const silence) pat)) st f = (fromIntegral :: Int -> Rational) . floor offset st = fromMaybe (pure 0) $ do p <- Map.lookup ctrl (controls st) return $ ((f . fromMaybe 0 . getR) <$> p) ctrl = "_t_" ++ show k tidal-1.5.2/src/Sound/Tidal/Core.hs0000644000000000000000000005174407346545000015160 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns #-} module Sound.Tidal.Core where import Prelude hiding ((<*), (*>)) import Data.Fixed (mod') import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Sound.Tidal.Pattern -- ** Elemental patterns -- | An empty pattern silence :: Pattern a silence = empty -- | Takes a function from time to values, and turns it into a 'Pattern'. sig :: (Time -> a) -> Pattern a sig f = Pattern q where q (State (Arc s e) _) | s > e = [] | otherwise = [Event (Context []) Nothing (Arc s e) (f (s+((e-s)/2)))] -- | @sine@ returns a 'Pattern' of continuous 'Fractional' values following a -- sinewave with frequency of one cycle, and amplitude from 0 to 1. sine :: Fractional a => Pattern a sine = sig $ \t -> (sin_rat ((pi :: Double) * 2 * fromRational t) + 1) / 2 where sin_rat = fromRational . toRational . sin -- | @cosine@ is a synonym for @0.25 ~> sine@. cosine :: Fractional a => Pattern a cosine = 0.25 `rotR` sine -- | @saw@ is the equivalent of 'sine' for (ascending) sawtooth waves. saw :: (Fractional a, Real a) => Pattern a saw = sig $ \t -> mod' (fromRational t) 1 -- | @isaw@ is the equivalent of 'sine' for inverse (descending) sawtooth waves. isaw :: (Fractional a, Real a) => Pattern a isaw = (1-) <$> saw -- | @tri@ is the equivalent of 'sine' for triangular waves. tri :: (Fractional a, Real a) => Pattern a tri = fastAppend saw isaw -- | @square@ is the equivalent of 'sine' for square waves. square :: (Fractional a) => Pattern a square = sig $ \t -> fromIntegral ((floor $ mod' (fromRational t :: Double) 1 * 2) :: Integer) -- | @envL@ is a 'Pattern' of continuous 'Double' values, representing -- a linear interpolation between 0 and 1 during the first cycle, then -- staying constant at 1 for all following cycles. Possibly only -- useful if you're using something like the retrig function defined -- in tidal.el. envL :: Pattern Double envL = sig $ \t -> max 0 $ min (fromRational t) 1 -- | like 'envL' but reversed. envLR :: Pattern Double envLR = (1-) <$> envL -- | 'Equal power' version of 'env', for gain-based transitions envEq :: Pattern Double envEq = sig $ \t -> sqrt (sin (pi/2 * max 0 (min (fromRational (1-t)) 1))) -- | Equal power reversed envEqR :: Pattern Double envEqR = sig $ \t -> sqrt (cos (pi/2 * max 0 (min (fromRational (1-t)) 1))) -- ** Pattern algebra -- class for types that support a left-biased union class Unionable a where union :: a -> a -> a -- default union is just to take the left hand side.. instance Unionable a where union = const instance {-# OVERLAPPING #-} Unionable ControlMap where union = Map.union (|+|) :: (Applicative a, Num b) => a b -> a b -> a b a |+| b = (+) <$> a <*> b (|+ ) :: Num a => Pattern a -> Pattern a -> Pattern a a |+ b = (+) <$> a <* b ( +|) :: Num a => Pattern a -> Pattern a -> Pattern a a +| b = (+) <$> a *> b (|++|) :: Applicative a => a String -> a String -> a String a |++| b = (++) <$> a <*> b (|++ ) :: Pattern String -> Pattern String -> Pattern String a |++ b = (++) <$> a <* b ( ++|) :: Pattern String -> Pattern String -> Pattern String a ++| b = (++) <$> a *> b (|/|) :: (Applicative a, Fractional b) => a b -> a b -> a b a |/| b = (/) <$> a <*> b (|/ ) :: Fractional a => Pattern a -> Pattern a -> Pattern a a |/ b = (/) <$> a <* b ( /|) :: Fractional a => Pattern a -> Pattern a -> Pattern a a /| b = (/) <$> a *> b (|*|) :: (Applicative a, Num b) => a b -> a b -> a b a |*| b = (*) <$> a <*> b (|* ) :: Num a => Pattern a -> Pattern a -> Pattern a a |* b = (*) <$> a <* b ( *|) :: Num a => Pattern a -> Pattern a -> Pattern a a *| b = (*) <$> a *> b (|-|) :: (Applicative a, Num b) => a b -> a b -> a b a |-| b = (-) <$> a <*> b (|- ) :: Num a => Pattern a -> Pattern a -> Pattern a a |- b = (-) <$> a <* b ( -|) :: Num a => Pattern a -> Pattern a -> Pattern a a -| b = (-) <$> a *> b (|%|) :: (Applicative a, Real b) => a b -> a b -> a b a |%| b = mod' <$> a <*> b (|% ) :: Real a => Pattern a -> Pattern a -> Pattern a a |% b = mod' <$> a <* b ( %|) :: Real a => Pattern a -> Pattern a -> Pattern a a %| b = mod' <$> a *> b (|**|) :: (Applicative a, Floating b) => a b -> a b -> a b a |**| b = (**) <$> a <*> b (|** ) :: Floating a => Pattern a -> Pattern a -> Pattern a a |** b = (**) <$> a <* b ( **|) :: Floating a => Pattern a -> Pattern a -> Pattern a a **| b = (**) <$> a *> b (|>|) :: (Applicative a, Unionable b) => a b -> a b -> a b a |>| b = flip union <$> a <*> b (|> ) :: Unionable a => Pattern a -> Pattern a -> Pattern a a |> b = flip union <$> a <* b ( >|) :: Unionable a => Pattern a -> Pattern a -> Pattern a a >| b = flip union <$> a *> b (|<|) :: (Applicative a, Unionable b) => a b -> a b -> a b a |<| b = union <$> a <*> b (|< ) :: Unionable a => Pattern a -> Pattern a -> Pattern a a |< b = union <$> a <* b ( <|) :: Unionable a => Pattern a -> Pattern a -> Pattern a a <| b = union <$> a *> b -- Backward compatibility - structure from left, values from right. (#) :: Unionable b => Pattern b -> Pattern b -> Pattern b (#) = (|>) -- ** Constructing patterns -- | Turns a list of values into a pattern, playing one of them per cycle. fromList :: [a] -> Pattern a fromList = cat . map pure -- | Turns a list of values into a pattern, playing all of them per cycle. fastFromList :: [a] -> Pattern a fastFromList = fastcat . map pure -- | A synonym for 'fastFromList' listToPat :: [a] -> Pattern a listToPat = fastFromList -- | 'fromMaybes; is similar to 'fromList', but allows values to -- be optional using the 'Maybe' type, so that 'Nothing' results in -- gaps in the pattern. fromMaybes :: [Maybe a] -> Pattern a fromMaybes = fastcat . map f where f Nothing = silence f (Just x) = pure x -- | A pattern of whole numbers from 0 to the given number, in a single cycle. run :: (Enum a, Num a) => Pattern a -> Pattern a run = (>>= _run) _run :: (Enum a, Num a) => a -> Pattern a _run n = fastFromList [0 .. n-1] -- | From @1@ for the first cycle, successively adds a number until it gets up to @n@ scan :: (Enum a, Num a) => Pattern a -> Pattern a scan = (>>= _scan) _scan :: (Enum a, Num a) => a -> Pattern a _scan n = slowcat $ map _run [1 .. n] -- ** Combining patterns -- | Alternate between cycles of the two given patterns append :: Pattern a -> Pattern a -> Pattern a append a b = cat [a,b] -- | Like 'append', but for a list of patterns. Interlaces them, playing the first cycle from each -- in turn, then the second cycle from each, and so on. cat :: [Pattern a] -> Pattern a cat [] = silence cat ps = Pattern $ q where n = length ps q st = concatMap (f st) $ arcCyclesZW (arc st) f st a = query (withResultTime (+offset) p) $ st {arc = Arc (subtract offset (start a)) (subtract offset (stop a))} where p = ps !! i cyc = (floor $ start a) :: Int i = cyc `mod` n offset = (fromIntegral $ cyc - ((cyc - i) `div` n)) :: Time -- | Alias for 'cat' slowCat :: [Pattern a] -> Pattern a slowCat = cat slowcat :: [Pattern a] -> Pattern a slowcat = slowCat -- | Alias for 'append' slowAppend :: Pattern a -> Pattern a -> Pattern a slowAppend = append slowappend :: Pattern a -> Pattern a -> Pattern a slowappend = append -- | Like 'append', but twice as fast fastAppend :: Pattern a -> Pattern a -> Pattern a fastAppend a b = _fast 2 $ append a b fastappend :: Pattern a -> Pattern a -> Pattern a fastappend = fastAppend -- | The same as 'cat', but speeds up the result by the number of -- patterns there are, so the cycles from each are squashed to fit a -- single cycle. fastCat :: [Pattern a] -> Pattern a fastCat ps = _fast (toTime $ length ps) $ cat ps fastcat :: [Pattern a] -> Pattern a fastcat = fastCat -- | Similar to @fastCat@, but each pattern is given a relative duration timeCat :: [(Time, Pattern a)] -> Pattern a timeCat tps = stack $ map (\(s,e,p) -> compressArc (Arc (s/total) (e/total)) p) $ arrange 0 tps where total = sum $ map fst tps arrange :: Time -> [(Time, Pattern a)] -> [(Time, Time, Pattern a)] arrange _ [] = [] arrange t ((t',p):tps') = (t,t+t',p) : arrange (t+t') tps' -- | 'overlay' combines two 'Pattern's into a new pattern, so that -- their events are combined over time. overlay :: Pattern a -> Pattern a -> Pattern a overlay !p !p' = Pattern $ \st -> query p st ++ query p' st -- | An infix alias of @overlay@ (<>) :: Pattern a -> Pattern a -> Pattern a (<>) = overlay -- | 'stack' combines a list of 'Pattern's into a new pattern, so that -- their events are combined over time. stack :: [Pattern a] -> Pattern a stack = foldr overlay silence -- ** Manipulating time -- | Shifts a pattern back in time by the given amount, expressed in cycles (<~) :: Pattern Time -> Pattern a -> Pattern a (<~) = tParam rotL -- | Shifts a pattern forward in time by the given amount, expressed in cycles (~>) :: Pattern Time -> Pattern a -> Pattern a (~>) = tParam rotR -- | Speed up a pattern by the given time pattern fast :: Pattern Time -> Pattern a -> Pattern a fast = tParam _fast -- | Slow down a pattern by the factors in the given time pattern, 'squeezing' -- the pattern to fit the slot given in the time pattern fastSqueeze :: Pattern Time -> Pattern a -> Pattern a fastSqueeze = tParamSqueeze _fast -- | An alias for @fast@ density :: Pattern Time -> Pattern a -> Pattern a density = fast _fast :: Time -> Pattern a -> Pattern a _fast r p | r == 0 = silence | r < 0 = rev $ _fast (negate r) p | otherwise = withResultTime (/ r) $ withQueryTime (* r) p -- | Slow down a pattern by the given time pattern slow :: Pattern Time -> Pattern a -> Pattern a slow = tParam _slow _slow :: Time -> Pattern a -> Pattern a _slow 0 _ = silence _slow r p = _fast (1/r) p -- | Slow down a pattern by the factors in the given time pattern, 'squeezing' -- the pattern to fit the slot given in the time pattern slowSqueeze :: Pattern Time -> Pattern a -> Pattern a slowSqueeze = tParamSqueeze _slow -- | An alias for @slow@ sparsity :: Pattern Time -> Pattern a -> Pattern a sparsity = slow -- | @rev p@ returns @p@ with the event positions in each cycle -- reversed (or mirrored). rev :: Pattern a -> Pattern a rev p = splitQueries $ p { query = \st -> map makeWholeAbsolute $ mapParts (mirrorArc (midCycle $ arc st)) $ map makeWholeRelative (query p st {arc = mirrorArc (midCycle $ arc st) (arc st) }) } where makeWholeRelative :: Event a -> Event a makeWholeRelative (e@(Event {whole = Nothing})) = e makeWholeRelative (Event c (Just (Arc s e)) p'@(Arc s' e') v) = Event c (Just $ Arc (s'-s) (e-e')) p' v makeWholeAbsolute :: Event a -> Event a makeWholeAbsolute (e@(Event {whole = Nothing})) = e makeWholeAbsolute (Event c (Just (Arc s e)) p'@(Arc s' e') v) = Event c (Just $ Arc (s'-e) (e'+s)) p' v midCycle :: Arc -> Time midCycle (Arc s _) = sam s + 0.5 mapParts :: (Arc -> Arc) -> [Event a] -> [Event a] mapParts f es = (\(Event c w p' v) -> Event c w (f p') v) <$> es -- | Returns the `mirror image' of a 'Arc' around the given point in time mirrorArc :: Time -> Arc -> Arc mirrorArc mid' (Arc s e) = Arc (mid' - (e-mid')) (mid'+(mid'-s)) {- | Plays a portion of a pattern, specified by a time arc (start and end time). The new resulting pattern is played over the time period of the original pattern: @ d1 $ zoom (0.25, 0.75) $ sound "bd*2 hh*3 [sn bd]*2 drum" @ In the pattern above, `zoom` is used with an arc from 25% to 75%. It is equivalent to this pattern: @ d1 $ sound "hh*3 [sn bd]*2" @ -} zoom :: (Time, Time) -> Pattern a -> Pattern a zoom (s,e) = zoomArc (Arc s e) zoomArc :: Arc -> Pattern a -> Pattern a zoomArc (Arc s e) p = splitQueries $ withResultArc (mapCycle ((/d) . subtract s)) $ withQueryArc (mapCycle ((+s) . (*d))) p where d = e-s -- | @fastGap@ is similar to 'fast' but maintains its cyclic -- alignment. For example, @fastGap 2 p@ would squash the events in -- pattern @p@ into the first half of each cycle (and the second -- halves would be empty). The factor should be at least 1 fastGap :: Pattern Time -> Pattern a -> Pattern a fastGap = tParam _fastGap -- | An alias for @fastGap@ densityGap :: Pattern Time -> Pattern a -> Pattern a densityGap = fastGap compress :: (Time,Time) -> Pattern a -> Pattern a compress (s,e) = compressArc (Arc s e) compressTo :: (Time,Time) -> Pattern a -> Pattern a compressTo (s,e) = compressArcTo (Arc s e) repeatCycles :: Int -> Pattern a -> Pattern a repeatCycles n p = cat (replicate n p) fastRepeatCycles :: Int -> Pattern a -> Pattern a fastRepeatCycles n p = cat (replicate n p) -- | * Higher order functions -- | Functions which work on other functions (higher order functions) -- | @every n f p@ applies the function @f@ to @p@, but only affects -- every @n@ cycles. every :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a every tp f p = innerJoin $ (\t -> _every t f p) <$> tp _every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a _every 0 _ p = p _every n f p = when ((== 0) . (`mod` n)) f p -- | @every n o f'@ is like @every n f@ with an offset of @o@ cycles every' :: Pattern Int -> Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a every' np op f p = do { n <- np; o <- op; _every' n o f p } _every' :: Int -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a _every' n o = when ((== o) . (`mod` n)) -- | @foldEvery ns f p@ applies the function @f@ to @p@, and is applied for -- each cycle in @ns@. foldEvery :: [Int] -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a foldEvery ns f p = foldr (`_every` f) p ns {-| Only `when` the given test function returns `True` the given pattern transformation is applied. The test function will be called with the current cycle as a number. @ d1 $ when ((elem '4').show) (striate 4) $ sound "hh hc" @ The above will only apply `striate 4` to the pattern if the current cycle number contains the number 4. So the fourth cycle will be striated and the fourteenth and so on. Expect lots of striates after cycle number 399. -} when :: (Int -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a when test f p = splitQueries $ p {query = apply} where apply st | test (floor $ start $ arc st) = query (f p) st | otherwise = query p st -- | Like 'when', but works on continuous time values rather than cycle numbers. whenT :: (Time -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a whenT test f p = splitQueries $ p {query = apply} where apply st | test (start $ arc st) = query (f p) st | otherwise = query p st _getP_ :: (Value -> Maybe a) -> Pattern Value -> Pattern a _getP_ f pat = filterJust $ f <$> pat _getP :: a -> (Value -> Maybe a) -> Pattern Value -> Pattern a _getP d f pat = (fromMaybe d . f) <$> pat _cX :: a -> (Value -> Maybe a) -> String -> Pattern a _cX d f s = Pattern $ \(State a m) -> queryArc (maybe (pure d) (_getP d f) $ Map.lookup s m) a _cX_ :: (Value -> Maybe a) -> String -> Pattern a _cX_ f s = Pattern $ \(State a m) -> queryArc (maybe silence (_getP_ f) $ Map.lookup s m) a cF :: Double -> String -> Pattern Double cF d = _cX d getF cF_ :: String -> Pattern Double cF_ = _cX_ getF cF0 :: String -> Pattern Double cF0 = _cX 0 getF cI :: Int -> String -> Pattern Int cI d = _cX d getI cI_ :: String -> Pattern Int cI_ = _cX_ getI cI0 :: String -> Pattern Int cI0 = _cX 0 getI cB :: Bool -> String -> Pattern Bool cB d = _cX d getB cB_ :: String -> Pattern Bool cB_ = _cX_ getB cB0 :: String -> Pattern Bool cB0 = _cX False getB cR :: Rational -> String -> Pattern Rational cR d = _cX d getR cR_ :: String -> Pattern Rational cR_ = _cX_ getR cR0 :: String -> Pattern Rational cR0 = _cX 0 getR cT :: Time -> String -> Pattern Time cT = cR cT0 :: String -> Pattern Time cT0 = cR0 cT_ :: String -> Pattern Time cT_ = cR_ cS :: String -> String -> Pattern String cS d = _cX d getS cS_ :: String -> Pattern String cS_ = _cX_ getS cS0 :: String -> Pattern String cS0 = _cX "" getS -- Default controller inputs (for MIDI) in0 :: Pattern Double in0 = cF 0 "0" in1 :: Pattern Double in1 = cF 0 "1" in2 :: Pattern Double in2 = cF 0 "2" in3 :: Pattern Double in3 = cF 0 "3" in4 :: Pattern Double in4 = cF 0 "4" in5 :: Pattern Double in5 = cF 0 "5" in6 :: Pattern Double in6 = cF 0 "6" in7 :: Pattern Double in7 = cF 0 "7" in8 :: Pattern Double in8 = cF 0 "8" in9 :: Pattern Double in9 = cF 0 "9" in10 :: Pattern Double in10 = cF 0 "10" in11 :: Pattern Double in11 = cF 0 "11" in12 :: Pattern Double in12 = cF 0 "12" in13 :: Pattern Double in13 = cF 0 "13" in14 :: Pattern Double in14 = cF 0 "14" in15 :: Pattern Double in15 = cF 0 "15" in16 :: Pattern Double in16 = cF 0 "16" in17 :: Pattern Double in17 = cF 0 "17" in18 :: Pattern Double in18 = cF 0 "18" in19 :: Pattern Double in19 = cF 0 "19" in20 :: Pattern Double in20 = cF 0 "20" in21 :: Pattern Double in21 = cF 0 "21" in22 :: Pattern Double in22 = cF 0 "22" in23 :: Pattern Double in23 = cF 0 "23" in24 :: Pattern Double in24 = cF 0 "24" in25 :: Pattern Double in25 = cF 0 "25" in26 :: Pattern Double in26 = cF 0 "26" in27 :: Pattern Double in27 = cF 0 "27" in28 :: Pattern Double in28 = cF 0 "28" in29 :: Pattern Double in29 = cF 0 "29" in30 :: Pattern Double in30 = cF 0 "30" in31 :: Pattern Double in31 = cF 0 "31" in32 :: Pattern Double in32 = cF 0 "32" in33 :: Pattern Double in33 = cF 0 "33" in34 :: Pattern Double in34 = cF 0 "34" in35 :: Pattern Double in35 = cF 0 "35" in36 :: Pattern Double in36 = cF 0 "36" in37 :: Pattern Double in37 = cF 0 "37" in38 :: Pattern Double in38 = cF 0 "38" in39 :: Pattern Double in39 = cF 0 "39" in40 :: Pattern Double in40 = cF 0 "40" in41 :: Pattern Double in41 = cF 0 "41" in42 :: Pattern Double in42 = cF 0 "42" in43 :: Pattern Double in43 = cF 0 "43" in44 :: Pattern Double in44 = cF 0 "44" in45 :: Pattern Double in45 = cF 0 "45" in46 :: Pattern Double in46 = cF 0 "46" in47 :: Pattern Double in47 = cF 0 "47" in48 :: Pattern Double in48 = cF 0 "48" in49 :: Pattern Double in49 = cF 0 "49" in50 :: Pattern Double in50 = cF 0 "50" in51 :: Pattern Double in51 = cF 0 "51" in52 :: Pattern Double in52 = cF 0 "52" in53 :: Pattern Double in53 = cF 0 "53" in54 :: Pattern Double in54 = cF 0 "54" in55 :: Pattern Double in55 = cF 0 "55" in56 :: Pattern Double in56 = cF 0 "56" in57 :: Pattern Double in57 = cF 0 "57" in58 :: Pattern Double in58 = cF 0 "58" in59 :: Pattern Double in59 = cF 0 "59" in60 :: Pattern Double in60 = cF 0 "60" in61 :: Pattern Double in61 = cF 0 "61" in62 :: Pattern Double in62 = cF 0 "62" in63 :: Pattern Double in63 = cF 0 "63" in64 :: Pattern Double in64 = cF 0 "64" in65 :: Pattern Double in65 = cF 0 "65" in66 :: Pattern Double in66 = cF 0 "66" in67 :: Pattern Double in67 = cF 0 "67" in68 :: Pattern Double in68 = cF 0 "68" in69 :: Pattern Double in69 = cF 0 "69" in70 :: Pattern Double in70 = cF 0 "70" in71 :: Pattern Double in71 = cF 0 "71" in72 :: Pattern Double in72 = cF 0 "72" in73 :: Pattern Double in73 = cF 0 "73" in74 :: Pattern Double in74 = cF 0 "74" in75 :: Pattern Double in75 = cF 0 "75" in76 :: Pattern Double in76 = cF 0 "76" in77 :: Pattern Double in77 = cF 0 "77" in78 :: Pattern Double in78 = cF 0 "78" in79 :: Pattern Double in79 = cF 0 "79" in80 :: Pattern Double in80 = cF 0 "80" in81 :: Pattern Double in81 = cF 0 "81" in82 :: Pattern Double in82 = cF 0 "82" in83 :: Pattern Double in83 = cF 0 "83" in84 :: Pattern Double in84 = cF 0 "84" in85 :: Pattern Double in85 = cF 0 "85" in86 :: Pattern Double in86 = cF 0 "86" in87 :: Pattern Double in87 = cF 0 "87" in88 :: Pattern Double in88 = cF 0 "88" in89 :: Pattern Double in89 = cF 0 "89" in90 :: Pattern Double in90 = cF 0 "90" in91 :: Pattern Double in91 = cF 0 "91" in92 :: Pattern Double in92 = cF 0 "92" in93 :: Pattern Double in93 = cF 0 "93" in94 :: Pattern Double in94 = cF 0 "94" in95 :: Pattern Double in95 = cF 0 "95" in96 :: Pattern Double in96 = cF 0 "96" in97 :: Pattern Double in97 = cF 0 "97" in98 :: Pattern Double in98 = cF 0 "98" in99 :: Pattern Double in99 = cF 0 "99" in100 :: Pattern Double in100 = cF 0 "100" in101 :: Pattern Double in101 = cF 0 "101" in102 :: Pattern Double in102 = cF 0 "102" in103 :: Pattern Double in103 = cF 0 "103" in104 :: Pattern Double in104 = cF 0 "104" in105 :: Pattern Double in105 = cF 0 "105" in106 :: Pattern Double in106 = cF 0 "106" in107 :: Pattern Double in107 = cF 0 "107" in108 :: Pattern Double in108 = cF 0 "108" in109 :: Pattern Double in109 = cF 0 "109" in110 :: Pattern Double in110 = cF 0 "110" in111 :: Pattern Double in111 = cF 0 "111" in112 :: Pattern Double in112 = cF 0 "112" in113 :: Pattern Double in113 = cF 0 "113" in114 :: Pattern Double in114 = cF 0 "114" in115 :: Pattern Double in115 = cF 0 "115" in116 :: Pattern Double in116 = cF 0 "116" in117 :: Pattern Double in117 = cF 0 "117" in118 :: Pattern Double in118 = cF 0 "118" in119 :: Pattern Double in119 = cF 0 "119" in120 :: Pattern Double in120 = cF 0 "120" in121 :: Pattern Double in121 = cF 0 "121" in122 :: Pattern Double in122 = cF 0 "122" in123 :: Pattern Double in123 = cF 0 "123" in124 :: Pattern Double in124 = cF 0 "124" in125 :: Pattern Double in125 = cF 0 "125" in126 :: Pattern Double in126 = cF 0 "126" in127 :: Pattern Double in127 = cF 0 "127" tidal-1.5.2/src/Sound/Tidal/EspGrid.hs0000644000000000000000000000356707346545000015625 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Sound.Tidal.EspGrid (tidalEspGridLink,cpsEsp,espgrid) where import Control.Concurrent.MVar import Control.Concurrent (forkIO,threadDelay) import Control.Monad (forever) import Control.Exception import Sound.OSC.FD import Sound.Tidal.Tempo import Sound.Tidal.Stream (Stream, sTempoMV) parseEspTempo :: [Datum] -> Maybe (Tempo -> Tempo) parseEspTempo d = do on :: Integer <- datum_integral (d!!0) bpm <- datum_floating (d!!1) t1 :: Integer <- datum_integral (d!!2) t2 <- datum_integral (d!!3) n :: Integer <- datum_integral (d!!4) let nanos = (t1*1000000000) + t2 return $ \t -> t { atTime = ut_to_ntpr $ realToFrac nanos / 1000000000, atCycle = fromIntegral n, cps = bpm/60, paused = on == 0 } changeTempo :: MVar Tempo -> Packet -> IO () changeTempo t (Packet_Message msg) = case parseEspTempo (messageDatum msg) of Just f -> modifyMVarMasked_ t $ \t0 -> return (f t0) Nothing -> putStrLn "Warning: Unable to parse message from EspGrid as Tempo" changeTempo _ _ = putStrLn "Serious error: Can only process Packet_Message" tidalEspGridLink :: MVar Tempo -> IO () tidalEspGridLink _ = putStrLn "Function no longer supported, please use 'espgrid tidal' to connect to ESPgrid instead." espgrid :: Stream -> IO () espgrid st = do let t = sTempoMV st socket <- openUDP "127.0.0.1" 5510 _ <- forkIO $ forever $ do (do sendMessage socket $ Message "/esp/tempo/q" [] response <- waitAddress socket "/esp/tempo/r" Sound.Tidal.EspGrid.changeTempo t response threadDelay 200000) `catch` (\e -> putStrLn $ "exception caught in tidalEspGridLink: " ++ show (e :: SomeException)) return () cpsEsp :: Real t => t -> IO () cpsEsp t = do socket <- openUDP "127.0.0.1" 5510 sendMessage socket $ Message "/esp/beat/tempo" [float (t*60)] tidal-1.5.2/src/Sound/Tidal/Params.hs0000644000000000000000000006007507346545000015510 0ustar0000000000000000module Sound.Tidal.Params where import qualified Data.Map.Strict as Map import Sound.Tidal.Pattern import Sound.Tidal.Utils import Data.Maybe (fromMaybe) import Data.Word (Word8) -- | group multiple params into one grp :: [String -> ControlMap] -> Pattern String -> ControlPattern grp [] _ = empty grp fs p = splitby <$> p where splitby name = Map.unions $ map (\(v, f) -> f v) $ zip (split name) fs split :: String -> [String] split = wordsBy (==':') mF :: String -> String -> ControlMap mF name v = fromMaybe Map.empty $ do f <- readMaybe v return $ Map.singleton name (VF f) mI :: String -> String -> ControlMap mI name v = fromMaybe Map.empty $ do i <- readMaybe v return $ Map.singleton name (VI i) mS :: String -> String -> ControlMap mS name v = Map.singleton name (VS v) -- | Grouped params sound :: Pattern String -> ControlPattern sound = grp [mS "s", mF "n"] s :: Pattern String -> ControlPattern s = sound cc :: Pattern String -> ControlPattern cc = grp [mF "ccn", mF "ccv"] nrpn :: Pattern String -> ControlPattern nrpn = grp [mI "nrpn", mI "val"] -- | Singular params pF :: String -> Pattern Double -> ControlPattern pF name = fmap (Map.singleton name . VF) pI :: String -> Pattern Int -> ControlPattern pI name = fmap (Map.singleton name . VI) pS :: String -> Pattern String -> ControlPattern pS name = fmap (Map.singleton name . VS) pX :: String -> Pattern [Word8] -> ControlPattern pX name = fmap (Map.singleton name . VX) -- | patterns for internal sound routing toArg :: Pattern String -> ControlPattern toArg = pS "toArg" from :: Pattern Double -> ControlPattern from = pF "from" to :: Pattern Double -> ControlPattern to = pF "to" -- | a pattern of numbers that speed up (or slow down) samples while they play. accelerate :: Pattern Double -> ControlPattern accelerate = pF "accelerate" -- | Amplitude; like @gain@, but linear. amp :: Pattern Double -> ControlPattern amp = pF "amp" -- | a pattern of numbers to specify the attack time (in seconds) of an envelope applied to each sample. Only takes effect if `release` is also specified. attack :: Pattern Double -> ControlPattern attack = pF "attack" -- | a pattern of numbers from 0 to 1. Sets the center frequency of the band-pass filter. bandf :: Pattern Double -> ControlPattern bandf = pF "bandf" -- | a pattern of numbers from 0 to 1. Sets the q-factor of the band-pass filter.y bandq :: Pattern Double -> ControlPattern bandq = pF "bandq" {- | a pattern of numbers from 0 to 1. Skips the beginning of each sample, e.g. `0.25` to cut off the first quarter from each sample. Using `begin "-1"` combined with `cut "-1"` means that when the sample cuts itself it will begin playback from where the previous one left off, so it will sound like one seamless sample. This allows you to apply a synth param across a long sample in a way similar to `chop`: @ cps 0.5 d1 $ sound "breaks125*8" # unit "c" # begin "-1" # cut "-1" # coarse "1 2 4 8 16 32 64 128" @ This will play the `breaks125` sample and apply the changing `coarse` parameter over the sample. Compare to: @ d1 $ (chop 8 $ sounds "breaks125") # unit "c" # coarse "1 2 4 8 16 32 64 128" @ which performs a similar effect, but due to differences in implementation sounds different. -} begin, legato, clhatdecay, crush :: Pattern Double -> ControlPattern channel, coarse :: Pattern Int -> ControlPattern begin = pF "begin" -- | choose the physical channel the pattern is sent to, this is super dirt specific channel = pI "channel" --legato controls the amount of overlap between two adjacent synth sounds legato = pF "legato" clhatdecay = pF "clhatdecay" -- | fake-resampling, a pattern of numbers for lowering the sample rate, i.e. 1 for original 2 for half, 3 for a third and so on. coarse = pI "coarse" -- | bit crushing, a pattern of numbers from 1 (for drastic reduction in bit-depth) to 16 (for barely no reduction). crush = pF "crush" {- | In the style of classic drum-machines, `cut` will stop a playing sample as soon as another samples with in same cutgroup is to be played. An example would be an open hi-hat followed by a closed one, essentially muting the open. @ d1 $ stack [ sound "bd", sound "~ [~ [ho:2 hc/2]]" # cut "1" ] @ This will mute the open hi-hat every second cycle when the closed one is played. Using `cut` with negative values will only cut the same sample. This is useful to cut very long samples @ d1 $ sound "[bev, [ho:3](3,8)]" # cut "-1" @ Using `cut "0"` is effectively _no_ cutgroup. -} cut :: Pattern Int -> ControlPattern cut = pI "cut" -- | a pattern of numbers from 0 to 1. Applies the cutoff frequency of the low-pass filter. cutoff :: Pattern Double -> ControlPattern cutoff = pF "cutoff" cutoffegint :: Pattern Double -> ControlPattern cutoffegint = pF "cutoffegint" decay :: Pattern Double -> ControlPattern decay = pF "decay" -- | a pattern of numbers from 0 to 1. Sets the level of the delay signal. delay :: Pattern Double -> ControlPattern delay = pF "delay" -- | a pattern of numbers from 0 to 1. Sets the amount of delay feedback. delayfeedback :: Pattern Double -> ControlPattern delayfeedback = pF "delayfeedback" -- | a pattern of numbers from 0 to 1. Sets the length of the delay. delaytime :: Pattern Double -> ControlPattern delaytime = pF "delaytime" detune :: Pattern Double -> ControlPattern detune = pF "detune" -- DJ filter djf :: Pattern Double -> ControlPattern djf = pF "djf" -- | when set to `1` will disable all reverb for this pattern. See `room` and `size` for more information about reverb. dry :: Pattern Double -> ControlPattern dry = pF "dry" {- the same as `begin`, but cuts the end off samples, shortening them; e.g. `0.75` to cut off the last quarter of each sample. -} end :: Pattern Double -> ControlPattern end = pF "end" freq :: Pattern Double -> ControlPattern freq = pF "freq" -- | a pattern of numbers that specify volume. Values less than 1 make -- the sound quieter. Values greater than 1 make the sound louder. For -- the linear equivalent, see @amp@. gain :: Pattern Double -> ControlPattern gain = pF "gain" gate :: Pattern Double -> ControlPattern gate = pF "gate" hatgrain :: Pattern Double -> ControlPattern hatgrain = pF "hatgrain" -- | a pattern of numbers from 0 to 1. Applies the cutoff frequency of the high-pass filter. hcutoff :: Pattern Double -> ControlPattern hcutoff = pF "hcutoff" -- | a pattern of numbers to specify the hold time (in seconds) of an envelope applied to each sample. Only takes effect if `attack` and `release` are also specified. hold :: Pattern Double -> ControlPattern hold = pF "hold" -- | a pattern of numbers from 0 to 1. Applies the resonance of the high-pass filter. hresonance :: Pattern Double -> ControlPattern hresonance = pF "hresonance" kriole :: Pattern Int -> ControlPattern kriole = pI "kriole" lagogo :: Pattern Double -> ControlPattern lagogo = pF "lagogo" lclap :: Pattern Double -> ControlPattern lclap = pF "lclap" lclaves :: Pattern Double -> ControlPattern lclaves = pF "lclaves" lclhat :: Pattern Double -> ControlPattern lclhat = pF "lclhat" lcrash :: Pattern Double -> ControlPattern lcrash = pF "lcrash" leslie :: Pattern Double -> ControlPattern leslie = pF "leslie" lrate :: Pattern Double -> ControlPattern lrate = pF "lrate" lsize :: Pattern Double -> ControlPattern lsize = pF "lsize" lfo :: Pattern Double -> ControlPattern lfo = pF "lfo" lfocutoffint :: Pattern Double -> ControlPattern lfocutoffint = pF "lfocutoffint" lfodelay :: Pattern Double -> ControlPattern lfodelay = pF "lfodelay" lfoint :: Pattern Double -> ControlPattern lfoint = pF "lfoint" lfopitchint :: Pattern Double -> ControlPattern lfopitchint = pF "lfopitchint" lfoshape :: Pattern Double -> ControlPattern lfoshape = pF "lfoshape" lfosync :: Pattern Double -> ControlPattern lfosync = pF "lfosync" lhitom :: Pattern Double -> ControlPattern lhitom = pF "lhitom" lkick :: Pattern Double -> ControlPattern lkick = pF "lkick" llotom :: Pattern Double -> ControlPattern llotom = pF "llotom" {- | A pattern of numbers. Specifies whether delaytime is calculated relative to cps. When set to 1, delaytime is a direct multiple of a cycle. -} lock :: Pattern Double -> ControlPattern lock = pF "lock" -- | loops the sample (from `begin` to `end`) the specified number of times. loop :: Pattern Double -> ControlPattern loop = pF "loop" lophat :: Pattern Double -> ControlPattern lophat = pF "lophat" lsnare :: Pattern Double -> ControlPattern lsnare = pF "lsnare" -- | specifies the sample or note number to be used n :: Pattern Double -> ControlPattern n = pF "n" note :: Pattern Double -> ControlPattern note = pF "note" {- | Pushes things forward (or backwards within built-in latency) in time. Allows for nice things like _swing_ feeling: @ d1 $ stack [ sound "bd bd/4", sound "hh(5,8)" ] # nudge "[0 0.04]*4" @ --pitch model -} degree, mtranspose, ctranspose, harmonic, stepsPerOctave, octaveRatio :: Pattern Double -> ControlPattern degree = pF "degree" mtranspose = pF "mtranspose" ctranspose = pF "ctranspose" harmonic = pF "ctranspose" stepsPerOctave = pF "stepsPerOctave" octaveRatio = pF "octaveRatio" --Low values will give a more _human_ feeling, high values might result in quite the contrary. nudge :: Pattern Double -> ControlPattern nudge = pF "nudge" octave :: Pattern Int -> ControlPattern octave = pI "octave" offset :: Pattern Double -> ControlPattern offset = pF "offset" ophatdecay :: Pattern Double -> ControlPattern ophatdecay = pF "ophatdecay" {- | a pattern of numbers. An `orbit` is a global parameter context for patterns. Patterns with the same orbit will share hardware output bus offset and global effects, e.g. reverb and delay. The maximum number of orbits is specified in the superdirt startup, numbers higher than maximum will wrap around. -} orbit :: Pattern Int -> ControlPattern orbit = pI "orbit" overgain :: Pattern Double -> ControlPattern overgain = pF "overgain" overshape :: Pattern Double -> ControlPattern overshape = pF "overshape" -- | a pattern of numbers between 0 and 1, from left to right (assuming stereo), once round a circle (assuming multichannel) pan :: Pattern Double -> ControlPattern pan = pF "pan" -- | a pattern of numbers between -inf and inf, which controls how much multichannel output is fanned out (negative is backwards ordering) panspan :: Pattern Double -> ControlPattern panspan = pF "span" -- | a pattern of numbers between 0.0 and 1.0, which controls the multichannel spread range (multichannel only) pansplay :: Pattern Double -> ControlPattern pansplay = pF "splay" -- | a pattern of numbers between 0.0 and inf, which controls how much each channel is distributed over neighbours (multichannel only) panwidth :: Pattern Double -> ControlPattern panwidth = pF "panwidth" -- | a pattern of numbers between -1.0 and 1.0, which controls the relative position of the centre pan in a pair of adjacent speakers (multichannel only) panorient :: Pattern Double -> ControlPattern panorient = pF "orientation" pitch1 :: Pattern Double -> ControlPattern pitch1 = pF "pitch1" pitch2 :: Pattern Double -> ControlPattern pitch2 = pF "pitch2" pitch3 :: Pattern Double -> ControlPattern pitch3 = pF "pitch3" portamento :: Pattern Double -> ControlPattern portamento = pF "portamento" -- | used in SuperDirt softsynths as a control rate or "speed" rate :: Pattern Double -> ControlPattern rate = pF "rate" -- | a pattern of numbers to specify the release time (in seconds) of an envelope applied to each sample. Only takes effect if `attack` is also specified. release :: Pattern Double -> ControlPattern release = pF "release" -- | a pattern of numbers from 0 to 1. Specifies the resonance of the low-pass filter. resonance :: Pattern Double -> ControlPattern resonance = pF "resonance" -- | a pattern of numbers from 0 to 1. Sets the level of reverb. room :: Pattern Double -> ControlPattern room = pF "room" sagogo :: Pattern Double -> ControlPattern sagogo = pF "sagogo" sclap :: Pattern Double -> ControlPattern sclap = pF "sclap" sclaves :: Pattern Double -> ControlPattern sclaves = pF "sclaves" scrash :: Pattern Double -> ControlPattern scrash = pF "scrash" semitone :: Pattern Double -> ControlPattern semitone = pF "semitone" -- | wave shaping distortion, a pattern of numbers from 0 for no distortion up to 1 for loads of distortion. shape :: Pattern Double -> ControlPattern shape = pF "shape" -- | a pattern of numbers from 0 to 1. Sets the perceptual size (reverb time) of the `room` to be used in reverb. size :: Pattern Double -> ControlPattern size = pF "size" slide :: Pattern Double -> ControlPattern slide = pF "slide" -- | a pattern of numbers which changes the speed of sample playback, i.e. a cheap way of changing pitch. Negative values will play the sample backwards! speed :: Pattern Double -> ControlPattern speed = pF "speed" squiz :: Pattern Double -> ControlPattern squiz = pF "squiz" -- | a pattern of strings. Selects the sample to be played. s' :: Pattern String -> ControlPattern s' = pS "s" stutterdepth :: Pattern Double -> ControlPattern stutterdepth = pF "stutterdepth" stuttertime :: Pattern Double -> ControlPattern stuttertime = pF "stuttertime" sustain :: Pattern Double -> ControlPattern sustain = pF "sustain" tomdecay :: Pattern Double -> ControlPattern tomdecay = pF "tomdecay" {- | used in conjunction with `speed`, accepts values of "r" (rate, default behavior), "c" (cycles), or "s" (seconds). Using `unit "c"` means `speed` will be interpreted in units of cycles, e.g. `speed "1"` means samples will be stretched to fill a cycle. Using `unit "s"` means the playback speed will be adjusted so that the duration is the number of seconds specified by `speed`. -} unit :: Pattern String -> ControlPattern unit = pS "unit" velocity :: Pattern Double -> ControlPattern velocity = pF "velocity" vcfegint :: Pattern Double -> ControlPattern vcfegint = pF "vcfegint" vcoegint :: Pattern Double -> ControlPattern vcoegint = pF "vcoegint" voice :: Pattern Double -> ControlPattern voice = pF "voice" -- | formant filter to make things sound like vowels, a pattern of either `a`, `e`, `i`, `o` or `u`. Use a rest (`~`) for no effect. vowel :: Pattern String -> ControlPattern vowel = pS "vowel" voweli :: Pattern Int -> ControlPattern voweli = pI "vowel" waveloss :: Pattern Double -> ControlPattern waveloss = pF "waveloss" -- MIDI-specific params dur :: Pattern Double -> ControlPattern dur = pF "dur" modwheel :: Pattern Double -> ControlPattern modwheel = pF "modwheel" expression :: Pattern Double -> ControlPattern expression = pF "expression" sustainpedal :: Pattern Double -> ControlPattern sustainpedal = pF "sustainpedal" -- Tremolo Audio DSP effect | params are "tremolorate" and "tremolodepth" tremolorate, tremolodepth :: Pattern Double -> ControlPattern tremolorate = pF "tremolorate" tremolodepth = pF "tremolodepth" -- Phaser Audio DSP effect | params are "phaserrate" and "phaserdepth" phaserrate, phaserdepth :: Pattern Double -> ControlPattern phaserrate = pF "phaserrate" phaserdepth = pF "phaserdepth" -- More SuperDirt effects -- frequency shifter fshift, fshiftphase, fshiftnote :: Pattern Double -> ControlPattern fshift = pF "fshift" fshiftphase = pF "fshiftphase" fshiftnote = pF "fshiftnote" -- triode (tube distortion) triode :: Pattern Double -> ControlPattern triode = pF "triode" -- krush (like Sonic Pi's shape/bass enhancer) krush, kcutoff :: Pattern Double -> ControlPattern krush = pF "krush" kcutoff = pF "kcutoff" -- octer (like Sonic Pi's octaver effect) octer, octersub, octersubsub :: Pattern Double -> ControlPattern octer = pF "octer" octersub = pF "octersub" octersubsub = pF "octersubsub" -- ring modulation ring, ringf, ringdf :: Pattern Double -> ControlPattern ring = pF "ring" ringf = pF "ringf" ringdf = pF "ringdf" -- noisy fuzzy distortion distort :: Pattern Double -> ControlPattern distort = pF "distort" -- Spectral freeze freeze :: Pattern Double -> ControlPattern freeze = pF "freeze" -- Spectral delay xsdelay :: Pattern Double -> ControlPattern xsdelay = pF "xsdelay" tsdelay :: Pattern Double -> ControlPattern tsdelay = pF "tsdelay" -- Spectral conform real :: Pattern Double -> ControlPattern real = pF "real" imag :: Pattern Double -> ControlPattern imag = pF "imag" -- Spectral enhance enhance :: Pattern Double -> ControlPattern enhance = pF "enhance" partials :: Pattern Double -> ControlPattern partials = pF "partials" -- Spectral comb comb :: Pattern Double -> ControlPattern comb = pF "comb" -- Spectral smear smear :: Pattern Double -> ControlPattern smear = pF "smear" -- Spectral scramble scram :: Pattern Double -> ControlPattern scram = pF "scram" -- Spectral binshift binshift :: Pattern Double -> ControlPattern binshift = pF "binshift" -- High pass sort of spectral filter hbrick :: Pattern Double -> ControlPattern hbrick = pF "hbrick" -- Low pass sort of spectral filter lbrick :: Pattern Double -> ControlPattern lbrick = pF "lbrick" -- aliases att, bpf, bpq, chdecay, ctf, ctfg, delayfb, dfb, delayt, dt, det, gat, hg, hpf, hpq, lag, lbd, lch, lcl, lcp, lcr, lfoc, lfoi , lfop, lht, llt, loh, lpf, lpq, lsn, ohdecay, phasdp, phasr, pit1, pit2, pit3, por, rel, sz, sag, scl, scp , scr, sld, std, stt, sus, tdecay, tremdp, tremr, vcf, vco, voi :: Pattern Double -> ControlPattern att = attack bpf = bandf bpq = bandq chdecay = clhatdecay ctf = cutoff ctfg = cutoffegint delayfb = delayfeedback dfb = delayfeedback delayt = delaytime dt = delaytime det = detune gat = gate hg = hatgrain hpf = hcutoff hpq = hresonance lag = lagogo lbd = lkick lch = lclhat lcl = lclaves lcp = lclap lcr = lcrash lfoc = lfocutoffint lfoi = lfoint lfop = lfopitchint lht = lhitom llt = llotom loh = lophat lpf = cutoff lpq = resonance lsn = lsnare ohdecay = ophatdecay phasdp = phaserdepth phasr = phaserrate pit1 = pitch1 pit2 = pitch2 pit3 = pitch3 por = portamento rel = release sag = sagogo scl = sclaves scp = sclap scr = scrash sz = size sld = slide std = stutterdepth stt = stuttertime sus = sustain tdecay = tomdecay tremdp = tremolodepth tremr = tremolorate vcf = vcfegint vco = vcoegint voi = voice midinote :: Pattern Double -> ControlPattern midinote = note . (subtract 60 <$>) drum :: Pattern String -> ControlPattern drum = n . (subtract 60 . drumN <$>) drumN :: Num a => String -> a drumN "bd" = 36 drumN "sn" = 38 drumN "lt" = 43 drumN "ht" = 50 drumN "ch" = 42 drumN "oh" = 46 drumN "cp" = 39 drumN "cl" = 75 drumN "ag" = 67 drumN "cr" = 49 drumN _ = 0 -- SuperDirt MIDI Params array :: Pattern [Word8] -> ControlPattern array = pX "array" midichan :: Pattern Double -> ControlPattern midichan = pF "midichan" control :: Pattern Double -> ControlPattern control = pF "control" ccn :: Pattern Double -> ControlPattern ccn = pF "ccn" ccv :: Pattern Double -> ControlPattern ccv = pF "ccv" polyTouch :: Pattern Double -> ControlPattern polyTouch = pF "polyTouch" midibend :: Pattern Double -> ControlPattern midibend = pF "midibend" miditouch :: Pattern Double -> ControlPattern miditouch = pF "miditouch" nrpnn :: Pattern Int -> ControlPattern nrpnn = pI "nrpn" nrpnv :: Pattern Int -> ControlPattern nrpnv = pI "val" ctlNum :: Pattern Double -> ControlPattern ctlNum = pF "ctlNum" frameRate :: Pattern Double -> ControlPattern frameRate = pF "frameRate" frames :: Pattern Double -> ControlPattern frames = pF "frames" hours :: Pattern Double -> ControlPattern hours = pF "hours" midicmd :: Pattern String -> ControlPattern midicmd = pS "midicmd" command :: Pattern String -> ControlPattern command = midicmd minutes :: Pattern Double -> ControlPattern minutes = pF "minutes" progNum :: Pattern Double -> ControlPattern progNum = pF "progNum" seconds :: Pattern Double -> ControlPattern seconds = pF "seconds" songPtr :: Pattern Double -> ControlPattern songPtr = pF "songPtr" uid :: Pattern Double -> ControlPattern uid = pF "uid" val :: Pattern Double -> ControlPattern val = pF "val" {- | `up` is now an alias of `note`. -} up :: Pattern Double -> ControlPattern up = note cps :: Pattern Double -> ControlPattern cps = pF "cps" -- generic names for mapping to e.g. midi controls button0 :: Pattern Double -> ControlPattern button0 = pF "button0" button1 :: Pattern Double -> ControlPattern button1 = pF "button1" button2 :: Pattern Double -> ControlPattern button2 = pF "button2" button3 :: Pattern Double -> ControlPattern button3 = pF "button3" button4 :: Pattern Double -> ControlPattern button4 = pF "button4" button5 :: Pattern Double -> ControlPattern button5 = pF "button5" button6 :: Pattern Double -> ControlPattern button6 = pF "button6" button7 :: Pattern Double -> ControlPattern button7 = pF "button7" button8 :: Pattern Double -> ControlPattern button8 = pF "button8" button9 :: Pattern Double -> ControlPattern button9 = pF "button9" button10 :: Pattern Double -> ControlPattern button10 = pF "button10" button11 :: Pattern Double -> ControlPattern button11 = pF "button11" button12 :: Pattern Double -> ControlPattern button12 = pF "button12" button13 :: Pattern Double -> ControlPattern button13 = pF "button13" button14 :: Pattern Double -> ControlPattern button14 = pF "button14" button15 :: Pattern Double -> ControlPattern button15 = pF "button15" button16 :: Pattern Double -> ControlPattern button16 = pF "button16" button17 :: Pattern Double -> ControlPattern button17 = pF "button17" button18 :: Pattern Double -> ControlPattern button18 = pF "button18" button19 :: Pattern Double -> ControlPattern button19 = pF "button19" button20 :: Pattern Double -> ControlPattern button20 = pF "button20" button21 :: Pattern Double -> ControlPattern button21 = pF "button21" button22 :: Pattern Double -> ControlPattern button22 = pF "button22" button23 :: Pattern Double -> ControlPattern button23 = pF "button23" button24 :: Pattern Double -> ControlPattern button24 = pF "button24" button25 :: Pattern Double -> ControlPattern button25 = pF "button25" button26 :: Pattern Double -> ControlPattern button26 = pF "button26" button27 :: Pattern Double -> ControlPattern button27 = pF "button27" button28 :: Pattern Double -> ControlPattern button28 = pF "button28" button29 :: Pattern Double -> ControlPattern button29 = pF "button29" button30 :: Pattern Double -> ControlPattern button30 = pF "button30" button31 :: Pattern Double -> ControlPattern button31 = pF "button31" slider0 :: Pattern Double -> ControlPattern slider0 = pF "slider0" slider1 :: Pattern Double -> ControlPattern slider1 = pF "slider1" slider2 :: Pattern Double -> ControlPattern slider2 = pF "slider2" slider3 :: Pattern Double -> ControlPattern slider3 = pF "slider3" slider4 :: Pattern Double -> ControlPattern slider4 = pF "slider4" slider5 :: Pattern Double -> ControlPattern slider5 = pF "slider5" slider6 :: Pattern Double -> ControlPattern slider6 = pF "slider6" slider7 :: Pattern Double -> ControlPattern slider7 = pF "slider7" slider8 :: Pattern Double -> ControlPattern slider8 = pF "slider8" slider9 :: Pattern Double -> ControlPattern slider9 = pF "slider9" slider10 :: Pattern Double -> ControlPattern slider10 = pF "slider10" slider11 :: Pattern Double -> ControlPattern slider11 = pF "slider11" slider12 :: Pattern Double -> ControlPattern slider12 = pF "slider12" slider13 :: Pattern Double -> ControlPattern slider13 = pF "slider13" slider14 :: Pattern Double -> ControlPattern slider14 = pF "slider14" slider15 :: Pattern Double -> ControlPattern slider15 = pF "slider15" slider16 :: Pattern Double -> ControlPattern slider16 = pF "slider16" slider17 :: Pattern Double -> ControlPattern slider17 = pF "slider17" slider18 :: Pattern Double -> ControlPattern slider18 = pF "slider18" slider19 :: Pattern Double -> ControlPattern slider19 = pF "slider19" slider20 :: Pattern Double -> ControlPattern slider20 = pF "slider20" slider21 :: Pattern Double -> ControlPattern slider21 = pF "slider21" slider22 :: Pattern Double -> ControlPattern slider22 = pF "slider22" slider23 :: Pattern Double -> ControlPattern slider23 = pF "slider23" slider24 :: Pattern Double -> ControlPattern slider24 = pF "slider24" slider25 :: Pattern Double -> ControlPattern slider25 = pF "slider25" slider26 :: Pattern Double -> ControlPattern slider26 = pF "slider26" slider27 :: Pattern Double -> ControlPattern slider27 = pF "slider27" slider28 :: Pattern Double -> ControlPattern slider28 = pF "slider28" slider29 :: Pattern Double -> ControlPattern slider29 = pF "slider29" slider30 :: Pattern Double -> ControlPattern slider30 = pF "slider30" slider31 :: Pattern Double -> ControlPattern slider31 = pF "slider31" tidal-1.5.2/src/Sound/Tidal/ParseBP.hs0000644000000000000000000004611007346545000015553 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, CPP #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-unused-do-bind #-} module Sound.Tidal.ParseBP where import Control.Applicative ((<$>), (<*>), pure) import qualified Control.Exception as E import Data.Colour import Data.Colour.Names import Data.Functor.Identity (Identity) import Data.Maybe import Data.Ratio import Data.Typeable (Typeable) import GHC.Exts ( IsString(..) ) import Text.Parsec.Error import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Language ( haskellDef ) import qualified Text.ParserCombinators.Parsec.Token as P import qualified Text.Parsec.Prim import Sound.Tidal.Pattern import Sound.Tidal.UI import Sound.Tidal.Core import Sound.Tidal.Chords (chordTable) data TidalParseError = TidalParseError {parsecError :: ParseError, code :: String } deriving (Eq, Typeable) instance E.Exception TidalParseError instance Show TidalParseError where show err = "Syntax error in sequence:\n \"" ++ code err ++ "\"\n " ++ pointer ++ " " ++ message where pointer = replicate (sourceColumn $ errorPos perr) ' ' ++ "^" message = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" $ errorMessages perr perr = parsecError err type MyParser = Text.Parsec.Prim.Parsec String Int -- | AST representation of patterns data TPat a = TPat_Atom (Maybe ((Int, Int), (Int, Int))) a | TPat_Fast (TPat Time) (TPat a) | TPat_Slow (TPat Time) (TPat a) | TPat_DegradeBy Int Double (TPat a) | TPat_CycleChoose Int [TPat a] | TPat_Euclid (TPat Int) (TPat Int) (TPat Int) (TPat a) | TPat_Stack [TPat a] | TPat_Polyrhythm (Maybe (TPat Rational)) [TPat a] | TPat_Seq [TPat a] | TPat_Silence | TPat_Foot | TPat_Elongate Rational (TPat a) | TPat_Repeat Int (TPat a) | TPat_EnumFromTo (TPat a) (TPat a) | TPat_Var String deriving (Show) toPat :: (Parseable a, Enumerable a) => TPat a -> Pattern a toPat = \case TPat_Atom (Just loc) x -> setContext (Context [loc]) $ pure x TPat_Atom Nothing x -> pure x TPat_Fast t x -> fast (toPat t) $ toPat x TPat_Slow t x -> slow (toPat t) $ toPat x TPat_DegradeBy seed amt x -> _degradeByUsing (rotL (0.0001 * (fromIntegral seed)) rand) amt $ toPat x TPat_CycleChoose seed xs -> unwrap $ segment 1 $ chooseBy (rotL (0.0001 * (fromIntegral seed)) rand) $ map toPat xs TPat_Euclid n k s thing -> doEuclid (toPat n) (toPat k) (toPat s) (toPat thing) TPat_Stack xs -> stack $ map toPat xs TPat_Silence -> silence TPat_EnumFromTo a b -> unwrap $ fromTo <$> toPat a <*> toPat b TPat_Foot -> error "Can't happen, feet are pre-processed." TPat_Polyrhythm mSteprate ps -> stack $ map adjust_speed pats where adjust_speed (sz, pat) = fast ((/sz) <$> steprate) pat pats = map resolve_tpat ps steprate :: Pattern Rational steprate = fromMaybe base_first (toPat <$> mSteprate) base_first | null pats = pure 0 | otherwise = pure $ fst $ head pats TPat_Seq xs -> snd $ resolve_seq xs TPat_Var s -> getControl s _ -> silence resolve_tpat :: (Enumerable a, Parseable a) => TPat a -> (Rational, Pattern a) resolve_tpat (TPat_Seq xs) = resolve_seq xs resolve_tpat a = (1, toPat a) resolve_seq :: (Enumerable a, Parseable a) => [TPat a] -> (Rational, Pattern a) resolve_seq xs = (total_size, timeCat sized_pats) where sized_pats = map (toPat <$>) $ resolve_size xs total_size = sum $ map fst sized_pats resolve_size :: [TPat a] -> [(Rational, TPat a)] resolve_size [] = [] resolve_size ((TPat_Elongate r p):ps) = (r, p):(resolve_size ps) resolve_size ((TPat_Repeat n p):ps) = replicate n (1,p) ++ (resolve_size ps) resolve_size (p:ps) = (1,p):(resolve_size ps) {- durations :: [TPat a] -> [(Int, TPat a)] durations [] = [] durations (TPat_Elongate n : xs) = (n, TPat_Silence) : durations xs durations (a : TPat_Elongate n : xs) = (n+1,a) : durations xs durations (a:xs) = (1,a) : durations xs -} parseBP :: (Enumerable a, Parseable a) => String -> Either ParseError (Pattern a) parseBP s = toPat <$> parseTPat s parseBP_E :: (Enumerable a, Parseable a) => String -> Pattern a parseBP_E s = toE parsed where parsed = parseTPat s -- TODO - custom error toE (Left e) = E.throw $ TidalParseError {parsecError = e, code = s} toE (Right tp) = toPat tp parseTPat :: Parseable a => String -> Either ParseError (TPat a) parseTPat = parseRhythm tPatParser cP :: (Enumerable a, Parseable a) => String -> Pattern a cP s = innerJoin $ parseBP_E <$> (_cX_ getS s) class Parseable a where tPatParser :: MyParser (TPat a) doEuclid :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a getControl :: String -> Pattern a getControl _ = silence class Enumerable a where fromTo :: a -> a -> Pattern a fromThenTo :: a -> a -> a -> Pattern a instance Parseable Char where tPatParser = pChar doEuclid = euclidOff instance Enumerable Char where fromTo = enumFromTo' fromThenTo a b c = fastFromList [a,b,c] instance Parseable Double where tPatParser = pDouble doEuclid = euclidOff getControl = cF_ instance Enumerable Double where fromTo = enumFromTo' fromThenTo = enumFromThenTo' instance Parseable String where tPatParser = pVocable doEuclid = euclidOff getControl = cS_ instance Enumerable String where fromTo a b = fastFromList [a,b] fromThenTo a b c = fastFromList [a,b,c] instance Parseable Bool where tPatParser = pBool doEuclid = euclidOffBool getControl = cB_ instance Enumerable Bool where fromTo a b = fastFromList [a,b] fromThenTo a b c = fastFromList [a,b,c] instance Parseable Int where tPatParser = pIntegral doEuclid = euclidOff getControl = cI_ instance Enumerable Int where fromTo = enumFromTo' fromThenTo = enumFromThenTo' instance Parseable Integer where tPatParser = pIntegral doEuclid = euclidOff getControl = (fmap fromIntegral) . cI_ instance Enumerable Integer where fromTo = enumFromTo' fromThenTo = enumFromThenTo' instance Parseable Rational where tPatParser = pRational doEuclid = euclidOff getControl = cR_ instance Enumerable Rational where fromTo = enumFromTo' fromThenTo = enumFromThenTo' enumFromTo' :: (Ord a, Enum a) => a -> a -> Pattern a enumFromTo' a b | a > b = fastFromList $ reverse $ enumFromTo b a | otherwise = fastFromList $ enumFromTo a b enumFromThenTo' :: (Ord a, Enum a, Num a) => a -> a -> a -> Pattern a enumFromThenTo' a b c | a > c = fastFromList $ reverse $ enumFromThenTo c (c + (a-b)) a | otherwise = fastFromList $ enumFromThenTo a b c type ColourD = Colour Double instance Parseable ColourD where tPatParser = pColour doEuclid = euclidOff instance Enumerable ColourD where fromTo a b = fastFromList [a,b] fromThenTo a b c = fastFromList [a,b,c] instance (Enumerable a, Parseable a) => IsString (Pattern a) where fromString = parseBP_E --instance (Parseable a, Pattern p) => IsString (p a) where -- fromString = p :: String -> p a lexer :: P.GenTokenParser String u Data.Functor.Identity.Identity lexer = P.makeTokenParser haskellDef braces, brackets, parens, angles:: MyParser a -> MyParser a braces = P.braces lexer brackets = P.brackets lexer parens = P.parens lexer angles = P.angles lexer symbol :: String -> MyParser String symbol = P.symbol lexer natural, integer, decimal :: MyParser Integer natural = P.natural lexer integer = P.integer lexer decimal = P.integer lexer float :: MyParser Double float = P.float lexer naturalOrFloat :: MyParser (Either Integer Double) naturalOrFloat = P.naturalOrFloat lexer data Sign = Positive | Negative applySign :: Num a => Sign -> a -> a applySign Positive = id applySign Negative = negate sign :: MyParser Sign sign = do char '-' return Negative <|> do char '+' return Positive <|> return Positive intOrFloat :: MyParser Double intOrFloat = do s <- sign num <- naturalOrFloat return (case num of Right x -> applySign s x Left x -> fromIntegral $ applySign s x ) parseRhythm :: Parseable a => MyParser (TPat a) -> String -> Either ParseError (TPat a) parseRhythm f = runParser (pSequence f' Prelude.<* eof) (0 :: Int) "" where f' = do f <|> do symbol "~" "rest" return TPat_Silence pSequence :: Parseable a => MyParser (TPat a) -> GenParser Char Int (TPat a) pSequence f = do spaces -- TODO is this needed? -- d <- pFast s <- many $ do a <- pPart f spaces do try $ symbol ".." b <- pPart f return $ TPat_EnumFromTo a b <|> do rs <- many1 $ do oneOf "@_" r <- ((subtract 1) <$> pRatio) <|> return 1 spaces return $ r return $ TPat_Elongate (1 + sum rs) a <|> do es <- many1 $ do char '!' n <- (((subtract 1) . read) <$> many1 digit) <|> return 1 spaces return n return $ TPat_Repeat (1 + sum es) a <|> return a <|> do symbol "." return TPat_Foot return $ resolve_feet s where resolve_feet ps | length ss > 1 = TPat_Seq $ map TPat_Seq ss | otherwise = TPat_Seq ps where ss = splitFeet ps splitFeet :: [TPat t] -> [[TPat t]] splitFeet [] = [] splitFeet pats = foot : splitFeet pats' where (foot, pats') = takeFoot pats takeFoot [] = ([], []) takeFoot (TPat_Foot:pats'') = ([], pats'') takeFoot (pat:pats'') = (\(a,b) -> (pat:a,b)) $ takeFoot pats'' pSingle :: MyParser (TPat a) -> MyParser (TPat a) pSingle f = f >>= pRand >>= pMult pVar :: MyParser (TPat a) pVar = wrapPos $ do char '^' name <- many (letter <|> oneOf "0123456789:.-_") "string" return $ TPat_Var name pPart :: Parseable a => MyParser (TPat a) -> MyParser (TPat a) pPart f = do pt <- (pSingle f <|> pPolyIn f <|> pPolyOut f <|> pVar) >>= pE >>= pRand spaces -- TODO is this needed? return pt newSeed :: MyParser Int newSeed = do seed <- Text.Parsec.Prim.getState Text.Parsec.Prim.modifyState (+1) return seed pPolyIn :: Parseable a => MyParser (TPat a) -> MyParser (TPat a) pPolyIn f = do x <- brackets $ do s <- pSequence f "sequence" stackTail s <|> chooseTail s <|> return s pMult x where stackTail s = do symbol "," ss <- pSequence f `sepBy` symbol "," spaces -- TODO needed? return $ TPat_Stack (s:ss) chooseTail s = do symbol "|" ss <- pSequence f `sepBy` symbol "|" spaces -- TODO needed? seed <- newSeed return $ TPat_CycleChoose seed (s:ss) pPolyOut :: Parseable a => MyParser (TPat a) -> MyParser (TPat a) pPolyOut f = do ss <- braces (pSequence f `sepBy` symbol ",") spaces -- TODO needed? base <- do char '%' r <- pSequence pRational "rational number" return $ Just r <|> return Nothing pMult $ TPat_Polyrhythm base ss <|> do ss <- angles (pSequence f `sepBy` symbol ",") spaces -- TODO needed/wanted? pMult $ TPat_Polyrhythm (Just $ TPat_Atom Nothing 1) ss pCharNum :: MyParser Char pCharNum = (letter <|> oneOf "0123456789") "letter or number" pString :: MyParser String pString = do c <- pCharNum "charnum" cs <- many (letter <|> oneOf "0123456789:.-_") "string" return (c:cs) wrapPos :: MyParser (TPat a) -> MyParser (TPat a) wrapPos p = do b <- getPosition tpat <- p e <- getPosition let addPos (TPat_Atom _ v') = TPat_Atom (Just ((sourceColumn b, sourceLine b), (sourceColumn e, sourceLine e))) v' addPos x = x -- shouldn't happen.. return $ addPos tpat pVocable :: MyParser (TPat String) pVocable = wrapPos $ (TPat_Atom Nothing) <$> pString pChar :: MyParser (TPat Char) pChar = wrapPos $ (TPat_Atom Nothing) <$> pCharNum pDouble :: MyParser (TPat Double) pDouble = wrapPos $ do f <- choice [intOrFloat, parseNote] "float" do c <- parseChord return $ TPat_Stack $ map ((TPat_Atom Nothing) . (+f)) c <|> return (TPat_Atom Nothing f) <|> do c <- parseChord return $ TPat_Stack $ map (TPat_Atom Nothing) c <|> do r <- pRatioChar return $ TPat_Atom Nothing r pBool :: MyParser (TPat Bool) pBool = wrapPos $ do oneOf "t1" return $ TPat_Atom Nothing True <|> do oneOf "f0" return $ TPat_Atom Nothing False parseIntNote :: Integral i => MyParser i parseIntNote = do s <- sign i <- choice [integer, parseNote] return $ applySign s $ fromIntegral i parseInt :: MyParser Int parseInt = do s <- sign i <- integer return $ applySign s $ fromIntegral i pIntegral :: Integral a => MyParser (TPat a) pIntegral = wrapPos $ do i <- parseIntNote do c <- parseChord return $ TPat_Stack $ map ((TPat_Atom Nothing) . (+i)) c <|> return (TPat_Atom Nothing i) <|> do c <- parseChord return $ TPat_Stack $ map (TPat_Atom Nothing) c parseChord :: (Enum a, Num a) => MyParser [a] parseChord = do char '\'' name <- many1 $ letter <|> digit let chord = fromMaybe [0] $ lookup name chordTable do char '\'' notFollowedBy space "chord range or 'i'" let n = length chord i <- option n (fromIntegral <$> integer) j <- length <$> many (char 'i') let chord' = take i $ drop j $ concatMap (\x -> map (+ x) chord) [0,12..] return chord' <|> return chord parseNote :: Num a => MyParser a parseNote = do n <- notenum modifiers <- many noteModifier octave <- option 5 natural let n' = foldr (+) n modifiers return $ fromIntegral $ n' + ((octave-5)*12) where notenum :: MyParser Integer notenum = choice [char 'c' >> return 0, char 'd' >> return 2, char 'e' >> return 4, char 'f' >> return 5, char 'g' >> return 7, char 'a' >> return 9, char 'b' >> return 11 ] noteModifier :: MyParser Integer noteModifier = choice [char 's' >> return 1, char 'f' >> return (-1), char 'n' >> return 0 ] fromNote :: Num a => Pattern String -> Pattern a fromNote pat = either (const 0) id . runParser parseNote 0 "" <$> pat pColour :: MyParser (TPat ColourD) pColour = wrapPos $ do name <- many1 letter "colour name" colour <- readColourName name "known colour" return $ TPat_Atom Nothing colour pMult :: TPat a -> MyParser (TPat a) pMult thing = do char '*' spaces r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational return $ TPat_Fast r thing <|> do char '/' spaces r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational return $ TPat_Slow r thing <|> return thing pRand :: TPat a -> MyParser (TPat a) pRand thing = do char '?' r <- float <|> return 0.5 spaces seed <- newSeed return $ TPat_DegradeBy seed r thing <|> return thing pE :: TPat a -> MyParser (TPat a) pE thing = do (n,k,s) <- parens pair pure $ TPat_Euclid n k s thing <|> return thing where pair :: MyParser (TPat Int, TPat Int, TPat Int) pair = do a <- pSequence pIntegral spaces symbol "," spaces b <- pSequence pIntegral c <- do symbol "," spaces pSequence pIntegral <|> return (TPat_Atom Nothing 0) return (a, b, c) pRatio :: MyParser Rational pRatio = do s <- sign n <- read <$> many1 digit result <- do char '%' d <- decimal return (n%d) <|> do char '.' frac <- many1 digit -- A hack, but not sure if doing this -- numerically would be any faster.. return (toRational ((read $ show n ++ "." ++ frac) :: Double)) <|> return (n%1) c <- (pRatioChar <|> return 1) return $ applySign s (result * c) <|> pRatioChar pRatioChar :: Fractional a => MyParser a pRatioChar = do char 'w' return $ 1 <|> do char 'h' return $ 0.5 <|> do char 'q' return $ 0.25 <|> do char 'e' return $ 0.125 <|> do char 's' return $ 0.0625 <|> do char 't' return $ 1/3 <|> do char 'f' return $ 0.2 <|> do char 'x' return $ 1/6 pRational :: MyParser (TPat Rational) pRational = wrapPos $ (TPat_Atom Nothing) <$> pRatio tidal-1.5.2/src/Sound/Tidal/Pattern.hs0000644000000000000000000006574607346545000015714 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Sound.Tidal.Pattern where import Prelude hiding ((<*), (*>)) import Control.Applicative (liftA2) --import Data.Bifunctor (Bifunctor(..)) import Data.Data (Data) -- toConstr import Data.List (delete, findIndex, sort) import qualified Data.Map.Strict as Map import Data.Maybe (isJust, fromJust, catMaybes, mapMaybe) import Data.Typeable (Typeable) import Control.DeepSeq (NFData(rnf)) import Data.Word (Word8) ------------------------------------------------------------------------ -- * Types -- | Time is rational type Time = Rational -- | The 'sam' (start of cycle) for the given time value sam :: Time -> Time sam = fromIntegral . (floor :: Time -> Int) -- | Turns a number into a (rational) time value. An alias for 'toRational'. toTime :: Real a => a -> Rational toTime = toRational -- | The end point of the current cycle (and starting point of the next cycle) nextSam :: Time -> Time nextSam = (1+) . sam -- | The position of a time value relative to the start of its cycle. cyclePos :: Time -> Time cyclePos t = t - sam t -- | An arc of time, with a start time (or onset) and a stop time (or offset) data ArcF a = Arc { start :: a , stop :: a } deriving (Eq, Ord, Functor, Show) type Arc = ArcF Time instance NFData a => NFData (ArcF a) where rnf (Arc s e) = rnf s `seq` rnf e instance Num a => Num (ArcF a) where negate = fmap negate (+) = liftA2 (+) (*) = liftA2 (*) fromInteger = pure . fromInteger abs = fmap abs signum = fmap signum instance (Fractional a) => Fractional (ArcF a) where recip = fmap recip fromRational = pure . fromRational sect :: Arc -> Arc -> Arc sect (Arc s e) (Arc s' e') = Arc (max s s') (min e e') -- | convex hull union hull :: Arc -> Arc -> Arc hull (Arc s e) (Arc s' e') = Arc (min s s') (max e e') -- | @subArc i j@ is the timespan that is the intersection of @i@ and @j@. -- intersection -- The definition is a bit fiddly as results might be zero-width, but -- not at the end of an non-zero-width arc - e.g. (0,1) and (1,2) do -- not intersect, but (1,1) (1,1) does. subArc :: Arc -> Arc -> Maybe Arc subArc a@(Arc s e) b@(Arc s' e') | and [s'' == e'', s'' == e, s < e] = Nothing | and [s'' == e'', s'' == e', s' < e'] = Nothing | s'' <= e'' = Just (Arc s'' e'') | otherwise = Nothing where (Arc s'' e'') = sect a b subMaybeArc :: Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc) subMaybeArc (Just a) (Just b) = do sa <- subArc a b return $ Just sa subMaybeArc _ _ = Just Nothing instance Applicative ArcF where pure t = Arc t t (<*>) (Arc sf ef) (Arc sx ex) = Arc (sf sx) (ef ex) -- | The arc of the whole cycle that the given time value falls within timeToCycleArc :: Time -> Arc timeToCycleArc t = Arc (sam t) (sam t + 1) -- | Shifts an arc to the equivalent one that starts during cycle zero cycleArc :: Arc -> Arc cycleArc (Arc s e) = Arc (cyclePos s) (cyclePos s + (e-s)) -- | A list of cycle numbers which are included in the given arc cyclesInArc :: Integral a => Arc -> [a] cyclesInArc (Arc s e) | s > e = [] | s == e = [floor s] | otherwise = [floor s .. ceiling e-1] -- | A list of arcs of the whole cycles which are included in the given arc cycleArcsInArc :: Arc -> [Arc] cycleArcsInArc = map (timeToCycleArc . (toTime :: Int -> Time)) . cyclesInArc -- | Splits the given 'Arc' into a list of 'Arc's, at cycle boundaries. arcCycles :: Arc -> [Arc] arcCycles (Arc s e) | s >= e = [] | sam s == sam e = [Arc s e] | otherwise = Arc s (nextSam s) : arcCycles (Arc (nextSam s) e) -- | Like arcCycles, but returns zero-width arcs arcCyclesZW :: Arc -> [Arc] arcCyclesZW (Arc s e) | s == e = [Arc s e] | otherwise = arcCycles (Arc s e) -- | Similar to 'fmap' but time is relative to the cycle (i.e. the -- sam of the start of the arc) mapCycle :: (Time -> Time) -> Arc -> Arc mapCycle f (Arc s e) = Arc (sam' + f (s - sam')) (sam' + f (e - sam')) where sam' = sam s -- | @isIn a t@ is @True@ if @t@ is inside -- the arc represented by @a@. isIn :: Arc -> Time -> Bool isIn (Arc s e) t = t >= s && t < e data Context = Context {contextPosition :: [((Int, Int), (Int, Int))]} deriving (Eq, Ord) instance NFData Context where rnf (Context c) = rnf c combineContexts :: [Context] -> Context combineContexts = Context . concatMap contextPosition setContext :: Context -> Pattern a -> Pattern a setContext c pat = withEvents (map (\e -> e {context = c})) pat withContext :: (Context -> Context) -> Pattern a -> Pattern a withContext f pat = withEvents (map (\e -> e {context = f $ context e})) pat deltaContext :: Int -> Int -> Pattern a -> Pattern a deltaContext column line pat = withEvents (map (\e -> e {context = f $ context e})) pat where f :: Context -> Context f (Context xs) = Context $ map (\((bx,by), (ex,ey)) -> ((bx+column,by+line), (ex+column,ey+line))) xs -- | An event is a value that's active during a timespan. If a whole -- is present, the part should be equal to or fit inside it. data EventF a b = Event { context :: Context , whole :: Maybe a , part :: a , value :: b } deriving (Eq, Ord, Functor) type Event a = EventF (ArcF Time) a instance (NFData a, NFData b) => NFData (EventF a b) where rnf (Event c w p v) = rnf c `seq` rnf w `seq` rnf p `seq` rnf v {-instance Bifunctor EventF where bimap f g (Event w p e) = Event (f w) (f p) (g e) -} isAnalog :: Event a -> Bool isAnalog (Event {whole = Nothing}) = True isAnalog _ = False isDigital :: Event a -> Bool isDigital = not . isAnalog -- | `True` if an `Event`'s starts is within given `Arc` onsetIn :: Arc -> Event a -> Bool onsetIn a e = isIn a (wholeStart e) -- | Compares two lists of events, attempting to combine fragmented events in the process -- for a 'truer' compare compareDefrag :: (Ord a) => [Event a] -> [Event a] -> Bool compareDefrag as bs = sort (defragParts as) == sort (defragParts bs) -- | Returns a list of events, with any adjacent parts of the same whole combined defragParts :: Eq a => [Event a] -> [Event a] defragParts [] = [] defragParts [e] = [e] defragParts (e:es) | isJust i = defraged : defragParts (delete e' es) | otherwise = e : defragParts es where i = findIndex (isAdjacent e) es e' = es !! fromJust i defraged = Event (context e) (whole e) u (value e) u = hull (part e) (part e') -- | Returns 'True' if the two given events are adjacent parts of the same whole isAdjacent :: Eq a => Event a -> Event a -> Bool isAdjacent e e' = (whole e == whole e') && (value e == value e') && ((stop (part e) == start (part e')) || (stop (part e') == start (part e)) ) wholeOrPart :: Event a -> Arc wholeOrPart (Event {whole = Just a}) = a wholeOrPart e = part e -- | Get the onset of an event's 'whole' wholeStart :: Event a -> Time wholeStart = start . wholeOrPart -- | Get the offset of an event's 'whole' wholeStop :: Event a -> Time wholeStop = stop . wholeOrPart -- | Get the onset of an event's 'whole' eventPartStart :: Event a -> Time eventPartStart = start . part -- | Get the offset of an event's 'part' eventPartStop :: Event a -> Time eventPartStop = stop . part -- | Get the timespan of an event's 'part' eventPart :: Event a -> Arc eventPart = part eventValue :: Event a -> a eventValue = value eventHasOnset :: Event a -> Bool eventHasOnset e | isAnalog e = False | otherwise = start (fromJust $ whole e) == start (part e) -- TODO - Is this used anywhere? Just tests, it seems -- TODO - support 'context' field toEvent :: (((Time, Time), (Time, Time)), a) -> Event a toEvent (((ws, we), (ps, pe)), v) = Event (Context []) (Just $ Arc ws we) (Arc ps pe) v -- | an Arc and some named control values data State = State {arc :: Arc, controls :: StateMap } -- | A function that represents events taking place over time type Query a = (State -> [Event a]) -- | A datatype that's basically a query data Pattern a = Pattern {query :: Query a} data Value = VS { svalue :: String } | VF { fvalue :: Double } | VR { rvalue :: Rational } | VI { ivalue :: Int } | VB { bvalue :: Bool } | VX { xvalue :: [Word8] } -- Used for OSC 'blobs' deriving (Typeable,Data) class Valuable a where toValue :: a -> Value instance NFData Value where rnf (VS s) = rnf s rnf (VF f) = rnf f rnf (VR r) = rnf r rnf (VI i) = rnf i rnf (VB b) = rnf b rnf (VX xs) = rnf xs instance Valuable String where toValue = VS instance Valuable Double where toValue a = VF a instance Valuable Rational where toValue a = VR a instance Valuable Int where toValue a = VI a instance Valuable Bool where toValue a = VB a instance Valuable [Word8] where toValue a = VX a instance Eq Value where (VS x) == (VS y) = x == y (VB x) == (VB y) = x == y (VF x) == (VF y) = x == y (VI x) == (VI y) = x == y (VR x) == (VR y) = x == y (VX x) == (VX y) = x == y (VF x) == (VI y) = x == (fromIntegral y) (VI y) == (VF x) = x == (fromIntegral y) (VF x) == (VR y) = (toRational x) == y (VR y) == (VF x) = (toRational x) == y (VI x) == (VR y) = (toRational x) == y (VR y) == (VI x) = (toRational x) == y _ == _ = False instance Ord Value where compare (VS x) (VS y) = compare x y compare (VB x) (VB y) = compare x y compare (VF x) (VF y) = compare x y compare (VI x) (VI y) = compare x y compare (VR x) (VR y) = compare x y compare (VX x) (VX y) = compare x y compare (VS _) _ = LT compare _ (VS _) = GT compare (VB _) _ = LT compare _ (VB _) = GT compare (VX _) _ = LT compare _ (VX _) = GT compare (VF x) (VI y) = compare x (fromIntegral y) compare (VI x) (VF y) = compare (fromIntegral x) y compare (VR x) (VI y) = compare x (fromIntegral y) compare (VI x) (VR y) = compare (fromIntegral x) y compare (VF x) (VR y) = compare x (fromRational y) compare (VR x) (VF y) = compare (fromRational x) y type StateMap = Map.Map String (Pattern Value) type ControlMap = Map.Map String Value type ControlPattern = Pattern ControlMap ------------------------------------------------------------------------ -- * Instances instance NFData a => NFData (Pattern a) where rnf (Pattern q) = rnf $ \s -> q s instance Functor Pattern where -- | apply a function to all the values in a pattern fmap f p = p {query = fmap (fmap f) . query p} applyPatToPat :: (Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)) -> Pattern (a -> b) -> Pattern a -> Pattern b applyPatToPat combineWholes pf px = Pattern q where q st = catMaybes $ concatMap match $ query pf st where match (ef@(Event (Context c) _ fPart f)) = map (\ex@(Event (Context c') _ xPart x) -> do whole' <- combineWholes (whole ef) (whole ex) part' <- subArc fPart xPart return (Event (Context $ c ++ c') whole' part' (f x)) ) (query px $ st {arc = (wholeOrPart ef)}) instance Applicative Pattern where -- | Repeat the given value once per cycle, forever pure v = Pattern $ \(State a _) -> map (\a' -> Event (Context []) (Just a') (sect a a') v) $ cycleArcsInArc a (<*>) = applyPatToPatBoth applyPatToPatBoth :: Pattern (a -> b) -> Pattern a -> Pattern b applyPatToPatBoth pf px = Pattern q where q st = catMaybes $ (concatMap match $ query pf st) ++ (concatMap matchX $ query (filterAnalog px) st) where -- match analog events from pf with all events from px match ef@(Event _ Nothing fPart _) = map (withFX ef) (query px $ st {arc = fPart}) -- analog -- match digital events from pf with digital events from px match ef@(Event _ (Just fWhole) _ _) = map (withFX ef) (query (filterDigital px) $ st {arc = fWhole}) -- digital -- match analog events from px (constrained above) with digital events from px matchX ex@(Event _ Nothing fPart _) = map (\ef -> withFX ef ex) (query (filterDigital pf) $ st {arc = fPart}) -- digital matchX _ = error "can't happen" withFX ef ex = do whole' <- subMaybeArc (whole ef) (whole ex) part' <- subArc (part ef) (part ex) return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex)) applyPatToPatLeft :: Pattern (a -> b) -> Pattern a -> Pattern b applyPatToPatLeft pf px = Pattern q where q st = catMaybes $ (concatMap match $ query pf st) where match ef = map (withFX ef) (query px $ st {arc = wholeOrPart ef}) withFX ef ex = do let whole' = whole ef part' <- subArc (part ef) (part ex) return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex)) applyPatToPatRight :: Pattern (a -> b) -> Pattern a -> Pattern b applyPatToPatRight pf px = Pattern q where q st = catMaybes $ (concatMap match $ query px st) where match ex = map (\ef -> withFX ef ex) (query pf $ st {arc = wholeOrPart ex}) withFX ef ex = do let whole' = whole ex part' <- subArc (part ef) (part ex) return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex)) -- | Like <*>, but the 'wholes' come from the left (<*) :: Pattern (a -> b) -> Pattern a -> Pattern b (<*) = applyPatToPatLeft -- | Like <*>, but the 'wholes' come from the right (*>) :: Pattern (a -> b) -> Pattern a -> Pattern b (*>) = applyPatToPatRight infixl 4 <*, *> instance Monad Pattern where return = pure p >>= f = unwrap (f <$> p) -- | Turns a pattern of patterns into a single pattern. -- (this is actually 'join') -- -- 1/ For query 'arc', get the events from the outer pattern @pp@ -- 2/ Query the inner pattern using the 'part' of the outer -- 3/ For each inner event, set the whole and part to be the intersection -- of the outer whole and part, respectively -- 4/ Concatenate all the events together (discarding wholes/parts that didn't intersect) -- -- TODO - what if a continuous pattern contains a discrete one, or vice-versa? unwrap :: Pattern (Pattern a) -> Pattern a unwrap pp = pp {query = q} where q st = concatMap (\(Event c w p v) -> mapMaybe (munge c w p) $ query v st {arc = p}) (query pp st) munge oc ow op (Event ic iw ip v') = do w' <- subMaybeArc ow iw p' <- subArc op ip return (Event (combineContexts [ic, oc]) w' p' v') -- | Turns a pattern of patterns into a single pattern. Like @unwrap@, -- but structure only comes from the inner pattern. innerJoin :: Pattern (Pattern a) -> Pattern a innerJoin pp = pp {query = q} where q st = concatMap (\(Event oc _ op v) -> mapMaybe (munge oc) $ query v st {arc = op} ) (query pp st) where munge oc (Event ic iw ip v) = do p <- subArc (arc st) ip p' <- subArc p (arc st) return (Event (combineContexts [ic, oc]) iw p' v) -- | Turns a pattern of patterns into a single pattern. Like @unwrap@, -- but structure only comes from the outer pattern. outerJoin :: Pattern (Pattern a) -> Pattern a outerJoin pp = pp {query = q} where q st = concatMap (\e -> mapMaybe (munge (context e) (whole e) (part e)) $ query (value e) st {arc = pure (start $ wholeOrPart e)} ) (query pp st) where munge oc ow op (Event ic _ _ v') = do p' <- subArc (arc st) op return (Event (combineContexts [oc, ic]) ow p' v') -- | Like @unwrap@, but cycles of the inner patterns are compressed to fit the -- timespan of the outer whole (or the original query if it's a continuous pattern?) -- TODO - what if a continuous pattern contains a discrete one, or vice-versa? squeezeJoin :: Pattern (Pattern a) -> Pattern a squeezeJoin pp = pp {query = q} where q st = concatMap (\e@(Event c w p v) -> mapMaybe (munge c w p) $ query (compressArc (cycleArc $ wholeOrPart e) v) st {arc = p} ) (query pp st) munge oContext oWhole oPart (Event iContext iWhole iPart v) = do w' <- subMaybeArc oWhole iWhole p' <- subArc oPart iPart return (Event (combineContexts [iContext, oContext]) w' p' v) noOv :: String -> a noOv meth = error $ meth ++ ": not supported for patterns" class TolerantEq a where (~==) :: a -> a -> Bool instance TolerantEq Value where (VS a) ~== (VS b) = a == b (VI a) ~== (VI b) = a == b (VR a) ~== (VR b) = a == b (VF a) ~== (VF b) = abs (a - b) < 0.000001 _ ~== _ = False instance TolerantEq ControlMap where a ~== b = Map.differenceWith (\a' b' -> if a' ~== b' then Nothing else Just a') a b == Map.empty instance TolerantEq (Event ControlMap) where (Event _ w p x) ~== (Event _ w' p' x') = w == w' && p == p' && x ~== x' instance TolerantEq a => TolerantEq [a] where as ~== bs = (length as == length bs) && all (uncurry (~==)) (zip as bs) instance Eq (Pattern a) where (==) = noOv "(==)" instance Ord a => Ord (Pattern a) where min = liftA2 min max = liftA2 max compare = noOv "compare" (<=) = noOv "(<=)" instance Num a => Num (Pattern a) where negate = fmap negate (+) = liftA2 (+) (*) = liftA2 (*) fromInteger = pure . fromInteger abs = fmap abs signum = fmap signum instance Enum a => Enum (Pattern a) where succ = fmap succ pred = fmap pred toEnum = pure . toEnum fromEnum = noOv "fromEnum" enumFrom = noOv "enumFrom" enumFromThen = noOv "enumFromThen" enumFromTo = noOv "enumFromTo" enumFromThenTo = noOv "enumFromThenTo" instance (Num a, Ord a) => Real (Pattern a) where toRational = noOv "toRational" instance (Integral a) => Integral (Pattern a) where quot = liftA2 quot rem = liftA2 rem div = liftA2 div mod = liftA2 mod toInteger = noOv "toInteger" x `quotRem` y = (x `quot` y, x `rem` y) x `divMod` y = (x `div` y, x `mod` y) instance (Fractional a) => Fractional (Pattern a) where recip = fmap recip fromRational = pure . fromRational instance (Floating a) => Floating (Pattern a) where pi = pure pi sqrt = fmap sqrt exp = fmap exp log = fmap log sin = fmap sin cos = fmap cos asin = fmap asin atan = fmap atan acos = fmap acos sinh = fmap sinh cosh = fmap cosh asinh = fmap asinh atanh = fmap atanh acosh = fmap acosh instance (RealFrac a) => RealFrac (Pattern a) where properFraction = noOv "properFraction" truncate = noOv "truncate" round = noOv "round" ceiling = noOv "ceiling" floor = noOv "floor" instance (RealFloat a) => RealFloat (Pattern a) where floatRadix = noOv "floatRadix" floatDigits = noOv "floatDigits" floatRange = noOv "floatRange" decodeFloat = noOv "decodeFloat" encodeFloat = ((.).(.)) pure encodeFloat exponent = noOv "exponent" significand = noOv "significand" scaleFloat n = fmap (scaleFloat n) isNaN = noOv "isNaN" isInfinite = noOv "isInfinite" isDenormalized = noOv "isDenormalized" isNegativeZero = noOv "isNegativeZero" isIEEE = noOv "isIEEE" atan2 = liftA2 atan2 instance Num ControlMap where negate = (applyFIS negate negate id <$>) (+) = Map.unionWith (fNum2 (+) (+)) (*) = Map.unionWith (fNum2 (*) (*)) fromInteger i = Map.singleton "n" $ VI $ fromInteger i signum = (applyFIS signum signum id <$>) abs = (applyFIS abs abs id <$>) instance Fractional ControlMap where recip = fmap (applyFIS recip id id) fromRational = Map.singleton "speed" . VF . fromRational ------------------------------------------------------------------------ -- * Internal functions empty :: Pattern a empty = Pattern {query = const []} queryArc :: Pattern a -> Arc -> [Event a] queryArc p a = query p $ State a Map.empty -- | Splits queries that span cycles. For example `query p (0.5, 1.5)` would be -- turned into two queries, `(0.5,1)` and `(1,1.5)`, and the results -- combined. Being able to assume queries don't span cycles often -- makes transformations easier to specify. splitQueries :: Pattern a -> Pattern a splitQueries p = p {query = \st -> concatMap (\a -> query p st {arc = a}) $ arcCyclesZW (arc st)} -- | Apply a function to the arcs/timespans (both whole and parts) of the result withResultArc :: (Arc -> Arc) -> Pattern a -> Pattern a withResultArc f pat = pat { query = map (\(Event c w p e) -> Event c (f <$> w) (f p) e) . query pat} -- | Apply a function to the time (both start and end of the timespans -- of both whole and parts) of the result withResultTime :: (Time -> Time) -> Pattern a -> Pattern a withResultTime f = withResultArc (\(Arc s e) -> Arc (f s) (f e)) -- | Apply a function to the timespan of the query withQueryArc :: (Arc -> Arc) -> Pattern a -> Pattern a withQueryArc f p = p {query = query p . (\(State a m) -> State (f a) m)} -- | Apply a function to the time (both start and end) of the query withQueryTime :: (Time -> Time) -> Pattern a -> Pattern a withQueryTime f = withQueryArc (\(Arc s e) -> Arc (f s) (f e)) -- | @withEvent f p@ returns a new @Pattern@ with each event mapped over -- function @f@. withEvent :: (Event a -> Event b) -> Pattern a -> Pattern b withEvent f p = p {query = map f . query p} -- | @withEvent f p@ returns a new @Pattern@ with f applied to the resulting list of events for each query -- function @f@. withEvents :: ([Event a] -> [Event b]) -> Pattern a -> Pattern b withEvents f p = p {query = f . query p} -- | @withPart f p@ returns a new @Pattern@ with function @f@ applied -- to the part. withPart :: (Arc -> Arc) -> Pattern a -> Pattern a withPart f = withEvent (\(Event c w p v) -> Event c w (f p) v) -- | Apply one of three functions to a Value, depending on its type applyFIS :: (Double -> Double) -> (Int -> Int) -> (String -> String) -> Value -> Value applyFIS f _ _ (VF f') = VF $ f f' applyFIS _ f _ (VI i ) = VI $ f i applyFIS _ _ f (VS s ) = VS $ f s applyFIS _ _ _ v = v -- | Apply one of two functions to a Value, depending on its type (int -- or float; strings and rationals are ignored) fNum2 :: (Int -> Int -> Int) -> (Double -> Double -> Double) -> Value -> Value -> Value fNum2 fInt _ (VI a) (VI b) = VI $ fInt a b fNum2 _ fFloat (VF a) (VF b) = VF $ fFloat a b fNum2 _ fFloat (VI a) (VF b) = VF $ fFloat (fromIntegral a) b fNum2 _ fFloat (VF a) (VI b) = VF $ fFloat a (fromIntegral b) fNum2 _ _ x _ = x getI :: Value -> Maybe Int getI (VI i) = Just i getI (VR x) = Just $ floor x getI (VF x) = Just $ floor x getI _ = Nothing getF :: Value -> Maybe Double getF (VF f) = Just f getF (VR x) = Just $ fromRational x getF (VI x) = Just $ fromIntegral x getF _ = Nothing getS :: Value -> Maybe String getS (VS s) = Just s getS _ = Nothing getB :: Value -> Maybe Bool getB (VB b) = Just b getB _ = Nothing getR :: Value -> Maybe Rational getR (VR r) = Just r getR (VF x) = Just $ toRational x getR (VI x) = Just $ toRational x getR _ = Nothing getBlob :: Value -> Maybe [Word8] getBlob (VX xs) = Just xs getBlob _ = Nothing compressArc :: Arc -> Pattern a -> Pattern a compressArc (Arc s e) p | s > e = empty | s > 1 || e > 1 = empty | s < 0 || e < 0 = empty | otherwise = s `rotR` _fastGap (1/(e-s)) p compressArcTo :: Arc -> Pattern a -> Pattern a compressArcTo (Arc s e) = compressArc (Arc (cyclePos s) (e - sam s)) _fastGap :: Time -> Pattern a -> Pattern a _fastGap 0 _ = empty _fastGap r p = splitQueries $ withResultArc (\(Arc s e) -> Arc (sam s + ((s - sam s)/r')) (sam s + ((e - sam s)/r')) ) $ p {query = f} where r' = max r 1 -- zero width queries of the next sam should return zero in this case.. f st@(State a _) | start a' == nextSam (start a) = [] | otherwise = query p st {arc = a'} where mungeQuery t = sam t + min 1 (r' * cyclePos t) a' = (\(Arc s e) -> Arc (mungeQuery s) (mungeQuery e)) a -- | Shifts a pattern back in time by the given amount, expressed in cycles rotL :: Time -> Pattern a -> Pattern a rotL t p = withResultTime (subtract t) $ withQueryTime (+ t) p -- | Shifts a pattern forward in time by the given amount, expressed in cycles rotR :: Time -> Pattern a -> Pattern a rotR t = rotL (negate t) -- ** Event filters -- | Remove events from patterns that to not meet the given test filterValues :: (a -> Bool) -> Pattern a -> Pattern a filterValues f p = p {query = filter (f . value) . query p} -- | Turns a pattern of 'Maybe' values into a pattern of values, -- dropping the events of 'Nothing'. filterJust :: Pattern (Maybe a) -> Pattern a filterJust p = fromJust <$> filterValues isJust p -- formerly known as playWhen filterWhen :: (Time -> Bool) -> Pattern a -> Pattern a filterWhen test p = p {query = filter (test . wholeStart) . query p} filterOnsets :: Pattern a -> Pattern a filterOnsets p = p {query = filter (\e -> eventPartStart e == wholeStart e) . query (filterDigital p)} filterEvents :: (Event a -> Bool) -> Pattern a -> Pattern a filterEvents f p = p {query = filter f . query p} filterDigital :: Pattern a -> Pattern a filterDigital = filterEvents isDigital filterAnalog :: Pattern a -> Pattern a filterAnalog = filterEvents isAnalog playFor :: Time -> Time -> Pattern a -> Pattern a playFor s e = filterWhen (\t -> (t >= s) && (t < e)) -- ** Temporal parameter helpers tParam :: (t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a tParam f tv p = innerJoin $ (`f` p) <$> tv tParam2 :: (a -> b -> c -> Pattern d) -> Pattern a -> Pattern b -> c -> Pattern d tParam2 f a b p = innerJoin $ (\x y -> f x y p) <$> a <*> b tParam3 :: (a -> b -> c -> Pattern d -> Pattern e) -> (Pattern a -> Pattern b -> Pattern c -> Pattern d -> Pattern e) tParam3 f a b c p = innerJoin $ (\x y z -> f x y z p) <$> a <*> b <*> c tParamSqueeze :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c) tParamSqueeze f tv p = squeezeJoin $ (`f` p) <$> tv -- | Mark values in the first pattern which match with at least one -- value in the second pattern. matchManyToOne :: (b -> a -> Bool) -> Pattern a -> Pattern b -> Pattern (Bool, b) matchManyToOne f pa pb = pa {query = q} where q st = map match $ query pb st where match (ex@(Event xContext xWhole xPart x)) = Event (combineContexts $ xContext:(map context as')) xWhole xPart (any (f x) (map value $ as'), x) where as' = as $ start $ wholeOrPart ex as s = query pa $ fQuery s fQuery s = st {arc = Arc s s} tidal-1.5.2/src/Sound/Tidal/Scales.hs0000644000000000000000000002041507346545000015471 0ustar0000000000000000module Sound.Tidal.Scales (scale, scaleList, scaleTable, getScale) where import Prelude hiding ((<*), (*>)) import Data.Maybe import Sound.Tidal.Pattern import Sound.Tidal.Utils -- five notes scales minPent :: Fractional a => [a] minPent = [0,3,5,7,10] majPent :: Fractional a => [a] majPent = [0,2,4,7,9] -- another mode of major pentatonic ritusen :: Fractional a => [a] ritusen = [0,2,5,7,9] -- another mode of major pentatonic egyptian :: Fractional a => [a] egyptian = [0,2,5,7,10] -- kumai :: Fractional a => [a] kumai = [0,2,3,7,9] hirajoshi :: Fractional a => [a] hirajoshi = [0,2,3,7,8] iwato :: Fractional a => [a] iwato = [0,1,5,6,10] chinese :: Fractional a => [a] chinese = [0,4,6,7,11] indian :: Fractional a => [a] indian = [0,4,5,7,10] pelog :: Fractional a => [a] pelog = [0,1,3,7,8] -- prometheus :: Fractional a => [a] prometheus = [0,2,4,6,11] scriabin :: Fractional a => [a] scriabin = [0,1,4,7,9] -- han chinese pentatonic scales gong :: Fractional a => [a] gong = [0,2,4,7,9] shang :: Fractional a => [a] shang = [0,2,5,7,10] jiao :: Fractional a => [a] jiao = [0,3,5,8,10] zhi :: Fractional a => [a] zhi = [0,2,5,7,9] yu :: Fractional a => [a] yu = [0,3,5,7,10] -- 6 note scales whole' :: Fractional a => [a] whole' = [0,2,4,6,8,10] augmented :: Fractional a => [a] augmented = [0,3,4,7,8,11] augmented2 :: Fractional a => [a] augmented2 = [0,1,4,5,8,9] -- hexatonic modes with no tritone hexMajor7 :: Fractional a => [a] hexMajor7 = [0,2,4,7,9,11] hexDorian :: Fractional a => [a] hexDorian = [0,2,3,5,7,10] hexPhrygian :: Fractional a => [a] hexPhrygian = [0,1,3,5,8,10] hexSus :: Fractional a => [a] hexSus = [0,2,5,7,9,10] hexMajor6 :: Fractional a => [a] hexMajor6 = [0,2,4,5,7,9] hexAeolian :: Fractional a => [a] hexAeolian = [0,3,5,7,8,10] -- 7 note scales major :: Fractional a => [a] major = [0,2,4,5,7,9,11] ionian :: Fractional a => [a] ionian = [0,2,4,5,7,9,11] dorian :: Fractional a => [a] dorian = [0,2,3,5,7,9,10] phrygian :: Fractional a => [a] phrygian = [0,1,3,5,7,8,10] lydian :: Fractional a => [a] lydian = [0,2,4,6,7,9,11] mixolydian :: Fractional a => [a] mixolydian = [0,2,4,5,7,9,10] aeolian :: Fractional a => [a] aeolian = [0,2,3,5,7,8,10] minor :: Fractional a => [a] minor = [0,2,3,5,7,8,10] locrian :: Fractional a => [a] locrian = [0,1,3,5,6,8,10] harmonicMinor :: Fractional a => [a] harmonicMinor = [0,2,3,5,7,8,11] harmonicMajor :: Fractional a => [a] harmonicMajor = [0,2,4,5,7,8,11] melodicMinor :: Fractional a => [a] melodicMinor = [0,2,3,5,7,9,11] melodicMinorDesc :: Fractional a => [a] melodicMinorDesc = [0,2,3,5,7,8,10] melodicMajor :: Fractional a => [a] melodicMajor = [0,2,4,5,7,8,10] bartok :: Fractional a => [a] bartok = melodicMajor hindu :: Fractional a => [a] hindu = melodicMajor -- raga modes todi :: Fractional a => [a] todi = [0,1,3,6,7,8,11] purvi :: Fractional a => [a] purvi = [0,1,4,6,7,8,11] marva :: Fractional a => [a] marva = [0,1,4,6,7,9,11] bhairav :: Fractional a => [a] bhairav = [0,1,4,5,7,8,11] ahirbhairav :: Fractional a => [a] ahirbhairav = [0,1,4,5,7,9,10] -- superLocrian :: Fractional a => [a] superLocrian = [0,1,3,4,6,8,10] romanianMinor :: Fractional a => [a] romanianMinor = [0,2,3,6,7,9,10] hungarianMinor :: Fractional a => [a] hungarianMinor = [0,2,3,6,7,8,11] neapolitanMinor :: Fractional a => [a] neapolitanMinor = [0,1,3,5,7,8,11] enigmatic :: Fractional a => [a] enigmatic = [0,1,4,6,8,10,11] spanish :: Fractional a => [a] spanish = [0,1,4,5,7,8,10] -- modes of whole tones with added note -> leadingWhole :: Fractional a => [a] leadingWhole = [0,2,4,6,8,10,11] lydianMinor :: Fractional a => [a] lydianMinor = [0,2,4,6,7,8,10] neapolitanMajor :: Fractional a => [a] neapolitanMajor = [0,1,3,5,7,9,11] locrianMajor :: Fractional a => [a] locrianMajor = [0,2,4,5,6,8,10] -- 8 note scales diminished :: Fractional a => [a] diminished = [0,1,3,4,6,7,9,10] diminished2 :: Fractional a => [a] diminished2 = [0,2,3,5,6,8,9,11] -- modes of limited transposition messiaen1 :: Fractional a => [a] messiaen1 = whole' messiaen2 :: Fractional a => [a] messiaen2 = diminished messiaen3 :: Fractional a => [a] messiaen3 = [0, 2, 3, 4, 6, 7, 8, 10, 11] messiaen4 :: Fractional a => [a] messiaen4 = [0, 1, 2, 5, 6, 7, 8, 11] messiaen5 :: Fractional a => [a] messiaen5 = [0, 1, 5, 6, 7, 11] messiaen6 :: Fractional a => [a] messiaen6 = [0, 2, 4, 5, 6, 8, 10, 11] messiaen7 :: Fractional a => [a] messiaen7 = [0, 1, 2, 3, 5, 6, 7, 8, 9, 11] -- Arabic maqams taken from SuperCollider's Scale.sc bayati :: Fractional a => [a] bayati = [0, 1.5, 3, 5, 7, 8, 10] hijaz :: Fractional a => [a] hijaz = [0, 1, 4, 5, 7, 8.5, 10] sikah :: Fractional a => [a] sikah = [0, 1.5, 3.5, 5.5, 7, 8.5, 10.5] rast :: Fractional a => [a] rast = [0, 2, 3.5, 5, 7, 9, 10.5] iraq :: Fractional a => [a] iraq = [0, 1.5, 3.5, 5, 6.5, 8.5, 10.5] saba :: Fractional a => [a] saba = [0, 1.5, 3, 4, 6, 8, 10] -- 12 note scales chromatic :: Fractional a => [a] chromatic = [0,1,2,3,4,5,6,7,8,9,10,11] scale :: Fractional a => Pattern String -> Pattern Int -> Pattern a scale = getScale scaleTable getScale :: Fractional a => [(String, [a])] -> Pattern String -> Pattern Int -> Pattern a getScale table sp p = (\n scaleName -> noteInScale (fromMaybe [0] $ lookup scaleName table) n) <$> p <* sp where octave s x = x `div` length s noteInScale s x = (s !!! x) + fromIntegral (12 * octave s x) scaleList :: String scaleList = unwords $ map fst (scaleTable :: [(String, [Rational])]) scaleTable :: Fractional a => [(String, [a])] scaleTable = [("minPent", minPent), ("majPent", majPent), ("ritusen", ritusen), ("egyptian", egyptian), ("kumai", kumai), ("hirajoshi", hirajoshi), ("iwato", iwato), ("chinese", chinese), ("indian", indian), ("pelog", pelog), ("prometheus", prometheus), ("scriabin", scriabin), ("gong", gong), ("shang", shang), ("jiao", jiao), ("zhi", zhi), ("yu", yu), ("whole", whole'), ("wholetone", whole'), ("augmented", augmented), ("augmented2", augmented2), ("hexMajor7", hexMajor7), ("hexDorian", hexDorian), ("hexPhrygian", hexPhrygian), ("hexSus", hexSus), ("hexMajor6", hexMajor6), ("hexAeolian", hexAeolian), ("major", major), ("ionian", ionian), ("dorian", dorian), ("phrygian", phrygian), ("lydian", lydian), ("mixolydian", mixolydian), ("aeolian", aeolian), ("minor", minor), ("locrian", locrian), ("harmonicMinor", harmonicMinor), ("harmonicMajor", harmonicMajor), ("melodicMinor", melodicMinor), ("melodicMinorDesc", melodicMinorDesc), ("melodicMajor", melodicMajor), ("bartok", bartok), ("hindu", hindu), ("todi", todi), ("purvi", purvi), ("marva", marva), ("bhairav", bhairav), ("ahirbhairav", ahirbhairav), ("superLocrian", superLocrian), ("romanianMinor", romanianMinor), ("hungarianMinor", hungarianMinor), ("neapolitanMinor", neapolitanMinor), ("enigmatic", enigmatic), ("spanish", spanish), ("leadingWhole", leadingWhole), ("lydianMinor", lydianMinor), ("neapolitanMajor", neapolitanMajor), ("locrianMajor", locrianMajor), ("diminished", diminished), ("octatonic", diminished), ("diminished2", diminished2), ("octatonic2", diminished2), ("messiaen1", messiaen1), ("messiaen2", messiaen2), ("messiaen3", messiaen3), ("messiaen4", messiaen4), ("messiaen5", messiaen5), ("messiaen6", messiaen6), ("messiaen7", messiaen7), ("chromatic", chromatic), ("bayati", bayati), ("hijaz", hijaz), ("sikah", sikah), ("rast", rast), ("saba", saba), ("iraq", iraq) ] tidal-1.5.2/src/Sound/Tidal/Show.hs0000644000000000000000000001564507346545000015210 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Sound.Tidal.Show (show, showAll, draw, drawLine, drawLineSz) where import Sound.Tidal.Pattern import Data.List (intercalate, sortOn) import Data.Ratio (numerator, denominator) import Data.Maybe (fromMaybe, isJust) import qualified Data.Map.Strict as Map instance (Show a) => Show (Pattern a) where show = showPattern (Arc 0 1) showPattern :: Show a => Arc -> Pattern a -> String showPattern a p = intercalate "\n" evStrings where evs = map showEvent $ sortOn part $ queryArc p a maxPartLength :: Int maxPartLength = maximum $ map (length . fst) evs evString :: (String, String) -> String evString ev = ((replicate (maxPartLength - (length (fst ev))) ' ') ++ fst ev ++ snd ev ) evStrings = map evString evs showEvent :: Show a => Event a -> (String, String) showEvent (Event _ (Just (Arc ws we)) a@(Arc ps pe) e) = (h ++ "(" ++ show a ++ ")" ++ t ++ "|", show e) where h | ws == ps = "" | otherwise = prettyRat ws ++ "-" t | we == pe = "" | otherwise = "-" ++ prettyRat we showEvent (Event _ Nothing a e) = ("~" ++ show a ++ "~|", show e) -- Show everything, including event context showAll :: Show a => Arc -> Pattern a -> String showAll a p = intercalate "\n" $ map show $ sortOn part $ queryArc p a instance Show Context where show (Context cs) = show cs instance Show Value where show (VS s) = ('"':s) ++ "\"" show (VI i) = show i show (VF f) = show f ++ "f" show (VR r) = show r ++ "r" show (VB b) = show b show (VX xs) = show xs instance {-# OVERLAPPING #-} Show ControlMap where show m = intercalate ", " $ map (\(name, v) -> name ++ ": " ++ show v) $ Map.toList m instance {-# OVERLAPPING #-} Show Arc where show (Arc s e) = prettyRat s ++ ">" ++ prettyRat e instance {-# OVERLAPPING #-} Show a => Show (Event a) where show e = show (context e) ++ ((\(a,b) -> a ++ b) $ showEvent e) prettyRat :: Rational -> String prettyRat r | unit == 0 && frac > 0 = showFrac (numerator frac) (denominator frac) | otherwise = show unit ++ showFrac (numerator frac) (denominator frac) where unit = floor r :: Int frac = r - toRational unit showFrac :: Integer -> Integer -> String showFrac 0 _ = "" showFrac 1 2 = "½" showFrac 1 3 = "⅓" showFrac 2 3 = "⅔" showFrac 1 4 = "¼" showFrac 3 4 = "¾" showFrac 1 5 = "⅕" showFrac 2 5 = "⅖" showFrac 3 5 = "⅗" showFrac 4 5 = "⅘" showFrac 1 6 = "⅙" showFrac 5 6 = "⅚" showFrac 1 7 = "⅐" showFrac 1 8 = "⅛" showFrac 3 8 = "⅜" showFrac 5 8 = "⅝" showFrac 7 8 = "⅞" showFrac 1 9 = "⅑" showFrac 1 10 = "⅒" showFrac n d = fromMaybe plain $ do n' <- up n d' <- down d return $ n' ++ d' where plain = show n ++ "/" ++ show d up 1 = Just "¹" up 2 = Just "²" up 3 = Just "³" up 4 = Just "⁴" up 5 = Just "⁵" up 6 = Just "⁶" up 7 = Just "⁷" up 8 = Just "⁸" up 9 = Just "⁹" up 0 = Just "⁰" up _ = Nothing down 1 = Just "₁" down 2 = Just "₂" down 3 = Just "₃" down 4 = Just "₄" down 5 = Just "₅" down 6 = Just "₆" down 7 = Just "₇" down 8 = Just "₈" down 9 = Just "₉" down 0 = Just "₀" down _ = Nothing stepcount :: Pattern a -> Int stepcount pat = fromIntegral $ eventSteps $ concatMap (\ev -> [start ev, stop ev]) $ map part $ filter eventHasOnset $ queryArc pat (Arc 0 1) where eventSteps xs = foldr lcm 1 $ map denominator xs data Render = Render Int Int String instance Show Render where show (Render cyc i render) | i <= 1024 = "\n[" ++ show cyc ++ (if cyc == 1 then " cycle" else " cycles") ++ "]\n" ++ render | otherwise = "That pattern is too complex to draw." drawLine :: Pattern Char -> Render drawLine = drawLineSz 78 drawLineSz :: Int -> Pattern Char -> Render drawLineSz sz pat = joinCycles sz $ drawCycles pat where drawCycles :: Pattern Char -> [Render] drawCycles pat' = (draw pat'):(drawCycles $ rotL 1 pat') joinCycles :: Int -> [Render] -> Render joinCycles _ [] = Render 0 0 "" joinCycles n ((Render cyc l s):cs) | l > n = Render 0 0 "" | otherwise = Render (cyc+cyc') (l + l' + 1) $ intercalate "\n" $ map (\(a,b) -> a ++ b) lineZip where (Render cyc' l' s') = joinCycles (n-l-1) cs linesN = max (length $ lines s) (length $ lines s') lineZip = take linesN $ zip (lines s ++ (repeat $ replicate l ' ')) (lines s' ++ (repeat $ replicate l' ' ')) -- where maximum (map (length . head . (++ [""]) . lines) cs) draw :: Pattern Char -> Render draw pat = Render 1 s $ (intercalate "\n" $ map ((\x -> ('|':x)) .drawLevel) ls) where ls = levels pat s = stepcount pat rs = toRational s drawLevel :: [Event Char] -> String drawLevel [] = replicate s ' ' drawLevel (e:es) = map f $ take s $ zip (drawLevel es ++ repeat ' ') (drawEvent e ++ repeat ' ') f (' ', x) = x f (x, _) = x drawEvent :: Event Char -> String drawEvent ev = (replicate (floor $ rs * evStart) ' ') ++ (value ev:(replicate ((floor $ rs * (evStop - evStart)) - 1) '-')) where evStart = start $ wholeOrPart ev evStop = stop $ wholeOrPart ev {- fitsWhole :: Event b -> [Event b] -> Bool fitsWhole event events = not $ any (\event' -> isJust $ subArc (wholeOrPart event) (wholeOrPart event')) events addEventWhole :: Event b -> [[Event b]] -> [[Event b]] addEventWhole e [] = [[e]] addEventWhole e (level:ls) | isAnalog e = level:ls | fitsWhole e level = (e:level) : ls | otherwise = level : addEventWhole e ls arrangeEventsWhole :: [Event b] -> [[Event b]] arrangeEventsWhole = foldr addEventWhole [] levelsWhole :: Eq a => Pattern a -> [[Event a]] levelsWhole pat = arrangeEventsWhole $ sortOn' ((\Arc{..} -> 0 - (stop - start)) . wholeOrPart) (defragParts $ queryArc pat (Arc 0 1)) sortOn' :: Ord a => (b -> a) -> [b] -> [b] sortOn' f = map snd . sortOn fst . map (\x -> let y = f x in y `seq` (y, x)) -} fits :: Event b -> [Event b] -> Bool fits (Event _ _ part' _) events = not $ any (\Event{..} -> isJust $ subArc part' part) events addEvent :: Event b -> [[Event b]] -> [[Event b]] addEvent e [] = [[e]] addEvent e (level:ls) | fits e level = (e:level) : ls | otherwise = level : addEvent e ls arrangeEvents :: [Event b] -> [[Event b]] arrangeEvents = foldr addEvent [] levels :: Eq a => Pattern a -> [[Event a]] -- levels pat = arrangeEvents $ sortOn' ((\Arc{..} -> stop - start) . part) (defragParts $ queryArc pat (Arc 0 1)) levels pat = arrangeEvents $ reverse $ defragParts $ queryArc pat (Arc 0 1) tidal-1.5.2/src/Sound/Tidal/Simple.hs0000644000000000000000000000235707346545000015515 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Sound.Tidal.Simple where import Sound.Tidal.Control (chop, hurry) import Sound.Tidal.Core ((#), (|*), (<~), silence, rev) import Sound.Tidal.Params (crush, gain, pan, speed, s) import Sound.Tidal.ParseBP (parseBP_E) import Sound.Tidal.Pattern (ControlPattern) import GHC.Exts ( IsString(..) ) instance {-# OVERLAPPING #-} IsString ControlPattern where fromString = s . parseBP_E crunch :: ControlPattern -> ControlPattern crunch = (# crush 3) scratch :: ControlPattern -> ControlPattern scratch = rev . chop 32 louder :: ControlPattern -> ControlPattern louder = (|* gain 1.2) quieter :: ControlPattern -> ControlPattern quieter = (|* gain 0.8) silent :: ControlPattern -> ControlPattern silent = const silence skip :: ControlPattern -> ControlPattern skip = (0.25 <~) left :: ControlPattern -> ControlPattern left = (# pan 0) right :: ControlPattern -> ControlPattern right = (# pan 1) higher :: ControlPattern -> ControlPattern higher = (|* speed 1.5) lower :: ControlPattern -> ControlPattern lower = (|* speed 0.75) faster :: ControlPattern -> ControlPattern faster = hurry 2 slower :: ControlPattern -> ControlPattern slower = hurry 0.5 tidal-1.5.2/src/Sound/Tidal/Stream.hs0000644000000000000000000005075707346545000015526 0ustar0000000000000000{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} module Sound.Tidal.Stream where import Control.Applicative ((<|>)) import Control.Concurrent.MVar import Control.Concurrent import qualified Data.Map.Strict as Map import Data.Maybe (fromJust, fromMaybe, catMaybes) import qualified Control.Exception as E -- import Control.Monad.Reader -- import Control.Monad.Except -- import qualified Data.Bifunctor as BF -- import qualified Data.Bool as B -- import qualified Data.Char as C import System.IO (hPutStrLn, stderr) import qualified Sound.OSC.FD as O import Sound.Tidal.Config import Sound.Tidal.Core (stack, silence) import Sound.Tidal.Pattern import qualified Sound.Tidal.Tempo as T -- import qualified Sound.OSC.Datum as O import Data.List (sortOn) import System.Random (getStdRandom, randomR) import Sound.Tidal.Show () data Stream = Stream {sConfig :: Config, sInput :: MVar StateMap, -- sOutput :: MVar ControlPattern, sListenTid :: Maybe ThreadId, sPMapMV :: MVar PlayMap, sTempoMV :: MVar T.Tempo, sGlobalFMV :: MVar (ControlPattern -> ControlPattern), sCxs :: [Cx] } type PatId = String data Cx = Cx {cxTarget :: Target, cxUDP :: O.UDP, cxOSCs :: [OSC] } deriving (Show) data StampStyle = BundleStamp | MessageStamp deriving (Eq, Show) data Schedule = Pre StampStyle | Live deriving (Eq, Show) data Target = Target {oName :: String, oAddress :: String, oPort :: Int, oLatency :: Double, oWindow :: Maybe Arc, oSchedule :: Schedule } deriving Show data Args = Named {required :: [String]} | ArgList [(String, Maybe Value)] deriving Show data OSC = OSC {path :: String, args :: Args } deriving Show data PlayState = PlayState {pattern :: ControlPattern, mute :: Bool, solo :: Bool, history :: [ControlPattern] } deriving Show type PlayMap = Map.Map PatId PlayState superdirtTarget :: Target superdirtTarget = Target {oName = "SuperDirt", oAddress = "127.0.0.1", oPort = 57120, oLatency = 0.2, oWindow = Nothing, oSchedule = Pre BundleStamp } superdirtShape :: OSC superdirtShape = OSC "/play2" $ Named {required = ["s"]} dirtTarget :: Target dirtTarget = Target {oName = "Dirt", oAddress = "127.0.0.1", oPort = 7771, oLatency = 0.02, oWindow = Nothing, oSchedule = Pre MessageStamp } dirtShape :: OSC dirtShape = OSC "/play" $ ArgList [("sec", Just $ VI 0), ("usec", Just $ VI 0), ("cps", Just $ VF 0), ("s", Nothing), ("offset", Just $ VF 0), ("begin", Just $ VF 0), ("end", Just $ VF 1), ("speed", Just $ VF 1), ("pan", Just $ VF 0.5), ("velocity", Just $ VF 0.5), ("vowel", Just $ VS ""), ("cutoff", Just $ VF 0), ("resonance", Just $ VF 0), ("accelerate", Just $ VF 0), ("shape", Just $ VF 0), ("kriole", Just $ VI 0), ("gain", Just $ VF 1), ("cut", Just $ VI 0), ("delay", Just $ VF 0), ("delaytime", Just $ VF (-1)), ("delayfeedback", Just $ VF (-1)), ("crush", Just $ VF 0), ("coarse", Just $ VI 0), ("hcutoff", Just $ VF 0), ("hresonance", Just $ VF 0), ("bandf", Just $ VF 0), ("bandq", Just $ VF 0), ("unit", Just $ VS "rate"), ("loop", Just $ VF 0), ("n", Just $ VF 0), ("attack", Just $ VF (-1)), ("hold", Just $ VF 0), ("release", Just $ VF (-1)), ("orbit", Just $ VI 0), ("id", Just $ VI 0) ] startStream :: Config -> [(Target, [OSC])] -> IO Stream startStream config oscmap = do cxs <- mapM (\(target, os) -> do u <- O.openUDP (oAddress target) (oPort target) return $ Cx {cxUDP = u, cxTarget = target, cxOSCs = os} ) oscmap sMapMV <- newMVar Map.empty pMapMV <- newMVar Map.empty globalFMV <- newMVar id listenTid <- ctrlListen sMapMV config tempoMV <- newEmptyMVar let stream = Stream {sConfig = config, sInput = sMapMV, sListenTid = listenTid, sPMapMV = pMapMV, sTempoMV = tempoMV, sGlobalFMV = globalFMV, sCxs = cxs } _ <- T.clocked config tempoMV $ onTick stream return stream startTidal :: Target -> Config -> IO Stream startTidal target config = startStream config [(target, [superdirtShape])] startMulti :: [Target] -> Config -> IO () startMulti _ _ = putStrLn $ "startMulti has been removed, please check the latest documentation on tidalcycles.org" toDatum :: Value -> O.Datum toDatum (VF x) = O.float x toDatum (VI x) = O.int32 x toDatum (VS x) = O.string x toDatum (VR x) = O.float $ ((fromRational x) :: Double) toDatum (VB True) = O.int32 (1 :: Int) toDatum (VB False) = O.int32 (0 :: Int) toDatum (VX xs) = O.Blob $ O.blob_pack xs toData :: OSC -> Event ControlMap -> Maybe [O.Datum] toData (OSC {args = ArgList as}) e = fmap (fmap toDatum) $ sequence $ map (\(n,v) -> Map.lookup n (value e) <|> v) as toData (OSC {args = Named rqrd}) e | hasRequired rqrd = Just $ concatMap (\(n,v) -> [O.string n, toDatum v]) $ Map.toList $ value e | otherwise = Nothing where hasRequired [] = True hasRequired xs = null $ filter (not . (`elem` ks)) xs ks = Map.keys (value e) substitutePath :: String -> ControlMap -> Maybe String substitutePath str cm = parse str where parse [] = Just [] parse ('{':xs) = parseWord xs parse (x:xs) = do xs' <- parse xs return (x:xs') parseWord xs | b == [] = getString cm a | otherwise = do v <- getString cm a xs' <- parse (tail b) return $ v ++ xs' where (a,b) = break (== '}') xs getString :: ControlMap -> String -> Maybe String getString cm s = defaultValue $ simpleShow <$> Map.lookup s cm where simpleShow :: Value -> String simpleShow (VS str) = str simpleShow (VI i) = show i simpleShow (VF f) = show f simpleShow (VR r) = show r simpleShow (VB b) = show b simpleShow (VX xs) = show xs (_, dflt) = break (== '=') s defaultValue :: Maybe String -> Maybe String defaultValue Nothing | null dflt = Nothing | otherwise = Just $ tail dflt defaultValue x = x playStack :: PlayMap -> ControlPattern playStack pMap = stack $ map pattern active where active = filter (\pState -> if hasSolo pMap then solo pState else not (mute pState) ) $ Map.elems pMap toOSC :: Double -> Event ControlMap -> T.Tempo -> OSC -> Maybe (Double, O.Message) toOSC latency e tempo osc = do vs <- toData osc addExtra mungedPath <- substitutePath (path osc) (value e) return (ts, O.Message mungedPath vs) where on = sched tempo $ start $ wholeOrPart e off = sched tempo $ stop $ wholeOrPart e delta = off - on -- If there is already cps in the event, the union will preserve that. addExtra = (\v -> (Map.union v extra)) <$> e extra = Map.fromList [("cps", (VF $ T.cps tempo)), ("delta", VF delta), ("cycle", VF (fromRational $ start $ wholeOrPart e)) ] ts = on + nudge + latency nudge = fromJust $ getF $ fromMaybe (VF 0) $ Map.lookup "nudge" $ value e doCps :: MVar T.Tempo -> (Double, Maybe Value) -> IO () doCps tempoMV (d, Just (VF cps)) = do _ <- forkIO $ do threadDelay $ floor $ d * 1000000 -- hack to stop things from stopping ! _ <- T.setCps tempoMV (max 0.00001 cps) return () return () doCps _ _ = return () onTick :: Stream -> T.State -> IO () onTick stream st = do doTick False stream st processCps :: T.Tempo -> [Event ControlMap] -> ([(T.Tempo, Event ControlMap)], T.Tempo) processCps t [] = ([], t) -- If an event has a tempo change, that affects the following events.. processCps t (e:evs) = (((t', e):es'), t'') where cps' = do x <- Map.lookup "cps" $ value e getF x t' = (maybe t (\newCps -> T.changeTempo' t newCps (eventPartStart e)) cps') (es', t'') = processCps t' evs 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 = do now <- O.time tempo <- readMVar (sTempoMV stream) pMapMV <- newMVar $ Map.singleton "fake" (PlayState {pattern = pat, mute = False, solo = False, history = [] } ) let cps = T.cps tempo state = T.State {T.ticks = 0, T.start = now, T.nowTimespan = (now, now + (1/cps)), T.nowArc = (Arc 0 1) } doTick True (stream {sPMapMV = pMapMV}) state doTick :: Bool -> Stream -> T.State -> IO () doTick fake stream st = do tempo <- takeMVar (sTempoMV stream) pMap <- readMVar (sPMapMV stream) sMap <- readMVar (sInput stream) sGlobalF <- readMVar (sGlobalFMV stream) -- putStrLn $ show st let config = sConfig stream cxs = sCxs stream cycleNow = T.timeToCycles tempo $ T.start st patstack = sGlobalF $ playStack pMap -- If a 'fake' tick, it'll be aligned with cycle zero pat | fake = withResultTime (+ cycleNow) patstack | otherwise = patstack frameEnd = snd $ T.nowTimespan st -- add cps to state sMap' = Map.insert "_cps" (pure $ VF $ T.cps tempo) sMap filterOns = filter eventHasOnset extraLatency | fake = 0 | otherwise = cFrameTimespan config + T.nudged tempo --filterOns | cSendParts config = id -- | otherwise = filter eventHasOnset es = sortOn (start . part) $ filterOns $ query pat (State {arc = T.nowArc st, controls = sMap' } ) -- TODO onset is calculated in toOSC as well.. on e tempo'' = (sched tempo'' $ start $ wholeOrPart e) (tes, tempo') = processCps tempo es mapM_ (\cx@(Cx target _ oscs) -> (do let latency = oLatency target + extraLatency ms = concatMap (\(t, e) -> if (fake || (on e t) < frameEnd) then catMaybes $ map (toOSC latency e t) oscs else [] ) tes E.catch $ mapM_ (send cx) ms ) (\(e ::E.SomeException) -> putStrLn $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e ) ) cxs putMVar (sTempoMV stream) tempo' return () send :: Cx -> (Double, O.Message) -> IO () send cx (time, m) | oSchedule target == Pre BundleStamp = O.sendBundle u $ O.Bundle time [m] | oSchedule target == Pre MessageStamp = O.sendMessage u $ addtime m | otherwise = do _ <- forkIO $ do now <- O.time threadDelay $ floor $ (time - now) * 1000000 O.sendMessage u m return () where addtime (O.Message mpath params) = O.Message mpath ((O.int32 sec):((O.int32 usec):params)) ut = O.ntpr_to_ut time sec :: Int sec = floor ut usec :: Int usec = floor $ 1000000 * (ut - (fromIntegral sec)) u = cxUDP cx target = cxTarget cx -- latency target = oLatency target + cFrameTimespan config + T.nudged tempo sched :: T.Tempo -> Rational -> Double sched tempo c = ((fromRational $ c - (T.atCycle tempo)) / T.cps tempo) + (T.atTime tempo) -- Interaction streamNudgeAll :: Stream -> Double -> IO () streamNudgeAll s nudge = do tempo <- takeMVar $ sTempoMV s putMVar (sTempoMV s) $ tempo {T.nudged = nudge} streamResetCycles :: Stream -> IO () streamResetCycles s = do _ <- T.resetCycles (sTempoMV s) return () hasSolo :: Map.Map k PlayState -> Bool hasSolo = (>= 1) . length . filter solo . Map.elems streamList :: Stream -> IO () streamList s = do pMap <- readMVar (sPMapMV s) let hs = hasSolo pMap putStrLn $ concatMap (showKV hs) $ Map.toList pMap where showKV :: Bool -> (PatId, PlayState) -> String showKV True (k, (PlayState {solo = True})) = k ++ " - solo\n" showKV True (k, _) = "(" ++ k ++ ")\n" showKV False (k, (PlayState {solo = False})) = k ++ "\n" showKV False (k, _) = "(" ++ k ++ ") - muted\n" -- Evaluation of pat is forced so exceptions are picked up here, before replacing the existing pattern. streamReplace :: Show a => Stream -> a -> ControlPattern -> IO () streamReplace s k !pat = E.catch (do let x = queryArc pat (Arc 0 0) tempo <- readMVar $ sTempoMV s input <- takeMVar $ sInput s -- put change time in control input now <- O.time let cyc = T.timeToCycles tempo now putMVar (sInput s) $ Map.insert ("_t_all") (pure $ VR cyc) $ Map.insert ("_t_" ++ show k) (pure $ VR cyc) input -- update the pattern itself pMap <- seq x $ takeMVar $ sPMapMV s let playState = updatePS $ Map.lookup (show k) pMap putMVar (sPMapMV s) $ Map.insert (show k) playState pMap return () ) (\(e :: E.SomeException) -> hPutStrLn stderr $ "Error in pattern: " ++ show e ) where updatePS (Just playState) = do playState {pattern = pat, history = pat:(history playState)} updatePS Nothing = PlayState pat False False [pat] streamMute :: Show a => Stream -> a -> IO () streamMute s k = withPatId s (show k) (\x -> x {mute = True}) streamMutes :: Show a => Stream -> [a] -> IO () streamMutes s ks = withPatIds s (map show ks) (\x -> x {mute = True}) streamUnmute :: Show a => Stream -> a -> IO () streamUnmute s k = withPatId s (show k) (\x -> x {mute = False}) streamSolo :: Show a => Stream -> a -> IO () streamSolo s k = withPatId s (show k) (\x -> x {solo = True}) streamUnsolo :: Show a => Stream -> a -> IO () streamUnsolo s k = withPatId s (show k) (\x -> x {solo = False}) withPatId :: Stream -> PatId -> (PlayState -> PlayState) -> IO () withPatId s k f = withPatIds s [k] f withPatIds :: Stream -> [PatId] -> (PlayState -> PlayState) -> IO () withPatIds s ks f = do playMap <- takeMVar $ sPMapMV s let pMap' = foldr (Map.update (\x -> Just $ f x)) playMap ks putMVar (sPMapMV s) pMap' return () -- TODO - is there a race condition here? streamMuteAll :: Stream -> IO () streamMuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = True}) streamHush :: Stream -> IO () streamHush s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {pattern = silence, history = silence:history x}) streamUnmuteAll :: Stream -> IO () streamUnmuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = False}) streamAll :: Stream -> (ControlPattern -> ControlPattern) -> IO () streamAll s f = do _ <- swapMVar (sGlobalFMV s) f return () streamSet :: Valuable a => Stream -> String -> Pattern a -> IO () streamSet s k pat = do sMap <- takeMVar $ sInput s let pat' = toValue <$> pat sMap' = Map.insert k pat' sMap putMVar (sInput s) $ sMap' streamSetI :: Stream -> String -> Pattern Int -> IO () streamSetI = streamSet streamSetF :: Stream -> String -> Pattern Double -> IO () streamSetF = streamSet streamSetS :: Stream -> String -> Pattern String -> IO () streamSetS = streamSet streamSetB :: Stream -> String -> Pattern Bool -> IO () streamSetB = streamSet streamSetR :: Stream -> String -> Pattern Rational -> IO () streamSetR = streamSet ctrlListen :: MVar StateMap -> Config -> IO (Maybe ThreadId) ctrlListen sMapMV c | cCtrlListen c = do putStrLn $ "Listening for controls on " ++ cCtrlAddr c ++ ":" ++ show (cCtrlPort c) catchAny run (\_ -> do putStrLn $ "Control listen failed. Perhaps there's already another tidal instance listening on that port?" return Nothing ) | otherwise = return Nothing where run = do sock <- O.udpServer (cCtrlAddr c) (cCtrlPort c) tid <- forkIO $ loop sock return $ Just tid loop sock = do ms <- O.recvMessages sock mapM_ act ms loop sock act (O.Message x (O.Int32 k:v:[])) = act (O.Message x [O.string $ show k,v]) act (O.Message _ (O.ASCII_String k:v@(O.Float _):[])) = add (O.ascii_to_string k) (VF $ fromJust $ O.datum_floating v) act (O.Message _ (O.ASCII_String k:O.ASCII_String v:[])) = add (O.ascii_to_string k) (VS $ O.ascii_to_string v) act (O.Message _ (O.ASCII_String k:O.Int32 v:[])) = add (O.ascii_to_string k) (VI $ fromIntegral v) act m = putStrLn $ "Unhandled OSC: " ++ show m add :: String -> Value -> IO () add k v = do sMap <- takeMVar sMapMV putMVar sMapMV $ Map.insert k (pure v) sMap return () catchAny :: IO a -> (E.SomeException -> IO a) -> IO a catchAny = E.catch tidal-1.5.2/src/Sound/Tidal/Tempo.hs0000644000000000000000000002355307346545000015351 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-orphans #-} {-# LANGUAGE RecordWildCards #-} module Sound.Tidal.Tempo where import Control.Concurrent.MVar import qualified Sound.Tidal.Pattern as P import qualified Sound.OSC.FD as O import qualified Network.Socket as N import Control.Concurrent (forkIO, ThreadId, threadDelay) import Control.Monad (forever, when, foldM) import Data.List (nub) import qualified Control.Exception as E import Sound.Tidal.Config import Sound.Tidal.Utils (writeError) instance Show O.UDP where show _ = "-unshowable-" data Tempo = Tempo {atTime :: O.Time, atCycle :: Rational, cps :: O.Time, paused :: Bool, nudged :: Double, localUDP :: O.UDP, remoteAddr :: N.SockAddr, synched :: Bool } deriving Show data State = State {ticks :: Int, start :: O.Time, nowTimespan :: (O.Time, O.Time), nowArc :: P.Arc, starting :: Bool } deriving Show changeTempo :: MVar Tempo -> (O.Time -> Tempo -> Tempo) -> IO Tempo changeTempo tempoMV f = do t <- O.time tempo <- takeMVar tempoMV let tempo' = f t $ tempo sendTempo tempo' putMVar tempoMV tempo' return tempo' changeTempo' :: Tempo -> O.Time -> Rational -> Tempo changeTempo' tempo newCps cyc = tempo {atTime = cyclesToTime tempo cyc, cps = newCps, atCycle = cyc } resetCycles :: MVar Tempo -> IO Tempo resetCycles tempoMV = changeTempo tempoMV (\t tempo -> tempo {atTime = t, atCycle = 0}) setCps :: MVar Tempo -> O.Time -> IO Tempo setCps tempoMV newCps = changeTempo tempoMV (\t tempo -> tempo {atTime = t, atCycle = timeToCycles tempo t, cps = newCps }) defaultCps :: O.Time defaultCps = 0.5625 defaultTempo :: O.Time -> O.UDP -> N.SockAddr -> Tempo defaultTempo t local remote = Tempo {atTime = t, atCycle = 0, cps = defaultCps, paused = False, nudged = 0, localUDP = local, remoteAddr = remote, synched = False } -- | Returns the given time in terms of -- cycles relative to metrical grid of a given Tempo timeToCycles :: Tempo -> O.Time -> Rational timeToCycles tempo t = atCycle tempo + toRational cycleDelta where delta = t - atTime tempo cycleDelta = realToFrac (cps tempo) * delta cyclesToTime :: Tempo -> Rational -> O.Time cyclesToTime tempo cyc = atTime tempo + (fromRational timeDelta) where cycleDelta = cyc - atCycle tempo timeDelta = cycleDelta / (toRational $ cps tempo) {- getCurrentCycle :: MVar Tempo -> IO Rational getCurrentCycle t = (readMVar t) >>= (cyclesNow) >>= (return . toRational) -} clocked :: Config -> MVar Tempo -> (State -> IO ()) -> IO [ThreadId] clocked config tempoMV callback = do s <- O.time -- TODO - do something with thread id _ <- serverListen config listenTid <- clientListen config tempoMV s let st = State {ticks = 0, start = s, nowTimespan = (s, s + frameTimespan), nowArc = P.Arc 0 0, starting = True } clockTid <- forkIO $ loop st return [listenTid, clockTid] where frameTimespan :: Double frameTimespan = cFrameTimespan config loop st = do -- putStrLn $ show $ nowArc ts tempo <- readMVar tempoMV t <- O.time let logicalT ticks' = start st + fromIntegral ticks' * frameTimespan logicalNow = logicalT $ ticks st + 1 -- Wait maximum of two frames delta = min (frameTimespan * 2) (logicalNow - t) e = timeToCycles tempo logicalNow s = if starting st && synched tempo then timeToCycles tempo (logicalT $ ticks st) else P.stop $ nowArc st when (t < logicalNow) $ threadDelay (floor $ delta * 1000000) t' <- O.time let actualTick = floor $ (t' - start st) / frameTimespan -- reset ticks if ahead/behind by skipTicks or more ahead = (abs $ actualTick - ticks st) > (cSkipTicks config) newTick | ahead = actualTick | otherwise = (ticks st) + 1 st' = st {ticks = newTick, nowArc = P.Arc s e, nowTimespan = (logicalNow, logicalNow + frameTimespan), starting = not (synched tempo) } when ahead $ writeError $ "skip: " ++ show (actualTick - ticks st) callback st' {-putStrLn ("actual tick: " ++ show actualTick ++ " old tick: " ++ show (ticks st) ++ " new tick: " ++ show newTick )-} loop st' clientListen :: Config -> MVar Tempo -> O.Time -> IO (ThreadId) clientListen config tempoMV s = do -- Listen on random port let tempoClientPort = cTempoClientPort config hostname = cTempoAddr config port = cTempoPort config (remote_addr:_) <- N.getAddrInfo Nothing (Just hostname) Nothing local <- O.udpServer "0.0.0.0" tempoClientPort let (N.SockAddrInet _ a) = N.addrAddress remote_addr remote = N.SockAddrInet (fromIntegral port) a t = defaultTempo s local remote putMVar tempoMV t -- Send to clock port from same port that's listened to O.sendTo local (O.p_message "/hello" []) remote -- Make tempo mvar -- Listen to tempo changes tempoChild <- forkIO $ listenTempo local tempoMV return tempoChild sendTempo :: Tempo -> IO () sendTempo tempo = O.sendTo (localUDP tempo) (O.p_bundle (atTime tempo) [m]) (remoteAddr tempo) where m = O.Message "/transmit/cps/cycle" [O.Float $ fromRational $ atCycle tempo, O.Float $ realToFrac $ cps tempo, O.Int32 $ if paused tempo then 1 else 0 ] listenTempo :: O.UDP -> MVar Tempo -> IO () listenTempo udp tempoMV = forever $ do pkt <- O.recvPacket udp act Nothing pkt return () where act _ (O.Packet_Bundle (O.Bundle ts ms)) = mapM_ (act (Just ts) . O.Packet_Message) ms act (Just ts) (O.Packet_Message (O.Message "/cps/cycle" [O.Float atCycle', O.Float cps', O.Int32 paused' ] ) ) = do tempo <- takeMVar tempoMV putMVar tempoMV $ tempo {atTime = ts, atCycle = realToFrac atCycle', cps = realToFrac cps', paused = paused' == 1, synched = True } act _ pkt = writeError $ "Unknown packet (client): " ++ show pkt serverListen :: Config -> IO (Maybe ThreadId) serverListen config = catchAny run (\_ -> return Nothing) -- probably just already running) where run = do let port = cTempoPort config -- iNADDR_ANY deprecated - what's the right way to do this? udp <- O.udpServer "0.0.0.0" port cpsMessage <- defaultCpsMessage tid <- forkIO $ loop udp ([], cpsMessage) return $ Just tid loop udp (cs, msg) = do (pkt,c) <- O.recvFrom udp (cs', msg') <- act udp c Nothing (cs,msg) pkt loop udp (cs', msg') act :: O.UDP -> N.SockAddr -> Maybe O.Time -> ([N.SockAddr], O.Packet) -> O.Packet -> IO ([N.SockAddr], O.Packet) act udp c _ (cs,msg) (O.Packet_Bundle (O.Bundle ts ms)) = foldM (act udp c (Just ts)) (cs,msg) $ map O.Packet_Message ms act udp c _ (cs,msg) (O.Packet_Message (O.Message "/hello" [])) = do O.sendTo udp msg c return (nub (c:cs),msg) act udp _ (Just ts) (cs,_) (O.Packet_Message (O.Message "/transmit/cps/cycle" params)) = do let path' = "/cps/cycle" msg' = O.p_bundle ts [O.Message path' params] mapM_ (O.sendTo udp msg') cs return (cs, msg') act _ x _ (cs,msg) pkt = do writeError $ "Unknown packet (serv): " ++ show pkt ++ " / " ++ (show x) return (cs,msg) catchAny :: IO a -> (E.SomeException -> IO a) -> IO a catchAny = E.catch defaultCpsMessage = do ts <- O.time return $ O.p_bundle ts [O.Message "/cps/cycle" [O.Float $ 0, O.Float $ realToFrac $ defaultCps, O.Int32 0 ] ] tidal-1.5.2/src/Sound/Tidal/Transition.hs0000644000000000000000000001702307346545000016412 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Sound.Tidal.Transition where import Prelude hiding ((<*), (*>)) import Control.Concurrent.MVar (readMVar, takeMVar, putMVar) import qualified Sound.OSC.FD as O import qualified Data.Map.Strict as Map -- import Data.Maybe (fromJust) import Sound.Tidal.Control import Sound.Tidal.Core import Sound.Tidal.Params (gain, pan) import Sound.Tidal.Pattern import Sound.Tidal.Stream import Sound.Tidal.Tempo (timeToCycles) import Sound.Tidal.UI (fadeOutFrom, fadeInFrom) import Sound.Tidal.Utils (enumerate) -- Evaluation of pat is forced so exceptions are picked up here, before replacing the existing pattern. -- the "historyFlag" determines if the new pattern should be placed on the history stack or not transition :: Show a => Stream -> Bool -> (Time -> [ControlPattern] -> ControlPattern) -> a -> ControlPattern -> IO () transition stream historyFlag f patId !pat = do pMap <- takeMVar (sPMapMV stream) let playState = updatePS $ Map.lookup (show patId) pMap pat' <- transition' $ appendPat (not historyFlag) (history playState) let pMap' = Map.insert (show patId) (playState {pattern = pat'}) pMap putMVar (sPMapMV stream) pMap' return () where appendPat flag = if flag then (pat:) else id updatePS (Just playState) = playState {history = (appendPat historyFlag) (history playState)} updatePS Nothing = PlayState {pattern = silence, mute = False, solo = False, history = (appendPat historyFlag) (silence:[]) } transition' pat' = do tempo <- readMVar $ sTempoMV stream now <- O.time let c = timeToCycles tempo now return $ f c pat' 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 -- | 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 tidal-1.5.2/src/Sound/Tidal/UI.hs0000644000000000000000000022275107346545000014603 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-} module Sound.Tidal.UI where import Prelude hiding ((<*), (*>)) import Data.Char (digitToInt, isDigit, ord) import Data.Bits (testBit, Bits, xor, shiftL, shiftR) -- import System.Random (randoms, mkStdGen) -- import Control.Monad.ST -- import Control.Monad.Primitive (PrimState, PrimMonad) -- import qualified Data.Vector as V -- import Data.Word (Word32) import Data.Ratio ((%)) import Data.List (sort, sortOn, findIndices, elemIndex, groupBy, transpose, intercalate, findIndex) import Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe) import qualified Data.Text as T import qualified Data.Map.Strict as Map import Data.Bool (bool) import Sound.Tidal.Bjorklund (bjorklund) import Sound.Tidal.Core import qualified Sound.Tidal.Params as P import Sound.Tidal.Pattern import Sound.Tidal.Utils ------------------------------------------------------------------------ -- * UI -- | Randomisation -- cf. George Marsaglia (2003). "Xorshift RNGs". Journal of Statistical Software 8:14. -- https://www.jstatsoft.org/article/view/v008i14 xorwise :: Int -> Int xorwise x = let a = xor (shiftL x 13) x b = xor (shiftR a 17) a in xor (shiftL b 5) b -- stretch 300 cycles over the range of [0,2**29 == 536870912) then apply the xorshift algorithm timeToIntSeed :: RealFrac a => a -> Int timeToIntSeed = xorwise . truncate . (* 536870912) . snd . (properFraction :: (RealFrac a => a -> (Int,a))) . (/ 300) intSeedToRand :: Fractional a => Int -> a intSeedToRand = (/ 536870912) . realToFrac . (`mod` 536870912) timeToRand :: (RealFrac a, Fractional b) => a -> b timeToRand = intSeedToRand . timeToIntSeed timeToRands :: (RealFrac a, Fractional b) => a -> Int -> [b] timeToRands t n = timeToRands' (timeToIntSeed t) n timeToRands' :: Fractional a => Int -> Int -> [a] timeToRands' seed n | n <= 0 = [] | otherwise = (intSeedToRand seed) : (timeToRands' (xorwise seed) (n-1)) {-| `rand` generates a continuous pattern of (pseudo-)random numbers between `0` and `1`. @ sound "bd*8" # pan rand @ pans bass drums randomly @ sound "sn sn ~ sn" # gain rand @ makes the snares' randomly loud and quiet. Numbers coming from this pattern are 'seeded' by time. So if you reset time (via `cps (-1)`, then `cps 1.1` or whatever cps you want to restart with) the random pattern will emit the exact same _random_ numbers again. In cases where you need two different random patterns, you can shift one of them around to change the time from which the _random_ pattern is read, note the difference: @ jux (# gain rand) $ sound "sn sn ~ sn" # gain rand @ and with the juxed version shifted backwards for 1024 cycles: @ jux (# ((1024 <~) $ gain rand)) $ sound "sn sn ~ sn" # gain rand @ -} rand :: Fractional a => Pattern a rand = Pattern (\(State a@(Arc s e) _) -> [Event (Context []) Nothing a (realToFrac $ (timeToRand ((e + s)/2) :: Double))]) {- | Just like `rand` but for whole numbers, `irand n` generates a pattern of (pseudo-) random whole numbers between `0` to `n-1` inclusive. Notably used to pick a random samples from a folder: @ d1 $ segment 4 $ n (irand 5) # sound "drum" @ -} irand :: Num a => Int -> Pattern a irand i = fromIntegral . (floor :: Double -> Int) . (* fromIntegral i) <$> rand {- | 1D Perlin (smooth) noise, works like rand but smoothly moves between random values each cycle. `perlinWith` takes a pattern as the RNG's "input" instead of automatically using the cycle count. @ d1 $ s "arpy*32" # cutoff (perlinWith (saw * 4) * 2000) @ will generate a smooth random pattern for the cutoff frequency which will repeat every cycle (because the saw does) The `perlin` function uses the cycle count as input and can be used much like @rand@. -} perlinWith :: Pattern Double -> Pattern Double perlinWith p = interp <$> (p-pa) <*> (timeToRand <$> pa) <*> (timeToRand <$> pb) where pa = (fromIntegral :: Int -> Double) . floor <$> p pb = (fromIntegral :: Int -> Double) . (+1) . floor <$> p interp x a b = a + smootherStep x * (b-a) smootherStep x = 6.0 * x**5 - 15.0 * x**4 + 10.0 * x**3 perlin :: Pattern Double perlin = perlinWith (sig fromRational) {- `perlin2With` is Perlin noise with a 2-dimensional input. This can be useful for more control over how the randomness repeats (or doesn't). @ d1 $ s "[supersaw:-12*32]" # lpf (rangex 60 5000 $ perlin2With (cosine*2) (sine*2)) # lpq 0.3 @ will generate a smooth random cutoff pattern that repeats every cycle without any reversals or discontinuities (because the 2D path is a circle). `perlin2` only needs one input because it uses the cycle count as the second input. -} perlin2With :: Pattern Double -> Pattern Double -> Pattern Double perlin2With x y = (/2) . (+1) $ interp2 <$> xfrac <*> yfrac <*> dota <*> dotb <*> dotc <*> dotd where fl = fmap ((fromIntegral :: Int -> Double) . floor) ce = fmap ((fromIntegral :: Int -> Double) . (+1) . floor) xfrac = x - fl x yfrac = y - fl y randAngle a b = 2 * pi * timeToRand (a + 0.0001 * b) pcos x' y' = cos $ randAngle <$> x' <*> y' psin x' y' = sin $ randAngle <$> x' <*> y' dota = pcos (fl x) (fl y) * xfrac + psin (fl x) (fl y) * yfrac dotb = pcos (ce x) (fl y) * (xfrac - 1) + psin (ce x) (fl y) * yfrac dotc = pcos (fl x) (ce y) * xfrac + psin (fl x) (ce y) * (yfrac - 1) dotd = pcos (ce x) (ce y) * (xfrac - 1) + psin (ce x) (ce y) * (yfrac - 1) interp2 x' y' a b c d = (1.0 - s x') * (1.0 - s y') * a + s x' * (1.0 - s y') * b + (1.0 - s x') * s y' * c + s x' * s y' * d s x' = 6.0 * x'**5 - 15.0 * x'**4 + 10.0 * x'**3 perlin2 :: Pattern Double -> Pattern Double perlin2 = perlin2With (sig fromRational) {- | Randomly picks an element from the given list @ sound "superpiano(3,8)" # note (choose ["a", "e", "g", "c"]) @ plays a melody randomly choosing one of the four notes \"a\", \"e\", \"g\", \"c\". -} choose :: [a] -> Pattern a choose = chooseBy rand chooseBy :: Pattern Double -> [a] -> Pattern a chooseBy _ [] = silence chooseBy f xs = (xs !!!) . floor <$> range 0 (fromIntegral $ length xs) f {- | Like @choose@, but works on an a list of tuples of values and weights @ sound "superpiano(3,8)" # note (wchoose [("a",1), ("e",0.5), ("g",2), ("c",1)]) @ In the above example, the "a" and "c" notes are twice as likely to play as the "e" note, and half as likely to play as the "g" note. -} wchoose :: [(a,Double)] -> Pattern a wchoose = wchooseBy rand wchooseBy :: Pattern Double -> [(a,Double)] -> Pattern a wchooseBy pat pairs = match <$> pat where match r = values !! head (findIndices (> (r*total)) cweights) cweights = scanl1 (+) (map snd pairs) values = map fst pairs total = sum $ map snd pairs {- | Similar to `degrade` `degradeBy` allows you to control the percentage of events that are removed. For example, to remove events 90% of the time: @ d1 $ slow 2 $ degradeBy 0.9 $ sound "[[[feel:5*8,feel*3] feel:3*8], feel*4]" # accelerate "-6" # speed "2" @ -} degradeBy :: Pattern Double -> Pattern a -> Pattern a degradeBy = tParam _degradeBy _degradeBy :: Double -> Pattern a -> Pattern a _degradeBy = _degradeByUsing rand -- Useful for manipulating random stream, e.g. to change 'seed' _degradeByUsing :: Pattern Double -> Double -> Pattern a -> Pattern a _degradeByUsing prand x p = fmap fst $ filterValues ((> x) . snd) $ (,) <$> p <* prand unDegradeBy :: Pattern Double -> Pattern a -> Pattern a unDegradeBy = tParam _unDegradeBy _unDegradeBy :: Double -> Pattern a -> Pattern a _unDegradeBy x p = fmap fst $ filterValues ((<= x) . snd) $ (,) <$> p <* rand degradeOverBy :: Int -> Pattern Double -> Pattern a -> Pattern a degradeOverBy i tx p = unwrap $ (\x -> fmap fst $ filterValues ((> x) . snd) $ (,) <$> p <* fastRepeatCycles i rand) <$> slow (fromIntegral i) tx {- | Use @sometimesBy@ to apply a given function "sometimes". For example, the following code results in `density 2` being applied about 25% of the time: @ d1 $ sometimesBy 0.25 (density 2) $ sound "bd*8" @ There are some aliases as well: @ sometimes = sometimesBy 0.5 often = sometimesBy 0.75 rarely = sometimesBy 0.25 almostNever = sometimesBy 0.1 almostAlways = sometimesBy 0.9 @ -} sometimesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a sometimesBy x f p = overlay (degradeBy x p) (unDegradeBy x $ f p) -- | @sometimes@ is an alias for sometimesBy 0.5. sometimes :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a sometimes = sometimesBy 0.5 -- | @often@ is an alias for sometimesBy 0.75. often :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a often = sometimesBy 0.75 -- | @rarely@ is an alias for sometimesBy 0.25. rarely :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a rarely = sometimesBy 0.25 -- | @almostNever@ is an alias for sometimesBy 0.1 almostNever :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a almostNever = sometimesBy 0.1 -- | @almostAlways@ is an alias for sometimesBy 0.9 almostAlways :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a almostAlways = sometimesBy 0.9 never :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a never = flip const always :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a always = id {- | @someCyclesBy@ is a cycle-by-cycle version of @sometimesBy@. It has a `someCycles = someCyclesBy 0.5` alias -} someCyclesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a someCyclesBy pd f pat = innerJoin $ (\d -> _someCyclesBy d f pat) <$> pd _someCyclesBy :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a _someCyclesBy x = when test where test c = timeToRand (fromIntegral c :: Double) < x somecyclesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a somecyclesBy = someCyclesBy someCycles :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a someCycles = someCyclesBy 0.5 somecycles :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a somecycles = someCycles {- | `degrade` randomly removes events from a pattern 50% of the time: @ d1 $ slow 2 $ degrade $ sound "[[[feel:5*8,feel*3] feel:3*8], feel*4]" # accelerate "-6" # speed "2" @ The shorthand syntax for `degrade` is a question mark: `?`. Using `?` will allow you to randomly remove events from a portion of a pattern: @ d1 $ slow 2 $ sound "bd ~ sn bd ~ bd? [sn bd?] ~" @ You can also use `?` to randomly remove events from entire sub-patterns: @ d1 $ slow 2 $ sound "[[[feel:5*8,feel*3] feel:3*8]?, feel*4]" @ -} degrade :: Pattern a -> Pattern a degrade = _degradeBy 0.5 {- | (The above means that `brak` is a function from patterns of any type, to a pattern of the same type.) Make a pattern sound a bit like a breakbeat Example: @ d1 $ sound (brak "bd sn kurt") @ -} brak :: Pattern a -> Pattern a brak = when ((== 1) . (`mod` 2)) (((1%4) `rotR`) . (\x -> fastcat [x, silence])) {- | Divides a pattern into a given number of subdivisions, plays the subdivisions in order, but increments the starting subdivision each cycle. The pattern wraps to the first subdivision after the last subdivision is played. Example: @ d1 $ iter 4 $ sound "bd hh sn cp" @ This will produce the following over four cycles: @ bd hh sn cp hh sn cp bd sn cp bd hh cp bd hh sn @ There is also `iter'`, which shifts the pattern in the opposite direction. -} iter :: Pattern Int -> Pattern c -> Pattern c iter = tParam _iter _iter :: Int -> Pattern a -> Pattern a _iter n p = slowcat $ map (\i -> (fromIntegral i % fromIntegral n) `rotL` p) [0 .. (n-1)] -- | @iter'@ is the same as @iter@, but decrements the starting -- subdivision instead of incrementing it. iter' :: Pattern Int -> Pattern c -> Pattern c iter' = tParam _iter' _iter' :: Int -> Pattern a -> Pattern a _iter' n p = slowcat $ map (\i -> (fromIntegral i % fromIntegral n) `rotR` p) [0 .. (n-1)] -- | @palindrome p@ applies @rev@ to @p@ every other cycle, so that -- the pattern alternates between forwards and backwards. palindrome :: Pattern a -> Pattern a palindrome p = slowAppend p (rev p) -- | Composing patterns {- | The function @seqP@ allows you to define when a sound within a list starts and ends. The code below contains three separate patterns in a `stack`, but each has different start times (zero cycles, eight cycles, and sixteen cycles, respectively). All patterns stop after 128 cycles: @ d1 $ seqP [ (0, 128, sound "bd bd*2"), (8, 128, sound "hh*2 [sn cp] cp future*4"), (16, 128, sound (samples "arpy*8" (run 16))) ] @ -} seqP :: [(Time, Time, Pattern a)] -> Pattern a seqP ps = stack $ map (\(s, e, p) -> playFor s e (sam s `rotR` p)) ps -- | Degrades a pattern over the given time. fadeOut :: Time -> Pattern a -> Pattern a fadeOut dur p = innerJoin $ (`_degradeBy` p) <$> _slow dur envL -- | Alternate version to @fadeOut@ where you can provide the time from which the fade starts fadeOutFrom :: Time -> Time -> Pattern a -> Pattern a fadeOutFrom from dur p = innerJoin $ (`_degradeBy` p) <$> (from `rotR` _slow dur envL) -- | 'Undegrades' a pattern over the given time. fadeIn :: Time -> Pattern a -> Pattern a fadeIn dur p = innerJoin $ (`_degradeBy` p) <$> _slow dur envLR -- | Alternate version to @fadeIn@ where you can provide the time from -- which the fade in starts fadeInFrom :: Time -> Time -> Pattern a -> Pattern a fadeInFrom from dur p = innerJoin $ (`_degradeBy` p) <$> (from `rotR` _slow dur envLR) {- | The 'spread' function allows you to take a pattern transformation which takes a parameter, such as `slow`, and provide several parameters which are switched between. In other words it 'spreads' a function across several values. Taking a simple high hat loop as an example: @ d1 $ sound "ho ho:2 ho:3 hc" @ We can slow it down by different amounts, such as by a half: @ d1 $ slow 2 $ sound "ho ho:2 ho:3 hc" @ Or by four thirds (i.e. speeding it up by a third; `4%3` means four over three): @ d1 $ slow (4%3) $ sound "ho ho:2 ho:3 hc" @ But if we use `spread`, we can make a pattern which alternates between the two speeds: @ d1 $ spread slow [2,4%3] $ sound "ho ho:2 ho:3 hc" @ Note that if you pass ($) as the function to spread values over, you can put functions as the list of values. For example: @ d1 $ spread ($) [density 2, rev, slow 2, striate 3, (# speed "0.8")] $ sound "[bd*2 [~ bd]] [sn future]*2 cp jvbass*4" @ Above, the pattern will have these transforms applied to it, one at a time, per cycle: * cycle 1: `density 2` - pattern will increase in speed * cycle 2: `rev` - pattern will be reversed * cycle 3: `slow 2` - pattern will decrease in speed * cycle 4: `striate 3` - pattern will be granualized * cycle 5: `(# speed "0.8")` - pattern samples will be played back more slowly After `(# speed "0.8")`, the transforms will repeat and start at `density 2` again. -} spread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b spread f xs p = slowcat $ map (`f` p) xs slowspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b slowspread = spread {- | @fastspread@ works the same as @spread@, but the result is squashed into a single cycle. If you gave four values to @spread@, then the result would seem to speed up by a factor of four. Compare these two: d1 $ spread chop [4,64,32,16] $ sound "ho ho:2 ho:3 hc" d1 $ fastspread chop [4,64,32,16] $ sound "ho ho:2 ho:3 hc" There is also @slowspread@, which is an alias of @spread@. -} fastspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b fastspread f xs p = fastcat $ map (`f` p) xs {- | There's a version of this function, `spread'` (pronounced "spread prime"), which takes a *pattern* of parameters, instead of a list: @ d1 $ spread' slow "2 4%3" $ sound "ho ho:2 ho:3 hc" @ This is quite a messy area of Tidal - due to a slight difference of implementation this sounds completely different! One advantage of using `spread'` though is that you can provide polyphonic parameters, e.g.: @ d1 $ spread' slow "[2 4%3, 3]" $ sound "ho ho:2 ho:3 hc" @ -} spread' :: Monad m => (a -> b -> m c) -> m a -> b -> m c spread' f vpat pat = vpat >>= \v -> f v pat {- | `spreadChoose f xs p` is similar to `slowspread` but picks values from `xs` at random, rather than cycling through them in order. It has a shorter alias `spreadr`. -} spreadChoose :: (t -> t1 -> Pattern b) -> [t] -> t1 -> Pattern b spreadChoose f vs p = do v <- _segment 1 (choose vs) f v p spreadr :: (t -> t1 -> Pattern b) -> [t] -> t1 -> Pattern b spreadr = spreadChoose {-| Decide whether to apply one or another function depending on the result of a test function that is passed the current cycle as a number. @ d1 $ ifp ((== 0).(flip mod 2)) (striate 4) (# coarse "24 48") $ sound "hh hc" @ This will apply `striate 4` for every _even_ cycle and aply `# coarse "24 48"` for every _odd_. Detail: As you can see the test function is arbitrary and does not rely on anything tidal specific. In fact it uses only plain haskell functionality, that is: it calculates the modulo of 2 of the current cycle which is either 0 (for even cycles) or 1. It then compares this value against 0 and returns the result, which is either `True` or `False`. This is what the `ifp` signature's first part signifies `(Int -> Bool)`, a function that takes a whole number and returns either `True` or `False`. -} ifp :: (Int -> Bool) -> (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a ifp test f1 f2 p = splitQueries $ p {query = q} where q a | test (floor $ start $ arc a) = query (f1 p) a | otherwise = query (f2 p) a -- | @wedge t p p'@ combines patterns @p@ and @p'@ by squashing the -- @p@ into the portion of each cycle given by @t@, and @p'@ into the -- remainer of each cycle. wedge :: Time -> Pattern a -> Pattern a -> Pattern a wedge 0 _ p' = p' wedge 1 p _ = p wedge t p p' = overlay (_fastGap (1/t) p) (t `rotR` _fastGap (1/(1-t)) p') {- | @whenmod@ has a similar form and behavior to `every`, but requires an additional number. Applies the function to the pattern, when the remainder of the current loop number divided by the first parameter, is greater or equal than the second parameter. For example the following makes every other block of four loops twice as dense: @ d1 $ whenmod 8 4 (density 2) (sound "bd sn kurt") @ -} whenmod :: Int -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a whenmod a b = Sound.Tidal.Core.when (\t -> (t `mod` a) >= b ) {- | @ superimpose f p = stack [p, f p] @ `superimpose` plays a modified version of a pattern at the same time as the original pattern, resulting in two patterns being played at the same time. @ d1 $ superimpose (density 2) $ sound "bd sn [cp ht] hh" d1 $ superimpose ((# speed "2") . (0.125 <~)) $ sound "bd sn cp hh" @ -} superimpose :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a superimpose f p = stack [p, f p] {- | @trunc@ truncates a pattern so that only a fraction of the pattern is played. The following example plays only the first quarter of the pattern: @ d1 $ trunc 0.25 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2" @ -} trunc :: Pattern Time -> Pattern a -> Pattern a trunc = tParam _trunc _trunc :: Time -> Pattern a -> Pattern a _trunc t = compress (0, t) . zoomArc (Arc 0 t) {- | @linger@ is similar to `trunc` but the truncated part of the pattern loops until the end of the cycle @ d1 $ linger 0.25 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2" @ -} linger :: Pattern Time -> Pattern a -> Pattern a linger = tParam _linger _linger :: Time -> Pattern a -> Pattern a _linger n p = _fast (1/n) $ zoomArc (Arc 0 n) p {- | Use `within` to apply a function to only a part of a pattern. For example, to apply `density 2` to only the first half of a pattern: @ d1 $ within (0, 0.5) (density 2) $ sound "bd*2 sn lt mt hh hh hh hh" @ Or, to apply `(# speed "0.5") to only the last quarter of a pattern: @ d1 $ within (0.75, 1) (# speed "0.5") $ sound "bd*2 sn lt mt hh hh hh hh" @ -} within :: (Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a within (s, e) f p = stack [filterWhen (\t -> cyclePos t >= s && cyclePos t < e) $ f p, filterWhen (\t -> not $ cyclePos t >= s && cyclePos t < e) p ] withinArc :: Arc -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a withinArc (Arc s e) = within (s, e) {- | For many cases, @within'@ will function exactly as within. The difference between the two occurs when applying functions that change the timing of notes such as 'fast' or '<~'. within first applies the function to all notes in the cycle, then keeps the results in the specified interval, and then combines it with the old cycle (an "apply split combine" paradigm). within' first keeps notes in the specified interval, then applies the function to these notes, and then combines it with the old cycle (a "split apply combine" paradigm). For example, whereas using the standard version of within @ d1 $ within (0, 0.25) (fast 2) $ sound "bd hh cp sd" @ sounds like: @ d1 $ sound "[bd hh] hh cp sd" @ using this alternative version, within' @ d1 $ within' (0, 0.25) (fast 2) $ sound "bd hh cp sd" @ sounds like: @ d1 $ sound "[bd bd] hh cp sd" @ -} within' :: (Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a within' a@(s, e) f p = stack [ filterWhen (\t -> cyclePos t >= s && cyclePos t < e) $ compress a $ f $ zoom a p , filterWhen (\t -> not $ cyclePos t >= s && cyclePos t < e) p ] revArc :: (Time, Time) -> Pattern a -> Pattern a revArc a = within a rev {- | You can use the @e@ function to apply a Euclidean algorithm over a complex pattern, although the structure of that pattern will be lost: @ d1 $ e 3 8 $ sound "bd*2 [sn cp]" @ In the above, three sounds are picked from the pattern on the right according to the structure given by the `e 3 8`. It ends up picking two `bd` sounds, a `cp` and missing the `sn` entirely. These types of sequences use "Bjorklund's algorithm", which wasn't made for music but for an application in nuclear physics, which is exciting. More exciting still is that it is very similar in structure to the one of the first known algorithms written in Euclid's book of elements in 300 BC. You can read more about this in the paper [The Euclidean Algorithm Generates Traditional Musical Rhythms](http://cgm.cs.mcgill.ca/~godfried/publications/banff.pdf) by Toussaint. Some examples from this paper are included below, including rotation in some cases. @ - (2,5) : A thirteenth century Persian rhythm called Khafif-e-ramal. - (3,4) : The archetypal pattern of the Cumbia from Colombia, as well as a Calypso rhythm from Trinidad. - (3,5,2) : Another thirteenth century Persian rhythm by the name of Khafif-e-ramal, as well as a Rumanian folk-dance rhythm. - (3,7) : A Ruchenitza rhythm used in a Bulgarian folk-dance. - (3,8) : The Cuban tresillo pattern. - (4,7) : Another Ruchenitza Bulgarian folk-dance rhythm. - (4,9) : The Aksak rhythm of Turkey. - (4,11) : The metric pattern used by Frank Zappa in his piece titled Outside Now. - (5,6) : Yields the York-Samai pattern, a popular Arab rhythm. - (5,7) : The Nawakhat pattern, another popular Arab rhythm. - (5,8) : The Cuban cinquillo pattern. - (5,9) : A popular Arab rhythm called Agsag-Samai. - (5,11) : The metric pattern used by Moussorgsky in Pictures at an Exhibition. - (5,12) : The Venda clapping pattern of a South African children’s song. - (5,16) : The Bossa-Nova rhythm necklace of Brazil. - (7,8) : A typical rhythm played on the Bendir (frame drum). - (7,12) : A common West African bell pattern. - (7,16,14) : A Samba rhythm necklace from Brazil. - (9,16) : A rhythm necklace used in the Central African Republic. - (11,24,14) : A rhythm necklace of the Aka Pygmies of Central Africa. - (13,24,5) : Another rhythm necklace of the Aka Pygmies of the upper Sangha. @ -} euclid :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a euclid = tParam2 _euclid _euclid :: Int -> Int -> Pattern a -> Pattern a _euclid n k a = fastcat $ fmap (bool silence a) $ bjorklund (n,k) -- _euclid :: Int -> Int -> Pattern a -> Pattern a -- _euclid n k p = flip const <$> filterValues (== True) (fastFromList $ bjorklund (n,k)) <*> p {- | `euclidfull n k pa pb` stacks @e n k pa@ with @einv n k pb@ -} euclidFull :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a --euclidFull pn pk pa pb = innerJoin $ (\n k -> _euclidFull n k pa pb) <$> pn <*> pk euclidFull n k pa pb = stack [ euclid n k pa, euclidInv n k pb ] _euclidBool :: Int -> Int -> Pattern Bool _euclidBool n k = fastFromList $ bjorklund (n,k) {-_euclidFull :: Int -> Int -> Pattern a -> Pattern a -> Pattern a _euclidFull n k p p' = pickbool <$> _euclidBool n k <*> p <*> p' where pickbool True a _ = a pickbool False _ b = b -} -- euclid' :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a -- euclid' = tParam2 _euclidq' _euclid' :: Int -> Int -> Pattern a -> Pattern a _euclid' n k p = fastcat $ map (\x -> if x then p else silence) (bjorklund (n,k)) euclidOff :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a euclidOff = tParam3 _euclidOff eoff :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a eoff = euclidOff _euclidOff :: Int -> Int -> Int -> Pattern a -> Pattern a _euclidOff _ 0 _ _ = silence _euclidOff n k s p = (rotL $ fromIntegral s%fromIntegral k) (_euclid n k p) euclidOffBool :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern Bool -> Pattern Bool euclidOffBool = tParam3 _euclidOffBool _euclidOffBool :: Int -> Int -> Int -> Pattern Bool -> Pattern Bool _euclidOffBool _ 0 _ _ = silence _euclidOffBool n k s p = ((fromIntegral s % fromIntegral k) `rotL`) ((\a b -> if b then a else not a) <$> _euclidBool n k <*> p) distrib :: [Pattern Int] -> Pattern a -> Pattern a distrib ps p = do p' <- sequence ps _distrib p' p _distrib :: [Int] -> Pattern a -> Pattern a _distrib xs p = boolsToPat (foldr distrib' (replicate (last xs) True) (reverse $ layers xs)) p where distrib' :: [Bool] -> [Bool] -> [Bool] distrib' [] _ = [] distrib' (_:a) [] = False : distrib' a [] distrib' (True:a) (x:b) = x : distrib' a b distrib' (False:a) b = False : distrib' a b layers = map bjorklund . (zip<*>tail) boolsToPat a b' = flip const <$> filterValues (== True) (fastFromList a) <*> b' {- | `euclidInv` fills in the blanks left by `e` - @e 3 8 "x"@ -> @"x ~ ~ x ~ ~ x ~"@ @euclidInv 3 8 "x"@ -> @"~ x x ~ x x ~ x"@ -} euclidInv :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a euclidInv = tParam2 _euclidInv _euclidInv :: Int -> Int -> Pattern a -> Pattern a --_euclidInv n k p = flip const <$> filterValues (== False) (fastFromList $ bjorklund (n,k)) <*> p _euclidInv n k a = fastcat $ fmap (bool a silence) $ bjorklund (n,k) index :: Real b => b -> Pattern b -> Pattern c -> Pattern c index sz indexpat pat = spread' (zoom' $ toRational sz) (toRational . (*(1-sz)) <$> indexpat) pat where zoom' tSz s = zoomArc (Arc s (s+tSz)) {- -- | @prrw f rot (blen, vlen) beatPattern valuePattern@: pattern rotate/replace. prrw :: (a -> b -> c) -> Int -> (Time, Time) -> Pattern a -> Pattern b -> Pattern c prrw f rot (blen, vlen) beatPattern valuePattern = let ecompare (_,e1,_) (_,e2,_) = compare (fst e1) (fst e2) beats = sortBy ecompare $ arc beatPattern (0, blen) values = fmap thd' . sortBy ecompare $ arc valuePattern (0, vlen) cycles = blen * (fromIntegral $ lcm (length beats) (length values) `div` (length beats)) in _slow cycles $ stack $ zipWith (\( _, (start, end), v') v -> (start `rotR`) $ densityGap (1 / (end - start)) $ pure (f v' v)) (sortBy ecompare $ arc (_fast cycles $ beatPattern) (0, blen)) (drop (rot `mod` length values) $ cycle values) -- | @prr rot (blen, vlen) beatPattern valuePattern@: pattern rotate/replace. prr :: Int -> (Time, Time) -> Pattern String -> Pattern b -> Pattern b prr = prrw $ flip const {-| @preplace (blen, plen) beats values@ combines the timing of @beats@ with the values of @values@. Other ways of saying this are: * sequential convolution * @values@ quantized to @beats@. Examples: @ d1 $ sound $ preplace (1,1) "x [~ x] x x" "bd sn" d1 $ sound $ preplace (1,1) "x(3,8)" "bd sn" d1 $ sound $ "x(3,8)" <~> "bd sn" d1 $ sound "[jvbass jvbass:5]*3" |+| (shape $ "1 1 1 1 1" <~> "0.2 0.9") @ It is assumed the pattern fits into a single cycle. This works well with pattern literals, but not always with patterns defined elsewhere. In those cases use @preplace@ and provide desired pattern lengths: @ let p = slow 2 $ "x x x" d1 $ sound $ preplace (2,1) p "bd sn" @ -} preplace :: (Time, Time) -> Pattern String -> Pattern b -> Pattern b preplace = preplaceWith $ flip const -- | @prep@ is an alias for preplace. prep :: (Time, Time) -> Pattern String -> Pattern b -> Pattern b prep = preplace preplace1 :: Pattern String -> Pattern b -> Pattern b preplace1 = preplace (1, 1) preplaceWith :: (a -> b -> c) -> (Time, Time) -> Pattern a -> Pattern b -> Pattern c preplaceWith f (blen, plen) = prrw f 0 (blen, plen) prw :: (a -> b -> c) -> (Time, Time) -> Pattern a -> Pattern b -> Pattern c prw = preplaceWith preplaceWith1 :: (a -> b -> c) -> Pattern a -> Pattern b -> Pattern c preplaceWith1 f = prrw f 0 (1, 1) prw1 :: (a -> b -> c) -> Pattern a -> Pattern b -> Pattern c prw1 = preplaceWith1 (<~>) :: Pattern String -> Pattern b -> Pattern b (<~>) = preplace (1, 1) -- | @protate len rot p@ rotates pattern @p@ by @rot@ beats to the left. -- @len@: length of the pattern, in cycles. -- Example: @d1 $ every 4 (protate 2 (-1)) $ slow 2 $ sound "bd hh hh hh"@ protate :: Time -> Int -> Pattern a -> Pattern a protate len rot p = prrw (flip const) rot (len, len) p p prot :: Time -> Int -> Pattern a -> Pattern a prot = protate prot1 :: Int -> Pattern a -> Pattern a prot1 = protate 1 {-| The @<<~@ operator rotates a unit pattern to the left, similar to @<~@, but by events rather than linear time. The timing of the pattern remains constant: @ d1 $ (1 <<~) $ sound "bd ~ sn hh" -- will become d1 $ sound "sn ~ hh bd" @ -} (<<~) :: Int -> Pattern a -> Pattern a (<<~) = protate 1 -- | @~>>@ is like @<<~@ but for shifting to the right. (~>>) :: Int -> Pattern a -> Pattern a (~>>) = (<<~) . (0-) -- | @pequal cycles p1 p2@: quickly test if @p1@ and @p2@ are the same. pequal :: Ord a => Time -> Pattern a -> Pattern a -> Bool pequal cycles p1 p2 = (sort $ arc p1 (0, cycles)) == (sort $ arc p2 (0, cycles)) -} -- | @rot n p@ rotates the values in a pattern @p@ by @n@ beats to the left. -- Example: @d1 $ every 4 (rot 2) $ slow 2 $ sound "bd hh hh hh"@ rot :: Ord a => Pattern Int -> Pattern a -> Pattern a rot = tParam _rot -- Calculates a whole cycle, rotates it, then constrains events to the original query arc _rot :: Ord a => Int -> Pattern a -> Pattern a _rot i pat = splitQueries $ pat {query = \st -> f st (query pat (st {arc = wholeCycle (arc st)}))} where -- TODO maybe events with the same arc (part+whole) should be -- grouped together in the rotation? f st es = constrainEvents (arc st) $ shiftValues $ sort $ defragParts es shiftValues es | i >= 0 = zipWith (\e s -> e {value = s}) es (drop i $ cycle $ map value es) | otherwise = zipWith (\e s -> e{value = s}) es (drop (length es - abs i) $ cycle $ map value es) wholeCycle (Arc s _) = Arc (sam s) (nextSam s) constrainEvents :: Arc -> [Event a] -> [Event a] constrainEvents a es = mapMaybe (constrainEvent a) es constrainEvent :: Arc -> Event a -> Maybe (Event a) constrainEvent a e = do p' <- subArc (part e) a return e {part = p'} -- | @segment n p@: 'samples' the pattern @p@ at a rate of @n@ -- events per cycle. Useful for turning a continuous pattern into a -- discrete one. segment :: Pattern Time -> Pattern a -> Pattern a segment = tParam _segment _segment :: Time -> Pattern a -> Pattern a _segment n p = _fast n (pure id) <* p -- | @discretise@: the old (deprecated) name for 'segment' discretise :: Pattern Time -> Pattern a -> Pattern a discretise = segment -- | @randcat ps@: does a @slowcat@ on the list of patterns @ps@ but -- randomises the order in which they are played. randcat :: [Pattern a] -> Pattern a randcat ps = spread' rotL (_segment 1 $ (%1) . fromIntegral <$> (irand (length ps) :: Pattern Int)) (slowcat ps) wrandcat :: [(Pattern a, Double)] -> Pattern a wrandcat ps = unwrap $ wchooseBy (segment 1 rand) ps -- @fromNote p@: converts a pattern of human-readable pitch names -- into pitch numbers. For example, @"cs2"@ will be parsed as C Sharp -- in the 2nd octave with the result of @11@, and @"b-3"@ as -- @-25@. Pitches can be decorated using: -- -- * s = Sharp, a half-step above (@"gs-1"@) -- * f = Flat, a half-step below (@"gf-1"@) -- * n = Natural, no decoration (@"g-1" and "gn-1"@ are equivalent) -- * ss = Double sharp, a whole step above (@"gss-1"@) -- * ff = Double flat, a whole step below (@"gff-1"@) -- -- Note that TidalCycles now assumes that middle C is represented by -- the value 0, rather than the previous value of 60. This function -- is similar to previously available functions @tom@ and @toMIDI@, -- but the default octave is now 0 rather than 5. {- definition moved to Parse.hs .. toMIDI :: Pattern String -> Pattern Int toMIDI p = fromJust <$> (filterValues (isJust) (noteLookup <$> p)) where noteLookup :: String -> Maybe Int noteLookup [] = Nothing noteLookup s | not (last s `elem` ['0' .. '9']) = noteLookup (s ++ "0") | not (isLetter (s !! 1)) = noteLookup((head s):'n':(tail s)) | otherwise = parse s parse x = (\a b c -> a+b+c) <$> pc x <*> sym x <*> Just(12*digitToInt (last x)) pc x = lookup (head x) [('c',0),('d',2),('e',4),('f',5),('g',7),('a',9),('b',11)] sym x = lookup (init (tail x)) [("s",1),("f",-1),("n",0),("ss",2),("ff",-2)] -} -- @tom p@: Alias for @toMIDI@. -- tom = toMIDI {- | The `fit` function takes a pattern of integer numbers, which are used to select values from the given list. What makes this a bit strange is that only a given number of values are selected each cycle. For example: @ d1 $ sound (fit 3 ["bd", "sn", "arpy", "arpy:1", "casio"] "0 [~ 1] 2 1") @ The above fits three samples into the pattern, i.e. for the first cycle this will be `"bd"`, `"sn"` and `"arpy"`, giving the result `"bd [~ sn] arpy sn"` (note that we start counting at zero, so that `0` picks the first value). The following cycle the *next* three values in the list will be picked, i.e. `"arpy:1"`, `"casio"` and `"bd"`, giving the pattern `"arpy:1 [~ casio] bd casio"` (note that the list wraps round here). -} fit :: Int -> [a] -> Pattern Int -> Pattern a fit perCycle xs p = (xs !!!) <$> (p {query = map (\e -> fmap (+ pos e) e) . query p}) where pos e = perCycle * floor (start $ part e) permstep :: RealFrac b => Int -> [a] -> Pattern b -> Pattern a permstep nSteps things p = unwrap $ (\n -> fastFromList $ concatMap (\x -> replicate (fst x) (snd x)) $ zip (ps !! floor (n * fromIntegral (length ps - 1))) things) <$> _segment 1 p where ps = permsort (length things) nSteps deviance avg xs = sum $ map (abs . (avg-) . fromIntegral) xs permsort n total = map fst $ sortOn snd $ map (\x -> (x,deviance (fromIntegral total / (fromIntegral n :: Double)) x)) $ perms n total perms 0 _ = [] perms 1 n = [[n]] perms n total = concatMap (\x -> map (x:) $ perms (n-1) (total-x)) [1 .. (total-(n-1))] -- | @struct a b@: structures pattern @b@ in terms of the pattern of -- boolean values @a@. Only @True@ values in the boolean pattern are -- used. struct :: Pattern Bool -> Pattern a -> Pattern a struct ps pv = filterJust $ (\a b -> if a then Just b else Nothing ) <$> ps <* pv -- | @substruct a b@: similar to @struct@, but each event in pattern @a@ gets replaced with pattern @b@, compressed to fit the timespan of the event. substruct :: Pattern String -> Pattern b -> Pattern b substruct s p = p {query = f} where f st = concatMap ((\a' -> queryArc (compressArcTo a' p) a') . fromJust . whole) $ filter isDigital $ (query s st) randArcs :: Int -> Pattern [Arc] randArcs n = do rs <- mapM (\x -> pure (toRational x / toRational n) <~ choose [1 :: Int,2,3]) [0 .. (n-1)] let rats = map toRational rs total = sum rats pairs = pairUp $ accumulate $ map (/total) rats return pairs where pairUp [] = [] pairUp xs = Arc 0 (head xs) : pairUp' xs pairUp' [] = [] pairUp' [_] = [] pairUp' [a, _] = [Arc a 1] pairUp' (a:b:xs) = Arc a b: pairUp' (b:xs) -- TODO - what does this do? Something for @stripe@ .. randStruct :: Int -> Pattern Int randStruct n = splitQueries $ Pattern {query = f} where f st = map (\(a,b,c) -> Event (Context []) (Just a) (fromJust b) c) $ filter (\(_,x,_) -> isJust x) as where as = map (\(i, Arc s' e') -> (Arc (s' + sam s) (e' + sam s), subArc (Arc s e) (Arc (s' + sam s) (e' + sam s)), i)) $ enumerate $ value $ head $ queryArc (randArcs n) (Arc (sam s) (nextSam s)) (Arc s e) = arc st -- TODO - what does this do? substruct' :: Pattern Int -> Pattern a -> Pattern a substruct' s p = p {query = \st -> concatMap (f st) (query s st)} where f st (Event c (Just a') _ i) = map (\e -> e {context = combineContexts [c, context e]}) $ queryArc (compressArcTo a' (inside (pure $ 1/toRational(length (queryArc s (Arc (sam (start $ arc st)) (nextSam (start $ arc st)))))) (rotR (toRational i)) p)) a' -- Ignore analog events (ones without wholes) f _ _ = [] -- | @stripe n p@: repeats pattern @p@, @n@ times per cycle. So -- similar to @fast@, but with random durations. The repetitions will -- be continguous (touching, but not overlapping) and the durations -- will add up to a single cycle. @n@ can be supplied as a pattern of -- integers. stripe :: Pattern Int -> Pattern a -> Pattern a stripe = tParam _stripe _stripe :: Int -> Pattern a -> Pattern a _stripe = substruct' . randStruct -- | @slowstripe n p@: The same as @stripe@, but the result is also -- @n@ times slower, so that the mean average duration of the stripes -- is exactly one cycle, and every @n@th stripe starts on a cycle -- boundary (in indian classical terms, the @sam@). slowstripe :: Pattern Int -> Pattern a -> Pattern a slowstripe n = slow (toRational <$> n) . stripe n -- Lindenmayer patterns, these go well with the step sequencer -- general rule parser (strings map to strings) parseLMRule :: String -> [(String,String)] parseLMRule s = map (splitOn ':') commaSplit where splitOn sep str = splitAt (fromJust $ elemIndex sep str) $ filter (/= sep) str commaSplit = map T.unpack $ T.splitOn (T.pack ",") $ T.pack s -- specific parser for step sequencer (chars map to string) -- ruleset in form "a:b,b:ab" parseLMRule' :: String -> [(Char, String)] parseLMRule' str = map fixer $ parseLMRule str where fixer (c,r) = (head c, r) {- | returns the `n`th iteration of a [Lindenmayer System](https://en.wikipedia.org/wiki/L-system) with given start sequence. for example: @ lindenmayer 1 "a:b,b:ab" "ab" -> "bab" @ -} lindenmayer :: Int -> String -> String -> String lindenmayer _ _ [] = [] lindenmayer 1 r (c:cs) = fromMaybe [c] (lookup c $ parseLMRule' r) ++ lindenmayer 1 r cs lindenmayer n r s = iterate (lindenmayer 1 r) s !! n {- | @lindenmayerI@ converts the resulting string into a a list of integers with @fromIntegral@ applied (so they can be used seamlessly where floats or rationals are required) -} lindenmayerI :: Num b => Int -> String -> String -> [b] lindenmayerI n r s = fmap (fromIntegral . digitToInt) $ lindenmayer n r s {- | @runMarkov n tmat xi seed@ generates a Markov chain (as a list) of length @n@ using the transition matrix @tmat@ starting from initial state @xi@, starting with random numbers generated from @seed@ Each entry in the chain is the index of state (starting from zero). Each row of the matrix will be automatically normalized. For example: @ runMarkov 8 [[2,3], [1,3]] 0 0 @ will produce a two-state chain 8 steps long, from initial state @0@, where the transition probability from state 0->0 is 2/5, 0->1 is 3/5, 1->0 is 1/4, and 1->1 is 3/4. -} runMarkov :: Int -> [[Double]] -> Int -> Time -> [Int] runMarkov n tp xi seed = reverse $ (iterate (markovStep $ renorm) [xi])!! (n-1) where markovStep tp' xs = (fromJust $ findIndex (r <=) $ scanl1 (+) (tp'!!(head xs))) : xs where r = timeToRand $ seed + (fromIntegral . length) xs / fromIntegral n renorm = [ map (/ sum x) x | x <- tp ] {- @markovPat n xi tp@ generates a one-cycle pattern of @n@ steps in a Markov chain starting from state @xi@ with transition matrix @tp@. Each row of the transition matrix is automatically normalized. For example: @ tidal> markovPat 8 1 [[3,5,2], [4,4,2], [0,1,0]] (0>⅛)|1 (⅛>¼)|2 (¼>⅜)|1 (⅜>½)|1 (½>⅝)|2 (⅝>¾)|1 (¾>⅞)|1 (⅞>1)|0 @ -} markovPat :: Pattern Int -> Pattern Int -> [[Double]] -> Pattern Int markovPat = tParam2 _markovPat _markovPat :: Int -> Int -> [[Double]] -> Pattern Int _markovPat n xi tp = splitQueries $ Pattern (\(State a@(Arc s _) _) -> queryArc (listToPat $ runMarkov n tp xi (sam s)) a) {-| Removes events from second pattern that don't start during an event from first. Consider this, kind of messy rhythm without any rests. @ d1 $ sound (slowcat ["sn*8", "[cp*4 bd*4, hc*5]"]) # n (run 8) @ If we apply a mask to it @ d1 $ s (mask ("1 1 1 ~ 1 1 ~ 1" :: Pattern Bool) (slowcat ["sn*8", "[cp*4 bd*4, bass*5]"] )) # n (run 8) @ Due to the use of `slowcat` here, the same mask is first applied to `"sn*8"` and in the next cycle to `"[cp*4 bd*4, hc*5]". You could achieve the same effect by adding rests within the `slowcat` patterns, but mask allows you to do this more easily. It kind of keeps the rhythmic structure and you can change the used samples independently, e.g. @ d1 $ s (mask ("1 ~ 1 ~ 1 1 ~ 1") (slowcat ["can*8", "[cp*4 sn*4, jvbass*16]"] )) # n (run 8) @ -} mask :: Pattern Bool -> Pattern a -> Pattern a mask b p = const <$> p <* (filterValues id b) {- mask :: Pattern Bool -> Pattern b -> Pattern b -- TODO - should that be part or whole? mask pa pb = pb {query = \st -> concat [filterOns (subArc (arc st) $ part i) (query pb st) | i <- query pa st]} where filterOns Nothing _ = [] filterOns (Just a) es = filter (onsetIn a) es -} -- | TODO: refactor towards union enclosingArc :: [Arc] -> Arc enclosingArc [] = Arc 0 1 enclosingArc as = Arc (minimum (map start as)) (maximum (map stop as)) stretch :: Pattern a -> Pattern a -- TODO - should that be whole or part? stretch p = splitQueries $ p {query = q} where q st = query (zoomArc (cycleArc $ enclosingArc $ map wholeOrPart $ query p (st {arc = Arc (sam s) (nextSam s)})) p) st where s = start $ arc st {- | `fit'` is a generalization of `fit`, where the list is instead constructed by using another integer pattern to slice up a given pattern. The first argument is the number of cycles of that latter pattern to use when slicing. It's easier to understand this with a few examples: @ d1 $ sound (fit' 1 2 "0 1" "1 0" "bd sn") @ So what does this do? The first `1` just tells it to slice up a single cycle of `"bd sn"`. The `2` tells it to select two values each cycle, just like the first argument to `fit`. The next pattern `"0 1"` is the "from" pattern which tells it how to slice, which in this case means `"0"` maps to `"bd"`, and `"1"` maps to `"sn"`. The next pattern `"1 0"` is the "to" pattern, which tells it how to rearrange those slices. So the final result is the pattern `"sn bd"`. A more useful example might be something like @ d1 $ fit' 1 4 (run 4) "[0 3*2 2 1 0 3*2 2 [1*8 ~]]/2" $ chop 4 $ (sound "breaks152" # unit "c") @ which uses `chop` to break a single sample into individual pieces, which `fit'` then puts into a list (using the `run 4` pattern) and reassembles according to the complicated integer pattern. -} fit' :: Pattern Time -> Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a fit' cyc n from to p = squeezeJoin $ fit n mapMasks to where mapMasks = [stretch $ mask (const True <$> filterValues (== i) from') p' | i <- [0..n-1]] p' = density cyc p from' = density cyc from {-| @chunk n f p@ treats the given pattern @p@ as having @n@ chunks, and applies the function @f@ to one of those sections per cycle, running from left to right. @ d1 $ chunk 4 (density 4) $ sound "cp sn arpy [mt lt]" @ -} chunk :: Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b chunk n f p = cat [withinArc (Arc (i % fromIntegral n) ((i+1) % fromIntegral n)) f p | i <- [0 .. fromIntegral n - 1]] {- chunk n f p = do i <- _slow (toRational n) $ run (fromIntegral n) within (i%(fromIntegral n),(i+)1%(fromIntegral n)) f p -} -- deprecated (renamed to chunk) runWith :: Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b runWith = chunk {-| @chunk'@ works much the same as `chunk`, but runs from right to left. -} chunk' :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b chunk' n f p = do i <- _slow (toRational n) $ rev $ run (fromIntegral n) withinArc (Arc (i % fromIntegral n) ((i+)1 % fromIntegral n)) f p -- deprecated (renamed to chunk') runWith' :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b runWith' = chunk' inside :: Pattern Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a inside n f p = density n $ f (slow n p) outside :: Pattern Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a outside n = inside (1/n) loopFirst :: Pattern a -> Pattern a loopFirst p = splitQueries $ p {query = f} where f st = map (\(Event c w p' v) -> Event c (plus <$> w) (plus p') v) $ query p (st {arc = minus $ arc st}) where minus = fmap (subtract (sam s)) plus = fmap (+ sam s) s = start $ arc st timeLoop :: Pattern Time -> Pattern a -> Pattern a timeLoop n = outside n loopFirst seqPLoop :: [(Time, Time, Pattern a)] -> Pattern a seqPLoop ps = timeLoop (pure $ maxT - minT) $ minT `rotL` seqP ps where minT = minimum $ map (\(x,_,_) -> x) ps maxT = maximum $ map (\(_,x,_) -> x) ps {- | @toScale@ lets you turn a pattern of notes within a scale (expressed as a list) to note numbers. For example `toScale [0, 4, 7] "0 1 2 3"` will turn into the pattern `"0 4 7 12"`. It assumes your scale fits within an octave; to change this use `toScale' size`. Example: `toScale' 24 [0,4,7,10,14,17] (run 8)` turns into `"0 4 7 10 14 17 24 28"` -} toScale' :: Num a => Int -> [a] -> Pattern Int -> Pattern a toScale' _ [] = const silence toScale' o s = fmap noteInScale where octave x = x `div` length s noteInScale x = (s !!! x) + fromIntegral (o * octave x) toScale :: Num a => [a] -> Pattern Int -> Pattern a toScale = toScale' 12 {- | `swingBy x n` divides a cycle into `n` slices and delays the notes in the second half of each slice by `x` fraction of a slice . @swing@ is an alias for `swingBy (1%3)` -} swingBy :: Pattern Time -> Pattern Time -> Pattern a -> Pattern a swingBy x n = inside n (withinArc (Arc 0.5 1) (x ~>)) swing :: Pattern Time -> Pattern a -> Pattern a swing = swingBy (pure $ 1%3) {- | `cycleChoose` is like `choose` but only picks a new item from the list once each cycle -} cycleChoose :: [a] -> Pattern a cycleChoose = segment 1 . choose {- | Internal function used by shuffle and scramble -} _rearrangeWith :: Pattern Int -> Int -> Pattern a -> Pattern a _rearrangeWith ipat n pat = innerJoin $ (\i -> _fast nT $ repeatCycles n $ pats !! i) <$> ipat where pats = map (\i -> zoom (fromIntegral i / nT, fromIntegral (i+1) / nT) pat) [0 .. (n-1)] nT :: Time nT = fromIntegral n {- | `shuffle n p` evenly divides one cycle of the pattern `p` into `n` parts, and returns a random permutation of the parts each cycle. For example, `shuffle 3 "a b c"` could return `"a b c"`, `"a c b"`, `"b a c"`, `"b c a"`, `"c a b"`, or `"c b a"`. But it will **never** return `"a a a"`, because that is not a permutation of the parts. -} shuffle :: Pattern Int -> Pattern a -> Pattern a shuffle = tParam _shuffle _shuffle :: Int -> Pattern a -> Pattern a _shuffle n = _rearrangeWith (randrun n) n {- | `scramble n p` is like `shuffle` but randomly selects from the parts of `p` instead of making permutations. For example, `scramble 3 "a b c"` will randomly select 3 parts from `"a"` `"b"` and `"c"`, possibly repeating a single part. -} scramble :: Pattern Int -> Pattern a -> Pattern a scramble = tParam _scramble _scramble :: Int -> Pattern a -> Pattern a _scramble n = _rearrangeWith (_segment (fromIntegral n) $ irand n) n randrun :: Int -> Pattern Int randrun 0 = silence randrun n' = splitQueries $ Pattern (\(State a@(Arc s _) _) -> events a $ sam s) where events a seed = mapMaybe toEv $ zip arcs shuffled where shuffled = map snd $ sortOn fst $ zip rs [0 .. (n'-1)] rs = timeToRands seed n' :: [Double] arcs = zipWith Arc fractions (tail fractions) fractions = map (+ (sam $ start a)) [0, 1 / fromIntegral n' .. 1] toEv (a',v) = do a'' <- subArc a a' return $ Event (Context []) (Just a') a'' v ur :: Time -> Pattern String -> [(String, Pattern a)] -> [(String, Pattern a -> Pattern a)] -> Pattern a ur t outer_p ps fs = _slow t $ unwrap $ adjust <$> timedValues (getPat . split <$> outer_p) where split = wordsBy (==':') getPat (s:xs) = (match s, transform xs) -- TODO - check this really can't happen.. getPat _ = error "can't happen?" match s = fromMaybe silence $ lookup s ps' ps' = map (fmap (_fast t)) ps adjust (a, (p, f)) = f a p transform (x:_) a = transform' x a transform _ _ = id transform' str (Arc s e) p = s `rotR` inside (pure $ 1/(e-s)) (matchF str) p matchF str = fromMaybe id $ lookup str fs timedValues = withEvent (\(Event c (Just a) a' v) -> Event c (Just a) a' (a,v)) . filterDigital inhabit :: [(String, Pattern a)] -> Pattern String -> Pattern a inhabit ps p = squeezeJoin $ (\s -> fromMaybe silence $ lookup s ps) <$> p {- | @spaceOut xs p@ repeats a pattern @p@ at different durations given by the list of time values in @xs@ -} spaceOut :: [Time] -> Pattern a -> Pattern a spaceOut xs p = _slow (toRational $ sum xs) $ stack $ map (`compressArc` p) spaceArcs where markOut :: Time -> [Time] -> [Arc] markOut _ [] = [] markOut offset (x:xs') = Arc offset (offset+x):markOut (offset+x) xs' spaceArcs = map (\(Arc a b) -> Arc (a/s) (b/s)) $ markOut 0 xs s = sum xs -- | @flatpat@ takes a Pattern of lists and pulls the list elements as -- separate Events flatpat :: Pattern [a] -> Pattern a flatpat p = p {query = concatMap (\(Event c b b' xs) -> map (Event c b b') xs) . query p} -- | @layer@ takes a Pattern of lists and pulls the list elements as -- separate Events layer :: [a -> Pattern b] -> a -> Pattern b layer fs p = stack $ map ($ p) fs -- | @arpeggiate@ finds events that share the same timespan, and spreads -- them out during that timespan, so for example @arpeggiate "[bd,sn]"@ -- gets turned into @"bd sn"@. Useful for creating arpeggios/broken chords. arpeggiate :: Pattern a -> Pattern a arpeggiate = arpWith id -- | Shorthand alias for arpeggiate arpg :: Pattern a -> Pattern a arpg = arpeggiate arpWith :: ([EventF (ArcF Time) a] -> [EventF (ArcF Time) b]) -> Pattern a -> Pattern b arpWith f p = withEvents munge p where munge es = concatMap (spreadOut . f) (groupBy (\a b -> whole a == whole b) $ sortOn whole es) spreadOut xs = mapMaybe (\(n, x) -> shiftIt n (length xs) x) $ enumerate xs shiftIt n d (Event c (Just (Arc s e)) a' v) = do a'' <- subArc (Arc newS newE) a' return (Event c (Just $ Arc newS newE) a'' v) where newS = s + (dur * fromIntegral n) newE = newS + dur dur = (e - s) / fromIntegral d -- TODO ignoring analog events.. Should we just leave them as-is? shiftIt _ _ _ = Nothing arp :: Pattern String -> Pattern a -> Pattern a arp = tParam _arp _arp :: String -> Pattern a -> Pattern a _arp name p = arpWith f p where f = fromMaybe id $ lookup name arps arps :: [(String, [a] -> [a])] arps = [("up", id), ("down", reverse), ("updown", \x -> init x ++ init (reverse x)), ("downup", \x -> init (reverse x) ++ init x), ("up&down", \x -> x ++ reverse x), ("down&up", \x -> reverse x ++ x), ("converge", converge), ("diverge", reverse . converge), ("disconverge", \x -> converge x ++ tail (reverse $ converge x)), ("pinkyup", pinkyup), ("pinkyupdown", \x -> init (pinkyup x) ++ init (reverse $ pinkyup x)), ("thumbup", thumbup), ("thumbupdown", \x -> init (thumbup x) ++ init (reverse $ thumbup x)) ] converge [] = [] converge (x:xs) = x : converge' xs converge' [] = [] converge' xs = last xs : converge (init xs) pinkyup xs = concatMap (:[pinky]) $ init xs where pinky = last xs thumbup xs = concatMap (\x -> [thumb,x]) $ tail xs where thumb = head xs {- TODO ! -- | @fill@ 'fills in' gaps in one pattern with events from another. For example @fill "bd" "cp ~ cp"@ would result in the equivalent of `"~ bd ~"`. This only finds gaps in a resulting pattern, in other words @"[bd ~, sn]"@ doesn't contain any gaps (because @sn@ covers it all), and @"bd ~ ~ sn"@ only contains a single gap that bridges two steps. fill :: Pattern a -> Pattern a -> Pattern a fill p' p = struct (splitQueries $ p {query = q}) p' where q st = removeTolerance (s,e) $ invert (s-tolerance, e+tolerance) $ query p (st {arc = (s-tolerance, e+tolerance)}) where (s,e) = arc st invert (s,e) es = map arcToEvent $ foldr remove [(s,e)] (map part es) remove (s,e) xs = concatMap (remove' (s, e)) xs remove' (s,e) (s',e') | s > s' && e < e' = [(s',s),(e,e')] -- inside | s > s' && s < e' = [(s',s)] -- cut off right | e > s' && e < e' = [(e,e')] -- cut off left | s <= s' && e >= e' = [] -- swallow | otherwise = [(s',e')] -- miss arcToEvent a = ((a,a),"x") removeTolerance (s,e) es = concatMap (expand) $ map (withPart f) es where f a = concatMap (remove' (e,e+tolerance)) $ remove' (s-tolerance,s) a expand ((a,xs),c) = map (\x -> ((a,x),c)) xs tolerance = 0.01 -} -- Repeats each event @n@ times within its arc ply :: Pattern Int -> Pattern a -> Pattern a ply = tParam _ply _ply :: Int -> Pattern a -> Pattern a _ply n p = arpeggiate $ stack (replicate n p) -- Like ply, but applies a function each time. The applications are compounded. plyWith :: (Ord t, Num t) => Pattern t -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a plyWith np f p = innerJoin $ (\n -> _plyWith n f p) <$> np _plyWith :: (Ord t, Num t) => t -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a _plyWith numPat f p = arpeggiate $ compound numPat where compound n | n <= 1 = p | otherwise = overlay p (f $ compound $ n-1) -- | Uses the first (binary) pattern to switch between the following -- two patterns. The resulting structure comes from the source patterns, not the -- binary pattern. See also @stitch@. sew :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a sew pb a b = overlay (mask pb a) (mask (inv pb) b) -- | Uses the first (binary) pattern to switch between the following -- two patterns. The resulting structure comes from the binary -- pattern, not the source patterns. See also @sew@. stitch :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a stitch pb a b = overlay (struct pb a) (struct (inv pb) b) -- | A binary pattern is used to conditionally apply a function to a -- source pattern. The function is applied when a @True@ value is -- active, and the pattern is let through unchanged when a @False@ -- value is active. No events are let through where no binary values -- are active. while :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a while b f pat = sew b (f pat) pat stutter :: Integral i => i -> Time -> Pattern a -> Pattern a stutter n t p = stack $ map (\i -> (t * fromIntegral i) `rotR` p) [0 .. (n-1)] echo, triple, quad, double :: Time -> Pattern a -> Pattern a echo = stutter (2 :: Int) triple = stutter (3 :: Int) quad = stutter (4 :: Int) double = echo {- | The `jux` function creates strange stereo effects, by applying a function to a pattern, but only in the right-hand channel. For example, the following reverses the pattern on the righthand side: @ d1 $ slow 32 $ jux (rev) $ striateBy 32 (1/16) $ sound "bev" @ When passing pattern transforms to functions like [jux](#jux) and [every](#every), it's possible to chain multiple transforms together with `.`, for example this both reverses and halves the playback speed of the pattern in the righthand channel: @ d1 $ slow 32 $ jux ((# speed "0.5") . rev) $ striateBy 32 (1/16) $ sound "bev" @ -} jux :: (Pattern ControlMap -> Pattern ControlMap) -> Pattern ControlMap -> Pattern ControlMap jux = juxBy 1 juxcut :: (Pattern ControlMap -> Pattern ControlMap) -> Pattern ControlMap -> Pattern ControlMap juxcut f p = stack [p # P.pan (pure 0) # P.cut (pure (-1)), f $ p # P.pan (pure 1) # P.cut (pure (-2)) ] juxcut' :: [t -> Pattern ControlMap] -> t -> Pattern ControlMap juxcut' fs p = stack $ map (\n -> ((fs !! n) p |+ P.cut (pure $ 1-n)) # P.pan (pure $ fromIntegral n / fromIntegral l)) [0 .. l-1] where l = length fs {- | In addition to `jux`, `jux'` allows using a list of pattern transform. resulting patterns from each transformation will be spread via pan from left to right. For example: @ d1 $ jux' [iter 4, chop 16, id, rev, palindrome] $ sound "bd sn" @ will put `iter 4` of the pattern to the far left and `palindrome` to the far right. In the center the original pattern will play and mid left mid right the chopped and the reversed version will appear. One could also write: @ d1 $ stack [ iter 4 $ sound "bd sn" # pan "0", chop 16 $ sound "bd sn" # pan "0.25", sound "bd sn" # pan "0.5", rev $ sound "bd sn" # pan "0.75", palindrome $ sound "bd sn" # pan "1", ] @ -} jux' :: [t -> Pattern ControlMap] -> t -> Pattern ControlMap jux' fs p = stack $ map (\n -> (fs !! n) p |+ P.pan (pure $ fromIntegral n / fromIntegral l)) [0 .. l-1] where l = length fs -- | Multichannel variant of `jux`, _not sure what it does_ jux4 :: (Pattern ControlMap -> Pattern ControlMap) -> Pattern ControlMap -> Pattern ControlMap jux4 f p = stack [p # P.pan (pure (5/8)), f $ p # P.pan (pure (1/8))] {- | With `jux`, the original and effected versions of the pattern are panned hard left and right (i.e., panned at 0 and 1). This can be a bit much, especially when listening on headphones. The variant `juxBy` has an additional parameter, which brings the channel closer to the centre. For example: @ d1 $ juxBy 0.5 (density 2) $ sound "bd sn:1" @ In the above, the two versions of the pattern would be panned at 0.25 and 0.75, rather than 0 and 1. -} juxBy :: Pattern Double -> (Pattern ControlMap -> Pattern ControlMap) -> Pattern ControlMap -> Pattern ControlMap juxBy n f p = stack [p |+ P.pan 0.5 |- P.pan (n/2), f $ p |+ P.pan 0.5 |+ P.pan (n/2)] pick :: String -> Int -> String pick name n = name ++ ":" ++ show n -- samples "jvbass [~ latibro] [jvbass [latibro jvbass]]" ((1%2) `rotL` slow 6 "[1 6 8 7 3]") samples :: Applicative f => f String -> f Int -> f String samples p p' = pick <$> p <*> p' samples' :: Applicative f => f String -> f Int -> f String samples' p p' = flip pick <$> p' <*> p {- scrumple :: Time -> Pattern a -> Pattern a -> Pattern a scrumple o p p' = p'' -- overlay p (o `rotR` p'') where p'' = Pattern $ \a -> concatMap (\((s,d), vs) -> map (\x -> ((s,d), snd x ) ) (arc p' (s,s)) ) (arc p a) -} spreadf :: [a -> Pattern b] -> a -> Pattern b spreadf = spread ($) stackwith :: Unionable a => Pattern a -> [Pattern a] -> Pattern a stackwith p ps | null ps = silence | otherwise = stack $ map (\(i, p') -> p' # ((fromIntegral i % l) `rotL` p)) (zip [0::Int ..] ps) where l = fromIntegral $ length ps {- cross f p p' = Pattern $ \t -> concat [filter flt $ arc p t, filter (not . flt) $ arc p' t ] ] where flt = f . cyclePos . fst . fst -} {- | `range` will take a pattern which goes from 0 to 1 (like `sine`), and range it to a different range - between the first and second arguments. In the below example, `range 1 1.5` shifts the range of `sine1` from 0 - 1 to 1 - 1.5. @ d1 $ jux (iter 4) $ sound "arpy arpy:2*2" |+ speed (slow 4 $ range 1 1.5 sine1) @ -} range :: Num a => Pattern a -> Pattern a -> Pattern a -> Pattern a range fromP toP p = (\from to v -> ((v * (to-from)) + from)) <$> fromP *> toP *> p _range :: (Functor f, Num b) => b -> b -> f b -> f b _range from to p = (+ from) . (* (to-from)) <$> p {- | `rangex` is an exponential version of `range`, good for using with frequencies. Do *not* use negative numbers or zero as arguments! -} rangex :: (Functor f, Floating b) => b -> b -> f b -> f b rangex from to p = exp <$> _range (log from) (log to) p off :: Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a off tp f p = innerJoin $ (\tv -> _off tv f p) <$> tp _off :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a _off t f p = superimpose (f . (t `rotR`)) p offadd :: Num a => Pattern Time -> Pattern a -> Pattern a -> Pattern a offadd tp pn p = off tp (+pn) p -- | Step sequencing step :: String -> String -> Pattern String step s cs = fastcat $ map f cs where f c | c == 'x' = pure s | isDigit c = pure $ s ++ ":" ++ [c] | otherwise = silence steps :: [(String, String)] -> Pattern String steps = stack . map (uncurry step) -- | like `step`, but allows you to specify an array of strings to use for 0,1,2... step' :: [String] -> String -> Pattern String step' ss cs = fastcat $ map f cs where f c | c == 'x' = pure $ head ss | isDigit c = pure $ ss !! digitToInt c | otherwise = silence ghost'' :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a ghost'' a f p = superimpose (((a*2.5) `rotR`) . f) $ superimpose (((a*1.5) `rotR`) . f) p ghost' :: Time -> Pattern ControlMap -> Pattern ControlMap ghost' a p = ghost'' a ((|*| P.gain (pure 0.7)) . (|> P.end (pure 0.2)) . (|*| P.speed (pure 1.25))) p ghost :: Pattern ControlMap -> Pattern ControlMap ghost = ghost' 0.125 {- | tabby - A more literal weaving than the `weave` function, give number of 'threads' per cycle and two patterns, and this function will weave them together using a plain (aka 'tabby') weave, with a simple over/under structure -} tabby :: Int -> Pattern a -> Pattern a -> Pattern a tabby nInt p p' = stack [maskedWarp, maskedWeft ] where n = fromIntegral nInt weft = concatMap (const [[0..n-1], reverse [0..n-1]]) [0 .. (n `div` 2) - 1] warp = transpose weft thread xs p'' = _slow (n%1) $ fastcat $ map (\i -> zoomArc (Arc (i%n) ((i+1)%n)) p'') (concat xs) weftP = thread weft p' warpP = thread warp p maskedWeft = mask (every 2 rev $ _fast (n % 2) $ fastCat [silence, pure True]) weftP maskedWarp = mask (every 2 rev $ _fast (n % 2) $ fastCat [pure True, silence]) warpP -- | chooses between a list of patterns, using a pattern of floats (from 0-1) select :: Pattern Double -> [Pattern a] -> Pattern a select = tParam _select _select :: Double -> [Pattern a] -> Pattern a _select f ps = ps !! floor (max 0 (min 1 f) * fromIntegral (length ps - 1)) -- | chooses between a list of functions, using a pattern of floats (from 0-1) selectF :: Pattern Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a selectF pf ps p = innerJoin $ (\f -> _selectF f ps p) <$> pf _selectF :: Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a _selectF f ps p = (ps !! floor (max 0 (min 0.999999 f) * fromIntegral (length ps))) p -- | chooses between a list of functions, using a pattern of integers pickF :: Pattern Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a pickF pInt fs pat = innerJoin $ (\i -> _pickF i fs pat) <$> pInt _pickF :: Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a _pickF i fs p = (fs !!! i) p -- | @contrast p f f' p'@ splits controlpattern @p'@ in two, applying -- the function @f@ to one and @f'@ to the other. This depends on -- whether events in it contains values matching with those in @p@. -- For example in @contrast (n "1") (# crush 3) (# vowel "a") $ n "0 1" # s "bd sn" # speed 3@, -- the first event will have the vowel effect applied and the second -- will have the crush applied. contrast :: (ControlPattern -> ControlPattern) -> (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern contrast = contrastBy (==) contrastBy :: (a -> Value -> Bool) -> (ControlPattern -> Pattern b) -> (ControlPattern -> Pattern b) -> Pattern (Map.Map String a) -> Pattern (Map.Map String Value) -> Pattern b contrastBy comp f f' p p' = overlay (f matched) (f' unmatched) where matches = matchManyToOne (flip $ Map.isSubmapOfBy comp) p p' matched :: ControlPattern matched = filterJust $ (\(t, a) -> if t then Just a else Nothing) <$> matches unmatched :: ControlPattern unmatched = filterJust $ (\(t, a) -> if not t then Just a else Nothing) <$> matches contrastRange :: (ControlPattern -> Pattern a) -> (ControlPattern -> Pattern a) -> Pattern (Map.Map String (Value, Value)) -> ControlPattern -> Pattern a contrastRange = contrastBy f where f (VI s, VI e) (VI v) = v >= s && v <= e f (VF s, VF e) (VF v) = v >= s && v <= e f (VS s, VS e) (VS v) = v == s && v == e f _ _ = False -- | Like @contrast@, but one function is given, and applied to events with matching controls. fix :: (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern fix f = contrast f id -- | Like @contrast@, but one function is given, and applied to events -- with controls which don't match. unfix :: (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern unfix = contrast id fixRange :: (ControlPattern -> Pattern ControlMap) -> Pattern (Map.Map String (Value, Value)) -> ControlPattern -> Pattern ControlMap fixRange f = contrastRange f id unfixRange :: (ControlPattern -> Pattern ControlMap) -> Pattern (Map.Map String (Value, Value)) -> ControlPattern -> Pattern ControlMap unfixRange = contrastRange id -- | limit values in a Pattern (or other Functor) to n equally spaced -- divisions of 1. quantise :: (Functor f, RealFrac b) => b -> f b -> f b quantise n = fmap ((/n) . (fromIntegral :: RealFrac b => Int -> b) . floor . (*n)) -- | Inverts all the values in a boolean pattern inv :: Functor f => f Bool -> f Bool inv = (not <$>) -- | Serialises a pattern so there's only one event playing at any one -- time, making it 'monophonic'. Events which start/end earlier are given priority. mono :: Pattern a -> Pattern a mono p = Pattern $ \(State a cm) -> flatten $ query p (State a cm) where flatten :: [Event a] -> [Event a] flatten = mapMaybe constrainPart . truncateOverlaps . sortOn whole truncateOverlaps [] = [] truncateOverlaps (e:es) = e : truncateOverlaps (mapMaybe (snip e) es) -- TODO - decide what to do about analog events.. snip a b | start (wholeOrPart b) >= stop (wholeOrPart a) = Just b | stop (wholeOrPart b) <= stop (wholeOrPart a) = Nothing | otherwise = Just b {whole = Just $ Arc (stop $ wholeOrPart a) (stop $ wholeOrPart b)} constrainPart :: Event a -> Maybe (Event a) constrainPart e = do a <- subArc (wholeOrPart e) (part e) return $ e {part = a} -- serialize the given pattern -- find the middle of the query's arc and use that to query the serialized pattern. We should get either no events or a single event back -- if we don't get any events, return nothing -- if we get an event, get the stop of its arc, and use that to query the serialized pattern, to see if there's an adjoining event -- if there isn't, return the event as-is. -- if there is, check where we are in the 'whole' of the event, and use that to tween between the values of the event and the next event -- smooth :: Pattern Double -> Pattern Double -- TODO - test this with analog events smooth :: Fractional a => Pattern a -> Pattern a smooth p = Pattern $ \st@(State a cm) -> tween st a $ query monoP (State (midArc a) cm) where midArc a = Arc (mid (start a, stop a)) (mid (start a, stop a)) tween _ _ [] = [] tween st queryA (e:_) = maybe [e {whole = Just queryA, part = queryA}] (tween' queryA) (nextV st) where aStop = Arc (wholeStop e) (wholeStop e) nextEs st' = query monoP (st' {arc = aStop}) nextV st' | null (nextEs st') = Nothing | otherwise = Just $ value (head (nextEs st')) tween' queryA' v = [ Event { context = context e, whole = Just queryA' , part = queryA' , value = value e + ((v - value e) * pc)} ] pc | delta' (wholeOrPart e) == 0 = 0 | otherwise = fromRational $ (eventPartStart e - wholeStart e) / delta' (wholeOrPart e) delta' a = stop a - start a monoP = mono p -- | Looks up values from a list of tuples, in order to swap values in the given pattern swap :: Eq a => [(a, b)] -> Pattern a -> Pattern b swap things p = filterJust $ (`lookup` things) <$> p {- snowball | snowball takes a function that can combine patterns (like '+'), a function that transforms a pattern (like 'slow'), a depth, and a starting pattern, it will then transform the pattern and combine it with the last transformation until the depth is reached this is like putting an effect (like a filter) in the feedback of a delay line each echo is more effected d1 $ note (scale "hexDorian" $ snowball (+) (slow 2 . rev) 8 "0 ~ . -1 . 5 3 4 . ~ -2") # s "gtr" -} snowball :: Int -> (Pattern a -> Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a snowball depth combinationFunction f pattern = cat $ take depth $ scanl combinationFunction pattern $ iterate f pattern {- @soak@ | applies a function to a pattern and cats the resulting pattern, then continues applying the function until the depth is reached this can be used to create a pattern that wanders away from the original pattern by continually adding random numbers d1 $ note (scale "hexDorian" mutateBy (+ (range -1 1 $ irand 2)) 8 $ "0 1 . 2 3 4") # s "gtr" -} soak :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a soak depth f pattern = cat $ take depth $ iterate f pattern deconstruct :: Int -> Pattern String -> String deconstruct n p = intercalate " " $ map showStep $ toList p where showStep :: [String] -> String showStep [] = "~" showStep [x] = x showStep xs = "[" ++ (intercalate ", " xs) ++ "]" toList :: Pattern a -> [[a]] toList pat = map (\(s,e) -> map value $ queryArc (_segment n' pat) (Arc s e)) arcs where breaks = [0, (1/n') ..] arcs = zip (take n breaks) (drop 1 breaks) n' = fromIntegral n {- @bite@ n ipat pat | slices a pattern `pat` into `n` pieces, then uses the `ipat` pattern of integers to index into those slices. So `bite 4 "0 2*2" (run 8)` is the same as `"[0 1] [4 5]*2"`. -} bite :: Int -> Pattern Int -> Pattern a -> Pattern a bite n ipat pat = squeezeJoin $ zoompat <$> ipat where zoompat i = zoom (i'/(fromIntegral n), (i'+1)/(fromIntegral n)) pat where i' = fromIntegral $ i `mod` n {- @squeeze@ ipat pats | uses a pattern of integers to index into a list of patterns. -} squeeze :: Pattern Int -> [Pattern a] -> Pattern a squeeze _ [] = silence squeeze ipat pats = squeezeJoin $ (pats !!!) <$> ipat squeezeJoinUp :: Pattern (ControlPattern) -> ControlPattern squeezeJoinUp pp = pp {query = q} where q st = concatMap (f st) (query (filterDigital pp) st) f st (Event c (Just w) p v) = mapMaybe (munge c w p) $ query (compressArc (cycleArc w) (v |* P.speed (pure $ fromRational $ 1/(stop w - start w)))) st {arc = p} -- already ignoring analog events, but for completeness.. f _ _ = [] munge co oWhole oPart (Event ci (Just iWhole) iPart v) = do w' <- subArc oWhole iWhole p' <- subArc oPart iPart return (Event (combineContexts [ci,co]) (Just w') p' v) munge _ _ _ _ = Nothing _chew :: Int -> Pattern Int -> ControlPattern -> ControlPattern _chew n ipat pat = (squeezeJoinUp $ zoompat <$> ipat) |/ P.speed (pure $ fromIntegral n) where zoompat i = zoom (i'/(fromIntegral n), (i'+1)/(fromIntegral n)) (pat) where i' = fromIntegral $ i `mod` n -- TODO maybe _chew could pattern the first parameter directly.. chew :: Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern chew npat ipat pat = innerJoin $ (\n -> _chew n ipat pat) <$> npat __binary :: Data.Bits.Bits b => Int -> b -> [Bool] __binary n num = map (testBit num) $ reverse [0 .. n-1] _binary :: Data.Bits.Bits b => Int -> b -> Pattern Bool _binary n num = listToPat $ __binary n num binaryN :: Int -> Pattern Int -> Pattern Bool binaryN n p = squeezeJoin $ _binary n <$> p binary :: Pattern Int -> Pattern Bool binary = binaryN 8 ascii :: Pattern String -> Pattern Bool ascii p = squeezeJoin $ (listToPat . concatMap (__binary 8 . ord)) <$> p tidal-1.5.2/src/Sound/Tidal/Utils.hs0000644000000000000000000000562507346545000015365 0ustar0000000000000000module Sound.Tidal.Utils where import Data.List (delete) import System.IO (hPutStrLn, stderr) writeError :: String -> IO () writeError = hPutStrLn stderr mapBoth :: (a -> a) -> (a,a) -> (a,a) mapBoth f (a,b) = (f a, f b) mapPartTimes :: (a -> a) -> ((a,a),(a,a)) -> ((a,a),(a,a)) mapPartTimes f = mapBoth (mapBoth f) mapFst :: (a -> b) -> (a, c) -> (b, c) mapFst f (x,y) = (f x,y) mapSnd :: (a -> b) -> (c, a) -> (c, b) mapSnd f (x,y) = (x,f y) delta :: Num a => (a, a) -> a delta (a,b) = b-a -- | The midpoint of two values mid :: Fractional a => (a,a) -> a mid (a,b) = a + ((b - a) / 2) removeCommon :: Eq a => [a] -> [a] -> ([a],[a]) removeCommon [] bs = ([],bs) removeCommon as [] = (as,[]) removeCommon (a:as) bs | a `elem` bs = removeCommon as (delete a bs) | otherwise = (a:as',bs') where (as',bs') = removeCommon as bs readMaybe :: (Read a) => String -> Maybe a readMaybe s = case [x | (x,t) <- reads s, ("","") <- lex t] of [x] -> Just x _ -> Nothing {- | like `!!` selects @n@th element from xs, but wraps over at the end of @xs@ >>> map ((!!!) [1,3,5]) [0,1,2,3,4,5] [1,3,5,1,3,5] -} (!!!) :: [a] -> Int -> a (!!!) xs n = xs !! (n `mod` length xs) {- | Safer version of !! --} nth :: Int -> [a] -> Maybe a nth _ [] = Nothing nth 0 (x : _) = Just x nth n (_ : xs) = nth (n - 1) xs accumulate :: Num t => [t] -> [t] accumulate [] = [] accumulate (x:xs) = scanl (+) x xs {- | enumerate a list of things >>> enumerate ["foo","bar","baz"] [(1,"foo"), (2,"bar"), (3,"baz")] -} enumerate :: [a] -> [(Int, a)] enumerate = zip [0..] {- | split given list of @a@ by given single a, e.g. >>> wordsBy (== ':') "bd:3" ["bd", "3"] -} wordsBy :: (a -> Bool) -> [a] -> [[a]] wordsBy p s = case dropWhile p s of [] -> [] s':rest -> (s':w) : wordsBy p (drop 1 s'') where (w, s'') = break p rest -- A hack to add to the source code context for mini-notation, so -- events know where they are within a whole tidal pattern deltaMini :: String -> String deltaMini = outside 0 0 where outside :: Int -> Int -> String -> String outside _ _ [] = [] outside column line ('"':xs) = ("(deltaContext " ++ show column ++ " " ++ show line ++ " \"" ++ inside (column+1) line xs ) outside _ line ('\n':xs) = '\n':(outside 0 (line+1) xs) outside column line (x:xs) = x:(outside (column+1) line xs) inside :: Int -> Int -> String -> String inside _ _ [] = [] inside column line ('"':xs) = '"':')':(outside (column+1) line xs) inside _ line ('\n':xs) = '\n':(inside 0 (line+1) xs) inside column line (x:xs) = x:(inside (column+1) line xs) tidal-1.5.2/src/Sound/Tidal/Version.hs0000644000000000000000000000012207346545000015675 0ustar0000000000000000module Sound.Tidal.Version where tidal_version :: String tidal_version = "1.5.2" tidal-1.5.2/test/Sound/Tidal/0000755000000000000000000000000007346545000014111 5ustar0000000000000000tidal-1.5.2/test/Sound/Tidal/ControlTest.hs0000644000000000000000000000136507346545000016732 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.ControlTest where import TestUtils import Test.Microspec import Prelude hiding ((<*), (*>)) import Sound.Tidal.Control import Sound.Tidal.Core import Sound.Tidal.Params import Sound.Tidal.Pattern run :: Microspec () run = describe "Sound.Tidal.Control" $ do describe "stutWith" $ do it "can mimic stut" $ do comparePD (Arc 0 1) (filterOnsets $ stutWith 4 0.25 (# gain 1) $ sound "bd") (filterOnsets $ stut 4 1 0.25 $ sound "bd") describe "splice" $ do it "can beatslice" $ do comparePD (Arc 0 1) (splice "4 8" "0 1" $ sound "bev") (begin "0 0.125" # end "0.25 0.25" # speed "0.5 0.25" # sound "bev" # unit "c") tidal-1.5.2/test/Sound/Tidal/CoreTest.hs0000644000000000000000000001353707346545000016206 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.CoreTest where import TestUtils import Test.Microspec import Prelude hiding ((<*), (*>)) import Data.Ratio import Data.List (sort) import Sound.Tidal.Context run :: Microspec () run = describe "Sound.Tidal.Core" $ do describe "append" $ do it "can switch between the cycles from two pures" $ do (queryArc (append (pure "a") (pure "b")) (Arc 0 5)) `shouldBe` fmap toEvent [(((0,1), (0,1)), "a" :: String), (((1,2), (1,2)), "b"), (((2,3), (2,3)), "a"), (((3,4), (3,4)), "b"), (((4,5), (4,5)), "a") ] describe "cat" $ do it "can switch between the cycles from three pures" $ do queryArc (cat [pure "a", pure "b", pure "c"]) (Arc 0 5) `shouldBe` fmap toEvent [(((0,1), (0,1)), "a" :: String), (((1,2), (1,2)), "b"), (((2,3), (2,3)), "c"), (((3,4), (3,4)), "a"), (((4,5), (4,5)), "b") ] describe "fastCat" $ do it "can switch between the cycles from three pures inside one cycle" $ do it "1" $ queryArc (fastCat [pure "a", pure "b", pure "c"]) (Arc 0 1) `shouldBe` fmap toEvent [(((0,1/3), (0,1/3)), "a" :: String), (((1/3,2/3), (1/3,2/3)), "b"), (((2/3,1), (2/3,1)), "c") ] it "5/3" $ queryArc (fastCat [pure "a", pure "b", pure "c"]) (Arc 0 (5/3)) `shouldBe` fmap toEvent [(((0,1/3), (0,1/3)), "a" :: String), (((1/3,2/3), (1/3,2/3)), "b"), (((2/3,1), (2/3,1)), "c"), (((1,4/3), (1,4/3)), "a"), (((4/3,5/3), (4/3,5/3)), "b") ] it "works with zero-length queries" $ do it "0" $ queryArc (fastCat [pure "a", pure "b"]) (Arc 0 0) `shouldBe` fmap toEvent [(((0,0.5), (0,0)), "a" :: String)] it "1/3" $ queryArc (fastCat [pure "a", pure "b"]) (Arc (1%3) (1%3)) `shouldBe` fmap toEvent [(((0,0.5), (1%3,1%3)), "a" :: String)] describe "rev" $ do it "mirrors events" $ do let forward = fastCat [fastCat [pure 7, pure 8], pure 9] :: Pattern Int backward = fastCat [pure 9, fastCat [pure 8, pure 7]] -- sort the events into time order to compare them (sort $ queryArc (rev forward) (Arc 0 1)) `shouldBe` (sort $ queryArc (backward) (Arc 0 1)) it "returns the original if you reverse it twice" $ do let x = fastCat [fastCat [pure 7, pure 8], pure 9] :: Pattern Int (queryArc (rev $ rev x) (Arc 0 5)) `shouldBe` (queryArc x (Arc 0 5)) describe "compress" $ do it "squashes cycles to the start of a cycle" $ do let p = compress (0, 0.5) $ fastCat [pure 7, pure 8] :: Pattern Int (queryArc p (Arc 0 1)) `shouldBe` fmap toEvent [ (((0,0.25), (0,0.25)), 7), (((0.25,0.5),(0.25,0.5)), 8) ] it "squashes cycles to the end of a cycle" $ do let p = compress (0.5, 1) $ fastCat [pure 7, pure 8] :: Pattern Int (queryArc p (Arc 0 1)) `shouldBe` fmap toEvent [(((0.5,0.75), (0.5,0.75)), 7 :: Int), (((0.75,1), (0.75,1)), 8) ] it "squashes cycles to the middle of a cycle" $ do let p = compress (0.25, 0.75) $ fastCat [pure 7, pure 8] (queryArc p (Arc 0 1)) `shouldBe` fmap toEvent [(((0.25,0.5), (0.25,0.5)), 7 :: Int), (((0.5,0.75), (0.5,0.75)), 8) ] describe "saw" $ do it "goes from 0 up to 1 every cycle" $ do it "0" $ (queryArc saw (Arc 0 0)) `shouldBe` [(Event (Context []) Nothing (Arc 0 0) 0 :: Event Double)] it "0.25" $ (queryArc saw (Arc 0.25 0.25)) `shouldBe` [(Event (Context []) Nothing (Arc 0.25 0.25) 0.25 :: Event Double)] it "0.5" $ (queryArc saw (Arc 0.5 0.5)) `shouldBe` [(Event (Context []) Nothing (Arc 0.5 0.5) 0.5 :: Event Double)] it "0.75" $ (queryArc saw (Arc 0.75 0.75)) `shouldBe` [(Event (Context []) Nothing (Arc 0.75 0.75) 0.75 :: Event Double)] it "can be added to" $ do (map value $ queryArc ((+1) <$> saw) (Arc 0.5 0.5)) `shouldBe` [1.5 :: Float] it "works on the left of <*>" $ do (queryArc ((+) <$> saw <*> pure 3) (Arc 0 1)) `shouldBe` [Event (Context []) Nothing (Arc 0 1) 3.5 :: Event Double] it "works on the right of <*>" $ do (queryArc ((fast 4 $ pure (+3)) <*> saw) (Arc 0 1)) `shouldBe` [Event (Context []) Nothing (Arc 0 0.25) 3.5 :: Event Double, Event (Context []) Nothing (Arc 0.25 0.5) 3.5, Event (Context []) Nothing (Arc 0.5 0.75) 3.5, Event (Context []) Nothing (Arc 0.75 1) 3.5 ] it "can be reversed" $ do it "works with whole cycles" $ (queryArc (rev saw) (Arc 0 1)) `shouldBe` [(Event (Context []) Nothing (Arc 0 1) 0.5 :: Event Double)] it "works with half cycles" $ (queryArc (rev saw) (Arc 0 0.5)) `shouldBe` [(Event (Context []) Nothing (Arc 0 0.5) 0.75 :: Event Double)] it "works with inset points" $ (queryArc (rev saw) (Arc 0.25 0.25)) `shouldBe` [(Event (Context []) Nothing (Arc 0.25 0.25) 0.75 :: Event Double)] describe "tri" $ do it "goes from 0 up to 1 and back every cycle" $ do comparePD (Arc 0 1) (struct "t*8" (tri :: Pattern Double)) ("0.125 0.375 0.625 0.875 0.875 0.625 0.375 0.125") it "can be added to" $ do comparePD (Arc 0 1) (struct "t*8" $ (tri :: Pattern Double) + 1) ("1.125 1.375 1.625 1.875 1.875 1.625 1.375 1.125") describe "every" $ do it "`every n id` doesn't change the pattern's structure" $ do comparePD (Arc 0 4) (every 2 id $ "x/2" :: Pattern String) ("x/2") tidal-1.5.2/test/Sound/Tidal/ParseTest.hs0000644000000000000000000001053207346545000016360 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.ParseTest where import TestUtils import Test.Microspec import Prelude hiding ((<*), (*>)) import Sound.Tidal.Core import Sound.Tidal.Pattern import Sound.Tidal.UI (_degradeBy) run :: Microspec () run = describe "Sound.Tidal.Parse" $ do describe "parseBP_E" $ do it "can parse strings" $ do compareP (Arc 0 12) ("a b c" :: Pattern String) (fastCat ["a", "b", "c"]) it "can parse ints" $ do compareP (Arc 0 2) ("0 1 2 3 4 5 6 7 8 0 10 20 30 40 50" :: Pattern Int) (fastCat $ map (pure . read) $ words "0 1 2 3 4 5 6 7 8 0 10 20 30 40 50") it "can alternate with <>" $ do compareP (Arc 0 2) ("a " :: Pattern String) (cat [fastCat ["a", "b"], fastCat ["a", "c"]]) it "can slow with /" $ do compareP (Arc 0 2) ("a/2" :: Pattern String) (slow 2 $ "a") it "can speed up with *" $ do compareP (Arc 0 2) ("a*8" :: Pattern String) (fast 8 "a") it "can elongate with _" $ do compareP (Arc 0 2) ("a _ _ b _" :: Pattern String) (timeCat [(3,"a"), (2,"b")]) it "can replicate with !" $ do compareP (Arc 0 2) ("a! b" :: Pattern String) (fastCat ["a", "a", "b"]) it "can replicate with ! inside {}" $ do compareP (Arc 0 2) ("{a a}%2" :: Pattern String) ("{a !}%2" :: Pattern String) it "can replicate with ! and number" $ do compareP (Arc 0 2) ("a!3 b" :: Pattern String) (fastCat ["a", "a", "a", "b"]) it "can degrade with ?" $ do compareP (Arc 0 1) ("a?" :: Pattern String) (degradeByDefault "a") it "can degrade with ? and number" $ do compareP (Arc 0 1) ("a?0.2" :: Pattern String) (_degradeBy 0.2 "a") it "can degrade with ? for double patterns" $ do compareP (Arc 0 1) ("0.4 0.5? 0.6" :: Pattern Double) (fastcat[0.4, degradeByDefault 0.5, 0.6]) it "can stretch with @" $ do comparePD (Arc 0 1) ("a@2 b" :: Pattern String) (timeCat [(2, "a"),(1,"b")]) it "can do polymeter with {}" $ do compareP (Arc 0 2) ("{a b, c d e}" :: Pattern String) (stack [fastcat [pure "a", pure "b"], slow 1.5 $ fastcat [pure "c", pure "d", pure "e"]]) it "can parse .. with ints" $ do compareP (Arc 0 2) ("0 .. 8" :: Pattern Int) ("0 1 2 3 4 5 6 7 8") it "can parse .. with rationals" $ do compareP (Arc 0 2) ("0 .. 8" :: Pattern Rational) ("0 1 2 3 4 5 6 7 8") it "can handle repeats (!) and durations (@) with <>" $ do compareP (Arc 0 31) ("" :: Pattern String) (slow 10 "[a a a b b] c") it "can handle repeats (!) and durations (@) with <> (with ints)" $ do compareP (Arc 0 31) ("<1!3 2 ! 3@5>" :: Pattern Int) (slow 10 "[1 1 1 2 2] 3") it "can handle fractional durations" $ do compareP (Arc 0 2) ("a@0.5 b@1%6 b@1%6 b@1%6" :: Pattern String) ("a b*3") it "can handle fractional durations (with rationals)" $ do compareP (Arc 0 2) ("1%3@0.5 3%4@1%6 3%4@1%6 3%4@1%6" :: Pattern Rational) ("1%3 0.75*3") it "can parse a chord" $ do compareP (Arc 0 2) ("'major" :: Pattern Int) ("[0,4,7]") it "can parse two chords" $ do compareP (Arc 0 2) ("'major 'minor" :: Pattern Int) ("[0,4,7] [0,3,7]") it "can parse c chords" $ do compareP (Arc 0 2) ("'major 'minor 'dim7" :: Pattern Int) ("c'major c'minor c'dim7") it "can parse various chords" $ do compareP (Arc 0 2) ("c'major e'minor f'dim7" :: Pattern Int) ("c e f" + "'major 'minor 'dim7") it "doesn't crash on zeroes (1)" $ do compareP (Arc 0 2) ("cp/0" :: Pattern String) (silence) it "doesn't crash on zeroes (2)" $ do compareP (Arc 0 2) ("cp(5,0)" :: Pattern String) (silence) it "doesn't crash on zeroes (3)" $ do compareP (Arc 0 2) ("cp(5,c)" :: Pattern String) (silence) where degradeByDefault = _degradeBy 0.5 tidal-1.5.2/test/Sound/Tidal/PatternTest.hs0000644000000000000000000006700107346545000016726 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.PatternTest where import Test.Microspec import TestUtils import Prelude hiding ((*>), (<*)) import Data.Ratio import Sound.Tidal.Core import Sound.Tidal.Pattern import Sound.Tidal.UI import qualified Data.Map.Strict as Map run :: Microspec () run = describe "Sound.Tidal.Pattern" $ do describe "Arc" $ do it "Arc is a Functor: Apply a given function to the start and end values of an Arc" $ do let res = fmap (+1) (Arc 3 5) property $ ((Arc 4 6) :: Arc) === res {- describe "Event" $ do it "(Bifunctor) first: Apply a function to the Arc elements: whole and part" $ do let res = Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event (Context []) Int f = (+1) property $ first f res === Event (Context []) (Just $ Arc 2 3) (Arc 4 5) 5 it "(Bifunctor) second: Apply a function to the event element" $ do let res = Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event (Context []) Int f = (+1) property $ second f res === Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 6-} describe "whole" $ do it "returns the whole Arc in an Event" $ do property $ (Just $ Arc 1 2) === whole (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event Int) describe "part" $ do it "returns the part Arc in an Event" $ do property $ (Arc 3 4) === part (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event Int) describe "value" $ do it "returns the event value in an Event" $ do property $ 5 === value (Event (Context []) (Just $ Arc (1 :: Rational) 2) (Arc 3 4) ( 5 :: Int)) describe "wholeStart" $ do it "retrieve the onset of an event: the start of the whole Arc" $ do property $ 1 === wholeStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventHasOnset" $ do it "return True when the start values of the two arcs in an event are equal" $ do let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 1 3) (4 :: Int)) property $ True === eventHasOnset ev it "return False when the start values of the two arcs in an event are not equal" $ do let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) property $ False === eventHasOnset ev describe "pure" $ do it "fills a whole cycle" $ do property $ queryArc (pure 0) (Arc 0 1) === [(Event (Context []) (Just $ Arc 0 1) (Arc 0 1) (0 :: Int))] it "returns the part of an pure that you ask for, preserving the whole" $ do property $ queryArc (pure 0) (Arc 0.25 0.75) === [(Event (Context []) (Just $ Arc 0 1) (Arc 0.25 0.75) (0 :: Int))] it "gives correct fragments when you go over cycle boundaries" $ do property $ queryArc (pure 0) (Arc 0.25 1.25) === [ (Event (Context []) (Just $ Arc 0 1) (Arc 0.25 1) (0 :: Int)), (Event (Context []) (Just $ Arc 1 2) (Arc 1 1.25) 0) ] it "works with zero-length queries" $ do it "0" $ queryArc (pure "a") (Arc 0 0) `shouldBe` fmap toEvent [(((0,1), (0,0)), "a" :: String)] it "1/3" $ queryArc (pure "a") (Arc (1%3) (1%3)) `shouldBe` fmap toEvent [(((0,1), (1%3,1%3)), "a" :: String)] describe "_fastGap" $ do it "copes with cross-cycle queries" $ do (queryArc(_fastGap 2 $ fastCat [pure "a", pure "b"]) (Arc 0.5 1.5)) `shouldBe` [(Event (Context []) (Just $ Arc (1 % 1) (5 % 4)) (Arc (1 % 1) (5 % 4)) ("a" :: String)), (Event (Context []) (Just $ Arc (5 % 4) (3 % 2)) (Arc (5 % 4) (3 % 2)) "b") ] it "does not return events outside of the query" $ do (queryArc(_fastGap 2 $ fastCat [pure "a", pure ("b" :: String)]) (Arc 0.5 0.9)) `shouldBe` [] describe "<*>" $ do it "can apply a pattern of values to a pattern of values" $ do queryArc ((pure (+1)) <*> (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0,1), (0,1)), 4 :: Int)] it "can take structure from the left" $ do queryArc ((fastCat [pure (+1), pure (+2)]) <*> (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0,0.5), (0,0.5)), 4 :: Int), (((0.5,1), (0.5,1)), 5) ] it "can take structure from the right" $ do queryArc (pure (+1) <*> (fastCat [pure 7, pure 8])) (Arc 0 1) `shouldBe` fmap toEvent [(((0,0.5), (0,0.5)), 8 :: Int), (((0.5,1), (0.5,1)), 9) ] it "can take structure from the both sides" $ do it "one" $ queryArc ((fastCat [pure (+1), pure (+2)]) <*> (fastCat [pure 7, pure 8])) (Arc 0 1) `shouldBe` fmap toEvent [(((0,0.5), (0,0.5)), 8 :: Int), (((0.5,1), (0.5,1)), 10) ] it "two" $ queryArc ((fastCat [pure (+1), pure (+2), pure (+3)]) <*> (fastCat [pure 7, pure 8])) (Arc 0 1) `shouldBe` fmap toEvent [ (((0%1, 1%3), (0%1, 1%3)), 8 :: Int), (((1%3, 1%2), (1%3, 1%2)), 9), (((1%2, 2%3), (1%2, 2%3)), 10), (((2%3, 1%1), (2%3, 1%1)), 11) ] it "obeys pure id <*> v = v" $ do let v = (fastCat [fastCat [pure 7, pure 8], pure 9]) :: Pattern Int queryArc ((pure id <*> v)) (Arc 0 5) `shouldBe` queryArc v (Arc 0 5) it "obeys pure f <*> pure x = pure (f x)" $ do let f = (+3) x = 7 :: Int queryArc (pure f <*> pure x) (Arc 0 5) `shouldBe` queryArc (pure (f x)) (Arc 0 5) it "obeys u <*> pure y = pure ($ y) <*> u" $ do let u = fastCat [pure (+7), pure (+8)] y = 6 :: Int queryArc (u <*> pure y) (Arc 0 5) `shouldBe` queryArc (pure ($ y) <*> u) (Arc 0 5) it "obeys pure (.) <*> u <*> v <*> w = u <*> (v <*> w)" $ do let u = (fastCat [pure (+7), pure (+8)]) :: Pattern (Int -> Int) v = fastCat [pure (+3), pure (+4), pure (+5)] w = fastCat [pure 1, pure 2] queryArc (pure (.) <*> u <*> v <*> w) (Arc 0 5) `shouldBe` queryArc (u <*> (v <*> w)) (Arc 0 5) describe "<*" $ do it "can apply a pattern of values to a pattern of functions" $ do queryArc ((pure (+1)) <* (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0,1), (0,1)), 4 :: Int)] it "doesn't take structure from the right" $ do queryArc (pure (+1) <* (fastCat [pure 7, pure 8])) (Arc 0 1) `shouldBe` fmap toEvent [(((0,1), (0,0.5)), 8 :: Int), (((0,1), (0.5,1)), 9 :: Int) ] describe "*>" $ do it "can apply a pattern of values to a pattern of functions" $ do it "works within cycles" $ queryArc ((pure (+1)) *> (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0,1), (0,1)), 4 :: Int)] it "works across cycles" $ queryArc ((pure (+1)) *> (slow 2 $ pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0,2), (0,1)), 4 :: Int)] it "doesn't take structure from the left" $ do queryArc (pure (+1) *> (fastCat [pure 7, pure 8])) (Arc 0 1) `shouldBe` fmap toEvent [(((0,0.5), (0,0.5)), 8 :: Int), (((0.5,1), (0.5,1)), 9 :: Int) ] describe "arcCycles" $ do it "leaves a unit cycle intact" $ do it "(0,1)" $ arcCycles (Arc 0 1) `shouldBe` [(Arc 0 1)] it "(3,4)" $ arcCycles (Arc 3 4) `shouldBe` [(Arc 3 4)] it "splits a cycle at cycle boundaries" $ do it "(0,1.1)" $ arcCycles (Arc 0 1.1) `shouldBe` [(Arc 0 1),(Arc 1 1.1)] it "(1,2,1)" $ arcCycles (Arc 1 2.1) `shouldBe` [(Arc 1 2),(Arc 2 2.1)] it "(3 + (1%3),5.1)" $ arcCycles (Arc (3 + (1%3)) 5.1) `shouldBe` [(Arc (3+(1%3)) 4),(Arc 4 5),(Arc 5 5.1)] describe "unwrap" $ do it "preserves inner structure" $ do it "one" $ (queryArc (unwrap $ pure (fastCat [pure "a", pure ("b" :: String)])) (Arc 0 1)) `shouldBe` (queryArc (fastCat [pure "a", pure "b"]) (Arc 0 1)) it "two" $ (queryArc (unwrap $ pure (fastCat [pure "a", pure "b", fastCat [pure "c", pure ("d" :: String)]])) (Arc 0 1)) `shouldBe` (queryArc (fastCat [pure "a", pure "b", fastCat [pure "c", pure "d"]]) (Arc 0 1)) it "preserves outer structure" $ do it "one" $ (queryArc (unwrap $ fastCat [pure $ pure "a", pure $ pure ("b" :: String)]) (Arc 0 1)) `shouldBe` (queryArc (fastCat [pure "a", pure "b"]) (Arc 0 1)) it "two" $ (queryArc (unwrap $ fastCat [pure $ pure "a", pure $ pure "b", fastCat [pure $ pure "c", pure $ pure ("d" :: String)]]) (Arc 0 1)) `shouldBe` (queryArc (fastCat [pure "a", pure "b", fastCat [pure "c", pure "d"]]) (Arc 0 1)) it "gives events whole/part timespans that are an intersection of that of inner and outer events" $ do let a = fastCat [pure "a", pure "b"] b = fastCat [pure "c", pure "d", pure "e"] pp = fastCat [pure a, pure b] queryArc (unwrap pp) (Arc 0 1) `shouldBe` [(Event (Context []) (Just $ Arc (0 % 1) (1 % 2)) (Arc (0 % 1) (1 % 2)) ("a" :: String)), (Event (Context []) (Just $ Arc (1 % 2) (2 % 3)) (Arc (1 % 2) (2 % 3)) "d"), (Event (Context []) (Just $ Arc (2 % 3) (1 % 1)) (Arc (2 % 3) (1 % 1)) "e") ] describe "squeezeJoin" $ do it "compresses cycles to fit outer 'whole' timearc of event" $ do let a = fastCat [pure "a", pure "b"] b = fastCat [pure "c", pure "d", pure "e"] pp = fastCat [pure a, pure b] queryArc (squeezeJoin pp) (Arc 0 1) `shouldBe` [(Event (Context []) (Just $ Arc (0 % 1) (1 % 4)) (Arc (0 % 1) (1 % 4)) ("a" :: String)), (Event (Context []) (Just $ Arc (1 % 4) (1 % 2)) (Arc (1 % 4) (1 % 2)) "b"), (Event (Context []) (Just $ Arc (1 % 2) (2 % 3)) (Arc (1 % 2) (2 % 3)) "c"), (Event (Context []) (Just $ Arc (2 % 3) (5 % 6)) (Arc (2 % 3) (5 % 6)) "d"), (Event (Context []) (Just $ Arc (5 % 6) (1 % 1)) (Arc (5 % 6) (1 % 1)) "e") ] describe ">>=" $ do it "can apply functions to patterns" $ do let p = fastCat [pure 7, pure 8] :: Pattern Int p' = do x <- p return $ x + 1 (queryArc p' (Arc 0 1)) `shouldBe` (queryArc ((+1) <$> p) (Arc 0 1)) it "can add two patterns together" $ do let p1 = fastCat [pure 7, pure 8, pure 9] :: Pattern Int p2 = fastCat [pure 4, fastCat [pure 5, pure 6]] p' = do x <- p1 y <- p2 return $ x + y compareP (Arc 0 1) p' ((+) <$> p1 <*> p2) it "conforms to (return v) >>= f = f v" $ do let f x = pure $ x + 10 v = 5 :: Int compareP (Arc 0 5) ((return v) >>= f) (f v) it "conforms to m >>= return ≡ m" $ do let m = fastCat [pure "a", fastCat [pure "b", pure ("c" :: String)]] compareP (Arc 0 1) (m >>= return) m -- it "conforms to (m >>= f) >>= g ≡ m >>= ( \x -> (f x >>= g) )" $ do -- let m = fastCat [pure "a", fastCat [pure "b", pure "c"]] describe "rotR" $ do it "works over two cycles" $ property $ comparePD (Arc 0 2) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) it "works over one cycle" $ property $ compareP (Arc 0 1) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) it "works with zero width queries" $ property $ compareP (Arc 0 0) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) describe "comparePD" $ do it "allows split events to be compared" $ property $ comparePD (Arc 0 2) (splitQueries $ _slow 2 $ pure ("a" :: String)) (_slow 2 $ pure "a") describe "controlI" $ do it "can retrieve values from state" $ (query (pure 3 + cF_ "hello") $ State (Arc 0 1) (Map.singleton "hello" (pure $ VF 0.5))) `shouldBe` [(Event (Context []) (Just $ Arc (0 % 1) (1 % 1)) (Arc (0 % 1) (1 % 1)) 3.5)] describe "wholeStart" $ do it "retrieve first element of a tuple, inside first element of a tuple, inside the first of another" $ do property $ 1 === wholeStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "wholeStop" $ do it "retrieve the end time from the first Arc in an Event" $ do property $ 2 === wholeStop (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventPartStart" $ do it "retrieve the start time of the second Arc in an Event" $ do property $ 3 === eventPartStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventPartStop" $ do it "retrieve the end time of the second Arc in an Event" $ do property $ 4 === eventPartStop (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventPart" $ do it "retrieve the second Arc in an Event" $ do property $ Arc 3 4 === eventPart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventValue" $ do it "retrieve the second value from a tuple" $ do property $ 5 === eventValue (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "eventHasOnset" $ do it "return True when the start values of the two arcs in an event are equal" $ do let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 1 3) (4 :: Int)) property $ True === eventHasOnset ev it "return False when the start values of the two arcs in an event are not equal" $ do let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) property $ False === eventHasOnset ev describe "sam" $ do it "start of a cycle, round down time value" $ do let res = sam (3.4 :: Time) property $ (3.0 :: Time) === res describe "nextSam" $ do it "the end point of the current cycle, and start of the next" $ do let res = nextSam (3.4 :: Time) property $ (4.0 :: Time) === res describe "arcCycles" $ do it "if start time is greater than end time return empty list" $ do let res = arcCycles (Arc 2.3 2.1) property $ [] === res it "if start time is equal to end time return empty list" $ do let res = arcCycles (Arc 3 3) property $ [] === res it "if start and end time round down to same value return list of (start, end)" $ do let res = arcCycles (Arc 2.1 2.3) property $ [(Arc 2.1 2.3)] === res it "if start time is less than end time and start time does not round down to same value as end time" $ do let res = arcCycles (Arc 2.1 3.3) property $ [(Arc 2.1 3.0), (Arc 3.0 3.3)] === res describe "arcCyclesZW" $ do it "if start and end time are equal return list of (start, end)" $ do let res = arcCyclesZW (Arc 2.5 2.5) property $ [(Arc 2.5 2.5)] === res it "if start and end time are not equal call arcCycles (start, end) with same rules as above" $ do let res = arcCyclesZW (Arc 2.3 2.1) property $ [] === res it "if start time is less than end time" $ do let res = arcCyclesZW (Arc 2.1 2.3) property $ [(Arc 2.1 2.3)] === res it "if start time is greater than end time" $ do let res = arcCyclesZW (Arc 2.1 3.3) property $ [(Arc 2.1 3.0), (Arc 3.0 3.3)] === res describe "mapCycle" $ do it "Apply a function to the Arc values minus the start value rounded down (sam'), adding both results to sam' to obtain the new Arc value" $ do let res = mapCycle (*2) (Arc 3.3 5) property $ ((Arc 3.6 7.0) :: Arc) === res describe "toTime" $ do it "Convert a number of type Real to a Time value of type Rational, Int test" $ do let res = toTime (3 :: Int) property $ (3 % 1 :: Time) === res it "Convert a number of type Double to a Time value of type Rational" $ do let res = toTime (3.2 :: Double) property $ (3602879701896397 % 1125899906842624 :: Time) === res describe "cyclePos" $ do it "Subtract a Time value from its value rounded down (the start of the cycle)" $ do let res = cyclePos 2.6 property $ (0.6 :: Time) === res it "If no difference between a given Time and the start of the cycle" $ do let res = cyclePos 2 property $ (0.0 :: Time) === res describe "isIn" $ do it "Check given Time is inside a given Arc value, Time is greater than start and less than end Arc values" $ do let res = isIn (Arc 2.0 2.8) 2.5 property $ True === res it "Given Time is equal to the Arc start value" $ do let res = isIn (Arc 2.0 2.8) 2.0 property $ True === res it "Given Time is less than the Arc start value" $ do let res = isIn (Arc 2.0 2.8) 1.4 property $ False === res it "Given Time is greater than the Arc end value" $ do let res = isIn (Arc 2.0 2.8) 3.2 property $ False === res describe "onsetIn" $ do it "If the beginning of an Event is within a given Arc, same rules as 'isIn'" $ do let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 2.2 2.7) (Arc 3.3 3.8) (5 :: Int)) property $ True === res it "Beginning of Event is equal to beggining of given Arc" $ do let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 2.0 2.7) (Arc 3.3 3.8) (5 :: Int)) property $ True === res it "Beginning of an Event is less than the start of the Arc" $ do let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 1.2 1.7) (Arc 3.3 3.8) (5 :: Int)) property $ False === res it "Start of Event is greater than the start of the given Arc" $ do let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 3.1 3.5) (Arc 4.0 4.6) (5 :: Int)) property $ False === res describe "subArc" $ do it "Checks if an Arc is within another, returns Just (max $ (fst a1) (fst a2), min $ (snd a1) (snd a2)) if so, otherwise Nothing" $ do let res = subArc (Arc 2.1 2.4) (Arc 2.4 2.8) property $ Nothing === res it "if max (fst arc1) (fst arc2) <= min (snd arc1) (snd arc2) return Just (max (fst arc1) (fst arc2), min...)" $ do let res = subArc (Arc 2 2.8) (Arc 2.4 2.9) property $ Just (Arc 2.4 2.8) === res describe "timeToCycleArc" $ do it "given a Time value return the Arc in which it resides" $ do let res = timeToCycleArc 2.2 property $ (Arc 2.0 3.0) === res describe "cyclesInArc" $ do it "Return a list of cycles in a given arc, if start is greater than end return empty list" $ do let res = cyclesInArc (Arc 2.4 2.2) property $ ([] :: [Int]) === res it "If start value of Arc is equal to end value return list with start value rounded down" $ do let res = cyclesInArc (Arc 2.4 2.4) property $ ([2] :: [Int]) === res it "if start of Arc is less than end return list of start rounded down to end rounded up minus one" $ do let res = cyclesInArc (Arc 2.2 4.5) property $ ([2,3,4] :: [Int]) === res describe "cycleArcsInArc" $ do it "generates a list of Arcs based on the cycles found within a given a Arc" $ do let res = cycleArcsInArc (Arc 2.2 4.5) property $ [(Arc 2.0 3.0), (Arc 3.0 4.0), (Arc 4.0 5.0)] === res describe "isAdjacent" $ do it "if the given Events are adjacent parts of the same whole" $ do let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (5 :: Int)) property $ True === res it "if first Arc of of first Event is not equal to first Arc of second Event" $ do let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int)) property $ False === res it "if the value of the first Event does not equal the value of the second Event" $ do let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (6 :: Int)) property $ False === res it "second value of second Arc of first Event not equal to first value of second Arc in second Event..." $ do let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) property $ False === res describe "defragParts" $ do it "if empty list with no events return empty list" $ do let res = defragParts ([] :: [Event Int]) property $ [] === res it "if list consists of only one Event return it as is" $ do let res = defragParts [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))] property $ [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] === res it "if list contains adjacent Events return list with Parts combined" $ do let res = defragParts [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)), (Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (5 :: Int))] property $ [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5)] === res it "if list contains more than one Event none of which are adjacent, return List as is" $ do let res = defragParts [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5), (Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int))] property $ [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5, Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int)] === res describe "compareDefrag" $ do it "compare list with Events with empty list of Events" $ do let res = compareDefrag [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int), Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (5 :: Int)] [] property $ False === res it "compare lists containing same Events but of different length" $ do let res = compareDefrag [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int), Event (Context []) (Just $ Arc 1 2) (Arc 4 3) 5] [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] property $ True === res it "compare lists of same length with same Events" $ do let res = compareDefrag [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] property $ True === res describe "sect" $ do it "take two Arcs and return - Arc (max of two starts) (min of two ends)" $ do let res = sect (Arc 2.2 3) (Arc 2 2.9) property $ Arc 2.2 2.9 == res describe "hull" $ do it "take two Arcs anre return - Arc (min of two starts) (max of two ends)" $ do let res = hull (Arc 2.2 3) (Arc 2 2.9) property $ Arc 2 3 == res describe "withResultArc" $ do it "apply given function to the Arcs" $ do let p = withResultArc (+5) (stripContext $ fast "1 2" "3 4" :: Pattern Int) let res = queryArc p (Arc 0 1) property $ res === fmap toEvent [(((5, 11%2), (5, 11%2)), 3), (((11%2, 23%4), (11%2, 23%4)), 3), (((23%4, 6), (23%4, 6)), 4)] describe "applyFIS" $ do it "apply Float function when value of type VF" $ do let res = applyFIS (+1) (+1) (++ "1") (VF 1) property $ (VF $ 2.0) === res it "apply Int function when value of type VI" $ do let res = applyFIS (+1) (+1) (++ "1") (VI 1) property $ (VI $ 2) === res it "apply String function when value of type VS" $ do let res = applyFIS (+1) (+1) (++ "1") (VS "1") property $ (VS $ "11") === res describe "fNum2" $ do it "apply Int function for two Int values" $ do let res = fNum2 (+) (+) (VI 2) (VI 3) property $ (VI $ 5) === res it "apply float function when given two float values" $ do let res = fNum2 (+) (+) (VF 2) (VF 3) property $ (VF $ 5.0) === res it "apply float function when one float and one int value given" $ do let res = fNum2 (+) (+) (VF 2) (VI 3) property $ (VF $ 5.0) === res describe "getI" $ do it "get Just value when Int value is supplied" $ do let res = getI (VI 3) property $ (Just 3) === res it "get floored value when float value is supplied" $ do let res = getI (VF 3.5) property $ (Just 3) === res it "get Nothing if String value is supplied" $ do let res = getI (VS "3") property $ Nothing === res describe "getF" $ do it "get Just value when Float value is supplied" $ do let res = getF (VF 3) property $ (Just 3.0) === res it "get converted value if Int value is supplied" $ do let res = getF (VI 3) property $ (Just 3.0) === res describe "getS" $ do it "get Just value when String value is supplied" $ do let res = getS (VS "Tidal") property $ (Just "Tidal") === res it "get Nothing if Int value is not supplied" $ do let res = getS (VI 3) property $ Nothing === res describe "filterValues" $ do it "remove Events above given threshold" $ do let fil = filterValues (<2) $ fastCat [pure 1, pure 2, pure 3] :: Pattern Time let res = queryArc fil (Arc 0.5 1.5) property $ fmap toEvent [(((1, 4%3), (1, 4%3)), 1%1)] === res it "remove Events below given threshold" $ do let fil = filterValues (>2) $ fastCat [pure 1, pure 2, pure 3] :: Pattern Time let res = queryArc fil (Arc 0.5 1.5) property $ fmap toEvent [(((2%3, 1), (2%3, 1)), 3%1)] === res describe "filterWhen" $ do it "filter below given threshold" $ do let fil = filterWhen (<0.5) $ struct "t*4" $ (tri :: Pattern Double) + 1 let res = queryArc fil (Arc 0.5 1.5) property $ [] === res it "filter above given threshold" $ do let fil = stripContext $ filterWhen (>0.5) $ struct "t*4" $ (tri :: Pattern Double) + 1 let res = queryArc fil (Arc 0.5 1.5) property $ fmap toEvent [(((3%4, 1), (3%4, 1)), 1.25), (((1, 5%4), (1, 5%4)), 1.25), (((5%4, 3%2), (5%4, 3%2)), 1.75)] === res describe "compressArc" $ do it "return empty if start time is greater than end time" $ do let res = queryArc (compressArc (Arc 0.8 0.1) (fast "1 2" "3 4" :: Pattern Time) ) (Arc 1 2) property $ [] === res it "return empty if start time or end time are greater than 1" $ do let res = queryArc (compressArc (Arc 0.1 2) (fast "1 2" "3 4" :: Pattern Time)) (Arc 1 2) property $ [] === res it "return empty if start or end are less than zero" $ do let res = queryArc (compressArc (Arc (-0.8) 0.1) (fast "1 2" "3 4" :: Pattern Time)) (Arc 1 2) property $ [] === res it "otherwise compress difference between start and end values of Arc" $ do let p = fast "1 2" "3 4" :: Pattern Time let res = queryArc (stripContext $ compressArc (Arc 0.2 0.8) p) (Arc 0 1) let expected = fmap toEvent [(((1%5, 1%2), (1%5, 1%2)), 3%1), (((1%2, 13%20), (1%2, 13%20)), 3%1), (((13%20, 4%5), (13%20, 4%5)), 4%1)] property $ expected === res -- pending "Sound.Tidal.Pattern.eventL" $ do -- it "succeeds if the first event 'whole' is shorter" $ do -- property $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 1.1)) "x") -- it "fails if the events are the same length" $ do -- property $ not $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 1)) "x") -- it "fails if the second event is shorter" $ do -- property $ not $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 0.5)) "x") tidal-1.5.2/test/Sound/Tidal/ScalesTest.hs0000644000000000000000000005071307346545000016525 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.ScalesTest where import TestUtils import Test.Microspec import Prelude hiding ((<*), (*>)) import Sound.Tidal.Scales import Sound.Tidal.Pattern run :: Microspec () run = describe "Sound.Tidal.Scales" $ do describe "scale" $ do describe "5 note scales" $ do let twoOctavesOf5NoteScale = "0 1 2 3 4 5 6 7 8 9" it "can transform notes correctly over 2 octaves - minPent" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "minPent" twoOctavesOf5NoteScale) ("0 3 5 7 10 12 15 17 19 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - majPent" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "majPent" twoOctavesOf5NoteScale) ("0 2 4 7 9 12 14 16 19 21"::Pattern Rational) it "can transform notes correctly over 2 octaves - ritusen" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "ritusen" twoOctavesOf5NoteScale) ("0 2 5 7 9 12 14 17 19 21"::Pattern Rational) it "can transform notes correctly over 2 octaves - egyptian" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "egyptian" twoOctavesOf5NoteScale) ("0 2 5 7 10 12 14 17 19 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - kumai" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "kumai" twoOctavesOf5NoteScale) ("0 2 3 7 9 12 14 15 19 21"::Pattern Rational) it "can transform notes correctly over 2 octaves - hirajoshi" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "hirajoshi" twoOctavesOf5NoteScale) ("0 2 3 7 8 12 14 15 19 20"::Pattern Rational) it "can transform notes correctly over 2 octaves - iwato" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "iwato" twoOctavesOf5NoteScale) ("0 1 5 6 10 12 13 17 18 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - chinese" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "chinese" twoOctavesOf5NoteScale) ("0 4 6 7 11 12 16 18 19 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - indian" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "indian" twoOctavesOf5NoteScale) ("0 4 5 7 10 12 16 17 19 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - pelog" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "pelog" twoOctavesOf5NoteScale) ("0 1 3 7 8 12 13 15 19 20"::Pattern Rational) it "can transform notes correctly over 2 octaves - prometheus" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "prometheus" twoOctavesOf5NoteScale) ("0 2 4 6 11 12 14 16 18 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - scriabin" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "scriabin" twoOctavesOf5NoteScale) ("0 1 4 7 9 12 13 16 19 21"::Pattern Rational) it "can transform notes correctly over 2 octaves - gong" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "gong" twoOctavesOf5NoteScale) ("0 2 4 7 9 12 14 16 19 21"::Pattern Rational) it "can transform notes correctly over 2 octaves - shang" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "shang" twoOctavesOf5NoteScale) ("0 2 5 7 10 12 14 17 19 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - jiao" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "jiao" twoOctavesOf5NoteScale) ("0 3 5 8 10 12 15 17 20 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - zhi" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "zhi" twoOctavesOf5NoteScale) ("0 2 5 7 9 12 14 17 19 21"::Pattern Rational) it "can transform notes correctly over 2 octaves - yu" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "yu" twoOctavesOf5NoteScale) ("0 3 5 7 10 12 15 17 19 22"::Pattern Rational) describe "6 note scales" $ do let twoOctavesOf6NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11" it "can transform notes correctly over 2 octaves - whole" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "whole" twoOctavesOf6NoteScale) ("0 2 4 6 8 10 12 14 16 18 20 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - wholetone" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "wholetone" twoOctavesOf6NoteScale) (Sound.Tidal.Scales.scale "whole" twoOctavesOf6NoteScale :: Pattern Rational) it "can transform notes correctly over 2 octaves - augmented" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "augmented" twoOctavesOf6NoteScale) ("0 3 4 7 8 11 12 15 16 19 20 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - augmented2" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "augmented2" twoOctavesOf6NoteScale) ("0 1 4 5 8 9 12 13 16 17 20 21"::Pattern Rational) it "can transform notes correctly over 2 octaves - hexMajor7" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "hexMajor7" twoOctavesOf6NoteScale) ("0 2 4 7 9 11 12 14 16 19 21 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - hexPhrygian" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "hexPhrygian" twoOctavesOf6NoteScale) ("0 1 3 5 8 10 12 13 15 17 20 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - hexDorian" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "hexDorian" twoOctavesOf6NoteScale) ("0 2 3 5 7 10 12 14 15 17 19 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - hexSus" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "hexSus" twoOctavesOf6NoteScale) ("0 2 5 7 9 10 12 14 17 19 21 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - hexMajor6" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "hexMajor6" twoOctavesOf6NoteScale) ("0 2 4 5 7 9 12 14 16 17 19 21"::Pattern Rational) it "can transform notes correctly over 2 octaves - hexAeolian" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "hexAeolian" twoOctavesOf6NoteScale) ("0 3 5 7 8 10 12 15 17 19 20 22"::Pattern Rational) describe "7 note scales" $ do let twoOctavesOf7NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13" it "can transform notes correctly over 2 octaves - major" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "major" twoOctavesOf7NoteScale) ("0 2 4 5 7 9 11 12 14 16 17 19 21 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - ionian" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "ionian" twoOctavesOf7NoteScale) (Sound.Tidal.Scales.scale "major" twoOctavesOf7NoteScale :: Pattern Rational) it "can transform notes correctly over 2 octaves - dorian" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "dorian" twoOctavesOf7NoteScale) ("0 2 3 5 7 9 10 12 14 15 17 19 21 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - aeolian" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale) ("0 2 3 5 7 8 10 12 14 15 17 19 20 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - aeolian" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale) (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale::Pattern Rational) it "can transform notes correctly over 2 octaves - minor" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale) (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale::Pattern Rational) it "can transform notes correctly over 2 octaves - locrian" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "locrian" twoOctavesOf7NoteScale) ("0 1 3 5 6 8 10 12 13 15 17 18 20 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - harmonicMinor" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "harmonicMinor" twoOctavesOf7NoteScale) ("0 2 3 5 7 8 11 12 14 15 17 19 20 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - harmonicMajor" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "harmonicMajor" twoOctavesOf7NoteScale) ("0 2 4 5 7 8 11 12 14 16 17 19 20 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - melodicMinor" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "melodicMinor" twoOctavesOf7NoteScale) ("0 2 3 5 7 9 11 12 14 15 17 19 21 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - melodicMinorDesc" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "melodicMinorDesc" twoOctavesOf7NoteScale) (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale::Pattern Rational) it "can transform notes correctly over 2 octaves - melodicMajor" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale) ("0 2 4 5 7 8 10 12 14 16 17 19 20 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - bartok" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "bartok" twoOctavesOf7NoteScale) (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale::Pattern Rational) it "can transform notes correctly over 2 octaves - hindu" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "hindu" twoOctavesOf7NoteScale) (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale::Pattern Rational) it "can transform notes correctly over 2 octaves - todi" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "todi" twoOctavesOf7NoteScale) ("0 1 3 6 7 8 11 12 13 15 18 19 20 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - purvi" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "purvi" twoOctavesOf7NoteScale) ("0 1 4 6 7 8 11 12 13 16 18 19 20 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - marva" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "marva" twoOctavesOf7NoteScale) ("0 1 4 6 7 9 11 12 13 16 18 19 21 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - bhairav" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "bhairav" twoOctavesOf7NoteScale) ("0 1 4 5 7 8 11 12 13 16 17 19 20 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - ahirbhairav" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "ahirbhairav" twoOctavesOf7NoteScale) ("0 1 4 5 7 9 10 12 13 16 17 19 21 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - superLocrian" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "superLocrian" twoOctavesOf7NoteScale) ("0 1 3 4 6 8 10 12 13 15 16 18 20 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - romanianMinor" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "romanianMinor" twoOctavesOf7NoteScale) ("0 2 3 6 7 9 10 12 14 15 18 19 21 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - hungarianMinor" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "hungarianMinor" twoOctavesOf7NoteScale) ("0 2 3 6 7 8 11 12 14 15 18 19 20 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - neapolitanMinor" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "neapolitanMinor" twoOctavesOf7NoteScale) ("0 1 3 5 7 8 11 12 13 15 17 19 20 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - enigmatic" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "enigmatic" twoOctavesOf7NoteScale) ("0 1 4 6 8 10 11 12 13 16 18 20 22 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - spanish" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "spanish" twoOctavesOf7NoteScale) ("0 1 4 5 7 8 10 12 13 16 17 19 20 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - leadingWhole" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "leadingWhole" twoOctavesOf7NoteScale) ("0 2 4 6 8 10 11 12 14 16 18 20 22 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - lydianMinor" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "lydianMinor" twoOctavesOf7NoteScale) ("0 2 4 6 7 8 10 12 14 16 18 19 20 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - neapolitanMajor" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "neapolitanMajor" twoOctavesOf7NoteScale) ("0 1 3 5 7 9 11 12 13 15 17 19 21 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - locrianMajor" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "locrianMajor" twoOctavesOf7NoteScale) ("0 2 4 5 6 8 10 12 14 16 17 18 20 22"::Pattern Rational) describe "8 note scales" $ do let twoOctavesOf8NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15" it "can transform notes correctly over 2 octaves - diminished" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale) ("0 1 3 4 6 7 9 10 12 13 15 16 18 19 21 22"::Pattern Rational) it "can transform notes correctly over 2 octaves - octatonic" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "octatonic" twoOctavesOf8NoteScale) (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale::Pattern Rational) it "can transform notes correctly over 2 octaves - diminished2" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "diminished2" twoOctavesOf8NoteScale) ("0 2 3 5 6 8 9 11 12 14 15 17 18 20 21 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - octatonic2" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "octatonic2" twoOctavesOf8NoteScale) (Sound.Tidal.Scales.scale "diminished2" twoOctavesOf8NoteScale::Pattern Rational) describe "modes of limited transposition" $ do let twoOctavesOf6NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11" let twoOctavesOf8NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15" let twoOctavesOf9NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17" let twoOctavesOf10NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19" it "can transform notes correctly over 2 octaves - messiaen1" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "messiaen1" twoOctavesOf6NoteScale) (Sound.Tidal.Scales.scale "wholetone" twoOctavesOf6NoteScale::Pattern Rational) it "can transform notes correctly over 2 octaves - messiaen2" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "messiaen2" twoOctavesOf8NoteScale) (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale::Pattern Rational) it "can transform notes correctly over 2 octaves - messiaen3" $ do -- tone, semitone, semitone, tone, semitone, semitone, tone, semitone, semitone compareP (Arc 0 1) (Sound.Tidal.Scales.scale "messiaen3" twoOctavesOf9NoteScale) ("0 2 3 4 6 7 8 10 11 12 14 15 16 18 19 20 22 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - messiaen4" $ do -- semitone, semitone, minor third, semitone, semitone, semitone, minor third, semitone compareP (Arc 0 1) (Sound.Tidal.Scales.scale "messiaen4" twoOctavesOf8NoteScale) ("0 1 2 5 6 7 8 11 12 13 14 17 18 19 20 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - messiaen5" $ do -- semitone, major third, semitone, semitone, major third, semitone compareP (Arc 0 1) (Sound.Tidal.Scales.scale "messiaen5" twoOctavesOf6NoteScale) ("0 1 5 6 7 11 12 13 17 18 19 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - messiaen6" $ do -- tone, tone, semitone, semitone, tone, tone, semitone, semitone compareP (Arc 0 1) (Sound.Tidal.Scales.scale "messiaen6" twoOctavesOf8NoteScale) ("0 2 4 5 6 8 10 11 12 14 16 17 18 20 22 23"::Pattern Rational) it "can transform notes correctly over 2 octaves - messiaen7" $ do -- semitone, semitone, semitone, tone, semitone, semitone, semitone, semitone, tone, semitone compareP (Arc 0 1) (Sound.Tidal.Scales.scale "messiaen7" twoOctavesOf10NoteScale) ("0 1 2 3 5 6 7 8 9 11 12 13 14 15 17 18 19 20 21 23"::Pattern Rational) describe "12 note scales" $ do let twoOctavesOf12NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23" it "can transform notes correctly over 2 octaves - chromatic" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "chromatic" twoOctavesOf12NoteScale) ("0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23"::Pattern Rational) describe "edge cases" $ do it "responds to unknown scales by mapping to octaves" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "ergaerv" "0 1 2 3 4") ("0 12 24 36 48"::Pattern Rational) it "correctly maps negative numbers" $ do compareP (Arc 0 1) (Sound.Tidal.Scales.scale "major" "0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13") ("0 -1 -3 -5 -7 -8 -10 -12 -13 -15 -17 -19 -20 -22 "::Pattern Rational) tidal-1.5.2/test/Sound/Tidal/UITest.hs0000644000000000000000000002723407346545000015632 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.UITest where import TestUtils import Test.Microspec import Prelude hiding ((<*), (*>)) import qualified Data.Map.Strict as Map -- import Sound.Tidal.Pattern import Sound.Tidal.Control import Sound.Tidal.Core import Sound.Tidal.Params import Sound.Tidal.ParseBP import Sound.Tidal.Pattern import Sound.Tidal.UI run :: Microspec () run = describe "Sound.Tidal.UI" $ do describe "_chop" $ do it "can chop in two bits" $ do compareP (Arc 0 1) (_chop 2 $ s (pure "a")) (begin (fastcat [pure 0, pure 0.5]) # end (fastcat [pure 0.5, pure 1]) # (s (pure "a"))) it "can be slowed" $ do compareP (Arc 0 1) (slow 2 $ _chop 2 $ s (pure "a")) (begin (pure 0) # end (pure 0.5) # (s (pure "a"))) it "can chop a chop" $ property $ compareTol (Arc 0 1) (_chop 6 $ s $ pure "a") (_chop 2 $ _chop 3 $ s $ pure "a") describe "segment" $ do it "can turn a single event into multiple events" $ do compareP (Arc 0 3) (segment 4 "x") ("x*4" :: Pattern String) it "can turn a continuous pattern into multiple discrete events" $ do compareP (Arc 0 3) (segment 4 saw) ("0.125 0.375 0.625 0.875" :: Pattern Double) it "can hold a value over multiple cycles" $ do comparePD (Arc 0 8) (segment 0.5 saw) (slow 2 "0" :: Pattern Double) {- -- not sure what this is supposed to do! it "holding values over multiple cycles works in combination" $ do comparePD (Arc 0 8) ("0*4" |+ (_segment (1/8) $ saw)) ("0*4" :: Pattern Double) -} describe "sometimesBy" $ do it "does nothing when set at 0% probability" $ do let overTimeSpan = (Arc 0 1) testMe = sometimesBy 0 (rev) (ps "bd*2 hh sn") expectedResult = ps "bd*2 hh sn" in compareP overTimeSpan testMe expectedResult it "does nothing when set at 0% probability -- const" $ do let overTimeSpan = (Arc 0 2) testMe = sometimesBy 0 (const $ s "cp") (s "bd*8") expectedResult = s "bd*8" in compareP overTimeSpan testMe expectedResult it "applies the 'rev' function when set at 100% probability" $ do let overTimeSpan = (Arc 0 1) testMe = sometimesBy 1 (rev) (ps "bd*2 hh cp") expectedResult = ps "cp hh bd*2" in compareP overTimeSpan testMe expectedResult describe "rand" $ do it "generates a (pseudo-)random number between zero & one" $ do it "at the start of a cycle" $ (queryArc rand (Arc 0 0)) `shouldBe` [Event (Context []) Nothing (Arc 0 0) (0 :: Float)] it "at 1/4 of a cycle" $ (queryArc rand (Arc 0.25 0.25)) `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (0.6295689214020967:: Float)] it "at 3/4 of a cycle" $ (queryArc rand (Arc 0.75 0.75)) `shouldBe` [Event (Context []) Nothing (Arc 0.75 0.75) (0.20052618719637394 :: Float)] describe "range" $ do describe "scales a pattern to the supplied range" $ do describe "from 3 to 4" $ do it "at the start of a cycle" $ (queryArc (Sound.Tidal.UI.range 3 4 saw) (Arc 0 0)) `shouldBe` [Event (Context []) Nothing (Arc 0 0) (3 :: Float)] it "at 1/4 of a cycle" $ (queryArc (Sound.Tidal.UI.range 3 4 saw) (Arc 0.25 0.25)) `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (3.25 :: Float)] it "at 3/4 of a cycle" $ (queryArc (Sound.Tidal.UI.range 3 4 saw) (Arc 0.75 0.75)) `shouldBe` [Event (Context []) Nothing (Arc 0.75 0.75) (3.75 :: Float)] describe "from -1 to 1" $ do it "at 1/2 of a cycle" $ (queryArc (Sound.Tidal.UI.range (-1) 1 saw) (Arc 0.5 0.5)) `shouldBe` [Event (Context []) Nothing (Arc 0.5 0.5) (0 :: Float)] describe "from 4 to 2" $ do it "at the start of a cycle" $ (queryArc (Sound.Tidal.UI.range 4 2 saw) (Arc 0 0)) `shouldBe` [Event (Context []) Nothing (Arc 0 0) (4 :: Float)] it "at 1/4 of a cycle" $ (queryArc (Sound.Tidal.UI.range 4 2 saw) (Arc 0.25 0.25)) `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (3.5 :: Float)] it "at 3/4 of a cycle" $ (queryArc (Sound.Tidal.UI.range 4 2 saw) (Arc 0.75 0.75)) `shouldBe` [Event (Context []) Nothing (Arc 0.75 0.75) (2.5 :: Float)] describe "from 10 to 10" $ do it "at 1/2 of a cycle" $ (queryArc (Sound.Tidal.UI.range 10 10 saw) (Arc 0.5 0.5)) `shouldBe` [Event (Context []) Nothing (Arc 0.5 0.5) (10 :: Float)] describe "rot" $ do it "rotates values in a pattern irrespective of structure" $ property $ comparePD (Arc 0 2) (rot 1 "a ~ b c" :: Pattern String) ( "b ~ c a" :: Pattern String) it "works with negative values" $ property $ comparePD (Arc 0 2) (rot (-1) "a ~ b c" :: Pattern String) ( "c ~ a b" :: Pattern String) it "works with complex patterns" $ property $ comparePD (Arc 0 2) (rot (1) "a ~ [b [c ~ d]] [e ]" :: Pattern String) ( "b ~ [c [d ~ e]] [ a]" :: Pattern String) describe "fix" $ do it "can apply functions conditionally" $ do compareP (Arc 0 1) (fix (|+ n 1) (s "sn") (s "bd sn cp" # n 1)) (s "bd sn cp" # n "1 2 1") it "works with complex matches" $ do compareP (Arc 0 1) (fix (|+ n 2) (s "sn" # n 2) (s "bd sn*4 cp" # n "1 2")) (s "bd sn*4 cp" # n "1 [1 4] 2") it "leaves unmatched controls in place" $ do compareP (Arc 0 1) (fix (|+ n 2) (s "sn" # n 2) (s "bd sn*4 cp" # n "1 2" # speed (sine + 1))) (s "bd sn*4 cp" # n "1 [1 4] 2" # speed (sine + 1)) it "ignores silence" $ do compareP (Arc 0 1) (fix (|+ n 2) (silence) $ s "bd sn*4 cp" # n "1 2" # speed (sine + 1)) (s "bd sn*4 cp" # n "1 2" # speed (sine + 1)) it "treats polyphony as 'or'" $ do compareP (Arc 0 1) (fix (# crush 2) (n "[1,2]") $ s "bd sn" # n "1 2") (s "bd sn" # n "1 2" # crush 2) describe "unfix" $ do it "does the opposite of fix" $ do compareP (Arc 0 1) (unfix (|+ n 2) (s "sn" # n 2) (s "bd sn*4 cp" # n "1 2" # speed (sine + 1))) (s "bd sn*4 cp" # n "3 [3 2] 4" # speed (sine + 1)) describe "contrast" $ do it "does both fix and unfix" $ do compareP (Arc 0 1) (contrast (|+ n 2) (|+ n 10) (s "sn" # n 2) (s "bd sn*4 cp" # n "1 2" # speed (sine + 1))) (s "bd sn*4 cp" # n "11 [11 4] 12" # speed (sine + 1)) describe "contrastRange" $ do it "matches using a pattern of ranges" $ do compareP (Arc 0 1) (contrastRange (# crush 3) (# crush 0) (pure $ Map.singleton "n" $ (VF 0, VF 3)) $ s "bd" >| n "1 4") (s "bd" >| n "1 4" >| crush "3 0") describe "euclidFull" $ do it "can match against silence" $ do compareP (Arc 0 1) (euclidFull 3 8 "bd" silence) ("bd(3,8)" :: Pattern String) describe "snowball" $ do let testPattern = ("1 2 3 4"::Pattern Int) it "acummulates a transform version of a pattern and appends the result - addition" $ do compareP (Arc 0 1) (snowball 3 (+) (slow 2) (testPattern)) (cat [testPattern,(testPattern+(slow 2 testPattern)),((testPattern+(slow 2 testPattern))+slow 2 (testPattern+(slow 2 testPattern)))]) describe "soak" $ do it "applies a transform and then appends the result -- addition" $ do compareP (Arc 0 3) (soak 3 (+ 1) "4 ~ 0 1") (cat ["4 ~ 0 1"::Pattern Int,"5 ~ 1 2"::Pattern Int,"6 ~ 2 3"::Pattern Int]) it "applies a transform and then appends the result -- slow" $ do compareP (Arc 0 7) (soak 3 (slow 2) "4 ~ 0 1") (cat ["4 ~ 0 1"::Pattern Int, slow 2 "4 ~ 0 1"::Pattern Int, slow 4 "4 ~ 0 1"::Pattern Int]) it "applies a transform and then appends the result -- addition patterns" $ do compareP (Arc 0 3) (soak 3 (+ "1 2 3") "1 1") (cat ["1 1"::Pattern Int,"2 [3 3] 4"::Pattern Int,"3 [5 5] 7"::Pattern Int]) describe "euclid" $ do it "matches examples in Toussaint's paper" $ do sequence_ $ map (\(a,b) -> it b $ compareP (Arc 0 1) a (parseBP_E b)) ([(euclid 1 2 "x", "x ~"), (euclid 1 3 "x", "x ~ ~"), (euclid 1 4 "x", "x ~ ~ ~"), (euclid 4 12 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~"), (euclid 2 5 "x", "x ~ x ~ ~"), -- (euclid 3 4 "x", "x ~ x x"), -- Toussaint is wrong.. (euclid 3 4 "x", "x x x ~"), -- correction (euclid 3 5 "x", "x ~ x ~ x"), (euclid 3 7 "x", "x ~ x ~ x ~ ~"), (euclid 3 8 "x", "x ~ ~ x ~ ~ x ~"), (euclid 4 7 "x", "x ~ x ~ x ~ x"), (euclid 4 9 "x", "x ~ x ~ x ~ x ~ ~"), (euclid 4 11 "x", "x ~ ~ x ~ ~ x ~ ~ x ~"), -- (euclid 5 6 "x", "x ~ x x x x"), -- Toussaint is wrong.. (euclid 5 6 "x", "x x x x x ~"), -- correction (euclid 5 7 "x", "x ~ x x ~ x x"), (euclid 5 8 "x", "x ~ x x ~ x x ~"), (euclid 5 9 "x", "x ~ x ~ x ~ x ~ x"), (euclid 5 11 "x", "x ~ x ~ x ~ x ~ x ~ ~"), (euclid 5 12 "x", "x ~ ~ x ~ x ~ ~ x ~ x ~"), -- (euclid 5 16 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~ x ~ ~ ~ ~"), -- Toussaint is wrong.. (euclid 5 16 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~ x ~ ~ ~"), -- correction -- (euclid 7 8 "x", "x ~ x x x x x x"), -- Toussaint is wrong.. (euclid 7 8 "x", "x x x x x x x ~"), -- Correction (euclid 7 12 "x", "x ~ x x ~ x ~ x x ~ x ~"), (euclid 7 16 "x", "x ~ ~ x ~ x ~ x ~ ~ x ~ x ~ x ~"), (euclid 9 16 "x", "x ~ x x ~ x ~ x ~ x x ~ x ~ x ~"), (euclid 11 24 "x", "x ~ ~ x ~ x ~ x ~ x ~ x ~ ~ x ~ x ~ x ~ x ~ x ~"), (euclid 13 24 "x", "x ~ x x ~ x ~ x ~ x ~ x ~ x x ~ x ~ x ~ x ~ x ~") ] :: [(Pattern String, String)]) describe "wedge" $ do it "should not freeze tidal amount is 1" $ do compareP (Arc 0 1) (wedge (1) (s "ho ho:2 ho:3 hc") (rev $ s "ho ho:2 ho:3 hc")) (s "ho ho:2 ho:3 hc") it "should not freeze tidal amount is 0" $ do compareP (Arc 0 1) (wedge (0) (s "ho ho:2 ho:3 hc") (rev $ s "ho ho:2 ho:3 hc")) (rev $ s "ho ho:2 ho:3 hc") describe "bite" $ do it "can slice a pattern into bits" $ do compareP (Arc 0 4) (bite 4 "0 2*2" (Sound.Tidal.Core.run 8)) ("[0 1] [4 5]*2" :: Pattern Int) describe "chooseBy" $ do it "chooses from elements based on closest scaled double value" $ do compareP (Arc 0 4) (("0"::Pattern Int) |+ chooseBy ((/ 4)$(sig fromRational)) [0,1,2,3]) ("<0 1 2 3>"::Pattern Int) it "never gets an index out of bounds" $ do compareP (Arc 0 4) ("0" |+ chooseBy (sig fromRational) [0,1,2,3]) ("2"::Pattern Int) describe "arpeggiate" $ do it "can arpeggiate" $ do compareP (Arc 0 1) (arpeggiate ("[bd, sn] [hh:1, cp]" :: Pattern String)) ("bd sn hh:1 cp" :: Pattern String) it "can arpeggiate" $ do compareP (Arc 0 4) (arpeggiate $ "[0,0] [0,0]") ("0 0 0 0" :: Pattern Int) it "can arpeggiate a 'sped up' pattern" $ do compareP (Arc 0 4) (arpeggiate $ "[0,0]*2") ("0 0 0 0" :: Pattern Int) tidal-1.5.2/test/Sound/Tidal/UtilsTest.hs0000644000000000000000000000341107346545000016404 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.UtilsTest where import Test.Microspec import Prelude hiding ((<*), (*>)) import Sound.Tidal.Utils run :: Microspec () run = describe "Sound.Tidal.Utils" $ do describe "delta" $ do it "subtracts the second element of a tuple from the first" $ do property $ delta (3,10) === (7 :: Int) describe "applies function to both elements of tuple" $ do let res = mapBoth (+1) (2,5) property $ ((3,6) :: (Int, Int)) === res describe "apply function to first element of tuple" $ do let res = mapFst (+1) (2, 5) property $ ((3, 5) :: (Int, Int)) === res describe "apply function to second element of tuple" $ do let res = mapSnd (+1) (2, 5) property $ ((2, 6) :: (Int, Int)) === res describe "return midpoint between first and second tuple value" $ do let res = mid (2, 5) property $ (3.5 :: Double) === res describe "return of two lists, with unique values to each list" $ do let res = removeCommon [1,2,5,7,12,16] [2,3,4,5,15,16] property $ (([1,7,12],[3,4,15]) :: ([Int], [Int])) === res describe "wrap around indexing" $ do let res = (!!!) [1..5] 7 property $ (3 :: Int) === res describe "safe list indexing" $ do let res = nth 2 ([] :: [Int]) property $ Nothing === res describe "list accumulation with given list elements" $ do let res = accumulate ([1..5] :: [Int]) property $ [1,3,6,10,15] === res describe "index elements in list" $ do let res = enumerate ['a', 'b', 'c'] property $ [(0,'a'),(1,'b'),(2,'c')] === res describe "split list by given pred" $ do let res = wordsBy (== ':') "bd:3" property $ ["bd", "3"] === res tidal-1.5.2/test/0000755000000000000000000000000007346545000011764 5ustar0000000000000000tidal-1.5.2/test/Test.hs0000644000000000000000000000076107346545000013243 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} import Test.Microspec import Sound.Tidal.CoreTest import Sound.Tidal.ParseTest import Sound.Tidal.PatternTest import Sound.Tidal.ControlTest import Sound.Tidal.ScalesTest import Sound.Tidal.UITest import Sound.Tidal.UtilsTest main :: IO () main = microspec $ do Sound.Tidal.CoreTest.run Sound.Tidal.ParseTest.run Sound.Tidal.PatternTest.run Sound.Tidal.ControlTest.run Sound.Tidal.ScalesTest.run Sound.Tidal.UITest.run Sound.Tidal.UtilsTest.run tidal-1.5.2/test/TestUtils.hs0000644000000000000000000000224007346545000014256 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module TestUtils where import Test.Microspec import Prelude hiding ((<*), (*>)) import Data.List (sort) import Sound.Tidal.Context import qualified Data.Map.Strict as Map -- | Compare the events of two patterns using the given arc compareP :: (Ord a, Show a) => Arc -> Pattern a -> Pattern a -> Property compareP a p p' = (sort $ query (stripContext p) $ State a Map.empty) `shouldBe` (sort $ query (stripContext p') $ State a Map.empty) -- | Like @compareP@, but tries to 'defragment' the events comparePD :: (Ord a) => Arc -> Pattern a -> Pattern a -> Bool comparePD a p p' = compareDefrag es es' where es = query (stripContext p) (State a Map.empty) es' = query (stripContext p') (State a Map.empty) -- | 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 [] tidal-1.5.2/tidal.cabal0000644000000000000000000000713207346545000013071 0ustar0000000000000000name: tidal version: 1.5.2 synopsis: Pattern language for improvised music -- description: homepage: http://tidalcycles.org/ license: GPL-3 license-file: LICENSE author: Alex McLean maintainer: Alex McLean , Mike Hodnick Stability: Experimental Copyright: (c) Tidal contributors, 2019 category: Sound build-type: Simple cabal-version: >=1.10 tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 data-files: BootTidal.hs Extra-source-files: README.md CHANGELOG.md tidal.el Description: Tidal is a domain specific language for live coding pattern. library ghc-options: -Wall hs-source-dirs: src default-language: Haskell2010 Exposed-modules: Sound.Tidal.Bjorklund Sound.Tidal.Carabiner Sound.Tidal.Chords Sound.Tidal.Config Sound.Tidal.Control Sound.Tidal.Context Sound.Tidal.Core Sound.Tidal.Params Sound.Tidal.ParseBP Sound.Tidal.Pattern Sound.Tidal.Scales Sound.Tidal.Show Sound.Tidal.Simple Sound.Tidal.Stream Sound.Tidal.Tempo Sound.Tidal.Transition Sound.Tidal.UI Sound.Tidal.Utils Sound.Tidal.Version Sound.Tidal.EspGrid -- Sound.Tidal.Light -- Sound.Tidal.TH Build-depends: base >=4.8 && <5 , containers < 0.7 , colour < 2.4 , hosc >= 0.17 && < 0.18 , text < 1.3 , parsec >= 3.1.12 && < 3.2 , network < 3.2 , vector < 0.13 , bifunctors < 5.6 , transformers >= 0.5 && < 0.5.7 , bytestring < 0.11 , clock < 0.9 , deepseq >= 1.1.0.0 , primitive < 0.8 , random < 1.2 -- , serialport -- , hashable if !impl(ghc >= 8.4.1) build-depends: semigroups >= 0.18 && < 0.20 test-suite tests type: exitcode-stdio-1.0 main-is: Test.hs hs-source-dirs: test ghc-options: -Wall other-modules: Sound.Tidal.ControlTest Sound.Tidal.CoreTest Sound.Tidal.ParseTest Sound.Tidal.PatternTest Sound.Tidal.ScalesTest Sound.Tidal.UITest Sound.Tidal.UtilsTest TestUtils build-depends: base ==4.* , microspec >= 0.2.0.1 , containers , parsec , tidal default-language: Haskell2010 benchmark bench-speed type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: bench/Speed other-modules: Tidal.PatternB Tidal.CoreB Tidal.UIB Tidal.Inputs build-depends: base == 4.* , criterion , tidal ghc-options: -Wall -O2 default-language: Haskell2010 benchmark bench-memory type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: bench/Memory other-modules: Tidal.UIB Tidal.Inputs build-depends: base == 4.* , weigh , tidal ghc-options: -Wall -O2 default-language: Haskell2010 source-repository head type: git location: https://github.com/tidalcycles/Tidal tidal-1.5.2/tidal.el0000755000000000000000000003702207346545000012433 0ustar0000000000000000;;; tidal.el --- Interact with TidalCycles for live coding patterns -*- lexical-binding: t; -*- ;; Copyright (C) 2012 alex@slab.org ;; Copyright (C) 2006-2008 rohan drape (hsc3.el) ;; Author: alex@slab.org ;; Homepage: https://github.com/tidalcycles/Tidal ;; Version: 0 ;; Keywords: tools ;; Package-Requires: ((haskell-mode "16") (emacs "24")) ;; 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 . ;;; Commentary: ;; notes from hsc3: ;; This mode is implemented as a derivation of `haskell' mode, ;; indentation and font locking is courtesy that mode. The ;; inter-process communication is courtesy `comint'. The symbol at ;; 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*" "*The name of the tidal process buffer (default=*tidal*).") (defvar tidal-interpreter "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 () "*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" . "ghc-pkg field tidal data-dir") ("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 in S." (replace-regexp-in-string "^> " "" s)) (defun tidal-intersperse (e l) "Insert E between every element of list L." (when l (cons e (cons (car l) (tidal-intersperse e (cdr l)))))) (defun tidal-start-haskell () "Start haskell." (interactive) (if (comint-check-proc tidal-buffer) (error "A tidal process is already running") (apply 'make-comint "tidal" tidal-interpreter nil tidal-interpreter-arguments) (tidal-see-output)) (tidal-send-string (concat ":script " tidal-boot-script-path)) ) (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))))))) (defun tidal-quit-haskell () "Quit haskell." (interactive) (kill-buffer tidal-buffer) (delete-other-windows)) (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 (tidal-chunk-string n (substring s n)))))) (defun tidal-send-string (s) (if (comint-check-proc tidal-buffer) (let ((cs (tidal-chunk-string 64 (concat s "\n")))) (mapcar (lambda (c) (comint-send-string tidal-buffer c)) cs)) (error "no tidal process running?"))) (defun tidal-transform-and-store (f s) "Transform example text into compilable form." (with-temp-file f (mapc (lambda (module) (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'." (interactive) (tidal-send-string "now' <- getNow") (tidal-send-string "let now = nextSam now'") (tidal-send-string "let retrig = (now `rotR`)") (tidal-send-string "let fadeOut n = spread' (_degradeBy) (retrig $ slow n $ envL)") (tidal-send-string "let fadeIn n = spread' (_degradeBy) (retrig $ slow n $ (1-) <$> envL)") ) (defun tidal-run-line () "Send the current line to the interpreter." (interactive) ;(tidal-get-now) (let* ((s (buffer-substring (line-beginning-position) (line-end-position))) (s* (if tidal-literate-p (tidal-unlit s) s))) (tidal-send-string s*)) (pulse-momentary-highlight-one-line (point)) (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) (if (>= emacs-major-version 25) (save-mark-and-excursion (tidal-eval-multiple-lines)) (save-excursion (tidal-eval-multiple-lines)) ) ) (defun tidal-run-d1 () "Send the first instance of d1 to the interpreter as a single line." (interactive) (goto-char 0) (search-forward "d1" nil nil 1) (tidal-run-multiple-lines) ) (defun tidal-run-d2 () "Send the d2 to the interpreter as a single line." (interactive) (goto-char 0) (search-forward "d2" nil nil 1) (tidal-run-multiple-lines) ) (defun tidal-run-d3 () "Send the d3 to the interpreter as a single line." (interactive) (goto-char 0) (search-forward "d3" nil nil 1) (tidal-run-multiple-lines) ) (defun tidal-run-d4 () "Send the d4 to the interpreter as a single line." (interactive) (goto-char 0) (search-forward "d4" nil nil 1) (tidal-run-multiple-lines) ) (defun tidal-run-d5 () "Send the d5 to the interpreter as a single line." (interactive) (goto-char 0) (search-forward "d5" nil nil 1) (tidal-run-multiple-lines) ) (defun tidal-run-d6 () "Send the d6 to the interpreter as a single line." (interactive) (goto-char 0) (search-forward "d6" nil nil 1) (tidal-run-multiple-lines) ) (defun tidal-run-d7 () "Send the d7 to the interpreter as a single line." (interactive) (goto-char 0) (search-forward "d7" nil nil 1) (tidal-run-multiple-lines) ) (defun tidal-run-d8 () "Send the d9 to the interpreter as a single line." (interactive) (goto-char 0) (search-forward "d8" nil nil 1) (tidal-run-multiple-lines) ) (defun tidal-run-d9 () "Send the d9 to the interpreter as a single line." (interactive) (goto-char 0) (search-forward "d9" nil nil 1) (tidal-run-multiple-lines) ) (defun tidal-stop-d1 () "send d1 $ silence as a single line" (interactive) (tidal-send-string ":{") (tidal-send-string " mapM_ ($ silence) [d1]") (tidal-send-string ":}") ) (defun tidal-stop-d2 () "send d1 $ silence as a single line" (interactive) (tidal-send-string ":{") (tidal-send-string " mapM_ ($ silence) [d2]") (tidal-send-string ":}") ) (defun tidal-stop-d3 () "send d1 $ silence as a single line" (interactive) (tidal-send-string ":{") (tidal-send-string " mapM_ ($ silence) [d3]") (tidal-send-string ":}") ) (defun tidal-stop-d4 () "send d1 $ silence as a single line" (interactive) (tidal-send-string ":{") (tidal-send-string " mapM_ ($ silence) [d4]") (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-stop-d7 () "send d1 $ silence as a single line" (interactive) (tidal-send-string ":{") (tidal-send-string " mapM_ ($ silence) [d7]") (tidal-send-string ":}") ) (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 ":}") ) (defun tidal-run-region () "Place the region in a do block and compile." (interactive) (tidal-transform-and-store "/tmp/tidal.hs" (buffer-substring-no-properties (region-beginning) (region-end))) (tidal-send-string ":load \"/tmp/tidal.hs\"") (tidal-send-string "main")) (defun tidal-load-buffer () "Load the current buffer." (interactive) (save-buffer) (tidal-send-string (format ":load \"%s\"" buffer-file-name))) (defun tidal-run-main () "Run current main." (interactive) (tidal-send-string "main")) (defun tidal-interrupt-haskell () (interactive) (if (comint-check-proc tidal-buffer) (with-current-buffer tidal-buffer (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 "") 'tidal-run-multiple-lines) (define-key map [?\C-c ?\C-r] 'tidal-run-region) (define-key map [?\C-c ?\C-l] 'tidal-load-buffer) (define-key map [?\C-c ?\C-i] 'tidal-interrupt-haskell) (define-key map [?\C-c ?\C-m] 'tidal-run-main) (define-key map [?\C-c ?\C-1] 'tidal-run-d1) (define-key map [?\C-c ?\C-2] 'tidal-run-d2) (define-key map [?\C-c ?\C-3] 'tidal-run-d3) (define-key map [?\C-c ?\C-4] 'tidal-run-d4) (define-key map [?\C-c ?\C-5] 'tidal-run-d5) (define-key map [?\C-c ?\C-6] 'tidal-run-d6) (define-key map [?\C-c ?\C-7] 'tidal-run-d7) (define-key map [?\C-c ?\C-8] 'tidal-run-d8) (define-key map [?\C-c ?\C-9] 'tidal-run-d9) (define-key map [?\C-v ?\C-1] 'tidal-stop-d1) (define-key map [?\C-v ?\C-2] 'tidal-stop-d2) (define-key map [?\C-v ?\C-3] 'tidal-stop-d3) (define-key map [?\C-v ?\C-4] 'tidal-stop-d4) (define-key map [?\C-v ?\C-5] 'tidal-stop-d5) (define-key map [?\C-v ?\C-6] 'tidal-stop-d6) (define-key map [?\C-v ?\C-7] 'tidal-stop-d7) (define-key map [?\C-v ?\C-8] 'tidal-stop-d8) (define-key map [?\C-v ?\C-9] 'tidal-stop-d9)) (defun turn-on-tidal-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 "") 'tidal-run-multiple-lines) (local-set-key [?\C-c ?\C-r] 'tidal-run-region) (local-set-key [?\C-c ?\C-l] 'tidal-load-buffer) (local-set-key [?\C-c ?\C-i] 'tidal-interrupt-haskell) (local-set-key [?\C-c ?\C-m] 'tidal-run-main) (local-set-key [?\C-c ?\C-1] 'tidal-run-d1) (local-set-key [?\C-c ?\C-2] 'tidal-run-d2) (local-set-key [?\C-c ?\C-3] 'tidal-run-d3) (local-set-key [?\C-c ?\C-4] 'tidal-run-d4) (local-set-key [?\C-c ?\C-5] 'tidal-run-d5) (local-set-key [?\C-c ?\C-6] 'tidal-run-d6) (local-set-key [?\C-c ?\C-7] 'tidal-run-d7) (local-set-key [?\C-c ?\C-8] 'tidal-run-d8) (local-set-key [?\C-c ?\C-9] 'tidal-run-d9) (local-set-key [?\C-v ?\C-1] 'tidal-stop-d1) (local-set-key [?\C-v ?\C-2] 'tidal-stop-d2) (local-set-key [?\C-v ?\C-3] 'tidal-stop-d3) (local-set-key [?\C-v ?\C-4] 'tidal-stop-d4) (local-set-key [?\C-v ?\C-5] 'tidal-stop-d5) (local-set-key [?\C-v ?\C-6] 'tidal-stop-d6) (local-set-key [?\C-v ?\C-7] 'tidal-stop-d7) (local-set-key [?\C-v ?\C-8] 'tidal-stop-d8) (local-set-key [?\C-v ?\C-9] 'tidal-stop-d9)) (defun tidal-mode-menu (map) "Haskell Tidal menu." (define-key map [menu-bar tidal] (cons "Haskell-Tidal" (make-sparse-keymap "Haskell-Tidal"))) (define-key map [menu-bar tidal help] (cons "Help" (make-sparse-keymap "Help"))) (define-key map [menu-bar tidal expression] (cons "Expression" (make-sparse-keymap "Expression"))) (define-key map [menu-bar tidal expression load-buffer] '("Load buffer" . tidal-load-buffer)) (define-key map [menu-bar tidal expression run-main] '("Run main" . tidal-run-main)) (define-key map [menu-bar tidal expression run-region] '("Run region" . tidal-run-region)) (define-key map [menu-bar tidal expression run-multiple-lines] '("Run multiple lines" . tidal-run-multiple-lines)) (define-key map [menu-bar tidal expression run-line] '("Run line" . tidal-run-line)) (define-key map [menu-bar tidal haskell] (cons "Haskell" (make-sparse-keymap "Haskell"))) (define-key map [menu-bar tidal haskell quit-haskell] '("Quit haskell" . tidal-quit-haskell)) (define-key map [menu-bar tidal haskell see-output] '("See output" . tidal-see-output)) (define-key map [menu-bar tidal haskell start-haskell] '("Start haskell" . tidal-start-haskell))) (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 "Literate Haskell Tidal" "Major mode for interacting with an inferior haskell process." (set (make-local-variable 'paragraph-start) "\f\\|[ \t]*$") (set (make-local-variable 'paragraph-separate) "[ \t\f]*$") (setq tidal-literate-p t) (setq haskell-literate 'bird) (turn-on-font-lock)) ;;;###autoload (add-to-list 'auto-mode-alist '("\\.ltidal$" . literate-tidal-mode)) ;;(add-to-list 'load-path "/usr/share/emacs/site-lisp/haskell-mode/") ;required by olig1905 on linux ;;(require 'haskell-mode) ;required by olig1905 on linux ;;;###autoload (define-derived-mode tidal-mode haskell-mode "Haskell Tidal" "Major mode for interacting with an inferior haskell process." (set (make-local-variable 'paragraph-start) "\f\\|[ \t]*$") (set (make-local-variable 'paragraph-separate) "[ \t\f]*$") (setq tidal-literate-p nil) (turn-on-font-lock)) ;;;###autoload (add-to-list 'auto-mode-alist '("\\.tidal$" . tidal-mode)) (provide 'tidal) ;;; tidal.el ends here