tidal-1.0.14/ 0000755 0000000 0000000 00000000000 13504651510 011060 5 ustar 00 0000000 0000000 tidal-1.0.14/tidal.el 0000644 0000000 0000000 00000035742 13504651510 012512 0 ustar 00 0000000 0000000 ;;; 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)
(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
(concat (substring
(shell-command-to-string
"ghc-pkg describe $(ghc-pkg latest tidal) | grep data-dir | cut -f2 -d' '") 0 -1)
"/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
tidal-1.0.14/README.md 0000644 0000000 0000000 00000000703 13504651510 012337 0 ustar 00 0000000 0000000
Tidal [](https://travis-ci.org/tidalcycles/Tidal)
=====
Language for live coding of pattern
For documentation, mailing list and more info see here:
https://tidalcycles.org/
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.0.14/CHANGELOG.md 0000644 0000000 0000000 00000013371 13504651510 012676 0 ustar 00 0000000 0000000 # TidalCycles log of changes
## 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.0.14/tidal.cabal 0000644 0000000 0000000 00000005647 13504651510 013155 0 ustar 00 0000000 0000000 name: tidal
version: 1.0.14
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.MiniTidal
Sound.Tidal.Params
Sound.Tidal.ParseBP
Sound.Tidal.Pattern
Sound.Tidal.Scales
Sound.Tidal.Simple
Sound.Tidal.Stream
Sound.Tidal.Tempo
Sound.Tidal.Transition
Sound.Tidal.UI
Sound.Tidal.Utils
Sound.Tidal.Version
Sound.Tidal.EspGrid
other-modules: Sound.Tidal.MiniTidal.TH
Sound.Tidal.MiniTidal.Token
Build-depends:
base >=4.8 && <5
, containers < 0.7
, colour < 2.4
, hosc < 0.18
, text < 1.3
, parsec >= 3.1.12 && < 3.2
, network < 3.2
, mwc-random < 0.15
, vector < 0.13
, bifunctors < 5.6
, transformers >= 0.5 && < 0.5.7
, template-haskell >= 2.10.0.0 && < 2.15
, bytestring < 0.11
, clock < 0.9
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.MiniTidalTest
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
source-repository head
type: git
location: https://github.com/tidalcycles/Tidal
tidal-1.0.14/Setup.hs 0000644 0000000 0000000 00000000056 13504651510 012515 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
tidal-1.0.14/LICENSE 0000644 0000000 0000000 00000104442 13504651510 012072 0 ustar 00 0000000 0000000 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.0.14/BootTidal.hs 0000644 0000000 0000000 00000004272 13504651510 013302 0 ustar 00 0000000 0000000 :set -XOverloadedStrings
:set prompt ""
:set prompt-cont ""
import Sound.Tidal.Context
-- total latency = oLatency + cFrameTimespan
tidal <- startTidal (superdirtTarget {oLatency = 0.1, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig {cFrameTimespan = 1/20})
let p = streamReplace tidal
let hush = streamHush tidal
let list = streamList tidal
let mute = streamMute tidal
let unmute = streamUnmute tidal
let solo = streamSolo tidal
let unsolo = streamUnsolo tidal
let once = streamOnce tidal
let asap = once
let nudgeAll = streamNudgeAll tidal
let all = streamAll tidal
let resetCycles = streamResetCycles tidal
let setcps = asap . cps
let xfade i = transition tidal True (Sound.Tidal.Transition.xfadeIn 4) i
let xfadeIn i t = transition tidal True (Sound.Tidal.Transition.xfadeIn t) i
let histpan i t = transition tidal True (Sound.Tidal.Transition.histpan t) i
let wait i t = transition tidal True (Sound.Tidal.Transition.wait t) i
let waitT i f t = transition tidal True (Sound.Tidal.Transition.waitT f t) i
let jump i = transition tidal True (Sound.Tidal.Transition.jump) i
let jumpIn i t = transition tidal True (Sound.Tidal.Transition.jumpIn t) i
let jumpIn' i t = transition tidal True (Sound.Tidal.Transition.jumpIn' t) i
let jumpMod i t = transition tidal True (Sound.Tidal.Transition.jumpMod t) i
let mortal i lifespan release = transition tidal True (Sound.Tidal.Transition.mortal lifespan release) i
let interpolate i = transition tidal True (Sound.Tidal.Transition.interpolate) i
let interpolateIn i t = transition tidal True (Sound.Tidal.Transition.interpolateIn t) i
let clutch i = transition tidal True (Sound.Tidal.Transition.clutch) i
let clutchIn i t = transition tidal True (Sound.Tidal.Transition.clutchIn t) i
let anticipate i = transition tidal True (Sound.Tidal.Transition.anticipate) i
let anticipateIn i t = transition tidal True (Sound.Tidal.Transition.anticipateIn t) i
let forId i t = transition tidal False (Sound.Tidal.Transition.mortalOverlay t) i
let d1 = p 1
let d2 = p 2
let d3 = p 3
let d4 = p 4
let d5 = p 5
let d6 = p 6
let d7 = p 7
let d8 = p 8
let d9 = p 9
let d10 = p 10
let d11 = p 11
let d12 = p 12
let d13 = p 13
let d14 = p 14
let d15 = p 15
let d16 = p 16
:set prompt "tidal> "
tidal-1.0.14/src/ 0000755 0000000 0000000 00000000000 13504651510 011647 5 ustar 00 0000000 0000000 tidal-1.0.14/src/Sound/ 0000755 0000000 0000000 00000000000 13504651510 012737 5 ustar 00 0000000 0000000 tidal-1.0.14/src/Sound/Tidal/ 0000755 0000000 0000000 00000000000 13504651510 013774 5 ustar 00 0000000 0000000 tidal-1.0.14/src/Sound/Tidal/Config.hs 0000644 0000000 0000000 00000001357 13504651510 015543 0 ustar 00 0000000 0000000 module Sound.Tidal.Config where
data Config = Config {cCtrlListen :: Bool,
cCtrlAddr :: String,
cCtrlPort :: Int,
cFrameTimespan :: Double,
cTempoAddr :: String,
cTempoPort :: Int,
cTempoClientPort :: 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
}
tidal-1.0.14/src/Sound/Tidal/Context.hs 0000644 0000000 0000000 00000001041 13504651510 015750 0 ustar 00 0000000 0000000 module 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.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.0.14/src/Sound/Tidal/Version.hs 0000644 0000000 0000000 00000000123 13504651510 015751 0 ustar 00 0000000 0000000 module Sound.Tidal.Version where
tidal_version :: String
tidal_version = "1.0.14"
tidal-1.0.14/src/Sound/Tidal/Bjorklund.hs 0000644 0000000 0000000 00000002001 13504651510 016253 0 ustar 00 0000000 0000000 module Sound.Tidal.Bjorklund (bjorklund) where
-- The below is (c) Rohan Drape, taken from the hmt library and
-- distributed here under the terms of the GNU Public Licence. Tidal
-- used to just include the library but removed for now due to
-- dependency problems.. We could however likely benefit from other
-- parts of the library..
type STEP a = ((Int,Int),([[a]],[[a]]))
left :: STEP a -> STEP a
left ((i,j),(xs,ys)) =
let (xs',xs'') = splitAt j xs
in ((j,i-j),(zipWith (++) xs' ys,xs''))
right :: STEP a -> STEP a
right ((i,j),(xs,ys)) =
let (ys',ys'') = splitAt i ys
in ((i,j-i),(zipWith (++) xs ys',ys''))
bjorklund' :: STEP a -> STEP a
bjorklund' (n,x) =
let (i,j) = n
in if min i j <= 1
then (n,x)
else bjorklund' (if i > j then left (n,x) else right (n,x))
bjorklund :: (Int,Int) -> [Bool]
bjorklund (i,j') =
let j = j' - i
x = replicate i [True]
y = replicate j [False]
(_,(x',y')) = bjorklund' ((i,j),(x,y))
in concat x' ++ concat y'
tidal-1.0.14/src/Sound/Tidal/ParseBP.hs 0000644 0000000 0000000 00000040573 13504651510 015635 0 ustar 00 0000000 0000000 {-# 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 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
-- | AST representation of patterns
data TPat a = TPat_Atom a
| TPat_Density (TPat Time) (TPat a)
| TPat_Slow (TPat Time) (TPat a)
| TPat_Zoom Arc (TPat a)
| TPat_DegradeBy Double (TPat a)
| TPat_Silence
| TPat_Foot
| TPat_Elongate Int
| TPat_EnumFromTo (TPat a) (TPat a)
| TPat_Cat [TPat a]
| TPat_TimeCat [TPat a]
| TPat_Overlay (TPat a) (TPat a)
| TPat_Stack [TPat a]
| TPat_ShiftL Time (TPat a)
-- TPat_E Int Int (TPat a)
| TPat_pE (TPat Int) (TPat Int) (TPat Int) (TPat a)
deriving (Show)
toPat :: (Enumerable a, Parseable a) => TPat a -> Pattern a
toPat = \case
TPat_Atom x -> pure x
TPat_Density t x -> fast (toPat t) $ toPat x
TPat_Slow t x -> slow (toPat t) $ toPat x
TPat_Zoom a x -> zoomArc a $ toPat x
TPat_DegradeBy amt x -> _degradeBy amt $ toPat x
TPat_Silence -> silence
TPat_Cat xs -> fastcat $ map toPat xs
TPat_TimeCat xs -> timeCat $ map (\(n, pat) -> (toRational n, toPat pat)) $ durations xs
TPat_Overlay x0 x1 -> overlay (toPat x0) (toPat x1)
TPat_Stack xs -> stack $ map toPat xs
TPat_ShiftL t x -> t `rotL` toPat x
TPat_pE n k s thing ->
doEuclid (toPat n) (toPat k) (toPat s) (toPat thing)
TPat_Foot -> error "Can't happen, feet (.'s) only used internally.."
TPat_EnumFromTo a b -> unwrap $ fromTo <$> toPat a <*> toPat b
-- TPat_EnumFromThenTo a b c -> unwrap $ fromThenTo <$> (toPat a) <*> (toPat b) <*> (toPat c)
_ -> silence
durations :: [TPat a] -> [(Int, TPat a)]
durations [] = []
durations (TPat_Elongate n : xs) = (n, TPat_Silence) : durations xs
durations (a : TPat_Elongate n : xs) = (n+1,a) : durations xs
durations (a:xs) = (1,a) : durations xs
parseBP :: (Enumerable a, Parseable a) => String -> Either ParseError (Pattern a)
parseBP s = toPat <$> parseTPat s
parseBP_E :: (Enumerable a, Parseable a) => String -> Pattern a
parseBP_E s = toE parsed
where
parsed = parseTPat s
-- TODO - custom error
toE (Left e) = E.throw $ TidalParseError {parsecError = e, code = s}
toE (Right tp) = toPat tp
parseTPat :: Parseable a => String -> Either ParseError (TPat a)
parseTPat = parseRhythm tPatParser
class Parseable a where
tPatParser :: Parser (TPat a)
doEuclid :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a
-- toEuclid :: a ->
class Enumerable a where
fromTo :: a -> a -> Pattern a
fromThenTo :: a -> a -> a -> Pattern a
instance Parseable Double where
tPatParser = pDouble
doEuclid = euclidOff
instance Enumerable Double where
fromTo = enumFromTo'
fromThenTo = enumFromThenTo'
instance Parseable String where
tPatParser = pVocable
doEuclid = euclidOff
instance Enumerable String where
fromTo a b = fastFromList [a,b]
fromThenTo a b c = fastFromList [a,b,c]
instance Parseable Bool where
tPatParser = pBool
doEuclid = euclidOffBool
instance Enumerable Bool where
fromTo a b = fastFromList [a,b]
fromThenTo a b c = fastFromList [a,b,c]
instance Parseable Int where
tPatParser = pIntegral
doEuclid = euclidOff
instance Enumerable Int where
fromTo = enumFromTo'
fromThenTo = enumFromThenTo'
instance Parseable Integer where
tPatParser = pIntegral
doEuclid = euclidOff
instance Enumerable Integer where
fromTo = enumFromTo'
fromThenTo = enumFromThenTo'
instance Parseable Rational where
tPatParser = pRational
doEuclid = euclidOff
instance Enumerable Rational where
fromTo = enumFromTo'
fromThenTo = enumFromThenTo'
enumFromTo' :: (Ord a, Enum a) => a -> a -> Pattern a
enumFromTo' a b | a > b = fastFromList $ reverse $ enumFromTo b a
| otherwise = fastFromList $ enumFromTo a b
enumFromThenTo'
:: (Ord a, Enum a, Num a) => a -> a -> a -> Pattern a
enumFromThenTo' a b c | a > c = fastFromList $ reverse $ enumFromThenTo c (c + (a-b)) a
| otherwise = fastFromList $ enumFromThenTo a b c
type ColourD = Colour Double
instance Parseable ColourD where
tPatParser = pColour
doEuclid = euclidOff
instance Enumerable ColourD where
fromTo a b = fastFromList [a,b]
fromThenTo a b c = fastFromList [a,b,c]
instance (Enumerable a, Parseable a) => IsString (Pattern a) where
fromString = parseBP_E
--instance (Parseable a, Pattern p) => IsString (p a) where
-- fromString = p :: String -> p a
lexer :: P.GenTokenParser String u Data.Functor.Identity.Identity
lexer = P.makeTokenParser haskellDef
braces, brackets, parens, angles:: Parser a -> Parser a
braces = P.braces lexer
brackets = P.brackets lexer
parens = P.parens lexer
angles = P.angles lexer
symbol :: String -> Parser String
symbol = P.symbol lexer
natural, integer :: Parser Integer
natural = P.natural lexer
integer = P.integer lexer
float :: Parser Double
float = P.float lexer
naturalOrFloat :: Parser (Either Integer Double)
naturalOrFloat = P.naturalOrFloat lexer
data Sign = Positive | Negative
applySign :: Num a => Sign -> a -> a
applySign Positive = id
applySign Negative = negate
sign :: Parser Sign
sign = do char '-'
return Negative
<|> do char '+'
return Positive
<|> return Positive
intOrFloat :: Parser Double
intOrFloat = do s <- sign
num <- naturalOrFloat
return (case num of
Right x -> applySign s x
Left x -> fromIntegral $ applySign s x
)
{-
r :: (Enumerable a, Parseable a) => String -> Pattern a -> IO (Pattern a)
r s orig = do E.handle
(\err -> do putStrLn (show (err :: E.SomeException))
return orig
)
(return $ p s)
-}
parseRhythm :: Parseable a => Parser (TPat a) -> String -> Either ParseError (TPat a)
parseRhythm f = parse (pSequence f') ""
where f' = f
<|> do symbol "~" "rest"
return TPat_Silence
pSequenceN :: Parseable a => Parser (TPat a) -> GenParser Char () (Int, TPat a)
pSequenceN f = do spaces
-- d <- pDensity
ps <- many $ do a <- pPart f
do Text.ParserCombinators.Parsec.try $ symbol ".."
b <- pPart f
return [TPat_EnumFromTo (TPat_Cat a) (TPat_Cat b)]
<|> return a
<|> do symbol "."
return [TPat_Foot]
<|> do es <- many1 (symbol "_")
return [TPat_Elongate (length es)]
let ps' = TPat_Cat $ map elongate $ splitFeet $ concat ps
extraElongate (TPat_Elongate n) = n-1
extraElongate _ = 0
sumElongates x = sum (map extraElongate x)
return (length ps + sumElongates (concat ps), ps')
elongate :: [TPat a] -> TPat a
elongate xs | any isElongate xs = TPat_TimeCat xs
| otherwise = TPat_Cat xs
where isElongate (TPat_Elongate _) = True
isElongate _ = False
{-
expandEnum :: Parseable t => Maybe (TPat t) -> [TPat t] -> [TPat t]
expandEnum a [] = [a]
expandEnum (Just a) (TPat_Enum:b:ps) = (TPat_EnumFromTo a b) : (expandEnum Nothing ps)
-- ignore ..s in other places
expandEnum a (TPat_Enum:ps) = expandEnum a ps
expandEnum (Just a) (b:ps) = a:(expandEnum b (Just c) ps)
expandEnum Nothing (c:ps) = expandEnum (Just c) ps
-}
-- could use splitOn here but `TPat a` isn't a member of `EQ`..
splitFeet :: [TPat t] -> [[TPat t]]
splitFeet [] = []
splitFeet 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''
pSequence :: Parseable a => Parser (TPat a) -> GenParser Char () (TPat a)
pSequence f = do (_, pat) <- pSequenceN f
return pat
pSingle :: Parser (TPat a) -> Parser (TPat a)
pSingle f = f >>= pRand >>= pMult
pPart :: Parseable a => Parser (TPat a) -> Parser [TPat a]
pPart f = do pt <- pSingle f <|> pPolyIn f <|> pPolyOut f
pt' <- pE pt
pt'' <- pRand pt'
spaces
pts <- pStretch pt
<|> pReplicate pt''
spaces
return pts
pPolyIn :: Parseable a => Parser (TPat a) -> Parser (TPat a)
pPolyIn f = do ps <- brackets (pSequence f `sepBy` symbol ",")
spaces
pMult $ TPat_Stack ps
pPolyOut :: Parseable a => Parser (TPat a) -> Parser (TPat a)
pPolyOut f = do ps <- braces (pSequenceN f `sepBy` symbol ",")
spaces
base <- do char '%'
spaces
i <- integer "integer"
return $ Just (fromIntegral i)
<|> return Nothing
pMult $ TPat_Stack $ scale' base ps
<|>
do ps <- angles (pSequenceN f `sepBy` symbol ",")
spaces
pMult $ TPat_Stack $ scale' (Just 1) ps
where scale' _ [] = []
scale' base pats@((n,_):_) = map (\(n',pat) -> TPat_Density (TPat_Atom $ fromIntegral (fromMaybe n base)/ fromIntegral n') pat) pats
pString :: Parser String
pString = do c <- (letter <|> oneOf "0123456789") "charnum"
cs <- many (letter <|> oneOf "0123456789:.-_") "string"
return (c:cs)
pVocable :: Parser (TPat String)
pVocable = TPat_Atom <$> pString
pDouble :: Parser (TPat Double)
pDouble = do f <- choice [intOrFloat, parseNote] "float"
do c <- parseChord
return $ TPat_Stack $ map (TPat_Atom . (+f)) c
<|> return (TPat_Atom f)
<|>
do c <- parseChord
return $ TPat_Stack $ map TPat_Atom c
pBool :: Parser (TPat Bool)
pBool = do oneOf "t1"
return $ TPat_Atom True
<|>
do oneOf "f0"
return $ TPat_Atom False
parseIntNote :: Integral i => Parser i
parseIntNote = do s <- sign
i <- choice [integer, parseNote]
return $ applySign s $ fromIntegral i
parseInt :: Parser Int
parseInt = do s <- sign
i <- integer
return $ applySign s $ fromIntegral i
pIntegral :: Integral a => Parser (TPat a)
pIntegral = do i <- parseIntNote
do c <- parseChord
return $ TPat_Stack $ map (TPat_Atom . (+i)) c
<|> return (TPat_Atom i)
<|>
do c <- parseChord
return $ TPat_Stack $ map TPat_Atom c
parseChord :: (Enum a, Num a) => Parser [a]
parseChord = do char '\''
name <- many1 $ letter <|> digit
let chord = fromMaybe [0] $ lookup name chordTable
do char '\''
i <- integer "chord range"
let chord' = take (fromIntegral i) $ concatMap (\x -> map (+ x) chord) [0,12..]
return chord'
<|> return chord
parseNote :: Num a => Parser a
parseNote = do n <- notenum
modifiers <- many noteModifier
octave <- option 5 natural
let n' = foldr (+) n modifiers
return $ fromIntegral $ n' + ((octave-5)*12)
where
notenum :: Parser Integer
notenum = choice [char 'c' >> return 0,
char 'd' >> return 2,
char 'e' >> return 4,
char 'f' >> return 5,
char 'g' >> return 7,
char 'a' >> return 9,
char 'b' >> return 11
]
noteModifier :: Parser Integer
noteModifier = choice [char 's' >> return 1,
char 'f' >> return (-1),
char 'n' >> return 0
]
fromNote :: Num a => Pattern String -> Pattern a
fromNote pat = either (const 0) id . parse parseNote "" <$> pat
pColour :: Parser (TPat ColourD)
pColour = do name <- many1 letter "colour name"
colour <- readColourName name "known colour"
return $ TPat_Atom colour
pMult :: TPat a -> Parser (TPat a)
pMult thing = do char '*'
spaces
r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational
return $ TPat_Density r thing
<|>
do char '/'
spaces
r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational
return $ TPat_Slow r thing
<|>
return thing
pRand :: TPat a -> Parser (TPat a)
pRand thing = do char '?'
r <- float <|> return 0.5
spaces
return $ TPat_DegradeBy r thing
<|> return thing
pE :: TPat a -> Parser (TPat a)
pE thing = do (n,k,s) <- parens pair
pure $ TPat_pE n k s thing
<|> return thing
where pair :: Parser (TPat Int, TPat Int, TPat Int)
pair = do a <- pSequence pIntegral
spaces
symbol ","
spaces
b <- pSequence pIntegral
c <- do symbol ","
spaces
pSequence pIntegral
<|> return (TPat_Atom 0)
return (a, b, c)
pReplicate :: TPat a -> Parser [TPat a]
pReplicate thing =
do extras <- many $ do char '!'
-- if a number is given (without a space)slow 2 $ fast
-- replicate that number of times
n <- (read <$> many1 digit) <|> return (2 :: Int)
spaces
thing' <- pRand thing
-- -1 because we already have parsed the original one
return $ replicate (fromIntegral (n-1)) thing'
return (thing:concat extras)
pStretch :: TPat a -> Parser [TPat a]
pStretch thing =
do char '@'
n <- (read <$> many1 digit) <|> return 1
return $ map (\x -> TPat_Zoom (Arc (x%n) ((x+1)%n)) thing) [0 .. (n-1)]
pRatio :: Parser Rational
pRatio = do s <- sign
n <- natural
result <- do char '%'
d <- natural
return (n%d)
<|>
do char '.'
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)
return $ applySign s result
pRational :: Parser (TPat Rational)
pRational = TPat_Atom <$> pRatio
{-
pDensity :: Parser (Rational)
pDensity = angles (pRatio "ratio")
<|>
return (1 % 1)
-}
tidal-1.0.14/src/Sound/Tidal/MiniTidal.hs 0000644 0000000 0000000 00000054226 13504651510 016213 0 ustar 00 0000000 0000000 {-# LANGUAGE FlexibleInstances, TemplateHaskell #-}
module Sound.Tidal.MiniTidal (miniTidal,miniTidalIO,main) where
import Text.Parsec.Prim (parserZero)
import Text.ParserCombinators.Parsec
import Control.Monad (forever)
import Control.Applicative (liftA2)
-- import Language.Haskell.TH
import Sound.Tidal.Context (Pattern,ControlMap,ControlPattern,Enumerable,Parseable,Time,Arc,TPat,Stream)
import qualified Sound.Tidal.Context as T
import Sound.Tidal.MiniTidal.Token
import Sound.Tidal.MiniTidal.TH
-- This is depended upon by Estuary, and changes to its type will cause problems downstream for Estuary.
miniTidal :: String -> Either ParseError (Pattern ControlMap)
miniTidal = parse miniTidalParser "miniTidal"
miniTidalParser :: Parser ControlPattern
miniTidalParser = whiteSpace >> choice [
eof >> return T.silence,
do
x <- pattern
eof
return x
]
class MiniTidal a where
literal :: Parser a -- parse an individual pure value of this type
simplePattern :: Parser (Pattern a) -- any way of making this pattern that wouldn't require parentheses if it was an argument
complexPattern :: Parser (Pattern a) -- producing this pattern by way of unary functions with an argument of a different type
transformationWithArguments:: Parser (Pattern a -> Pattern a) -- producing this pattern by with unary functions that take same type
transformationWithoutArguments :: Parser (Pattern a -> Pattern a) -- also producing this pattern by unary functions of same type
mergeOperator :: Parser (Pattern a -> Pattern a -> Pattern a) -- operators for combining this type of pattern, eg. # or |>
binaryFunctions :: Parser (a -> a -> a) -- binary functions on pure values of this type, eg. (+) for Int or other Num instances
literalArg :: MiniTidal a => Parser a
literalArg = choice [
literal,
nestedParens literal,
try $ applied $ parensOrNot literal
]
listLiteralArg :: MiniTidal a => Parser [a]
listLiteralArg = brackets (commaSep $ parensOrNot literal)
pattern :: MiniTidal a => Parser (Pattern a)
pattern = chainl1 pattern' mergeOperator
pattern' :: MiniTidal a => Parser (Pattern a)
pattern' = choice [
nestedParens $ chainl1 pattern mergeOperator,
transformation <*> patternArg,
genericComplexPattern,
complexPattern,
simplePattern,
silence
]
patternArg :: MiniTidal a => Parser (Pattern a)
patternArg = choice [
try $ parensOrApplied $ chainl1 pattern mergeOperator,
try $ parensOrApplied $ transformation <*> patternArg,
try $ parensOrApplied genericComplexPattern,
try $ parensOrApplied complexPattern,
try $ appliedOrNot simplePattern,
appliedOrNot silence
]
transformation :: MiniTidal a => Parser (Pattern a -> Pattern a)
transformation = transformationWithArguments <|> transformationWithoutArguments
transformationArg :: MiniTidal a => Parser (Pattern a -> Pattern a)
transformationArg = choice [
try $ appliedOrNot $ transformationWithoutArguments,
parensOrApplied $ transformationWithArguments
]
listPatternArg :: MiniTidal a => Parser [Pattern a]
listPatternArg = try $ parensOrNot $ brackets (commaSep pattern)
listTransformationArg :: MiniTidal a => Parser [Pattern a -> Pattern a]
listTransformationArg = try $ parensOrNot $ brackets (commaSep transformation)
silence :: Parser (Pattern a)
silence = $(function "silence")
instance MiniTidal ControlMap where
literal = parserZero
simplePattern = parserZero
transformationWithArguments = p_p <|> pControl_pControl
transformationWithoutArguments = p_p_noArgs
complexPattern = specificControlPatterns
mergeOperator = controlPatternMergeOperator
binaryFunctions = parserZero
controlPatternMergeOperator :: Parser (ControlPattern -> ControlPattern -> ControlPattern)
controlPatternMergeOperator = choice [
$(op "#"),
$(op "|>"),
$(op "<|"),
$(op "|>"),
$(op "|<|"),
$(op "|+|"),
$(op "|-|"),
$(op "|*|"),
$(op "|/|")
]
specificControlPatterns :: Parser ControlPattern
specificControlPatterns = choice [
try $ parens specificControlPatterns,
$(function "coarse") <*> patternArg,
$(function "cut") <*> patternArg,
$(function "n") <*> patternArg,
$(function "up") <*> patternArg,
$(function "speed") <*> patternArg,
$(function "pan") <*> patternArg,
$(function "shape") <*> patternArg,
$(function "gain") <*> patternArg,
$(function "accelerate") <*> patternArg,
$(function "bandf") <*> patternArg,
$(function "bandq") <*> patternArg,
$(function "begin") <*> patternArg,
$(function "crush") <*> patternArg,
$(function "cutoff") <*> patternArg,
$(function "delayfeedback") <*> patternArg,
$(function "delaytime") <*> patternArg,
$(function "delay") <*> patternArg,
$(function "end") <*> patternArg,
$(function "hcutoff") <*> patternArg,
$(function "hresonance") <*> patternArg,
$(function "resonance") <*> patternArg,
$(function "shape") <*> patternArg,
$(function "loop") <*> patternArg,
$(function "s") <*> patternArg,
$(function "sound") <*> patternArg,
$(function "vowel") <*> patternArg,
$(function "unit") <*> patternArg,
$(function "note") <*> patternArg
]
genericComplexPattern :: MiniTidal a => Parser (Pattern a)
genericComplexPattern = choice [
try $ parens genericComplexPattern,
lp_p <*> listPatternArg,
l_p <*> listLiteralArg,
pInt_p <*> patternArg
]
p_p_noArgs :: Parser (Pattern a -> Pattern a)
p_p_noArgs = choice [
$(function "brak"),
$(function "rev"),
$(function "palindrome"),
$(function "stretch"),
$(function "loopFirst"),
$(function "degrade")
]
p_p :: (MiniTidal a, MiniTidal a) => Parser (Pattern a -> Pattern a)
p_p = choice [
try $ parens p_p,
p_p_p <*> patternArg,
t_p_p <*> transformationArg,
lp_p_p <*> listPatternArg,
lt_p_p <*> listTransformationArg,
lpInt_p_p <*> listPatternArg,
pTime_p_p <*> patternArg,
pInt_p_p <*> patternArg,
pString_p_p <*> patternArg,
pDouble_p_p <*> patternArg,
vTime_p_p <*> literalArg,
vInt_p_p <*> literalArg,
vTimeTime_p_p <*> literalArg,
pDouble_p_p <*> patternArg,
lTime_p_p <*> listLiteralArg
]
lt_p_p :: MiniTidal a => Parser ([t -> Pattern a] -> t -> Pattern a)
lt_p_p = choice [
try $ parens lt_p_p,
spreads <*> (nestedParens $ reservedOp "$" >> return ($))
]
l_p :: MiniTidal a => Parser ([a] -> Pattern a)
l_p = choice [
$(function "listToPat"),
$(function "choose"),
$(function "cycleChoose")
]
lp_p :: MiniTidal a => Parser ([Pattern a] -> Pattern a)
lp_p = choice [
$(function "stack"),
$(function "fastcat"),
$(function "slowcat"),
$(function "cat"),
$(function "randcat")
]
pInt_p :: MiniTidal a => Parser (Pattern Int -> Pattern a)
pInt_p = choice [
try $ parens pInt_p,
l_pInt_p <*> listLiteralArg
]
p_p_p :: MiniTidal a => Parser (Pattern a -> Pattern a -> Pattern a)
p_p_p = choice [
try $ parens p_p_p,
liftA2 <$> binaryFunctions,
$(function "overlay"),
$(function "append"),
vTime_p_p_p <*> literalArg,
pInt_p_p_p <*> patternArg
]
pTime_p_p :: MiniTidal a => Parser (Pattern Time -> Pattern a -> Pattern a)
pTime_p_p = choice [
try $ parens pTime_p_p,
$(function "fast"),
$(function "fastGap"),
$(function "density"),
$(function "slow"),
$(function "trunc"),
$(function "fastGap"),
$(function "densityGap"),
$(function "sparsity"),
$(function "trunc"),
$(function "linger"),
$(function "segment"),
$(function "discretise"),
$(function "timeLoop"),
$(function "swing"),
pTime_pTime_p_p <*> patternArg
]
lTime_p_p :: MiniTidal a => Parser ([Time] -> Pattern a -> Pattern a)
lTime_p_p = choice [
try $ parens lTime_p_p,
$(function "spaceOut"),
spreads <*> parens vTime_p_p -- re: spread
]
spreads :: MiniTidal a => Parser ((b -> t -> Pattern a) -> [b] -> t -> Pattern a)
spreads = choice [
$(function "spread"),
$(function "slowspread"),
$(function "fastspread")
]
pInt_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern a -> Pattern a)
pInt_p_p = choice [
try $ parens pInt_p_p,
$(function "iter"),
$(function "iter'"),
$(function "ply"),
$(function "substruct'"),
$(function "slowstripe"),
$(function "shuffle"),
$(function "scramble"),
pInt_pInt_p_p <*> patternArg
]
pString_p_p :: MiniTidal a => Parser (Pattern String -> Pattern a -> Pattern a)
pString_p_p = $(function "substruct")
pDouble_p_p :: MiniTidal a => Parser (Pattern Double -> Pattern a -> Pattern a)
pDouble_p_p = choice [
try $ parens pDouble_p_p,
$(function "degradeBy"),
$(function "unDegradeBy"),
vInt_pDouble_p_p <*> literalArg
]
vTime_p_p :: MiniTidal a => Parser (Time -> Pattern a -> Pattern a)
vTime_p_p = choice [
try $ parens vTime_p_p,
$(function "rotL"),
$(function "rotR"),
vTime_vTime_p_p <*> literalArg
]
vInt_p_p :: MiniTidal a => Parser (Int -> Pattern a -> Pattern a)
vInt_p_p = $(function "repeatCycles")
vTimeTime_p_p :: MiniTidal a => Parser ((Time,Time) -> Pattern a -> Pattern a)
vTimeTime_p_p = choice [
$(function "compress"),
$(function "zoom"),
$(function "compressTo")
]
t_p_p :: MiniTidal a => Parser ((Pattern a -> Pattern a) -> Pattern a -> Pattern a)
t_p_p = choice [
try $ parens t_p_p,
$(function "sometimes"),
$(function "often"),
$(function "rarely"),
$(function "almostNever"),
$(function "almostAlways"),
$(function "never"),
$(function "always"),
$(function "superimpose"),
$(function "someCycles"),
pInt_t_p_p <*> patternArg,
pDouble_t_p_p <*> patternArg,
lvInt_t_p_p <*> listLiteralArg,
vInt_t_p_p <*> literalArg,
vDouble_t_p_p <*> literalArg,
vTimeTime_t_p_p <*> literalArg
]
lpInt_p_p :: MiniTidal a => Parser ([Pattern Int] -> Pattern a -> Pattern a)
lpInt_p_p = $(function "distrib")
lp_p_p :: MiniTidal a => Parser ([Pattern a] -> Pattern a -> Pattern a)
lp_p_p = choice [
try $ parens lp_p_p,
try $ spreads <*> parens p_p_p
]
l_pInt_p :: MiniTidal a => Parser ([a] -> Pattern Int -> Pattern a)
l_pInt_p = choice [
try $ parens l_pInt_p,
vInt_l_pInt_p <*> literalArg
]
vInt_l_pInt_p :: MiniTidal a => Parser (Int -> [a] -> Pattern Int -> Pattern a)
vInt_l_pInt_p = $(function "fit")
vTime_p_p_p :: MiniTidal a => Parser (Time -> Pattern a -> Pattern a -> Pattern a)
vTime_p_p_p = $(function "wedge")
vInt_pDouble_p_p :: MiniTidal a => Parser (Int -> Pattern Double -> Pattern a -> Pattern a)
vInt_pDouble_p_p = $(function "degradeOverBy")
pInt_t_p_p :: MiniTidal a => Parser (Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)
pInt_t_p_p = choice [
try $ parens pInt_t_p_p,
$(function "every"),
pInt_pInt_t_p_p <*> patternArg
]
pDouble_t_p_p :: MiniTidal a => Parser (Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)
pDouble_t_p_p = $(function "sometimesBy")
lvInt_t_p_p :: MiniTidal a => Parser ([Int] -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)
lvInt_t_p_p = $(function "foldEvery")
vTime_vTime_p_p :: MiniTidal a => Parser (Time -> Time -> Pattern a -> Pattern a)
vTime_vTime_p_p = $(function "playFor")
vTimeTime_t_p_p :: MiniTidal a => Parser ((Time,Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)
vTimeTime_t_p_p = $(function "within")
vInt_t_p_p :: MiniTidal a => Parser (Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)
vInt_t_p_p = choice [
try $ parens vInt_t_p_p,
$(function "chunk"),
vInt_vInt_t_p_p <*> literalArg
]
vDouble_t_p_p :: MiniTidal a => Parser (Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)
vDouble_t_p_p = $(function "someCyclesBy")
pInt_pInt_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern Int -> Pattern a -> Pattern a)
pInt_pInt_p_p = choice [
try $ parens pInt_pInt_p_p,
$(function "euclid"),
$(function "euclidInv"),
vInt_pInt_pInt_p_p <*> literalArg
]
pTime_pTime_p_p :: MiniTidal a => Parser (Pattern Time -> Pattern Time -> Pattern a -> Pattern a)
pTime_pTime_p_p = $(function "swingBy")
pInt_pInt_t_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)
pInt_pInt_t_p_p = $(function "every'")
vInt_vInt_t_p_p :: MiniTidal a => Parser (Int -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)
vInt_vInt_t_p_p = $(function "whenmod")
pInt_p_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern a -> Pattern a -> Pattern a)
pInt_p_p_p = choice [
try $ parens pInt_p_p_p,
pInt_pInt_p_p_p <*> patternArg
]
pInt_pInt_p_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a)
pInt_pInt_p_p_p = $(function "euclidFull")
vInt_pInt_pInt_p_p :: MiniTidal a => Parser (Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a)
vInt_pInt_pInt_p_p = choice [
try $ parens vInt_pInt_pInt_p_p,
pTime_vInt_pInt_pInt_p_p <*> patternArg
]
pTime_vInt_pInt_pInt_p_p :: MiniTidal a => Parser (Pattern Time -> Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a)
pTime_vInt_pInt_pInt_p_p = $(function "fit'")
pControl_pControl :: Parser (ControlPattern -> ControlPattern)
pControl_pControl = choice [
try $ parens pControl_pControl,
pInt_pControl_pControl <*> patternArg,
pDouble_pControl_pControl <*> patternArg,
pTime_pControl_pControl <*> patternArg,
tControl_pControl_pControl <*> transformationArg
]
tControl_pControl_pControl :: Parser ((ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern)
tControl_pControl_pControl = $(function "jux")
pInt_pControl_pControl :: Parser (Pattern Int -> ControlPattern -> ControlPattern)
pInt_pControl_pControl = choice [
$(function "chop"),
$(function "striate")
]
pDouble_pControl_pControl :: Parser (Pattern Double -> ControlPattern -> ControlPattern)
pDouble_pControl_pControl = choice [
try $ parens pDouble_pControl_pControl,
pInt_pDouble_pControl_pControl <*> patternArg
]
pInt_pDouble_pControl_pControl :: Parser (Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern)
pInt_pDouble_pControl_pControl = $(function "striate'")
pTime_pControl_pControl :: Parser (Pattern Time -> ControlPattern -> ControlPattern)
pTime_pControl_pControl = choice [
try $ parens pTime_pControl_pControl,
pDouble_pTime_pControl_pControl <*> patternArg
]
pDouble_pTime_pControl_pControl :: Parser (Pattern Double -> Pattern Time -> ControlPattern -> ControlPattern)
pDouble_pTime_pControl_pControl = choice [
try $ parens pDouble_pTime_pControl_pControl,
pInteger_pDouble_pTime_pControl_pControl <*> patternArg
]
pInteger_pDouble_pTime_pControl_pControl :: Parser (Pattern Integer -> Pattern Double -> Pattern Time -> ControlPattern -> ControlPattern)
pInteger_pDouble_pTime_pControl_pControl = $(function "stut")
simpleDoublePatterns :: Parser (Pattern Double)
simpleDoublePatterns = choice [
$(function "rand"),
$(function "sine"),
$(function "saw"),
$(function "isaw"),
$(function "tri"),
$(function "square"),
$(function "cosine")
]
binaryNumFunctions :: Num a => Parser (a -> a -> a)
binaryNumFunctions = choice [
try $ parens binaryNumFunctions,
reservedOp "+" >> return (+),
reservedOp "-" >> return (-),
reservedOp "*" >> return (*)
]
instance MiniTidal Int where
literal = int
simplePattern = parseBP' <|> (pure <$> int)
transformationWithArguments = p_p_noArgs
transformationWithoutArguments = p_p
complexPattern = (atom <*> int) <|> enumComplexPatterns <|> numComplexPatterns <|> intComplexPatterns
mergeOperator = numMergeOperator
binaryFunctions = binaryNumFunctions
instance MiniTidal Integer where
literal = integer
simplePattern = parseBP' <|> (pure <$> integer)
transformationWithArguments = p_p_noArgs
transformationWithoutArguments = p_p
complexPattern = (atom <*> integer) <|> enumComplexPatterns <|> numComplexPatterns
mergeOperator = numMergeOperator
binaryFunctions = binaryNumFunctions
instance MiniTidal Double where
literal = double
simplePattern = parseBP' <|> (try $ pure <$> double) <|> simpleDoublePatterns
transformationWithArguments = p_p_noArgs
transformationWithoutArguments = p_p
complexPattern = (atom <*> double) <|> enumComplexPatterns <|> numComplexPatterns
mergeOperator = numMergeOperator <|> fractionalMergeOperator
binaryFunctions = binaryNumFunctions
instance MiniTidal Time where
literal = (toRational <$> double) <|> (fromIntegral <$> integer)
simplePattern = parseBP' <|> (pure <$> literal)
transformationWithArguments = p_p_noArgs
transformationWithoutArguments = p_p
complexPattern = atom <*> literal <|> numComplexPatterns
mergeOperator = numMergeOperator <|> fractionalMergeOperator
binaryFunctions = binaryNumFunctions
instance MiniTidal Arc where
literal = do
xs <- parens (commaSep1 literal)
if length xs == 2 then return (T.Arc (xs!!0) (xs!!1)) else unexpected "Arcs must contain exactly two values"
simplePattern = pure <$> literal
transformationWithArguments = p_p_noArgs
transformationWithoutArguments = p_p
complexPattern = atom <*> literal
mergeOperator = parserZero
binaryFunctions = parserZero
instance MiniTidal (Time,Time) where
literal = do
xs <- parens (commaSep1 literal)
if length xs == 2 then return ((xs!!0),(xs!!1)) else unexpected "(Time,Time) must contain exactly two values"
simplePattern = pure <$> literal
transformationWithArguments = p_p_noArgs
transformationWithoutArguments = p_p
complexPattern = atom <*> literal
mergeOperator = parserZero
binaryFunctions = parserZero
instance MiniTidal String where
literal = stringLiteral
simplePattern = parseBP'
transformationWithArguments = p_p_noArgs
transformationWithoutArguments = p_p
complexPattern = atom <*> stringLiteral
mergeOperator = parserZero
binaryFunctions = parserZero
fractionalMergeOperator :: Fractional a => Parser (Pattern a -> Pattern a -> Pattern a)
fractionalMergeOperator = opParser "/" >> return (/)
numMergeOperator :: Num a => Parser (Pattern a -> Pattern a -> Pattern a)
numMergeOperator = choice [
opParser "+" >> return (+),
opParser "-" >> return (-),
opParser "*" >> return (*)
]
enumComplexPatterns :: (Enum a, Num a, MiniTidal a) => Parser (Pattern a)
enumComplexPatterns = choice [
$(function "run") <*> patternArg,
$(function "scan") <*> patternArg
]
numComplexPatterns :: (Num a, MiniTidal a) => Parser (Pattern a)
numComplexPatterns = choice [
$(function "irand") <*> literal,
$(function "toScale'") <*> literalArg <*> listLiteralArg <*> patternArg,
$(function "toScale") <*> listLiteralArg <*> patternArg
]
intComplexPatterns :: Parser (Pattern Int)
intComplexPatterns = choice [
$(function "randStruct") <*> literalArg
]
atom :: Applicative m => Parser (a -> m a)
atom = (functionParser "pure" <|> functionParser "atom" <|> functionParser "return") >> return (pure)
parseBP' :: (Enumerable a, Parseable a) => Parser (Pattern a)
parseBP' = parseTPat' >>= return . T.toPat
parseTPat' :: Parseable a => Parser (TPat a)
parseTPat' = parseRhythm' T.tPatParser
parseRhythm' :: Parseable a => Parser (TPat a) -> Parser (TPat a)
parseRhythm' f = do
char '\"' >> whiteSpace
x <- T.pSequence f'
char '\"' >> whiteSpace
return x
where f' = f
<|> do _ <- symbol "~" "rest"
return T.TPat_Silence
miniTidalIO :: Stream -> String -> Either ParseError (IO ())
miniTidalIO tidal = parse (miniTidalIOParser tidal) "miniTidal"
miniTidalIOParser :: Stream -> Parser (IO ())
miniTidalIOParser tidal = whiteSpace >> choice [
eof >> return (return ()),
dParser tidal <*> patternArg
{- tParser tidal <*> transitionArg tidal <*> patternArg, -}
-- (reserved "setcps" >> return (T.streamOnce tidal True . T.cps)) <*> literalArg
]
dParser :: Stream -> Parser (ControlPattern -> IO ())
dParser tidal = choice [
reserved "d1" >> return (T.streamReplace tidal "1"),
reserved "d2" >> return (T.streamReplace tidal "2"),
reserved "d3" >> return (T.streamReplace tidal "3"),
reserved "d4" >> return (T.streamReplace tidal "4"),
reserved "d5" >> return (T.streamReplace tidal "5"),
reserved "d6" >> return (T.streamReplace tidal "6"),
reserved "d7" >> return (T.streamReplace tidal "7"),
reserved "d8" >> return (T.streamReplace tidal "8"),
reserved "d9" >> return (T.streamReplace tidal "9"),
reserved "d10" >> return (T.streamReplace tidal "10"),
reserved "d11" >> return (T.streamReplace tidal "11"),
reserved "d12" >> return (T.streamReplace tidal "12"),
reserved "d13" >> return (T.streamReplace tidal "13"),
reserved "d14" >> return (T.streamReplace tidal "14"),
reserved "d15" >> return (T.streamReplace tidal "15"),
reserved "d16" >> return (T.streamReplace tidal "16")
]
{- tParser :: Stream -> Parser ((Time -> [ControlPattern] -> ControlPattern) -> ControlPattern -> IO ())
tParser tidal = choice [
reserved "t1" >> return ((ts tidal)!!0),
reserved "t2" >> return ((ts tidal)!!1),
reserved "t3" >> return ((ts tidal)!!2),
reserved "t4" >> return ((ts tidal)!!3),
reserved "t5" >> return ((ts tidal)!!4),
reserved "t6" >> return ((ts tidal)!!5),
reserved "t7" >> return ((ts tidal)!!6),
reserved "t8" >> return ((ts tidal)!!7),
reserved "t9" >> return ((ts tidal)!!8)
] -}
{- transitionArg :: Stream -> Parser (Time -> [ControlPattern] -> ControlPattern)
transitionArg tidal = choice [
parensOrApplied $ (reserved "xfadeIn" >> return (T.transition tidal . T.xfadeIn)) <*> literalArg
] -}
-- below is a stand-alone Tidal interpreter
-- can be compiled, for example, with: ghc --make Sound/Tidal/MiniTidal.hs -main-is Sound.Tidal.MiniTidal -o miniTidal
main :: IO ()
main = do
putStrLn "miniTidal"
tidal <- T.startTidal T.superdirtTarget T.defaultConfig
forever $ do
cmd <- miniTidalIO tidal <$> getLine
either (\x -> putStrLn $ "error: " ++ show x) id cmd
-- things whose status in new tidal we are unsure of
--(function "within'" >> return T.within') <*> literalArg <*> transformationArg,
-- (function "revArc" >> return T.revArc) <*> literalArg,
-- (function "prr" >> return T.prr) <*> literalArg <*> literalArg <*> patternArg,
-- (function "preplace" >> return T.preplace) <*> literalArg <*> patternArg,
-- (function "prep" >> return T.prep) <*> literalArg <*> patternArg,
-- (function "preplace1" >> return T.preplace1) <*> patternArg,
-- (function "protate" >> return T.protate) <*> literalArg <*> literalArg,
-- (function "prot" >> return T.prot) <*> literalArg <*> literalArg,
-- (function "prot1" >> return T.prot1) <*> literalArg,
-- (function "fill" >> return T.fill) <*> patternArg,
--function "struct" >> return T.struct,
-- (function "sliceArc" >> return T.sliceArc) <*> literalArg
-- function "breakUp" >> return T.breakUp, -- removed from new Tidal?
tidal-1.0.14/src/Sound/Tidal/Chords.hs 0000644 0000000 0000000 00000012430 13504651510 015552 0 ustar 00 0000000 0000000 module Sound.Tidal.Chords where
import Data.Maybe
import Sound.Tidal.Pattern
major :: Num a => [a]
major = [0,4,7]
minor :: Num a => [a]
minor = [0,3,7]
major7 :: Num a => [a]
major7 = [0,4,7,11]
dom7 :: Num a => [a]
dom7 = [0,4,7,10]
minor7 :: Num a => [a]
minor7 = [0,3,7,10]
aug :: Num a => [a]
aug = [0,4,8]
dim :: Num a => [a]
dim = [0,3,6]
dim7 :: Num a => [a]
dim7 = [0,3,6,9]
one :: Num a => [a]
one = [0]
five :: Num a => [a]
five = [0,7]
plus :: Num a => [a]
plus = [0,4,8]
sharp5 :: Num a => [a]
sharp5 = [0,4,8]
msharp5 :: Num a => [a]
msharp5 = [0,3,8]
sus2 :: Num a => [a]
sus2 = [0,2,7]
sus4 :: Num a => [a]
sus4 = [0,5,7]
six :: Num a => [a]
six = [0,4,7,9]
m6 :: Num a => [a]
m6 = [0,3,7,9]
sevenSus2 :: Num a => [a]
sevenSus2 = [0,2,7,10]
sevenSus4 :: Num a => [a]
sevenSus4 = [0,5,7,10]
sevenFlat5 :: Num a => [a]
sevenFlat5 = [0,4,6,10]
m7flat5 :: Num a => [a]
m7flat5 = [0,3,6,10]
sevenSharp5 :: Num a => [a]
sevenSharp5 = [0,4,8,10]
m7sharp5 :: Num a => [a]
m7sharp5 = [0,3,8,10]
nine :: Num a => [a]
nine = [0,4,7,10,14]
m9 :: Num a => [a]
m9 = [0,3,7,10,14]
m7sharp9 :: Num a => [a]
m7sharp9 = [0,3,7,10,14]
maj9 :: Num a => [a]
maj9 = [0,4,7,11,14]
nineSus4 :: Num a => [a]
nineSus4 = [0,5,7,10,14]
sixby9 :: Num a => [a]
sixby9 = [0,4,7,9,14]
m6by9 :: Num a => [a]
m6by9 = [0,3,9,7,14]
sevenFlat9 :: Num a => [a]
sevenFlat9 = [0,4,7,10,13]
m7flat9 :: Num a => [a]
m7flat9 = [0,3,7,10,13]
sevenFlat10 :: Num a => [a]
sevenFlat10 = [0,4,7,10,15]
nineSharp5 :: Num a => [a]
nineSharp5 = [0,1,13]
m9sharp5 :: Num a => [a]
m9sharp5 = [0,1,14]
sevenSharp5flat9 :: Num a => [a]
sevenSharp5flat9 = [0,4,8,10,13]
m7sharp5flat9 :: Num a => [a]
m7sharp5flat9 = [0,3,8,10,13]
eleven :: Num a => [a]
eleven = [0,4,7,10,14,17]
m11 :: Num a => [a]
m11 = [0,3,7,10,14,17]
maj11 :: Num a => [a]
maj11 = [0,4,7,11,14,17]
elevenSharp :: Num a => [a]
elevenSharp = [0,4,7,10,14,18]
m11sharp :: Num a => [a]
m11sharp = [0,3,7,10,14,18]
thirteen :: Num a => [a]
thirteen = [0,4,7,10,14,17,21]
m13 :: Num a => [a]
m13 = [0,3,7,10,14,17,21]
-- | @chordate cs m n@ selects the @n@th "chord" (a chord is a list of Ints)
-- from a list of chords @cs@ and transposes it by @m@
-- chordate :: Num b => [[b]] -> b -> Int -> [b]
-- chordate cs m n = map (+m) $ cs!!n
-- | @enchord chords pn pc@ turns every note in the note pattern @pn@ into
-- a chord, selecting from the chord lists @chords@ using the index pattern
-- @pc@. For example, @Chords.enchord [Chords.major Chords.minor] "c g" "0 1"@
-- will create a pattern of a C-major chord followed by a G-minor chord.
-- enchord :: Num a => [[a]] -> Pattern a -> Pattern Int -> Pattern a
-- enchord chords pn pc = flatpat $ (chordate chords) <$> pn <*> pc
chordTable :: Num a => [(String, [a])]
chordTable = [("major", major),
("maj", major),
("minor", minor),
("min", minor),
("aug", aug),
("dim", dim),
("major7", major7),
("maj7", major7),
("dom7", dom7),
("minor7", minor7),
("min7", minor7),
("dim7", dim7),
("one", one),
("1", one),
("five", five),
("5", five),
("plus", plus),
("sharp5", sharp5),
("msharp5", msharp5),
("sus2", sus2),
("sus4", sus4),
("six", six),
("6", six),
("m6", m6),
("sevenSus2", sevenSus2),
("7sus2", sevenSus2),
("sevenSus4", sevenSus4),
("7sus4", sevenSus4),
("sevenFlat5", sevenFlat5),
("7f5", sevenFlat5),
("m7flat5", m7flat5),
("m7f5", m7flat5),
("sevenSharp5", sevenSharp5),
("7s5", sevenSharp5),
("m7sharp5", m7sharp5),
("m7s5", m7sharp5),
("nine", nine),
("m9", m9),
("m7sharp9", m7sharp9),
("m7s9", m7sharp9),
("maj9", maj9),
("nineSus4", nineSus4),
("ninesus4", nineSus4),
("9sus4", nineSus4),
("sixby9", sixby9),
("6by9", sixby9),
("m6by9", m6by9),
("sevenFlat9", sevenFlat9),
("7f9", sevenFlat9),
("m7flat9", m7flat9),
("m7f9", m7flat9),
("sevenFlat10", sevenFlat10),
("7f10", sevenFlat10),
("nineSharp5", nineSharp5),
("9s5", nineSharp5),
("m9sharp5", m9sharp5),
("m9s5", m9sharp5),
("sevenSharp5flat9", sevenSharp5flat9),
("7s5f9", sevenSharp5flat9),
("m7sharp5flat9", m7sharp5flat9),
("eleven", eleven),
("11", eleven),
("m11", m11),
("maj11", maj11),
("elevenSharp", elevenSharp),
("11s", elevenSharp),
("m11sharp", m11sharp),
("m11s", m11sharp),
("thirteen", thirteen),
("13", thirteen),
("m13", m13)
]
chordL :: Num a => Pattern String -> Pattern [a]
chordL p = (\name -> fromMaybe [] $ lookup name chordTable) <$> p
chordList :: String
chordList = unwords $ map fst (chordTable :: [(String, [Int])])
tidal-1.0.14/src/Sound/Tidal/Tempo.hs 0000644 0000000 0000000 00000020733 13504651510 015421 0 ustar 00 0000000 0000000 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module Sound.Tidal.Tempo where
-- import Data.Time (getCurrentTime, UTCTime, NominalDiffTime, diffUTCTime, addUTCTime)
-- import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Control.Concurrent.MVar
import qualified Sound.Tidal.Pattern as P
import qualified Sound.OSC.FD as O
-- import qualified Sound.OSC.Transport.FD.UDP as O
import qualified Network.Socket as N
import Control.Concurrent (forkIO, ThreadId, threadDelay)
import Control.Monad (forever, when, foldM)
import Data.List (isPrefixOf, nub)
import qualified Control.Exception as E
import Sound.Tidal.Config
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
-- sendTempo udp tempo remote_sockaddr
--
data State = State {ticks :: Int,
start :: O.Time,
nowTime :: O.Time,
nowArc :: P.Arc,
starting :: Bool
}
changeTempo :: MVar Tempo -> (O.Time -> Tempo -> Tempo) -> IO Tempo
changeTempo tempoMV f = do t <- O.time
tempo <- takeMVar tempoMV
let tempo' = f t $ tempo
sendTempo tempo'
putMVar tempoMV tempo'
return tempo'
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
})
defaultTempo :: O.Time -> O.UDP -> N.SockAddr -> Tempo
defaultTempo t local remote = Tempo {atTime = t,
atCycle = 0,
cps = 0.5625,
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
{-
getCurrentCycle :: MVar Tempo -> IO Rational
getCurrentCycle t = (readMVar t) >>= (cyclesNow) >>= (return . toRational)
-}
clocked :: Config -> (MVar Tempo -> State -> IO ()) -> IO (MVar Tempo, [ThreadId])
clocked config callback
= do s <- O.time
-- TODO - do something with thread id
_ <- serverListen config
(tempoMV, listenTid) <- clientListen config s
let st = State {ticks = 0,
start = s,
nowTime = s,
nowArc = P.Arc 0 0,
starting = True
}
clockTid <- forkIO $ loop tempoMV st
return (tempoMV, [listenTid, clockTid])
where loop tempoMV st =
do -- putStrLn $ show $ nowArc ts
tempo <- readMVar tempoMV
t <- O.time
let frameTimespan = cFrameTimespan config
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 4 or more
newTick | (abs $ actualTick - ticks st) > 4 = actualTick
| otherwise = (ticks st) + 1
st' = st {ticks = newTick,
nowArc = P.Arc s e,
starting = not (synched tempo)
}
callback tempoMV st'
loop tempoMV st'
clientListen :: Config -> O.Time -> IO (MVar Tempo, ThreadId)
clientListen config s =
do -- Listen on random port
let tempoClientPort = cTempoClientPort config
hostname = cTempoAddr config
port = cTempoPort config
(remote_addr:_) <- N.getAddrInfo Nothing (Just hostname) Nothing
local <- O.udpServer "0.0.0.0" tempoClientPort
let (N.SockAddrInet _ a) = N.addrAddress remote_addr
remote = N.SockAddrInet (fromIntegral port) a
t = defaultTempo s local remote
-- Send to clock port from same port that's listened to
O.sendTo local (O.p_message "/hello" []) remote
-- Make tempo mvar
tempoMV <- newMVar t
-- Listen to tempo changes
tempoChild <- forkIO $ listenTempo local tempoMV
return (tempoMV, tempoChild)
sendTempo :: Tempo -> IO ()
sendTempo tempo = O.sendTo (localUDP tempo) (O.p_bundle (atTime tempo) [m]) (remoteAddr tempo)
where m = O.Message "/transmit/cps/cycle" [O.Float $ fromRational $ atCycle tempo,
O.Float $ realToFrac $ cps tempo,
O.Int32 $ if paused tempo then 1 else 0
]
listenTempo :: O.UDP -> MVar Tempo -> IO ()
listenTempo udp tempoMV = forever $ do pkt <- O.recvPacket udp
act Nothing pkt
return ()
where act _ (O.Packet_Bundle (O.Bundle ts ms)) = mapM_ (act (Just ts) . O.Packet_Message) ms
act (Just ts) (O.Packet_Message (O.Message "/cps/cycle" [O.Float atCycle',
O.Float cps',
O.Int32 paused'
]
)
) =
do tempo <- takeMVar tempoMV
putMVar tempoMV $ tempo {atTime = ts,
atCycle = realToFrac atCycle',
cps = realToFrac cps',
paused = paused' == 1,
synched = True
}
act _ pkt = putStrLn $ "Unknown packet: " ++ show pkt
serverListen :: Config -> IO (Maybe ThreadId)
serverListen config = catchAny run (\_ -> do putStrLn "Tempo listener failed (is one already running?)"
return Nothing
)
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
tid <- forkIO $ loop udp []
return $ Just tid
loop udp cs = do (pkt,c) <- O.recvFrom udp
cs' <- act udp c Nothing cs pkt
loop udp cs'
act :: O.UDP -> N.SockAddr -> Maybe O.Time -> [N.SockAddr] -> O.Packet -> IO [N.SockAddr]
act udp c _ cs (O.Packet_Bundle (O.Bundle ts ms)) = foldM (act udp c (Just ts)) cs $ map O.Packet_Message ms
act _ c _ cs (O.Packet_Message (O.Message "/hello" []))
= return $ nub $ c:cs
act udp _ (Just ts) cs (O.Packet_Message (O.Message path params))
| "/transmit" `isPrefixOf` path =
do let path' = drop 9 path
msg = O.Message path' params
mapM_ (O.sendTo udp $ O.p_bundle ts [msg]) cs
return cs
act _ _ _ cs pkt = do putStrLn $ "Unknown packet: " ++ show pkt
return cs
catchAny :: IO a -> (E.SomeException -> IO a) -> IO a
catchAny = E.catch
tidal-1.0.14/src/Sound/Tidal/Transition.hs 0000644 0000000 0000000 00000017065 13504651510 016473 0 ustar 00 0000000 0000000 {-# 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'
calcOutput stream
return ()
where
appendPat flag = if flag then (pat:) else id
updatePS (Just playState) = playState {history = (appendPat historyFlag) (history playState)}
updatePS Nothing = PlayState {pattern = silence,
mute = False,
solo = False,
history = (appendPat historyFlag) (silence:[])
}
transition' context = do tempo <- readMVar $ sTempoMV stream
now <- O.time
let c = timeToCycles tempo now
return $ f c context
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:xs) = x
s = sam (now - fromIntegral (floor now `mod` floor t)) + 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.0.14/src/Sound/Tidal/EspGrid.hs 0000644 0000000 0000000 00000003567 13504651510 015700 0 ustar 00 0000000 0000000 {-# 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.0.14/src/Sound/Tidal/Control.hs 0000644 0000000 0000000 00000050676 13504651510 015766 0 ustar 00 0000000 0000000 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings, FlexibleContexts #-}
module Sound.Tidal.Control where
import Prelude hiding ((<*), (*>))
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, isJust, fromJust)
import Data.Ratio
import Sound.Tidal.Pattern
import Sound.Tidal.Core
import Sound.Tidal.UI
import qualified Sound.Tidal.Params as P
import Sound.Tidal.Utils
import Sound.Tidal.ParseBP (Parseable, Enumerable, parseBP_E)
{- | `spin` will "spin" a layer up a pattern the given number of times,
with each successive layer offset in time by an additional `1/n` of a
cycle, and panned by an additional `1/n`. The result is a pattern that
seems to spin around. This function works best on multichannel
systems.
@
d1 $ slow 3 $ spin 4 $ sound "drum*3 tabla:4 [arpy:2 ~ arpy] [can:2 can:3]"
@
-}
spin :: Pattern Int -> ControlPattern -> ControlPattern
spin = tParam _spin
_spin :: Int -> ControlPattern -> ControlPattern
_spin copies p =
stack $ map (\i -> let offset = toInteger i % toInteger copies in
offset `rotL` p
# P.pan (pure $ fromRational offset)
)
[0 .. (copies - 1)]
{- | `chop` granualizes every sample in place as it is played, turning a pattern of samples into a pattern of sample parts. Use an integer value to specify how many granules each sample is chopped into:
@
d1 $ chop 16 $ sound "arpy arp feel*4 arpy*4"
@
Different values of `chop` can yield very different results, depending
on the samples used:
@
d1 $ chop 16 $ sound (samples "arpy*8" (run 16))
d1 $ chop 32 $ sound (samples "arpy*8" (run 16))
d1 $ chop 256 $ sound "bd*4 [sn cp] [hh future]*2 [cp feel]"
@
-}
chop :: Pattern Int -> ControlPattern -> ControlPattern
chop = tParam _chop
chopArc :: Arc -> Int -> [Arc]
chopArc (Arc s e) n = map (\i -> Arc (s + (e-s)*(fromIntegral i/fromIntegral n)) (s + (e-s)*(fromIntegral (i+1) / fromIntegral n))) [0 .. n-1]
_chop :: Int -> ControlPattern -> ControlPattern
_chop n = withEvents (concatMap chopEvent)
where -- for each part,
chopEvent :: Event ControlMap -> [Event ControlMap]
chopEvent (Event w p' v) = map (chomp v (length $ chopArc w n)) $ arcs w p'
-- 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 :: ControlMap -> Int -> (Int, (Arc, Arc)) -> Event ControlMap
chomp v n' (i, (w,p')) = Event w p' (Map.insert "begin" (VF b') $ Map.insert "end" (VF e') v)
where b = fromMaybe 0 $ do v' <- Map.lookup "begin" v
getF v'
e = fromMaybe 1 $ do v' <- Map.lookup "end" v
getF v'
d = e-b
b' = ((fromIntegral i/fromIntegral n') * d) + b
e' = ((fromIntegral (i+1) / fromIntegral n') * d) + b
{-
-- A simpler definition than the above, but this version doesn't chop
-- with multiple chops, and only works with a single 'pure' event..
_chop' :: Int -> ControlPattern -> ControlPattern
_chop' n p = begin (fromList begins) # end (fromList ends) # p
where step = 1/(fromIntegral n)
begins = [0,step .. (1-step)]
ends = (tail begins) ++ [1]
-}
{- | Striate is a kind of granulator, for example:
@
d1 $ striate 3 $ sound "ho ho:2 ho:3 hc"
@
This plays the loop the given number of times, but triggering
progressive portions of each sample. So in this case it plays the loop
three times, the first time playing the first third of each sample,
then the second time playing the second third of each sample, etc..
With the highhat samples in the above example it sounds a bit like
reverb, but it isn't really.
You can also use striate with very long samples, to cut it into short
chunks and pattern those chunks. This is where things get towards
granular synthesis. The following cuts a sample into 128 parts, plays
it over 8 cycles and manipulates those parts by reversing and rotating
the loops.
@
d1 $ slow 8 $ striate 128 $ sound "bev"
@
-}
striate :: Pattern Int -> ControlPattern -> ControlPattern
striate = tParam _striate
_striate :: Int -> ControlPattern -> ControlPattern
_striate n p = fastcat $ map offset [0 .. n-1]
where offset i = mergePlayRange (fromIntegral i / fromIntegral n, fromIntegral (i+1) / fromIntegral n) <$> p
mergePlayRange :: (Double, Double) -> ControlMap -> ControlMap
mergePlayRange (b,e) cm = Map.insert "begin" (VF $ (b*d')+b') $ Map.insert "end" (VF $ (e*d')+b') cm
where b' = fromMaybe 0 $ Map.lookup "begin" cm >>= getF
e' = fromMaybe 1 $ Map.lookup "end" cm >>= getF
d' = e' - b'
{-|
The `striateBy` function is a variant of `striate` with an extra
parameter, which specifies the length of each part. The `striateBy`
function still scans across the sample over a single cycle, but if
each bit is longer, it creates a sort of stuttering effect. For
example the following will cut the bev sample into 32 parts, but each
will be 1/16th of a sample long:
@
d1 $ slow 32 $ striateBy 32 (1/16) $ sound "bev"
@
Note that `striate` uses the `begin` and `end` parameters
internally. This means that if you're using `striate` (or `striateBy`)
you probably shouldn't also specify `begin` or `end`. -}
striateBy :: Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern
striateBy = tParam2 _striateBy
-- Old name for striateBy, here as a deprecated alias for now.
striate' :: Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern
striate' = striateBy
_striateBy :: Int -> Double -> ControlPattern -> ControlPattern
_striateBy n f p = fastcat $ map (offset . fromIntegral) [0 .. n-1]
where offset i = p # P.begin (pure (slot * i) :: Pattern Double) # P.end (pure ((slot * i) + f) :: Pattern Double)
slot = (1 - f) / fromIntegral n
{- | `gap` is similar to `chop` in that it granualizes every sample in place as it is played,
but every other grain is silent. Use an integer value to specify how many granules
each sample is chopped into:
@
d1 $ gap 8 $ sound "jvbass"
d1 $ gap 16 $ sound "[jvbass drum:4]"
@-}
gap :: Pattern Int -> ControlPattern -> ControlPattern
gap = tParam _gap
_gap :: Int -> ControlPattern -> ControlPattern
_gap n p = _fast (toRational n) (cat [pure 1, silence]) |>| _chop n p
{- |
`weave` applies a function smoothly over an array of different patterns. It uses an `OscPattern` to
apply the function at different levels to each pattern, creating a weaving effect.
@
d1 $ weave 3 (shape $ sine1) [sound "bd [sn drum:2*2] bd*2 [sn drum:1]", sound "arpy*8 ~"]
@
-}
weave :: Time -> ControlPattern -> [ControlPattern] -> ControlPattern
weave t p ps = weave' t p (map (#) ps)
{- | `weaveWith` is similar in that it blends functions at the same time at different amounts over a pattern:
@
d1 $ weaveWith 3 (sound "bd [sn drum:2*2] bd*2 [sn drum:1]") [density 2, (# speed "0.5"), chop 16]
@
-}
weaveWith :: Time -> Pattern a -> [Pattern a -> Pattern a] -> Pattern a
weaveWith t p fs | l == 0 = silence
| otherwise = _slow t $ stack $ map (\(i, f) -> (fromIntegral i % l) `rotL` _fast t (f (_slow t p))) (zip [0 :: Int ..] fs)
where l = fromIntegral $ length fs
weave' :: Time -> Pattern a -> [Pattern a -> Pattern a] -> Pattern a
weave' = weaveWith
{- |
(A function that takes two ControlPatterns, and blends them together into
a new ControlPattern. An ControlPattern is basically a pattern of messages to
a synthesiser.)
Shifts between the two given patterns, using distortion.
Example:
@
d1 $ interlace (sound "bd sn kurt") (every 3 rev $ sound "bd sn:2")
@
-}
interlace :: ControlPattern -> ControlPattern -> ControlPattern
interlace a b = weave 16 (P.shape (sine * 0.9)) [a, b]
{-
{- | Just like `striate`, but also loops each sample chunk a number of times specified in the second argument.
The primed version is just like `striateBy`, where the loop count is the third argument. For example:
@
d1 $ striateL' 3 0.125 4 $ sound "feel sn:2"
@
Like `striate`, these use the `begin` and `end` parameters internally, as well as the `loop` parameter for these versions.
-}
striateL :: Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern
striateL = tParam2 _striateL
striateL' :: Pattern Int -> Pattern Double -> Pattern Int -> ControlPattern -> ControlPattern
striateL' = tParam3 _striateL'
_striateL :: Int -> Int -> ControlPattern -> ControlPattern
_striateL n l p = _striate n p # loop (pure $ fromIntegral l)
_striateL' n f l p = _striateBy n f p # loop (pure $ fromIntegral l)
en :: [(Int, Int)] -> Pattern String -> Pattern String
en ns p = stack $ map (\(i, (k, n)) -> _e k n (samples p (pure i))) $ enumerate ns
-}
slice :: Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern
slice pN pI p = P.begin b # P.end e # p
where b = div' <$> pI <* pN
e = (\i n -> div' i n + div' 1 n) <$> pI <* pN
div' num den = fromIntegral (num `mod` den) / fromIntegral den
_slice :: Int -> Int -> ControlPattern -> ControlPattern
_slice n i p =
p
# P.begin (pure $ fromIntegral i / fromIntegral n)
# P.end (pure $ fromIntegral (i+1) / fromIntegral n)
randslice :: Pattern Int -> ControlPattern -> ControlPattern
randslice = tParam $ \n p -> innerJoin $ (\i -> _slice n i p) <$> irand n
{- |
`loopAt` makes a sample fit the given number of cycles. Internally, it
works by setting the `unit` parameter to "c", changing the playback
speed of the sample with the `speed` parameter, and setting setting
the `density` of the pattern to match.
@
d1 $ loopAt 4 $ sound "breaks125"
d1 $ juxBy 0.6 (|* speed "2") $ slowspread (loopAt) [4,6,2,3] $ chop 12 $ sound "fm:14"
@
-}
loopAt :: Pattern Time -> ControlPattern -> ControlPattern
loopAt n p = slow n p |* P.speed (fromRational <$> (1/n)) # P.unit (pure "c")
hurry :: Pattern Rational -> ControlPattern -> ControlPattern
hurry x = (|* P.speed (fromRational <$> x)) . fast x
{- | Smash is a combination of `spread` and `striate` - it cuts the samples
into the given number of bits, and then cuts between playing the loop
at different speeds according to the values in the list.
So this:
@
d1 $ smash 3 [2,3,4] $ sound "ho ho:2 ho:3 hc"
@
Is a bit like this:
@
d1 $ spread (slow) [2,3,4] $ striate 3 $ sound "ho ho:2 ho:3 hc"
@
This is quite dancehall:
@
d1 $ (spread' slow "1%4 2 1 3" $ spread (striate) [2,3,4,1] $ sound
"sn:2 sid:3 cp sid:4")
# speed "[1 2 1 1]/2"
@
-}
smash :: Pattern Int -> [Pattern Time] -> ControlPattern -> Pattern ControlMap
smash n xs p = slowcat $ map (`slow` p') xs
where p' = striate n p
{- | an altenative form to `smash` is `smash'` which will use `chop` instead of `striate`.
-}
smash' :: Int -> [Pattern Time] -> ControlPattern -> Pattern ControlMap
smash' n xs p = slowcat $ map (`slow` p') xs
where p' = _chop n p
{- | Stut applies a type of delay to a pattern. It has three parameters,
which could be called depth, feedback and time. Depth is an integer
and the others floating point. This adds a bit of echo:
@
d1 $ stut 4 0.5 0.2 $ sound "bd sn"
@
The above results in 4 echos, each one 50% quieter than the last,
with 1/5th of a cycle between them. It is possible to reverse the echo:
@
d1 $ stut 4 0.5 (-0.2) $ sound "bd sn"
@
-}
stut :: Pattern Integer -> Pattern Double -> Pattern Rational -> ControlPattern -> ControlPattern
stut = tParam3 _stut
_stut :: Integer -> Double -> Rational -> ControlPattern -> ControlPattern
_stut count feedback steptime p = stack (p:map (\x -> ((x%1)*steptime) `rotR` (p |* P.gain (pure $ scalegain (fromIntegral x)))) [1..(count-1)])
where scalegain
= (+feedback) . (*(1-feedback)) . (/ fromIntegral count) . (fromIntegral count -)
{- | Instead of just decreasing volume to produce echoes, @stut'@ allows to apply a function for each step and overlays the result delayed by the given time.
@
d1 $ stut' 2 (1%3) (# vowel "{a e i o u}%2") $ sound "bd sn"
@
In this case there are two _overlays_ delayed by 1/3 of a cycle, where each has the @vowel@ filter applied.
-}
stutWith :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
stutWith n t f p = innerJoin $ (\a b -> _stutWith a b f p) <$> n <* t
_stutWith :: (Num n, Ord n) => n -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
_stutWith count steptime f p | count <= 1 = p
| otherwise = overlay (f (steptime `rotR` _stutWith (count-1) steptime f p)) p
-- | The old name for stutWith
stut' :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
stut' = stutWith
-- | Turns a pattern of seconds into a pattern of (rational) cycle durations
sec :: Fractional a => Pattern a -> Pattern a
sec p = (realToFrac <$> cF 1 "_cps") *| p
-- | Turns a pattern of milliseconds into a pattern of (rational)
-- cycle durations, according to the current cps.
msec :: Fractional a => Pattern a -> Pattern a
msec p = ((realToFrac . (/1000)) <$> cF 1 "_cps") *| p
trigger :: Show a => a -> Pattern b -> Pattern b
trigger k pat = pat {query = q}
where q st = query ((offset st) ~> pat) st
offset st = fromMaybe (pure 0) $ do pat <- Map.lookup ctrl (controls st)
return $ ((fromMaybe 0 . getR) <$> pat)
ctrl = "_t_" ++ show k
_getP_ :: (Value -> Maybe a) -> Pattern Value -> Pattern a
_getP_ f pat = filterJust $ f <$> pat
_getP :: a -> (Value -> Maybe a) -> Pattern Value -> Pattern a
_getP d f pat = (fromMaybe d . f) <$> pat
_cX :: a -> (Value -> Maybe a) -> String -> Pattern a
_cX d f s = Pattern Analog $ \(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 Analog $ \(State a m) -> queryArc (maybe silence (_getP_ f) $ Map.lookup s m) a
cF :: Double -> String -> Pattern Double
cF d = _cX d getF
cF_ :: String -> Pattern Double
cF_ = _cX_ getF
cF0 :: String -> Pattern Double
cF0 = _cX 0 getF
cI :: Int -> String -> Pattern Int
cI d = _cX d getI
cI_ :: String -> Pattern Int
cI_ = _cX_ getI
cI0 :: String -> Pattern Int
cI0 = _cX 0 getI
cB :: Bool -> String -> Pattern Bool
cB d = _cX d getB
cB_ :: String -> Pattern Bool
cB_ = _cX_ getB
cB0 :: String -> Pattern Bool
cB0 = _cX False getB
cR :: Rational -> String -> Pattern Rational
cR d = _cX d getR
cR_ :: String -> Pattern Rational
cR_ = _cX_ getR
cR0 :: String -> Pattern Rational
cR0 = _cX 0 getR
cT :: Time -> String -> Pattern Time
cT = cR
cT0 :: String -> Pattern Time
cT0 = cR0
cT_ :: String -> Pattern Time
cT_ = cR_
cS :: String -> String -> Pattern String
cS d = _cX d getS
cS_ :: String -> Pattern String
cS_ = _cX_ getS
cS0 :: String -> Pattern String
cS0 = _cX "" getS
cP :: String -> Pattern String
cP s = innerJoin $ parseBP_E <$> (_cX_ getS s)
-- Default controller inputs (for MIDI)
in0 :: Pattern Double
in0 = cF 0 "0"
in1 :: Pattern Double
in1 = cF 0 "1"
in2 :: Pattern Double
in2 = cF 0 "2"
in3 :: Pattern Double
in3 = cF 0 "3"
in4 :: Pattern Double
in4 = cF 0 "4"
in5 :: Pattern Double
in5 = cF 0 "5"
in6 :: Pattern Double
in6 = cF 0 "6"
in7 :: Pattern Double
in7 = cF 0 "7"
in8 :: Pattern Double
in8 = cF 0 "8"
in9 :: Pattern Double
in9 = cF 0 "9"
in10 :: Pattern Double
in10 = cF 0 "10"
in11 :: Pattern Double
in11 = cF 0 "11"
in12 :: Pattern Double
in12 = cF 0 "12"
in13 :: Pattern Double
in13 = cF 0 "13"
in14 :: Pattern Double
in14 = cF 0 "14"
in15 :: Pattern Double
in15 = cF 0 "15"
in16 :: Pattern Double
in16 = cF 0 "16"
in17 :: Pattern Double
in17 = cF 0 "17"
in18 :: Pattern Double
in18 = cF 0 "18"
in19 :: Pattern Double
in19 = cF 0 "19"
in20 :: Pattern Double
in20 = cF 0 "20"
in21 :: Pattern Double
in21 = cF 0 "21"
in22 :: Pattern Double
in22 = cF 0 "22"
in23 :: Pattern Double
in23 = cF 0 "23"
in24 :: Pattern Double
in24 = cF 0 "24"
in25 :: Pattern Double
in25 = cF 0 "25"
in26 :: Pattern Double
in26 = cF 0 "26"
in27 :: Pattern Double
in27 = cF 0 "27"
in28 :: Pattern Double
in28 = cF 0 "28"
in29 :: Pattern Double
in29 = cF 0 "29"
in30 :: Pattern Double
in30 = cF 0 "30"
in31 :: Pattern Double
in31 = cF 0 "31"
in32 :: Pattern Double
in32 = cF 0 "32"
in33 :: Pattern Double
in33 = cF 0 "33"
in34 :: Pattern Double
in34 = cF 0 "34"
in35 :: Pattern Double
in35 = cF 0 "35"
in36 :: Pattern Double
in36 = cF 0 "36"
in37 :: Pattern Double
in37 = cF 0 "37"
in38 :: Pattern Double
in38 = cF 0 "38"
in39 :: Pattern Double
in39 = cF 0 "39"
in40 :: Pattern Double
in40 = cF 0 "40"
in41 :: Pattern Double
in41 = cF 0 "41"
in42 :: Pattern Double
in42 = cF 0 "42"
in43 :: Pattern Double
in43 = cF 0 "43"
in44 :: Pattern Double
in44 = cF 0 "44"
in45 :: Pattern Double
in45 = cF 0 "45"
in46 :: Pattern Double
in46 = cF 0 "46"
in47 :: Pattern Double
in47 = cF 0 "47"
in48 :: Pattern Double
in48 = cF 0 "48"
in49 :: Pattern Double
in49 = cF 0 "49"
in50 :: Pattern Double
in50 = cF 0 "50"
in51 :: Pattern Double
in51 = cF 0 "51"
in52 :: Pattern Double
in52 = cF 0 "52"
in53 :: Pattern Double
in53 = cF 0 "53"
in54 :: Pattern Double
in54 = cF 0 "54"
in55 :: Pattern Double
in55 = cF 0 "55"
in56 :: Pattern Double
in56 = cF 0 "56"
in57 :: Pattern Double
in57 = cF 0 "57"
in58 :: Pattern Double
in58 = cF 0 "58"
in59 :: Pattern Double
in59 = cF 0 "59"
in60 :: Pattern Double
in60 = cF 0 "60"
in61 :: Pattern Double
in61 = cF 0 "61"
in62 :: Pattern Double
in62 = cF 0 "62"
in63 :: Pattern Double
in63 = cF 0 "63"
in64 :: Pattern Double
in64 = cF 0 "64"
in65 :: Pattern Double
in65 = cF 0 "65"
in66 :: Pattern Double
in66 = cF 0 "66"
in67 :: Pattern Double
in67 = cF 0 "67"
in68 :: Pattern Double
in68 = cF 0 "68"
in69 :: Pattern Double
in69 = cF 0 "69"
in70 :: Pattern Double
in70 = cF 0 "70"
in71 :: Pattern Double
in71 = cF 0 "71"
in72 :: Pattern Double
in72 = cF 0 "72"
in73 :: Pattern Double
in73 = cF 0 "73"
in74 :: Pattern Double
in74 = cF 0 "74"
in75 :: Pattern Double
in75 = cF 0 "75"
in76 :: Pattern Double
in76 = cF 0 "76"
in77 :: Pattern Double
in77 = cF 0 "77"
in78 :: Pattern Double
in78 = cF 0 "78"
in79 :: Pattern Double
in79 = cF 0 "79"
in80 :: Pattern Double
in80 = cF 0 "80"
in81 :: Pattern Double
in81 = cF 0 "81"
in82 :: Pattern Double
in82 = cF 0 "82"
in83 :: Pattern Double
in83 = cF 0 "83"
in84 :: Pattern Double
in84 = cF 0 "84"
in85 :: Pattern Double
in85 = cF 0 "85"
in86 :: Pattern Double
in86 = cF 0 "86"
in87 :: Pattern Double
in87 = cF 0 "87"
in88 :: Pattern Double
in88 = cF 0 "88"
in89 :: Pattern Double
in89 = cF 0 "89"
in90 :: Pattern Double
in90 = cF 0 "90"
in91 :: Pattern Double
in91 = cF 0 "91"
in92 :: Pattern Double
in92 = cF 0 "92"
in93 :: Pattern Double
in93 = cF 0 "93"
in94 :: Pattern Double
in94 = cF 0 "94"
in95 :: Pattern Double
in95 = cF 0 "95"
in96 :: Pattern Double
in96 = cF 0 "96"
in97 :: Pattern Double
in97 = cF 0 "97"
in98 :: Pattern Double
in98 = cF 0 "98"
in99 :: Pattern Double
in99 = cF 0 "99"
in100 :: Pattern Double
in100 = cF 0 "100"
in101 :: Pattern Double
in101 = cF 0 "101"
in102 :: Pattern Double
in102 = cF 0 "102"
in103 :: Pattern Double
in103 = cF 0 "103"
in104 :: Pattern Double
in104 = cF 0 "104"
in105 :: Pattern Double
in105 = cF 0 "105"
in106 :: Pattern Double
in106 = cF 0 "106"
in107 :: Pattern Double
in107 = cF 0 "107"
in108 :: Pattern Double
in108 = cF 0 "108"
in109 :: Pattern Double
in109 = cF 0 "109"
in110 :: Pattern Double
in110 = cF 0 "110"
in111 :: Pattern Double
in111 = cF 0 "111"
in112 :: Pattern Double
in112 = cF 0 "112"
in113 :: Pattern Double
in113 = cF 0 "113"
in114 :: Pattern Double
in114 = cF 0 "114"
in115 :: Pattern Double
in115 = cF 0 "115"
in116 :: Pattern Double
in116 = cF 0 "116"
in117 :: Pattern Double
in117 = cF 0 "117"
in118 :: Pattern Double
in118 = cF 0 "118"
in119 :: Pattern Double
in119 = cF 0 "119"
in120 :: Pattern Double
in120 = cF 0 "120"
in121 :: Pattern Double
in121 = cF 0 "121"
in122 :: Pattern Double
in122 = cF 0 "122"
in123 :: Pattern Double
in123 = cF 0 "123"
in124 :: Pattern Double
in124 = cF 0 "124"
in125 :: Pattern Double
in125 = cF 0 "125"
in126 :: Pattern Double
in126 = cF 0 "126"
in127 :: Pattern Double
in127 = cF 0 "127"
splice :: Int -> Pattern Int -> ControlPattern -> Pattern (Map.Map String Value)
splice bits ipat pat = withEvent f (slice (pure bits) ipat pat) # P.unit "c"
where f ev = ev {value = Map.insert "speed" (VF d) (value ev)}
where d = sz / (fromRational $ (wholeStop ev) - (wholeStart ev))
sz = 1/(fromIntegral bits)
tidal-1.0.14/src/Sound/Tidal/Core.hs 0000644 0000000 0000000 00000033620 13504651510 015224 0 ustar 00 0000000 0000000 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module Sound.Tidal.Core where
import Prelude hiding ((<*), (*>))
import Data.Fixed (mod')
import qualified Data.Map.Strict as Map
import Sound.Tidal.Pattern
-- ** Elemental patterns
-- | An empty pattern
silence :: Pattern a
silence = empty
-- | Takes a function from time to values, and turns it into a 'Pattern'.
sig :: (Time -> a) -> Pattern a
sig f = Pattern Analog q
where q (State (Arc s e) _)
| s > e = []
| otherwise = [Event (Arc s e) (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, 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, Unionable b) => a b -> a b -> a b
a |>| b = flip union <$> a <*> b
(|> ) :: Unionable a => Pattern a -> Pattern a -> Pattern a
a |> b = flip union <$> a <* b
( >|) :: Unionable a => Pattern a -> Pattern a -> Pattern a
a >| b = flip union <$> a *> b
(|<|) :: (Applicative a, Unionable b) => a b -> a b -> a b
a |<| b = union <$> a <*> b
(|< ) :: Unionable a => Pattern a -> Pattern a -> Pattern a
a |< b = union <$> a <* b
( <|) :: Unionable a => Pattern a -> Pattern a -> Pattern a
a <| b = union <$> a *> b
-- Backward compatibility - structure from left, values from right.
(#) :: Unionable b => Pattern b -> Pattern b -> Pattern b
(#) = (|>)
-- ** Constructing patterns
-- | Turns a list of values into a pattern, playing one of them per cycle.
fromList :: [a] -> Pattern a
fromList = cat . map pure
-- | Turns a list of values into a pattern, playing one of them per cycle.
fastFromList :: [a] -> Pattern a
fastFromList = fastcat . map pure
-- | A synonym for 'fastFromList'
listToPat :: [a] -> Pattern a
listToPat = fastFromList
-- | 'fromMaybes; is similar to 'fromList', but allows values to
-- be optional using the 'Maybe' type, so that 'Nothing' results in
-- gaps in the pattern.
fromMaybes :: [Maybe a] -> Pattern a
fromMaybes = fastcat . map f
where f Nothing = silence
f (Just x) = pure x
-- | A pattern of whole numbers from 0 to the given number, in a single cycle.
run :: (Enum a, Num a) => Pattern a -> Pattern a
run = (>>= _run)
_run :: (Enum a, Num a) => a -> Pattern a
_run n = fastFromList [0 .. n-1]
-- | From @1@ for the first cycle, successively adds a number until it gets up to @n@
scan :: (Enum a, Num a) => Pattern a -> Pattern a
scan = (>>= _scan)
_scan :: (Enum a, Num a) => a -> Pattern a
_scan n = slowcat $ map _run [1 .. n]
-- ** Combining patterns
-- | Alternate between cycles of the two given patterns
append :: Pattern a -> Pattern a -> Pattern a
append a b = cat [a,b]
-- | Like 'append', but for a list of patterns. Interlaces them, playing the first cycle from each
-- in turn, then the second cycle from each, and so on.
cat :: [Pattern a] -> Pattern a
cat [] = silence
-- TODO I *guess* it would be digital..
cat ps = Pattern Digital 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
-- | Like 'append', but twice as fast
fastAppend :: Pattern a -> Pattern a -> Pattern a
fastAppend a b = _fast 2 $ append a b
-- | 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
-- Analog if they're both analog
overlay p@(Pattern Analog _) p'@(Pattern Analog _) = Pattern Analog $ \st -> query p st ++ query p' st
-- Otherwise digital. Won't really work to have a mixture.. Hmm
overlay p p' = Pattern Digital $ \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 (Event (Arc s e) p'@(Arc s' e') v) =
Event (Arc (s'-s) (e'-e)) p' v
makeWholeAbsolute :: Event a -> Event a
makeWholeAbsolute (Event (Arc s e) p'@(Arc s' e') v) =
Event (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 w p' v) -> Event 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
tidal-1.0.14/src/Sound/Tidal/Utils.hs 0000644 0000000 0000000 00000003535 13504651510 015436 0 ustar 00 0000000 0000000 module Sound.Tidal.Utils where
import Data.List (delete)
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' 0
where accumulate' _ [] = []
accumulate' n (a:xs) = (n+a) : accumulate' (n+a) 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
tidal-1.0.14/src/Sound/Tidal/Scales.hs 0000644 0000000 0000000 00000016174 13504651510 015553 0 ustar 00 0000000 0000000 module Sound.Tidal.Scales (scale, scaleList, scaleTable, getScale) where
import Data.Maybe
import Sound.Tidal.Pattern
import Sound.Tidal.Utils
-- five notes scales
minPent :: Num a => [a]
minPent = [0,3,5,7,10]
majPent :: Num a => [a]
majPent = [0,2,4,7,9]
-- another mode of major pentatonic
ritusen :: Num a => [a]
ritusen = [0,2,5,7,9]
-- another mode of major pentatonic
egyptian :: Num a => [a]
egyptian = [0,2,5,7,10]
--
kumai :: Num a => [a]
kumai = [0,2,3,7,9]
hirajoshi :: Num a => [a]
hirajoshi = [0,2,3,7,8]
iwato :: Num a => [a]
iwato = [0,1,5,6,10]
chinese :: Num a => [a]
chinese = [0,4,6,7,11]
indian :: Num a => [a]
indian = [0,4,5,7,10]
pelog :: Num a => [a]
pelog = [0,1,3,7,8]
--
prometheus :: Num a => [a]
prometheus = [0,2,4,6,11]
scriabin :: Num a => [a]
scriabin = [0,1,4,7,9]
-- han chinese pentatonic scales
gong :: Num a => [a]
gong = [0,2,4,7,9]
shang :: Num a => [a]
shang = [0,2,5,7,10]
jiao :: Num a => [a]
jiao = [0,3,5,8,10]
zhi :: Num a => [a]
zhi = [0,2,5,7,9]
yu :: Num a => [a]
yu = [0,3,5,7,10]
-- 6 note scales
whole' :: Num a => [a]
whole' = [0,2,4,6,8,10]
augmented :: Num a => [a]
augmented = [0,3,4,7,8,11]
augmented2 :: Num a => [a]
augmented2 = [0,1,4,5,8,9]
-- hexatonic modes with no tritone
hexMajor7 :: Num a => [a]
hexMajor7 = [0,2,4,7,9,11]
hexDorian :: Num a => [a]
hexDorian = [0,2,3,5,7,10]
hexPhrygian :: Num a => [a]
hexPhrygian = [0,1,3,5,8,10]
hexSus :: Num a => [a]
hexSus = [0,2,5,7,9,10]
hexMajor6 :: Num a => [a]
hexMajor6 = [0,2,4,5,7,9]
hexAeolian :: Num a => [a]
hexAeolian = [0,3,5,7,8,10]
-- 7 note scales
major :: Num a => [a]
major = [0,2,4,5,7,9,11]
ionian :: Num a => [a]
ionian = [0,2,4,5,7,9,11]
dorian :: Num a => [a]
dorian = [0,2,3,5,7,9,10]
phrygian :: Num a => [a]
phrygian = [0,1,3,5,7,8,10]
lydian :: Num a => [a]
lydian = [0,2,4,6,7,9,11]
mixolydian :: Num a => [a]
mixolydian = [0,2,4,5,7,9,10]
aeolian :: Num a => [a]
aeolian = [0,2,3,5,7,8,10]
minor :: Num a => [a]
minor = [0,2,3,5,7,8,10]
locrian :: Num a => [a]
locrian = [0,1,3,5,6,8,10]
harmonicMinor :: Num a => [a]
harmonicMinor = [0,2,3,5,7,8,11]
harmonicMajor :: Num a => [a]
harmonicMajor = [0,2,4,5,7,8,11]
melodicMinor :: Num a => [a]
melodicMinor = [0,2,3,5,7,9,11]
melodicMinorDesc :: Num a => [a]
melodicMinorDesc = [0,2,3,5,7,8,10]
melodicMajor :: Num a => [a]
melodicMajor = [0,2,4,5,7,8,10]
bartok :: Num a => [a]
bartok = melodicMajor
hindu :: Num a => [a]
hindu = melodicMajor
-- raga modes
todi :: Num a => [a]
todi = [0,1,3,6,7,8,11]
purvi :: Num a => [a]
purvi = [0,1,4,6,7,8,11]
marva :: Num a => [a]
marva = [0,1,4,6,7,9,11]
bhairav :: Num a => [a]
bhairav = [0,1,4,5,7,8,11]
ahirbhairav :: Num a => [a]
ahirbhairav = [0,1,4,5,7,9,10]
--
superLocrian :: Num a => [a]
superLocrian = [0,1,3,4,6,8,10]
romanianMinor :: Num a => [a]
romanianMinor = [0,2,3,6,7,9,10]
hungarianMinor :: Num a => [a]
hungarianMinor = [0,2,3,6,7,8,11]
neapolitanMinor :: Num a => [a]
neapolitanMinor = [0,1,3,5,7,8,11]
enigmatic :: Num a => [a]
enigmatic = [0,1,4,6,8,10,11]
spanish :: Num a => [a]
spanish = [0,1,4,5,7,8,10]
-- modes of whole tones with added note ->
leadingWhole :: Num a => [a]
leadingWhole = [0,2,4,6,8,10,11]
lydianMinor :: Num a => [a]
lydianMinor = [0,2,4,6,7,8,10]
neapolitanMajor :: Num a => [a]
neapolitanMajor = [0,1,3,5,7,9,11]
locrianMajor :: Num a => [a]
locrianMajor = [0,2,4,5,6,8,10]
-- 8 note scales
diminished :: Num a => [a]
diminished = [0,1,3,4,6,7,9,10]
diminished2 :: Num a => [a]
diminished2 = [0,2,3,5,6,8,9,11]
-- modes of limited transposition
messiaen1 :: Num a => [a]
messiaen1 = whole'
messiaen2 :: Num a => [a]
messiaen2 = diminished
messiaen3 :: Num a => [a]
messiaen3 = [0, 2, 3, 4, 6, 7, 8, 10, 11]
messiaen4 :: Num a => [a]
messiaen4 = [0, 1, 2, 5, 6, 7, 8, 11]
messiaen5 :: Num a => [a]
messiaen5 = [0, 1, 5, 6, 7, 11]
messiaen6 :: Num a => [a]
messiaen6 = [0, 2, 4, 5, 6, 8, 10, 11]
messiaen7 :: Num a => [a]
messiaen7 = [0, 1, 2, 3, 5, 6, 7, 8, 9, 11]
-- 12 note scales
chromatic :: Num a => [a]
chromatic = [0,1,2,3,4,5,6,7,8,9,10,11]
scale :: Num a => Pattern String -> Pattern Int -> Pattern a
scale = getScale scaleTable
getScale :: Num 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, [Int])])
scaleTable :: Num a => [(String, [a])]
scaleTable = [("minPent", minPent),
("majPent", majPent),
("ritusen", ritusen),
("egyptian", egyptian),
("kumai", kumai),
("hirajoshi", hirajoshi),
("iwato", iwato),
("chinese", chinese),
("indian", indian),
("pelog", pelog),
("prometheus", prometheus),
("scriabin", scriabin),
("gong", gong),
("shang", shang),
("jiao", jiao),
("zhi", zhi),
("yu", yu),
("whole", whole'),
("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)
]
tidal-1.0.14/src/Sound/Tidal/Carabiner.hs 0000644 0000000 0000000 00000005607 13504651510 016226 0 ustar 00 0000000 0000000 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, threadDelay, 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
port = 17000
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.0.14/src/Sound/Tidal/Params.hs 0000644 0000000 0000000 00000056067 13504651510 015571 0 ustar 00 0000000 0000000 module Sound.Tidal.Params where
import qualified Data.Map.Strict as Map
import Sound.Tidal.Pattern
import Sound.Tidal.Utils
-- | 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 = Map.singleton name (VF $ read v)
mI :: String -> String -> ControlMap
mI name v = Map.singleton name (VI $ read v)
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"]
-- | 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)
-- |Β 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"
-- | 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"
-- | a pattern of numbers between 0 and 1, from left to right (assuming stereo), once round a circle (assuming multichannel)
pan :: Pattern Double -> ControlPattern
pan = pF "pan"
-- | a pattern of numbers between -inf and inf, which controls how much multichannel output is fanned out (negative is backwards ordering)
panspan :: Pattern Double -> ControlPattern
panspan = pF "span"
-- | a pattern of numbers between 0.0 and 1.0, which controls the multichannel spread range (multichannel only)
pansplay :: Pattern Double -> ControlPattern
pansplay = pF "splay"
-- | a pattern of numbers between 0.0 and inf, which controls how much each channel is distributed over neighbours (multichannel only)
panwidth :: Pattern Double -> ControlPattern
panwidth = pF "panwidth"
-- | a pattern of numbers between -1.0 and 1.0, which controls the relative position of the centre pan in a pair of adjacent speakers (multichannel only)
panorient :: Pattern Double -> ControlPattern
panorient = pF "orientation"
pitch1 :: Pattern Double -> ControlPattern
pitch1 = pF "pitch1"
pitch2 :: Pattern Double -> ControlPattern
pitch2 = pF "pitch2"
pitch3 :: Pattern Double -> ControlPattern
pitch3 = pF "pitch3"
portamento :: Pattern Double -> ControlPattern
portamento = pF "portamento"
-- | used in SuperDirt softsynths as a control rate or "speed"
rate :: Pattern Double -> ControlPattern
rate = pF "rate"
-- | a pattern of numbers to specify the release time (in seconds) of an envelope applied to each sample. Only takes effect if `attack` is also specified.
release :: Pattern Double -> ControlPattern
release = pF "release"
-- | a pattern of numbers from 0 to 1. Specifies the resonance of the low-pass filter.
resonance :: Pattern Double -> ControlPattern
resonance = pF "resonance"
-- | a pattern of numbers from 0 to 1. Sets the level of reverb.
room :: Pattern Double -> ControlPattern
room = pF "room"
sagogo :: Pattern Double -> ControlPattern
sagogo = pF "sagogo"
sclap :: Pattern Double -> ControlPattern
sclap = pF "sclap"
sclaves :: Pattern Double -> ControlPattern
sclaves = pF "sclaves"
scrash :: Pattern Double -> ControlPattern
scrash = pF "scrash"
semitone :: Pattern Double -> ControlPattern
semitone = pF "semitone"
-- | wave shaping distortion, a pattern of numbers from 0 for no distortion up to 1 for loads of distortion.
shape :: Pattern Double -> ControlPattern
shape = pF "shape"
-- | a pattern of numbers from 0 to 1. Sets the perceptual size (reverb time) of the `room` to be used in reverb.
size :: Pattern Double -> ControlPattern
size = pF "size"
slide :: Pattern Double -> ControlPattern
slide = pF "slide"
-- | a pattern of numbers which changes the speed of sample playback, i.e. a cheap way of changing pitch. Negative values will play the sample backwards!
speed :: Pattern Double -> ControlPattern
speed = pF "speed"
squiz :: Pattern Double -> ControlPattern
squiz = pF "squiz"
-- | a pattern of strings. Selects the sample to be played.
s' :: Pattern String -> ControlPattern
s' = pS "s"
stutterdepth :: Pattern Double -> ControlPattern
stutterdepth = pF "stutterdepth"
stuttertime :: Pattern Double -> ControlPattern
stuttertime = pF "stuttertime"
sustain :: Pattern Double -> ControlPattern
sustain = pF "sustain"
tomdecay :: Pattern Double -> ControlPattern
tomdecay = pF "tomdecay"
{- | used in conjunction with `speed`, accepts values of "r" (rate, default behavior), "c" (cycles), or "s" (seconds).
Using `unit "c"` means `speed` will be interpreted in units of cycles, e.g. `speed "1"` means samples will be stretched to fill a cycle.
Using `unit "s"` means the playback speed will be adjusted so that the duration is the number of seconds specified by `speed`.
-}
unit :: Pattern String -> ControlPattern
unit = pS "unit"
velocity :: Pattern Double -> ControlPattern
velocity = pF "velocity"
vcfegint :: Pattern Double -> ControlPattern
vcfegint = pF "vcfegint"
vcoegint :: Pattern Double -> ControlPattern
vcoegint = pF "vcoegint"
voice :: Pattern Double -> ControlPattern
voice = pF "voice"
-- | formant filter to make things sound like vowels, a pattern of either `a`, `e`, `i`, `o` or `u`. Use a rest (`~`) for no effect.
vowel :: Pattern String -> ControlPattern
vowel = pS "vowel"
waveloss :: Pattern Double -> ControlPattern
waveloss = pF "waveloss"
-- MIDI-specific params
dur :: Pattern Double -> ControlPattern
dur = pF "dur"
modwheel :: Pattern Double -> ControlPattern
modwheel = pF "modwheel"
expression :: Pattern Double -> ControlPattern
expression = pF "expression"
sustainpedal :: Pattern Double -> ControlPattern
sustainpedal = pF "sustainpedal"
-- Tremolo Audio DSP effect | params are "tremolorate" and "tremolodepth"
tremolorate, tremolodepth :: Pattern Double -> ControlPattern
tremolorate = pF "tremolorate"
tremolodepth = pF "tremolodepth"
-- Phaser Audio DSP effect | params are "phaserrate" and "phaserdepth"
phaserrate, phaserdepth :: Pattern Double -> ControlPattern
phaserrate = pF "phaserrate"
phaserdepth = pF "phaserdepth"
-- More SuperDirt effects
-- frequency shifter
fshift, fshiftphase, fshiftnote :: Pattern Double -> ControlPattern
fshift = pF "fshift"
fshiftphase = pF "fshiftphase"
fshiftnote = pF "fshiftnote"
-- triode (tube distortion)
triode :: Pattern Double -> ControlPattern
triode = pF "triode"
-- krush (like Sonic Pi's shape/bass enhancer)
krush, kcutoff :: Pattern Double -> ControlPattern
krush = pF "krush"
kcutoff = pF "kcutoff"
-- octer (like Sonic Pi's octaver effect)
octer, octersub, octersubsub :: Pattern Double -> ControlPattern
octer = pF "octer"
octersub = pF "octersub"
octersubsub = pF "octersubsub"
-- ring modulation
ring, ringf, ringdf :: Pattern Double -> ControlPattern
ring = pF "ring"
ringf = pF "ringf"
ringdf = pF "ringdf"
-- noisy fuzzy distortion
distort :: Pattern Double -> ControlPattern
distort = pF "distort"
-- Spectral freeze
freeze :: Pattern Double -> ControlPattern
freeze = pF "freeze"
-- Spectral delay
xsdelay :: Pattern Double -> ControlPattern
xsdelay = pF "xsdelay"
tsdelay :: Pattern Double -> ControlPattern
tsdelay = pF "tsdelay"
-- Spectral conform
real :: Pattern Double -> ControlPattern
real = pF "real"
imag :: Pattern Double -> ControlPattern
imag = pF "imag"
-- Spectral enhance
enhance :: Pattern Double -> ControlPattern
enhance = pF "enhance"
partials :: Pattern Double -> ControlPattern
partials = pF "partials"
-- Spectral comb
comb :: Pattern Double -> ControlPattern
comb = pF "comb"
-- Spectral smear
smear :: Pattern Double -> ControlPattern
smear = pF "smear"
-- Spectral scramble
scram :: Pattern Double -> ControlPattern
scram = pF "scram"
-- Spectral binshift
binshift :: Pattern Double -> ControlPattern
binshift = pF "binshift"
-- High pass sort of spectral filter
hbrick :: Pattern Double -> ControlPattern
hbrick = pF "hbrick"
-- Low pass sort of spectral filter
lbrick :: Pattern Double -> ControlPattern
lbrick = pF "lbrick"
-- aliases
att, bpf, bpq, chdecay, ctf, ctfg, delayfb, delayt, det, gat, hg, hpf, hpq, lag, lbd, lch, lcl, lcp, lcr, lfoc, lfoi
, lfop, lht, llt, loh, lpf, lpq, lsn, ohdecay, phasdp, phasr, pit1, pit2, pit3, por, rel, sz, sag, scl, scp
, scr, sld, std, stt, sus, tdecay, tremdp, tremr, vcf, vco, voi
:: Pattern Double -> ControlPattern
att = attack
bpf = bandf
bpq = bandq
chdecay = clhatdecay
ctf = cutoff
ctfg = cutoffegint
delayfb = delayfeedback
delayt = delaytime
det = detune
gat = gate
hg = hatgrain
hpf = hcutoff
hpq = hresonance
lag = lagogo
lbd = lkick
lch = lclhat
lcl = lclaves
lcp = lclap
lcr = lcrash
lfoc = lfocutoffint
lfoi = lfoint
lfop = lfopitchint
lht = lhitom
llt = llotom
loh = lophat
lpf = cutoff
lpq = resonance
lsn = lsnare
ohdecay = ophatdecay
phasdp = phaserdepth
phasr = phaserrate
pit1 = pitch1
pit2 = pitch2
pit3 = pitch3
por = portamento
rel = release
sag = sagogo
scl = sclaves
scp = sclap
scr = scrash
sz = size
sld = slide
std = stutterdepth
stt = stuttertime
sus = sustain
tdecay = tomdecay
tremdp = tremolodepth
tremr = tremolorate
vcf = vcfegint
vco = vcoegint
voi = voice
midinote :: Pattern Double -> ControlPattern
midinote = note . (subtract 60 <$>)
drum :: Pattern String -> ControlPattern
drum = n . (subtract 60 . drumN <$>)
drumN :: Num a => String -> a
drumN "bd" = 36
drumN "sn" = 38
drumN "lt" = 43
drumN "ht" = 50
drumN "ch" = 42
drumN "oh" = 46
drumN "cp" = 39
drumN "cl" = 75
drumN "ag" = 67
drumN "cr" = 49
drumN _ = 0
-- SuperDirt MIDI Params
array :: Pattern Double -> ControlPattern
array = pF "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"
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.0.14/src/Sound/Tidal/Pattern.hs 0000644 0000000 0000000 00000065111 13504651510 015751 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
{-# 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, intercalate)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe, mapMaybe)
import Data.Ratio (numerator, denominator)
import Data.Typeable (Typeable)
------------------------------------------------------------------------
-- * Types
-- | Time is rational
type Time = Rational
-- | The 'sam' (start of cycle) for the given time value
sam :: Time -> Time
sam = fromIntegral . (floor :: Time -> Int)
-- | Turns a number into a (rational) time value. An alias for 'toRational'.
toTime :: Real a => a -> Rational
toTime = toRational
-- | The end point of the current cycle (and starting point of the next cycle)
nextSam :: Time -> Time
nextSam = (1+) . sam
-- | The position of a time value relative to the start of its cycle.
cyclePos :: Time -> Time
cyclePos t = t - sam t
-- | An arc of time, with a start time (or onset) and a stop time (or offset)
data ArcF a = Arc
{ start :: a
, stop :: a
} deriving (Eq, Ord, Functor)
type Arc = ArcF Time
instance {-# OVERLAPPING #-} Show Arc where
show (Arc s e) = prettyRat s ++ ">" ++ prettyRat 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
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
-- | An event is a value that's active during a timespan
-- The part should be equal to or fit inside the
-- whole
data EventF a b = Event
{ whole :: a
, part :: a
, value :: b
} deriving (Eq, Ord, Functor)
type Event a = EventF (ArcF Time) a
instance Bifunctor EventF where
bimap f g (Event w p e) = Event (f w) (f p) (g e)
instance {-# OVERLAPPING #-} Show a => Show (Event a) where
show (Event (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
-- | `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 (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))
)
-- | Get the onset of an event's 'whole'
wholeStart :: Event a -> Time
wholeStart = start . whole
-- | Get the offset of an event's 'whole'
wholeStop :: Event a -> Time
wholeStop = stop . whole
-- | 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 = start (whole e) == start (part e)
toEvent :: (((Time, Time), (Time, Time)), a) -> Event a
toEvent (((ws, we), (ps, pe)), v) = Event (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])
-- | Also known as Continuous vs Discrete/Amorphous vs Pulsating etc.
data Nature = Analog | Digital
deriving (Eq, Show)
-- | A datatype that's basically a query, plus a hint about whether its events
-- are Analogue or Digital by nature
data Pattern a = Pattern {nature :: Nature, query :: Query a}
data Value = VS { svalue :: String }
| VF { fvalue :: Double }
| VR { rvalue :: Rational }
| VI { ivalue :: Int }
| VB { bvalue :: Bool }
deriving (Typeable,Data)
class Valuable a where
toValue :: a -> Value
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 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
(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 (VS _) _ = LT
compare _ (VS _) = GT
compare (VB _) _ = LT
compare _ (VB _) = 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 Functor Pattern where
-- | apply a function to all the values in a pattern
fmap f p = p {query = fmap (fmap f) . query p}
instance Applicative Pattern where
-- | Repeat the given value once per cycle, forever
pure v = Pattern Digital $ \(State a _) ->
map (\a' -> Event a' (sect a a') v) $ cycleArcsInArc a
(<*>) pf@(Pattern Digital _) px@(Pattern Digital _) = Pattern Digital q
where q st = catMaybes $ concatMap match $ query pf st
where
match (Event fWhole fPart f) =
map
(\(Event xWhole xPart x) ->
do whole' <- subArc xWhole fWhole
part' <- subArc fPart xPart
return (Event whole' part' (f x))
)
(query px $ st {arc = fPart})
(<*>) pf@(Pattern Digital _) px@(Pattern Analog _) = Pattern Digital q
where q st = concatMap match $ query pf st
where
match (Event fWhole fPart f) =
map
(Event fWhole fPart . f . value)
(query px $ st {arc = pure (start fPart)})
(<*>) pf@(Pattern Analog _) px@(Pattern Digital _) = Pattern Digital q
where q st = concatMap match $ query px st
where
match (Event xWhole xPart x) =
map
(\e -> Event xWhole xPart (value e x))
(query pf st {arc = pure (start xPart)})
(<*>) pf px = Pattern Analog q
where q st = concatMap match $ query pf st
where
match ef =
map
(Event (arc st) (arc st) . value ef . value)
(query px st)
-- | Like <*>, but the structure only comes from the left
(<*) :: Pattern (a -> b) -> Pattern a -> Pattern b
(<*) pf@(Pattern Analog _) px@(Pattern Analog _) = Pattern Analog q
where q st = concatMap match $ query pf st
where
match (Event fWhole fPart f) =
map
(Event fWhole fPart . f . value) $
query px st -- for continuous events, use the original query
-- If one of the patterns is digital, treat both as digital.. (TODO - needs extra thought)
(<*) pf px = Pattern Digital q
where q st = concatMap match $ query pf st
where
match (Event fWhole fPart f) =
map
(Event fWhole fPart . f . value) $
query px $ st {arc = xQuery fWhole}
xQuery (Arc s _) = pure s -- for discrete events, match with the onset
-- | Like <*>, but the structure only comes from the right
(*>) :: Pattern (a -> b) -> Pattern a -> Pattern b
(*>) pf@(Pattern Analog _) px@(Pattern Analog _) = Pattern Analog q
where q st = concatMap match $ query px st
where
match (Event xWhole xPart x) =
map
(\e -> Event xWhole xPart (value e x)) $
query pf st -- for continuous events, use the original query
(*>) pf px = Pattern Digital q
where q st = concatMap match $ query px st
where
match (Event xWhole xPart x) =
map
(\e -> Event xWhole xPart (value e x)) $
query pf $ fQuery xWhole
fQuery (Arc s _) = st {arc = pure s} -- for discrete events, match with the onset
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 w p v) ->
mapMaybe (munge w p) $ query v st {arc = p})
(query pp st)
munge ow op (Event iw ip v') =
do
w' <- subArc ow iw
p' <- subArc op ip
return (Event 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 _ p v) -> mapMaybe munge $ query v st {arc = p}
)
(query pp st)
where munge (Event iw ip v) =
do
p <- subArc (arc st) ip
p' <- subArc p (arc st)
return (Event 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
(\(Event w p v) ->
mapMaybe (munge w p) $ query v st {arc = pure (start w)}
)
(query pp st)
where munge ow op (Event _ _ v') =
do
p' <- subArc (arc st) op
return (Event 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
(\(Event w p v) ->
mapMaybe (munge w p) $ query (compressArc (cycleArc w) v) st {arc = p}
)
(query pp st)
munge oWhole oPart (Event iWhole iPart v) =
do w' <- subArc oWhole iWhole
p' <- subArc oPart iPart
return (Event 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
showPattern :: Show a => Arc -> Pattern a -> String
showPattern a p = intercalate "\n" $ map show $ queryArc p a
instance (Show a) => Show (Pattern a) where
show = showPattern (Arc 0 1)
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
instance {-# OVERLAPPING #-} Show ControlMap where
show m = intercalate ", " $ map (\(name, v) -> name ++ ": " ++ show v) $ Map.toList m
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
------------------------------------------------------------------------
-- * Internal functions
empty :: Pattern a
empty = Pattern {nature = Digital, query = const []}
queryArc :: Pattern a -> Arc -> [Event a]
queryArc p a = query p $ State a Map.empty
isDigital :: Pattern a -> Bool
isDigital = (== Digital) . nature
isAnalog :: Pattern a -> Bool
isAnalog = not . isDigital
-- | 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 w p e) -> Event (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 w p v) -> Event 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
compressArc :: Arc -> Pattern a -> Pattern a
compressArc (Arc s e) p | s > e = empty
| s > 1 || e > 1 = empty
| s < 0 || e < 0 = empty
| otherwise = s `rotR` _fastGap (1/(e-s)) p
compressArcTo :: Arc -> Pattern a -> Pattern a
compressArcTo (Arc s e) = compressArc (Arc (cyclePos s) (e - sam s))
_fastGap :: Time -> Pattern a -> Pattern a
_fastGap 0 _ = empty
_fastGap r p = splitQueries $
withResultArc (\(Arc s e) -> Arc (sam s + ((s - sam s)/r'))
(sam s + ((e - sam s)/r'))
) $ p {query = f}
where r' = max r 1
-- zero width queries of the next sam should return zero in this case..
f st@(State a _) | start a' == nextSam (start a) = []
| otherwise = query p st {arc = a'}
where mungeQuery t = sam t + min 1 (r' * cyclePos t)
a' = (\(Arc s e) -> Arc (mungeQuery s) (mungeQuery e)) a
-- | Shifts a pattern back in time by the given amount, expressed in cycles
rotL :: Time -> Pattern a -> Pattern a
rotL t p = withResultTime (subtract t) $ withQueryTime (+ t) p
-- | Shifts a pattern forward in time by the given amount, expressed in cycles
rotR :: Time -> Pattern a -> Pattern a
rotR t = rotL (negate t)
-- ** Event filters
-- | Remove events from patterns that to not meet the given test
filterValues :: (a -> Bool) -> Pattern a -> Pattern a
filterValues f p = p {query = filter (f . value) . query p}
-- | Turns a pattern of 'Maybe' values in to a pattern of values,
-- dropping the events of 'Nothing'.
filterJust :: Pattern (Maybe a) -> Pattern a
filterJust p = fromJust <$> filterValues isJust p
-- formerly known as playWhen
filterWhen :: (Time -> Bool) -> Pattern a -> Pattern a
filterWhen test p = p {query = filter (test . wholeStart) . query p}
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 (Event xWhole xPart x) =
Event xWhole xPart (any (f x) (as $ start xWhole), x)
as s = map value $ query pa $ fQuery s
fQuery s = st {arc = Arc s s}
tidal-1.0.14/src/Sound/Tidal/Stream.hs 0000644 0000000 0000000 00000044216 13504651510 015572 0 ustar 00 0000000 0000000 {-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
module Sound.Tidal.Stream where
import Control.Applicative ((<|>))
import Control.Concurrent.MVar
import Control.Concurrent
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust, fromMaybe, isJust, catMaybes)
import qualified Control.Exception as E
-- import Control.Monad.Reader
-- import Control.Monad.Except
-- import qualified Data.Bifunctor as BF
-- import qualified Data.Bool as B
-- import qualified Data.Char as C
import System.IO (hPutStrLn, stderr)
import qualified Sound.OSC.FD as O
import Sound.Tidal.Config
import Sound.Tidal.Core (stack, silence)
import Sound.Tidal.Pattern
import qualified Sound.Tidal.Tempo as T
-- import qualified Sound.OSC.Datum as O
data TimeStamp = BundleStamp | MessageStamp | NoStamp
deriving (Eq, Show)
data Stream = Stream {sConfig :: Config,
sInput :: MVar StateMap,
sOutput :: MVar ControlPattern,
sListenTid :: Maybe ThreadId,
sPMapMV :: MVar PlayMap,
sTempoMV :: MVar T.Tempo,
sGlobalFMV :: MVar (ControlPattern -> ControlPattern),
sCxs :: [Cx]
}
type PatId = String
data Cx = Cx {cxTarget :: OSCTarget,
cxUDP :: O.UDP
}
data OSCTarget = OSCTarget {oName :: String,
oAddress :: String,
oPort :: Int,
oPath :: String,
oShape :: Maybe [(String, Maybe Value)],
oLatency :: Double,
oPreamble :: [O.Datum],
oTimestamp :: TimeStamp
}
deriving Show
superdirtTarget :: OSCTarget
superdirtTarget = OSCTarget {oName = "SuperDirt",
oAddress = "127.0.0.1",
oPort = 57120,
oPath = "/play2",
oShape = Nothing,
oLatency = 0.02,
oPreamble = [],
oTimestamp = BundleStamp
}
dirtTarget :: OSCTarget
dirtTarget = OSCTarget {oName = "Dirt",
oAddress = "127.0.0.1",
oPort = 7771,
oPath = "/play",
oShape = Just [("sec", Just $ VI 0),
("usec", Just $ VI 0),
("cps", Just $ VF 0),
("s", Nothing),
("offset", Just $ VF 0),
("begin", Just $ VF 0),
("end", Just $ VF 1),
("speed", Just $ VF 1),
("pan", Just $ VF 0.5),
("velocity", Just $ VF 0.5),
("vowel", Just $ VS ""),
("cutoff", Just $ VF 0),
("resonance", Just $ VF 0),
("accelerate", Just $ VF 0),
("shape", Just $ VF 0),
("kriole", Just $ VI 0),
("gain", Just $ VF 1),
("cut", Just $ VI 0),
("delay", Just $ VF 0),
("delaytime", Just $ VF (-1)),
("delayfeedback", Just $ VF (-1)),
("crush", Just $ VF 0),
("coarse", Just $ VI 0),
("hcutoff", Just $ VF 0),
("hresonance", Just $ VF 0),
("bandf", Just $ VF 0),
("bandq", Just $ VF 0),
("unit", Just $ VS "rate"),
("loop", Just $ VF 0),
("n", Just $ VF 0),
("attack", Just $ VF (-1)),
("hold", Just $ VF 0),
("release", Just $ VF (-1)),
("orbit", Just $ VI 0)
],
oLatency = 0.02,
oPreamble = [],
oTimestamp = MessageStamp
}
startStream :: Config -> MVar StateMap -> [OSCTarget] -> IO (MVar ControlPattern, MVar T.Tempo, [Cx])
startStream config sMapMV targets
= do cxs <- mapM (\target -> do u <- O.openUDP (oAddress target) (oPort target)
return $ Cx {cxUDP = u,
cxTarget = target
}
) targets
pMV <- newMVar empty
(tempoMV, _) <- T.clocked config $ onTick config sMapMV pMV cxs
return $ (pMV, tempoMV, cxs)
data PlayState = PlayState {pattern :: ControlPattern,
mute :: Bool,
solo :: Bool,
history :: [ControlPattern]
}
deriving Show
type PlayMap = Map.Map PatId PlayState
toDatum :: Value -> O.Datum
toDatum (VF x) = O.float x
toDatum (VI x) = O.int32 x
toDatum (VS x) = O.string x
toDatum (VR x) = O.float $ ((fromRational x) :: Double)
toDatum (VB True) = O.int32 (1 :: Int)
toDatum (VB False) = O.int32 (0 :: Int)
toData :: OSCTarget -> Event ControlMap -> Maybe [O.Datum]
toData target e
| isJust (oShape target) = fmap (fmap toDatum) $ sequence $ map (\(n,v) -> Map.lookup n (value e) <|> v) (fromJust $ oShape target)
| otherwise = Just $ concatMap (\(n,v) -> [O.string n, toDatum v]) $ Map.toList $ value e
toMessage :: Double -> OSCTarget -> T.Tempo -> Event (Map.Map String Value) -> Maybe O.Message
toMessage t target tempo e = do vs <- toData target addExtra
return $ O.Message (oPath target) $ oPreamble target ++ vs
where on = sched tempo $ start $ whole e
off = sched tempo $ stop $ whole e
delta = off - on
messageStamp = oTimestamp target == MessageStamp
-- If there is already cps in the event, the union will preserve that.
addExtra = (\v -> (Map.union v $ Map.fromList (extra messageStamp)
)) <$> e
extra False = [("cps", (VF $ T.cps tempo)),
("delta", VF delta),
("cycle", VF (fromRational $ start $ whole e))
]
extra True = timestamp ++ (extra False)
timestamp = [("sec", VI sec),
("usec", VI usec)
]
ut = O.ntpr_to_ut t
sec = floor ut
usec = floor $ 1000000 * (ut - (fromIntegral sec))
doCps :: MVar T.Tempo -> (Double, Maybe Value) -> IO ()
doCps tempoMV (d, Just (VF cps)) = do _ <- forkIO $ do threadDelay $ floor $ d * 1000000
-- hack to stop things from stopping !
_ <- T.setCps tempoMV (max 0.00001 cps)
return ()
return ()
doCps _ _ = return ()
onTick :: Config -> MVar StateMap -> MVar ControlPattern -> [Cx] -> MVar T.Tempo -> T.State -> IO ()
onTick config sMapMV pMV cxs tempoMV st =
do p <- readMVar pMV
sMap <- readMVar sMapMV
tempo <- readMVar tempoMV
now <- O.time
let sMap' = Map.insert "_cps" (pure $ VF $ T.cps tempo) sMap
es = filter eventHasOnset $ query p (State {arc = T.nowArc st, controls = sMap'})
on e = (sched tempo $ start $ whole e) + eventNudge e
eventNudge e = fromJust $ getF $ fromMaybe (VF 0) $ Map.lookup "nudge" $ value e
messages target = catMaybes $ map (\e -> do m <- toMessage (on e + latency target) target tempo e
return $ (on e, m)
) es
cpsChanges = map (\e -> (on e - now, Map.lookup "cps" $ value e)) es
latency target = oLatency target + cFrameTimespan config + T.nudged tempo
mapM_ (\(Cx target udp) -> E.catch (mapM_ (send target (latency target) udp) (messages target))
(\(_ ::E.SomeException)
-> putStrLn $ "Failed to send. Is the '" ++ oName target ++ "' target running?"
)
) cxs
mapM_ (doCps tempoMV) cpsChanges
return ()
send :: O.Transport t => OSCTarget -> Double -> t -> (Double, O.Message) -> IO ()
send target latency u (time, m)
| oTimestamp target == BundleStamp = O.sendBundle u $ O.Bundle (time + latency) [m]
| oTimestamp target == MessageStamp = O.sendMessage u m
| otherwise = do _ <- forkIO $ do now <- O.time
threadDelay $ floor $ ((time+latency) - now) * 1000000
O.sendMessage u m
return ()
sched :: T.Tempo -> Rational -> Double
sched tempo c = ((fromRational $ c - (T.atCycle tempo)) / T.cps tempo) + (T.atTime tempo)
-- Interaction
streamNudgeAll :: Stream -> Double -> IO ()
streamNudgeAll s nudge = do tempo <- takeMVar $ sTempoMV s
putMVar (sTempoMV s) $ tempo {T.nudged = nudge}
streamResetCycles :: Stream -> IO ()
streamResetCycles s = do _ <- T.resetCycles (sTempoMV s)
return ()
hasSolo :: Map.Map k PlayState -> Bool
hasSolo = (>= 1) . length . filter solo . Map.elems
streamList :: Stream -> IO ()
streamList s = do pMap <- readMVar (sPMapMV s)
let hs = hasSolo pMap
putStrLn $ concatMap (showKV hs) $ Map.toList pMap
where showKV :: Bool -> (PatId, PlayState) -> String
showKV True (k, (PlayState _ _ True _)) = k ++ " - solo\n"
showKV True (k, _) = "(" ++ k ++ ")\n"
showKV False (k, (PlayState _ False _ _)) = k ++ "\n"
showKV False (k, _) = "(" ++ k ++ ") - muted\n"
-- Evaluation of pat is forced so exceptions are picked up here, before replacing the existing pattern.
streamReplace :: Show a => Stream -> a -> ControlPattern -> IO ()
streamReplace s k pat
= E.catch (do let x = queryArc pat (Arc 0 0)
tempo <- readMVar $ sTempoMV s
input <- takeMVar $ sInput s
-- put change time in control input
now <- O.time
let cyc = T.timeToCycles tempo now
putMVar (sInput s) $
Map.insert ("_t_all") (pure $ VR cyc) $ Map.insert ("_t_" ++ show k) (pure $ VR cyc) input
-- update the pattern itself
pMap <- seq x $ takeMVar $ sPMapMV s
let playState = updatePS $ Map.lookup (show k) pMap
putMVar (sPMapMV s) $ Map.insert (show k) playState pMap
calcOutput s
return ()
)
(\(e :: E.SomeException) -> hPutStrLn stderr $ "Error in pattern: " ++ show e
)
where updatePS (Just playState) = do playState {pattern = pat, history = pat:(history playState)}
updatePS Nothing = PlayState pat False False [pat]
streamMute :: Show a => Stream -> a -> IO ()
streamMute s k = withPatId s (show k) (\x -> x {mute = True})
streamMutes :: Show a => Stream -> [a] -> IO ()
streamMutes s ks = withPatIds s (map show ks) (\x -> x {mute = True})
streamUnmute :: Show a => Stream -> a -> IO ()
streamUnmute s k = withPatId s (show k) (\x -> x {mute = False})
streamSolo :: Show a => Stream -> a -> IO ()
streamSolo s k = withPatId s (show k) (\x -> x {solo = True})
streamUnsolo :: Show a => Stream -> a -> IO ()
streamUnsolo s k = withPatId s (show k) (\x -> x {solo = False})
streamOnce :: Stream -> ControlPattern -> IO ()
streamOnce st p
= do sMap <- readMVar (sInput st)
tempo <- readMVar (sTempoMV st)
now <- O.time
let fakeTempo = T.Tempo {T.cps = T.cps tempo,
T.atCycle = 0,
T.atTime = now,
T.paused = False,
T.nudged = 0
}
sMap' = Map.insert "_cps" (pure $ VF $ T.cps tempo) sMap
es = filter eventHasOnset $ query p (State {arc = (Arc 0 1),
controls = sMap'
}
)
at e = sched fakeTempo $ start $ whole e
on e = sched tempo $ start $ whole e
cpsChanges = map (\e -> (on e - now, Map.lookup "cps" $ value e)) es
messages target =
catMaybes $ map (\e -> do m <- toMessage (at e + (oLatency target)) target fakeTempo e
return $ (at e, m)
) es
mapM_ (\(Cx target udp) ->
E.catch (mapM_ (send target (oLatency target) udp) (messages target))
(\(_ ::E.SomeException)
-> putStrLn $ "Failed to send. Is the '" ++ oName target ++ "' target running?"
)
) (sCxs st)
mapM_ (doCps $ sTempoMV st) cpsChanges
return ()
withPatId :: Stream -> PatId -> (PlayState -> PlayState) -> IO ()
withPatId s k f = withPatIds s [k] f
withPatIds :: Stream -> [PatId] -> (PlayState -> PlayState) -> IO ()
withPatIds s ks f
= do playMap <- takeMVar $ sPMapMV s
let pMap' = foldr (Map.update (\x -> Just $ f x)) playMap ks
putMVar (sPMapMV s) pMap'
calcOutput s
return ()
-- TODO - is there a race condition here?
streamMuteAll :: Stream -> IO ()
streamMuteAll s = do modifyMVar_ (sOutput s) $ return . const silence
modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = True})
streamHush :: Stream -> IO ()
streamHush s = do modifyMVar_ (sOutput s) $ return . const silence
modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {pattern = silence, history = silence:history x})
streamUnmuteAll :: Stream -> IO ()
streamUnmuteAll s = do modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = False})
calcOutput s
streamAll :: Stream -> (ControlPattern -> ControlPattern) -> IO ()
streamAll s f = do _ <- swapMVar (sGlobalFMV s) f
calcOutput s
streamSet :: Valuable a => Stream -> String -> Pattern a -> IO ()
streamSet s k pat = do sMap <- takeMVar $ sInput s
let pat' = toValue <$> pat
sMap' = Map.insert k pat' sMap
putMVar (sInput s) $ sMap'
streamSetI :: Stream -> String -> Pattern Int -> IO ()
streamSetI = streamSet
streamSetF :: Stream -> String -> Pattern Double -> IO ()
streamSetF = streamSet
streamSetS :: Stream -> String -> Pattern String -> IO ()
streamSetS = streamSet
streamSetB :: Stream -> String -> Pattern Bool -> IO ()
streamSetB = streamSet
streamSetR :: Stream -> String -> Pattern Rational -> IO ()
streamSetR = streamSet
calcOutput :: Stream -> IO ()
calcOutput s = do pMap <- readMVar $ sPMapMV s
globalF <- (readMVar $ sGlobalFMV s)
_ <- swapMVar (sOutput s) $ globalF $ toPat $ pMap
return ()
where toPat pMap =
stack $ map pattern $ filter (\pState -> if hasSolo pMap
then solo pState
else not (mute pState)
) (Map.elems pMap)
startTidal :: OSCTarget -> Config -> IO Stream
startTidal target config = startMulti [target] config
startMulti :: [OSCTarget] -> Config -> IO Stream
startMulti targets config =
do sMapMV <- newMVar (Map.empty :: StateMap)
listenTid <- ctrlListen sMapMV config
(pMV, tempoMV, cxs) <- startStream config sMapMV targets
pMapMV <- newMVar Map.empty
globalFMV <- newMVar id
return $ Stream {sConfig = config,
sInput = sMapMV,
sListenTid = listenTid,
sOutput = pMV,
sPMapMV = pMapMV,
sTempoMV = tempoMV,
sGlobalFMV = globalFMV,
sCxs = cxs
}
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.0.14/src/Sound/Tidal/Simple.hs 0000644 0000000 0000000 00000002311 13504651510 015556 0 ustar 00 0000000 0000000 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
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.0.14/src/Sound/Tidal/UI.hs 0000644 0000000 0000000 00000211025 13504651510 014646 0 ustar 00 0000000 0000000 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}
module Sound.Tidal.UI where
import Prelude hiding ((<*), (*>))
import Data.Char (digitToInt, isDigit)
-- import System.Random (randoms, mkStdGen)
import System.Random.MWC
import Control.Monad.ST
import qualified Data.Vector as V
import Data.Word (Word32)
import Data.Ratio ((%),numerator,denominator)
import Data.List (sort, sortOn, findIndices, elemIndex, groupBy, transpose, intercalate)
import Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe)
import qualified Data.Text as T
import qualified Data.Map.Strict as Map
import Data.Bool (bool)
import Sound.Tidal.Bjorklund (bjorklund)
import Sound.Tidal.Core
import qualified Sound.Tidal.Params as P
import Sound.Tidal.Pattern
import Sound.Tidal.Utils
------------------------------------------------------------------------
-- * UI
-- | Randomisation
timeToSeed x = do
let x' = toRational (x*x) / 1000000
let n' = fromIntegral $ numerator x'
let d' = fromIntegral $ denominator x'
initialize (V.fromList [n',d'] :: V.Vector Word32)
timeToRand :: RealFrac a => a -> Double
timeToRand x = runST $ do seed <- timeToSeed x
uniform seed
timeToRands :: RealFrac a => a -> Int -> [Double]
timeToRands x n = V.toList $ runST $ do seed <- timeToSeed x
uniformVector seed n
{-|
`rand` generates a continuous pattern of (pseudo-)random numbers between `0` and `1`.
@
sound "bd*8" # pan rand
@
pans bass drums randomly
@
sound "sn sn ~ sn" # gain rand
@
makes the snares' randomly loud and quiet.
Numbers coming from this pattern are 'seeded' by time. So if you reset
time (via `cps (-1)`, then `cps 1.1` or whatever cps you want to
restart with) the random pattern will emit the exact same _random_
numbers again.
In cases where you need two different random patterns, you can shift
one of them around to change the time from which the _random_ pattern
is read, note the difference:
@
jux (# gain rand) $ sound "sn sn ~ sn" # gain rand
@
and with the juxed version shifted backwards for 1024 cycles:
@
jux (# ((1024 <~) $ gain rand)) $ sound "sn sn ~ sn" # gain rand
@
-}
rand :: Fractional a => Pattern a
rand = Pattern Analog (\(State a@(Arc s e) _) -> [Event a a (realToFrac $ timeToRand $ (e + s)/2)])
{- | Just like `rand` but for whole numbers, `irand n` generates a pattern of (pseudo-) random whole numbers between `0` to `n-1` inclusive. Notably used to pick a random
samples from a folder:
@
d1 $ segment 4 $ n (irand 5) # sound "drum"
@
-}
irand :: Num a => Int -> Pattern a
irand i = fromIntegral . (floor :: Double -> Int) . (* fromIntegral i) <$> rand
{- | 1D Perlin (smooth) noise, works like rand but smoothly moves between random
values each cycle. `perlinWith` takes a pattern as the RNG's "input" instead
of automatically using the cycle count.
@
d1 $ s "arpy*32" # cutoff (perlinWith (saw * 4) * 2000)
@
will generate a smooth random pattern for the cutoff frequency which will
repeat every cycle (because the saw does)
The `perlin` function uses the cycle count as input and can be used much like @rand@.
-}
perlinWith :: Pattern Double -> Pattern Double
perlinWith p = interp <$> (p-pa) <*> (timeToRand <$> pa) <*> (timeToRand <$> pb) where
pa = (fromIntegral :: Int -> Double) . floor <$> p
pb = (fromIntegral :: Int -> Double) . (+1) . floor <$> p
interp x a b = a + smootherStep x * (b-a)
smootherStep x = 6.0 * x**5 - 15.0 * x**4 + 10.0 * x**3
perlin :: Pattern Double
perlin = perlinWith (sig fromRational)
{- `perlin2With` is Perlin noise with a 2-dimensional input. This can be
useful for more control over how the randomness repeats (or doesn't).
@
d1
$ s "[supersaw:-12*32]"
# lpf (rangex 60 5000 $ perlin2With (cosine*2) (sine*2))
# lpq 0.3
@
will generate a smooth random cutoff pattern that repeats every cycle without
any reversals or discontinuities (because the 2D path is a circle).
`perlin2` only needs one input because it uses the cycle count as the
second input.
-}
perlin2With :: Pattern Double -> Pattern Double -> Pattern Double
perlin2With x y = (/2) . (+1) $ interp2 <$> xfrac <*> yfrac <*> dota <*> dotb <*> dotc <*> dotd where
fl = fmap ((fromIntegral :: Int -> Double) . floor)
ce = fmap ((fromIntegral :: Int -> Double) . (+1) . floor)
xfrac = x - fl x
yfrac = y - fl y
randAngle a b = 2 * pi * timeToRand (a + 0.0001 * b)
pcos x' y' = cos $ randAngle <$> x' <*> y'
psin x' y' = sin $ randAngle <$> x' <*> y'
dota = pcos (fl x) (fl y) * xfrac + psin (fl x) (fl y) * yfrac
dotb = pcos (ce x) (fl y) * (xfrac - 1) + psin (ce x) (fl y) * yfrac
dotc = pcos (fl x) (ce y) * xfrac + psin (fl x) (ce y) * (yfrac - 1)
dotd = pcos (ce x) (ce y) * (xfrac - 1) + psin (ce x) (ce y) * (yfrac - 1)
interp2 x' y' a b c d = (1.0 - s x') * (1.0 - s y') * a + s x' * (1.0 - s y') * b
+ (1.0 - s x') * s y' * c + s x' * s y' * d
s x' = 6.0 * x'**5 - 15.0 * x'**4 + 10.0 * x'**3
perlin2 :: Pattern Double -> Pattern Double
perlin2 = perlin2With (sig fromRational)
{- | Randomly picks an element from the given list
@
sound "superpiano(3,8)" # note (choose ["a", "e", "g", "c"])
@
plays a melody randomly choosing one of the four notes \"a\", \"e\", \"g\", \"c\".
-}
choose :: [a] -> Pattern a
choose = chooseBy rand
chooseBy :: Pattern Double -> [a] -> Pattern a
chooseBy _ [] = silence
chooseBy f xs = (xs !!!) . floor <$> range 0 (fromIntegral $ length xs) f
{- | Like @choose@, but works on an a list of tuples of values and weights
@
sound "superpiano(3,8)" # note (wchoose [("a",1), ("e",0.5), ("g",2), ("c",1)])
@
In the above example, the "a" and "c" notes are twice as likely to
play as the "e" note, and half as likely to play as the "g" note.
-}
wchoose :: [(a,Double)] -> Pattern a
wchoose = wchooseBy rand
wchooseBy :: Pattern Double -> [(a,Double)] -> Pattern a
wchooseBy pat pairs = match <$> pat
where
match r = values !! head (findIndices (> (r*total)) cweights)
cweights = scanl1 (+) (map snd pairs)
values = map fst pairs
total = sum $ map snd pairs
{- |
Similar to `degrade` `degradeBy` allows you to control the percentage of events that
are removed. For example, to remove events 90% of the time:
@
d1 $ slow 2 $ degradeBy 0.9 $ sound "[[[feel:5*8,feel*3] feel:3*8], feel*4]"
# accelerate "-6"
# speed "2"
@
-}
degradeBy :: Pattern Double -> Pattern a -> Pattern a
degradeBy = tParam _degradeBy
_degradeBy :: Double -> Pattern a -> Pattern a
_degradeBy x p = fmap fst $ filterValues ((> x) . snd) $ (,) <$> p <*> rand
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 :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
someCyclesBy x = when test
where test c = timeToRand (fromIntegral c :: Double) < x
somecyclesBy :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
somecyclesBy = someCyclesBy
someCycles :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
someCycles = someCyclesBy 0.5
somecycles :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
somecycles = someCycles
{- | `degrade` randomly removes events from a pattern 50% of the time:
@
d1 $ slow 2 $ degrade $ sound "[[[feel:5*8,feel*3] feel:3*8], feel*4]"
# accelerate "-6"
# speed "2"
@
The shorthand syntax for `degrade` is a question mark: `?`. Using `?`
will allow you to randomly remove events from a portion of a pattern:
@
d1 $ slow 2 $ sound "bd ~ sn bd ~ bd? [sn bd?] ~"
@
You can also use `?` to randomly remove events from entire sub-patterns:
@
d1 $ slow 2 $ sound "[[[feel:5*8,feel*3] feel:3*8]?, feel*4]"
@
-}
degrade :: Pattern a -> Pattern a
degrade = _degradeBy 0.5
{- | (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 (\(Event w p _) s -> Event w p s) es
(drop i $ cycle $ map value es)
| otherwise =
zipWith (\(Event w p _) s -> Event w p 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 (Event w p v) =
do
p' <- subArc p a
return (Event w p' v)
-- | @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)
-- @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') . whole) (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 {nature = Digital, query = f}
where f st = map (\(a,b,c) -> Event 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 (\(Event a' _ i) -> queryArc (compressArcTo a' (inside (pure $ 1/toRational(length (queryArc s (Arc (sam (start $ arc st)) (nextSam (start $ arc st)))))) (rotR (toRational i)) p)) a') (query s st)}
-- | @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
{-|
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 maskpat pat = filterJust $ toMaybe <$> pat'
where pat' = matchManyToOne (flip const) maskpat pat
toMaybe (True, a) = Just a
toMaybe (False, _) = Nothing
{-
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 whole $ 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 w p' v) ->
Event (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 Digital (\(State a@(Arc s _) _) -> events a $ sam s)
where events a seed = mapMaybe toEv $ zip arcs shuffled
where shuffled = map snd $ sortOn fst $ zip rs [0 .. (n'-1)]
rs = timeToRands seed n'
arcs = zipWith Arc fractions (tail fractions)
fractions = map (+ (sam $ start a)) [0, 1 / fromIntegral n' .. 1]
toEv (a',v) = do a'' <- subArc a a'
return $ Event 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 a a' v) -> Event a a' (a,v))
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 b b' xs) -> map (Event 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 (Arc s e) a' v) =
do
a'' <- subArc (Arc newS newE) a'
return (Event (Arc newS newE) a'' v)
where newS = s + (dur * fromIntegral n)
newE = newS + dur
dur = (e - s) / fromIntegral d
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)
-- Uses the first (binary) pattern to switch between the following two
-- patterns.
sew :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a
sew stitch p1 p2 = overlay (const <$> p1 <* a) (const <$> p2 <* b)
where a = filterValues id stitch
b = filterValues not stitch
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 = do
from <- fromP
to <- toP
_range from to 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 pi fs pat = innerJoin $ (\i -> _pickF i fs pat) <$> pi
_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 Digital $ \(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)
snip a b | start (whole b) >= stop (whole a) = Just b
| stop (whole b) <= stop (whole a) = Nothing
| otherwise = Just b {whole = Arc (stop $ whole a) (stop $ whole b)}
constrainPart :: Event a -> Maybe (Event a)
constrainPart e = do a <- subArc (whole 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
smooth :: Fractional a => Pattern a -> Pattern a
smooth p = Pattern Analog $ \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 = 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
{ whole = queryA'
, part = queryA'
, value = value e + ((v - value e) * pc)}
]
pc | delta' (whole e) == 0 = 0
| otherwise = fromRational $ (eventPartStart e - wholeStart e) / delta' (whole 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
(\(Event w p v) ->
mapMaybe (munge w p) $ query (compressArc (cycleArc w) (v |* P.speed (pure $ fromRational $ 1/(stop w - start w)))) st {arc = p}
)
(query pp st)
munge oWhole oPart (Event iWhole iPart v) =
do w' <- subArc oWhole iWhole
p' <- subArc oPart iPart
return (Event w' p' v)
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
tidal-1.0.14/src/Sound/Tidal/MiniTidal/ 0000755 0000000 0000000 00000000000 13504651510 015646 5 ustar 00 0000000 0000000 tidal-1.0.14/src/Sound/Tidal/MiniTidal/Token.hs 0000644 0000000 0000000 00000012446 13504651510 017271 0 ustar 00 0000000 0000000 module Sound.Tidal.MiniTidal.Token where
import Data.Functor.Identity (Identity)
import Text.Parsec.Prim (ParsecT,parserZero)
import Text.ParserCombinators.Parsec
import Text.Parsec.Language (haskellDef)
import qualified Text.ParserCombinators.Parsec.Token as P
tokenParser :: P.TokenParser a
tokenParser = P.makeTokenParser $ haskellDef {
P.reservedNames = ["chop","striate","striate'","stut","jux","brak","rev",
"palindrome","fast","density","slow","iter","iter'","trunc","swingBy","every","whenmod",
"append","append'","silence","s","sound","n","up","speed","vowel","pan","shape","gain",
"accelerate","bandf","bandq","begin","coarse","crush","cut","cutoff","delayfeedback",
"delaytime","delay","end","hcutoff","hresonance","loop","resonance","shape","unit",
"sine","saw","isaw","fit","irand","tri","square","rand",
"pure","return","stack","fastcat","slowcat","cat","atom","overlay","run","scan","fast'",
"fastGap","densityGap","sparsity","rotL","rotR","playFor","every'","foldEvery",
"cosine","superimpose","trunc","linger","zoom","compress","sliceArc","within","within'",
"revArc","euclid","euclidFull","euclidInv","distrib","wedge","prr","preplace","prep","preplace1",
"protate","prot","prot1","discretise","segment","struct","substruct","compressTo",
"substruct'","stripe","slowstripe","stretch","fit'","chunk","loopFirst","timeLoop","swing",
"choose","degradeBy","unDegradeBy","degradeOverBy","sometimesBy","sometimes","often",
"rarely","almostNever","almostAlways","never","always","someCyclesBy","somecyclesBy",
"someCycles","somecycles","substruct'","repeatCycles","spaceOut","fill","ply","shuffle",
"scramble","breakUp","degrade","randcat","randStruct","toScale'","toScale","cycleChoose",
"d1","d2","d3","d4","d5","d6","d7","d8","d9","t1","t2","t3","t4","t5","t6","t7","t8","t9",
"cps","xfadeIn","note","spread","slowspread","fastspread"],
P.reservedOpNames = ["+","-","*","/","<~","~>","#","|+|","|-|","|*|","|/|","$","\"","|>","<|","|>|","|<|"]
}
{- Not currently in use
angles :: ParsecT String u Identity a -> ParsecT String u Identity a
angles = P.angles tokenParser
braces :: ParsecT String u Identity a -> ParsecT String u Identity a
braces = P.braces tokenParser
charLiteral :: ParsecT String u Identity Char
charLiteral = P.charLiteral tokenParser
colon :: ParsecT String u Identity String
colon = P.colon tokenParser
comma :: ParsecT String u Identity String
comma = P.comma tokenParser
decimal :: ParsecT String u Identity Integer
decimal = P.decimal tokenParser
dot :: ParsecT String u Identity String
dot = P.dot tokenParser
hexadecimal :: ParsecT String u Identity Integer
hexadecimal = P.hexadecimal tokenParser
identifier :: ParsecT String u Identity String
identifier = P.identifier tokenParser
lexeme :: ParsecT String u Identity a -> ParsecT String u Identity a
lexeme = P.lexeme tokenParser
naturalOrFloat :: ParsecT String u Identity (Either Integer Double)
naturalOrFloat = P.naturalOrFloat tokenParser
natural :: ParsecT String u Identity Integer
natural = P.natural tokenParser
octal :: ParsecT String u Identity Integer
octal = P.octal tokenParser
operator :: ParsecT String u Identity String
operator = P.operator tokenParser
semi :: ParsecT String u Identity String
semi = P.semi tokenParser
semiSep1 :: ParsecT String u Identity a -> ParsecT String u Identity [a]
semiSep1 = P.semiSep1 tokenParser
semiSep :: ParsecT String u Identity a -> ParsecT String u Identity [a]
semiSep = P.semiSep tokenParser
-}
brackets :: ParsecT String u Identity a -> ParsecT String u Identity a
brackets = P.brackets tokenParser
commaSep1 :: ParsecT String u Identity a -> ParsecT String u Identity [a]
commaSep1 = P.commaSep1 tokenParser
commaSep :: ParsecT String u Identity a -> ParsecT String u Identity [a]
commaSep = P.commaSep tokenParser
float :: ParsecT String u Identity Double
float = P.float tokenParser
integer :: ParsecT String u Identity Integer
integer = P.integer tokenParser
parens :: ParsecT String u Identity a -> ParsecT String u Identity a
parens = P.parens tokenParser
reservedOp :: String -> ParsecT String u Identity ()
reservedOp = P.reservedOp tokenParser
reserved :: String -> ParsecT String u Identity ()
reserved = P.reserved tokenParser
stringLiteral :: ParsecT String u Identity String
stringLiteral = P.stringLiteral tokenParser
symbol :: String -> ParsecT String u Identity String
symbol = P.symbol tokenParser
whiteSpace :: ParsecT String u Identity ()
whiteSpace = P.whiteSpace tokenParser
functionParser :: String -> Parser ()
functionParser x = reserved x <|> try (parens (functionParser x))
opParser :: String -> Parser ()
opParser x = reservedOp x <|> try (parens (opParser x))
double :: Parser Double
double = choice [
parens $ symbol "-" >> float >>= return . (* (-1)),
parens double,
try float,
try $ fromIntegral <$> integer
]
int :: Parser Int
int = try $ parensOrNot $ fromIntegral <$> integer
parensOrNot :: Parser a -> Parser a
parensOrNot p = p <|> try (parens (parensOrNot p))
nestedParens :: Parser a -> Parser a
nestedParens p = try (parens p) <|> try (parens (nestedParens p))
applied :: Parser a -> Parser a
applied p = opParser "$" >> p
appliedOrNot :: Parser a -> Parser a
appliedOrNot p = applied p <|> p
parensOrApplied :: Parser a -> Parser a
parensOrApplied p = try (parens p) <|> try (applied p)
tidal-1.0.14/src/Sound/Tidal/MiniTidal/TH.hs 0000644 0000000 0000000 00000001055 13504651510 016516 0 ustar 00 0000000 0000000 {-# LANGUAGE TemplateHaskell #-}
module Sound.Tidal.MiniTidal.TH where
import Language.Haskell.TH
import Sound.Tidal.MiniTidal.Token
op :: String -> Q Exp
op x = do -- op "x" >> return T.x
let y = appE [|opParser|] $ return (LitE $ StringL x)
let z = appE [|return|] $ return (VarE $ mkName $ "T." ++ x)
uInfixE y [|(>>)|] z
function :: String -> Q Exp
function x = do -- function "x" >> return T.x
let y = appE [|functionParser|] $ return (LitE $ StringL x)
let z = appE [|return|] $ return (VarE $ mkName $ "T." ++ x)
uInfixE y [|(>>)|] z
tidal-1.0.14/test/ 0000755 0000000 0000000 00000000000 13504651510 012037 5 ustar 00 0000000 0000000 tidal-1.0.14/test/Test.hs 0000644 0000000 0000000 00000001062 13504651510 013311 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
import Test.Microspec
import Sound.Tidal.CoreTest
import Sound.Tidal.MiniTidalTest
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.MiniTidalTest.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.0.14/test/TestUtils.hs 0000644 0000000 0000000 00000002036 13504651510 014334 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
module TestUtils where
import Test.Microspec
import Prelude hiding ((<*), (*>))
import Data.List (sort)
import Sound.Tidal.ParseBP (parseBP_E)
import Sound.Tidal.Pattern
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 p $ State a Map.empty) `shouldBe` (sort $ query 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 p (State a Map.empty)
es' = query 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 p a) ~== (sort $ queryArc p' a)
-- | Utility to create a pattern from a String
ps :: String -> Pattern String
ps = parseBP_E
tidal-1.0.14/test/Sound/ 0000755 0000000 0000000 00000000000 13504651510 013127 5 ustar 00 0000000 0000000 tidal-1.0.14/test/Sound/Tidal/ 0000755 0000000 0000000 00000000000 13504651510 014164 5 ustar 00 0000000 0000000 tidal-1.0.14/test/Sound/Tidal/ControlTest.hs 0000644 0000000 0000000 00000000773 13504651510 017007 0 ustar 00 0000000 0000000 {-# 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)
(stutWith 4 0.25 (# gain 1) $ sound "bd")
(stut 4 1 0.25 $ sound "bd")
tidal-1.0.14/test/Sound/Tidal/UtilsTest.hs 0000644 0000000 0000000 00000003411 13504651510 016457 0 ustar 00 0000000 0000000 {-# 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.0.14/test/Sound/Tidal/MiniTidalTest.hs 0000644 0000000 0000000 00000014131 13504651510 017232 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
module Sound.Tidal.MiniTidalTest where
import Test.Microspec
import Sound.Tidal.MiniTidal
import Sound.Tidal.Context as Tidal
import Data.Either
import Text.ParserCombinators.Parsec (ParseError)
import qualified Data.Map.Strict as Map
parsesTo :: String -> ControlPattern -> Property
parsesTo str p = x `shouldBe` y
where x = query <$> miniTidal str <*> Right (State (Arc 0 16) Map.empty)
y = Right $ query p $ State (Arc 0 16) Map.empty
causesParseError :: String -> Property
causesParseError str = isLeft (miniTidal str :: Either ParseError ControlPattern) `shouldBe` True
run :: Microspec ()
run =
describe "miniTidal" $ do
it "parses the empty string as silence" $
"" `parsesTo` silence
it "parses a string containing only spaces as silence" $
" " `parsesTo` silence
it "parses a very simple single 's' pattern" $
"s \"bd cp\"" `parsesTo` s "bd cp"
it "parses a single 's' pattern that uses angle brackets" $
"s \"\"" `parsesTo` s ""
it "parses a single 's' pattern that uses square brackets" $
"s \"[bd sn] cp\"" `parsesTo` s "[bd sn] cp"
it "parses a single 's' pattern that uses square brackets and *" $
"s \"[bd sn]*2 cp\"" `parsesTo` s "[bd sn]*2 cp"
it "parses a single 's' pattern that uses Bjorklund rhythms" $
"s \"sn(5,16)\"" `parsesTo` s "sn(5,16)"
it "parses a literal int as a double pattern" $
"pan 0" `parsesTo` (pan 0)
it "parses a literal double as a double pattern" $
"pan 1.0" `parsesTo` (pan 1.0)
it "parses a negative literal double as a double pattern" $
"pan (-1.0)" `parsesTo` (pan (-1.0))
it "parses two merged patterns" $
"s \"bd cp\" # pan \"0 1\"" `parsesTo` (s "bd cp" # pan "0 1")
it "parses three merged patterns" $
"s \"bd cp\" # pan \"0 1\" # gain \"0.5 0.7\"" `parsesTo`
(s "bd cp" # pan "0 1" # gain "0.5 0.7")
it "parses three merged patterns, everything in brackets" $
"(s \"bd cp\" # pan \"0 1\" # gain \"0.5 0.7\")" `parsesTo`
((s "bd cp" # pan "0 1" # gain "0.5 0.7"))
it "parses three merged patterns, everything in muliple layers of brackets" $
"(((s \"bd cp\" # pan \"0 1\" # gain \"0.5 0.7\")))" `parsesTo`
((((s "bd cp" # pan "0 1" # gain "0.5 0.7"))))
it "parses three merged patterns with right associative brackets" $
"s \"bd cp\" # (pan \"0 1\" # gain \"0.5 0.7\")" `parsesTo`
(s "bd cp" # (pan "0 1" # gain "0.5 0.7"))
it "parses three merged patterns with left associative brackets" $
"(s \"bd cp\" # pan \"0 1\") # gain \"0.5 0.7\"" `parsesTo`
((s "bd cp" # pan "0 1") # gain "0.5 0.7")
it "parses simple patterns in brackets applied to ParamPattern functions" $
"s (\"bd cp\")" `parsesTo` (s ("bd cp"))
it "parses simple patterns applied to ParamPattern functions with $" $
"s $ \"bd cp\"" `parsesTo` (s $ "bd cp")
it "parses addition of simple patterns" $
"n (\"0 1\" + \"2 3\")" `parsesTo` (n ("0 1" + "2 3"))
it "parses multiplication of simple patterns as a merged parampattern" $
"s \"arpy*8\" # up (\"3\" * \"2\")" `parsesTo` (s "arpy*8" # up ("3" * "2"))
it "parses pan patterns" $
"pan \"0 0.25 0.5 0.75 1\"" `parsesTo` (pan "0 0.25 0.5 0.75 1")
it "parses note patterns" $
"note \"0 0.25 0.5 0.75 1\"" `parsesTo` (note "0 0.25 0.5 0.75 1")
it "parses sine oscillators" $
"pan sine" `parsesTo` (pan sine)
it "parses sine oscillators used in pan patterns" $
"s \"arpy*8\" # pan sine" `parsesTo` (s "arpy*8" # pan sine)
it "parses fast transformations of parampatterns" $
"fast 2 $ s \"bd cp\"" `parsesTo` (fast 2 $ s "bd cp")
it "parses fast transformations of parampatterns when in brackets" $
"(fast 2) $ s \"bd cp\"" `parsesTo` ((fast 2) $ s "bd cp")
it "parses rev transformations of parampatterns" $
"rev $ s \"bd cp\"" `parsesTo` (rev $ s "bd cp")
it "parses rev transformations of parampatterns when in brackets" $
"(rev) $ s \"bd cp\"" `parsesTo` ((rev) $ s "bd cp")
it "parses jux transformations with transformations in brackets" $
"jux (rev) $ s \"arpy*8\" # up \"0 2 3 5 3 5 7 8\"" `parsesTo`
(jux (rev) $ s "arpy*8" # up "0 2 3 5 3 5 7 8")
it "parses jux transformations with transformations not in brackets" $
"jux rev $ s \"arpy*8\" # up \"0 2 3 5 3 5 7 8\"" `parsesTo`
(jux rev $ s "arpy*8" # up "0 2 3 5 3 5 7 8")
it "doesn't parse when a transformation requiring an argument is provided without parens or $ to jux" $
causesParseError "jux fast 2 $ s \"bd*4 cp\""
it "parses multiple fast transformations of parampatterns" $
"fast 2 $ fast 2 $ s \"bd cp\"" `parsesTo` (fast 2 $ fast 2 $ s "bd cp")
it "parses an 'every' transformation applied to a simple s pattern" $
"every 2 (fast 2) (s \"bd cp\")" `parsesTo` (every 2 (fast 2) (s "bd cp"))
it "parses a transformed pattern merged with a pattern constructed from parampatterning an arithmetic expression on patterns" $
"(every 2 (fast 2) $ s \"arpy*8\") # up (\"[0 4 7 2,16 12 12 16]\" - \"<0 3 5 7>\")" `parsesTo` ((every 2 (fast 2) $ s "arpy*8") # up ("[0 4 7 2,16 12 12 16]" - "<0 3 5 7>"))
it "parses a fast transformation applied to a simple (ie. non-param) pattern" $
"up (fast 2 \"<0 2 3 5>\")" `parsesTo`
(up (fast 2 "<0 2 3 5>"))
it "parses a binary Num function spread over a simple Num pattern" $
"n (spread (+) [2,3,4] \"1 2 3\")" `parsesTo`
(n (spread (+) [2,3,4] "1 2 3"))
it "parses an $ application spread over partially applied transformations of a non-Control Pattern" $
"n (spread ($) [density 2, rev, slow 2] $ \"1 2 3 4\")" `parsesTo`
(n (spread ($) [density 2, rev, slow 2] $ "1 2 3 4"))
it "parses an $ application spread over partially applied transformations of a Control Pattern" $
"spread ($) [density 2, rev, slow 2, striate 3] $ sound \"[bd*2 [~ bd]] [sn future]*2 cp jvbass*4\"" `parsesTo`
(spread ($) [density 2, rev, slow 2, striate 3] $ sound "[bd*2 [~ bd]] [sn future]*2 cp jvbass*4")
tidal-1.0.14/test/Sound/Tidal/ParseTest.hs 0000644 0000000 0000000 00000006365 13504651510 016444 0 ustar 00 0000000 0000000 {-# 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 ! 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 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.0.14/test/Sound/Tidal/PatternTest.hs 0000644 0000000 0000000 00000064215 13504651510 017005 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
module Sound.Tidal.PatternTest where
import Test.Microspec
import TestUtils
import Prelude hiding ((*>), (<*))
import Data.Bifunctor (first, second)
import Data.Ratio
import Sound.Tidal.Control
import Sound.Tidal.Core
import Sound.Tidal.Pattern
import Sound.Tidal.UI
import qualified Data.Map.Strict as Map
run :: Microspec ()
run =
describe "Sound.Tidal.Pattern" $ do
describe "Arc" $ do
it "Arc is a Functor: Apply a given function to the start and end values of an Arc" $ do
let res = fmap (+1) (Arc 3 5)
property $ ((Arc 4 6) :: Arc) === res
describe "Event" $ do
it "(Bifunctor) first: Apply a function to the Arc elements: whole and part" $ do
let res = Event (Arc 1 2) (Arc 3 4) 5 :: Event Int
f = (+1)
property $
first f res ===
Event (Arc 2 3) (Arc 4 5) 5
it "(Bifunctor) second: Apply a function to the event element" $ do
let res = Event (Arc 1 2) (Arc 3 4) 5 :: Event Int
f = (+1)
property $
second f res ===
Event (Arc 1 2) (Arc 3 4) 6
describe "whole" $ do
it "returns the whole Arc in an Event" $ do
property $ Arc 1 2 === whole (Event (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 (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 (Arc 1 2 :: Arc) (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 (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 (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 (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 (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 (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 (Arc 0 1) (Arc 0.25 1) (0 :: Int)),
(Event (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 (Arc (1 % 1) (5 % 4)) (Arc (1 % 1) (5 % 4)) ("a" :: String)),
(Event (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,1)), 8 :: 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 (Arc (0 % 1) (1 % 2)) (Arc (0 % 1) (1 % 2)) ("a" :: String)),
(Event (Arc (1 % 2) (2 % 3)) (Arc (1 % 2) (2 % 3)) "d"),
(Event (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 (Arc (0 % 1) (1 % 4)) (Arc (0 % 1) (1 % 4)) ("a" :: String)),
(Event (Arc (1 % 4) (1 % 2)) (Arc (1 % 4) (1 % 2)) "b"),
(Event (Arc (1 % 2) (2 % 3)) (Arc (1 % 2) (2 % 3)) "c"),
(Event (Arc (2 % 3) (5 % 6)) (Arc (2 % 3) (5 % 6)) "d"),
(Event (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 (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 (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 (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 (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 (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 (Arc 1 2) (Arc 3 4) (5 :: Int))
describe "eventValue" $ do
it "retrieve the second value from a tuple" $ do
property $ 5 === eventValue (Event (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 (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 (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 (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 (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 (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 (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 (Arc 1 2) (Arc 3 4) 5) (Event (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 (Arc 1 2) (Arc 3 4) 5) (Event (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 (Arc 1 2) (Arc 3 4) 5) (Event (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 (Arc 1 2) (Arc 3 4) 5) (Event (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 (Arc 1 2) (Arc 3 4) (5 :: Int))]
property $ [Event (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 (Arc 1 2) (Arc 3 4) (5 :: Int)), (Event (Arc 1 2) (Arc 4 3) (5 :: Int))]
property $ [(Event (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 (Arc 1 2) (Arc 3 4) 5), (Event (Arc 7 8) (Arc 4 3) (5 :: Int))]
property $ [Event (Arc 1 2) (Arc 3 4) 5, Event (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 (Arc 1 2) (Arc 3 4) (5 :: Int), Event (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 (Arc 1 2) (Arc 3 4) (5 :: Int), Event (Arc 1 2) (Arc 4 3) 5] [Event (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 (Arc 1 2) (Arc 3 4) (5 :: Int)] [Event (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) (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 = 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.5), (((1, 5%4), (1, 5%4)), 1.0), (((5%4, 3%2), (5%4, 3%2)), 1.5)] === 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 (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 (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 (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 (Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 0.5)) "x")
tidal-1.0.14/test/Sound/Tidal/ScalesTest.hs 0000644 0000000 0000000 00000050104 13504651510 016572 0 ustar 00 0000000 0000000 {-# 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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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 Int)
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)
(twoOctavesOf12NoteScale::Pattern Int)
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 Int)
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 Int)
tidal-1.0.14/test/Sound/Tidal/CoreTest.hs 0000644 0000000 0000000 00000013262 13504651510 016254 0 ustar 00 0000000 0000000 {-# 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` fmap toEvent [(((0,0), (0,0)), 0 :: Float)]
it "0.25" $
(queryArc saw (Arc 0.25 0.25)) `shouldBe` fmap toEvent [(((0.25,0.25), (0.25,0.25)), 0.25 :: Float)]
it "0.5" $
(queryArc saw (Arc 0.5 0.5)) `shouldBe` fmap toEvent [(((0.5,0.5), (0.5,0.5) ), 0.5 :: Float)]
it "0.75" $
(queryArc saw (Arc 0.75 0.75)) `shouldBe` fmap toEvent [(((0.75,0.75), (0.75,0.75)), 0.75 :: Float)]
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` fmap toEvent [(((0,1), (0,1)), 3 :: Float)]
it "works on the right of <*>" $ do
(queryArc ((fast 4 $ pure (+3)) <*> saw) (Arc 0 1))
`shouldBe` fmap toEvent
[(((0,0.25), (0,0.25)), 3 :: Float),
(((0.25,0.5), (0.25,0.5)), 3.25),
(((0.5,0.75), (0.5,0.75)), 3.5),
(((0.75,1), (0.75,1)), 3.75)
]
it "can be reversed" $ do
it "works with whole cycles" $
(queryArc (rev saw) (Arc 0 1))
`shouldBe` fmap toEvent [(((0,1), (0,1)), 0.5 :: Float)]
it "works with half cycles" $
(queryArc (rev saw) (Arc 0 0.5))
`shouldBe` fmap toEvent [(((0,0.5), (0,0.5)), 0.75 :: Float)]
it "works with inset points" $
(queryArc (rev saw) (Arc 0.25 0.25))
`shouldBe` fmap toEvent [(((0.25,0.25), (0.25,0.25)), 0.75 :: Float)]
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 0.25 0.5 0.75 1 0.75 0.5 0.25")
it "can be added to" $ do
comparePD (Arc 0 1)
(struct "t*8" $ (tri :: Pattern Double) + 1)
("1 1.25 1.5 1.75 2 1.75 1.5 1.25")
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.0.14/test/Sound/Tidal/UITest.hs 0000644 0000000 0000000 00000027123 13504651510 015702 0 ustar 00 0000000 0000000 {-# 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 0.25 0.5 0.75" :: Pattern Double)
it "can hold a value over multiple cycles" $ do
comparePD (Arc 0 8)
(segment 0.5 saw)
(slow 2 "0" :: Pattern Double)
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` fmap toEvent [(((0, 0), (0, 0)), 0.5000844 :: Float)]
it "at 1/4 of a cycle" $
(queryArc rand (Arc 0.25 0.25)) `shouldBe` fmap toEvent
[(((0.25, 0.25), (0.25, 0.25)), 0.8587171 :: Float)]
it "at 3/4 of a cycle" $
(queryArc rand (Arc 0.75 0.75)) `shouldBe` fmap toEvent
[(((0.75, 0.75), (0.75, 0.75)), 0.7277789 :: Float)]
describe "range" $ do
describe "scales a pattern to the supplied range" $ do
describe "from 3 to 4" $ do
it "at the start of a cycle" $
(queryArc (Sound.Tidal.UI.range 3 4 saw) (Arc 0 0)) `shouldBe` fmap toEvent
[(((0, 0), (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` fmap toEvent
[(((0.25, 0.25), (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` fmap toEvent
[(((0.75, 0.75), (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` fmap toEvent
[(((0.5, 0.5), (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` fmap toEvent
[(((0, 0), (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` fmap toEvent
[(((0.25, 0.25), (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` fmap toEvent
[(((0.75, 0.75), (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` fmap toEvent
[(((0.5, 0.5), (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"::Pattern Int) |+ chooseBy (sig fromRational) [0,1,2,3])
("<0>"::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)