diff --git a/Release/EffectsMenuDefaults.xml b/Release/EffectsMenuDefaults.xml
new file mode 100644
index 0000000000000000000000000000000000000000..a6d55e94ce88704bea60dd5061da791559c72779
--- /dev/null
+++ b/Release/EffectsMenuDefaults.xml
@@ -0,0 +1,98 @@
+<EffectMenuList>
+ <Group>
+ <!-- Effects menu group name; audio dynamics compression, not data compression -->
+ <Name>Volume and Compression</Name>
+ <Effects>
+ <Effect>Amplify</Effect>
+ <Effect>Compressor</Effect>
+ <Effect>Limiter</Effect>
+ <Effect>Normalize</Effect>
+ <Effect>Loudness Normalization</Effect>
+ <Effect>Auto Duck</Effect>
+ </Effects>
+ </Group>
+ <Group>
+ <!-- Effects menu group name -->
+ <Name>Fading</Name>
+ <Effects>
+ <Effect>Fade In</Effect>
+ <Effect>Fade Out</Effect>
+ <Effect>Studio Fade Out</Effect>
+ <Effect>Adjustable Fade</Effect>
+ <Effect>Crossfade Clips</Effect>
+ <Effect>Crossfade Tracks</Effect>
+ </Effects>
+ </Group>
+ <Group>
+ <Name>Pitch and Tempo</Name>
+ <Effects>
+ <Effect>Change Pitch</Effect>
+ <Effect>Change Speed and Pitch</Effect>
+ <Effect>Change Tempo</Effect>
+ <Effect>Paulstretch</Effect>
+ <Effect>Sliding Stretch</Effect>
+ </Effects>
+ </Group>
+ <Group>
+ <Name>EQ and Filters</Name>
+ <Effects>
+ <Effect>Bass and Treble</Effect>
+ <Effect>Graphic EQ</Effect>
+ <Effect>Filter Curve EQ</Effect>
+ <Effect>High-Pass Filter</Effect>
+ <Effect>Low-Pass Filter</Effect>
+ <Effect>Shelf Filter</Effect>
+ <Effect>Notch Filter</Effect>
+ <Effect>Classic Filters</Effect>
+ </Effects>
+ </Group>
+ <Group>
+ <Name>Noise Removal and Repair</Name>
+ <Effects>
+ <Effect>Click Removal</Effect>
+ <Effect>Noise Reduction</Effect>
+ <Effect>Noise Gate</Effect>
+ <Effect>Repair</Effect>
+ <Effect>Clip Fix</Effect>
+ </Effects>
+ </Group>
+ <Group>
+ <Name>Delay and Reverb</Name>
+ <Effects>
+ <Effect>Echo</Effect>
+ <Effect>Reverb</Effect>
+ <Effect>Delay</Effect>
+ </Effects>
+ </Group>
+ <Group>
+ <Name>Distortion and Modulation</Name>
+ <Effects>
+ <Effect>Tremolo</Effect>
+ <Effect>Distortion</Effect>
+ <Effect>Wahwah</Effect>
+ <Effect>Phaser</Effect>
+ <Effect>Vocoder</Effect>
+ </Effects>
+ </Group>
+ <Group>
+ <!-- Effects menu group name -->
+ <Name>Special</Name>
+ <Effects>
+ <Effect>Repeat</Effect>
+ <Effect>Reverse</Effect>
+ <Effect>Invert</Effect>
+ <Effect>Truncate Silence</Effect>
+ <Effect>Vocal Reduction and Isolation</Effect>
+ <Effect>Vocal Remover</Effect>
+ </Effects>
+ </Group>
+ <Group>
+ <Name>Spectral Tools</Name>
+ <Effects>
+ <Effect>Spectral Delete</Effect>
+ <Effect>Spectral Edit Multi Tool</Effect>
+ <Effect>Spectral Edit Parametric EQ</Effect>
+ <Effect>Spectral Edit Shelves</Effect>
+ </Effects>
+ </Group>
+</EffectMenuList>
diff --git a/Release/Languages/af/audacity.mo b/Release/Languages/af/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..970a3108a5d3c06060accf665d4c44bece03cfa4
Binary files /dev/null and b/Release/Languages/af/audacity.mo differ
diff --git a/Release/Languages/ar/audacity.mo b/Release/Languages/ar/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..145839f308bab09a821b4e99e7c6bad77f749f77
Binary files /dev/null and b/Release/Languages/ar/audacity.mo differ
diff --git a/Release/Languages/be/audacity.mo b/Release/Languages/be/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..1bdba3c3c531919df9817fb767f89704f70cb179
Binary files /dev/null and b/Release/Languages/be/audacity.mo differ
diff --git a/Release/Languages/bg/audacity.mo b/Release/Languages/bg/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..c75306e8041b0038954068efafd17061dab8b193
Binary files /dev/null and b/Release/Languages/bg/audacity.mo differ
diff --git a/Release/Languages/bn/audacity.mo b/Release/Languages/bn/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..10302253e6120235c115e80167e71eb6c51c6d33
Binary files /dev/null and b/Release/Languages/bn/audacity.mo differ
diff --git a/Release/Languages/bs/audacity.mo b/Release/Languages/bs/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..d160e5bc7992afb503d05a2b043023a0a90c704e
Binary files /dev/null and b/Release/Languages/bs/audacity.mo differ
diff --git a/Release/Languages/ca/audacity.mo b/Release/Languages/ca/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..fd622b2409055711355f5eddf84a474e402a31b4
Binary files /dev/null and b/Release/Languages/ca/audacity.mo differ
diff --git a/Release/Languages/ca_ES@valencia/audacity.mo b/Release/Languages/ca_ES@valencia/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..d92359b54c6cb1e972ec36ec98010fa9b7dd60e8
Binary files /dev/null and b/Release/Languages/ca_ES@valencia/audacity.mo differ
diff --git a/Release/Languages/co/audacity.mo b/Release/Languages/co/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..bb7e30a6a55c6fb4d2026d814b7f140385109069
Binary files /dev/null and b/Release/Languages/co/audacity.mo differ
diff --git a/Release/Languages/cs/audacity.mo b/Release/Languages/cs/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..05f3b60ae4abf0665b9219406f78484a3d5ce9d4
Binary files /dev/null and b/Release/Languages/cs/audacity.mo differ
diff --git a/Release/Languages/cy/audacity.mo b/Release/Languages/cy/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..d0ad28dd94039c1f4d176cabc939c5e5355f2154
Binary files /dev/null and b/Release/Languages/cy/audacity.mo differ
diff --git a/Release/Languages/da/audacity.mo b/Release/Languages/da/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..3a88d48622acd6df000b0bc5564c83e535bba131
Binary files /dev/null and b/Release/Languages/da/audacity.mo differ
diff --git a/Release/Languages/de/audacity.mo b/Release/Languages/de/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..e2bf17fd1fe76bf33205afb32bbad28451861935
Binary files /dev/null and b/Release/Languages/de/audacity.mo differ
diff --git a/Release/Languages/el/audacity.mo b/Release/Languages/el/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..b5417eefacc193dfb17025964d9e865068309c15
Binary files /dev/null and b/Release/Languages/el/audacity.mo differ
diff --git a/Release/Languages/es/audacity.mo b/Release/Languages/es/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..0b62b6b64e31c1a8050acb06f9afd117dfd6b206
Binary files /dev/null and b/Release/Languages/es/audacity.mo differ
diff --git a/Release/Languages/eu/audacity.mo b/Release/Languages/eu/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..40d5ae1d88b3c0ebfb376ceedb56c18a68ef9871
Binary files /dev/null and b/Release/Languages/eu/audacity.mo differ
diff --git a/Release/Languages/eu_ES/audacity.mo b/Release/Languages/eu_ES/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..473499ac3348f6e7c1e71e6dfd470845a8231782
Binary files /dev/null and b/Release/Languages/eu_ES/audacity.mo differ
diff --git a/Release/Languages/fa/audacity.mo b/Release/Languages/fa/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..4bcabb9d5026e8e341c9c7b2f9bbac834a1c3736
Binary files /dev/null and b/Release/Languages/fa/audacity.mo differ
diff --git a/Release/Languages/fi/audacity.mo b/Release/Languages/fi/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..b3b2eee00e682f941a53a282f439facc6740208f
Binary files /dev/null and b/Release/Languages/fi/audacity.mo differ
diff --git a/Release/Languages/fr/audacity.mo b/Release/Languages/fr/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..8621984b56ce0ef75a4b10674aa88c0ed77b539b
Binary files /dev/null and b/Release/Languages/fr/audacity.mo differ
diff --git a/Release/Languages/ga/audacity.mo b/Release/Languages/ga/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..6c18dbd40550ccdd8011e66679a96ba76c2bf4fc
Binary files /dev/null and b/Release/Languages/ga/audacity.mo differ
diff --git a/Release/Languages/gl/audacity.mo b/Release/Languages/gl/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..0fbf0e0655d66532742295688eb1e5093da37431
Binary files /dev/null and b/Release/Languages/gl/audacity.mo differ
diff --git a/Release/Languages/he/audacity.mo b/Release/Languages/he/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..a5bf9570a24ac12d7ec4f0fbe0cf95bbd900474b
Binary files /dev/null and b/Release/Languages/he/audacity.mo differ
diff --git a/Release/Languages/hi/audacity.mo b/Release/Languages/hi/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..f3b2e08e3ba1ceac7dffeec06e77bce5bca6ae54
Binary files /dev/null and b/Release/Languages/hi/audacity.mo differ
diff --git a/Release/Languages/hr/audacity.mo b/Release/Languages/hr/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..316678e61d8d8371c372141f9d6f2d3e72e3efcd
Binary files /dev/null and b/Release/Languages/hr/audacity.mo differ
diff --git a/Release/Languages/hu/audacity.mo b/Release/Languages/hu/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..005db52746e3cbfc75aa690de671b864ecd0e8fa
Binary files /dev/null and b/Release/Languages/hu/audacity.mo differ
diff --git a/Release/Languages/hy/audacity.mo b/Release/Languages/hy/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..fe91b5386d5db6e80d66af432a93681a2b30c54e
Binary files /dev/null and b/Release/Languages/hy/audacity.mo differ
diff --git a/Release/Languages/id/audacity.mo b/Release/Languages/id/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..49daf2b5ac1f12a6044ad580efc8ae91c1944b4f
Binary files /dev/null and b/Release/Languages/id/audacity.mo differ
diff --git a/Release/Languages/it/audacity.mo b/Release/Languages/it/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..4a53e043bf5b363f9cfe991cd47b8ce544617496
Binary files /dev/null and b/Release/Languages/it/audacity.mo differ
diff --git a/Release/Languages/ja/audacity.mo b/Release/Languages/ja/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..c7d338e96a93e35482ac9d3368e072173f4b6ecc
Binary files /dev/null and b/Release/Languages/ja/audacity.mo differ
diff --git a/Release/Languages/ka/audacity.mo b/Release/Languages/ka/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..31cc3243c6ac79c856628862c1ce460340e761a5
Binary files /dev/null and b/Release/Languages/ka/audacity.mo differ
diff --git a/Release/Languages/km/audacity.mo b/Release/Languages/km/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..c178d483a6f80dc9ca9c5307761a4899c89c33d2
Binary files /dev/null and b/Release/Languages/km/audacity.mo differ
diff --git a/Release/Languages/ko/audacity.mo b/Release/Languages/ko/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..0391d3dfb07a45814005d20666812008111f7829
Binary files /dev/null and b/Release/Languages/ko/audacity.mo differ
diff --git a/Release/Languages/lt/audacity.mo b/Release/Languages/lt/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..6fdfbe025623b17d0a08f8c8ecaaaf6274cd820f
Binary files /dev/null and b/Release/Languages/lt/audacity.mo differ
diff --git a/Release/Languages/mk/audacity.mo b/Release/Languages/mk/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..2f9d3cfdf1b71585ec0a076ac3d33a2aeb087daa
Binary files /dev/null and b/Release/Languages/mk/audacity.mo differ
diff --git a/Release/Languages/mr/audacity.mo b/Release/Languages/mr/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..931fdb275ce88bc9506645b347ffc3601b444bf7
Binary files /dev/null and b/Release/Languages/mr/audacity.mo differ
diff --git a/Release/Languages/my/audacity.mo b/Release/Languages/my/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..5226392ed5da27b5f7c836bb6f56a27e95e024eb
Binary files /dev/null and b/Release/Languages/my/audacity.mo differ
diff --git a/Release/Languages/nb/audacity.mo b/Release/Languages/nb/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..db3c3c18ba1a4e2a749e7a0de27d806f068a030f
Binary files /dev/null and b/Release/Languages/nb/audacity.mo differ
diff --git a/Release/Languages/nl/audacity.mo b/Release/Languages/nl/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..3e83e1d73e52f322900a698977367171502850c5
Binary files /dev/null and b/Release/Languages/nl/audacity.mo differ
diff --git a/Release/Languages/oc/audacity.mo b/Release/Languages/oc/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..a90bc1eb7f99b6badec05e133bfc0d7e0ad8466e
Binary files /dev/null and b/Release/Languages/oc/audacity.mo differ
diff --git a/Release/Languages/pl/audacity.mo b/Release/Languages/pl/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..95203ebbf1d7af0fc25a33855d3d55f93d69d340
Binary files /dev/null and b/Release/Languages/pl/audacity.mo differ
diff --git a/Release/Languages/pt_BR/audacity.mo b/Release/Languages/pt_BR/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..00d56a97e46d5226ae9fa3565afa04f635dd5cb8
Binary files /dev/null and b/Release/Languages/pt_BR/audacity.mo differ
diff --git a/Release/Languages/pt_PT/audacity.mo b/Release/Languages/pt_PT/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..87cd0b56e1733fbc2c25bd8273a9a3fb228811af
Binary files /dev/null and b/Release/Languages/pt_PT/audacity.mo differ
diff --git a/Release/Languages/ro/audacity.mo b/Release/Languages/ro/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..bcdd446eeea043b75af8e0624e270d833eb4e59f
Binary files /dev/null and b/Release/Languages/ro/audacity.mo differ
diff --git a/Release/Languages/ru/audacity.mo b/Release/Languages/ru/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..d59648b9dfaa5217b50e4ae468e477f09b95c51f
Binary files /dev/null and b/Release/Languages/ru/audacity.mo differ
diff --git a/Release/Languages/sk/audacity.mo b/Release/Languages/sk/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..6c7ba98fd1925616177bb65647b53453555519b4
Binary files /dev/null and b/Release/Languages/sk/audacity.mo differ
diff --git a/Release/Languages/sl/audacity.mo b/Release/Languages/sl/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..eb01b59051512703f5c8c1798c49e7b03653bd75
Binary files /dev/null and b/Release/Languages/sl/audacity.mo differ
diff --git a/Release/Languages/sr_RS/audacity.mo b/Release/Languages/sr_RS/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..be8e9fae57149e61f99f8c597e6e046e5841aa0d
Binary files /dev/null and b/Release/Languages/sr_RS/audacity.mo differ
diff --git a/Release/Languages/sr_RS@latin/audacity.mo b/Release/Languages/sr_RS@latin/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..c030cc81c6f1776970921d73d70c5ef0fe47fa1d
Binary files /dev/null and b/Release/Languages/sr_RS@latin/audacity.mo differ
diff --git a/Release/Languages/sv/audacity.mo b/Release/Languages/sv/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..77085ad35ad2dcd886f611079ba9669274ffd1c1
Binary files /dev/null and b/Release/Languages/sv/audacity.mo differ
diff --git a/Release/Languages/ta/audacity.mo b/Release/Languages/ta/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..c1b4ab02d8c428ad1a870e517fa778296f632edc
Binary files /dev/null and b/Release/Languages/ta/audacity.mo differ
diff --git a/Release/Languages/tg/audacity.mo b/Release/Languages/tg/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..8badb1cad64b05d562e4a7e9f4dee9192cc247ef
Binary files /dev/null and b/Release/Languages/tg/audacity.mo differ
diff --git a/Release/Languages/tr/audacity.mo b/Release/Languages/tr/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..ed416dc2ec7f8d1620773da5ae1e4bc560d887a1
Binary files /dev/null and b/Release/Languages/tr/audacity.mo differ
diff --git a/Release/Languages/uk/audacity.mo b/Release/Languages/uk/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..278ebe41918685d8be5e15816e6a185538ee23c3
Binary files /dev/null and b/Release/Languages/uk/audacity.mo differ
diff --git a/Release/Languages/vi/audacity.mo b/Release/Languages/vi/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..c34aba21c9245d9d4a91fea032992e8853d92d48
Binary files /dev/null and b/Release/Languages/vi/audacity.mo differ
diff --git a/Release/Languages/zh_CN/audacity.mo b/Release/Languages/zh_CN/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..42b2bba6c973650f95ba433e3970ee71709cfc24
Binary files /dev/null and b/Release/Languages/zh_CN/audacity.mo differ
diff --git a/Release/Languages/zh_TW/audacity.mo b/Release/Languages/zh_TW/audacity.mo
new file mode 100644
index 0000000000000000000000000000000000000000..953ec249a1a179e1d5d59fdb604fb0bb5071234f
Binary files /dev/null and b/Release/Languages/zh_TW/audacity.mo differ
diff --git a/Release/nyquist/aud-do-support.lsp b/Release/nyquist/aud-do-support.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..23981f5796a210f89ffd49a30fd9b7a6f6f5c79a
--- /dev/null
+++ b/Release/nyquist/aud-do-support.lsp
@@ -0,0 +1,236 @@
+;;; A collection of helper functions and macros to make scripting Audacity commands
+;;; easier and more Lisp-like.
+;;;
+;;; Copyright 2018 - 2020 Audacity Team
+;;; Steve Daulton
+;;; Released under terms of the GNU General Public License version 2:
+;;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+
+
+(defun char-remove (ch str)
+ ;;; Remove all occurrences of character from string.
+ (do ((out "")
+ (i 0 (1+ i)))
+ ((= i (length str)) out)
+ (if (char/= (char str i) ch)
+ (setf out (format nil "~a~a" out (char str i))))))
+
+(defun number-string-p (str)
+ ;;; like digit-char-p for strings
+ (unless (stringp str)
+ (return-from number-string-p nil))
+ (let ((num (string-to-number str)))
+ (if (numberp num)
+ num
+ nil)))
+
+(defmacro string-append (str &rest strs)
+ ;;; Append one or more strings to 'str'
+ `(setf ,str (strcat ,str ,@strs)))
+
+(defun aud-print-command (cmd)
+ ;;; Print a quick reference for command arguments.
+ (let ((help-data (first (aud-do-command "Help" :command cmd :format "LISP")))
+ (out (format nil "(aud-do-command ~s [:key val ...])~%" (string-downcase cmd))))
+ (cond
+ ((string-equal help-data "Command not found")
+ ;Debug out can be copied on all platforms.
+ (format t "~a~a." out help-data)
+ (format nil "~a~a." out help-data))
+ (t (setf help-data (eval-string (quote-string help-data)))
+ (let ((params (second (assoc 'params help-data))))
+ (dolist (p params)
+ (setf out (format nil "~a :~a (~a) default: ~s~%"
+ out
+ (string-downcase (second (assoc 'key p)))
+ (second (assoc 'type p))
+ (second (assoc 'default p))))
+ (let ((enums (assoc 'enum p)))
+ (when enums
+ (setf out (format nil "~a [" out))
+ (dolist (e (second enums))
+ (setf out (format nil "~a~s " out e)))
+ (setf out (format nil "~a]~%" (string-right-trim " " out)))))))
+ (format t "~a" out)
+ out))))
+
+
+(defun aud-do-command (id &rest params)
+ ;; Translate aud-do-command, to (aud-do "command").
+ ;; To avoid unnecessary overhead, only validate when debugging enabled
+ ;; 'aud-import-commands' passes params as a list, so we need to unpack it.
+ (when (and (= (length params) 1)
+ (listp (first params)))
+ (setf params (first params)))
+ (when *tracenable*
+ (aud-check-debug-cache)
+ (let (val-allowed type enums pstr
+ (id-valid (aud-verify-command-id id))
+ (valid-params (aud-get-command-params id))
+ (keystr ""))
+ (if (not id-valid)
+ ; The command may still be valid as
+ ; "GetInfo: Type=Commands" does not return all valid AUD-DO commands.
+ (format t "Debug data unavailable: ~s.~%" id)
+ ;; Command ID recognised, so check params.
+ (dolist (p params)
+ (setf pstr (format nil "~a" p))
+ (cond
+ ((char= (char pstr 0) #\:) ;keyword
+ (setf keystr (subseq pstr 1))
+ (let ((kf (dolist (vp valid-params nil)
+ (when (string-equal (second (assoc 'key vp)) keystr)
+ (return vp)))))
+ (cond
+ (kf ;keyword found
+ (setf type (second (assoc 'type kf)))
+ (setf enums (second (assoc 'enum kf)))
+ (cond
+ ((member type '("int" "float" "double") :test 'string-equal)
+ (setf val-allowed "number"))
+ ((string-equal type "enum")
+ (setf val-allowed enums)) ;a list
+ (t (setf val-allowed type)))) ;"string" "bool" or NIL
+ ;; Invalid keyword, so give some helpful hints:
+ (t (format t "Invalid key in ~s :~a~%" id keystr)
+ ;; pretty print valid keywords
+ (format t "Valid keys for ~a are:~%" id)
+ (dolist (vp valid-params)
+ (dolist (item vp)
+ (let ((itype (first item)))
+ (case itype
+ ('KEY (format t " ~a " (second item)))
+ ('TYPE (when (string-not-equal (second item) "enum")
+ (format t "(~a) " (second item))))
+ ('ENUM (format t "[~a]"
+ (string-trim "()"
+ (format nil "~a" (second item))))))))
+ (format t "~%"))))))
+ (t ;key value
+ (cond
+ ((not val-allowed)
+ (format t "Too many arguments: ~s :~a~%" id keystr))
+ ((listp val-allowed)
+ (unless (member pstr enums :test 'string=) ;case sensitive
+ (format t "Invalid enum in ~s :~a - ~s~%" id keystr p)
+ (format t "Options are:~% ~a~%" enums)))
+ ((string= val-allowed "bool")
+ (unless (or (string= pstr "0") (string= pstr "1"))
+ (format t "~s :~a value must be 0 or 1~%" id keystr)))
+ ((string= val-allowed "number")
+ (unless (or (numberp p) (number-string-p p))
+ (format t "~s :~a value must be a number: ~s~%" id keystr p)))
+ ((string= val-allowed "string")
+ (unless (stringp p)
+ (format t "~s :~a value must be a string: ~a~%" id keystr p))))
+ (psetq val-allowed nil
+ type nil
+ enums nil)))))))
+ ;; Send the command
+ (let ((cmd (format nil "~a:" id)))
+ (dolist (p params)
+ (setf p (format nil "~a" p))
+ (string-append cmd
+ (cond
+ ((char= (char p 0) #\:) ;keyword
+ (format nil " ~a=" (subseq p 1)))
+ (t ;key value
+ (format nil "~s" p)))))
+ (aud-do cmd)))
+
+
+(defun aud-import-commands (&aux cmd)
+ ;; Generate function stubs in the form (aud-<command> [&key arg ...])
+ ;; Call once to make "aud-<command>"s available.
+ ;; We don't call this on load, as we don't want to delay loading Nyquist unnecessarily.
+ (aud-check-debug-cache)
+ (dolist (cmd (aud-get-command))
+ (setf cmd (second (assoc 'id cmd)))
+ (let ((symb (intern (string-upcase (format nil "aud-~a" cmd)))))
+ (eval `(defun ,symb (&rest args)
+ (aud-do-command ,cmd args))))))
+
+
+(defun aud-check-debug-cache ()
+ ;;; Load aud-do-debug-data-cache, updating if necessary.
+ (let ((fqname (format nil "~a~a~a"
+ (string-right-trim (string *file-separator*) (get-temp-path))
+ *file-separator*
+ "aud-do-debug-data-cache.lsp")))
+ (cond ;Update if necessary
+ ((fboundp 'aud-do-version) ;cache is loaded
+ ;; Refresh cache if versions don't match.
+ ;; 'aud-do-version' tests the interned version.
+ ;; 'autoload-helper' tests the disk version and prevents repeating cache refresh in the initial session.
+ (unless (or (string= (format nil "~a" (aud-do-version))
+ (format nil "~a" (get '*audacity* 'version)))
+ (string= (format nil "~a" (autoload-helper fqname 'aud-do-version nil))
+ (format nil "~a" (get '*audacity* 'version))))
+ (aud-refresh-debug-data-cache fqname)))
+ ;cache not loaded, so try loading and refresh if we can't.
+ ((not (load fqname :verbose t))
+ (aud-refresh-debug-data-cache fqname)))))
+
+
+(defun aud-refresh-debug-data-cache (fqname)
+ ;; Cache the list of command profiles as function "aud-get-command", and load it.
+ (labels ((disable-plugins (typestring &aux oldval)
+ ;; Disable plug-ins of type 'typestring' and return it's previous value.
+ (let ((getcmd (format nil "GetPreference: Name=\"~a/Enable\"" typestring)))
+ (setf oldval (first (aud-do getcmd)))
+ (do-set-val typestring oldval 0) ;Disable all plug-ins
+ oldval)) ;may be 0, 1 or ""
+ (do-set-val (typestring oldval newval)
+ ;; If plug-in type was previously enabled ('oldval = true, "1" or empty), set it to 'newval'.
+ (let ((setcmd (format nil "SetPreference: Name=\"/~a/Enable\" Value=" typestring)))
+ (when (and oldval (or (string= oldval "")(string= oldval "1")))
+ (aud-do (format nil "~a~s" setcmd (if (= newval 0) 0 oldval))))))
+ (get-usable-commands ()
+ ;; Disable plug-ins, get list of remaining commands, then re-enable plug-ins if previously enabled.
+ ;; Return list of commands.
+ (let ((cmds '(("Nyquist" ny)("LADSPA" la)("LV2" lv)("VST" vs)("AudioUnit" au)("Vamp" va)))
+ info)
+ (dolist (cmd cmds)
+ (setf (nth 1 cmd) (disable-plugins (nth 0 cmd))))
+ (setf info (first (aud-do "getinfo: type=Commands format=LISP"))) ;Get scriptables and built-in effects
+ (dolist (cmd cmds)
+ (do-set-val (nth 0 cmd) (nth 1 cmd) 1)) ;Re-enable plug-ins
+ info)))
+ (let ((fp (open fqname :direction :output)))
+ ;; Write cache file, or return error.
+ (cond
+ (fp (format fp
+";; Intended for internal use by aud-do-command.~%
+(defun aud-do-version ()
+ '~a)~%
+(defun aud-verify-command-id (id)
+ (second (assoc 'id (aud-get-command id))))~%
+(defun aud-get-command-params (id)
+ (second (assoc 'params (aud-get-command id))))~%
+(defun aud-get-command (&optional id &aux cmds)
+ ;; If id supplied, return command profile or nil.
+ ;; Else, return full list.
+ (setf cmds
+ '~a)
+ ;; Return all commands, or one command or nil.
+ (if id
+ (dolist (cmd cmds nil)
+ (when (string-equal (string id) (second (assoc 'id cmd)))
+ (return cmd)))
+ cmds))"
+ (get '*audacity* 'version)
+ (get-usable-commands))
+ (format t "Debug data cache refreshed.~%")
+ (close fp)
+ (unless (load fqname :verbose t) ;load the file
+ (error "Unable to load" fqname))) ;assert
+ (t (format t "Error: ~a cannot be written." fqname))))))
+
+
+;; Try to load AUD- command cache.
+(when (get-temp-path)
+ (let ((fqname (format nil "~a~a~a"
+ (string-right-trim (string *file-separator*) (get-temp-path))
+ *file-separator*
+ "aud-do-debug-data-cache.lsp")))
+ (load fqname :verbose t)))
diff --git a/Release/nyquist/dspprims.lsp b/Release/nyquist/dspprims.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..2085556acfee43c961dd63431fa3b49c763796bc
--- /dev/null
+++ b/Release/nyquist/dspprims.lsp
@@ -0,0 +1,728 @@
+;; dspprims.lsp -- interface to dsp primitives
+
+;; ARESON - notch filter
+;;
+(defun areson (s c b &optional (n 0))
+ (multichan-expand "ARESON" #'nyq:areson
+ '(((SOUND) nil) ((NUMBER SOUND) "center")
+ ((NUMBER SOUND) "bandwidth") ((INTEGER) nil))
+ s c b n))
+
+(setf areson-implementations
+ (vector #'snd-areson #'snd-aresonvc #'snd-aresoncv #'snd-aresonvv))
+
+;; NYQ:ARESON - notch filter, single channel
+;;
+(defun nyq:areson (signal center bandwidth normalize)
+ (select-implementation-1-2 "ARESON" areson-implementations
+ signal center bandwidth normalize))
+
+
+;; hp - highpass filter
+;;
+(defun hp (s c)
+ (multichan-expand "HP" #'nyq:hp
+ '(((SOUND) "snd") ((NUMBER SOUND) "cutoff")) s c))
+
+(setf hp-implementations
+ (vector #'snd-atone #'snd-atonev))
+
+;; NYQ:hp - highpass filter, single channel
+;;
+(defun nyq:hp (s c)
+ (select-implementation-1-1 "HP" hp-implementations s c))
+
+
+;; comb-delay-from-hz -- compute the delay argument
+;;
+(defun comb-delay-from-hz (hz)
+ (recip hz))
+
+;; comb-feedback -- compute the feedback argument
+;;
+(defun comb-feedback (decay delay)
+ (s-exp (mult -6.9087 delay (recip decay))))
+
+;; COMB - comb filter
+;;
+;; this is just a feedback-delay with different arguments
+;;
+(defun comb (snd decay hz)
+ (multichan-expand "COMB" #'nyq:comb
+ '(((SOUND) "snd") ((NUMBER SOUND) "decay") ((POSITIVE) "hz"))
+ snd decay hz))
+
+
+(defun nyq:comb (snd decay hz)
+ (let (delay feedback len d)
+ ; convert decay to feedback
+ (setf delay (/ (float hz)))
+ (setf feedback (comb-feedback decay delay))
+ (nyq:feedback-delay snd delay feedback "COMB")))
+
+;; ALPASS - all-pass filter
+;;
+(defun alpass (snd decay hz &optional min-hz)
+ (multichan-expand "ALPASS" #'nyq:alpass
+ '(((SOUND) "snd") ((NUMBER SOUND) "decay")
+ ((POSITIVE SOUND) "hz") ((POSITIVE-OR-NULL) "min-hz"))
+ snd decay hz min-hz))
+
+(defun nyq:alpass (snd decay hz min-hz)
+ (let (delay feedback len d)
+ ; convert decay to feedback, iterate over array if necessary
+ (setf delay (comb-delay-from-hz hz))
+ (setf feedback (comb-feedback decay delay))
+ (nyq:alpass1 snd delay feedback min-hz)))
+
+
+;; CONST -- a constant at control-srate
+;;
+(defun const (value &optional (dur 1.0))
+ (ny:typecheck (not (numberp value))
+ (ny:error "CONST" 1 '((NUMBER) "value") value))
+ (ny:typecheck (not (numberp dur))
+ (ny:error "CONST" 2 '((NUMBER) "dur") dur))
+ (let ((d (get-duration dur)))
+ (snd-const value *rslt* *CONTROL-SRATE* d)))
+
+
+;; CONVOLVE - fast convolution
+;;
+(defun convolve (s r)
+ (multichan-expand "CONVOLVE" #'nyq:convolve
+ '(((SOUND) nil) ((SOUND) nil)) s r))
+
+(defun nyq:convolve (s r)
+ (snd-convolve s (force-srate (snd-srate s) r)))
+
+
+;; FEEDBACK-DELAY -- (delay is quantized to sample period)
+;;
+(defun feedback-delay (snd delay feedback)
+ (multichan-expand "FEEDBACK-DELAY" #'nyq:feedback-delay
+ '(((SOUND) "snd") ((NUMBER) "delay") ((NUMBER SOUND) "feedback"))
+ snd delay feedback))
+
+
+;; SND-DELAY-ERROR -- report type error
+;;
+(defun snd-delay-error (snd delay feedback)
+ (error "FEEDBACK-DELAY with variable delay is not implemented"))
+
+
+(setf feedback-delay-implementations
+ (vector #'snd-delay #'snd-delay-error #'snd-delaycv #'snd-delay-error))
+
+
+;; NYQ:FEEDBACK-DELAY -- single channel delay
+;;
+(defun nyq:feedback-delay (snd delay feedback &optional (src "FEEDBACK-DELAY"))
+ (select-implementation-1-2 src feedback-delay-implementations
+ snd delay feedback))
+
+
+;; SND-ALPASS-ERROR -- report type error
+;;
+(defun snd-alpass-error (snd delay feedback)
+ (error "ALPASS with constant decay and variable hz is not implemented"))
+
+
+(if (not (fboundp 'snd-alpasscv))
+ (defun snd-alpasscv (snd delay feedback min-hz)
+ (error "snd-alpasscv (ALPASS with variable decay) is not implemented")))
+(if (not (fboundp 'snd-alpassvv))
+ (defun snd-alpassvv (snd delay feedback min-hz)
+ (error "snd-alpassvv (ALPASS with variable decay and feedback) is not implemented")))
+
+
+(defun nyq:alpassvv (the-snd delay feedback min-hz)
+ (let (max-delay)
+ (ny:typecheck (or (not (numberp min-hz)) (<= min-hz 0))
+ (ny:error "ALPASS" 4 '((POSITIVE) "min-hz") min-hz))
+ (setf max-delay (/ (float min-hz)))
+ ; make sure delay is between 0 and max-delay
+ ; use clip function, which is symmetric, with an offset
+ (setf delay (snd-offset (clip (snd-offset delay (* max-delay -0.5))
+ (* max-delay 0.5))
+ (* max-delay 0.5)))
+ ; now delay is between 0 and max-delay, so we won't crash nyquist when
+ ; we call snd-alpassvv, which doesn't test for out-of-range data
+ (snd-alpassvv the-snd delay feedback max-delay)))
+
+
+;; NYQ:SND-ALPASS -- ignores min-hz argument and calls snd-alpass
+;;
+(defun nyq:snd-alpass (snd delay feedback min-hz)
+ (snd-alpass snd delay feedback))
+
+;; NYQ:SND-ALPASSCV -- ignores min-hz argument and calls snd-alpasscv
+;;
+(defun nyq:snd-alpasscv (snd delay feedback min-hz)
+ (snd-alpasscv snd delay feedback))
+
+(setf alpass-implementations
+ (vector #'nyq:snd-alpass #'snd-alpass-error
+ #'nyq:snd-alpasscv #'nyq:alpassvv))
+
+
+;; NYQ:ALPASS1 -- single channel alpass
+;;
+(defun nyq:alpass1 (snd delay feedback min-hz)
+ (select-implementation-1-2 "ALPASS" alpass-implementations
+ snd delay feedback min-hz))
+
+;; CONGEN -- contour generator, patterned after gated analog env gen
+;;
+(defun congen (gate rise fall)
+ (multichan-expand "CONGEN" #'snd-congen
+ '(((SOUND) "gate") ((NONNEGATIVE) "rise") ((NONNEGATIVE) "fall"))
+ gate rise fall))
+
+
+;; S-EXP -- exponentiate a sound
+;;
+(defun s-exp (s)
+ (multichan-expand "S-EXP" #'nyq:exp
+ '(((NUMBER SOUND) nil)) s))
+
+
+;; NYQ:EXP -- exponentiate number or sound
+;;
+(defun nyq:exp (s) (if (soundp s) (snd-exp s) (exp s)))
+
+;; S-ABS -- absolute value of a sound
+;;
+(defun s-abs (s)
+ (multichan-expand "S-ABS" #'nyq:abs
+ '(((NUMBER SOUND) nil)) s))
+
+;; NYQ:ABS -- absolute value of number or sound
+;;
+(defun nyq:abs (s)
+ (if (soundp s) (snd-abs s) (abs s)))
+
+;; S-AVG -- moving average or peak computation
+;;
+(defun s-avg (s blocksize stepsize operation)
+ (multichan-expand "S-AVG" #'snd-avg
+ '(((SOUND) nil) ((INTEGER) "blocksize") ((INTEGER) "stepsize")
+ ((INTEGER) "operation"))
+ s blocksize stepsize operation))
+
+;; S-SQRT -- square root of a sound
+;;
+(defun s-sqrt (s)
+ (multichan-expand "S-SQRT" #'nyq:sqrt
+ '(((NUMBER SOUND) nil)) s))
+
+
+;; NYQ:SQRT -- square root of a number or sound
+;;
+(defun nyq:sqrt (s)
+ (if (soundp s) (snd-sqrt s) (sqrt s)))
+
+
+;; INTEGRATE -- integration
+;;
+(defun integrate (s)
+ (multichan-expand "INTEGRATE" #'snd-integrate
+ '(((SOUND) nil)) s))
+
+
+;; S-LOG -- natural log of a sound
+;;
+(defun s-log (s)
+ (multichan-expand "S-LOG" #'nyq:log
+ '(((NUMBER SOUND) nil)) s))
+
+
+;; NYQ:LOG -- log of a number or sound
+;;
+(defun nyq:log (s)
+ (if (soundp s) (snd-log s) (log s)))
+
+
+;; NOISE -- white noise
+;;
+(defun noise (&optional (dur 1.0))
+ (ny:typecheck (not (numberp dur))
+ (ny:error "NOISE" 1 number-anon dur))
+ (let ((d (get-duration dur)))
+ (snd-white *rslt* *SOUND-SRATE* d)))
+
+
+(defun noise-gate (snd &optional (lookahead 0.5) (risetime 0.02) (falltime 0.5)
+ (floor 0.01) (threshold 0.01) &key (rms nil) (link t))
+ (let ((sense (if rms (rms snd 100.0 nil "NOISE-GATE") (s-abs snd))))
+ (cond (link
+ (mult snd (gate sense lookahead risetime falltime floor
+ threshold "NOISE-GATE")))
+ (t
+ (mult snd (multichan-expand "NOISE-GATE" #'gate
+ '(((SOUND) "sound") ((NUMBER) "lookahead")
+ ((NUMBER) "risetime") ((NUMBER) "falltime")
+ ((NUMBER) "floor") ((NUMBER) "threshold")
+ ((STRING) "source"))
+ sense lookahead risetime falltime
+ floor threshold "NOISE-GATE"))))))
+
+
+;; QUANTIZE -- quantize a sound
+;;
+(defun quantize (s f)
+ (multichan-expand "QUANTIZE" #'snd-quantize
+ '(((SOUND) nil) ((POSITIVE) nil)) s f))
+
+
+;; RECIP -- reciprocal of a sound
+;;
+(defun recip (s)
+ (multichan-expand "RECIP" #'nyq:recip
+ '(((NUMBER SOUND) nil)) s))
+
+
+;; NYQ:RECIP -- reciprocal of a number or sound
+;;
+(defun nyq:recip (s)
+ (if (soundp s) (snd-recip s) (/ (float s))))
+
+
+
+;; RMS -- compute the RMS of a sound
+;;
+(defun rms (s &optional (rate 100.0) window-size (source "RMS"))
+ (multichan-expand "RMS" #'ny:rms
+ '(((SOUND) nil) ((POSITIVE) "rate") ((POSITIVE-OR-NULL) "window-size")
+ ((STRING) "source"))
+ s rate window-size source))
+
+
+;; NY:RMS -- single channel RMS
+;;
+(defun ny:rms (s &optional (rate 100.0) window-size source)
+ (let (rslt step-size)
+ (ny:typecheck (not (or (soundp s) (multichannel-soundp s)))
+ (ny:error source 1 '((SOUND) NIL) s t))
+ (ny:typecheck (not (numberp rate))
+ (ny:error source 2 '((NUMBER) "rate") rate))
+ (setf step-size (round (/ (snd-srate s) rate)))
+ (cond ((null window-size)
+ (setf window-size step-size))
+ ((not (integerp window-size))
+ (ny:error source 3 '((INTEGER) "window-size" window-size))))
+ (setf s (prod s s))
+ (setf result (snd-avg s window-size step-size OP-AVERAGE))
+ ;; compute square root of average
+ (s-exp (scale 0.5 (s-log result)))))
+
+
+;; RESON - bandpass filter
+;;
+(defun reson (s c b &optional (n 0))
+ (multichan-expand "RESON" #'nyq:reson
+ '(((SOUND) "snd") ((NUMBER SOUND) "center")
+ ((NUMBER SOUND) "bandwidth") ((INTEGER) "n"))
+ s c b n))
+
+
+(setf reson-implementations
+ (vector #'snd-reson #'snd-resonvc #'snd-resoncv #'snd-resonvv))
+
+;; NYQ:RESON - bandpass filter, single channel
+;;
+(defun nyq:reson (signal center bandwidth normalize)
+ (select-implementation-1-2 "RESON" reson-implementations
+ signal center bandwidth normalize))
+
+
+;; SHAPE -- waveshaper
+;;
+(defun shape (snd shape origin)
+ (multichan-expand "SHAPE" #'snd-shape
+ '(((SOUND) "snd") ((SOUND) "shape") ((NUMBER) "origin"))
+ snd shape origin))
+
+
+;; SLOPE -- calculate the first derivative of a signal
+;;
+(defun slope (s)
+ (multichan-expand "SLOPE" #'nyq:slope
+ '(((SOUND) nil)) s))
+
+
+;; NYQ:SLOPE -- first derivative of single channel
+;;
+(defun nyq:slope (s)
+ (let* ((sr (snd-srate s))
+ (sr-inverse (/ sr)))
+ (snd-xform (snd-slope s) sr 0 sr-inverse MAX-STOP-TIME 1.0)))
+
+
+;; lp - lowpass filter
+;;
+(defun lp (s c)
+ (multichan-expand "LP" #'nyq:lp
+ '(((SOUND) "snd") ((NUMBER SOUND) "cutoff")) s c))
+
+(setf lp-implementations
+ (vector #'snd-tone #'snd-tonev))
+
+;; NYQ:lp - lowpass filter, single channel
+;;
+(defun nyq:lp (s c)
+ (select-implementation-1-1 "LP" lp-implementations s c))
+
+
+
+;;; fixed-parameter filters based on snd-biquad
+;;; note: snd-biquad is implemented in biquadfilt.[ch],
+;;; while BiQuad.{cpp,h} is part of STK
+
+(setf Pi 3.14159265358979)
+
+(defun square (x) (* x x))
+(defun sinh (x) (* 0.5 (- (exp x) (exp (- x)))))
+
+
+; remember that snd-biquad uses the opposite sign convention for a_i's
+; than Matlab does.
+;
+; Stability: Based on courses.cs.washington.edu/courses/cse490s/11au/
+; Readings/Digital_Sound_Generation_2.pdf, the stable region is
+; (a2 < 1) and ((a2 + 1) > |a1|)
+; It doesn't look to me like our a0, a1, a2 match the paper's a0, a1, a2,
+; and I'm not convinced the paper's derivation is correct, but at least
+; the predicted region of stability is correct if we swap signs on a1 and
+; a2 (but due to the |a1| term, only the sign of a2 matters). This was
+; tested manually at a number of points inside and outside the stable
+; triangle. Previously, the stability test was (>= a0 1.0) which seems
+; generally wrong. The old test has been removed.
+
+; convenient biquad: normalize a0, and use zero initial conditions.
+(defun nyq:biquad (x b0 b1 b2 a0 a1 a2)
+ (ny:typecheck (<= a0 0.0)
+ (error (format nil "In BIQUAD, a0 < 0 (unstable parameter a0 = ~A)" a0)))
+ (let ((a0r (/ (float a0))))
+ (setf a1 (* a0r a1)
+ a2 (* a0r a2))
+ (ny:typecheck (or (<= a2 -1.0) (<= (- 1.0 a2) (abs a1)))
+ (error (format nil
+ "In BIQUAD, (a2 <= -1) or (1 - a2 <= |a1|) (~A a1 = ~A, a2 = ~A)"
+ "unstable parameters" a1 a2)))
+ (snd-biquad x (* a0r b0) (* a0r b1) (* a0r b2)
+ a1 a2 0 0)))
+
+
+(defun biquad (x b0 b1 b2 a0 a1 a2 &optional (source "BIQUAD"))
+ (multichan-expand "BIQUAD" #'nyq:biquad
+ '(((SOUND) "snd") ((NUMBER) "b0") ((NUMBER) "b1")
+ ((NUMBER) "b2") ((NUMBER) "a0") ((NUMBER) "a1")
+ ((NUMBER) "a2"))
+ x b0 b1 b2 a0 a1 a2))
+
+
+; biquad with Matlab sign conventions for a_i's.
+(defun biquad-m (x b0 b1 b2 a0 a1 a2)
+ (multichan-expand "BIQUAD-M" #'nyq:biquad-m
+ '(((SOUND) "snd") ((NUMBER) "b0") ((NUMBER) "b1")
+ ((NUMBER) "b2") ((NUMBER) "a0") ((NUMBER) "a1")
+ ((NUMBER) "a2"))
+ x b0 b1 b2 a0 a1 a2))
+
+(defun nyq:biquad-m (x b0 b1 b2 a0 a1 a2 &optional (source "BIQUAD-M"))
+ (nyq:biquad x b0 b1 b2 a0 (- a1) (- a2)))
+
+; two-pole lowpass
+(defun lowpass2 (x hz &optional (q 0.7071) (source "LOWPASS2"))
+ (multichan-expand source #'nyq:lowpass2
+ '(((SOUND) "snd") ((POSITIVE) "hz") ((POSITIVE) "q") ((STRING) "source"))
+ x hz q source))
+
+;; NYQ:LOWPASS2 -- operates on single channel
+(defun nyq:lowpass2 (x hz q source)
+ (if (or (> hz (* 0.5 (snd-srate x)))
+ (< hz 0))
+ (error "cutoff frequency out of range" hz))
+ (let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
+ (cw (cos w))
+ (sw (sin w))
+ (alpha (* sw (sinh (/ 0.5 q))))
+ (a0 (+ 1.0 alpha))
+ (a1 (* -2.0 cw))
+ (a2 (- 1.0 alpha))
+ (b1 (- 1.0 cw))
+ (b0 (* 0.5 b1))
+ (b2 b0))
+ (nyq:biquad-m x b0 b1 b2 a0 a1 a2 source)))
+
+; two-pole highpass
+(defun highpass2 (x hz &optional (q 0.7071) (source "HIGHPASS2"))
+ (multichan-expand source #'nyq:highpass2
+ '(((SOUND) "snd") ((POSITIVE) "hz") ((POSITIVE) "q") ((STRING) "source"))
+ x hz q source))
+
+(defun nyq:highpass2 (x hz q source)
+ (if (or (> hz (* 0.5 (snd-srate x)))
+ (< hz 0))
+ (error "cutoff frequency out of range" hz))
+ (let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
+ (cw (cos w))
+ (sw (sin w))
+ (alpha (* sw (sinh (/ 0.5 q))))
+ (a0 (+ 1.0 alpha))
+ (a1 (* -2.0 cw))
+ (a2 (- 1.0 alpha))
+ (b1 (- -1.0 cw))
+ (b0 (* -0.5 b1))
+ (b2 b0))
+ (nyq:biquad-m x b0 b1 b2 a0 a1 a2 source)))
+
+; two-pole bandpass. max gain is unity.
+(defun bandpass2 (x hz q)
+ (multichan-expand "BANDPASS2" #'nyq:bandpass2
+ '(((SOUND) "snd") ((POSITIVE) "hz") ((POSITIVE) "q"))
+ x hz q))
+
+(defun nyq:bandpass2 (x hz q)
+ (let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
+ (cw (cos w))
+ (sw (sin w))
+ (alpha (* sw (sinh (/ 0.5 q))))
+ (a0 (+ 1.0 alpha))
+ (a1 (* -2.0 cw))
+ (a2 (- 1.0 alpha))
+ (b0 alpha)
+ (b1 0.0)
+ (b2 (- alpha)))
+ (nyq:biquad-m x b0 b1 b2 a0 a1 a2 "BANDPASS2")))
+
+; two-pole notch.
+(defun notch2 (x hz q)
+ (multichan-expand "NOTCH2" #'nyq:notch2
+ '(((SOUND) "snd") ((POSITIVE) "hz") ((POSITIVE) "q"))
+ x hz q))
+
+(defun nyq:notch2 (x hz q)
+ (let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
+ (cw (cos w))
+ (sw (sin w))
+ (alpha (* sw (sinh (/ 0.5 q))))
+ (a0 (+ 1.0 alpha))
+ (a1 (* -2.0 cw))
+ (a2 (- 1.0 alpha))
+ (b0 1.0)
+ (b1 (* -2.0 cw))
+ (b2 1.0))
+ (nyq:biquad-m x b0 b1 b2 a0 a1 a2 "NOTCH2")))
+
+
+; two-pole allpass.
+(defun allpass2 (x hz q)
+ (multichan-expand "ALLPASS2" #'nyq:allpass
+ '(((SOUND) "snd") ((POSITIVE) "hz") ((POSITIVE) "q"))
+ x hz q))
+
+(defun nyq:allpass (x hz q)
+ (let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
+ (cw (cos w))
+ (sw (sin w))
+ (k (exp (* -0.5 w (/ (float q)))))
+ (a0 1.0)
+ (a1 (* -2.0 cw k))
+ (a2 (* k k))
+ (b0 a2)
+ (b1 a1)
+ (b2 1.0))
+ (nyq:biquad-m x b0 b1 b2 a0 a1 a2 "ALLPASS2")))
+
+
+; bass shelving EQ. gain in dB; Fc is halfway point.
+; response becomes peaky at slope > 1.
+(defun eq-lowshelf (x hz gain &optional (slope 1.0))
+ (multichan-expand "EQ-LOWSHELF" #'nyq:eq-lowshelf
+ '(((SOUND) "snd") ((POSITIVE) "hz") ((NUMBER) "gain") ((NUMBER) "slope"))
+ x hz gain slope))
+
+
+(defun nyq:eq-lowshelf (x hz gain slope)
+ (let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
+ (sw (sin w))
+ (cw (cos w))
+ (A (expt 10.0 (/ gain (* 2.0 20.0))))
+ (b (sqrt (- (/ (+ 1.0 (square A)) slope) (square (- A 1.0)))))
+ (apc (* cw (+ A 1.0)))
+ (amc (* cw (- A 1.0)))
+ (bs (* b sw))
+
+ (b0 (* A (+ A 1.0 (- amc) bs )))
+ (b1 (* 2.0 A (+ A -1.0 (- apc) )))
+ (b2 (* A (+ A 1.0 (- amc) (- bs) )))
+ (a0 (+ A 1.0 amc bs ))
+ (a1 (* -2.0 (+ A -1.0 apc )))
+ (a2 (+ A 1.0 amc (- bs) )))
+ (nyq:biquad-m x b0 b1 b2 a0 a1 a2)))
+
+
+; treble shelving EQ. gain in dB; Fc is halfway point.
+; response becomes peaky at slope > 1.
+(defun eq-highshelf (x hz gain &optional (slope 1.0))
+ (multichan-expand "EQ-HIGHSHELF" #'nyq:eq-highshelf
+ '(((SOUND) "snd") ((POSITIVE) "hz") ((NUMBER) "gain") ((NUMBER) "slope"))
+ x hz gain slope))
+
+(defun nyq:eq-highshelf (x hz gain slope)
+ (let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
+ (sw (sin w))
+ (cw (cos w))
+ (A (expt 10.0 (/ gain (* 2.0 20.0))))
+ (b (sqrt (- (/ (+ 1.0 (square A)) slope) (square (- A 1.0)))))
+ (apc (* cw (+ A 1.0)))
+ (amc (* cw (- A 1.0)))
+ (bs (* b sw))
+
+ (b0 (* A (+ A 1.0 amc bs )))
+ (b1 (* -2.0 A (+ A -1.0 apc )))
+ (b2 (* A (+ A 1.0 amc (- bs) )))
+ (a0 (+ A 1.0 (- amc) bs ))
+ (a1 (* 2.0 (+ A -1.0 (- apc) )))
+ (a2 (+ A 1.0 (- amc) (- bs) )))
+ (nyq:biquad-m x b0 b1 b2 a0 a1 a2)))
+
+(defun nyq:eq-band (x hz gain width)
+ (cond ((and (numberp hz) (numberp gain) (numberp width))
+ (eq-band-ccc x hz gain width))
+ ((and (soundp hz) (soundp gain) (soundp width))
+ (snd-eqbandvvv x hz (db-to-linear gain) width))
+ (t (error
+ (strcat
+ "In EQ-BAND, hz, gain, and width must be all numbers"
+ " or all sounds (if any parameter is an array, there"
+ " is a problem with at least one channel), hz is "
+ (param-to-string hz) ", gain is " (param-to-string gain)
+ ", width is " (param-to-string width)) )) ))
+
+; midrange EQ. gain in dB, width in octaves (half-gain width).
+(defun eq-band (x hz gain width)
+ (multichan-expand "EQ-BAND" #'nyq:eq-band
+ '(((SOUND) "snd") ((POSITIVE SOUND) "hz")
+ ((NUMBER SOUND) "gain") ((POSITIVE SOUND) "width"))
+ x hz gain width))
+
+
+(defun eq-band-ccc (x hz gain width)
+ (let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
+ (sw (sin w))
+ (cw (cos w))
+ (J (sqrt (expt 10.0 (/ gain 20.0))))
+ ;(dummy (display "eq-band-ccc" gain J))
+ (g (* sw (sinh (* 0.5 (log 2.0) width (/ w sw)))))
+ ;(dummy2 (display "eq-band-ccc" width w sw g))
+ (b0 (+ 1.0 (* g J)))
+ (b1 (* -2.0 cw))
+ (b2 (- 1.0 (* g J)))
+ (a0 (+ 1.0 (/ g J)))
+ (a1 (- b1))
+ (a2 (- (/ g J) 1.0)))
+ (biquad x b0 b1 b2 a0 a1 a2)))
+
+; see failed attempt in eub-reject.lsp to do these with higher-order fns:
+
+; four-pole Butterworth lowpass
+(defun lowpass4 (x hz)
+ (lowpass2 (lowpass2 x hz 0.60492333 "LOWPASS4")
+ hz 1.33722126 "LOWPASS4"))
+
+; six-pole Butterworth lowpass
+(defun lowpass6 (x hz)
+ (lowpass2 (lowpass2 (lowpass2 x hz 0.58338080 "LOWPASS6")
+ hz 0.75932572 "LOWPASS6")
+ hz 1.95302407 "LOWPASS6"))
+
+; eight-pole Butterworth lowpass
+(defun lowpass8 (x hz)
+ (lowpass2 (lowpass2 (lowpass2 (lowpass2 x hz 0.57622191 "LOWPASS8")
+ hz 0.66045510 "LOWPASS8")
+ hz 0.94276399 "LOWPASS8")
+ hz 2.57900101 "LOWPASS8"))
+
+; four-pole Butterworth highpass
+(defun highpass4 (x hz)
+ (highpass2 (highpass2 x hz 0.60492333 "HIGHPASS4")
+ hz 1.33722126 "HIGHPASS4"))
+
+; six-pole Butterworth highpass
+(defun highpass6 (x hz)
+ (highpass2 (highpass2 (highpass2 x hz 0.58338080 "HIGHPASS6")
+ hz 0.75932572 "HIGHPASS6")
+ hz 1.95302407 "HIGHPASS6"))
+
+; eight-pole Butterworth highpass
+(defun highpass8 (x hz)
+ (highpass2 (highpass2 (highpass2 (highpass2 x hz 0.57622191 "HIGHPASS8")
+ hz 0.66045510 "HIGHPASS8")
+ hz 0.94276399 "HIGHPASS8")
+ hz 2.57900101 "HIGHPASS8"))
+
+; YIN
+; maybe this should handle multiple channels, etc.
+(defun yin (sound minstep maxstep stepsize)
+ (ny:typecheck (not (soundp sound))
+ (ny:error "YIN" 1 '((SOUND) "sound") sound))
+ (ny:typecheck (not (numberp minstep))
+ (ny:error "YIN" 2 '((NUMBER) "minstep") minstep))
+ (ny:typecheck (not (numberp maxstep))
+ (ny:error "YIN" 3 '((NUMBER) "maxstep") maxstep))
+ (ny:typecheck (not (integerp stepsize))
+ (ny:error "YIN" 4 '((INTEGER) "stepsize") stepsize))
+ (snd-yin sound minstep maxstep stepsize))
+
+
+; FOLLOW
+(defun follow (sound floor risetime falltime lookahead)
+ (ny:typecheck (not (soundp sound))
+ (ny:error "FOLLOW" 1 '((SOUND) "sound") sound))
+ (ny:typecheck (not (numberp floor))
+ (ny:error "FOLLOW" 2 '((NUMBER) "floor") floor))
+ (ny:typecheck (not (numberp risetime))
+ (ny:error "FOLLOW" 3 '((NUMBER) "risetime") risetime))
+ (ny:typecheck (not (numberp falltime))
+ (ny:error "FOLLOW" 4 '((NUMBER) "stepsize") falltime))
+ (ny:typecheck (not (numberp lookahead))
+ (ny:error "FOLLOW" 5 '((NUMBER) "lookahead") lookahead))
+ ;; use 10000s as "infinite" -- that's about 2^30 samples at 96K
+ (setf lookahead (round (* lookahead (snd-srate sound))))
+ (extract (/ lookahead (snd-srate sound)) 10000
+ (snd-follow sound floor risetime falltime lookahead)))
+
+
+;; PHASE VOCODER
+(defun phasevocoder (s map &optional (fftsize -1) (hopsize -1) (mode 0))
+ (multichan-expand "PHASEVOCODER" #'snd-phasevocoder
+ '(((SOUND) nil) ((SOUND) "map") ((INTEGER) "fftsize")
+ ((INTEGER) "hopsize") ((INTEGER) "mode"))
+ s map fftsize hopsize mode))
+
+
+;; PV-TIME-PITCH
+;; PV-TIME-PITCH -- control time stretch and transposition
+;;
+;; stretchfn maps from input time to output time
+;; pitchfn maps from input time to transposition factor (2 means octave up)
+(defun pv-time-pitch (input stretchfn pitchfn dur &optional
+ (fftsize 2048) (hopsize nil) (mode 0))
+ (multichan-expand "PV-TIME-PITCH" #'nyq:pv-time-pitch
+ '(((SOUND) "input") ((SOUND) "stretchfn") ((SOUND) "pitchfn")
+ ((NUMBER) "dur") ((INTEGER) "fftsize") ((INT-OR-NULL) "hopsize")
+ ((INTEGER) "mode"))
+ input stretchfn pitchfn dur fftsize hopsize mode))
+
+(defun nyq:pv-time-pitch (input stretchfn pitchfn dur fftsize hopsize mode)
+ (let (wrate u v w vinv)
+ (if (null hopsize) (setf hopsize (/ fftsize 8)))
+ (setf wrate (/ 3000 dur))
+ (setf vinv (integrate (prod stretchfn pitchfn)))
+ (setf v (snd-inverse vinv (local-to-global 0) wrate))
+ (setf w (integrate (snd-recip (snd-compose pitchfn v))))
+ (sound-warp w (phasevocoder input v fftsize hopsize mode) wrate)))
+
diff --git a/Release/nyquist/envelopes.lsp b/Release/nyquist/envelopes.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..18e6a6f6524e4d76aa3fadfe84a521ed6389cd24
--- /dev/null
+++ b/Release/nyquist/envelopes.lsp
@@ -0,0 +1,163 @@
+;; envelopes.lsp -- support functions for envelope editor in NyquistIDE
+
+#| In Nyquist, editable envelopes are saved as one entry in the workspace
+named *envelopes*. The entry is an association list where each element
+looks like this:
+
+(name type parameters... )
+
+where name is a symbol, e.g. MY-ENVELOPE-1,
+ type is a function name, e.g. PWL, PWLV, PWE, etc., and
+ parameters are breakpoint data, e.g. 0.1 1 0.2 0.5 1
+
+Example of two envelopes named FOO and BAR:
+
+((FOO PWL 0.1 1 1) (BAR PWE 0.2 1 1))
+
+To convert envelope data into functions, call (MAKE-ENV-FUNCTIONS).
+This function should be on the workspace's list of functions to call.
+(See ADD-ACTION-TO-WORKSPACE in Nyquist Manual.)
+
+When the NyquistIDE wants to get the envelope data from the workspace, it
+should call (GET-ENV-DATA), which will dump formatted data to Nyquist's
+standard output as follows:
+
+get-env-data: begin
+name (type parameters...) newline
+name (type parameters...) newline
+...
+get-env-data: end
+
+When the IDE wants to save a definition, it should call
+(DEFINE-ENV 'NAME 'EXPRESSION)
+
+To delete a definition, call:
+(DELETE-ENV 'NAME)
+
+Envelope data will be loaded when the editor window is opened and saved
+whenever the user issues a "save" command. If the user switches envelopes
+without saving, there is a prompt to save or ignore.
+
+The user will also be prompted to save when the editor window is closed
+or when Nyquist is exited.
+
+Saving the workspace automatically is something that Nyquist should do
+(or prompt the user to do) when it exits.
+
+|#
+
+;; WORKSPACE -- the workspace is just a set of variables, typically
+;; with scores as values. These are stored in the file workspace.lsp
+;; so that you can work on some data and then store it for use later.
+
+(cond ((not (boundp '*workspace*))
+ (setf *workspace* nil)))
+(cond ((not (boundp '*workspace-actions*))
+ (setf *workspace-actions* nil)))
+;; one of the variables in the workspace is *envelopes*
+(cond ((not (boundp '*envelopes*))
+ (setf *envelopes* nil)))
+
+;; DESCRIBE -- add a description to a global variable
+;;
+(defun describe (symbol &optional description)
+ (add-to-workspace symbol)
+ (cond (description
+ (putprop symbol description 'description))
+ (t
+ (get symbol 'description))))
+
+;; ADD-TO-WORKSPACE -- add a global symbol to workspace
+;;
+(defun add-to-workspace (symbol)
+ (cond ((not (symbolp symbol))
+ (format t "add-to-workspace expects a (quoted) symbol~%"))
+ ((not (member symbol *workspace*))
+ (push symbol *workspace*))))
+
+
+;; ADD-ACTION-TO-WORKSPACE -- call function when workspace is loaded
+;;
+(defun add-action-to-workspace (symbol)
+ (cond ((not (symbolp symbol))
+ (format t "add-action-to-workspace expects a (quoted) symbol~%"))
+ ((not (member symbol *workspace-actions*))
+ (push symbol *workspace-actions*))))
+
+;; SAVE-WORKSPACE -- write data to file
+;;
+(defun save-workspace ()
+ (let (val (outf (open "workspace.lsp" :direction :output)))
+ (dolist (sym *workspace*)
+ (format outf "(add-to-workspace '~A)~%" sym)
+ (cond ((get sym 'description)
+ (format outf "(putprop '~A \"~A\" 'description)~%"
+ sym (get sym 'description))))
+ (format outf "(setf ~A '" sym)
+ (setf val (symbol-value sym))
+ (cond ((listp val)
+ (format outf "(~%")
+ (dolist (elem val)
+ (format outf " ~A~%" elem))
+ (format outf " ))~%~%"))
+ (t
+ (format outf "~A)~%~%" val))))
+ (dolist (sym *workspace-actions*) ;; call hooks after reading data
+ (format outf "(add-action-to-workspace '~A)~%" sym)
+ (format outf "(if (fboundp '~A) (~A))~%" sym sym))
+ (format outf "(princ \"workspace loaded\\n\")~%")
+ (close outf)
+ (princ "workspace saved\n")
+ nil))
+
+
+;; DEFINE-ENV -- save the env data and make corresponding function
+;;
+(defun define-env (name expression)
+ (delete-env name)
+ (push (cons name expression) *envelopes*)
+ (make-env-function name expression)
+ ; make sure envelopes are redefined when workspace is loaded
+ (add-to-workspace '*envelopes*) ; so *envelopes* will be saved
+ (describe '*envelopes* "data for envelope editor in NyquistIDE")
+ (add-action-to-workspace 'make-env-functions)
+ nil)
+
+
+;; DELETE-ENV -- delete an envelope definition from workspace
+;;
+;; note that this will not undefine the corresponding envelope function
+;;
+(defun delete-env (name)
+ (setf *envelopes*
+ (remove name *envelopes*
+ :test #'(lambda (key item) (eql key (car item))))))
+
+
+;; MAKE-ENV-FUNCTION -- convert data to a defined function
+;;
+(defun make-env-function (name expression)
+ (setf (symbol-function name)
+ (eval (list 'lambda '() expression))))
+
+
+;; MAKE-ENV-FUNCTIONS -- convert data to defined functions
+;;
+(defun make-env-functions ()
+ (let (name type parameters)
+ (dolist (env *envelopes*)
+ (setf name (car env))
+ (setf type (cadr env))
+ (setf parameters (cddr env))
+ (make-env-function name (cons type parameters)))))
+
+
+;; GET-ENV-DATA -- print env data for IDE
+;;
+(defun get-env-data ()
+ (princ "get-env-data: begin\n")
+ (dolist (env *envelopes*)
+ (format t "~A ~A~%" (car env) (cdr env)))
+ (princ "get-env-data: end\n")
+ nil)
+
diff --git a/Release/nyquist/equalizer.lsp b/Release/nyquist/equalizer.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..12ff4873c8623860c2e1a89ee8708c0eb776e9f4
--- /dev/null
+++ b/Release/nyquist/equalizer.lsp
@@ -0,0 +1,75 @@
+;; equalizer.lsp -- support functions for equalizer editor in jNyqIDE
+
+#| This is modeled after envelopes.lsp, which details how envelope data is
+exchanged between Nyquist and jNyqIDE.
+
+The jNyqIDE code needs some work to make it look like the envelope
+editor (which also needs work, but that's another matter). For consistency,
+both should support named envelopes and equalizers.
+
+However, for now, we have equalizers numbered from 0 to 9. The format for
+exchange will be:
+
+get-eq-data: begin
+name parameters newline
+name parameters newline
+...
+get-eq-data: end
+
+and when the IDE wants to save a definition, it should call
+(DEFINE-EQ 'NAME 'PARAMETER-LIST)
+
+|#
+
+(cond ((not (boundp '*equalizers*))
+ (setf *equalizers* nil)))
+
+;; DEFINE-EQ -- save the eq data and make corresponding function
+;;
+(defun define-eq (name expression)
+ (setf *equalizers* (remove name *equalizers*
+ :test #'(lambda (key item) (eql key (car item)))))
+ (push (list name expression) *equalizers*)
+ (make-eq-function name expression)
+ ; make sure equalizers are redefined when workspace is loaded
+ (add-to-workspace '*equalizers*)
+ (describe '*equalizers* "data for equalizers in jNyqIDE")
+ (add-action-to-workspace 'make-eq-functions)
+ nil)
+
+
+;; MAKE-EQ-FUNCTION -- convert data to a defined function
+;;
+(defun make-eq-function (name parameters)
+ (cond ((numberp name)
+ (setf name (intern (format nil "EQ-~A" name)))))
+ (if (not (boundp '*grapheq-loaded*)) (load "grapheq.lsp"))
+ (setf (symbol-function name)
+ (eval `(lambda (s) (nband-range s ',parameters 60 14000)))))
+
+
+;; MAKE-EQ-FUNCTIONS -- convert data to defined functions
+;;
+(defun make-eq-functions ()
+ (let (name type parameters)
+ (dolist (eq *equalizers*)
+ (setf name (car eq))
+ (setf parameters (second parameters))
+ (make-eq-function name parameters))))
+
+
+;; GET-EQ-DATA -- print env data for IDE
+;;
+(defun get-eq-data ()
+ (let (parameters)
+ (princ "get-eq-data: begin\n")
+ (dolist (env *equalizers*)
+ (format t "~A" (car env))
+ (setf parameters (second env))
+ (dotimes (i (length parameters))
+ (format t " ~A" (aref parameters i)))
+ (format t "~%"))
+ (princ "get-eq-data: end\n")
+ nil))
+
+
diff --git a/Release/nyquist/evalenv.lsp b/Release/nyquist/evalenv.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..da8ce76896465cd4ff3a928df4992449675ebef7
--- /dev/null
+++ b/Release/nyquist/evalenv.lsp
@@ -0,0 +1,36 @@
+;;
+;; The EVAL function in the original XLISP evaluated in the current lexical
+;; context. This was changed to evaluate in the NIL (global) context to
+;; match Common Lisp. But this created a problem: how do you EVAL an
+;; expression in the current lexical context?
+;;
+;; The answer is you can use the evalhook facility. The evalhook function
+;; will evaluate an expression using an environment given to it as an
+;; argument. But then the problem is "how do you get the current
+;; environment?" Well the getenv macro, below obtains the environment by
+;; using an *evalhook* form.
+;;
+;; The following two macros do the job. Insteading of executing (eval <expr>)
+;; just execute (eval-env <expr>). If you want, you can dispense with the
+;; macros and execute:
+;;
+;;(evalhook <expr> nil nil (let ((*evalhook* (lambda (x env) env)))
+;; (eval nil)))
+;;
+;; Tom Almy 10/91
+;;
+
+(defmacro getenv ()
+ '(progv '(*evalhook*)
+ (list #'(lambda (exp env) env))
+ (eval nil)))
+
+; this didn't work, may be for a later (Almy) version of xlisp?
+;(defmacro getenv ()
+; '(let ((*evalhook* (lambda (x env) env)))
+; (eval nil))) ; hook function evaluates by returning
+ ; environment
+
+(defmacro eval-env (arg) ; evaluate in current environment
+ `(evalhook ,arg nil nil (getenv)))
+
diff --git a/Release/nyquist/fileio.lsp b/Release/nyquist/fileio.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..f09914b84743cafc765416f66058382146a827dd
--- /dev/null
+++ b/Release/nyquist/fileio.lsp
@@ -0,0 +1,417 @@
+;; fileio.lsp
+
+;; if *default-sf-dir* undefined, set it to user's tmp directory
+;;
+(cond ((not (boundp '*default-sf-dir*))
+ ;; it would be nice to use get-temp-path, but when running
+ ;; the Java-based IDE, Nyquist does not get environment
+ ;; variables to tell TMP or TEMP or USERPROFILE
+ ;; We want to avoid the current directory because it may
+ ;; be read-only. Search for some likely paths...
+ ;; Note that since these paths don't work for Unix or OS X,
+ ;; they will not be used, so no system-dependent code is
+ ;; needed
+ (let ((current (setdir ".")))
+ (setf *default-sf-dir*
+ (or (setdir "c:\\tmp\\" nil)
+ (setdir "c:\\temp\\" nil)
+ (setdir "d:\\tmp\\" nil)
+ (setdir "d:\\temp\\" nil)
+ (setdir "e:\\tmp\\" nil)
+ (setdir "e:\\temp\\" nil)
+ (get-temp-path)))
+ (format t "Set *default-sf-dir* to \"~A\" in fileio.lsp~%"
+ *default-sf-dir*)
+ (setdir current))))
+
+;; if the steps above fail, then *default-sf-dir* might be "" (especially
+;; on windows), and the current directory could be read-only on Vista and
+;; Windows 7. Therefore, the Nyquist IDE will subsequently call
+;; suggest-default-sf-dir with Java's idea of a valid temp directory.
+;; If *default-sf-dir* is the empty string (""), this will set the variable:
+(defun suggest-default-sf-dir (path)
+ (cond ((equal *default-sf-dir* "") (setf *default-sf-dir* path))))
+
+;; s-save -- saves a file
+(setf *in-s-save* nil)
+(setf NY:ALL 576460752303423488) ; constant for maxlen == 1 << 59
+;; note that at 16-bytes-per-frame, this could generate a file byte offset
+;; that overflows an int64_t. Is this big enough? Time will tell.
+;; What if Nyquist is compiled for 32-bit machines and FIXNUM is 32-bits?
+;; if we don't have 64-bit ints, use 0x7f000000, which is about 10M less
+;; than the maximum signed 32-bit int, giving a lot of "headroom" but still
+;; over 2 billion, or about 13.4 hours at 44.1KHz
+(if (/= 10000000000 (* 100000 100000))
+ (setf NY:ALL 2130706432))
+
+
+;; S-SAVE combines optional and keyword parameters, but this is a really bad
+;; idea because keywords and values are used as optional parameters until
+;; all the optional parameters are used up. Thus if you leave out filename
+;; and progress, but you provide :endian T, then filename becomes :endian and
+;; progress becomes T. AARRGG!!
+;; I should have required filename and made everything else keyword, but
+;; rather than breaking compatibility, I'm using &rest to grab everything,
+;; parse the parameters for keywords (giving them priority over optional
+;; parameters, and filling in optional parameters as they are encountered.
+;;
+(defmacro s-save (expression &rest parameters)
+ (prog (parm (format *default-sf-format*)
+ (mode *default-sf-mode*)
+ (bits *default-sf-bits*)
+ ;; endian can be nil, :big, or :little
+ endian play optionals maxlen filename progress swap)
+ loop ;; until all parameters are used
+ (cond ((setf parm (car parameters))
+ (setf parameters (cdr parameters))
+ (case parm
+ (:format (setf format (car parameters)
+ parameters (cdr parameters)))
+ (:mode (setf mode (car parameters)
+ parameters (cdr parameters)))
+ (:bits (setf bits (car parameters)
+ parameters (cdr parameters)))
+ (:endian (setf endian (car parameters)
+ parameters (cdr parameters)))
+ (:play (setf play (car parameters)
+ parameters (cdr parameters)))
+ (t (setf optionals (cons parm optionals))))
+ (go loop)))
+ (cond ((> (length optionals) 3)
+ (error "S-SAVE got extra parameter(s)")))
+ (cond ((< (length optionals) 1) ;; need maxlen
+ (setf optionals (list ny:all))))
+ (cond ((< (length optionals) 2) ;; need filename
+ (setf optionals (cons nil optionals))))
+ (cond ((< (length optionals) 3) ;; need progress
+ (setf optionals (cons 0 optionals))))
+ (setf progress (first optionals) ;; note that optionals are in reverse order
+ filename (second optionals)
+ maxlen (third optionals))
+ (cond (*in-s-save*
+ (error "Recursive call to S-SAVE (or maybe PLAY) detected!")))
+
+ ;; finally, we have all the parameters and we can call snd-save
+ (return
+ `(let ((ny:fname ,filename) (ny:swap 0) (ny:endian ,endian)
+ (ny:play ,play)
+ ny:max-sample) ; return value
+ (progv '(*in-s-save*) '(t)
+ (if (null ny:fname)
+ (setf ny:fname *default-sound-file*))
+
+ (cond ((equal ny:fname "")
+ (cond ((not ,play)
+ (format t "S-SAVE: no file to write! ~
+ play option is off!\n"))))
+ (t
+ (setf ny:fname (soundfilename ny:fname))
+ (format t "Saving sound file to ~A~%" ny:fname)))
+
+ (cond ((eq ny:endian :big)
+ (setf ny:swap (if (bigendianp) 0 1)))
+ ((eq ny:endian :little)
+ (setf ny:swap (if (bigendianp) 1 0))))
+
+ ; print device info the first time sound is played
+ (cond (ny:play
+ (cond ((not (boundp '*snd-list-devices*))
+ (setf *snd-list-devices* t))))) ; one-time show
+ (setf max-sample
+ (snd-save ',expression ,maxlen ny:fname ,format
+ ,mode ,bits ny:swap ny:play ,progress))
+ ; more information if *snd-list-devices* was unbound:
+ (cond (ny:play
+ (cond (*snd-list-devices*
+ (format t "\nSet *snd-lfist-devices* = t \n ~
+ and call play to see device list again.\n~
+ Set *snd-device* to a fixnum to select an output device\n ~
+ or set *snd-device* to a substring of a device name\n ~
+ to select the first device containing the substring.\n")))
+ (setf *snd-list-devices* nil))) ; normally nil
+ max-sample)))))
+
+
+;; MULTICHANNEL-MAX -- find peak over all channels
+;;
+(defun multichannel-max (snd samples)
+ (cond ((soundp snd)
+ (snd-max snd samples))
+ ((arrayp snd) ;; assume it is multichannel sound
+ (let ((peak 0.0) (chans (length snd)))
+ (dotimes (i chans)
+ (setf peak (max peak (snd-max (aref snd i) (/ samples chans)))))
+ peak))
+ (t (error "unexpected value in multichannel-max" snd))))
+
+
+
+;; AUTONORM -- look ahead to find peak and normalize sound to 80%
+;;
+(defun autonorm (snd)
+ (let (peak)
+ (cond (*autonormflag*
+ (cond ((and (not (soundp snd))
+ (not (eq (type-of snd) 'ARRAY)))
+ (error "AUTONORM (or PLAY?) got unexpected value" snd))
+ ((eq *autonorm-type* 'previous)
+ (scale *autonorm* snd))
+ ((eq *autonorm-type* 'lookahead)
+ (setf peak (multichannel-max snd *autonorm-max-samples*))
+ (setf peak (max 0.001 peak))
+ (setf *autonorm* (/ *autonorm-target* peak))
+ (scale *autonorm* snd))
+ (t
+ (error "unknown *autonorm-type*"))))
+ (t snd))))
+
+
+(init-global *clipping-threshold* (/ 127.0 128.0))
+
+(defmacro s-save-autonorm (expression &rest arglist)
+ `(let ((peak (s-save (autonorm ,expression) ,@arglist)))
+ (when (and *clipping-error* (> peak *clipping-threshold*))
+ (format t "s-save-autonorm peak ~A from ~A~%" peak ,expression)
+ (error "clipping"))
+ (autonorm-update peak)))
+
+;; If the amplitude exceeds *clipping-threshold*, an error will
+;; be raised if *clipping-error* is set.
+;;
+(init-global *clipping-error* nil)
+
+;; The "AutoNorm" facility: when you play something, the Nyquist play
+;; command will automatically compute what normalization factor you
+;; should have used. If you play the same thing again, the normalization
+;; factor is automatically applied.
+;;
+;; Call AUTONORM-OFF to turn off this feature, and AUTONORM-ON to turn
+;; it back on.
+;;
+;; *autonorm-target* is the peak value we're aiming for (it's set below 1
+;; so allow the next signal to get slightly louder without clipping)
+;;
+(init-global *autonorm-target* 0.9)
+;;
+;; *autonorm-type* selects the autonorm algorithm to use
+;; 'previous means normalize according to the last computed sound
+;; 'precompute means precompute *autonorm-max-samples* samples in
+;; memory and normalize according to the peak
+;;
+(init-global *autonorm-type* 'lookahead)
+(init-global *autonorm-max-samples* 1000000) ; default is 4MB buffer
+
+;;
+(defun autonorm-on ()
+ (setf *autonorm* 1.0)
+ (setf *autonorm-previous-peak* 1.0)
+ (setf *autonormflag* t)
+ (format t "AutoNorm feature is on.~%"))
+
+(if (not (boundp '*autonormflag*)) (autonorm-on))
+
+(defun autonorm-off ()
+ (setf *autonormflag* nil)
+ (setf *autonorm* 1.0)
+ (format t "AutoNorm feature is off.~%"))
+
+(defun explain-why-autonorm-failed ()
+ (format t "~A~A~A~A~A~A"
+ " *autonorm-type* is LOOKAHEAD and your sound got\n"
+ " louder after the lookahead period, resulting in\n"
+ " too large a scale factor and clipping. Consider\n"
+ " setting *autonorm-type* to 'PREVIOUS. Alternatively,\n"
+ " try turning off autonorm, e.g. \"exec autonorm-off()\"\n"
+ " or in Lisp mode, (autonorm-off), and scale your sound\n"
+ " as follows.\n"))
+
+
+;; AUTONORM-UPDATE -- called with true peak to report and prepare
+;;
+;; after saving/playing a file, we have the true peak. This along
+;; with the autonorm state is printed in a summary and the autonorm
+;; state is updated for next time.
+;;
+;; There are currently two types: PREVIOUS and LOOKAHEAD
+;; With PREVIOUS:
+;; compute the true peak and print the before and after peak
+;; along with the scale factor to be used next time
+;; With LOOKAHEAD:
+;; compute the true peak and print the before and after peak
+;; along with the "suggested scale factor" that would achieve
+;; the *autonorm-target*
+;;
+(defun autonorm-update (peak)
+ (cond ((> peak 1.0)
+ (format t "*** CLIPPING DETECTED! ***~%")))
+ (cond ((and *autonormflag* (> peak 0.0))
+ (setf *autonorm-previous-peak* (/ peak *autonorm*))
+ (setf *autonorm* (/ *autonorm-target* *autonorm-previous-peak*))
+ (format t "AutoNorm: peak was ~A,~%" *autonorm-previous-peak*)
+ (format t " peak after normalization was ~A,~%" peak)
+ (cond ((eq *autonorm-type* 'PREVIOUS)
+ (cond ((zerop *autonorm*)
+ (setf *autonorm* 1.0)))
+ (format t " new normalization factor is ~A~%" *autonorm*))
+ ((eq *autonorm-type* 'LOOKAHEAD)
+ (cond ((> peak 1.0)
+ (explain-why-autonorm-failed)))
+ (format t " suggested manual normalization factor is ~A~%"
+ *autonorm*))
+ (t
+ (format t
+ " unexpected value for *autonorm-type*, reset to LOOKAHEAD\n")
+ (setf *autonorm-type* 'LOOKAHEAD))))
+ (t
+ (format t "Peak was ~A,~%" peak)
+ (cond ((> peak 0.0)
+ (format t " suggested normalization factor is ~A~%"
+ (/ *autonorm-target* peak))))))
+ peak
+ )
+
+
+;; s-read -- reads a file
+(defun s-read (filename &key (time-offset 0) (srate *sound-srate*)
+ (dur 10e20) (nchans 1) (format *default-sf-format*)
+ (mode *default-sf-mode*) (bits *default-sf-bits*) (endian NIL))
+ (let ((swap 0))
+ (cond ((eq endian :big)
+ (setf swap (if (bigendianp) 0 1)))
+ ((eq endian :little)
+ (setf swap (if (bigendianp) 1 0))))
+ (if (minusp dur) (error "s-read :dur is negative" dur))
+ (snd-read (soundfilename filename) time-offset
+ (local-to-global 0) format nchans mode bits swap srate
+ dur)))
+
+
+;; SF-INFO -- print sound file info
+;;
+(defun sf-info (filename)
+ (let (s format channels mode bits swap srate dur flags)
+ (format t "~A:~%" (soundfilename filename))
+ (setf s (s-read filename))
+ (setf format (snd-read-format *rslt*))
+ (setf channels (snd-read-channels *rslt*))
+ (setf mode (snd-read-mode *rslt*))
+ (setf bits (snd-read-bits *rslt*))
+ ; (setf swap (snd-read-swap *rslt*))
+ (setf srate (snd-read-srate *rslt*))
+ (setf dur (snd-read-dur *rslt*))
+ (setf flags (snd-read-flags *rslt*))
+ (format t "Format: ~A~%"
+ (nth format '("none" "AIFF" "IRCAM" "NeXT" "Wave" "PAF" "SVX"
+ "NIST" "VOC" "W64" "MAT4" "Mat5" "PVF" "XI" "HTK"
+ "SDS" "AVR" "SD2" "FLAC" "CAF")))
+ (cond ((setp (logand flags snd-head-channels))
+ (format t "Channels: ~A~%" channels)))
+ (cond ((setp (logand flags snd-head-mode))
+ (format t "Mode: ~A~%"
+ (nth mode '("ADPCM" "PCM" "uLaw" "aLaw" "Float" "UPCM"
+ "unknown" "double" "GSM610" "DWVW" "DPCM"
+ "msadpcm")))))
+ (cond ((setp (logand flags snd-head-bits))
+ (format t "Bits/Sample: ~A~%" bits)))
+ (cond ((setp (logand flags snd-head-srate))
+ (format t "SampleRate: ~A~%" srate)))
+ (cond ((setp (logand flags snd-head-dur))
+ (format t "Duration: ~A~%" dur)))
+ ))
+
+;; SETP -- tests whether a bit is set (non-zero)
+;
+(defun setp (bits) (not (zerop bits)))
+
+;; IS-FILE-SEPARATOR -- is this a file path separation character, e.g. "/"?
+;;
+(defun is-file-separator (c)
+ (or (eq c *file-separator*)
+ (and (eq *file-separator* #\\) ;; if this is windows (indicated by "\")
+ (eq c #\/)))) ;; then "/" is also a file separator
+
+;; SOUNDFILENAME -- add default directory to name to get filename
+;;
+(defun soundfilename (filename)
+ (cond ((= 0 (length filename))
+ (break "filename must be at least one character long" filename))
+ ((full-name-p filename))
+ (t
+ ; if sf-dir nonempty and does not end with filename separator,
+ ; append one
+ (cond ((and (< 0 (length *default-sf-dir*))
+ (not (is-file-separator
+ (char *default-sf-dir*
+ (1- (length *default-sf-dir*))))))
+ (setf *default-sf-dir* (strcat *default-sf-dir* (string *file-separator*)))
+ (format t "Warning: appending \"~A\" to *default-sf-dir*~%"
+ *file-separator*)))
+ (setf filename (strcat *default-sf-dir* (string filename)))))
+ ;; now we have a file name, but it may be relative to current directory, so
+ ;; expand it with the current directory
+ (cond ((relative-path-p filename)
+ ;; get current working directory and build full name
+ (let ((path (setdir ".")))
+ (cond (path
+ (setf filename (strcat path (string *file-separator*)
+ (string filename))))))))
+ filename)
+
+
+(setfn snd-read-format car)
+(setfn snd-read-channels cadr)
+(setfn snd-read-mode caddr)
+(setfn snd-read-bits cadddr)
+(defun snd-read-swap (rslt) (car (cddddr rslt)))
+(defun snd-read-srate (rslt) (cadr (cddddr rslt)))
+(defun snd-read-dur (rslt) (caddr (cddddr rslt)))
+(defun snd-read-flags (rslt) (cadddr (cddddr rslt)))
+
+;; round is tricky because truncate rounds toward zero as does C
+;; in other words, rounding is down for positive numbers and up
+;; for negative numbers. You can convert rounding up to rounding
+;; down by subtracting one, but this fails on the integers, so
+;; we need a special test if (- x 0.5) is an integer
+(defun round (x)
+ (cond ((> x 0) (truncate (+ x 0.5)))
+ ((= (- x 0.5) (truncate (- x 0.5))) (truncate x))
+ (t (truncate (- x 0.5)))))
+
+;; change defaults for PLAY macro:
+(init-global *soundenable* t)
+(defun sound-on () (setf *soundenable* t))
+(defun sound-off () (setf *soundenable* nil))
+
+(defun coterm (snd1 snd2)
+ (multichan-expand #'snd-coterm snd1 snd2))
+
+(defmacro s-add-to (expr maxlen filename
+ &optional (time-offset 0.0) (progress 0))
+ `(let ((ny:fname (soundfilename ,filename))
+ ny:peak ny:input (ny:offset ,time-offset))
+ (format t "Adding sound to ~A at offset ~A~%"
+ ny:fname ,time-offset)
+ (setf ny:peak (snd-overwrite '(let ((ny:addend ,expr))
+ (sum (coterm
+ (s-read ny:fname
+ :time-offset ny:offset)
+ ny:addend)
+ ny:addend))
+ ,maxlen ny:fname ny:offset ,progress))
+ (format t "Duration written: ~A~%" (car *rslt*))
+ ny:peak))
+
+
+(defmacro s-overwrite (expr maxlen filename
+ &optional (time-offset 0.0) (progress 0))
+ `(let ((ny:fname (soundfilename ,filename))
+ (ny:peak 0.0)
+ ny:input ny:rslt (ny:offset ,time-offset))
+ (format t "Overwriting ~A at offset ~A~%" ny:fname ny:offset)
+ (setf ny:peak (snd-overwrite `,expr ,maxlen ny:fname ny:offset ,progress))
+ (format t "Duration written: ~A~%" (car *rslt*))
+ ny:peak))
+
+
+
+
diff --git a/Release/nyquist/init.lsp b/Release/nyquist/init.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..102d0ab82fc8f3420b0aac65c3a5160212c29d36
--- /dev/null
+++ b/Release/nyquist/init.lsp
@@ -0,0 +1,88 @@
+; init.lsp -- default Nyquist startup file
+
+(setf *breakenable* t)
+(load "nyinit.lsp" :verbose nil)
+
+; add your customizations here:
+; e.g. (setf *default-sf-dir* "...")
+
+; (load "test.lsp")
+
+
+
+;; "_" (UNDERSCORE) - translation function
+;;
+;; Third party plug-ins are not translated by gettext in Audacity, but may include a
+;; list of translations named *locale*. The format of *locale* must be:
+;; (LIST (language-list) [(language-list) ...])
+;; Each language-list is an a-list in the form:
+;; ("cc" ((list "string" "translated-string") [(list "string" "translated-string") ...]))
+;; where "cc" is the quoted country code.
+;;
+(setfn underscore _)
+;;
+(defun _(txt &aux newtxt)
+ (when (boundp '*locale*)
+ (when (not (listp *locale*))
+ (error "bad argument type" *locale*))
+ (let* ((cc (get '*audacity* 'language))
+ (translations (second (assoc cc *locale* :test 'string-equal))))
+ (if translations
+ (let ((translation (second (assoc txt translations :test 'string=))))
+ (if translation
+ (if (stringp translation)
+ (setf newtxt translation)
+ (error "bad argument type" translation))
+ (format t "No ~s translation of ~s.~%" cc txt)))
+ (progn
+ (setf *locale* '*unbound*)
+ (format t "No ~s translations.~%" cc)))))
+ (if newtxt newtxt (underscore txt)))
+
+
+;;; Some helpers for parsing strings returned by (aud-do "GetInfo: ...
+
+(defun eval-string (string)
+ ;;; Evaluate a string as a LISP expression.
+ ;;; If 'string' is not a valid LISP expression, the behaviour is undefined.
+ (eval (read (make-string-input-stream string))))
+
+(defmacro quote-string (string)
+ ;;; Prepend a single quote to a string
+ `(setf ,string (format nil "\'~a" ,string)))
+
+(defun aud-get-info (str)
+ ;;; Return "GetInfo: type=type" as Lisp list, or throw error
+ ;;; Audacity 2.3.0 does not fail if type is not recognised, it
+ ;;; falls back to a default, so test for valid types.
+ ;;; 'Commands+' is not supported in Audacity 2.3.0
+ (let (type
+ info
+ (types '("Commands" "Menus" "Preferences"
+ "Tracks" "Clips" "Envelopes" "Labels" "Boxes")))
+ ;Case insensitive search, then set 'type' with correct case string, or NIL.
+ (setf type (first (member str types :test 'string-equal)))
+ (if (not type)
+ (error (format nil "bad argument '~a' in (aud-get-info ~a)" str str)))
+ (setf info (aud-do (format nil "GetInfo: type=~a format=LISP" type)))
+ (if (not (last info))
+ (error (format nil "(aud-get-info ~a) failed.~%" str)))
+ (let* ((info-string (first info))
+ (sanitized ""))
+ ;; Escape backslashes
+ (dotimes (i (length info-string))
+ (setf ch (subseq info-string i (1+ i)))
+ (if (string= ch "\\")
+ (string-append sanitized "\\\\")
+ (string-append sanitized ch)))
+ (eval-string (quote-string sanitized)))))
+
+
+;;; *NYQ-PATH* is not required as path to Nyquist .lsp files
+;;; is already defined (but not previously documented) as *runtime-path*
+;;(setf *NYQ-PATH* (current-path))
+
+;;; Load wrapper functions for aud-do commands.
+;;; If commented out, "aud-do-support.lsp" may be loaded by a plug-in.
+;;; Example: (lisp-loader (strcat *runtime-path* "aud-do-support.lsp"))
+(load "aud-do-support.lsp" :verbose nil)
diff --git a/Release/nyquist/misc.lsp b/Release/nyquist/misc.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..c81726ca80c009373b40f2df34ff59ba540da5d8
--- /dev/null
+++ b/Release/nyquist/misc.lsp
@@ -0,0 +1,235 @@
+;## misc.lsp -- a collection of useful support functions
+
+;; Garbage collection "improvement" -- XLISP will GC without allocation
+;; as long as it does not run out of cells. This can make it very slow
+;; since GC does work proportional to the heap size. If there were
+;; always at least, say, 1/3 of the heap free after GC, then allocating
+;; cells would be more-or-less a constant time operation (amortized).
+;;
+;; So, after GC, we'll expand until we have 1/3 of the heap free.
+;;
+(defun ny:gc-hook (heap-size free-cells)
+ (cond ((< (* free-cells 2) heap-size) ;; free cells is < 1/3 heap
+ ;; expand. Each expansion unit is 2000 cons cells
+ (let* ((how-many-not-free (- heap-size free-cells))
+ (should-be-free (/ how-many-not-free 2))
+ (how-many-more (- should-be-free free-cells))
+ (expand-amount (/ how-many-more 2000)))
+ (cond ((> expand-amount 0)
+ (if *gc-flag*
+ (format t
+ "[ny:gc-hook allocating ~A more cells] "
+ (* expand-amount 2000)))
+ (expand expand-amount)))))))
+
+(setf *gc-hook* 'ny:gc-hook)
+
+
+; set global if not already set
+;
+(defmacro init-global (symb expr)
+ `(if (boundp ',symb) ,symb (setf ,symb ,expr)))
+
+; controlling breaks and tracebacks:
+; XLISP and SAL behave differently, so there are four(!) flags:
+; *sal-traceback* -- print SAL traceback on error in SAL mode
+; Typically you want this on always.
+; *sal-break* -- allow break (to XLISP prompt) on error when in SAL mode
+; (overrides *sal-traceback*) Typically, you do not want
+; this unless you need to see exactly where an error happened
+; or the bug is in XLISP source code called from SAL.
+; *xlisp-break* -- allow break on error when in XLISP mode
+; Typically, you want this on.
+; *xlisp-traceback* -- print XLISP traceback on error in XLISP mode
+; Typically, you do not want this because the full
+; stack can be long and tedious. Also allow XLISP
+; traceback in SAL mode if *sal-break* is true.
+
+(setf *sal-mode* nil)
+
+(setf *sal-traceback* t
+ *sal-break* nil
+ *xlisp-break* t
+ *xlisp-traceback* nil)
+
+(defun sal-tracenable (flag) (setf *sal-traceback* flag))
+(defun sal-breakenable (flag)
+ (setf *sal-break* flag)
+ (if *sal-mode* (setf *breakenable* flag)))
+(defun xlisp-breakenable (flag)
+ (setf *xlisp-break* flag)
+ (if (not *sal-mode*) (setf *breakenable* flag)))
+(defun xlisp-tracenable (flag)
+ (setf *xlisp-traceback* flag)
+ (if flag (setf *xlisp-break* t))
+ (cond ((not *sal-mode*)
+ (if flag (setf *breakenable* t))
+ (setf *tracenable* flag))))
+
+
+; enable or disable breaks
+(defun bkon () (xlisp-breakenable t))
+(defun bkoff () (xlisp-breakenable nil))
+
+
+;; (grindef 'name) - pretty print a function
+;;
+(defun grindef (e) (pprint (get-lambda-expression (symbol-function e))))
+
+;; (args 'name) - print function and its formal arguments
+;;
+(defun args (e)
+ (pprint (cons e (second (get-lambda-expression (symbol-function e))))))
+
+;; (incf <place>), (decf <place>) - add/sub 1 to/from variable
+;;
+(defmacro incf (symbol) `(setf ,symbol (1+ ,symbol)))
+(defmacro decf (symbol) `(setf ,symbol (1- ,symbol)))
+
+
+;; (push val <place>) - cons val to list
+;;
+(defmacro push (val lis) `(setf ,lis (cons ,val ,lis)))
+(defmacro pop (lis) `(prog1 (car ,lis) (setf ,lis (cdr ,lis))))
+
+;; include this to use RBD's XLISP profiling hooks
+;;(load "/afs/andrew/usr/rbd/lib/xlisp/profile.lsp")
+
+;(cond ((boundp 'application-file-name)
+; (load application-file-name)))
+
+
+(defun get-input-file-name ()
+ (let (fname)
+ (format t "Input file name: ")
+ (setf fname (read-line))
+ (cond ((equal fname "") (get-input-file-name))
+ (t fname))))
+
+
+(defun open-output-file ()
+ (let (fname)
+ (format t "Output file name: ")
+ (setf fname (read-line))
+ (cond ((equal fname "") t)
+ (t (open fname :direction :output)))))
+
+
+(defmacro while (cond &rest stmts)
+ `(prog () loop (if ,cond () (return)) ,@stmts (go loop)))
+
+
+; when parens/quotes don't match, try this
+;
+(defun file-sexprs ()
+ (let ((fin (open (get-input-file-name)))
+ inp)
+ (while (setf inp (read fin)) (print inp))))
+
+;; get path for currently loading file (if any)
+;;
+(defun current-path ()
+ (let (fullpath n)
+ (setf n -1)
+ (cond (*loadingfiles*
+ (setf fullpath (car *loadingfiles*))
+ (dotimes (i (length fullpath))
+ ;; search for "/" (and on windows, also "\") in path:
+ (cond ((or (equal (char fullpath i) *file-separator*)
+ (equal (char fullpath i) #\/))
+ (setf n i))))
+ ;; trim off filename (after last separator char in path
+ (setf fullpath (subseq fullpath 0 (1+ n)))
+
+;; REMOVED SUPPORT FOR MAC OS-9 AND BELOW -RBD
+ ;; if this is a Mac, use ':' in place of empty path
+;; (cond ((and (equal fullpath "")
+;; (equal *file-separator* #\:))
+;; (setf fullpath ":")))
+;; END MAC OS-9 CODE
+
+ ;; Here's an interesting problem: fullpath is now the path
+ ;; specified to LOAD, but it may be relative to the current
+ ;; directory. What if we want to load a sound file from the
+ ;; current directory? It seems that S-READ gives priority to
+ ;; the *DEFAULT-SF-DIR*, so it will follow fullpath STARTING
+ ;; FROM *DEFAULT-SF-DIR*. To fix this, we need to make sure
+ ;; that fullpath is either an absolute path or starts with
+ ;; and explicit ./ which tells s-read to look in the current
+ ;; directory.
+ (cond ((> (length fullpath) 0)
+ (cond ((full-name-p fullpath))
+ (t ; not absolute, make it explicitly relative
+ (setf fullpath (strcat "./" fullpath)))))
+ (t (setf fullpath "./"))) ; use current directory
+ fullpath)
+ (t nil))))
+
+;; real-random -- pick a random real from a range
+;;
+(defun real-random (from to)
+ (+ (* (rrandom) (- to from)) from))
+
+;; power -- raise a number to some power x^y
+;;
+(defun power (x y)
+ (exp (* (log (float x)) y)))
+
+;; require-from -- load a file if a function is undefined
+;;
+;; fn-symbol -- the function defined when the file is loaded
+;; file-name -- the name of file to load if fn-symbol is undefined
+;; path -- if t, load from current-path; if a string, prepend string
+;; to file-name; if nil, ignore it
+;;
+(defmacro require-from (fn-symbol file-name &optional path)
+ (cond ((eq path t)
+ (setf file-name `(strcat (current-path) ,file-name)))
+ (path
+ (setf file-name `(strcat ,path ,file-name))))
+ ; (display "require-from" file-name)
+ `(if (fboundp (quote ,fn-symbol))
+ t
+ ;; search for either .lsp or .sal file
+ (sal-load ,file-name)))
+
+;; COMPUTE-DEFAULT-SOUND-FILE -- construct and set *default-sound-file*
+;;
+;; (this is harder than it might seem because the default place for
+;; sound files is in /tmp, which is shared by users, so we'd like to
+;; use a user-specific name to avoid collisions)
+;;
+(defun compute-default-sound-file ()
+ (let (inf user extension)
+ ; the reason for the user name is that if UserA creates a temp file,
+ ; then UserB will not be able to overwrite it. The user name is a
+ ; way to give each user a unique temp file name. Note that we don't
+ ; want each session to generate a unique name because Nyquist doesn't
+ ; delete the sound file at the end of the session.
+ (setf user (get-user))
+#|
+ (cond ((null user)
+ (format t
+"Please type your user-id so that I can construct a default
+sound-file name. To avoid this message in the future, add
+this to your .login file:
+ setenv USER <your id here>
+or add this to your init.lsp file:
+ (setf *default-sound-file* \"<your filename here>\")
+ (setf *default-sf-dir* \"<full pathname of desired directory here>\")
+
+Your id please: ")
+ (setf user (read))))
+|#
+ ; now compute the extension based on *default-sf-format*
+ (cond ((= *default-sf-format* snd-head-AIFF)
+ (setf extension ".aif"))
+ ((= *default-sf-format* snd-head-Wave)
+ (setf extension ".wav"))
+ (t
+ (setf extension ".snd")))
+ (setf *default-sound-file*
+ (strcat (string-downcase user) "-temp" extension))
+ (format t "Default sound file is ~A.~%" *default-sound-file*)))
+
+
diff --git a/Release/nyquist/nyinit-dbg.lsp b/Release/nyquist/nyinit-dbg.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..352844575b500bf7dd21c3cc268213467cf8bb05
--- /dev/null
+++ b/Release/nyquist/nyinit-dbg.lsp
@@ -0,0 +1,38 @@
+(expand 5)
+
+(load "xlinit.lsp" :verbose NIL)
+(setf *gc-flag* nil)
+(load "misc.lsp" :verbose NIL)
+(load "evalenv.lsp" :verbose NIL)
+(load "printrec.lsp" :verbose NIL)
+
+(load "sndfnint.lsp" :verbose NIL)
+(load "seqfnint.lsp" :verbose NIL)
+
+(load "velocity.lsp" :verbose NIL) ; linear-to-vel etc
+(load "nyquist-dbg.lsp" :verbose NIL)
+(load "compress.lsp" :verbose NIL)
+
+(load "system.lsp" :verbose NIL)
+
+(load "seqmidi.lsp" :verbose NIL)
+(load "nyqmisc.lsp" :verbose NIL)
+(load "stk.lsp" :verbose NIL)
+(load "envelopes.lsp" :verbose NIL)
+(load "equalizer.lsp" :verbose NIL)
+(load "xm.lsp" :verbose NIL)
+(load "sal.lsp" :verbose NIL)
+
+;; set to T to get ANSI headers and NIL to get antique headers
+(setf *ANSI* NIL)
+
+;; set to T to generate tracing code, NIL to disable tracing code
+(setf *WATCH* NIL)
+
+(format t "~%Nyquist -- A Language for Sound Synthesis and Composition~%")
+(format t " Copyright (c) 1991,1992,1995,2007-2012 by Roger B. Dannenberg~%")
+(format t " Version 3.10~%~%")
+
+;(setf *gc-flag* t)
+
+
diff --git a/Release/nyquist/nyinit.lsp b/Release/nyquist/nyinit.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..47b2cbdb5d8f54def8ab690a33e98e7171718680
--- /dev/null
+++ b/Release/nyquist/nyinit.lsp
@@ -0,0 +1,36 @@
+(expand 5)
+
+(load "xlinit.lsp" :verbose NIL)
+(setf *gc-flag* nil)
+(load "misc.lsp" :verbose NIL)
+;; now compute-default-sound-file is defined; needed by system.lsp ...
+(load "evalenv.lsp" :verbose NIL)
+(load "printrec.lsp" :verbose NIL)
+
+(load "sndfnint.lsp" :verbose NIL)
+(load "seqfnint.lsp" :verbose NIL)
+
+(load "velocity.lsp" :verbose NIL) ; linear-to-vel etc
+(if (not (load "system.lsp" :verbose NIL))
+ (error "Nyquist could not load system.lsp - check your installation"))
+;; now *file-separator* is defined, used by nyquist.lsp...
+(load "nyquist.lsp" :verbose NIL)
+
+
+(load "seqmidi.lsp" :verbose NIL)
+(load "nyqmisc.lsp" :verbose NIL)
+(load "stk.lsp" :verbose NIL)
+(load "envelopes.lsp" :verbose NIL)
+(load "equalizer.lsp" :verbose NIL)
+(load "xm.lsp" :verbose NIL)
+(load "sal.lsp" :verbose NIL)
+
+
+(format t "~%Nyquist -- A Language for Sound Synthesis and Composition~%")
+(format t " Copyright (c) 1991,1992,1995,2007-2020 by Roger B. Dannenberg~%")
+(format t " Version 3.16~%~%")
+(load "extensions.lsp" :verbose NIL)
+
+;(setf *gc-flag* t)
+
+
diff --git a/Release/nyquist/nyqmisc.lsp b/Release/nyquist/nyqmisc.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..3905d33c5ade1b4b7d9039e2ab11411ad3653612
--- /dev/null
+++ b/Release/nyquist/nyqmisc.lsp
@@ -0,0 +1,27 @@
+;; nyqmisc.lsp -- misc functions for nyquist
+
+(init-global *snd-display-max-samples* 10000)
+(init-global *snd-display-print-samples* 100)
+
+
+; (snd-display sound) -- describe a sound
+(defun snd-display (sound)
+ (let (t0 srate len extent dur samples)
+ (setf srate (snd-srate sound))
+ (setf t0 (snd-t0 sound))
+ (setf len (snd-length sound *snd-display-max-samples*))
+ (cond ((= len *snd-display-max-samples*)
+ (setf extent (format nil ">~A" (+ t0 (* srate *snd-display-max-samples*))))
+ (setf dur (format nil ">~A" (* srate *snd-display-max-samples*))))
+ (t
+ (setf extent (cadr (snd-extent sound *snd-display-max-samples*)))
+ (setf dur (/ (snd-length sound *snd-display-max-samples*) srate))))
+ (cond ((> len 100)
+ (setf samples (format nil "1st ~A samples" *snd-display-print-samples*))
+ (setf nsamples *snd-display-print-samples*))
+ (t
+ (setf samples (format nil "~A samples" len))
+ (setf nsamples len)))
+ (format t "~A: srate ~A, t0 ~A, extent ~A, dur ~A, ~A: ~A"
+ sound srate t0 extent dur samples (snd-samples sound nsamples))))
+
diff --git a/Release/nyquist/nyquist-plot.txt b/Release/nyquist/nyquist-plot.txt
new file mode 100644
index 0000000000000000000000000000000000000000..003e6e0f457b88eba3c2a3f76a9d94865521678f
--- /dev/null
+++ b/Release/nyquist/nyquist-plot.txt
@@ -0,0 +1,3 @@
+set nokey
+plot "points.dat" with lines
+
diff --git a/Release/nyquist/nyquist.lsp b/Release/nyquist/nyquist.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..dcd30c35969a163292b93020a6754ffe0125ff99
--- /dev/null
+++ b/Release/nyquist/nyquist.lsp
@@ -0,0 +1,2482 @@
+;;;
+;;; ###########################################################
+;;; ### NYQUIST-- A Language for Composition and Synthesis. ###
+;;; ### ###
+;;; ### Copyright (c) 1994-2006 by Roger B. Dannenberg ###
+;;; ###########################################################
+;;;
+(princ "LOADING NYQUIST RUNTIME DEBUG VERSION\n")
+
+;; #### Error checking and reporting functions ####
+
+(setf *SAL-CALL-STACK* nil) ; because SEQ looks at this
+
+;; MULTICHANNEL-SOUNDP - test for vector of sounds
+(defun multichannel-soundp (v)
+ (prog ((rslt t))
+ (if (not (arrayp v)) (return nil))
+ (dotimes (i (length v))
+ (cond ((not (soundp (aref v i)))
+ (setf rslt nil)
+ (return nil))))
+ (return rslt)))
+
+;; MULTICHANNELP - test for vector of sounds or numbers
+(defun multichannelp (v)
+ (prog ((rslt t))
+ (if (not (arrayp v)) (return nil))
+ (dotimes (i (length v))
+ (cond ((not (or (numberp (aref v i)) (soundp (aref v i))))
+ (setf rslt nil)
+ (return nil))))
+ (return rslt)))
+
+;; NUMBERSP - test for vector of numbers
+(defun numbersp (v)
+ (prog ((rslt t))
+ (if (not (arrayp v)) (return nil))
+ (dotimes (i (length v))
+ (cond ((not (numberp (aref v i)))
+ (setf rslt nil)
+ (return nil))))
+ (return rslt)))
+
+
+;; PARAM-TO-STRING - make printable parameter for error message
+(defun param-to-string (param)
+ (cond ((null param) (format nil "NIL"))
+ ((soundp param) (format nil "a SOUND"))
+ ((multichannel-soundp param)
+ (format nil "a ~A-channel SOUND" (length param)))
+ ((eq (type-of param) 'ARRAY) ;; avoid saying "#(1 2), a ARRAY"
+ (format nil "~A, an ARRAY" param))
+ ((stringp param) (format nil "~s, a STRING" param)) ;; add quotes
+ (t
+ (format nil "~A, a ~A" param (symbol-name (type-of param))))))
+
+
+;; NY:TYPECHECK -- syntactic sugar for "if", used for all nyquist typechecks
+(setfn ny:typecheck if)
+
+(defun index-to-string (index)
+ (nth index '("" " 1st" " 2nd" " 3rd" " 4th" " 5th" " 6th" " 7th")))
+
+(setf number-anon '((NUMBER) nil))
+(setf number-sound-anon '((NUMBER SOUND) nil))
+
+;; NY:TYPE-LIST-AS-STRING - convert permissible type list into
+;; description. E.g. typs = '(NUMBER SOUND) and multi = t returns:
+;; "number, sound or array thereof"
+(defun ny:type-list-as-string (typs multi)
+ (let (lis last penultimate (string "") multi-clause)
+ (if (member 'NUMBER typs) (push "number" lis))
+ (if (member 'POSITIVE typs) (push "positive number" lis))
+ (if (member 'NONNEGATIVE typs) (push "non-negative number" lis))
+ (if (member 'INTEGER typs) (push "integer" lis))
+ (if (member 'STEP typs) (push "step number" lis))
+ (if (member 'STRING typs) (push "string" lis))
+ (if (member 'SOUND typs) (push "sound" lis))
+ (if (member 'NULL typs) (push "NIL" lis))
+ ;; this should be handled with two entries: INTEGER and NULL, but
+ ;; this complicates multichan-expand, where lists of arbitrary types
+ ;; are not handled and we need INT-OR-NULL for PV-TIME-PITCH's
+ ;; hopsize parameter.
+ (cond ((member 'INT-OR-NULL typs)
+ (push "integer" lis)
+ (push "NIL" lis)))
+ (cond ((member 'POSITIVE-OR-NULL typs)
+ (push "positive number" lis)
+ (push "NIL" lis)))
+ (cond (multi
+ (setf multi-clause
+ (cond ((> (length lis) 1) "array thereof")
+ ((equal (car lis) "sound") "multichannel sound")
+ (t (strcat "array of " (car lis) "s"))))
+ (push multi-clause lis)))
+ (setf last (first lis))
+ (setf penultimate (second lis))
+ (setf lis (cddr lis))
+ (dolist (item lis)
+ (setf string (strcat item ", " string)))
+ (strcat string (if penultimate (strcat penultimate " or ") "") last)))
+
+
+;; NY:ERROR -- construct an error message and raise an error
+(defun ny:error (src index typ val &optional multi (val2 nil second-val))
+ (let ((types-string (ny:type-list-as-string (first typ) multi)))
+ (error (strcat "In " src "," (index-to-string index) " argument"
+ (if (second typ) (strcat " (" (second typ) ")") "")
+ (if (eq (char types-string 0) #\i) " must be an " " must be a ")
+ types-string
+ ", got " (param-to-string val)
+ (if second-val (strcat ", and" (param-to-string val2)) "")))))
+
+
+(prog ()
+ (setq lppp -12.0) (setq lpp -9.0) (setq lp -6.0) (setq lmp -3.0)
+ (setq lfff 12.0) (setq lff 9.0) (setq lf 6.0) (setq lmf 3.0)
+ (setq dB0 1.00) (setq dB1 1.122) (setq dB10 3.1623)
+
+ (setq s 0.25) (setq sd 0.375) (setq st (/ 0.5 3.0))
+ (setq i 0.5) (setq id 0.75) (setq it (* st 2.0))
+ (setq q 1.0) (setq qd 1.5) (setq qt (* st 4.0))
+ (setq h 2.0) (setq hd 3.0) (setq ht (* st 8.0))
+ (setq w 4.0) (setq wd 6.0) (setq wt (* st 16.0))
+)
+
+(init-global *A4-Hertz* 440.0)
+
+; next pitch, for initializations below
+;
+(defun np () (incf nyq:next-pitch))
+
+(defun set-pitch-names ()
+ (setq no-pitch 116.0)
+ ; note: 58.0 is A4 - (C0 - 1) = 69 - (12 - 1)
+ (setf nyq:next-pitch (- (hz-to-step *A4-Hertz*) 58.0))
+
+ (setf nyq:pitch-names
+ '(c0 (cs0 df0) d0 (ds0 ef0) e0 f0 (fs0 gf0) g0 (gs0 af0) a0
+ (as0 bf0) b0
+ c1 (cs1 df1) d1 (ds1 ef1) e1 f1 (fs1 gf1) g1 (gs1 af1) a1
+ (as1 bf1) b1
+ c2 (cs2 df2) d2 (ds2 ef2) e2 f2 (fs2 gf2) g2 (gs2 af2) a2
+ (as2 bf2) b2
+ c3 (cs3 df3) d3 (ds3 ef3) e3 f3 (fs3 gf3) g3 (gs3 af3) a3
+ (as3 bf3) b3
+ c4 (cs4 df4) d4 (ds4 ef4) e4 f4 (fs4 gf4) g4 (gs4 af4) a4
+ (as4 bf4) b4
+ c5 (cs5 df5) d5 (ds5 ef5) e5 f5 (fs5 gf5) g5 (gs5 af5) a5
+ (as5 bf5) b5
+ c6 (cs6 df6) d6 (ds6 ef6) e6 f6 (fs6 gf6) g6 (gs6 af6) a6
+ (as6 bf6) b6
+ c7 (cs7 df7) d7 (ds7 ef7) e7 f7 (fs7 gf7) g7 (gs7 af7) a7
+ (as7 bf7) b7
+ c8 (cs8 df8) d8 (ds8 ef8) e8 f8 (fs8 gf8) g8 (gs8 af8) a8
+ (as8 bf8) b8))
+
+ (dolist (p nyq:pitch-names)
+ (cond ((atom p) (set p (np)))
+ (t (let ((pitch (np)))
+ (dolist (s p) (set s pitch)))))))
+
+
+(set-pitch-names)
+
+(init-global *default-sound-srate* 44100.0)
+(init-global *default-control-srate* 2205.0)
+
+(setf *environment-variables*
+ '(*WARP* *SUSTAIN* *START* *LOUD* *TRANSPOSE*
+ *STOP* *CONTROL-SRATE* *SOUND-SRATE*))
+
+(setfn environment-time car)
+(setfn environment-stretch cadr)
+
+; ENVIRONMENT-MAP - map virtual time using an environment
+;
+;(defun environment-map (env tim)
+; (+ (environment-time env)
+; (* (environment-stretch env) tim)))
+
+
+(defun nyq:the-environment () (mapcar 'eval *environment-variables*))
+
+
+;; GLOBAL ENVIRONMENT VARIABLES and their startup values:
+(defun nyq:environment-init ()
+ (setq *WARP* '(0.0 1.0 nil))
+ (setq *LOUD* 0.0) ; now in dB
+ (setq *TRANSPOSE* 0.0)
+ (setq *SUSTAIN* 1.0)
+ (setq *START* MIN-START-TIME)
+ (setq *STOP* MAX-STOP-TIME)
+ (setq *CONTROL-SRATE* *DEFAULT-CONTROL-SRATE*)
+ (setq *SOUND-SRATE* *DEFAULT-SOUND-SRATE*)
+ t) ; return nothing in particular
+
+(nyq:environment-init)
+
+(defun get-duration (dur)
+ (ny:typecheck (not (numberp dur))
+ (ny:error "GET-DURATION" 0 number-anon dur))
+ (let ((duration
+ (- (local-to-global (* (get-sustain) dur))
+ (setf *rslt* (local-to-global 0)))))
+ (cond ((minusp duration)
+ (error
+"duration is less than zero: perhaps a warp or stretch
+is ill-formed. Nyquist cannot continue because synthesis
+functions assume durations are always positive.")))
+ duration))
+
+
+(defun get-loud ()
+ (cond ((numberp *loud*) *loud*)
+ ((soundp *loud*)
+ (sref *loud* 0))
+ (t
+ (error (format t "*LOUD* should be a number or sound: ~A" *LOUD*)))))
+
+
+(defun get-sustain ()
+ (cond ((numberp *SUSTAIN*) *SUSTAIN*)
+ ((soundp *SUSTAIN*)
+ ;(display "get-sustain: lookup " (local-to-global 0) 0))
+ (sref *SUSTAIN* 0))
+ (t
+ (error (format t "*SUSTAIN* should be a number or sound: ~A" *SUSTAIN*)))))
+
+
+(defun get-tempo ()
+ (if (warp-function *WARP*)
+ (slope (snd-inverse (get-warp) (local-to-global 0)
+ *control-srate*))
+ (/ 1.0 (warp-stretch *WARP*))))
+
+(defun get-transpose ()
+ (cond ((numberp *TRANSPOSE*) *TRANSPOSE*)
+ ((soundp *TRANSPOSE*)
+ (sref *TRANSPOSE* 0))
+ (t
+ (error (format t "*TRANSPOSE* should be a number or sound: ~A" *TRANSPOSE*)))))
+
+
+(defun get-warp ()
+ (let ((f (warp-function *WARP*)))
+ (ny:typecheck (null f)
+ (error "In GET-WARP, there is no warp function, probably because you are not within WARP or WARP-ABS"))
+ (shift-time (scale-srate f (/ (warp-stretch *WARP*)))
+ (- (warp-time *WARP*)))))
+
+
+(load "dspprims.lsp" :verbose NIL)
+(load "fileio.lsp" :verbose NIL)
+
+
+;;;;;;;;;;;;;;;;;;;;;;
+;; OSCILATORS
+;;;;;;;;;;;;;;;;;;;;;;
+
+(defun build-harmonic (n table-size)
+ (ny:typecheck (not (integerp n))
+ (ny:error "BUILD-HARMONIC" 1 '((INTEGER) "n") n))
+ (ny:typecheck (not (integerp table-size))
+ (ny:error "BUILD-HARMONIC" 2 '((INTEGER) "table-size") table-size))
+ (ny:typecheck (>= n (/ table-size 2))
+ (error "In BUILD-HARMONIC, harmonic number should be less than half the table size"
+ (list n table-size)))
+ (snd-sine 0 n table-size 1))
+
+
+(setf *SINE-TABLE* (list (build-harmonic 1 2048)
+ (hz-to-step 1.0)
+ T))
+(setf *TABLE* *SINE-TABLE*)
+
+
+(defun calculate-hz (pitch what &optional (max-fraction 0.5) maxlength)
+ (let ((hz (step-to-hz (+ pitch (get-transpose))))
+ (octaves 0) original)
+ (setf original hz)
+ (while (>= hz (* *SOUND-SRATE* max-fraction))
+ (setf octaves (1+ octaves)
+ hz (* hz 0.5)))
+ (cond ((> octaves 0)
+ (format t
+ "Warning: ~A frequency reduced by ~A octaves from ~A to ~A hz to avoid aliasing.\n"
+ what octaves original hz)
+ (setf octaves 0)))
+ (while (and maxlength (<= hz (/ *SOUND-SRATE* maxlength)))
+ (setf octaves (1+ octaves)
+ hz (* hz 2.0)))
+ (cond ((> octaves 0)
+ (format t
+ "Warning: ~A frequency increased by ~A octaves from ~A to ~A hz due to restriction on maximum table length.\n"
+ what octaves original hz)))
+ hz))
+
+
+(defun ny:assert-env-spec (env-spec message)
+ (if (not (ny:env-spec-p env-spec))
+ (error message env-spec)))
+
+
+(defun ny:assert-table (fun-name index formal actual)
+ (if (not (and (listp actual) (= 3 (length actual))))
+ (error (format nil
+ "In ~A,~A argument (~A) should be a list of 3 elements, got ~A"
+ fun-name (index-to-string index) formal actual)))
+ (if (not (soundp (car actual)))
+ (error (format nil
+ "In ~A,~A argument (~A) should be a list beginning with a sound, got ~A"
+ fun-name (index-to-string index) formal actual)))
+ (if (not (numberp (second actual)))
+ (error (format nil
+ "In ~A,~A argument (~A) should be a list whose 2nd element is a step number (pitch), got ~A"
+ fun-name (index-to-string index) formal actual)))
+ (if (not (third actual))
+ (error (format nil
+ "In ~A,~A argument (~A) should be a list whose 3rd element is true, got ~A"
+ fun-name (index-to-string index) formal actual))))
+
+
+(defun ny:assert-sample (fun-name index formal actual)
+ (if (not (and (listp actual) (= 3 (length actual))))
+ (error (format nil
+ "In ~A,~A argument (~A) should be a list of 3 elements, got ~A"
+ fun-name (index-to-string index) formal actual)))
+ (if (not (soundp (car actual)))
+ (error (format nil
+ "In ~A,~A argument (~A) should be a list beginning with a sound, got ~A"
+ fun-name (index-to-string index) formal actual)))
+ (if (not (numberp (second actual)))
+ (error (format nil
+ "In ~A,~A argument (~A) should be a list whose 2nd element is a step number (pitch), got ~A"
+ fun-name (index-to-string index) formal actual)))
+ (if (not (numberp (third actual)))
+ (error (format nil
+ "In ~A,~A argument (~A) should be a list whose 3rd element is the sample start time, got ~A"
+ fun-name (index-to-string index) formal actual))))
+
+(defun ny:env-spec-p (env-spec)
+ (prog (len (rslt t))
+ (if (not (listp env-spec)) (return nil))
+ (setf len (length env-spec))
+ (if (< len 6) (return nil))
+ (if (> len 7) (return nil))
+ (dolist (x env-spec)
+ (cond ((not (numberp x))
+ (setf rslt nil)
+ (return nil))))
+ (return rslt)))
+
+
+;; AMOSC
+;;
+(defun amosc (pitch modulation &optional (sound *table*) (phase 0.0))
+ (ny:typecheck (not (numberp pitch))
+ (ny:error "AMOSC" 1 '((STEP) "pitch") pitch))
+ (ny:typecheck (not (soundp modulation))
+ (ny:error "AMOSC" 2 '((SOUND) "modulation") modulation))
+ (ny:assert-table "AMOSC" 3 "table" sound)
+ (ny:typecheck (not (numberp phase))
+ (ny:error "AMOSC" 4 '((NUMBER) "phase") phase))
+ (let ((modulation-srate (snd-srate modulation))
+ (hz (calculate-hz pitch "amosc")))
+ (ny:scale-db (get-loud)
+ (snd-amosc
+ (car sound) ; samples for table
+ (cadr sound) ; step represented by table
+ *SOUND-SRATE* ; output sample rate
+ hz ; output hz
+ (local-to-global 0) ; starting time
+ modulation ; modulation
+ phase)))) ; phase
+
+
+;; FMOSC
+;;
+;; modulation rate must be less than or equal to sound-srate, so
+;; force resampling and issue a warning if necessary. snd-fmosc can
+;; handle upsampling cases internally.
+;;
+(defun fmosc (pitch modulation &optional (sound *table*) (phase 0.0))
+ (ny:typecheck (not (numberp pitch))
+ (ny:error "FMOSC" 1 '((STEP) "pitch") pitch))
+ (ny:typecheck (not (soundp modulation))
+ (ny:error "FMOSC" 2 '((SOUND) "modulation") modulation))
+ (ny:assert-table "FMOSC" 3 "table" sound)
+ (ny:typecheck (not (numberp phase))
+ (ny:error "FMOSC" 4 '((NUMBER) "phase") phase))
+ (let ((modulation-srate (snd-srate modulation))
+ (hz (calculate-hz pitch "fmosc")))
+ (ny:scale-db (get-loud)
+ (snd-fmosc
+ (car sound) ; samples for table
+ (cadr sound) ; step represented by table
+ *SOUND-SRATE* ; output sample rate
+ hz ; output hz
+ (local-to-global 0) ; starting time
+ modulation ; modulation
+ phase)))) ; phase
+
+
+;; FMFB
+;;
+;; this code is based on FMOSC above
+;;
+(defun fmfb (pitch index &optional (dur 1.0))
+ (ny:typecheck (not (numberp pitch))
+ (ny:error "FMFB" 1 '((STEP) "pitch") pitch))
+ (ny:typecheck (not (or (numberp index) (soundp index)))
+ (ny:error "FMFB" 2 '((NUMBER SOUND) "index") index))
+ (ny:typecheck (not (numberp dur))
+ (ny:error "FMFB" 3 '((NUMBER) "dur") dur))
+ (let ((hz (calculate-hz pitch "fmfb")))
+ (setf dur (get-duration dur))
+ (cond ((soundp index) (ny:fmfbv hz index))
+ (t
+ (ny:scale-db (get-loud)
+ (snd-fmfb (local-to-global 0)
+ hz *SOUND-SRATE* index dur))))))
+
+;; private variable index version of fmfb
+(defun ny:fmfbv (hz index)
+ (let ((modulation-srate (snd-srate index)))
+ (cond ((< *SOUND-SRATE* modulation-srate)
+ (format t "Warning: down-sampling FM modulation in fmfb~%")
+ (setf index (snd-down *SOUND-SRATE* index))))
+ (ny:scale-db (get-loud)
+ (snd-fmfbv (local-to-global 0) hz *SOUND-SRATE* index))))
+
+
+;; BUZZ
+;;
+;; (ARGUMENTS ("long" "n") ("rate_type" "sr") ("double" "hz")
+;; ("time_type" "t0") ("sound_type" "s_fm"))
+;;
+(defun buzz (n pitch modulation)
+ (ny:typecheck (not (integerp n))
+ (ny:error "BUZZ" 1 '((INTEGER) "number of harmonics") n))
+ (ny:typecheck (not (numberp pitch))
+ (ny:error "BUZZ" 2 '((STEP) "pitch") pitch))
+ (ny:typecheck (not (soundp modulation))
+ (ny:error "BUZZ" 3 '((SOUND) "modulation") modulation))
+ (let ((modulation-srate (snd-srate modulation))
+ (hz (calculate-hz pitch "buzz nominal")))
+ (cond ((< *SOUND-SRATE* modulation-srate)
+ (format t "Warning: down-sampling modulation in buzz~%")
+ (setf modulation (snd-down *SOUND-SRATE* modulation))))
+ (setf n (max n 1)) ; avoid divide by zero problem
+ (ny:scale-db (get-loud)
+ (snd-buzz n ; number of harmonics
+ *SOUND-SRATE* ; output sample rate
+ hz ; output hz
+ (local-to-global 0) ; starting time
+ modulation)))) ; freq. modulation
+
+
+;; (HZOSC hz [table [phase]])
+;;
+;; similar to FMOSC, but without "carrier" frequency parameter
+;; also, hz may be a scalar or a sound
+;;
+(defun hzosc (hz &optional (sound *table*) (phase 0.0))
+ (ny:typecheck (not (or (numberp hz) (soundp hz)))
+ (ny:error "HZOSC" 1 '((NUMBER SOUND) "hz") hz))
+ (ny:assert-table "HZOSC" 2 "table" sound)
+ (ny:typecheck (not (numberp phase))
+ (ny:error "HZOSC" 3 '((NUMBER) "phase") phase))
+ (let (hz-srate)
+ (cond ((numberp hz)
+ (osc (hz-to-step hz) 1.0 sound phase))
+ (t
+ (setf hz-srate (snd-srate hz))
+ (cond ((< *SOUND-SRATE* hz-srate)
+ (format t "Warning: down-sampling hz in hzosc~%")
+ (setf hz (snd-down *SOUND-SRATE* hz))))
+ (ny:scale-db (get-loud)
+ (snd-fmosc (car sound) ; samples for table
+ (cadr sound) ; step repr. by table
+ *SOUND-SRATE* ; output sample rate
+ 0.0 ; dummy carrier
+ (local-to-global 0) ; starting time
+ hz phase))))))
+
+
+;; (SIOSC-BREAKPOINTS tab0 t1 tab1 ... tn tabn)
+;; converts times to sample numbers
+;; NOTE: time-warping the spectral envelope seems
+;; like the wrong thing to do (wouldn't it be better
+;; to warp the parameters that control the spectra,
+;; or don't warp at all?). Nominally, a note should
+;; have a "score" or local time duration equal to the
+;; SUSTAIN environment variable. (When sustain is 1.0
+;; and no time-warping is in effect, the duration is 1).
+;; So, scale all times by
+;; (local-to-global (get-sustain))
+;; so that if the final time tn = 1.0, we get a nominal
+;; length note.
+
+(defun siosc-breakpoints (breakpoints)
+ (prog (sample-count result (last-count 0) time-factor (index 0))
+ (setf time-factor
+ (- (local-to-global (get-sustain))
+ (local-to-global 0.0)))
+ (setf time-factor (* time-factor *SOUND-SRATE*))
+ (ny:typecheck (not (and (listp breakpoints)
+ (cdr breakpoints)
+ (cddr breakpoints)))
+ (error "In SIOSC, 3rd argument (breakpoints) must be a list with at least 3 elements"
+ breakpoints))
+loop
+ (ny:typecheck (not (and (listp breakpoints)
+ (soundp (car breakpoints))))
+ (error (format nil
+ "In SIOSC, expected a sound in breakpoints list at index ~A"
+ index)
+ (car breakpoints)))
+ (push (car breakpoints) result)
+ (setf breakpoints (cdr breakpoints))
+ (setf index (1+ index))
+ (cond (breakpoints
+ (ny:typecheck (not (and (listp breakpoints)
+ (numberp (car breakpoints))))
+ (error (format nil
+ "In SIOSC, expected a number (time) in breakpoints list at index ~A"
+ index)
+ (car breakpoints)))
+ (setf sample-count (truncate
+ (+ 0.5 (* time-factor (car breakpoints)))))
+ (cond ((< sample-count last-count)
+ (setf sample-count (1+ last-count))))
+ (push sample-count result)
+ (setf last-count sample-count)
+ (setf breakpoints (cdr breakpoints))
+ (setf index (1+ index))
+ (cond (breakpoints
+ (go loop)))))
+ (setf result (reverse result))
+ (return result)))
+
+
+;; SIOSC -- spectral interpolation oscillator
+;;
+;; modulation rate must be less than or equal to sound-srate, so
+;; force resampling and issue a warning if necessary. snd-fmosc can
+;; handle upsampling cases internally.
+;;
+(defun siosc (pitch modulation breakpoints)
+ (ny:typecheck (not (numberp pitch))
+ (ny:error "SIOSC" 1 '((STEP) "pitch") pitch))
+ (ny:typecheck (not (soundp modulation))
+ (ny:error "SIOSC" 2 '((SOUND) "modulation") modulation))
+ (let ((modulation-srate (snd-srate modulation))
+ (hz (calculate-hz pitch "siosc nominal")))
+ (cond ((< *SOUND-SRATE* modulation-srate)
+ (format t "Warning: down-sampling FM modulation in siosc~%")
+ (setf modulation (snd-down *SOUND-SRATE* modulation))))
+ (ny:scale-db (get-loud)
+ (snd-siosc (siosc-breakpoints breakpoints) ; tables
+ *SOUND-SRATE* ; output sample rate
+ hz ; output hz
+ (local-to-global 0) ; starting time
+ modulation)))) ; modulation
+
+
+;; LFO -- freq &optional duration sound phase)
+;;
+;; Default duration is 1.0 sec, default sound is *TABLE*,
+;; default phase is 0.0.
+;;
+(defun lfo (freq &optional (duration 1.0)
+ (sound *SINE-TABLE*) (phase 0.0))
+ (ny:typecheck (not (numberp freq))
+ (ny:error "LFO" 1 '((NUMBER) "freq") freq))
+ (ny:typecheck (not (numberp duration))
+ (ny:error "LFO" 2 '((NUMBER) "duration") duration))
+ (ny:assert-table "LFO" 3 "table" sound)
+ (ny:typecheck (not (numberp phase))
+ (ny:error "LFO" 4 '((NUMBER) "phase") phase))
+ (let ((d (get-duration duration)))
+ (if (minusp d) (setf d 0))
+ (cond ((> freq (/ *CONTROL-SRATE* 2))
+ (format t "Warning: lfo frequency (~A hz) will alias at current control rate (~A hz).\n"
+ freq *CONTROL-SRATE*)))
+ (ny:set-logical-stop
+ (snd-osc
+ (car sound) ; samples for table
+ (cadr sound) ; step represented by table
+ *CONTROL-SRATE* ; output sample rate
+ freq ; output hz
+ *rslt* ; starting time
+ d ; duration
+ phase) ; phase
+ duration)))
+
+
+;; FMLFO -- like LFO but uses frequency modulation
+;;
+(defun fmlfo (freq &optional (sound *SINE-TABLE*) (phase 0.0))
+ (ny:typecheck (not (soundp freq))
+ (ny:error "FMLFO" 1 '((SOUND) "freq") freq))
+ (ny:assert-table "FMLFO" 2 "table" sound)
+ (ny:typecheck (not (numberp phase))
+ (ny:error "FMLFO" 3 '((NUMBER) "phase") phase))
+ (let ()
+ (cond ((numberp freq)
+ (lfo freq 1.0 sound phase))
+ ((soundp freq)
+ (cond ((> (snd-srate freq) *CONTROL-SRATE*)
+ (setf freq (force-srate *CONTROL-SRATE* freq))))
+ (snd-fmosc (car sound) (cadr sound) *CONTROL-SRATE* 0.0
+ (local-to-global 0) freq phase))
+ (t
+ (error "frequency must be a number or sound")))))
+
+
+;; OSC - table lookup oscillator
+;;
+(defun osc (pitch &optional (duration 1.0)
+ (sound *TABLE*) (phase 0.0))
+ (ny:typecheck (not (numberp pitch))
+ (ny:error "OSC" 1 '((STEP) "pitch") pitch))
+ (ny:typecheck (not (numberp duration))
+ (ny:error "OSC" 2 '((NUMBER) "duration") duration))
+ (ny:assert-table "OSC" 3 "table" sound)
+ (ny:typecheck (not (numberp phase))
+ (ny:error "OSC" 4 '((NUMBER) "phase") phase))
+ (let ((d (get-duration duration))
+ (hz (calculate-hz pitch "osc")))
+ (ny:set-logical-stop
+ (snd-scale (db-to-linear (get-loud))
+ (snd-osc
+ (car sound) ; samples for table
+ (cadr sound) ; step represented by table
+ *SOUND-SRATE* ; output sample rate
+ hz ; output hz
+ *rslt* ; starting time
+ d ; duration
+ phase)) ; phase
+ duration)))
+
+
+;; PARTIAL -- sine osc with built-in envelope scaling
+;;
+(defun partial (steps env)
+ (ny:typecheck (not (numberp steps))
+ (ny:error "PARTIAL" 1 '((STEP) "steps") steps))
+ (ny:typecheck (not (soundp env))
+ (ny:error "PARTIAL" 2 '((SOUND) "env") env))
+ (let ((hz (calculate-hz steps "partial")))
+ (ny:scale-db (get-loud)
+ (snd-partial *sound-srate* hz
+ (force-srate *sound-srate* env)))))
+
+
+(setf *SINE-SAMPLE* (list (first *TABLE*) (second *TABLE*) 0.0))
+
+
+;; SAMPLER -- simple attack + sustain sampler
+;;
+(defun sampler (pitch modulation
+ &optional (sample *SINE-SAMPLE*) (npoints 2))
+ (ny:typecheck (not (numberp pitch))
+ (ny:error "SAMPLER" 1 '((STEP) "pitch") pitch))
+ (ny:typecheck (not (soundp modulation))
+ (ny:error "SAMPLER" 2 '((SOUND) "modulation") modulation))
+ (ny:assert-sample "SAMPLER" 3 "table" sample)
+ (ny:typecheck (not (integerp npoints))
+ (ny:error "SAMPLER" 3 '((INTEGER) "npoints") npoints))
+ (let ((samp (car sample))
+ (samp-pitch (cadr sample))
+ (samp-loop-start (caddr sample))
+ (hz (calculate-hz pitch "sampler nominal")))
+ ; make a waveform table look like a sample with no attack:
+ (cond ((not (numberp samp-loop-start))
+ (setf samp-loop-start 0.0)))
+ (ny:scale-db (get-loud)
+ (snd-sampler
+ samp ; samples for table
+ samp-pitch ; step represented by table
+ samp-loop-start ; time to start loop
+ *SOUND-SRATE* ; output sample rate
+ hz ; output hz
+ (local-to-global 0) ; starting time
+ modulation ; modulation
+ npoints)))) ; number of interpolation points
+
+
+;; SINE -- simple sine oscillator
+;;
+(defun sine (steps &optional (duration 1.0))
+ (ny:typecheck (not (numberp steps))
+ (ny:error "SINE" 1 '((STEP) "steps") steps))
+ (ny:typecheck (not (numberp duration))
+ (ny:error "SINE" 2 '((NUMBER) "duration") duration))
+ (let ((hz (calculate-hz steps "sine"))
+ (d (get-duration duration)))
+ (ny:set-logical-stop
+ (ny:scale-db (get-loud)
+ (snd-sine *rslt* hz *sound-srate* d))
+ duration)))
+
+
+;; PLUCK
+;;
+;; (ARGUMENTS ("double" "sr") ("double" "hz") ("time_type" "t0")
+;; ("time_type" "d") ("double" "final_amp"))
+;;
+(defun pluck (steps &optional (duration 1.0) (final-amp 0.001))
+ (ny:typecheck (not (numberp steps))
+ (ny:error "PLUCK" 1 '((NUMBER) "steps") steps))
+ (ny:typecheck (not (numberp duration))
+ (ny:error "PLUCK" 2 '((NUMBER) "duration") duration))
+ (ny:typecheck (not (numberp final-amp))
+ (ny:error "PLUCK" 3 '((NUMBER) "final-amp") final-amp))
+ ;; 200000 is MAXLENGTH in nyquist/tran/pluck.alg - the max table length
+ (let ((hz (calculate-hz steps "pluck" (/ 1.0 3) 200000))
+ (d (get-duration duration)))
+ (ny:set-logical-stop
+ (ny:scale-db (get-loud)
+ (snd-pluck *SOUND-SRATE* hz *rslt* d final-amp))
+ duration)))
+
+
+;; abs-env -- restore the standard environment
+;;
+(defmacro abs-env (s)
+ `(progv '(*WARP* *LOUD* *TRANSPOSE* *SUSTAIN*
+ *START* *STOP*
+ *CONTROL-SRATE* *SOUND-SRATE*)
+ (list '(0.0 1.0 NIL) 0.0 0.0 1.0
+ MIN-START-TIME MAX-STOP-TIME
+ *DEFAULT-CONTROL-SRATE* *DEFAULT-SOUND-SRATE*)
+ ,s))
+
+
+;; (NYQ:TO-ARRAY SOUND N) - duplicate SOUND to N channels
+;
+(defun nyq:to-array (value len)
+ (let ((a (make-array len)))
+ (dotimes (i len)
+ (setf (aref a i) value))
+ a))
+
+
+; nyq:add2 - add two arguments.
+;
+; Assumes s1 and s2 are numbers, sounds, or multichannel sounds or numbers
+;
+; Semantics: numbers and sounds can be freely mixed and
+; add as expected. Arrays (multichannel) arguments are
+; added channel-by-channel, and if one array is larger,
+; the "extra" channels are simply copied to the result.
+; Therefore the result has the channel count of the
+; maximum channel count in s1 or s2. When adding a
+; multichannel sound to a (non-multichannel) sound, the
+; sound is coerced to a 1-channel multi-channel sound,
+; and therefore adds to channel 1 of the multi-channel
+; sound. However, when adding a multichannel sound to a
+; number, the number is added to *every* channel.
+; Semantics differ from the normal multichan-expand processing
+; in that sounds are considered to be a multichannel sound
+; with 1 channel, and channel counts do not have to match
+; when processing array arguments.
+;
+(defun nyq:add2 (s1 s2)
+ ; make number + number as fast as possible:
+ (cond ((and (numberp s1) (numberp s2)) (+ s1 s2))
+ ; if not 2 numbers, the overhead here is amortized by
+ ; computing samples of at least one sound
+ ((and (arrayp s1) (numberp s2))
+ (sum-of-arrays s1 (nyq:to-array s2 (length s1))))
+ ((and (arrayp s2) (numberp s1))
+ (sum-of-arrays (nyq:to-array s1 (length s2)) s2))
+ ((and (arrayp s1) (soundp s2))
+ (sum-of-arrays s1 (vector s2)))
+ ((and (arrayp s2) (soundp s1))
+ (sum-of-arrays (vector s1) s2))
+ ((and (arrayp s1) (arrayp s2))
+ (sum-of-arrays s1 s2))
+ ((numberp s1)
+ (snd-offset s2 s1))
+ ((numberp s2)
+ (snd-offset s1 s2))
+ (t
+ (nyq:add-2-sounds s1 s2))))
+
+
+; (NYQ:ADD-2-SOUNDS S1 S2) - add two sound arguments
+;
+; assumes s1 and s2 are sounds
+;
+(defun nyq:add-2-sounds (s1 s2)
+ (let ((s1sr (snd-srate s1))
+ (s2sr (snd-srate s2)))
+ (cond ((> s1sr s2sr)
+ (snd-add s1 (snd-up s1sr s2)))
+ ((< s1sr s2sr)
+ (snd-add (snd-up s2sr s1) s2))
+ (t
+ (snd-add s1 s2)))))
+
+
+(defmacro at (x s)
+ `(progv '(*WARP*)
+ (let ((shift ,x))
+ (ny:typecheck (not (numberp shift))
+ (error "1st argument of AT (or 2nd argument of SAL's @ operator) should be a time offset number" shift))
+ (list (list (+ (warp-time *WARP*)
+ (* (warp-stretch *WARP*) shift))
+ (warp-stretch *WARP*)
+ (warp-function *WARP*))))
+ ,s))
+
+
+;; (AT-ABS t behavior) evaluate behavior at global time t
+;;
+;; *WARP* is the triple (d s f) denoting the function f(st+d),
+;; a mapping from local to global time.
+;; We want (d' s f) such that f(s*0 + d') = t
+;; (Note that we keep the same s and f, and only change the offset.
+;; To eliminate the warp and stretch use "(abs-env (at t behavior))")
+;; Applying the inverse of f, d' = f-1(t), or (sref (snd-inverse f ...) t)
+;; Rather than invert the entire function just to evaluate at one point,
+;; we use SREF-INVERSE to find d'.
+;;
+(defmacro at-abs (x s)
+ `(progv '(*WARP*)
+ (let ((tim ,x))
+ (ny:typecheck (not (numberp tim))
+ (error "1st argument of AT-ABS (or 2nd argument of SAL's @@ operator) should be a number (start time)" tim))
+ (if (warp-function *WARP*)
+ (list (list (sref-inverse (warp-function *WARP*) tim)
+ (warp-stretch *WARP*)
+ (warp-function *WARP*)))
+ (list (list tim (warp-stretch *WARP*) NIL))))
+ ;; issue warning if sound starts in the past
+ (check-t0 ,s ',s)))
+
+
+(defun check-t0 (s src)
+ (let (flag t0 (now (local-to-global 0)))
+ (cond ((arrayp s)
+ (dotimes (i (length s))
+ (setf t0 (snd-t0 (aref s i))))
+ (if (< t0 now) (setf flag t0)))
+ (t
+ (setf t0 (snd-t0 s))
+ (if (< t0 now) (setf flag t0))))
+ (if flag
+ (format t "Warning: cannot go back in time to ~A, sound came from ~A~%"
+ flag src))
+ ; (display "check-t0" t0 now src)
+ ; return s whether or not warning was reported
+ s))
+
+;; (CLIP S1 VALUE) - clip maximum amplitude to value
+;
+(defun clip (x v)
+ (ny:typecheck (not (or (numberp x) (soundp x) (multichannelp x)))
+ (ny:error "CLIP" 1 number-sound-anon x t))
+ (ny:typecheck (not (numberp v))
+ (ny:error "CLIP" 2 number-anon v))
+ (cond ((numberp x)
+ (max (min x v) (- v)))
+ ((arrayp x)
+ (let* ((len (length x))
+ (result (make-array len)))
+ (dotimes (i len)
+ (setf (aref result i)
+ (snd-clip (aref x i) v)))
+ result))
+ (t ;; x is a sound
+ (snd-clip x v))))
+
+
+;; (NYQ:COERCE-TO S1 S2) - expand sound s1 to type of s2
+;
+(defun nyq:coerce-to (s1 s2)
+ (cond ((or (soundp s1) (numberp s1))
+ (cond ((arrayp s2)
+ (nyq:to-array s1 (length s2)))
+ (t s1)))
+ (t s1)))
+
+
+(defmacro continuous-control-warp (beh)
+ `(snd-compose (warp-abs nil ,beh)
+ (snd-inverse (get-warp)
+ (local-to-global 0) *control-srate*)))
+
+(defmacro continuous-sound-warp (beh)
+ `(snd-compose (warp-abs nil ,beh)
+ (snd-inverse (get-warp)
+ (local-to-global 0) *sound-srate*)))
+
+
+(defmacro control-srate-abs (r s)
+ `(let ((rate ,r))
+ (progv '(*CONTROL-SRATE*)
+ (progn (ny:typecheck (not (numberp rate))
+ (ny:error "CONTROL-SRATE-ABS" 1 '((NUMBER) "sample rate") rate))
+ (list rate))
+ ,s)))
+
+; db = 20log(ratio)
+; db = 20 ln(ratio)/ln(10)
+; db/20 = ln(ratio)/ln(10)
+; db ln(10)/20 = ln(ratio)
+; e^(db ln(10)/20) = ratio
+;
+(setf ln10over20 (/ (log 10.0) 20))
+
+(defun db-to-linear (x)
+ (ny:typecheck (not (or (numberp x) (soundp x) (multichannelp x)))
+ (ny:error "DB-TO-LINEAR" 0 number-sound-anon x t))
+ (cond ((numberp x)
+ (exp (* ln10over20 x)))
+ ((arrayp x)
+ (let* ((len (length x))
+ (result (make-array len)))
+ (dotimes (i len)
+ (setf (aref result i)
+ (snd-exp (snd-scale ln10over20 (aref x i)))))
+ result))
+ (t
+ (snd-exp (snd-scale ln10over20 x)))))
+
+
+(defun linear-to-db (x)
+ (ny:typecheck (not (or (numberp x) (soundp x) (multichannelp x)))
+ (ny:error "LINEAR-TO-DB" 0 number-sound-anon x t))
+ (cond ((numberp x)
+ (/ (log (float x)) ln10over20))
+ ((arrayp x)
+ (let* ((len (length x))
+ (result (make-array len)))
+ (dotimes (i len)
+ (setf (aref result i)
+ (snd-scale (/ 1.0 ln10over20) (snd-log (aref x i)))))
+ result))
+ (t
+ (snd-scale (/ 1.0 ln10over20) (snd-log x)))))
+
+
+(cond ((not (fboundp 'scalar-step-to-hz))
+ (setfn scalar-step-to-hz step-to-hz)
+ (setfn scalar-hz-to-step hz-to-step)))
+
+
+(defun step-to-hz (x)
+ (ny:typecheck (not (or (numberp x) (soundp x) (multichannelp x)))
+ (ny:error "STEP-TO-HZ" 0 number-sound-anon x t))
+ (cond ((numberp x)
+ (scalar-step-to-hz x))
+ ((arrayp x)
+ (let* ((len (length x))
+ (result (make-array len)))
+ (dotimes (i len)
+ (setf (aref result i) (step-to-hz (aref x i))))
+ result))
+ (t
+ (s-exp (snd-offset (snd-scale 0.0577622650466621 x)
+ 2.1011784386926213)))))
+
+(defun hz-to-step (x)
+ (ny:typecheck (not (or (numberp x) (soundp x) (multichannelp x)))
+ (ny:error "HZ-TO-STEP" 0 number-sound-anon x t))
+ (cond ((numberp x)
+ (scalar-hz-to-step x))
+ ((arrayp x)
+ (let* ((len (length x))
+ (result (make-array len)))
+ (dotimes (i len)
+ (setf (aref result i) (hz-to-step (aref x i))))
+ result))
+ (t
+ (snd-scale 17.312340490667565
+ (snd-offset (s-log x) -2.1011784386926213)))))
+
+
+; sref - access a sound at a given time point
+; note that the time is transformed to global
+(defun sref (sound point)
+ (ny:typecheck (not (soundp sound))
+ (ny:error "SREF" 1 '((SOUND) "sound") sound))
+ (ny:typecheck (not (numberp point))
+ (ny:error "SREF" 2 '((NUMBER) "time") point))
+ (snd-sref sound (local-to-global point)))
+
+
+; extract - start is stretched and shifted as is stop
+; result is shifted to start at local time zero
+(defun extract (start stop sound)
+ (ny:typecheck (not (numberp start))
+ (ny:error "EXTRACT" 1 '((NUMBER) "start") start))
+ (ny:typecheck (not (numberp stop))
+ (ny:error "EXTRACT" 2 '((NUMBER) "stop") stop))
+ (ny:typecheck (< stop start)
+ (error
+ (format nil "In EXTRACT, stop (~A) must be greater or equal to start (~A)"
+ stop start)))
+ (ny:typecheck (not (soundp sound))
+ (ny:error "EXTRACT" 3 '((SOUND) "sound") sound))
+ (extract-abs (local-to-global start) (local-to-global stop) sound
+ (local-to-global 0)))
+
+; extract-abs - return sound between start and stop
+; start-time is optional (to aid the implementation of
+; extract) and gives the start time of the result, normally 0.
+; There is a problem if sound t0 is not equal to start-time.
+; E.g. if sound was created with AT, its t0 might be
+; in the future, but snd-xform works by first shifting
+; t0 to local time zero, so we need to be very careful.
+; The solution is that if t0 > start_time, subtract the difference
+; from start and stop to shift them appropriately.
+(defun extract-abs (start stop sound &optional (start-time 0))
+ (ny:typecheck (not (numberp start))
+ (ny:error "EXTRACT-ABS" 1 '((NUMBER) "start") start))
+ (ny:typecheck (not (numberp stop))
+ (ny:error "EXTRACT-ABS" 2 '((NUMBER) "stop") stop))
+ (ny:typecheck (< stop start)
+ (error
+ (format nil
+ "In EXTRACT-ABS, stop (~A) must be greater or equal to start (~A)"
+ stop start)))
+ (ny:typecheck (not (soundp sound))
+ (ny:error "EXTRACT-ABS" 3 '((SOUND) "sound") sound))
+ (ny:typecheck (not (numberp start-time))
+ (ny:error "EXTRACT-ABS" 4 '((NUMBER) "start-time") start-time))
+ (let ((t0 (snd-t0 sound)) offset)
+ (cond ((/= t0 start-time)
+ (setf offset (- t0 start-time))
+ (setf start (- start offset))
+ (setf stop (- stop offset))))
+ (snd-xform sound (snd-srate sound) start-time start stop 1.0)))
+
+
+(defun local-to-global (local-time)
+ (ny:typecheck (not (numberp local-time))
+ (ny:error "LOCAL-TO-GLOBAL" 0 '((NUMBER) "local-time") local-time))
+ (let ((d (warp-time *WARP*))
+ (s (warp-stretch *WARP*))
+ (w (warp-function *WARP*))
+ global-time)
+ (setf global-time (+ (* s local-time) d))
+ (if w (snd-sref w global-time) global-time)))
+
+
+(defmacro loud (x s)
+ `(progv '(*LOUD*)
+ (let ((ld ,x))
+ (ny:typecheck (not (or (numberp ld) (soundp ld)))
+ (ny:error "LOUD" 1 number-sound-anon ld))
+ (list (sum *LOUD* ld)))
+ ,s))
+
+
+(defmacro loud-abs (x s)
+ `(progv '(*LOUD*)
+ (let ((ld ,x))
+ (ny:typecheck (not (or (numberp ld) (soundp ld)))
+ (ny:error "LOUD-ABS" 1 number-anon ld))
+ (list ld))
+ ,s))
+
+
+;(defun must-be-sound (x)
+; (cond ((soundp x) x)
+; (t
+; (error "SOUND type expected" x))))
+
+
+;; NY:SCALE-DB -- a "fast" scale-db: no typechecks and
+;; no multichannel expansion
+(defun ny:scale-db (factor sound)
+ (snd-scale (db-to-linear factor) sound))
+
+
+;; SCALE-DB -- same as scale, but argument is in db
+;;
+(defun scale-db (factor sound)
+; (ny:typecheck (not (or (numberp factor) (numbersp factor)))
+; (ny:error "SCALE-DB" 1 '((NUMBER) "dB") factor t))
+; (ny:typecheck (not (or (soundp sound) (multichannel-soundp sound)))
+; (ny:error "SCALE-DB" 2 '((SOUND) "sound") sound t))
+ (multichan-expand "SCALE-DB" #'ny:scale-db
+ '(((NUMBER) "factor") ((SOUND) "sound")) factor sound))
+
+
+
+(defun set-control-srate (rate)
+ (ny:typecheck (not (numberp rate))
+ (ny:error "SET-CONTROL-SRATE" 0 '((NUMBER) "rate") rate))
+ (setf *default-control-srate* (float rate))
+ (nyq:environment-init))
+
+(defun set-sound-srate (rate)
+ (ny:typecheck (not (numberp rate))
+ (ny:error "SET-SOUND-SRATE" 0 '((NUMBER) "rate") rate))
+ (setf *default-sound-srate* (float rate))
+ (nyq:environment-init))
+
+
+; s-plot -- compute and write n data points for plotting
+;
+; dur is how many seconds of sound to plot. If necessary, cut the
+; sample rate to allow plotting dur seconds
+; n is the number of points to plot. If there are more than n points,
+; cut the sample rate. If there are fewer than n samples, just
+; plot the points that exist.
+;
+(defun s-plot (snd &optional (dur 2.0) (n 1000))
+ (ny:typecheck (not (soundp snd))
+ (ny:error "S-PLOT (or PLOT command)" 1 '((SOUND) nil) snd))
+ (ny:typecheck (not (numberp dur))
+ (ny:error "S-PLOT (or PLOT command)" 2 '((NUMBER) "dur") dur))
+ (ny:typecheck (not (integerp n))
+ (ny:error "S-PLOT (or PLOT command)" 3 '((INTEGER) nil) n))
+
+ (prog* ((sr (snd-srate snd))
+ (t0 (snd-t0 snd))
+ (filename (soundfilename *default-plot-file*))
+ (s snd) ;; s is either snd or resampled copy of snd
+ (outf (open filename :direction :output)) ;; for plot data
+ (maximum -1000000.0) ;; maximum amplitude
+ (minimum 1000000.0) ;; minimum amplitude
+ actual-dur ;; is the actual-duration of snd
+ sample-count ;; is how many samples to get from s
+ period ;; is the period of samples to be plotted
+ truncation-flag ;; true if we didn't get whole sound
+ points) ;; is array of samples
+ ;; If we need more than n samples to get dur seconds, resample
+ (cond ((< n (* dur sr))
+ (setf s (force-srate (/ (float n) dur) snd))))
+ ;; Get samples from the signal
+ (setf points (snd-samples s (1+ n)))
+ ;; If we got fewer than n points, we can at least estimate the
+ ;; actual duration (we might not know exactly if we use a lowered
+ ;; sample rate). If the actual sample rate was lowered to avoid
+ ;; getting more than n samples, we can now raise the sample rate
+ ;; based on our estimate of the actual sample duration.
+ ;(display "test" (length points) n)
+ (cond ((< (length points) n)
+ ;; sound is shorter than dur, estimate actual length
+ (setf actual-dur (/ (length points) (snd-srate s)))
+ (setf sample-count (round (min n (* actual-dur sr))))
+ (cond ((< n (* actual-dur sr))
+ (setf s (force-srate (/ (float n) actual-dur) snd)))
+ (t ;; we can use original signal
+ (setf s snd)))
+ (setf points (snd-samples s sample-count))
+ ;; due to rounding, need to recalculate exact count
+ (setf sample-count (length points)))
+ ((= (length points) n)
+ (setf actual-dur dur)
+ (setf sample-count n))
+ (t ;; greater than n points, so we must have truncated sound
+ (setf actual-dur dur)
+ (setf sample-count n)
+ (setf truncation-flag t)))
+ ;; actual-dur is the duration of the plot
+ ;; sample-count is how many samples we have
+ (setf period (/ 1.0 (snd-srate s)))
+ (cond ((null outf)
+ (format t "s-plot: could not open ~A!~%" filename)
+ (return nil)))
+ (format t "s-plot: writing ~A ... ~%" filename)
+ (cond (truncation-flag
+ (format t " !!TRUNCATING SOUND TO ~As\n" actual-dur)))
+ (cond ((/= (snd-srate s) (snd-srate snd))
+ (format t " !!RESAMPLING SOUND FROM ~A to ~Ahz\n"
+ (snd-srate snd) (snd-srate s))))
+ (cond (truncation-flag
+ (format t " Plotting ~As, actual sound duration is greater\n"
+ actual-dur))
+ (t
+ (format t " Sound duration is ~As~%" actual-dur)))
+ (dotimes (i sample-count)
+ (setf maximum (max maximum (aref points i)))
+ (setf minimum (min minimum (aref points i)))
+ (format outf "~A ~A~%" (+ t0 (* i period)) (aref points i)))
+ (close outf)
+ (format t " Wrote ~A points from ~As to ~As~%"
+ sample-count t0 (+ t0 actual-dur))
+ (format t " Range of values ~A to ~A\n" minimum maximum)
+ (cond ((or (< minimum -1) (> maximum 1))
+ (format t " !!SIGNAL EXCEEDS +/-1~%")))))
+
+
+; run something like this to plot the points:
+; graph < points.dat | plot -Ttek
+
+(defmacro sound-srate-abs (r s)
+ `(progv '(*SOUND-SRATE*)
+ (let ((rate ,r))
+ (ny:typecheck (not (numberp rate))
+ (ny:error "SOUND-SRATE-ABS" 1 '((NUMBER) "sample rate") rate))
+ (list rate))
+ ,s))
+
+
+(defmacro stretch (x s)
+ `(progv '(*WARP*)
+ (let ((str ,x))
+ (ny:typecheck (not (numberp str))
+ (error "1st argument of STRETCH (or 2nd argument of SAL's ~ operator) should be a number (stretch factor)" str))
+ (list (list (warp-time *WARP*)
+ (* (warp-stretch *WARP*) str)
+ (warp-function *WARP*))))
+ (ny:typecheck (minusp (warp-stretch *WARP*))
+ (error "In STRETCH (or SAL's ~ operator), negative stretch factor is not allowed"
+ (warp-stretch *WARP*)))
+ ,s))
+
+
+(defmacro stretch-abs (x s)
+ `(progv '(*WARP*)
+ (let ((str ,x))
+ (ny:typecheck (not (numberp str))
+ (error "1st argument of STRETCH-ABS (or 2nd argument of SAL's ~~ operator) should be a number (stretch factor)" str))
+ (list (list (local-to-global 0) str nil)))
+ (ny:typecheck (minusp (warp-stretch *WARP*))
+ (error "In STRETCH-ABS (or SAL's ~~ operator), negative stretch factor is not allowed"
+ (warp-stretch *WARP*)))
+ ,s))
+
+
+(defmacro sustain (x s)
+ `(progv '(*SUSTAIN*)
+ (let ((sus ,x))
+ (ny:typecheck (not (or (numberp sus) (soundp sus)))
+ (ny:error "SUSTAIN" 1 number-sound-anon sus))
+ (list (prod *SUSTAIN* sus)))
+ ,s))
+
+
+(defmacro sustain-abs (x s)
+ `(progv '(*SUSTAIN*)
+ (let ((sus ,x))
+ (ny:typecheck (not (or (numberp sus) (soundp sus)))
+ (ny:error "SUSTAIN-ABS" 1 number-sound-anon sus))
+ (list sus))
+ ,s))
+
+
+;; (WARP-FUNCTION *WARP*) - extracts function field of warp triple
+;;
+(setfn warp-function caddr)
+
+
+;; (WARP-STRETCH *WARP*) - extracts stretch field of warp triple
+;;
+(setfn warp-stretch cadr)
+
+
+;; (WARP-TIME *WARP*) - extracts time field of warp triple
+;;
+(setfn warp-time car)
+
+
+(defmacro transpose (x s)
+ `(progv '(*TRANSPOSE*)
+ (let ((amt ,x))
+ (ny:typecheck (not (or (numberp amt) (soundp amt)))
+ (ny:error "TRANSPOSE" 1 number-sound-anon amt))
+ (list (sum *TRANSPOSE* amt)))
+ ,s))
+
+
+(defmacro transpose-abs (x s)
+ `(progv '(*TRANSPOSE*)
+ (let ((amt ,x))
+ (ny:typecheck (not (or (numberp amt) (soundp amt)))
+ (ny:error "TRANSPOSE-ABS" 1 number-anon amt))
+ (list amt))
+ ,s))
+
+
+;; CONTROL-WARP -- apply a warp function to a control function
+;;
+(defun control-warp (warp-fn control &optional wrate)
+ (ny:typecheck (not (soundp warp-fn))
+ (ny:error "CONTROL-WARP" 1 '((SOUND) "warp-fn") warp-fn))
+ (ny:typecheck (not (soundp control))
+ (ny:error "CONTROL-WARP" 2 '((SOUND) "control") control))
+ (cond (wrate
+ (ny:typecheck (not (numberp wrate))
+ (ny:error "CONTROL-WARP" 3 '((NUMBER) "wrate") wrate))
+ (snd-resamplev control *control-srate*
+ (snd-inverse warp-fn (local-to-global 0) wrate)))
+ (t
+ (snd-compose control
+ (snd-inverse warp-fn (local-to-global 0) *control-srate*)))))
+
+
+;; (cue sound)
+;; Cues the given sound; that is, it applies the current *WARP*, *LOUD*,
+;; *START*, and *STOP* values to the argument. The logical start time is at
+;; local time 0.
+(defun cue (sound)
+ (ny:typecheck (not (or (soundp sound) (multichannel-soundp sound)))
+ (ny:error "CUE" 0 '((SOUND) nil) sound t))
+ (cond ((arrayp sound)
+ (let* ((len (length sound))
+ (result (make-array len)))
+ (dotimes (i len)
+ (setf (aref result i)
+ (cue-sound (aref sound i))))
+ result))
+ (t
+ (cue-sound sound))))
+
+(defun cue-sound (sound)
+ (snd-xform sound
+ (snd-srate sound)
+ (local-to-global 0) *START* *STOP* (db-to-linear (get-loud))))
+
+;; (sound sound)
+;; Same as (cue sound), except also warps the sound.
+;; Note that the *WARP* can change the pitch of the
+;; sound as a result of resampling.
+;; Here's the derivation for the warping code:
+;; *WARP* is a triple: (d s f) which denotes that the warp from local to
+;; global time is: f(st+d)
+;; We need to compose sound with the inverse of this to get a function
+;; of global time
+;; Let f-1 be the inverse of f. Then the inverse of f(st+d) is
+;; (f-1(t) - d)/s
+;; The composition gives us: (snd-compose sound (f-1(t) - d)/s)
+;; Eliminate the 1/s term by changing the sample rate of sound:
+;; = (snd-compose (snd-scale-srate sound s) (f-1(t) - d))
+;; Eliminate the -d term by shifting f before taking the inverse:
+;; = (snd-compose (scale-srate sound s) ((inverse f) - d))
+;; = (snd-compose (scale-srate sound s) (inverse f(t + d)))
+;; = (snd-compose (scale-srate sound s) (inverse (shift f -d)))
+;; snd-inverse takes a time and sample rate. For time, use zero.
+;; The sample rate of inverse determines the final sample rate of
+;; this function, so use *SOUND-SRATE*:
+;; = (snd-compose (scale-srate sound s) (snd-inverse (shift-time f (- d))
+;; 0 *SOUND-SRATE*))
+;;
+(defun nyq:sound (sound)
+ (cond ((null (warp-function *WARP*))
+ (snd-xform sound (/ (snd-srate sound) (warp-stretch *WARP*))
+ (local-to-global 0)
+ *START* *STOP* (db-to-linear (get-loud))))
+ (t
+ (snd-compose (scale-srate sound (warp-stretch *WARP*))
+ (snd-inverse (shift-time (warp-function *WARP*)
+ (- (warp-time *WARP*)))
+ 0 *SOUND-SRATE*)))))
+
+(defun nyq:sound-of-array (sound)
+ (let* ((n (length sound))
+ (s (make-array n)))
+ (dotimes (i n)
+ (setf (aref s i) (nyq:sound (aref sound i))))
+ s))
+
+
+(defun sound (sound)
+ (ny:typecheck (not (or (soundp sound) (multichannel-soundp sound)))
+ (ny:error "SOUND" 0 '((SOUND) nil) sound t))
+ (cond ((arrayp sound)
+ (nyq:sound-of-array sound))
+ (t
+ (nyq:sound sound))))
+
+
+;; (SCALE-SRATE SOUND SCALE)
+;; multiplies the sample rate by scale
+(defun scale-srate (sound scale)
+ (ny:typecheck (not (soundp sound))
+ (ny:error "SCALE-SRATE" 1 '((SOUND) "sound") sound))
+ (ny:typecheck (not (numberp scale))
+ (ny:error "SCALE-SRATE" 2 '((NUMBER) "scale") scale))
+ (let ((new-srate (* scale (snd-srate sound))))
+ (snd-xform sound new-srate (snd-time sound)
+ MIN-START-TIME MAX-STOP-TIME 1.0)))
+
+
+;; (SHIFT-TIME SOUND SHIFT)
+;; shift the time of a function by SHIFT, i.e. if SOUND is f(t),
+;; then (shift-time SOUND SHIFT) is f(t - SHIFT). Note that if
+;; you look at plots, the shifted sound will move *right* when SHIFT
+;; is positive.
+(defun shift-time (sound shift)
+ (ny:typecheck (not (soundp sound))
+ (ny:error "SHIFT-TIME" 1 '((SOUND) "sound") sound))
+ (ny:typecheck (not (numberp shift))
+ (ny:error "SHIFT-TIME" 2 '((NUMBER) "shift") shift))
+ (snd-xform sound (snd-srate sound) (+ (snd-t0 sound) shift)
+ MIN-START-TIME MAX-STOP-TIME 1.0))
+
+
+;; (control sound)
+;; Same as (sound sound), except this is used for control signals.
+;; This code is identical to sound.
+(defun control (sound)
+ (ny:typecheck (not (or (soundp sound) (multichannel-soundp sound)))
+ (ny:error "CONTROL" 0 '((SOUND) nil) sound t))
+ (cond ((arrayp sound)
+ (nyq:sound-of-array sound))
+ (t
+ (nyq:sound sound))))
+
+
+;; (cue-file string)
+;; Loads a sound file with the given name, returning a sound which is
+;; transformed to the current environment.
+(defun cue-file (name)
+ (ny:typecheck (not (stringp name))
+ (ny:error "CUE-FILE" 0 '((STRING) "name") name))
+ (cue (force-srate *SOUND-SRATE* (s-read name))))
+
+
+;; (env t1 t2 t4 l1 l2 l3 &optional duration)
+;; Creates a 4-phase envelope.
+;; tN is the duration of phase N, and lN is the final level of
+;; phase N. t3 is implied by the duration, and l4 is 0.0.
+;; If dur is not supplied, then 1.0 is assumed. The envelope
+;; duration is the product of dur, *STRETCH*, and *SUSTAIN*. If
+;; t1 + t2 + 2ms + t4 > duration, then a two-phase envelope is
+;; substituted that has an attack/release time ratio = t1/t4.
+;; The sample rate of the returned sound is *CONTROL-SRATE*.
+;;
+;; Time transformation: the envelope is not warped; the start time and
+;; stop times are warped to global time. Then the value of *SUSTAIN* at
+;; the beginning of the envelope is used to determining absolute duration.
+;; Since PWL is ultimately called to create the envelope, we must use
+;; ABS-ENV to prevent any further transforms inside PWL. We use
+;; (AT global-start ...) inside ABS-ENV so that the final result has
+;; the proper starting time.
+;;
+(defun env (t1 t2 t4 l1 l2 l3 &optional (duration 1.0))
+ (ny:typecheck (not (and (numberp t1) (numberp t2) (numberp t4)
+ (numberp l1) (numberp l2) (numberp l3)))
+ (error "In ENV, expected 6 numbers (t1, t2, t4, l1, l2, l3)"
+ (list t1 t2 t4 l1 l2 l3)))
+ (ny:typecheck (not (numberp duration))
+ (ny:error "ENV" 7 '((NUMBER) "duration") duration))
+ (let (actual-dur min-dur ratio t3
+ (actual-dur (get-duration duration)))
+ (setf min-dur (+ t1 t2 t4 0.002))
+ (cond ((< actual-dur min-dur)
+ (setf ratio (/ t1 (float (+ t1 t4))))
+ (setf t1 (* ratio actual-dur))
+ (setf t2 (- actual-dur t1))
+ (setf t3 0.0)
+ (setf t4 0.0)
+ (setf l2 0.0)
+ (setf l3 0.0))
+ (t
+ (setf t3 (- actual-dur t1 t2 t4))))
+ (ny:set-logical-stop
+ (abs-env (at *rslt*
+ (pwl t1 l1 (+ t1 t2) l2 (- actual-dur t4) l3 actual-dur)))
+ duration)))
+
+
+(defun to-mono (sound)
+ (ny:typecheck (not (or (soundp sound) (multichannel-soundp sound)))
+ (ny:error "TO-MONO" 1 '((SOUND) NIL) sound t))
+ (let ((s sound))
+ (cond ((arrayp sound)
+ (setf s (aref sound 0)) ;; ANY channel opens the gate
+ (dotimes (i (1- (length sound)))
+ (setf s (nyq:add-2-sounds s (aref sound (1+ i)))))))
+ s))
+
+
+(defun gate (sound lookahead risetime falltime floor threshold
+ &optional (source "GATE"))
+ ;(ny:typecheck (not (soundp sound))
+ (ny:typecheck (not (or (soundp sound) (multichannel-soundp sound)))
+ (ny:error source 1 '((SOUND) "sound") sound t))
+ (ny:typecheck (not (numberp lookahead))
+ (ny:error source 2 '((NUMBER) "lookahead") lookahead))
+ (ny:typecheck (not (numberp risetime))
+ (ny:error source 3 '((NUMBER) "risetime") risetime))
+ (ny:typecheck (not (numberp falltime))
+ (ny:error source 4 '((NUMBER) "falltime") falltime))
+ (ny:typecheck (not (numberp floor))
+ (ny:error source 5 '((NUMBER) "floor") floor))
+ (ny:typecheck (not (numberp threshold))
+ (ny:error source 6 '((NUMBER) "threshold") threshold))
+ (cond ((< lookahead risetime)
+ (format t "WARNING: lookahead (~A) ~A (~A) in ~A ~A ~A.\n"
+ lookahead "must be greater than risetime" risetime
+ source "function; setting lookahead to" risetime)
+ (setf lookahead risetime)))
+ (cond ((< risetime 0)
+ (format t "WARNING: risetime (~A) ~A ~A ~A\n" risetime
+ "must be greater than zero in" source
+ "function; setting risetime to 0.01.")
+ (setf risetime 0.01)))
+ (cond ((< falltime 0)
+ (format t "WARNING: ~A ~A function; setting falltime to 0.01.\n"
+ "falltime must be greater than zero in" source)
+ (setf falltime 0.01)))
+ (cond ((< floor 0.00001)
+ (format t "WARNING: ~A ~A function; setting floor to 0.00001.\n"
+ "floor must be greater than zero in" source)
+ (setf floor 0.00001)))
+ (let (s) ;; s becomes sound after collapsing to one channel
+ (cond ((arrayp sound) ;; use s-max over all channels so that
+ (setf s (aref sound 0)) ;; ANY channel opens the gate
+ (dotimes (i (1- (length sound)))
+ (setf s (s-max s (aref sound (1+ i))))))
+ (t (setf s sound)))
+ (setf s (snd-gate (seq (cue s)
+ (stretch-abs 1.0 (s-rest lookahead)))
+ lookahead risetime falltime floor threshold))
+ ;; snd-gate delays everything by lookahead, so this will slide the sound
+ ;; earlier by lookahead and delete the first lookahead samples
+ (prog1 (snd-xform s (snd-srate s) (snd-t0 s)
+ (+ (snd-t0 s) lookahead) MAX-STOP-TIME 1.0)
+ ;; This is *really* tricky. Normally, we would return now and
+ ;; the GC would free s and sound which are local variables. The
+ ;; only references to the sounds once stored in s and sound are
+ ;; lazy unit generators that will free samples almost as soon as
+ ;; they are computed, so no samples will accumulate. But wait! The
+ ;; 2nd SEQ expression with S-REST can reference s and sound because
+ ;; (due to macro magic) a closure is constructed to hold them until
+ ;; the 2nd SEQ expression is evaluated. It's almost as though s and
+ ;; sound are back to being global variables. Since the closure does
+ ;; not actually use either s or sound, we can clear them (we are
+ ;; still in the same environment as the closures packed inside SEQ,
+ ;; so s and sound here are still the same variables as the ones in
+ ;; the closure. Note that the other uses of s and sound already made
+ ;; copies of the sounds, and s and sound are merely references to
+ ;; them -- setting to nil will not alter the immutable lazy sound
+ ;; we are returning. Whew!
+ (setf s nil) (setf sound nil))))
+
+
+;; (osc-note step &optional duration env sust volume sound)
+;; Creates a note using table-lookup osc, but with an envelope.
+;; The ENV parameter may be a parameter list for the env function,
+;; or it may be a sound.
+;;
+(defun osc-note (pitch &optional (duration 1.0)
+ (env-spec '(0.02 0.1 0.3 1.0 .8 .7))
+ (volume 0.0)
+ (table *TABLE*))
+ (ny:typecheck (not (numberp pitch))
+ (ny:error "OSC-NOTE" 1 '((STEP) "pitch") pitch))
+ (ny:typecheck (not (numberp duration))
+ (ny:error "OSC-NOTE" 2 '((NUMBER) "duration") duration))
+ (ny:assert-env-spec env-spec
+ "In OSCNOTE, 3rd argument (env-spec) must be a list of 6 or 7 numbers to pass as arguments to ENV")
+ (ny:typecheck (not (numberp volume))
+ (ny:error "OSC-NOTE" 4 '((NUMBER) "volume") volume))
+ (ny:assert-table "OSC-NOTE" 5 "table" table)
+
+ (ny:set-logical-stop
+ (mult (loud volume (osc pitch duration table))
+ (if (listp env-spec)
+ (apply 'env env-spec)
+ env-spec))
+ duration))
+
+
+;; force-srate -- resample snd if necessary to get sample rate
+;
+(defun force-srate (sr snd)
+ (ny:typecheck (not (numberp sr))
+ (ny:error "FORCE-SRATE" 1 '((NUMBER) "sr") sr))
+ (ny:typecheck (not (or (soundp snd) (multichannel-soundp snd)))
+ (ny:error "FORCE-SRATE" 2 '((SOUND) "snd") snd t))
+ (cond ((arrayp snd)
+ (let* ((len (length snd))
+ (result (make-array len)))
+ (dotimes (i len)
+ (setf (aref result i)
+ (force-srate sr (aref snd i))))
+ result))
+ (t
+ (let ((snd-sr (snd-srate snd)))
+ (cond ((> sr snd-sr) (snd-up sr snd))
+ ((< sr snd-sr) (snd-down sr snd))
+ (t snd))))))
+
+
+(defun force-srates (srs snd)
+ (cond ((and (numberp srs) (soundp snd))
+ (force-srate srs snd))
+ ((and (arrayp srs) (arrayp snd))
+ (let* ((len (length snd))
+ (result (make-array len)))
+ (dotimes (i len)
+ (setf (aref result i)
+ (force-srate (aref srs i) (aref snd i))))
+ result))
+ (t (error (format nil "In force-srates: arguments not compatible. srs is ~A, snd is ~A. Perhaps you are constructing a sequence using both mono and multi-channel sounds."
+ (type-of srs) (type-of snd))))))
+
+
+;; (breakpoints-convert (t1 x1 t2 x2 ... tn) t0)
+;; converts times to sample numbers and scales amplitudes
+;; t0 is the global (after warping) start time
+;;
+;; input list is one or more numbers
+;; result is abs-sample-count, val, abs-sample-count, val, ...
+;; if the list length is odd, the result length is odd, and
+;; snd-pwl treats it as if a final value of zero was appended
+;;
+;; NOTE: there were some stack overflow problems with the original
+;; recursive version (in comments now), so it was rewritten as an
+;; iteration.
+;;
+(defun breakpoints-convert (list t0 source)
+ (prog (sample-count result sust (last-count 0))
+ (setf sust (get-sustain))
+ (ny:typecheck (not (consp list))
+ (error (format nil "In ~A, expected a list of numbers" source) list))
+ loop
+ (ny:typecheck (not (numberp (car list)))
+ (error (format nil "In ~A, expected only numbers in breakpoint list, got ~A"
+ source (car list))))
+ (setf sample-count
+ (truncate (+ 0.5 (* (- (local-to-global (* (car list) sust)) t0)
+ *control-srate*))))
+ ; now we have a new sample count to put into result list
+ ; make sure result is non-decreasing
+ (cond ((< sample-count last-count)
+ (setf sample-count last-count)))
+ (setf last-count sample-count)
+ (push sample-count result)
+ (cond ((cdr list)
+ (setf list (cdr list))
+ (ny:typecheck (not (numberp (car list)))
+ (error (format nil "In ~A, expected only numbers in breakpoint list" source)
+ (car list)))
+ (push (float (car list)) result)))
+ (setf list (cdr list))
+ (cond (list
+ (go loop)))
+ (return (reverse result))))
+
+
+;; (pwl t1 l1 t2 l2 ... tn)
+;; Creates a piece-wise linear envelope from breakpoint data.
+;;
+(defun pwl (&rest breakpoints) (pwl-list breakpoints "PWL"))
+
+(defun pwlr (&rest breakpoints) (pwlr-list breakpoints "PWLR"))
+
+;; BREAKPOINTS-RELATIVE list source
+;; converts list, which has the form (value dur value dur value ...)
+;; into the form (value time value time value ...)
+;; the list may have an even or odd length
+;;
+(defun breakpoints-relative (breakpoints source)
+ (prog (result (sum 0.0))
+ (ny:typecheck (not (consp breakpoints))
+ (error (format nil "In ~A, expected list of numbers, got ~A"
+ source breakpoints)))
+ loop
+ (ny:typecheck (not (numberp (car breakpoints)))
+ (error (format nil
+ "In ~A, expected only numbers in breakpoints list, got ~A"
+ source (car breakpoints))))
+ (setf sum (+ sum (car breakpoints)))
+ (push sum result)
+ (cond ((cdr breakpoints)
+ (setf breakpoints (cdr breakpoints))
+ (ny:typecheck (not (numberp (car breakpoints)))
+ (error (format nil
+ "In ~A, expected only numbers in breakpoints list, got ~A"
+ source (car breakpoints))))
+ (push (car breakpoints) result)))
+ (setf breakpoints (cdr breakpoints))
+ (cond (breakpoints
+ (go loop)))
+ (return (reverse result))))
+
+
+(defun pwlr-list (breakpoints &optional (source "PWLR-LIST"))
+ (pwl-list (breakpoints-relative breakpoints source) source))
+
+(defun pwl-list (breakpoints &optional (source "PWL-LIST"))
+ (let ((t0 (local-to-global 0)))
+ (snd-pwl t0 *control-srate* (breakpoints-convert breakpoints t0 source))))
+
+;; (pwlv l1 t1 l2 t2 ... ln)
+;; Creates a piece-wise linear envelope from breakpoint data;
+;; the function initial and final values are explicit
+;;
+(defun pwlv (&rest breakpoints)
+ ;use pwl, modify breakpoints with initial and final changes
+ ;need to put initial time of 0, and final time of 0
+ (pwlv-list breakpoints "PWLV"))
+
+(defun pwlv-list (breakpoints &optional (source "PWLV-LIST"))
+ (ny:typecheck (not (consp breakpoints))
+ (error (format nil "In ~A, expected list of numbers, got ~A"
+ source breakpoints)))
+ (pwl-list (cons 0.0 breakpoints) source))
+
+(defun pwlvr (&rest breakpoints) (pwlvr-list breakpoints "PWLVR"))
+
+(defun pwlvr-list (breakpoints &optional (source "PWLVR-LIST"))
+ (ny:typecheck (not (consp breakpoints))
+ (error (format nil "In ~A, expected list of numbers, got ~A"
+ source breakpoints)))
+ (pwlr-list (cons 0.0 breakpoints) source))
+
+(defun pwe (&rest breakpoints)
+ (pwe-list breakpoints "PWE"))
+
+(defun pwe-list (breakpoints &optional (source "PWE-LIST"))
+ (ny:typecheck (not (consp breakpoints))
+ (error (format nil "In ~A, expected list of numbers, got ~A"
+ source breakpoints)))
+ (pwev-list (cons 1.0 breakpoints) source))
+
+(defun pwer (&rest breakpoints)
+ (pwer-list breakpoints "PWER"))
+
+(defun pwer-list (breakpoints &optional (source "PWER-LIST"))
+ (pwe-list (breakpoints-relative breakpoints source) source))
+
+(defun pwev (&rest breakpoints)
+ (pwev-list breakpoints "PWEV"))
+
+(defun pwev-list (breakpoints &optional (source "PWEV-LIST"))
+ (let ((lis (breakpoints-log breakpoints source)))
+ (s-exp (pwl-list lis))))
+
+(defun pwevr (&rest breakpoints) (pwevr-list breakpoints "PWEVR"))
+
+(defun pwevr-list (breakpoints &optional (source "PWEVR-LIST"))
+ (ny:typecheck (not (consp breakpoints))
+ (error (format nil "In ~A, expected list of numbers, got ~A"
+ source breakpoints)))
+ (pwev-list (cdr (breakpoints-relative (cons 0.0 breakpoints) source)) source))
+
+
+;; input is 2 or more numbers representing val, time, val, time, ...
+;; output is odd number of 1 or more numbers representing
+;; time, val, time, val, ..., time
+;;
+;;
+(defun breakpoints-log (breakpoints source)
+ (prog ((result '(0.0)) val tim)
+loop
+ (ny:typecheck (not (consp breakpoints))
+ (error (format nil "In ~A, expected list of numbers, got ~A"
+ source breakpoints)))
+ (ny:typecheck (not (numberp (car breakpoints)))
+ (error (format nil "In ~A, expected number in breakpoint list, got ~A"
+ source (car breakpoints))))
+
+ (setf val (float (car breakpoints)))
+ (setf breakpoints (cdr breakpoints))
+
+ (cond (breakpoints
+ (ny:typecheck (not (consp breakpoints))
+ (error (format nil "In ~A, expected list of numbers, got ~A"
+ source (car breakpoints))))
+ (setf tim (car breakpoints))
+ (setf breakpoints (cdr breakpoints))
+ (ny:typecheck (not (numberp tim))
+ (error (format nil "In ~A, expected number in breakpoint list, got ~A"
+ source tim)))))
+
+ (setf result (cons tim (cons (log val) result)))
+ (cond ((null breakpoints)
+ (return (reverse result))))
+ (go loop)))
+
+
+;; SOUND-WARP -- apply warp function to a sound
+;;
+(defun sound-warp (warp-fn signal &optional wrate)
+ (ny:typecheck (not (soundp warp-fn))
+ (ny:error "SOUND-WARP" 1 '((SOUND) "warp-fn") warp-fn))
+ (ny:typecheck (not (soundp signal))
+ (ny:error "SOUND-WARP" 2 '((SOUND) "signal") signal))
+ (cond (wrate
+ (ny:typecheck (not (numberp wrate))
+ (ny:error "SOUND-WARP" 3 '((NUMBER) "wrate") wrate))
+ (snd-resamplev signal *sound-srate*
+ (snd-inverse warp-fn (local-to-global 0) wrate)))
+ (t
+ (snd-compose signal
+ (snd-inverse warp-fn (local-to-global 0) *sound-srate*)))))
+
+(defun snd-extent (sound maxsamples)
+ (ny:typecheck (not (soundp sound))
+ (ny:error "SND-EXTENT" 1 '((SOUND) "sound") sound))
+ (ny:typecheck (not (integerp maxsamples))
+ (ny:error "SND-EXTENT" 2 '((INTEGER) "maxsamples") maxsamples))
+ (list (snd-t0 sound)
+ (+ (snd-t0 sound) (/ (snd-length sound maxsamples)
+ (snd-srate sound)))))
+
+(setfn snd-flatten snd-length)
+
+;; (maketable sound)
+;; Creates a table for osc, lfo, etc. by assuming that the samples
+;; in sound represent one period. The sound must start at time 0.
+
+(defun maketable (sound)
+ (ny:typecheck (not (soundp sound))
+ (ny:error "MAKETABLE" 0 '((SOUND) nil) sound))
+ (list sound
+ (hz-to-step
+ (/ 1.0
+ (cadr (snd-extent sound 1000000))))
+ T))
+
+
+; simple stereo pan: as where goes from 0 to 1, sound
+; is linearly panned from left to right
+;
+(defun pan (sound where)
+ (ny:typecheck (not (soundp sound))
+ (ny:error "PAN" 1 '((SOUND) "sound") sound))
+ (ny:typecheck (not (or (soundp where) (numberp where)))
+ (ny:error "PAN" 2 '((NUMBER SOUND) "where") where))
+ (vector (mult sound (sum 1 (mult -1 where)))
+ (mult sound where)))
+
+
+(setf prod-source "PROD (or * in SAL)")
+
+(defun prod (&rest snds)
+ (cond ((null snds)
+ (snd-zero (local-to-global 0) *sound-srate*))
+ ((null (cdr snds))
+ (car snds))
+ ((null (cddr snds))
+ (nyq:prod2 (car snds) (cadr snds) prod-source))
+ (t
+ (nyq:prod2 (car snds) (apply #'prod (cdr snds)) prod-source))))
+
+(setfn mult prod)
+
+
+;; (NYQ:PROD-OF-ARRAYS S1 S2) - form pairwise products
+;
+(defun nyq:prod-of-arrays (s1 s2 source)
+ (let* ((n (length s1))
+ (p (make-array n)))
+ (ny:typecheck (/= n (length s2))
+ (error (strcat "In " source ", unequal number of channels, got "
+ (param-to-string s1) " and " (param-to-string s2))))
+ (dotimes (i n)
+ (setf (aref p i) (nyq:prod2 (aref s1 i) (aref s2 i) source)))
+ p))
+
+
+; nyq:prod2 - multiply two arguments
+;
+(defun nyq:prod2 (s1 s2 source)
+ (setf s1 (nyq:coerce-to s1 s2))
+ (setf s2 (nyq:coerce-to s2 s1))
+ (cond ((arrayp s1)
+ (nyq:prod-of-arrays s1 s2 source))
+ (t
+ (nyq:prod-2-sounds s1 s2 source))))
+
+
+; (PROD-2-SOUNDS S1 S2) - multiply two sound arguments
+;
+(defun nyq:prod-2-sounds (s1 s2 source)
+ (cond ((numberp s1)
+ (cond ((numberp s2)
+ (* s1 s2))
+ ((soundp s2)
+ (snd-scale s1 s2))
+ (t
+ (ny:error source 0 number-sound-anon s2 t))))
+ ((numberp s2)
+ (ny:typecheck (not (soundp s1))
+ (ny:error source 0 number-sound-anon s1 t))
+ (snd-scale s2 s1))
+ ((and (soundp s1) (soundp s2))
+ (snd-prod s1 s2))
+ ((soundp s1)
+ (ny:error source 0 number-sound-anon s2 t))
+ (t
+ (ny:error source 0 number-sound-anon s1 t))))
+
+
+;; RAMP -- linear ramp from 0 to x
+;;
+(defun ramp (&optional (x 1))
+ (ny:typecheck (not (numberp x))
+ (ny:error "RAMP" 0 number-anon x))
+ (let* ((duration (get-duration x)))
+ (ny:set-logical-stop
+ (warp-abs nil
+ (at *rslt*
+ (sustain-abs 1
+ (pwl duration 1 (+ duration (/ *control-srate*))))))
+ x)))
+
+
+(defun resample (snd rate)
+ (ny:typecheck (not (or (soundp snd) (multichannel-soundp snd)))
+ (ny:error "RESAMPLE" 1 '((SOUND) nil) snd t))
+ (ny:typecheck (not (numberp rate))
+ (ny:error "RESAMPLE" 2 '((NUMBER) "rate") rate))
+ (cond ((arrayp snd)
+ (let* ((len (length snd))
+ (result (make-array len)))
+ (dotimes (i len)
+ (setf (aref result i)
+ (snd-resample (aref snd i) rate)))
+ result))
+ (t
+ (snd-resample snd rate))))
+
+
+(defun scale (amt snd)
+ (multichan-expand "SCALE" #'snd-scale
+ '(((NUMBER) "amt") ((SOUND) "snd")) amt snd))
+
+
+(setfn s-print-tree snd-print-tree)
+
+
+;; (PEAK sound-expression number-of-samples) - find peak amplitude
+;
+; NOTE: this used to be called s-max
+; It is tempting to try using multichan-expand here to get peaks
+; from multichannel sounds, but at this point the argument is just
+; an expression, so we cannot tell if it is multichannel. We could
+; evaluate the expression, but then we'd have a local binding and
+; would retain samples in memory if we called snd-max on each channel.
+;
+(defmacro peak (expression maxlen)
+ `(snd-max ',expression ,maxlen))
+
+
+;; (S-MAX S1 S2) - return maximum of S1, S2
+;
+(defun s-max (s1 s2)
+ (setf s1 (nyq:coerce-to s1 s2))
+ (setf s2 (nyq:coerce-to s2 s1))
+ (cond ((arrayp s1)
+ (nyq:max-of-arrays s1 s2))
+ (t
+ (nyq:max-2-sounds s1 s2))))
+
+(defun nyq:max-of-arrays (s1 s2)
+ (let* ((n (length s1))
+ (p (make-array n)))
+ (ny:typecheck (/= n (length s2))
+ (error (strcat "In S-MAX, unequal number of channels, got "
+ (param-to-string s1) " and " (param-to-string s2))))
+ (dotimes (i n)
+ (setf (aref p i) (s-max (aref s1 i) (aref s2 i))))
+ p))
+
+(defun nyq:max-2-sounds (s1 s2)
+ (cond ((numberp s1)
+ (cond ((numberp s2)
+ (max s1 s2))
+ ((soundp s2)
+ (snd-maxv s2
+ (snd-const s1 (local-to-global 0.0)
+ (snd-srate s2) (get-duration 1.0))))
+ (t
+ (ny:error "S-MAX" 2 number-sound-anon s2 t))))
+ ((numberp s2)
+ (ny:typecheck (not (soundp s1))
+ (ny:error "S-MAX" 2 number-sound-anon s2 t))
+ (snd-maxv s1 (snd-const s2 (local-to-global 0.0)
+ (snd-srate s1) (get-duration 1.0))))
+ ((and (soundp s1) (soundp s2))
+ (snd-maxv s1 s2))
+ ((soundp s1)
+ (ny:error "S-MAX" 2 number-sound-anon s2 t))
+ (t
+ (ny:error "S-MAX" 1 number-sound-anon s1 t))))
+
+
+(defun s-min (s1 s2)
+ (setf s1 (nyq:coerce-to s1 s2))
+ (setf s2 (nyq:coerce-to s2 s1))
+ (cond ((arrayp s1)
+ (nyq:min-of-arrays s1 s2))
+ (t
+ (nyq:min-2-sounds s1 s2))))
+
+(defun nyq:min-of-arrays (s1 s2)
+ (let* ((n (length s1))
+ (p (make-array n)))
+ (ny:typecheck (/= n (length s2))
+ (error (strcat "In S-MIN, unequal number of channels, got "
+ (param-to-string s1) (param-to-string s2))))
+ (cond ((/= n (length s2))
+ (error "unequal number of channels in max")))
+ (dotimes (i n)
+ (setf (aref p i) (s-min (aref s1 i) (aref s2 i))))
+ p))
+
+(defun nyq:min-2-sounds (s1 s2)
+ (cond ((numberp s1)
+ (cond ((numberp s2)
+ (min s1 s2))
+ ((soundp s2)
+ (snd-minv s2
+ (snd-const s1 (local-to-global 0.0)
+ (snd-srate s2) (get-duration 1.0))))
+ (t
+ (ny:error "S-MIN" 2 number-sound-anon s2 t))))
+ ((numberp s2)
+ (ny:typecheck (not (soundp s1))
+ (ny:error "S-MIN" 2 number-sound-anon s2 t))
+ (snd-minv s1 (snd-const s2 (local-to-global 0.0)
+ (snd-srate s1) (get-duration 1.0))))
+ ((and (soundp s1) (soundp s2))
+ (snd-minv s1 s2))
+ ((soundp s1)
+ (ny:error "S-MIN" 2 number-sound-anon s2 t))
+ (t
+ (ny:error "S-MIN" 1 number-sound-anon s1 t))))
+
+
+(defun snd-minv (s1 s2)
+ (snd-scale -1.0 (snd-maxv (snd-scale -1.0 s1) (snd-scale -1.0 s2))))
+
+; sequence macros SEQ and SEQREP are now in seq.lsp:
+;
+(load "seq" :verbose NIL)
+
+
+; set-logical-stop - modify the sound and return it, time is shifted and
+; stretched
+(defun set-logical-stop (snd tim)
+ (ny:typecheck (not (numberp tim))
+ (ny:error "SET-LOGICAL-STOP" 2 '((NUMBER) "logical stop time") tim))
+ (ny:typecheck (not (or (soundp snd) (multichannel-soundp snd)))
+ (ny:error "SET-LOGICAL-STOP" 1 '((SOUND) "snd") snd t))
+ (multichan-expand "SET-LOGICAL-STOP" #'ny:set-logical-stop
+ '(((SOUND) "snd") ((NUMBER) "logical stop time")) snd tim))
+
+
+;; NY:SET-LOGICAL-STOP - "fast" set-logical-stop: no typechecks and no
+;; multichannel expansion
+(defun ny:set-logical-stop (snd tim)
+ (let ((d (local-to-global tim)))
+ (snd-set-logical-stop snd d)
+ snd))
+
+
+; SET-LOGICAL-STOP-ABS - modify the sound and return it
+;
+(defun set-logical-stop-abs (snd tim)
+ (ny:typecheck (not (numberp tim))
+ (ny:error "SET-LOGICAL-STOP-ABS" 2 '((NUMBER) "logical stop time") tim))
+ (ny:typecheck (not (or (soundp snd) (multichannel-soundp snd)))
+ (ny:error "SET-LOGICAL-STOP-ABS" 1 '((SOUND) "snd") snd t))
+ (multichan-expand "SET-LOGICAL-STOP-ABS" #'ny:set-logical-stop-abs
+ '(((SOUND) "snd") ((NUMBER) "logical stop time")) snd tim))
+
+
+(defun ny:set-logical-stop-abs (snd tim)
+ (snd-set-logical-stop snd tim)
+ snd)
+
+
+(defmacro simrep (pair sound)
+ `(let (_snds)
+ (dotimes ,pair (push ,sound _snds))
+ (sim-list _snds "SIMREP")))
+
+(defun sim (&rest snds)
+ (sim-list snds "SIM or SUM (or + in SAL)"))
+
+(setfn sum sim)
+
+(defun sim-list (snds source)
+ (let (a b)
+ (cond ((null snds)
+ (snd-zero (local-to-global 0) *sound-srate*))
+ ((null (cdr snds))
+ (setf a (car snds))
+ (ny:typecheck (not (or (numberp a) (soundp a) (multichannel-soundp a)))
+ (ny:error source 0 number-sound-anon a t))
+ a)
+ ((null (cddr snds))
+ ;; sal-plus does typechecking, then calls nyq:add2
+ (sal-plus (car snds) (cadr snds)))
+ (t
+ (setf a (car snds))
+ (ny:typecheck (not (or (numberp a) (soundp a) (multichannel-soundp a)))
+ (ny:error source 0 number-sound-anon a t))
+ (nyq:add2 a (sim-list (cdr snds) source))))))
+
+
+(defun s-rest (&optional (dur 1.0) (chans 1))
+ (ny:typecheck (not (numberp dur))
+ (ny:error "S-REST" 1 '((NUMBER) "dur") dur))
+ (ny:typecheck (not (integerp chans))
+ (ny:error "S-REST" 2 '((INTEGER) "chans") chans))
+ (let ((d (get-duration dur))
+ r)
+ (cond ((= chans 1)
+ (snd-const 0.0 *rslt* *SOUND-SRATE* d))
+ (t
+ (setf r (make-array chans))
+ (dotimes (i chans)
+ (setf (aref r i) (snd-const 0.0 *rslt* *SOUND-SRATE* d)))
+ r))))
+
+
+(defun tempo (warpfn)
+ (ny:typecheck (not (soundp warpfn))
+ (ny:error "TEMPO" 0 '((SOUND) "warpfn") warpfn))
+ (slope (snd-inverse warpfn (local-to-global 0) *control-srate*)))
+
+
+;; (SUM-OF-ARRAYS S1 S2) - add multichannel sounds
+;
+; assumes s1 & s2 are arrays of numbers and sounds
+;
+; result has as many channels the largest of s1, s2
+; corresponding channels are added, extras are copied
+;
+(defun sum-of-arrays (s1 s2)
+; (ny:typecheck (not (multichannel-soundp s1))
+; (error (strcat "In SUM or SIM (or + in SAL), at least one channel in the array contains a non-sound, got " (param-to-string s1))))
+; (ny:typecheck (not (multichannel-soundp s2))
+; (error (strcat "In SUM or SIM (or + in SAL), at least one channel in the array contains a non-sound, got " (param-to-string s2))))
+ (let* ((n1 (length s1))
+ (n2 (length s2))
+ (n (min n1 n2))
+ (m (max n1 n2))
+ (result (make-array m))
+ (big-s (if (> n1 n2) s1 s2))
+ v1 v2)
+
+ (dotimes (i n)
+ (setf v1 (aref s1 i) v2 (aref s2 i))
+ (setf (aref result i)
+ (cond ((numberp v1)
+ (if (numberp v2) (+ v1 v2) (snd-offset v2 v1)))
+ ((numberp v2)
+ (if (numberp v1) (+ v1 v2) (snd-offset v1 v2)))
+ (t
+ (nyq:add-2-sounds v1 v2)))))
+ (dotimes (i (- m n))
+ (setf (aref result (+ n i)) (aref big-s (+ n i))))
+ result))
+
+
+;; (WARP fn behavior) - warp behavior according to fn
+;;
+;; fn is a map from behavior time to local time, and *WARP* expresses
+;; a map from local to global time.
+;; To produce a new *WARP* for the environment, we want to compose the
+;; effect of the current *WARP* with fn. Note that fn is also a behavior.
+;; It is evaluated in the current environment first, then it is used to
+;; modify the environment seen by behavior.
+;; *WARP* is a triple: (d s f) denoting the function f(st+d).
+;; Letting g represent the new warp function fn, we want f(st+d) o g, or
+;; f(s*g(t) + d) in the form (d' s' f').
+;; Let's do this one step at a time:
+;; f(s*g(t) + d) = f(scale(s, g) + d)
+;; = (shift f -d)(scale(s, g))
+;; = (snd-compose (shift-time f (- d)) (scale s g))
+;;
+;; If f in NIL, it denotes the identity mapping f(t)=t, so we can
+;; simplify:
+;; f(scale(s, g) + d) = scale(s, g) + d
+;; = (snd-offset (scale s g) d)
+
+(defmacro warp (x s)
+ `(progv '(*WARP*)
+ (let ((wp ,x))
+ (list (list 0.0 1.0
+ (cond ((warp-function *WARP*)
+ (ny:typecheck (not (soundp wp))
+ (ny:error "WARP" 1 '((SOUND) "warp function") wp))
+ (snd-compose (shift-time (warp-function *WARP*)
+ (- (warp-time *WARP*)))
+ (snd-scale (warp-stretch *WARP*) wp)))
+ (t
+ (ny:typecheck (not (soundp wp))
+ (ny:error "WARP" 1 '((SOUND) "warp function") wp))
+ (snd-offset (snd-scale (warp-stretch *WARP*) wp)
+ (warp-time *WARP*)))))))
+ ,s))
+
+
+(defmacro warp-abs (x s)
+ `(progv '(*WARP*)
+ (let ((wp ,x))
+ (ny:typecheck (and wp (not (soundp wp)))
+ (ny:error "WARP-ABS" 1 '((NULL SOUND) NIL) wp))
+ (list (list 0.0 1.0 wp)))
+ ,s))
+
+
+;; MULTICHAN-EXPAND -- construct and return array according to args
+;;
+;; arrays are used in Nyquist to represent multiple channels
+;; if any argument is an array, make sure all array arguments
+;; have the same length. Then, construct a multichannel result
+;; by calling fn once for each channel. The arguments passed to
+;; fn for the i'th channel are either the i'th element of an array
+;; argument, or just a copy of a non-array argument.
+;;
+;; types should be a list of type info for each arg, where type info is:
+;; (arg1-info arg2-info ...), where each arg-info is
+;; (valid-type-list name-or-nil), where valid-type-list is a list
+;; of valid types from among NUMBER, SOUND, POSITIVE (number > 0),
+;; NONNEGATIVE (number >= 0), INTEGER, STEP, STRING,
+;; POSITIVE-OR_NULL (a positive number or nil),
+;; INT-OR-NULL (integer or nil), or NULL (the value can be nil).
+;; It is implied that arrays of these are valid too. name-or-nil
+;; is the parameter name as a string if the parameter name should
+;; be printed, or NIL if the parameter name should not be printed.
+;; There can be at most 2 elements in valid-type-list, and if
+;; there are 2 elements, the 2nd one must be SOUND. For example,
+;; arg-info '((NUMBER SOUND) "cutoff") might generate the error
+;; In LOPASS8, 2nd argument (cutoff) must be a number, sound
+;; or array thereof, got "bad-value"
+;;
+;; Many existing Nyquist plug-ins require the old version of multichan-expand,
+;; so in Audacity we need to support both the old and new versions.
+(defun multichan-expand (&rest args)
+ (if (stringp (first args))
+ (apply 'multichan-expand-new args)
+ (apply 'multichan-expand-old args)))
+
+;; Legacy version:
+(defun multichan-expand-old (fn &rest args)
+ (let (len newlen result) ; len is a flag as well as a count
+ (dolist (a args)
+ (cond ((arrayp a)
+ (setf newlen (length a))
+ (cond ((and len (/= len newlen))
+ (error (format nil "In ~A, two arguments are vectors of differing length." fn))))
+ (setf len newlen))))
+ (cond (len
+ (setf result (make-array len))
+ ; for each channel, call fn with args
+ (dotimes (i len)
+ (setf (aref result i)
+ (apply fn
+ (mapcar
+ #'(lambda (a)
+ ; take i'th entry or replicate:
+ (cond ((arrayp a) (aref a i))
+ (t a)))
+ args))))
+ result)
+ (t
+ (apply fn args)))))
+
+;; The new (Nyquist 3.15) version:
+(defun multichan-expand-new (src fn types &rest args)
+ (let (chan len newlen result prev typ (index 0) nonsnd)
+ ; len is a flag as well as a count
+ (dolist (a args)
+ (setf typ (car types) types (cdr types))
+ ;; we only report argument position when there is more than one.
+ ;; index tracks argument position, where 0 means no position to report
+ (if (> (length args) 1) (setf index (1+ index)))
+ (setf nonsnd (caar typ)) ;; if non-sound type allowed, what is it?
+ ;; compute the length of any array argument, and typecheck all of them
+ (cond ((arrayp a)
+ (setf newlen (length a))
+ (ny:typecheck (and len (/= len newlen))
+ (error (strcat "In " src
+ ", two arguments are multichannels of differing length, got "
+ (param-to-string prev) ", and " (param-to-string a))))
+ (dotimes (i newlen)
+ (setf chan (aref a i))
+ (cond ((and (eq nonsnd 'NUMBER) (numberp chan)))
+ ((and (member 'SOUND (car typ)) (soundp chan)))
+ ((and (eq nonsnd 'STEP) (numberp chan)))
+ ((and (eq nonsnd 'POSITIVE) (numberp chan) (> chan 0)))
+ ((and (eq nonsnd 'POSITIVE-OR-NULL)
+ (or (and (numberp chan) (> chan 0)) (null chan))))
+ ((and (eq nonsnd 'NONNEGATIVE) (numberp chan) (>= chan 0)))
+ ((and (eq nonsnd 'INTEGER) (integerp chan)))
+ ((and (eq nonsnd 'STRING) (stringp chan)))
+ ((and (eq nonsnd 'NULL) (null chan)))
+ ((and (eq nonsnd 'INT-OR-NULL)
+ (or (integerp chan) (null chan))))
+ (t (ny:error src index typ a t))))
+ (setf prev a)
+ (setf len newlen))
+ ((and (eq nonsnd 'NUMBER) (numberp a)))
+ ((and (member 'SOUND (car typ)) (soundp a)))
+ ((and (eq nonsnd 'STEP) (numberp a)))
+ ((and (eq nonsnd 'POSITIVE) (numberp a) (>= a 0)))
+ ((and (eq nonsnd 'POSITIVE-OR-NULL)
+ (or (and (numberp a) (> a 0)) (null a))))
+ ((and (eq nonsnd 'NONNEGATIVE) (numberp a) (>= a 0)))
+ ((and (eq nonsnd 'INTEGER) (integerp a)))
+ ((and (eq nonsnd 'STRING) (stringp a)))
+ ((and (eq nonsnd 'NULL) (null a)))
+ ((and (eq nonsnd 'INT-OR-NULL)
+ (or (integerp a) (null a))))
+ (t
+ (ny:error src index typ a t))))
+ (cond (len
+ (setf result (make-array len))
+ ; for each channel, call fn with args
+ (dotimes (i len)
+ (setf (aref result i)
+ (apply fn
+ (mapcar
+ #'(lambda (a) ; take i'th entry or replicate:
+ (cond ((arrayp a) (aref a i))
+ (t a)))
+ args))))
+ result)
+ (t
+ (apply fn args)))))
+
+
+;; SELECT-IMPLEMENTATION-? -- apply an implementation according to args
+;;
+;; There is a different Nyquist primitive for each combination of
+;; constant (NUMBERP) and time-variable (SOUNDP) arguments. E.g.
+;; a filter with fixed parameters differs from one with varying
+;; parameters. In most cases, the user just calls one function,
+;; and the arguments are decoded here:
+
+
+;; SELECT-IMPLEMENTATION-1-1 -- 1 sound arg, 1 selector
+;;
+(defun select-implementation-1-1 (source fns snd sel1 &rest others)
+ (ny:typecheck (not (soundp snd))
+ (ny:error source 1 '((SOUND) nil) snd t))
+ (cond ((numberp sel1)
+ (apply (aref fns 0) (cons snd (cons sel1 others))))
+ ((soundp sel1)
+ (apply (aref fns 1) (cons snd (cons sel1 others))))
+ (t
+ (ny:error source 2 number-sound-anon sel1 t))))
+
+
+;; SELECT-IMPLEMENTATION-1-2 -- 1 sound arg, 2 selectors
+;;
+;; choose implementation according to args 2 and 3. In this implementation,
+;; since we have two arguments to test for types, we return from prog
+;; if we find good types. That way, we can fall through the decision tree
+;; and all paths lead to one call to ERROR if good types are not found.
+;;
+(defun select-implementation-1-2 (source fns snd sel1 sel2 &rest others)
+ (prog ()
+ (ny:typecheck (not (soundp snd))
+ (ny:error source 1 '((SOUND) nil) snd t))
+ (cond ((numberp sel2)
+ (cond ((numberp sel1)
+ (return (apply (aref fns 0)
+ (cons snd (cons sel1 (cons sel2 others))))))
+ ((soundp sel1)
+ (return (apply (aref fns 1)
+ (cons snd (cons sel1 (cons sel2 others))))))))
+ ((soundp sel2)
+ (cond ((numberp sel1)
+ (return (apply (aref fns 2)
+ (cons snd (cons sel1 (cons sel2 others))))))
+ ((soundp sel1)
+ (return (apply (aref fns 3)
+ (cons snd (cons sel1 (cons sel2 others)))))))))
+ (ny:typecheck (not (or (numberp sel1) (soundp sel1)))
+ (ny:error src 2 number-sound-anon sel1 t)
+ (ny:error src 3 number-sound-anon sel2 t))))
+
+
+;; some waveforms
+
+(setf *saw-table* (pwlvr -1 1 1)) ; eh, creepy way to get 2205 samples.
+(setf *saw-table* (list *saw-table* (hz-to-step 1) T))
+
+(setf *tri-table* (pwlvr -1 0.5 1 0.5 -1))
+(setf *tri-table* (list *tri-table* (hz-to-step 1) T))
+
+(setf *id-shape* (pwlvr -1 2 1 .01 1)) ; identity
+
+(setf *step-shape* (seq (const -1) (const 1 1.01))) ; hard step at zero
+
+(defun exp-dec (hold halfdec length)
+ (ny:typecheck (not (numberp hold))
+ (ny:error "EXP-DEC" 1 '((NUMBER) "hold") hold))
+ (ny:typecheck (not (numberp halfdec))
+ (ny:error "EXP-DEC" 2 '((NUMBER) "halfdec") halfdec))
+ (ny:typecheck (not (numberp length))
+ (ny:error "EXP-DEC" 3 '((NUMBER) "length") length))
+ (let* ((target (expt 0.5 (/ length halfdec)))
+ (expenv (pwev 1 hold 1 length target)))
+ expenv)
+)
+
+;;; operations on sounds
+
+(defun diff (x &rest y) (diff-list x y "DIFF (or - in SAL)"))
+
+(defun diff-list (x y source)
+ (cond ((and (numberp x) (numberp (car y)) (null (cdr y)))
+ (- x (car y))) ;; this is a fast path for the common case
+ (y (sal-plus x (nyq:prod2 -1 (car y) source) source))
+ (t (nyq:prod2 -1 x source))))
+
+
+; compare-shape is a shape table -- origin 1.
+(defun compare (x y &optional (compare-shape *step-shape*))
+ (ny:typecheck (not (or (soundp x) (soundp y)))
+ (error "In COMPARE, either first or second argument must be a sound"))
+ (ny:typecheck (not (soundp compare-shape))
+ (ny:error "COMPARE" 3 '((SOUND) "compare-shape") compare-shape))
+ (ny:typecheck (not (or (soundp x) (numberp x)))
+ (ny:error "COMPARE" 1 '((SOUND NUMBER) nil) x))
+ (ny:typecheck (not (or (soundp y) (numberp y)))
+ (ny:error "COMPARE" 2 '((SOUND NUMBER) nil) y))
+ (let ((xydiff (diff-list x (list y) "COMPARE")))
+ (shape xydiff compare-shape 1)))
+
+;;; oscs
+
+(defun osc-saw (hz) (hzosc hz *saw-table*))
+(defun osc-tri (hz) (hzosc hz *tri-table*))
+
+; bias is [-1, 1] pulse width. sound or scalar.
+; hz is a sound or scalar
+(defun osc-pulse (hz bias &optional (compare-shape *step-shape*))
+ (compare bias (osc-tri hz) compare-shape))
+
+;;; tapped delays
+
+;(tapv snd offset vardelay maxdelay)
+(defun tapv (snd offset vardelay maxdelay)
+ (multichan-expand "TAPV" #'snd-tapv
+ '(((SOUND) "snd") ((NUMBER) "offset")
+ ((SOUND) "vardelay") ((NUMBER) "maxdelay"))
+ snd offset vardelay maxdelay))
+
+(defun tapf (snd offset vardelay maxdelay)
+ (multichan-expand "TAPF" #'snd-tapf
+ '(((SOUND) "snd") ((NUMBER) "offset")
+ ((SOUND) "vardelay") ((NUMBER) "maxdelay"))
+ snd offset vardelay maxdelay))
+
+
+;; autoload functions -- SELF-MODIFYING CODE!
+;; generate functions that replace themselves by loading more files
+;; and then re-calling themselves as if they were already loaded
+;;
+(defun autoload (filename &rest fns)
+ ;; filename is the file to load (a string) from the current path
+ ;; fns are symbols to be defined as function that will load filename
+ ;; the first time any one is called, and it is assumed that
+ ;; filename will define each function in fns, so the called
+ ;; function can be called again to execute the real implementation
+ (let ((cp (current-path)))
+ (cond ((string-equal cp "./") ;; this is the typical case
+ (setf cp (setdir "."))))
+ ;; make sure cp ends in file separator
+ (cond ((not (equal (char cp (1- (length cp))) *file-separator*))
+ (setf cp (strcat cp (string *file-separator*)))))
+ (setf cp (strcat cp filename))
+ (dolist (fn fns)
+ (eval `(defun ,fn (&rest args)
+ (autoload-helper ,cp ',fn args))))))
+
+
+(defun autoload-helper (path fn args)
+ (if (abs-env (sal-load path))
+ (apply fn args)
+ (error (strcat "Could not load " path))))
+
+
+(autoload "spec-plot.lsp" 'spec-plot)
+
+(autoload "spectral-analysis.lsp" 'sa-init)
+
diff --git a/Release/nyquist/printrec.lsp b/Release/nyquist/printrec.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..4ca17bbc9d1ccce28c0cf97b13f93ad4b8e719ef
--- /dev/null
+++ b/Release/nyquist/printrec.lsp
@@ -0,0 +1,30 @@
+; prints recursive list structure
+
+;(let (seen-list)
+(setf seenlist nil)
+ (defun seenp (l) (member l seenlist :test 'eq))
+ (defun make-seen (l) (setf seenlist (cons l seenlist)))
+ (defun printrec (l) (printrec-any l) (setf seenlist nil))
+ (defun printrec-any (l)
+ (cond ((atom l) (prin1 l) (princ " "))
+ ((seenp l) (princ "<...> "))
+ (t
+ (make-seen l)
+ (princ "(")
+ (printrec-list l)
+ (princ ") ")))
+ nil)
+ (defun printrec-list (l)
+ (printrec-any (car l))
+ (cond ((cdr l)
+ (cond ((seenp (cdr l))
+ (princ "<...> "))
+ ((atom (cdr l))
+ (princ ". ")
+ (prin1 (cdr l))
+ (princ " "))
+ (t
+ (make-seen (cdr l))
+ (printrec-list (cdr l))))))
+ nil)
+; )
diff --git a/Release/nyquist/profile.lsp b/Release/nyquist/profile.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..0f7038b61db28abede72980faf2da4b45292b1da
--- /dev/null
+++ b/Release/nyquist/profile.lsp
@@ -0,0 +1,27 @@
+
+; profile.lsp -- support for profiling
+
+;## show-profile -- print profile data
+(defun show-profile ()
+ (let ((profile-flag (profile nil)) (total 0))
+ (dolist (name *PROFILE*)
+ (setq total (+ total (get name '*PROFILE*))))
+ (dolist (name *PROFILE*)
+ (format t "~A (~A%): ~A~%"
+ (get name '*PROFILE*)
+ (truncate
+ (+ 0.5 (/ (float (* 100 (get name '*PROFILE*)))
+ total)))
+ name))
+ (format t "Total: ~A~%" total)
+ (profile profile-flag)))
+
+
+;## start-profile -- clear old profile data and start profiling
+(defun start-profile ()
+ (profile nil)
+ (dolist (name *PROFILE*)
+ (remprop name '*PROFILE*))
+ (setq *PROFILE* nil)
+ (profile t))
+
diff --git a/Release/nyquist/rawwaves/mand1.raw b/Release/nyquist/rawwaves/mand1.raw
new file mode 100644
index 0000000000000000000000000000000000000000..bc04a0583599515565866453df6016d6d1c27694
Binary files /dev/null and b/Release/nyquist/rawwaves/mand1.raw differ
diff --git a/Release/nyquist/rawwaves/mand10.raw b/Release/nyquist/rawwaves/mand10.raw
new file mode 100644
index 0000000000000000000000000000000000000000..4b35376aeacdfc50cbef89ea76259403ac542b69
Binary files /dev/null and b/Release/nyquist/rawwaves/mand10.raw differ
diff --git a/Release/nyquist/rawwaves/mand11.raw b/Release/nyquist/rawwaves/mand11.raw
new file mode 100644
index 0000000000000000000000000000000000000000..94889be6f0d6dfeaa63449e06a39df1356508dac
Binary files /dev/null and b/Release/nyquist/rawwaves/mand11.raw differ
diff --git a/Release/nyquist/rawwaves/mand12.raw b/Release/nyquist/rawwaves/mand12.raw
new file mode 100644
index 0000000000000000000000000000000000000000..a128642bf6de4fdac74a1fa03bf32bc6003bb685
Binary files /dev/null and b/Release/nyquist/rawwaves/mand12.raw differ
diff --git a/Release/nyquist/rawwaves/mand2.raw b/Release/nyquist/rawwaves/mand2.raw
new file mode 100644
index 0000000000000000000000000000000000000000..62080081d289b7dfa042b787190b99b0399fe81e
Binary files /dev/null and b/Release/nyquist/rawwaves/mand2.raw differ
diff --git a/Release/nyquist/rawwaves/mand3.raw b/Release/nyquist/rawwaves/mand3.raw
new file mode 100644
index 0000000000000000000000000000000000000000..8857f862298c1fd4516047ce8f0daa096a08ebf4
Binary files /dev/null and b/Release/nyquist/rawwaves/mand3.raw differ
diff --git a/Release/nyquist/rawwaves/mand4.raw b/Release/nyquist/rawwaves/mand4.raw
new file mode 100644
index 0000000000000000000000000000000000000000..6058eb10081839bb84810134acd9252f873b8bfc
Binary files /dev/null and b/Release/nyquist/rawwaves/mand4.raw differ
diff --git a/Release/nyquist/rawwaves/mand5.raw b/Release/nyquist/rawwaves/mand5.raw
new file mode 100644
index 0000000000000000000000000000000000000000..9b308a860b4966a4bfa6148f01bdfa70fdc99495
Binary files /dev/null and b/Release/nyquist/rawwaves/mand5.raw differ
diff --git a/Release/nyquist/rawwaves/mand6.raw b/Release/nyquist/rawwaves/mand6.raw
new file mode 100644
index 0000000000000000000000000000000000000000..05f083d8912b7622d17e058ced75e9c06d65f25d
Binary files /dev/null and b/Release/nyquist/rawwaves/mand6.raw differ
diff --git a/Release/nyquist/rawwaves/mand7.raw b/Release/nyquist/rawwaves/mand7.raw
new file mode 100644
index 0000000000000000000000000000000000000000..64941e9f98421aa1b2b353abbfa5a25cd9942295
Binary files /dev/null and b/Release/nyquist/rawwaves/mand7.raw differ
diff --git a/Release/nyquist/rawwaves/mand8.raw b/Release/nyquist/rawwaves/mand8.raw
new file mode 100644
index 0000000000000000000000000000000000000000..52027bf695e8053eb0511e36ac16a38a500d7973
Binary files /dev/null and b/Release/nyquist/rawwaves/mand8.raw differ
diff --git a/Release/nyquist/rawwaves/mand9.raw b/Release/nyquist/rawwaves/mand9.raw
new file mode 100644
index 0000000000000000000000000000000000000000..9e88a0c91317db8a3f2ba7969fe7aa0e0b2e029f
Binary files /dev/null and b/Release/nyquist/rawwaves/mand9.raw differ
diff --git a/Release/nyquist/rawwaves/mandpluk.raw b/Release/nyquist/rawwaves/mandpluk.raw
new file mode 100644
index 0000000000000000000000000000000000000000..162a0da9e1d448ee915c7b4ba441c8da46b6298a
Binary files /dev/null and b/Release/nyquist/rawwaves/mandpluk.raw differ
diff --git a/Release/nyquist/rawwaves/marmstk1.raw b/Release/nyquist/rawwaves/marmstk1.raw
new file mode 100644
index 0000000000000000000000000000000000000000..185b4452613d748bf21d19614a54cd139e7d4b40
Binary files /dev/null and b/Release/nyquist/rawwaves/marmstk1.raw differ
diff --git a/Release/nyquist/rawwaves/sinewave.raw b/Release/nyquist/rawwaves/sinewave.raw
new file mode 100644
index 0000000000000000000000000000000000000000..a5cb34991bc7de10b0f342dc72b9f295a4eff628
Binary files /dev/null and b/Release/nyquist/rawwaves/sinewave.raw differ
diff --git a/Release/nyquist/sal-parse.lsp b/Release/nyquist/sal-parse.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..461ce057dc0792a80c0ac4efc80f1deaae3d7993
--- /dev/null
+++ b/Release/nyquist/sal-parse.lsp
@@ -0,0 +1,1899 @@
+;; SAL parser -- replaces original pattern-directed parser with
+;; a recursive descent one
+;;
+;; Parse functions either parse correctly and return
+;; compiled code as a lisp expression (which could be nil)
+;; or else they call parse-error, which does not return
+;; (instead, parse-error forces a return from parse)
+;; In the original SAL parser, triples were returned
+;; including the remainder if any of the tokens to be
+;; parsed. In this parser, tokens are on the list
+;; *sal-tokens*, and whatever remains on the list is
+;; the list of unparsed tokens.
+
+;; scanning delimiters.
+
+(setfn nreverse reverse)
+
+(defconstant +quote+ #\") ; "..." string
+(defconstant +kwote+ #\') ; '...' kwoted expr
+(defconstant +comma+ #\,) ; positional arg delimiter
+(defconstant +pound+ #\#) ; for bools etc
+(defconstant +semic+ #\;) ; comment char
+(defconstant +lbrace+ #\{) ; {} list notation
+(defconstant +rbrace+ #\})
+(defconstant +lbrack+ #\[) ; unused for now
+(defconstant +rbrack+ #\])
+(defconstant +lparen+ #\() ; () expr and arg grouping
+(defconstant +rparen+ #\))
+
+;; these are defined so that SAL programs can name these symbols
+;; note that quote(>) doesn't work, so you need quote(symbol:greater)
+
+(setf symbol:greater '>)
+(setf symbol:less '<)
+(setf symbol:greater-equal '>=)
+(setf symbol:less-equal '<=)
+(setf symbol:equal '=)
+(setf symbol:not '!)
+(setf symbol:not-equal '/=)
+
+
+(defparameter +whites+ (list #\space #\tab #\newline (code-char 13)))
+
+(defparameter +kwstyle+ (list :suffix #\:)) ; let's try dylan
+
+(defparameter +operators+
+ ;; each op is: (<token-class> <sal-name> <lisp-form>)
+ '((:+ "+" sal-plus)
+ (:- "-" diff)
+ (:* "*" mult)
+ (:/ "/" /)
+ (:% "%" rem)
+ (:^ "^" expt)
+ (:= "=" sal-equal) ; equality and assignment
+ (:!= "!=" not-sal-equal)
+ (:< "<" <)
+ (:> ">" >)
+ (:<= "<=" <=) ; leq and assignment minimization
+ (:>= ">=" >=) ; geq and assignment maximization
+ (:~= "~=" sal-about-equal) ; general equality
+ (:+= "+=" +=) ; assignment increment-and-store
+ (:-= "-=" -=) ; assignment increment-and-store
+ (:*= "*=" *=) ; assignment multiply-and-store
+ (:/= "/=" /=) ; assignment multiply-and-store
+ (:&= "&=" &=) ; assignment list collecting
+ (:@= "@=" @=) ; assignment list prepending
+ (:^= "^=" ^=) ; assignment list appending
+ (:! "!" not)
+ (:& "&" and)
+ (:\| "|" or)
+ (:~ "~" sal-stretch)
+ (:~~ "~~" sal-stretch-abs)
+ (:@ "@" sal-at)
+ (:@@ "@@" sal-at-abs)
+ ))
+
+(setf *sal-local-variables* nil) ;; used to avoid warning about variable
+ ;; names when the variable has been declared as a local
+
+(defparameter *sal-operators*
+ '(:+ :- :* :/ :% :^ := :!= :< :> :<= :>= :~= :+= :*= :&= :@= :^= :! :& :\|
+ :~ :~~ :@ :@@))
+
+(defparameter +delimiters+
+ '((:lp #\()
+ (:rp #\))
+ (:lc #\{) ; left curly
+ (:rc #\})
+ (:lb #\[)
+ (:rb #\])
+ (:co #\,)
+ (:kw #\') ; kwote
+ (nil #\") ; not token
+ ; (nil #\#)
+ (nil #\;)
+ ))
+
+(setf *reserved-words* '((::+ ":+") (::- ":-") (::* ":*") (::/ ":/") (::= ":=")
+ (::!= ":!=") (::< ":<") (::> ":>") (::<= ":<=")
+ (::>= ":>=") (::~= ":~=") (::! ":!") (::& ":&")
+ (::\| ":|") (:IF "if") (:THEN "then") (:ELSE "else")
+ (:WHEN "when") (:UNLESS "unless") (:SET "set")
+ (:= "=") (:+= "+=") (:*= "*=") (:&= "&=") (:@= "@=")
+ (:^= "^=") (:<= "<=") (:>= ">=") (:PRINT "print")
+ (:LOOP "loop") (:SEQV "seqv") (:SEQREPV "seqrepv")
+ (:RUN "run") (:REPEAT "repeat") (:FOR "for")
+ (:FROM "from") (:IN "in") (:BELOW "below") (:TO "to")
+ (:ABOVE "above") (:DOWNTO "downto") (:BY "by")
+ (:OVER "over") (:WHILE "while") (:UNTIL "until")
+ (:FINALLY "finally") (:RETURN "return")
+ (:WAIT "wait") (:BEGIN "begin") (:WITH "with")
+ (:END "end") (:VARIABLE "variable")
+ (:FUNCTION "function")
+ ; not in nyquist: (:PROCESS "process")
+ (:CHDIR "chdir")
+ (:DEFINE "define") (:LOAD "load")
+ (:PLAY "play") (:PLOT "plot")
+ (:EXEC "exec") (:exit "exit") (:DISPLAY "display")
+ (:~ "~") (:~~ "~~") (:@ ":@") (:@@ ":@@")))
+
+
+(setf *sal-fn-name* nil)
+
+(defun make-sal-error (&key type text (line nil) start)
+ ; (error 'make-sal-error-was-called-break)
+ (list 'sal-error type text line start))
+(setfn sal-error-type cadr)
+(setfn sal-error-text caddr)
+(setfn sal-error-line cadddr)
+(defun sal-error-start (x) (cadddr (cdr x)))
+(defun is-sal-error (x) (and x (eq (car x) 'sal-error)))
+(defun sal-tokens-error-start (start)
+ (cond (start
+ start)
+ (*sal-tokens*
+ (token-start (car *sal-tokens*)))
+ (t
+ (length *sal-input-text*))))
+
+
+(defmacro errexit (message &optional start)
+ `(parse-error (make-sal-error :type "parse"
+ :line *sal-input-text* :text ,message
+ :start ,(sal-tokens-error-start start))))
+
+(defmacro sal-warning (message &optional start)
+ `(pperror (make-sal-error :type "parse" :line *sal-input-text*
+ :text ,message
+ :start ,(sal-tokens-error-start start))
+ "warning"))
+
+(setf *pos-to-line-source* nil)
+(setf *pos-to-line-pos* nil)
+(setf *pos-to-line-line* nil)
+
+(defun pos-to-line (pos source)
+ ;; this is really inefficient to search every line from
+ ;; the beginning, so cache results and search forward
+ ;; from there if possible
+ (let ((i 0) (line-no 1)) ;; assume no cache
+ ;; see if we can use the cache
+ (cond ((and (eq source *pos-to-line-source*)
+ *pos-to-line-pos* *pos-to-line-line*
+ (>= pos *pos-to-line-pos*))
+ (setf i *pos-to-line-pos*)
+ (setf line-no *pos-to-line-line*)))
+ ;; count newlines up to pos
+ (while (< i pos)
+ (if (char= (char source i) #\newline)
+ (incf line-no))
+ (setf i (1+ i)))
+ ;; save results in cache
+ (setf *pos-to-line-source* source
+ *pos-to-line-pos* pos
+ *pos-to-line-line* line-no)
+ ;; return the line number at pos in source
+ line-no))
+
+
+;; makes a string of n spaces, empty string if n <= 0
+(defun make-spaces (n)
+ (cond ((> n 16)
+ (let* ((half (/ n 2))
+ (s (make-spaces half)))
+ (strcat s s (make-spaces (- n half half)))))
+ (t
+ (subseq " " 0 (max n 0)))))
+
+
+(defun pperror (x &optional (msg-type "error"))
+ (let* ((source (sal-error-line x))
+ (llen (length source))
+ line-no
+ beg end)
+ ; (display "pperror" x (strcat "|" (sal-error-line x) "|"))
+ ;; isolate line containing error
+ (setf beg (sal-error-start x))
+ (setf beg (min beg (1- llen)))
+ (do ((i beg (- i 1))
+ (n nil)) ; n gets set when we find a newline
+ ((or (< i 0) n)
+ (setq beg (or n 0)))
+ (if (char= (char source i) #\newline)
+ (setq n (+ i 1))))
+ (do ((i (sal-error-start x) (+ i 1))
+ (n nil))
+ ((or (>= i llen) n)
+ (setq end (or n llen)))
+ (if (char= (char source i) #\newline)
+ (setq n i)))
+ (setf line-no (pos-to-line beg source))
+ ; (display "pperror" beg end (sal-error-start x))
+
+ ;; print the error. include the specific line of input containing
+ ;; the error as well as a line below it marking the error position
+ ;; with an arrow: ^
+ (let* ((pos (- (sal-error-start x) beg))
+ (line (if (and (= beg 0) (= end llen))
+ source
+ (subseq source beg end)))
+ (mark (make-spaces pos)))
+ (format t "~%>>> ~A ~A: ~A.~%>>> in ~A, line ~A, col ~A.~%~%~A~%~A^~%"
+ (sal-error-type x) msg-type (sal-error-text x)
+ *sal-input-file-name* line-no (1+ pos)
+ line mark)
+; (format t "~%>>> ~A error in \"~A\", line ~A, col ~A: ~A.~%~%~A~%~A^~%"
+; (sal-error-type x) *sal-input-file-name* line-no pos
+; (sal-error-text x) line mark)
+ x)))
+
+
+;;;
+;;; the lexer. right now it assumes input string is complete and ready
+;;; to be processed as a valid expression.
+;;;
+
+(defun advance-white (str white start end)
+ ;; skip "white" chars, where white can be a char, list of chars
+ ;; or predicate test
+ (do ((i start )
+ (p nil))
+ ((or p (if (< start end)
+ (not (< -1 i end))
+ (not (> i end -1))))
+ (or p end))
+ (cond ((consp white)
+ (unless (member (char str i) white :test #'char=)
+ (setq p i)))
+ ((characterp white)
+ (unless (char= (char str i) white)
+ (setq p i)))
+ ((functionp white)
+ (unless (funcall white (char str i))
+ (setq p i))))
+ (if (< start end)
+ (incf i)
+ (decf i))))
+
+
+(defun search-delim (str delim start end)
+ ;; find position of "delim" chars, where delim can be
+ ;; a char, list of chars or predicate test
+ (do ((i start (+ i 1))
+ (p nil))
+ ((or (not (< i end)) p)
+ (or p end))
+ (cond ((consp delim)
+ (if (member (char str i) delim :test #'char=)
+ (setq p i)))
+ ((characterp delim)
+ (if (char= (char str i) delim)
+ (setq p i)))
+ ((functionp delim)
+ (if (funcall delim (char str i))
+ (setq p i))))))
+
+
+;; UNBALANCED-INPUT AND TOKENIZE HAVE BEEN REWRITTEN, SEE BELOW. THIS ONE IS
+;; OLD AND JUST KEPT HERE FOR REFERENCE
+#|
+(defun unbalanced-input (errf line toks par bra brk kwo)
+ ;; search input for the starting position of some unbalanced
+ ;; delimiter, toks is reversed list of tokens with something
+ ;; unbalanced
+ (let (char text targ othr levl pos)
+ (cond ((> par 0) (setq char #\( targ ':lp othr ':rp levl par))
+ ((< par 0) (setq char #\) targ ':rp othr ':lp levl 0))
+ ((> bra 0) (setq char #\{ targ ':lc othr ':rc levl bra))
+ ((< bra 0) (setq char #\} targ ':rc othr ':lc levl 0))
+ ((> brk 0) (setq char #\[ targ ':ls othr ':rs levl brk))
+ ((< brk 0) (setq char #\] targ ':rs othr ':ls levl 0))
+ ((> kwo 0) (setq char #\' targ ':kw othr ':kw levl kwo)))
+ (setq text (format nil "Unmatched '~A'" char))
+ ;; search for start of error in token list
+ (do ((n levl)
+ (tail toks (cdr tail)))
+ ((or (null tail) pos)
+ (or pos (error (format nil "Shouldn't! can't find op ~A in ~A."
+ targ (reverse toks)))))
+ (if (eql (token-type (car tail)) targ)
+ (if (= n levl)
+ (setq pos (token-start (car tail)))
+ (decf n))
+ (if (eql (token-type (car tail)) othr)
+ (incf n))))
+ (errexit text pos)))
+
+;; REMINDER: THIS IS PART OF A BIG BLOCK COMMENT
+(defun tokenize (str reserved error-fn)
+ ;&key (start 0) (end (length str))
+ ; (white-space +whites+) (delimiters +delimiters+)
+ ; (operators +operators+) (null-ok t)
+ ; (keyword-style +kwstyle+) (reserved nil)
+ ; (error-fn nil)
+ ; &allow-other-keys)
+ ;; return zero or more tokens or a sal-error
+ (let ((toks (list t))
+ (start 0)
+ (end (length str))
+ (all-delimiters +whites+)
+ (errf (or error-fn
+ (lambda (x) (pperror x) (return-from tokenize x)))))
+ (dolist (x +delimiters+)
+ (push (cadr x) all-delimiters))
+ (do ((beg start)
+ (pos nil)
+ (all all-delimiters)
+ (par 0)
+ (bra 0)
+ (brk 0)
+ (kwo 0)
+ (tok nil)
+ (tail toks))
+ ((not (< beg end))
+ ;; since input is complete check parens levels.
+ (if (= 0 par bra brk kwo)
+ (if (null (cdr toks))
+ (list)
+ (cdr toks))
+ (unbalanced-input errf str (reverse (cdr toks))
+ par bra brk kwo)))
+ (setq beg (advance-white str +whites+ beg end))
+ (setf tok
+ (read-delimited str :start beg :end end
+ :white +whites+ :delimit all
+ :skip-initial-white nil :errorf errf))
+ ;; multiple values are returned, so split them here:
+ (setf pos (second tok)) ; pos is the end of the token (!)
+ (setf tok (first tok))
+
+ ;; tok now string, char (delimiter), :eof or token since input
+ ;; is complete keep track of balancing delims
+ (cond ((eql tok +lbrace+) (incf bra))
+ ((eql tok +rbrace+) (decf bra))
+ ((eql tok +lparen+) (incf par))
+ ((eql tok +rparen+) (decf par))
+ ((eql tok +lbrack+) (incf brk))
+ ((eql tok +rbrack+) (decf brk))
+ ((eql tok +kwote+) (setq kwo (mod (+ kwo 1) 2))))
+ (cond ((eql tok ':eof)
+ (setq beg end))
+
+ (t
+ ;; may have to skip over comments to reach token, so
+ ;; token beginning is computed by backing up from current
+ ;; position (returned by read-delimited) by string length
+ (setf beg (if (stringp tok)
+ (- pos (length tok))
+ (1- pos)))
+ (setq tok (classify-token tok beg str errf
+ +delimiters+ +operators+
+ +kwstyle+ reserved))
+ ;(display "classify-token-result" tok)
+ (setf (cdr tail) (list tok ))
+ (setf tail (cdr tail))
+ (setq beg pos))))))
+|#
+
+
+;; old tokenize (above) counted delimiters to check for balance,
+;; but that does not catch constructions like ({)}. I think
+;; we could just leave this up to the parser, but this rewrite
+;; uses a stack to check balanced parens, braces, quotes, etc.
+;; The checking establishes at least some minimal global properties
+;; of the input before evaluating anything, which might be good
+;; even though it's doing some extra work. In fact, using a
+;; stack rather than counts is doing even more work, but the
+;; problem with counters is that some very misleading or just
+;; plain wrong error messages got generated.
+;;
+;; these five delimiter- functions do checks on balanced parens,
+;; braces, and brackets, leaving delimiter-mismatch set to bad
+;; token if there is a mismatch
+(defun delimiter-init ()
+ (setf delimiter-stack nil)
+ (setf delimiter-mismatch nil))
+(defun delimiter-match (tok what)
+ (cond ((eql (token-string (first delimiter-stack)) what)
+ (pop delimiter-stack))
+ ((null delimiter-mismatch)
+ ;(display "delimiter-mismatch" tok)
+ (setf delimiter-mismatch tok))))
+(defun delimiter-check (tok)
+ (let ((c (token-string tok)))
+ (cond ((member c '(#\( #\{ #\[))
+ (push tok delimiter-stack))
+ ((eql c +rbrace+)
+ (delimiter-match tok +lbrace+))
+ ((eql c +rparen+)
+ (delimiter-match tok +lparen+))
+ ((eql c +rbrack+)
+ (delimiter-match tok +lbrack+)))))
+(defun delimiter-error (tok)
+ (errexit (format nil "Unmatched '~A'" (token-string tok))
+ (token-start tok)))
+(defun delimiter-finish ()
+ (if delimiter-mismatch
+ (delimiter-error delimiter-mismatch))
+ (if delimiter-stack
+ (delimiter-error (car delimiter-stack))))
+(defun tokenize (str reserved error-fn)
+ ;; return zero or more tokens or a sal-error
+ (let ((toks (list t))
+ (start 0)
+ (end (length str))
+ (all-delimiters +whites+)
+ (errf (or error-fn
+ (lambda (x) (pperror x) (return-from tokenize x)))))
+ (dolist (x +delimiters+)
+ (push (cadr x) all-delimiters))
+ (delimiter-init)
+ (do ((beg start)
+ (pos nil)
+ (all all-delimiters)
+ (tok nil)
+ (tail toks))
+ ((not (< beg end))
+ ;; since input is complete check parens levels.
+ (delimiter-finish)
+ (if (null (cdr toks)) nil (cdr toks)))
+ (setq beg (advance-white str +whites+ beg end))
+ (setf tok
+ (read-delimited str :start beg :end end
+ :white +whites+ :delimit all
+ :skip-initial-white nil :errorf errf))
+ ;; multiple values are returned, so split them here:
+ (setf pos (second tok)) ; pos is the end of the token (!)
+ (setf tok (first tok))
+
+ (cond ((eql tok ':eof)
+ (setq beg end))
+ (t
+ ;; may have to skip over comments to reach token, so
+ ;; token beginning is computed by backing up from current
+ ;; position (returned by read-delimited) by string length
+ (setf beg (if (stringp tok)
+ (- pos (length tok))
+ (1- pos)))
+ (setq tok (classify-token tok beg str errf
+ +delimiters+ +operators+
+ +kwstyle+ reserved))
+ (delimiter-check tok)
+ ;(display "classify-token-result" tok)
+ (setf (cdr tail) (list tok ))
+ (setf tail (cdr tail))
+ (setq beg pos))))))
+
+
+(defun read-delimited (input &key (start 0) end (null-ok t)
+ (delimit +delims+) ; includes whites...
+ (white +whites+)
+ (skip-initial-white t)
+ (errorf #'pperror))
+ ;; read a substring from input, optionally skipping any white chars
+ ;; first. reading a comment delim equals end-of-line, input delim
+ ;; reads whole input, pound reads next token. call errf if error
+ ;(FORMAT T "~%READ-DELIMITED: ~S :START ~S :END ~S" input start end)
+ (let ((len (or end (length input))))
+ (while t ;; loop over comment lines
+ (when skip-initial-white
+ (setq start (advance-white input white start len)))
+ (if (< start len)
+ (let ((char (char input start)))
+ (setq end (search-delim input delimit start len))
+ (if (equal start end) ; have a delimiter
+ (cond ((char= char +semic+)
+ ;; comment skips to next line and try again...
+ (while (and (< start len)
+ (char/= (char input start) #\newline))
+ (incf start))
+ (cond ((< start len) ;; advance past comment and iterate
+ (incf start)
+ (setf skip-initial-white t))
+ (null-ok
+ (return (list ':eof end)))
+ (t
+ (errexit "Unexpected end of input"))))
+; ((char= char +pound+)
+; ;; read # dispatch
+; (read-hash input delimit start len errorf))
+ ((char= char +quote+)
+ ;; input delim reads whole input
+ (return (sal:read-string input delimit start len errorf)))
+ ((char= char +kwote+)
+ (errexit "Illegal delimiter" start))
+ (t ;; all other delimiters are tokens in and of themselves
+ (return (list char (+ start 1)))))
+ ; else part of (equal start end), so we have token before delimiter
+ (return (list (subseq input start end) end))))
+ ; else part of (< start len)...
+ (if null-ok
+ (return (list ':eof end))
+ (errexit "Unexpected end of input" start))))))
+
+
+(defparameter hash-readers
+ '(( #\t sal:read-bool)
+ ( #\f sal:read-bool)
+ ( #\? read-iftok)
+ ))
+
+
+(defun read-hash (str delims pos len errf)
+ (let ((e (+ pos 1)))
+ (if (< e len)
+ (let ((a (assoc (char str e) hash-readers)))
+ (if (not a)
+ (errexit "Illegal # character" e)
+ (funcall (cadr a) str delims e len errf)))
+ (errexit "Missing # character" pos))))
+
+
+(defun read-iftok (str delims pos len errf)
+ str delims len errf
+ (list (make-token :type ':? :string "#?" :lisp 'if
+ :start (- pos 1))
+ (+ pos 1)))
+
+; (sal:read-string str start len)
+
+(defun sal:read-bool (str delims pos len errf)
+ delims len errf
+ (let ((end (search-delim str delims pos len)))
+ (unless (= end (+ pos 1))
+ (errexit "Illegal # expression" (- pos 1)))
+ (list (let ((t? (char= (char str pos) #\t) ))
+ (make-token :type ':bool
+ :string (if t? "#t" "#f")
+ :lisp t?
+ :start (- pos 1)))
+ (+ pos 1))))
+
+
+(defun sal:read-string (str delims pos len errf)
+ (let* ((i (1+ pos)) ; i is index into string; start after open quote
+ c c2; c is the character at str[i]
+ (string (make-string-output-stream)))
+ ;; read string, processing escaped characters
+ ;; write the chars to string until end quote is found
+ ;; then retrieve the string. quotes are not included in result token
+
+ ;; in the loop, i is the next character location to examine
+ (while (and (< i len)
+ (not (char= (setf c (char str i)) +quote+)))
+ (if (char= c #\\) ;; escape character, does another character follow this?
+ (cond ((< (1+ i) len)
+ (incf i) ;; yes, set i so we'll get the escaped char
+ (setf c2 (char str i))
+ (setf c (assoc c2 `((#\n . #\newline) (#\t . #\tab)
+ (#\r . ,(char "\r" 0))
+ (#\f . ,(char "\f" 0)))))
+ (setf c (if c (cdr c) c2))) ;; use c2 if c wasn't listed
+ (t ;; no, we've hit the end of input too early
+ (errexit "Unmatched \"" i))))
+ ;; we're good to take this character and move on to the next one
+ (write-char c string)
+ (incf i))
+ ;; done with loop, so either we're out of string or we found end quote
+ (if (>= i len) (errexit "Unmatched \"" i))
+ ;; must have found the quote
+ (setf string (get-output-stream-string string))
+ (list (make-token :type :string :start pos :string string :lisp string)
+ (1+ i))))
+
+;;;
+;;; tokens
+;;;
+
+(defun make-token (&key (type nil) (string "") start (info nil) lisp)
+ (list :token type string start info lisp))
+(setfn token-type cadr)
+(setfn token-string caddr)
+(defun token-start (x) (cadddr x))
+(defun token-info (token) (car (cddddr token)))
+(defun token-lisp (token) (cadr (cddddr token)))
+(defmacro set-token-type (tok val) `(setf (car (cdr ,tok)) ,val))
+(defmacro set-token-lisp (tok val) `(setf (car (cdr (cddddr ,tok))) ,val))
+(defun tokenp (tok) (and (consp tok) (eq (car tok) :token)))
+
+(defun token=? (tok op)
+ (if (tokenp tok)
+ (equal (token-type tok) op)
+ (eql tok op)))
+
+(defmethod token-print (obj stream)
+ (let ((*print-case* ':downcase))
+ (format stream "#<~s ~s>"
+ (token-type obj)
+ (token-string obj))))
+
+(defun parse-token ()
+ (prog1 (car *sal-tokens*)
+ (setf *sal-tokens* (cdr *sal-tokens*))))
+
+;;;
+;;; token classification. types not disjoint!
+;;;
+
+(defun classify-token (str pos input errf delims ops kstyle res)
+ (let ((tok nil))
+ (cond ((characterp str)
+ ;; normalize char delimiter tokens
+ (setq tok (delimiter-token? str pos input errf delims)))
+ ((stringp str)
+ (setq tok (or (number-token? str pos input errf)
+ (operator-token? str pos input errf ops)
+ (keyword-token? str pos input errf kstyle)
+ (class-token? str pos input errf res)
+ (reserved-token? str pos input errf res)
+ (symbol-token? str pos input errf)
+ ))
+ (unless tok
+ (errexit "Not an expression or symbol" pos)))
+ (t (setq tok str)))
+ tok))
+
+
+(defun delimiter-token? (str pos input errf delims)
+ (let ((typ (member str delims :test (lambda (a b) (char= a (cadr b))))))
+ ;; member returns remainder of the list
+ ;(display "delimiter-token?" str delims typ)
+ (if (and typ (car typ) (caar typ))
+ (make-token :type (caar typ) :string str
+ :start pos)
+ (+ (break) (errexit "Shouldn't: non-token delimiter" pos)))))
+
+
+(defun string-to-number (s)
+ (read (make-string-input-stream s)))
+
+
+(defun number-token? (str pos input errf)
+ errf input
+ (do ((i 0 (+ i 1))
+ (len (length str))
+ (c nil)
+ (dot 0)
+ (typ ':int)
+ (sig 0)
+ (sla 0)
+ (dig 0)
+ (non nil))
+ ((or (not (< i len)) non)
+ (if non nil
+ (if (> dig 0)
+ (make-token :type typ :string str
+ :start pos :lisp (string-to-number str))
+ nil)))
+ (setq c (char str i))
+ (cond ((member c '(#\+ #\-))
+ (if (> i 0) (setq non t)
+ (incf sig)))
+ ((char= c #\.)
+ (if (> dot 0) (setq non t)
+ (if (> sla 0) (setq non t)
+ (incf dot))))
+; xlisp does not have ratios
+; ((char= c #\/)
+; (setq typ ':ratio)
+; (if (> sla 0) (setq non t)
+; (if (= dig 0) (setq non t)
+; (if (> dot 0) (setq non t)
+; (if (= i (1- len)) (setq non t)
+; (incf sla))))))
+ ((digit-char-p c)
+ (incf dig)
+ (if (> dot 0) (setq typ ':float)))
+ (t (setq non t)))))
+
+#||
+(number-token? "" 0 "" #'pperror)
+(number-token? " " 0 "" #'pperror)
+(number-token? "a" 0 "" #'pperror)
+(number-token? "1" 0 "" #'pperror)
+(number-token? "+" 0 "" #'pperror)
+(number-token? "-1/2" 0 "" #'pperror)
+(number-token? "1." 0 "" #'pperror)
+(number-token? "1.." 0 "" #'pperror)
+(number-token? ".1." 0 "" #'pperror)
+(number-token? ".1" 0 "" #'pperror)
+(number-token? "-0.1" 0 "" #'pperror)
+(number-token? "1/2" 0 "" #'pperror)
+(number-token? "1//2" 0 "" #'pperror)
+(number-token? "/12" 0 "" #'pperror)
+(number-token? "12/" 0 "" #'pperror)
+(number-token? "12/1" 0 "" #'pperror)
+(number-token? "12./1" 0 "" #'pperror)
+(number-token? "12/.1" 0 "" #'pperror)
+||#
+
+(defun operator-token? (str pos input errf ops)
+ ;; tok can be string or char
+ (let ((typ (member str ops :test (lambda (a b) (equal a (cadr b))))))
+ (cond (typ
+ (setf typ (car typ)) ;; member returns remainder of list
+ (make-token :type (car typ) :string str
+ :start pos :lisp (or (third typ)
+ (read-from-string str)))))))
+
+(defun str-to-keyword (str)
+ (intern (strcat ":" (string-upcase str))))
+
+
+(defun keyword-token? (tok pos input errf style)
+ (let* ((tlen (length tok))
+ (keys (cdr style))
+ (klen (length keys)))
+ (cond ((not (< klen tlen)) nil)
+ ((eql (car style) ':prefix)
+ (do ((i 0 (+ i 1))
+ (x nil))
+ ((or (not (< i klen)) x)
+ (if (not x)
+ (let ((sym (symbol-token? (subseq tok i)
+ pos input errf )))
+ (cond (sym
+ (set-token-type sym ':key)
+ (set-token-lisp sym
+ (str-to-keyword (token-string sym)))
+ sym)))
+ nil))
+ (unless (char= (char tok i) (nth i keys))
+ (setq x t))))
+ ((eql (car style) ':suffix)
+ (do ((j (- tlen klen) (+ j 1))
+ (i 0 (+ i 1))
+ (x nil))
+ ((or (not (< i klen)) x)
+ (if (not x)
+ (let ((sym (symbol-token? (subseq tok 0 (- tlen klen))
+ pos input errf )))
+ (cond (sym
+ (set-token-type sym ':key)
+ (set-token-lisp sym
+ (str-to-keyword (token-string sym)))
+ sym)))
+ nil))
+ (unless (char= (char tok j) (nth i keys))
+ (setq x t)))))))
+
+
+(setfn alpha-char-p both-case-p)
+
+
+(defun class-token? (str pos input errf res)
+ res
+ (let ((a (char str 0)))
+ (if (char= a #\<)
+ (let* ((l (length str))
+ (b (char str (- l 1))))
+ (if (char= b #\>)
+ (let ((tok (symbol-token? (subseq str 1 (- l 1))
+ pos input errf)))
+ ;; class token has <> removed!
+ (if tok (progn (set-token-type tok ':class)
+ tok)
+ (errexit "Not a class identifier" pos)))
+ (errexit "Not a class identifer" pos)))
+ nil)))
+
+; (keyword-token? ":asd" '(:prefix #\:))
+; (keyword-token? "asd" KSTYLE)
+; (keyword-token? "asd:" KSTYLE)
+; (keyword-token? "123:" KSTYLE)
+; (keyword-token? ":foo" '(:prefix #\:))
+; (keyword-token? "foo=" '(:suffix #\=))
+; (keyword-token? "--foo" '(:prefix #\- #\-))
+; (keyword-token? ":123" '(:suffix #\:))
+; (keyword-token? "--asd" '(:prefix #\-)) ; ok since -asd is legal symbol
+
+
+;; determine if str is a reserved word using reserved as the list of
+;; reserved words, of the form ((id string) (id string) ...) where
+;; id identifies the token, e.g. :to and string is the token, e.g. "to"
+;;
+(defun reserved-token? (str pos input errf reserved)
+ errf input
+ (let ((typ (member str reserved :test
+ (lambda (a b) (string-equal a (cadr b))))))
+ (if typ
+ (make-token :type (caar typ) :string str
+ :start pos)
+ nil)))
+
+
+(defun sal-string-to-symbol (str)
+ (let ((sym (intern (string-upcase str)))
+ sal-sym)
+ (cond ((and sym ;; (it might be "nil")
+ (setf sal-sym (get sym :sal-name)))
+ sal-sym)
+ (t sym))))
+
+
+(putprop 'simrep 'sal-simrep :sal-name)
+(putprop 'seqrep 'sal-seqrep :sal-name)
+
+(defun contains-op-char (s)
+ ;; assume most identifiers are very short, so we search
+ ;; over identifier letters, not over operator characters
+ ;; Minus (-) is so common, we don't complain about it.
+ (dotimes (i (length s))
+ (if (string-search (subseq s i (1+ i)) "*/+=<>!%^&|")
+ (return t))))
+
+(defun test-for-suspicious-symbol (token)
+ ;; assume token is of type :id
+ (let ((sym (token-lisp token))
+ (str (token-string token))
+ (pos (token-start token)))
+ (cond ((and sym ; nil is not suspicious, but it's not "boundp"
+ (not (fboundp sym)) ; existing functions not suspicious
+ (not (boundp sym)) ; existing globals not suspicious
+ (not (member sym *sal-local-variables*))
+ (not (eq sym '->)) ; used by make-markov, so let it pass
+ (contains-op-char str)) ; suspicious if embedded operators
+ (sal-warning
+ (strcat "Identifier contains operator character(s).\n"
+ " Perhaps you omitted spaces around an operator")
+ pos)))))
+
+
+(defun symbol-token? (str pos input errf)
+ ;; if a potential symbol is preceded by #, drop the #
+ (if (and (> (length str) 1)
+ (char= (char str 0) #\#))
+ ;; there are a couple of special cases: SAL defines #f and #?
+ (cond ((equal str "#f")
+ (return-from symbol-token?
+ (make-token :type ':id :string str :start pos :lisp nil)))
+ ((equal str "#?")
+ (return-from symbol-token?
+ (make-token :type ':id :string str :start pos :lisp 'if)))
+ (t
+ (setf str (subseq str 1)))))
+ ;; let's insist on at least one letter for sanity's sake
+ ;; exception: allow '-> because it is used in markov pattern specs
+ (do ((i 0 (+ i 1)) ; i is index into string
+ (bad "Not an expression or symbol")
+ (chr nil)
+ (ltr 0) ; ltr is count of alphabetic letters in string
+ (dot nil) ; dot is index of "."
+ (pkg nil) ; pkg is index if package name "xxx:" found
+ (len (length str))
+ (err nil))
+ ;; loop ends when i is at end of string or when err is set
+ ((or (not (< i len)) err)
+ (if (or (> ltr 0) ; must be at least one letter, or
+ (equal str "->")) ; symbol can be "->"
+ (let ((info ()) sym)
+ (if pkg (push (cons ':pkg pkg) info))
+ (if dot (push (cons ':slot dot) info))
+ ;(display "in symbol-token?" str)
+ (setf sym (sal-string-to-symbol str))
+ (make-token :type ':id :string str
+ :info info :start pos
+ :lisp sym))
+ nil))
+ (setq chr (char str i))
+ (cond ((alpha-char-p chr) (incf ltr))
+; need to allow arbitrary lisp symbols
+; ((member chr '(#\* #\+)) ;; special variable names can start/end
+; (if (< 0 i (- len 2)) ;; with + or *
+; (errexit bad pos)))
+ ((char= chr #\/) ;; embedded / is not allowed
+ (errexit bad pos))
+ ;((char= chr #\-) ;; hyphens are allowed anywhere in symbol
+ ; (if (= ltr 0)
+ ; (errexit errf input bad pos )
+ ; (setq ltr 0)
+ ; ))
+ ((char= chr #\$) (incf ltr)) ;; "$" is treated as a letter
+ ((char= chr #\:)
+ ; allowable forms are :foo, foo:bar, :foo:bar
+ (if (> i 0) ;; lisp keyword symbols ok
+ (cond ((= ltr 0)
+ (errexit bad pos))
+ ((not pkg)
+ (setq pkg i))
+ (t (errexit errf input
+ (format nil "Too many colons in ~s" str)
+ pos))))
+ (setq ltr 0))
+ ((char= chr #\.)
+ (if (or dot (= i 0) (= i (- len 1)))
+ (errexit bad pos)
+ (progn (setq dot i) (setq ltr 0)))))))
+
+
+; (let ((i "foo")) (symbol-token? i 0 i #'pperror))
+; (let ((i "foo..bar")) (symbol-token? i 0 i #'pperror))
+; (let ((i ".bar")) (symbol-token? i 0 i #'pperror))
+; (let ((i "bar.")) (symbol-token? i 0 i #'pperror))
+; (let ((i "1...")) (symbol-token? i 0 i #'pperror))
+; (let ((i "a1..." )) (symbol-token? i 0 i #'pperror))
+; (let ((i "a{b")) (symbol-token? i 0 i #'pperror))
+; (let ((i "foo-bar")) (symbol-token? i 0 i #'pperror))
+; (let ((i "123-a")) (symbol-token? i 0 i #'pperror))
+; (let ((i "1a23-a")) (symbol-token? i 0 i #'pperror))
+; (let ((i "*foo*")) (symbol-token? i 0 i #'pperror))
+; (let ((i "+foo+")) (symbol-token? i 0 i #'pperror))
+; (let ((i "foo+bar")) (symbol-token? i 0 i #'pperror))
+; (let ((i "foo/bar")) (symbol-token? i 0 i #'pperror))
+
+; (let ((i ":bar")) (symbol-token? i 0 i #'pperror))
+; (let ((i "::bar")) (symbol-token? i 0 i #'pperror))
+; (let ((i "foo:bar")) (symbol-token? i 0 i #'pperror))
+; (let ((i "cl-user:bar")) (symbol-token? i 0 i #'pperror))
+; (let ((i "cl-user::bar")) (symbol-token? i 0 i #'pperror))
+; (tokenize "aaa + bbb \"asdasdd\" aaa(1,2,3)")
+; (tokenize "aaa+bbb \"asdasdd\" aaa(1,2,3)")
+
+
+(setf *in-sal-parser* nil)
+
+;; line number info for debugging
+(setf *sal-line-number-info* t)
+(setf *sal-line* 0)
+
+(defun add-line-info-to-expression (expr token)
+ (let (line-no)
+ (cond ((and token ;; null token means do not change expr
+ *sal-line-number-info* ;; is this feature enabled?
+ (stringp *sal-input-text*))
+ ;; first, get line number
+ (setf line-no (pos-to-line (token-start token) *sal-input-text*))
+ `(prog2 (setf *sal-line* ,line-no) ,expr))
+ (t expr))))
+
+;; single statement is handled just like an expression
+(setfn add-line-info-to-stmt add-line-info-to-expression)
+
+;; list of statements is simple to handle: prepend SETF
+(defun add-line-info-to-stmts (stmts token)
+ (let (line-no)
+ (cond ((and *sal-line-number-info* ;; is this feature enabled?
+ (stringp *sal-input-text*))
+ (setf line-no (pos-to-line (token-start token) *sal-input-text*))
+ (cons `(setf *sal-line* ,line-no) stmts))
+ (t stmts))))
+
+
+;; PARSE-ERROR -- print error message, return from top-level
+;;
+(defun parse-error (e)
+ (unless (sal-error-line e)
+ (setf (sal-error-line e) *sal-input*))
+ (pperror e)
+ (return-from sal-parse (values nil e *sal-tokens*)))
+
+
+;; SAL-PARSE -- parse string or token input, translate to Lisp
+;;
+;; If input is text, *sal-input-text* is set to the text and
+;; read later (maybe) by ERREXIT.
+;; If input is a token list, it is assumed these are leftovers
+;; from tokenized text, so *sal-input-text* is already valid.
+;; *Therefore*, do not call sal-parse with tokens unless
+;; *sal-input-text* is set to the corresponding text.
+;;
+(defun sal-parse (grammar pat input multiple-statements file)
+ (progv '(*sal-input-file-name*) (list file)
+ (let (rslt expr rest)
+ ; ignore grammar and pat (just there for compatibility)
+ ; parse input and return lisp expression
+ (cond ((stringp input)
+ (setf *sal-input-text* input)
+ (setq input (tokenize input *reserved-words* #'parse-error))))
+ (setf *sal-input* input) ;; all input
+ (setf *sal-tokens* input) ;; current input
+ (cond ((null input)
+ (values t nil nil)) ; e.g. comments compile to nil
+ (t
+ (setf rslt (or (maybe-parse-command)
+ (maybe-parse-block)
+ (maybe-parse-conditional)
+ (maybe-parse-assignment)
+ (maybe-parse-loop)
+ (maybe-parse-exec)
+ (maybe-parse-exit)
+ (errexit "Syntax error")))
+ ;; note: there is a return-from parse in parse-error that
+ ;; returns (values nil error <unparsed-tokens>)
+ (cond ((and *sal-tokens* (not multiple-statements))
+ (errexit "leftover tokens")))
+ ;((null rslt)
+ ; (errexit "nothing to compile")))
+ (values t rslt *sal-tokens*))))))
+
+
+;; TOKEN-IS -- test if the type of next token matches expected type(s)
+;;
+;; type can be a list of possibilities or just a symbol
+;; Usually, suspicious-id-warn is true by default, and any symbol
+;; with embedded operator symbols, e.g. x+y results in a warning
+;; that this is an odd variable name. But if the symbol is declared
+;; as a local, a parameter, a function name, or a global variable,
+;; then the warning is suppressed.
+;;
+(defun token-is (type &optional (suspicious-id-warn t))
+ (let ((token-type
+ (if *sal-tokens* (token-type (car *sal-tokens*)) nil))
+ rslt)
+ ; input can be list of possible types or just a type:
+ (setf rslt (or (and (listp type)
+ (member token-type type))
+ (and (symbolp type) (eq token-type type))))
+ ; test if symbol has embedded operator characters:
+ (cond ((and rslt suspicious-id-warn (eq token-type :id))
+ (test-for-suspicious-symbol (car *sal-tokens*))))
+ rslt))
+
+
+(defun maybe-parse-command ()
+ (if (token-is '(:define :load :chdir :variable :function
+ ; :system
+ :play :print :display :plot))
+ (parse-command)
+ (if (and (token-is '(:return)) *audacity-top-level-return-flag*)
+ (parse-command))))
+
+
+(defun parse-command ()
+ (cond ((token-is '(:define :variable :function))
+ (parse-declaration))
+ ((token-is :load)
+ (parse-load))
+ ((token-is :chdir)
+ (parse-chdir))
+ ((token-is :play)
+ (parse-play))
+; ((token-is :system)
+; (parse-system))
+ ((token-is :print)
+ (parse-print-display :print 'sal-print))
+ ((token-is :display)
+ (parse-print-display :display 'display))
+ ((token-is :plot)
+ (parse-plot))
+ ((and *audacity-top-level-return-flag* (token-is :return))
+ (parse-return))
+; ((token-is :output)
+; (parse-output))
+ (t
+ (errexit "Command not found"))))
+
+
+(defun parse-stmt ()
+ (cond ((token-is :begin)
+ (parse-block))
+ ((token-is '(:if :when :unless))
+ (parse-conditional))
+ ((token-is :set)
+ (parse-assignment))
+ ((token-is :loop)
+ (parse-loop))
+ ((token-is :print)
+ (parse-print-display :print 'sal-print))
+ ((token-is :display)
+ (parse-print-display :display 'display))
+ ((token-is :plot)
+ (parse-plot))
+; ((token-is :output)
+; (parse-output))
+ ((token-is :exec)
+ (parse-exec))
+ ((token-is :exit)
+ (parse-exit))
+ ((token-is :return)
+ (parse-return))
+ ((token-is :load)
+ (parse-load))
+ ((token-is :chdir)
+ (parse-chdir))
+; ((token-is :system)
+; (parse-system))
+ ((token-is :play)
+ (parse-play))
+ (t
+ (errexit "Command not found"))))
+
+
+;; GET-PARM-NAMES -- given parms like (a b &key (x 1) (y 2)),
+;; return list of parameters: (a b x y)
+(defun get-parm-names (parms)
+ (let (rslt)
+ (dolist (p parms)
+ (cond ((symbolp p)
+ (if (eq p '&key) nil (push p rslt)))
+ (t (push (car p) rslt))))
+ (reverse rslt)))
+
+
+;; RETURNIZE -- make a statement (list) end with a sal-return-from
+;;
+;; SAL returns nil from begin-end statement lists
+;;
+(defun returnize (stmt)
+ (let (rev expr)
+ (setf rev (reverse stmt))
+ (setf expr (car rev)) ; last expression in list
+ (cond ((and (consp expr) (eq (car expr) 'sal-return-from))
+ stmt) ; already ends in sal-return-from
+ (t
+ (reverse (cons (list 'sal-return-from *sal-fn-name* nil)
+ rev))))))
+
+
+(defun parse-declaration ()
+ (if (token-is :define) (parse-token)) ; SAL extension: "define" is optional
+ (let (bindings setf-args formals parms stmt locals loc)
+ (cond ((token-is :variable)
+ (setf bindings (parse-bindings))
+ (setf loc *rslt*) ; the "variable" token
+ (dolist (b bindings)
+ (cond ((symbolp b)
+ (push b setf-args)
+ (push `(if (boundp ',b) ,b) setf-args))
+ (t
+ (push (first b) setf-args)
+ (push (second b) setf-args))))
+ (add-line-info-to-stmt (cons 'setf (reverse setf-args)) loc))
+ ((token-is :function)
+ (parse-token)
+ (if (token-is :id nil)
+ (setf *sal-fn-name* (token-lisp (parse-token)))
+ (errexit "function name expected here"))
+ (setf locals *sal-local-variables*)
+ (setf formals (parse-parms))
+ (setf stmt (parse-stmt))
+ ;; stmt may contain a return-from, so make this a progn or prog*
+ (cond ((and (consp stmt)
+ (not (eq (car stmt) 'progn))
+ (not (eq (car stmt) 'prog*)))
+ (setf stmt (list 'progn stmt))))
+ ;; need return to pop traceback stack
+ (setf stmt (returnize stmt))
+ ;; get list of parameter names
+ (setf parms (get-parm-names formals))
+ (setf *sal-local-variables* locals)
+ ;; build the defun
+ (prog1 (list 'defun *sal-fn-name* formals
+ (list 'sal-trace-enter
+ (list 'quote *sal-fn-name*)
+ (cons 'list parms)
+ (list 'quote parms))
+ stmt)
+ (setf *sal-fn-name* nil)))
+ (t
+ (errexit "bad syntax")))))
+
+
+(defun parse-one-parm (kargs)
+ ;; kargs is a flag indicating previous parameter was a keyword (all
+ ;; the following parameters must then also be keyword parameters)
+ ;; returns: (<keyword> <default>) or (nil <identifier>)
+ ;; where <keyword> is a keyword parameter name (nil if not a keyword parm)
+ ;; <default> is an expression for the default value
+ ;; <identifier> is the parameter name (if not a keyword parm)
+ (let (key default-value id)
+ (cond ((and kargs (token-is :id))
+ (errexit "positional parameter not allowed after keyword parameter"))
+ ((token-is :id)
+ ;(display "parse-one-1" (token-is :id) (car *sal-tokens*))
+ (setf id (token-lisp (parse-token)))
+ (push id *sal-local-variables*)
+ (list nil id))
+ ((token-is :key)
+ (setf key (sal-string-to-symbol (token-string (parse-token))))
+ (cond ((or (token-is :co) (token-is :rp))) ; no default value
+ (t
+ (setf default-value (parse-sexpr))))
+ (list key default-value))
+ (kargs
+ (errexit "expected keyword name"))
+ (t
+ (errexit "expected parameter name")))))
+
+
+(defun parse-parms ()
+ ;(display "parse-parms" *sal-tokens*)
+ (let (parms parm kargs expecting)
+ (if (token-is :lp)
+ (parse-token) ;; eat the left paren
+ (errexit "expected left parenthesis"))
+ (setf expecting (not (token-is :rp)))
+ (while expecting
+ (setf parm (parse-one-parm kargs))
+ ;(display "parm" parm)
+ ;; returns list of (kargs . parm)
+ (if (and (car parm) (not kargs)) ; kargs just set
+ (push '&key parms))
+ (setf kargs (car parm))
+ ;; normally push the <id>; for keyword parms, push id and default value
+ (push (if kargs parm (cadr parm)) parms)
+ (if (token-is :co)
+ (parse-token)
+ (setf expecting nil)))
+ (if (token-is :rp) (parse-token)
+ (errexit "expected right parenthesis"))
+ ;(display "parse-parms" (reverse parms))
+ (reverse parms)))
+
+
+(defun parse-bindings ()
+ (let (bindings bind)
+ (setf *rslt* (parse-token)) ; skip "variable" or "with"
+ ; return token as "extra" return value
+ (setf bind (parse-bind))
+ (push (if (second bind) bind (car bind))
+ bindings)
+ (while (token-is :co)
+ (parse-token)
+ (setf bind (parse-bind))
+ ;; if non-nil initializer, push (id expr)
+ (push (if (second bind) bind (car bind))
+ bindings))
+ (reverse bindings)))
+
+
+(defun parse-bind ()
+ (let (id val)
+ (if (token-is :id nil)
+ (setf id (token-lisp (parse-token)))
+ (errexit "expected a variable name"))
+ (cond ((token-is :=)
+ (parse-token)
+ (setf val (parse-sexpr))))
+ (push id *sal-local-variables*)
+ (list id val)))
+
+
+(defun parse-chdir ()
+ ;; assume next token is :chdir
+ (or (token-is :chdir) (error "parse-chdir internal error"))
+ (let (path loc)
+ (setf loc (parse-token))
+ (setf path (parse-path))
+ (add-line-info-to-stmt (list 'setdir path) loc)))
+
+
+(defun parse-play ()
+ ;; assume next token is :play
+ (or (token-is :play) (error "parse-play internal error"))
+ (let ((loc (parse-token)))
+ (add-line-info-to-stmt (list 'sal-play (parse-sexpr)) loc)))
+
+
+(defun parse-return ()
+ (or (token-is :return) (error "parse-return internal error"))
+ (let (loc expr)
+ ;; this seems to be a redundant test
+ (if (and (null *sal-fn-name*)
+ (not *audacity-top-level-return-flag*))
+ (errexit "Return must be inside a function body"))
+ (setf loc (parse-token))
+ (setf expr (parse-sexpr))
+ (if *sal-fn-name*
+ (add-line-info-to-stmt (list 'sal-return-from *sal-fn-name* expr) loc)
+ (list 'defun 'main '() (list 'sal-trace-enter '(quote main) '() '())
+ (add-line-info-to-stmt expr loc)))))
+
+
+(defun parse-load ()
+ ;; assume next token is :load
+ (or (token-is :load) (error "parse-load internal error"))
+ (let (path args loc)
+ (setf loc (parse-token))
+ (setf path (parse-path)) ; must return path or raise error
+ (setf args (parse-keyword-args))
+ (add-line-info-to-stmt (cons 'sal-load (cons path args)) loc)))
+
+(defun parse-keyword-args ()
+ (let (args)
+ (while (token-is :co)
+ (parse-token)
+ (cond ((token-is :key)
+ (push (token-value) args)
+ (push (parse-sexpr) args))))
+ (reverse args)))
+
+
+'(defun parse-system ()
+ ;; assume next token is :system
+ (or (token-is :system) (error "parse-system internal error"))
+ (let (path arg args)
+ (parse-token)
+ (setf path (parse-sexpr))
+ (list 'sal-system path)))
+
+
+(defun parse-path ()
+ (if (token-is '(:id :string))
+ (token-lisp (parse-token))
+ (errexit "path not found")))
+
+
+(defun parse-print-display (token function)
+ ;; assumes next token is :print
+ (or (token-is token) (error "parse-print-display internal error"))
+ (let (args arg loc)
+ (setf loc (parse-token))
+ (setf arg (parse-sexpr))
+ (setf args (list arg))
+ (while (token-is :co)
+ (parse-token) ; remove and ignore the comma
+ (setf arg (parse-sexpr))
+ (push arg args))
+ (add-line-info-to-stmt (cons function (reverse args)) loc)))
+
+(defun parse-plot ()
+ ;; assumes next token is :plot
+ (or (token-is :plot) (error "parse-plot internal error"))
+ (let (arg args loc)
+ (setf loc (parse-token))
+ (setf arg (parse-sexpr))
+ (setf args (list arg))
+ (cond ((token-is :co) ; get duration parameter
+ (parse-token) ; remove and ignore the comma
+ (setf arg (parse-sexpr))
+ (push arg args)
+ (cond ((token-is :co) ; get n points parameter
+ (parse-token) ; remove and ignore the comma
+ (setf arg (parse-sexpr))))))
+ (add-line-info-to-stmt (cons 's-plot (reverse args)) loc)))
+
+;(defun parse-output ()
+; ;; assume next token is :output
+; (or (token-is :output) (error "parse-output internal error"))
+; (parse-token)
+; (list 'sal-output (parse-sexpr)))
+
+
+(defun maybe-parse-block ()
+ (if (token-is :begin) (parse-block)))
+
+
+(defun parse-block ()
+ ;; assumes next token is :block
+ (or (token-is :begin) (error "parse-block internal error"))
+ (let (args stmts (locals *sal-local-variables*))
+ (parse-token)
+ (cond ((token-is :with)
+ (setf args (parse-bindings))))
+ (while (not (token-is :end))
+ (push (parse-stmt) stmts))
+ (parse-token)
+ (setf stmts (reverse stmts))
+ ;(display "parse-block" args stmts)
+ (setf *sal-local-variables* locals)
+ (cons 'prog* (cons args stmts))))
+
+
+;; MAKE-STATEMENT-LIST -- convert stmt to a stmt list
+;;
+;; if it is a (PROGN ...) then return cdr -- it's already a list
+;; otherwise, put single statement into a list
+;;
+(defun make-statement-list (stmt)
+ (cond ((atom stmt)
+ (list stmt))
+ ((eq (car stmt) 'progn)
+ (cdr stmt))
+ (t
+ (list stmt))))
+
+(setf *conditional-tokens* '(:if :when :unless))
+
+
+(defun maybe-parse-conditional ()
+ (if (token-is *conditional-tokens*)
+ (parse-conditional)))
+
+
+(defun parse-conditional ()
+ ;; assumes next token is :if
+ (or (token-is *conditional-tokens*)
+ (error "parse-conditional internal error"))
+ (let (test then-stmt else-stmt if-token)
+ (cond ((token-is :if)
+ (setf if-token (parse-token))
+ (setf test (parse-sexpr if-token))
+ (if (not (token-is :then))
+ (errexit "expected then after if"))
+ (parse-token)
+ (if (not (token-is :else)) ;; no then statement
+ (setf then-stmt (parse-stmt)))
+ (cond ((token-is :else)
+ (parse-token)
+ (setf else-stmt (parse-stmt))))
+ ;(display "cond" test then-stmt else-stmt)
+ (if else-stmt
+ (list 'if test then-stmt else-stmt)
+ (list 'if test then-stmt)))
+ ((token-is :when)
+ (parse-token)
+ (setf test (parse-sexpr))
+ (setf then-stmt (parse-stmt))
+ (cons 'when (cons test (make-statement-list then-stmt))))
+ ((token-is :unless)
+ (parse-token)
+ (setf test (parse-sexpr))
+ (setf else-stmt (parse-stmt))
+ (cons 'unless (cons test (make-statement-list else-stmt)))))))
+
+
+(defun maybe-parse-assignment ()
+ (if (token-is :set) (parse-assignment)))
+
+
+(defun parse-assignment ()
+ ;; first token must be set
+ (or (token-is :set) (error "parse-assignment internal error"))
+ (let (assignments rslt vref op expr set-token)
+ (setf set-token (parse-token))
+ (push (parse-assign) assignments) ; returns (target op value)
+ (while (token-is :co)
+ (parse-token) ; skip the comma
+ (push (parse-assign) assignments))
+ ; now assignments is ((target op value) (target op value)...)
+ (dolist (assign assignments)
+ (setf vref (first assign) op (second assign) expr (third assign))
+ (cond ((eq op '=))
+ ((eq op '-=) (setf expr `(diff ,vref ,expr)))
+ ((eq op '+=) (setf expr `(sum ,vref ,expr)))
+ ((eq op '*=) (setq expr `(mult ,vref ,expr)))
+ ((eq op '/=) (setq expr `(/ ,vref ,expr)))
+ ((eq op '&=) (setq expr `(nconc ,vref (list ,expr))))
+ ((eq op '@=) (setq expr `(cons ,expr ,vref)))
+ ((eq op '^=) (setq expr `(nconc ,vref (append ,expr nil))))
+ ((eq op '<=) (setq expr `(min ,vref ,expr)))
+ ((eq op '>=) (setq expr `(max ,vref ,expr)))
+ (t (errexit (format nil "unknown assignment operator ~A" op))))
+ (push (list 'setf vref expr) rslt))
+ (setf rslt (add-line-info-to-stmts rslt set-token))
+ (if (> (length rslt) 1)
+ (cons 'progn rslt)
+ (car rslt))))
+
+
+;; PARSE-ASSIGN -- based on parse-bind, but with different operators
+;;
+;; allows arbitrary term on left because it could be an array
+;; reference. After parsing, we can check that the target of the
+;; assignment is either an identifier or an (aref ...)
+;;
+(defun parse-assign ()
+ (let ((lhs (parse-term) op val))
+ (cond ((token-is '(:= :-= :+= :*= :/= :&= :@= :^= :<= :>=))
+ (setf op (parse-token))
+ (setf op (if (eq (token-type op) ':=) '= (token-lisp op)))
+ (setf val (parse-sexpr))))
+ (cond ((and (consp lhs) (eq (car lhs) 'aref))) ;; aref good
+ ((symbolp lhs)) ;; id good
+ (t (errexit "expected a variable name or array reference")))
+ (list lhs op val)))
+
+
+(defun maybe-parse-loop ()
+ (if (token-is :loop) (parse-loop)))
+
+
+;; loops are compiled to do*
+;; bindings go next as usual, but bindings include for variables
+;; and repeat is converted to a for +count+ from 0 to <sexpr>
+;; stepping is done after statement
+;; termination clauses are combined with OR and
+;; finally goes after termination
+;; statement goes in do* body
+;;
+(defun parse-loop ()
+ (or (token-is :loop) (error "parse-loop: internal error"))
+ (let (bindings termination-tests stmts sexpr rslt finally
+ loc
+ (locals *sal-local-variables*))
+ (parse-token) ; skip "loop"
+ (if (token-is :with)
+ (setf bindings (reverse (parse-bindings))))
+ (while (token-is '(:repeat :for))
+ (cond ((token-is :repeat)
+ (setf loc (parse-token))
+ (push (list 'sal:loopcount 0 '(1+ sal:loopcount)) bindings)
+ (setf sexpr (parse-sexpr loc)) ; get final count expression
+ (push (list 'sal:loopfinal sexpr) bindings)
+ (push '(>= sal:loopcount sal:loopfinal) termination-tests))
+ ((token-is :for)
+ (setf rslt (parse-for-clause))
+ ; there can be multiple bindings, build bindings in reverse
+ (cond ((first rslt)
+ (setf bindings (append (reverse (first rslt))
+ bindings))))
+ (if (second rslt) (push (second rslt) termination-tests)))))
+ (while (token-is '(:while :until))
+ (cond ((token-is :while)
+ (setf loc (parse-token))
+ (push (list 'not (parse-sexpr loc)) termination-tests))
+ ((token-is :until)
+ (setf loc (parse-token))
+ (push (parse-sexpr loc) termination-tests))))
+ ; (push (parse-stmt) stmts)
+ (while (not (token-is '(:end :finally)))
+ (push (parse-stmt) stmts))
+ (cond ((token-is :finally)
+ (parse-token) ; skip "finally"
+ (setf finally (parse-stmt))))
+ (if (token-is :end)
+ (parse-token)
+ (errexit "expected end after loop"))
+ (setf *sal-local-variables* locals)
+ `(do* ,(reverse bindings)
+ ,(list (or-ize (reverse termination-tests)) finally)
+ ,@(reverse stmts))))
+
+
+;; OR-IZE -- compute the OR of a list of expressions
+;;
+(defun or-ize (exprs)
+ (if (> (length exprs) 1) (cons 'or exprs)
+ (car exprs)))
+
+
+(defun maybe-parse-exec ()
+ (if (token-is :exec) (parse-exec)))
+
+
+(defun parse-exec ()
+ (or (token-is :exec) (error "parse-exec internal error"))
+ (let ((loc (parse-token))) ; skip the :exec
+ (parse-sexpr loc)))
+
+
+(defun maybe-parse-exit ()
+ (if (token-is :exit) (parse-exit)))
+
+
+(defun parse-exit ()
+ (let (tok loc)
+ (or (token-is :exit) (error "parse-exit internal error"))
+ (setf loc (parse-token)) ; skip the :exit
+ (cond ((token-is :id)
+ (setf tok (parse-token))
+ (cond ((eq (token-lisp tok) 'nyquist)
+ (add-line-info-to-stmt '(exit) loc))
+ ((eq (token-lisp tok) 'sal)
+ (add-line-info-to-stmt '(sal-exit) loc))
+ (t
+ (errexit "expected \"nyquist\" or \"sal\" after \"exit\""))))
+ (t
+ (add-line-info-to-stmt '(sal-exit) loc)))))
+
+
+;; PARSE-FOR-CLAUSE - returns (bindings term-test)
+;;
+(defun parse-for-clause ()
+ (or (token-is :for) (error "parse-for-clause: internal error"))
+ (let (id init next rslt binding term-test list-id loc)
+ (setf loc (parse-token)) ; skip for
+ (if (token-is :id)
+ (setf id (token-lisp (parse-token)))
+ (errexit "expected identifier after for"))
+ (cond ((token-is :=)
+ ;; if the clause is just for id = expr, then assume that
+ ;; expr depends on something that changes each iteration:
+ ;; recompute and assign expr to id each time around
+ (parse-token) ; skip "="
+ (setf init (parse-sexpr loc))
+ (cond ((token-is :then)
+ (parse-token) ; skip "then"
+ (setf binding (list id init (parse-sexpr loc))))
+ (t
+ (setf binding (list id init init))))
+ (setf binding (list binding)))
+ ((token-is :in)
+ (setf loc (parse-token)) ; skip "in"
+ (setf list-id (intern (format nil "SAL:~A-LIST" id)))
+ (setf binding
+ (list (list list-id (parse-sexpr loc)
+ (list 'cdr list-id))
+ (list id (list 'car list-id) (list 'car list-id))))
+ (setf term-test (list 'null list-id)))
+ ((token-is :over)
+ (setf loc (parse-token)) ; skip "over"
+ (setf start (parse-sexpr loc))
+#| (cond ((token-is :by)
+ (parse-token) ; skip "by"
+ (parse-sexpr))) ;-- I don't know what "by" means - RBD |#
+ (setf list-id (intern (format nil "SAL:~A-PATTERN" id)))
+ (setf binding
+ (list (list list-id start)
+ (list id (list 'next list-id) (list 'next list-id)))))
+ ((token-is '(:from :below :to :above :downto :by))
+ (cond ((token-is :from)
+ (setf loc (parse-token)) ; skip "from"
+ (setf init (parse-sexpr loc)))
+ (t
+ (setf init 0)))
+ (cond ((token-is :below)
+ (setf loc (parse-token)) ; skip "below"
+ (setf term-test (list '>= id (parse-sexpr loc))))
+ ((token-is :to)
+ (setf loc (parse-token)) ; skip "to"
+ (setf term-test (list '> id (parse-sexpr loc))))
+ ((token-is :above)
+ (setf loc (parse-token)) ; skip "above"
+ (setf term-test (list '<= id (parse-sexpr loc))))
+ ((token-is :downto)
+ (setf loc (parse-token)) ; skip "downto"
+ (setf term-test (list '< id (parse-sexpr loc)))))
+ (cond ((token-is :by)
+ (setf loc (parse-token)) ; skip "by"
+ (setf binding (list id init (list '+ id (parse-sexpr loc)))))
+ ((or (null term-test)
+ (and term-test (member (car term-test) '(>= >))))
+ (setf binding (list id init (list '1+ id))))
+ (t ; loop goes down because of "above" or "downto"
+ ; (display "for step" term-test)
+ (setf binding (list id init (list '1- id)))))
+ (setf binding (list binding)))
+ (t
+ (errexit "for statement syntax error")))
+ (list binding term-test)))
+
+
+;; parse-sexpr works by building a list: (term op term op term ...)
+;; later, the list is parsed again using operator precedence rules
+(defun parse-sexpr (&optional loc)
+ (let (term rslt)
+ (push (parse-term) rslt)
+ (while (token-is *sal-operators*)
+ (push (token-type (parse-token)) rslt)
+ (push (parse-term) rslt))
+ (setf rslt (reverse rslt))
+ ;(display "parse-sexpr before inf->pre" rslt)
+ (setf rslt (if (consp (cdr rslt))
+ (inf->pre rslt)
+ (car rslt)))
+ (if loc
+ (setf rslt (add-line-info-to-expression rslt loc)))
+ rslt))
+
+
+(defun get-lisp-op (op)
+ (third (assoc op +operators+)))
+
+
+;; a term is <unary-op> <term>, or
+;; ( <sexpr> ), or
+;; ? ( <sexpr> , <sexpr> , <sexpr> ), or
+;; <id>, or
+;; <id> ( <args> ), or
+;; <term> [ <sexpr> ]
+;; Since any term can be followed by indexing, handle everything
+;; but the indexing here in parse-term-1, then write parse-term
+;; to do term-1 followed by indexing operations
+;;
+(defun parse-term-1 ()
+ (let (sexpr id vars loopvar n)
+ (cond ((token-is '(:- :!))
+ (list (token-lisp (parse-token)) (parse-term)))
+ ((token-is :lp)
+ (parse-token) ; skip left paren
+ (setf sexpr (parse-sexpr))
+ (if (token-is :rp)
+ (parse-token)
+ (errexit "right parenthesis not found"))
+ sexpr)
+ ((token-is :?)
+ (parse-ifexpr))
+ ((token-is :lc)
+ (list 'quote (parse-list)))
+ ((token-is '(:int :float :bool :list :string))
+ ;(display "parse-term int float bool list string" (car *sal-tokens*))
+ (token-lisp (parse-token)))
+ ((token-is :id) ;; aref or funcall
+ (setf id (token-lisp (parse-token)))
+ ;; array indexing was here, but that only allows [x] after
+ ;; identifiers. Move this to expression parsing.
+ (cond ((token-is :lp)
+ (parse-token)
+ (setf sexpr (cons id (parse-pargs t)))
+ (if (token-is :rp)
+ (parse-token)
+ (errexit "right paren not found"))
+ sexpr)
+ (t id)))
+ ((token-is '(:seqv :seqrepv))
+ (setf id (intern (string-upcase (token-string (parse-token)))))
+ (display "parse-term-1" id)
+ (setf vars (parse-idlist))
+ (if (not (token-is :lp))
+ (errexit "expected list of behaviors"))
+ (parse-token)
+ (setf sexpr (parse-pargs nil))
+ ;; if this is seqrepv, move the first 2 parameters (loop var and
+ ;; count expression) in front of the var list
+ (cond ((eq id 'SEQREPV)
+ (setf loopvar (pop sexpr))
+ (if (not (and loopvar (symbolp loopvar)))
+ (errexit "expected identifier as first \"parameter\""))
+ (setf n (pop sexpr))
+ (if (null n)
+ (errexit "expected repetition count as second parameter"))
+ (setf vars (cons id (cons n vars)))))
+ (setf sexpr (cons id (cons vars sexpr)))
+ (if (token-is :rp)
+ (parse-token)
+ (errexit "right paren not found"))
+ sexpr)
+ (t
+ (errexit "expression not found")))))
+
+
+(defun parse-idlist ()
+ ; similar to parse-parms, but simpler because no keywords and default vals
+ (let (parms parm kargs expecting)
+ (if (token-is :lp) (parse-token) ;; eat the left paren
+ (errexit "expected left parenthesis"))
+ (setf expecting (not (token-is :rp)))
+ (while expecting
+ (if (token-is :id)
+ (push (token-lisp (parse-token)) parms)
+ (errexit "expected variable name"))
+ (if (token-is :co) (parse-token)
+ (setf expecting nil)))
+ (if (token-is :rp) (parse-token)
+ (errexit "expected right parenthesis"))
+ (reverse parms)))
+
+
+(defun parse-term ()
+ (let ((term (parse-term-1)))
+ ; (display "parse-term" term (token-is :lb))
+ (while (token-is :lb)
+ (parse-token)
+ (setf term (list 'aref term (parse-sexpr)))
+ (if (token-is :rb)
+ (parse-token)
+ (errexit "right bracket not found")))
+ term))
+
+
+(defun parse-ifexpr ()
+ (or (token-is :?) (error "parse-ifexpr internal error"))
+ (let (condition then-sexpr else-sexpr)
+ (parse-token) ; skip the :?
+ (if (token-is :lp) (parse-token) (errexit "expected left paren"))
+ (setf condition (parse-sexpr))
+ (if (token-is :co) (parse-token) (errexit "expected comma"))
+ (setf then-sexpr (parse-sexpr))
+ (if (token-is :co) (parse-token) (errexit "expected comma"))
+ (setf else-sexpr (parse-sexpr))
+ (if (token-is :rp) (parse-token) (errexit "expected left paren"))
+ (list 'if condition then-sexpr else-sexpr)))
+
+
+(defun keywordp (s)
+ (and (symbolp s) (eq (type-of (symbol-name s)) 'string)
+ (equal (char (symbol-name s) 0) #\:)))
+
+
+(defun functionp (x) (eq (type-of x) 'closure))
+
+
+(defun parse-pargs (keywords-allowed)
+ ;; get a list of sexprs. If keywords-allowed, then at any point
+ ;; the arg syntax can switch from [<co> <sexpr>]* to
+ ;; [<co> <keyword> <sexpr>]*
+ ;; also if keywords-allowed, it's a function call and the
+ ;; list may be empty. Otherwise, it's a list of indices and
+ ;; the list may not be empty
+ (let (pargs keyword-expected sexpr keyword)
+ (if (and keywords-allowed (token-is :rp))
+ nil ; return empty parameter list
+ (loop ; look for one or more [keyword] sexpr
+ ; optional keyword test
+ (setf keyword nil)
+ ; (display "pargs" (car *sal-tokens*))
+ (if (token-is :key)
+ (setf keyword (token-lisp (parse-token))))
+ ; (display "parse-pargs" keyword)
+ ; did we need a keyword?
+ (if (and keyword-expected (not keyword))
+ (errexit "expected keyword"))
+ ; was a keyword legal
+ (if (and keyword (not keywords-allowed))
+ (errexit "keyword not allowed here"))
+ (setf keyword-expected keyword) ; once we get a keyword, we need
+ ; one before each sexpr
+ ; now find sexpr
+ (setf sexpr (parse-sexpr))
+ (if keyword (push keyword pargs))
+ (push sexpr pargs)
+ ; (display "parse-pargs" keyword sexpr pargs)
+ (cond ((token-is :co)
+ (parse-token))
+ (t
+ (return (reverse pargs))))))))
+
+
+;; PARSE-LIST -- parse list in braces {}, return list not quoted list
+;;
+(defun parse-list ()
+ (or (token-is :lc) (error "parse-list internal error"))
+ (let (elts)
+ (parse-token)
+ (while (not (token-is :rc))
+ (cond ((token-is '(:int :float :id :bool :key :string))
+ (push (token-lisp (parse-token)) elts))
+ ((token-is *sal-operators*)
+ (push (intern (token-string (parse-token))) elts))
+ ((token-is :lc)
+ (push (parse-list) elts))
+ ((token-is :co)
+ (errexit "expected list element or right brace; do not use commas inside braces {}"))
+ (t
+ (errexit "expected list element or right brace"))))
+ (parse-token)
+ (reverse elts)))
+
+
+(defparameter *op-weights*
+ '(
+ (:\| 1)
+ (:& 2)
+ (:! 3)
+ (:= 4)
+ (:!= 4)
+ (:> 4)
+ (:>= 4)
+ (:< 4)
+ (:<= 4)
+ (:~= 4) ; general equality
+ (:+ 5)
+ (:- 5)
+ (:% 5)
+ (:* 6)
+ (:/ 6)
+ (:^ 7)
+ (:~ 8)
+ (:~~ 8)
+ (:@ 8)
+ (:@@ 8)))
+
+
+(defun is-op? (x)
+ ;; return op weight if x is operator
+ (let ((o (assoc (if (listp x) (token-type x) x)
+ *op-weights*)))
+ (and o (cadr o))))
+
+
+(defun inf->pre (inf)
+ ;; this does NOT rewrite subexpressions because parser applies rules
+ ;; depth-first so subexprs are already processed
+ (let (op lh rh w1)
+ (if (consp inf)
+ (do ()
+ ((null inf) lh)
+ (setq op (car inf)) ; look at each element of in
+ (pop inf)
+ (setq w1 (is-op? op))
+ (cond ((numberp w1) ; found op (w1 is precedence)
+ (do ((w2 nil)
+ (ok t)
+ (li (list)))
+ ((or (not inf) (not ok))
+ (setq rh (inf->pre (nreverse li)))
+ (setq lh (if lh (list (get-lisp-op op) lh rh)
+ (list (get-lisp-op op) rh nil))))
+ (setq w2 (is-op? (first inf)))
+ (cond ((and w2 (<= w2 w1))
+ (setq ok nil))
+ (t
+ (push (car inf) li)
+ (pop inf)))))
+ (t
+ (setq lh op))))
+ inf)))
+
diff --git a/Release/nyquist/sal.lsp b/Release/nyquist/sal.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..cbb451b1f268ad81a26ee0641316dcdf2f4c9689
--- /dev/null
+++ b/Release/nyquist/sal.lsp
@@ -0,0 +1,630 @@
+;;; **********************************************************************
+;;; Copyright (C) 2006 Rick Taube
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the Lisp Lesser Gnu Public License.
+;;; See http://www.cliki.net/LLGPL for the text of this agreement.
+;;; **********************************************************************
+
+;;; $Revision: 1.2 $
+;;; $Date: 2009-03-05 17:42:25 $
+
+;; DATA STRUCTURES AND ALGORITHMS (for sal.lsp and parse.lsp)
+;;
+;; TOKENIZE converts source language (a string) into a list of tokens
+;; each token is represented as follows:
+;; (:TOKEN <type> <string> <start> <info> <lisp>)
+;; where <type> is one of:
+;; :id -- an identifier
+;; :lp -- left paren
+;; :rp -- right paren
+;; :+, etc. -- operators
+;; :int -- an integer
+;; :float -- a float
+;; :print, etc. -- a reserved word
+;; <string> is the source string for the token
+;; <start> is the column of the string
+;; <info> and <lisp> are ??
+;; Tokenize uses a list of reserved words extracted from terminals in
+;; the grammar. Each reserved word has an associated token type, but
+;; all other identifiers are simply of type :ID.
+;;
+;; *** WHY REWRITE THE ORIGINAL PARSER? ***
+;; Originally, the code interpreted a grammar using a recursive pattern
+;; matcher, but XLISP does not have a huge stack and there were
+;; stack overflow problems because even relatively small expressions
+;; went through a very deep nesting of productions. E.g.
+;; "print note(between(30,odds(.5, 60, 90)))" 0 t nil))" was at recursion
+;; level 46 when the stack overflowed. The stack depth is 2000 or 4000,
+;; but all locals and parameters get pushed here, so since PARSE is the
+;; recursive function and it has lots of parameters and locals, it appears
+;; to use 80 elements in the stack per call.
+;; *** END ***
+;;
+;; The grammar for the recursive descent parser:
+;; note: [ <x> ] means optional <x>, <x>* means 0 or more of <x>
+;;
+;; <number> = <int> | <float>
+;; <atom> = <int> | <float> | <id> | <bool>
+;; <list> = { <elt>* }
+;; <elt> = <atom> | <list> | <string>
+;; <aref> = <id> <lb> <pargs> <rb>
+;; <ifexpr> = ? "(" <sexpr> , <sexpr> [ , <sexpr> ] ")"
+;; <funcall> = <id> <funargs>
+;; <funargs> = "(" [ <args> ] ")"
+;; <args> = <arg> [ , <arg> ]*
+;; <arg> = <sexpr> | <key> <sexpr>
+;; <op> = + | - | "*" | / | % | ^ | = | != |
+;; "<" | ">" | "<=" | ">=" | ~= | ! | & | "|"
+;; <mexpr> = <term> [ <op> <term> ]*
+;; <term> = <-> <term> | <!> <term> | "(" <mexpr> ")" |
+;; <ifexpr> | <funcall> | <aref> | <atom> | <list> | <string>
+;; <sexpr> = <mexpr> | <object> | class
+;; <top> = <command> | <block> | <conditional> | <assignment> | <loop> | <exec>
+;; <exec> = exec <sexpr>
+;; <command> = <define-cmd> | <file-cmd> | <output>
+;; <define-cmd> = define <declaration>
+;; <declaration> = <vardecl> | <fundecl>
+;; <vardecl> = variable <bindings>
+;; <bindings> = <bind> [ , <bind> ]*
+;; <bind> = <id> [ <=> <sexpr> ]
+;; <fundecl> = <function> <id> "(" [ <parms> ] ")" <statement>
+;; <parms> = <parm> [ , <parm> ]*
+;; this is new: key: expression for keyword parameter
+;; <parm> = <id> | <key> [ <sexpr> ]
+;; <statement> = <block> | <conditional> | <assignment> |
+;; <output-stmt> <loop-stmt> <return-from> | <exec>
+;; <block> = begin [ with <bindings> [ <statement> ]* end
+;; <conditional> = if <sexpr> then [ <statement> ] [ else <statement> ] |
+;; when <sexpr> <statement> | unless <sexpr> <statement>
+;; <assignment> = set <assign> [ , <assign> ]*
+;; <assign> = ( <aref> | <id> ) <assigner> <sexpr>
+;; <assigner> = = | += | *= | &= | @= | ^= | "<=" | ">="
+;; <file-cmd> = <load-cmd> | chdir <pathref> |
+;; system <pathref> | play <sexpr>
+;; (note: system was removed)
+;; <load-cmd> = load <pathref> [ , <key> <sexpr> ]*
+;; <pathref> = <string> | <id>
+;; <output-stmt> = print <sexpr> [ , <sexpr> ]* |
+;; output <sexpr>
+;; <loop-stmt> = loop [ with <bindings> ] [ <stepping> ]*
+;; [ <termination> ]* [ <statement> ]+
+;; [ finally <statement> ] end
+;; <stepping> = repeat <sexpr> |
+;; for <id> = <sexpr> [ then <sexpr> ] |
+;; for <id> in <sexpr> |
+;; for <id> over <sexpr> [ by <sexpr> ] |
+;; for <id> [ from <sexpr> ]
+;; [ ( below | to | above | downto ) <sexpr> ]
+;; [ by <sexpr> ] |
+;; <termination> = while <sexpr> | until <sexpr>
+;; <return-from> = return <sexpr>
+
+;(in-package cm)
+
+; (progn (cd "/Lisp/sal/") (load "parse.lisp") (load "sal.lisp"))
+
+(setfn defconstant setf)
+(setfn defparameter setf)
+(setfn defmethod defun)
+(setfn defvar setf)
+(setfn values list)
+(if (not (boundp '*sal-secondary-prompt*))
+ (setf *sal-secondary-prompt* t))
+(if (not (boundp '*sal-xlispbreak*))
+ (setf *sal-xlispbreak* nil))
+
+(defun sal-trace-enter (fn &optional argvals argnames)
+ (push (list fn *sal-line* argvals argnames) *sal-call-stack*))
+
+(defun sal-trace-exit ()
+ (setf *sal-line* (second (car *sal-call-stack*)))
+ (pop *sal-call-stack*))
+
+;; SAL-RETURN-FROM is generated by Sal compiler and
+;; performs a return as well as a sal-trace-exit()
+;;
+(defmacro sal-return-from (fn val)
+ `(prog ((sal:return-value ,val))
+ (setf *sal-line* (second (car *sal-call-stack*)))
+ (pop *sal-call-stack*)
+ (return-from ,fn sal:return-value)))
+
+
+(setf *sal-traceback* t)
+
+
+(defun sal-traceback (&optional (file t)
+ &aux comma name names line)
+ (format file "Call traceback:~%")
+ (setf line *sal-line*)
+ (dolist (frame *sal-call-stack*)
+ (setf comma "")
+ (format file " ~A" (car frame))
+ (cond ((symbolp (car frame))
+ (format file "(")
+ (setf names (cadddr frame))
+ (dolist (arg (caddr frame))
+ (setf name (car names))
+ (format file "~A~% ~A = ~A" comma name arg)
+ (setf names (cdr names))
+ (setf comma ","))
+ (format file ") at line ~A~%" line)
+ (setf line (second frame)))
+ (t
+ (format file "~%")))))
+
+
+'(defmacro defgrammer (sym rules &rest args)
+ `(defparameter ,sym
+ (make-grammer :rules ',rules ,@args)))
+
+'(defun make-grammer (&key rules literals)
+ (let ((g (list 'a-grammer rules literals)))
+ (grammer-initialize g)
+ g))
+
+'(defmethod grammer-initialize (obj)
+ (let (xlist)
+ ;; each literal is (:name "name")
+ (cond ((grammer-literals obj)
+ (dolist (x (grammer-literals obj))
+ (cond ((consp x)
+ (push x xlist))
+ (t
+ (push (list (string->keyword (string-upcase (string x)))
+ (string-downcase (string x)))
+ xlist)))))
+ (t
+ (dolist (x (grammer-rules obj))
+ (cond ((terminal-rule? x)
+ (push (list (car x)
+ (string-downcase (subseq (string (car x)) 1)))
+ xlist))))))
+ (set-grammer-literals obj (reverse xlist))))
+
+'(setfn grammer-rules cadr)
+'(setfn grammer-literals caddr)
+'(defun set-grammer-literals (obj val)
+ (setf (car (cddr obj)) val))
+'(defun is-grammer (obj) (and (consp obj) (eq (car obj) 'a-grammer)))
+
+(defun string->keyword (str)
+ (intern (strcat ":" (string-upcase str))))
+
+(defun terminal-rule? (rule)
+ (or (null (cdr rule)) (not (cadr rule))))
+
+(load "sal-parse.lsp" :verbose nil)
+
+(defparameter *sal-print-list* t)
+
+(defun sal-printer (x &key (stream *standard-output*) (add-space t)
+ (in-list nil))
+ (let ((*print-case* ':downcase))
+ (cond ((and (consp x) *sal-print-list*)
+ (write-char #\{ stream)
+ (do ((items x (cdr items)))
+ ((null items))
+ (sal-printer (car items) :stream stream
+ :add-space (cdr items) :in-list t)
+ (cond ((cdr items)
+ (cond ((not (consp (cdr items)))
+ (princ "<list not well-formed> " stream)
+ (sal-printer (cdr items) :stream stream :add-space nil)
+ (setf items nil))))))
+ (write-char #\} stream))
+ ((not x) (princ "#f" stream) )
+ ((eq x t) (princ "#t" stream))
+ (in-list (prin1 x stream))
+ (t (princ x stream)))
+ (if add-space (write-char #\space stream))))
+
+(defparameter *sal-printer* #'sal-printer)
+
+(defun sal-message (string &rest args)
+ (format t "~&; ")
+ (apply #'format t string args))
+
+
+;; sal-print has been modified from the original SAL to print items separated
+;; by spaces (no final trailing space) and followed by a newline.
+(defun sal-print (&rest args)
+ (do ((items args (cdr items)))
+ ((null items))
+ ;; add space unless we are at the last element
+ (funcall *sal-printer* (car items) :add-space (cdr items)))
+ (terpri)
+ (values))
+
+(defmacro keyword (sym)
+ `(str-to-keyword (symbol-name ',sym)))
+
+(defun plus (&rest nums)
+ (apply #'+ nums))
+
+(defun minus (num &rest nums)
+ (apply #'- num nums))
+
+(defun times (&rest nums)
+ (apply #'* nums))
+
+(defun divide (num &rest nums)
+ (apply #'/ num nums))
+
+;; implementation of infix "!=" operator
+(defun not-eql (x y)
+ (not (eql x y)))
+
+; dir "*.*
+; chdir
+; load "rts.sys"
+
+(defun sal-chdir ( dir)
+ (cd (expand-path-name dir))
+ (sal-message "Directory: ~A" (pwd))
+ (values))
+
+;;; sigh, not all lisps support ~/ directory components.
+
+(defun expand-path-name (path &optional absolute?)
+ (let ((dir (pathname-directory path)))
+ (flet ((curdir ()
+ (truename
+ (make-pathname :directory
+ (pathname-directory
+ *default-pathname-defaults*)))))
+ (cond ((null dir)
+ (if (equal path "~")
+ (namestring (user-homedir-pathname))
+ (if absolute?
+ (namestring (merge-pathnames path (curdir)))
+ (namestring path))))
+ ((eql (car dir) ':absolute)
+ (namestring path))
+ (t
+ (let* ((tok (second dir))
+ (len (length tok)))
+ (if (char= (char tok 0) #\~)
+ (let ((uhd (pathname-directory (user-homedir-pathname))))
+ (if (= len 1)
+ (namestring
+ (make-pathname :directory (append uhd (cddr dir))
+ :defaults path))
+ (namestring
+ (make-pathname :directory
+ (append (butlast uhd)
+ (list (subseq tok 1))
+ (cddr dir))
+ :defaults path))))
+ (if absolute?
+ (namestring (merge-pathnames path (curdir)))
+ (namestring path)))))))))
+
+
+(defun sal-load (filename &key (verbose t) print)
+ (progv '(*sal-input-file-name*) (list filename)
+ (prog (file extended-name)
+ ;; first try to load exact name
+ (cond ((setf file (open filename))
+ (close file) ;; found it: close it and load it
+ (return (generic-loader filename verbose print))))
+ ;; try to load name with ".sal" or ".lsp"
+ (cond ((string-search "." filename) ; already has extension
+ nil) ; don't try to add another extension
+ ((setf file (open (strcat filename ".sal")))
+ (close file)
+ (return (sal-loader (strcat filename ".sal")
+ :verbose verbose :print print)))
+ ((setf file (open (strcat filename ".lsp")))
+ (close file)
+ (return (lisp-loader filename :verbose verbose :print print))))
+ ;; search for file as is or with ".lsp" on path
+ (setf fullpath (find-in-xlisp-path filename))
+ (cond ((and (not fullpath) ; search for file.sal on path
+ (not (string-search "." filename))) ; no extension yet
+ (setf fullpath (find-in-xlisp-path (strcat filename ".sal")))))
+ (cond ((null fullpath)
+ (format t "sal-load: could not find ~A~%" filename))
+ (t
+ (return (generic-loader fullpath verbose print)))))))
+
+
+;; GENERIC-LOADER -- load a sal or lsp file based on extension
+;;
+;; assumes that file exists, and if no .sal extension, type is Lisp
+;;
+(defun generic-loader (fullpath verbose print)
+ (cond ((has-extension fullpath ".sal")
+ (sal-loader fullpath :verbose verbose :print print))
+ (t
+ (lisp-loader fullpath :verbose verbose :print print))))
+
+#|
+(defun sal-load (filename &key (verbose t) print)
+ (progv '(*sal-input-file-name*) (list filename)
+ (let (file extended-name)
+ (cond ((has-extension filename ".sal")
+ (sal-loader filename :verbose verbose :print print))
+ ((has-extension filename ".lsp")
+ (lisp-load filename :verbose verbose :print print))
+ ;; see if we can just open the exact filename and load it
+ ((setf file (open filename))
+ (close file)
+ (lisp-load filename :verbose verbose :print print))
+ ;; if not, then try loading file.sal and file.lsp
+ ((setf file (open (setf *sal-input-file-name*
+ (strcat filename ".sal"))))
+ (close file)
+ (sal-loader *sal-input-file-name* :verbose verbose :print print))
+ ((setf file (open (setf *sal-input-file-name*
+ (strcat filename ".lsp"))))
+ (close file)
+ (lisp-load *sal-input-file-name* :verbose verbose :print print))
+ (t
+ (format t "sal-load: could not find ~A~%" filename))))))
+|#
+
+(defun lisp-loader (filename &key (verbose t) print)
+ (if (load filename :verbose verbose :print print)
+ t ; be quiet if things work ok
+ (format t "error loading lisp file ~A~%" filename)))
+
+
+(defun has-extension (filename ext)
+ (let ((loc (string-search ext filename
+ :start (max 0 (- (length filename)
+ (length ext))))))
+ (not (null loc)))) ; coerce to t or nil
+
+
+(defmacro sal-at (s x) (list 'at x s))
+(defmacro sal-at-abs (s x) (list 'at-abs x s))
+(defmacro sal-stretch (s x) (list 'stretch x s))
+(defmacro sal-stretch-abs (s x) (list 'stretch-abs x s))
+
+;; splice every pair of lines
+(defun strcat-pairs (lines)
+ (let (rslt)
+ (while lines
+ (push (strcat (car lines) (cadr lines)) rslt)
+ (setf lines (cddr lines)))
+ (reverse rslt)))
+
+
+(defun strcat-list (lines)
+ ;; like (apply 'strcat lines), but does not use a lot of stack
+ ;; When there are too many lines, XLISP will overflow the stack
+ ;; because args go on the stack.
+ (let (r)
+ (while (> (setf len (length lines)) 1)
+ (if (oddp len) (setf lines (cons "" lines)))
+ (setf lines (strcat-pairs lines)))
+ ; if an empty list, return "", else list has one string: return it
+ (if (null lines) "" (car lines))))
+
+
+(defun sal-loader (filename &key verbose print)
+ (let ((input "") (file (open filename)) line lines)
+ (cond (file
+ (push filename *loadingfiles*)
+ (while (setf line (read-line file))
+ (push line lines)
+ (push "\n" lines))
+ (close file)
+ (setf input (strcat-list (reverse lines)))
+ (sal-trace-enter (strcat "Loading " filename))
+ (sal-compile input t t filename)
+ (pop *loadingfiles*)
+ (sal-trace-exit))
+ (t
+ (format t "error loading SAL file ~A~%" filename)))))
+
+
+; SYSTEM command is not implemented
+;(defun sal-system (sys &rest pairs)
+; (apply #'use-system sys pairs))
+
+
+(defun load-sal-file (file)
+ (with-open-file (f file :direction :input)
+ (let ((input (make-array '(512) :element-type 'character
+ :fill-pointer 0 :adjustable t)))
+ (loop with flag
+ for char = (read-char f nil ':eof)
+ until (or flag (eql char ':eof))
+ do
+ (when (char= char #\;)
+ (loop do (setq char (read-char f nil :eof))
+ until (or (eql char :eof)
+ (char= char #\newline))))
+ (unless (eql char ':eof)
+ (vector-push-extend char input)))
+ (sal input :pattern :command-sequence))))
+
+
+(defmacro sal-play (snd)
+ (if (stringp snd) `(play-file ,snd)
+ `(play ,snd)))
+
+
+(if (not (boundp '*sal-compiler-debug*))
+ (setf *sal-compiler-debug* nil))
+
+
+(defmacro sal-simrep (variable iterations body)
+ `(simrep (,variable ,iterations) ,body))
+
+
+(defmacro sal-seqrep (variable iterations body)
+ `(seqrep (,variable ,iterations) ,body))
+
+
+;; function called in sal programs to exit the sal read-compile-run-print loop
+(defun sal-exit () (setf *sal-exit* t))
+
+(setf *sal-call-stack* nil)
+
+;; read-eval-print loop for sal commands
+(defun sal ()
+ (progv '(*breakenable* *tracenable* *sal-exit* *sal-mode*)
+ (list *sal-break* *xlisp-traceback* nil t)
+ (let (input line)
+ (setf *sal-call-stack* nil)
+ (read-line) ; read the newline after the one the user
+ ; typed to invoke this fn
+ (princ "Entering SAL mode ...\n");
+ (while (not *sal-exit*)
+ (princ "\nSAL> ")
+ (sal-trace-enter "SAL top-level command interpreter")
+ ;; get input terminated by two returns
+ (setf input "")
+ (while (> (length (setf line (read-line))) 0)
+ (if *sal-secondary-prompt* (princ " ... "))
+ (setf input (strcat input "\n" line)))
+ ;; input may have an extra return, remaining from previous read
+ ;; if so, trim it because it affects line count in error messages
+ (if (and (> (length input) 0) (char= (char input 0) #\newline))
+ (setf input (subseq input 1)))
+ (sal-compile input t nil "<console>")
+ (sal-trace-exit))
+ (princ "Returning to Lisp ...\n")))
+ ;; in case *xlisp-break* or *xlisp-traceback* was set from SAL, impose
+ ;; them here
+ (cond ((not *sal-mode*)
+ (setf *breakenable* *xlisp-break*)
+ (setf *tracenable* *xlisp-traceback*)))
+ t)
+
+
+
+(defun sal-error-output (stack)
+ (if *sal-traceback* (sal-traceback))
+ (setf *sal-call-stack* stack)) ;; clear the stack
+
+
+;; when true, top-level return statement is legal and compiled into MAIN
+(setf *audacity-top-level-return-flag* nil)
+
+;; SAL-COMPILE-AUDACITY -- special treatment of RETURN
+;;
+;; This works like SAL-COMPILE, but if there is a top-level
+;; return statement (not normally legal), it is compiled into
+;; a function named MAIN. This is a shorthand for Audacity plug-ins
+;;
+(defun sal-compile-audacity (input eval-flag multiple-statements filename)
+ (progv '(*audacity-top-level-return-flag*) '(t)
+ (sal-compile input eval-flag multiple-statements filename)))
+
+
+;; SAL-COMPILE -- translate string or token list to lisp and eval
+;;
+;; input is either a string or a token list
+;; eval-flag tells whether to evaluate the program or return the lisp
+;; multiple-statements tells whether the input can contain multiple
+;; top-level units (e.g. from a file) or just one (from command line)
+;; returns:
+;; if eval-flag, then nothing is returned
+;; otherwise, returns nil if an error is encountered
+;; otherwise, returns a list (PROGN p1 p2 p3 ...) where pn are lisp
+;; expressions
+;;
+;; Note: replaced local variables here with "local" names to avoid
+;; collisions with globals that compiled code might try to use:
+;; eval uses local bindings, not global ones
+;;
+(defun sal-compile (sal:input sal:evflag sal:mult-stmts sal:filename)
+ ;; save some globals because eval could call back recursively
+ (progv '(*sal-tokens* *sal-input* *sal-input-text*) '(nil nil nil)
+ (let (sal:output sal:remainder sal:rslt sal:stack)
+ (setf sal:stack *sal-call-stack*)
+ ;; if first input char is "(", then eval as a lisp expression:
+ ;(display "sal-compile" sal:input)(setf *sal-compiler-debug* t)
+ (cond ((input-starts-with-open-paren sal:input)
+ ;(print "sal:input is lisp expression")
+ (errset
+ (print (eval (read (make-string-input-stream sal:input)))) t))
+ (t ;; compile SAL expression(s):
+ (loop
+ (setf sal:output (sal-parse nil nil sal:input sal:mult-stmts
+ sal:filename))
+ (cond ((first sal:output) ; successful parse
+ (setf sal:remainder *sal-tokens*)
+ (setf sal:output (second sal:output))
+ (when *sal-compiler-debug*
+ (terpri)
+ (pprint sal:output))
+ (cond (sal:evflag ;; evaluate the compiled code
+ (cond ((null (errset (eval sal:output) t))
+ (sal-error-output sal:stack)
+ (return)))) ;; stop on error
+ (t
+ (push sal:output sal:rslt)))
+ ;(display "sal-compile after eval"
+ ; sal:remainder *sal-tokens*)
+ ;; if there are statements left over, maybe compile again
+ (cond ((and sal:mult-stmts sal:remainder)
+ ;; move sal:remainder to sal:input and iterate
+ (setf sal:input sal:remainder))
+ ;; see if we've compiled everything
+ ((and (not sal:evflag) (not sal:remainder))
+ (return (cons 'progn (reverse sal:rslt))))
+ ;; if eval but no more sal:input, return
+ ((not sal:remainder)
+ (return))))
+ (t ; error encountered
+ (return)))))))))
+
+;; SAL just evaluates lisp expression if it starts with open-paren,
+;; but sometimes reader reads previous newline(s), so here we
+;; trim off initial newlines and check if first non-newline is open-paren
+(defun input-starts-with-open-paren (input)
+ (let ((i 0))
+ (while (and (stringp input)
+ (> (length input) i)
+ (eq (char input i) #\newline))
+ (incf i))
+ (and (stringp input)
+ (> (length input) i)
+ (eq (char input i) #\())))
+
+(defun sal-list-equal (a b)
+ (let ((rslt t)) ;; set to false if any element not equal
+ (dolist (x a)
+ (if (sal-equal x (car b))
+ t ;; continue comparing
+ (return (setf rslt nil))) ;; break out of loop
+ (setf b (cdr b)))
+ (and rslt (null b)))) ;; make sure no leftovers in b
+
+
+(defun sal-plus(a b &optional (source "+ operation in SAL"))
+ (ny:typecheck (not (or (numberp a) (soundp a) (multichannel-soundp a)))
+ (ny:error source 0 number-sound-anon a t))
+ (ny:typecheck (not (or (numberp b) (soundp b) (multichannel-soundp b)))
+ (ny:error source 0 number-sound-anon b t))
+ (nyq:add2 a b))
+
+
+(defun sal-equal (a b)
+ (or (and (numberp a) (numberp b) (= a b))
+ (and (consp a) (consp b) (sal-list-equal a b))
+ (equal a b)))
+
+(defun not-sal-equal (a b)
+ (not (sal-equal a b)))
+
+(defun sal-list-about-equal (a b)
+ (let ((rslt t)) ;; set to false if any element not equal
+ (dolist (x a)
+ (if (sal-about-equal x (car b))
+ t ;; continue comparing
+ (return (setf rslt nil))) ;; break out of loop
+ (setf b (cdr b)))
+ (and rslt (null b)))) ;; make sure no leftovers in b
+
+(setf *~=tolerance* 0.000001)
+
+(defun sal-about-equal (a b)
+ (or (and (numberp a) (numberp b) (< (abs (- a b)) *~=tolerance*))
+ (and (consp a) (consp b) (sal-list-about-equal a b))
+ (equal a b)))
diff --git a/Release/nyquist/seq.lsp b/Release/nyquist/seq.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..d360256057e98a2ae65ae008424961bdf4a3926d
--- /dev/null
+++ b/Release/nyquist/seq.lsp
@@ -0,0 +1,336 @@
+;; seq.lsp -- sequence control constructs for Nyquist
+
+;; get-srates -- this either returns the sample rate of a sound or a
+;; vector of sample rates of a vector of sounds
+;;
+(defun get-srates (sounds)
+ (cond ((arrayp sounds)
+ (let ((result (make-array (length sounds))))
+ (dotimes (i (length sounds))
+ (setf (aref result i) (snd-srate (aref sounds i))))
+ result))
+ (t
+ (snd-srate sounds))))
+
+; These are complex macros that implement sequences of various types.
+; The complexity is due to the fact that a behavior within a sequence
+; can reference the environment, e.g. (let ((p 60)) (seq (osc p) (osc p)))
+; is an example where p must be in the environment of each member of
+; the sequence. Since the execution of the sequence elements are delayed,
+; the environment must be captured and then used later. In XLISP, the
+; EVAL function does not execute in the current environment, so a special
+; EVAL, EVALHOOK must be used to evaluate with an environment. Another
+; feature of XLISP (see evalenv.lsp) is used to capture the environment
+; when the seq is first evaluated, so that the environment can be used
+; later. Finally, it is also necessary to save the current transformation
+; environment until later.
+;
+; The SEQ implementation passes an environment through closures that
+; are constructed to evaluate expressions. SEQREP is similar, but
+; the loop variable must be incremented and tested.
+;
+; Other considerations are that SEQ can handle multi-channel sounds, but
+; we don't know to call the snd_multiseq primitive until the first
+; SEQ expression is evaluated. Also, there's no real "NIL" for the end
+; of a sequence, so we need several special cases: (1) The sequences
+; is empty at the top level, so return silence, (2) There is one
+; expression, so just evaluate it, (3) there are 2 expressions, so
+; return the first followed by the second, (4) there are more than
+; 2 expressions, so return the first followed by what is effectively
+; a SEQ consisting of the remaining expressions.
+
+
+;; SEQ-EXPR-EXPAND - helper function, expands expression to push/pop entry
+;; on *sal-call-stack* to help debug calls into SAL from lazy evaluation
+;; of SAL code by SEQ
+(defun seq-expr-expand (expr source)
+ (if *sal-call-stack*
+ `(prog2 (sal-trace-enter '(,(strcat "Expression in " source ":") ,expr))
+ ,expr ;; here is where the seq behavior is evaluated
+ (sal-trace-exit))
+ expr))
+
+
+(defun with%environment (env expr)
+ ;; (progv (var1 ...) (val1 ...) expression-list)
+ `(progv ',*environment-variables* ,env ,expr))
+;(trace with%environment seq-expr-expand)
+
+(defmacro eval-seq-behavior (beh source)
+ ;(tracemacro 'eval-seq-behavior (list beh source)
+ (seq-expr-expand (with%environment 'nyq%environment
+ `(at-abs t0
+ (force-srates s%rate ,beh))) source));)
+
+;; Previous implementations grabbed the environment and passed it from
+;; closure to closure so that each behavior in the sequence could be
+;; evaluated in the saved environment using an evalhook trick. This
+;; version precomputes closures, which avoids using evalhook to get or
+;; use the environment. It's still tricky, because each behavior has
+;; to pass to snd-seq a closure that computes the remaining behavior
+;; sequence. To do this, I use a recursive macro to run down the
+;; behavior sequence, then as the recursion unwinds, construct nested
+;; closures that all capture the current environment. We end up with a
+;; closure we can apply to the current time to get a sound to return.
+;;
+(defmacro seq (&rest behlist)
+ ;; if we have no behaviors, return zero
+ (cond ((null behlist)
+ '(snd-zero (local-to-global 0) *sound-srate*))
+ (t ; we have behaviors. Must evaluate one to see if it is multichan:
+ `(let* ((first%sound ,(seq-expr-expand (car behlist) "SEQ"))
+ (s%rate (get-srates first%sound))
+ (nyq%environment (nyq:the-environment)))
+ ; if there's just one behavior, we have it and we're done:
+ ,(progn (setf behlist (cdr behlist))
+ (if (null behlist) 'first%sound
+ ; otherwise, start the recursive construction:
+ `(if (arrayp first%sound)
+ (seq2-deferred snd-multiseq ,behlist)
+ (seq2-deferred snd-seq ,behlist))))))))
+
+
+;; seq2-deferred uses seq2 and seq3 to construct nested closures for
+;; snd-seq. It is deferred so that we can first (in seq) determine whether
+;; this is a single- or multi-channel sound before recursively constructing
+;; the closures, since we only want to do it for either snd-seq or
+;; snd-multiseq, but not both. It simply calls seq2 to begin the expansion.
+;;
+(defmacro seq2-deferred (seq-prim behlist)
+ (seq2 seq-prim behlist))
+
+
+#|
+;; for debugging, you can replace references to snd-seq with this
+(defun snd-seq-trace (asound aclosure)
+ (princ "Evaluating SND-SEQ-TRACE instead of SND-SEQ...\n")
+ (format t " Sound argument is ~A\n" asound)
+ (princ " Closure argument is:\n")
+ (pprint (get-lambda-expression aclosure))
+ (princ " Calling SND-SEQ ...\n")
+ (let ((s (snd-seq asound aclosure)))
+ (format t " SND-SEQ returned ~A\n" s)
+ s))
+
+;; also for debugging, you can uncomment some tracemacro wrappers from
+;; macro definitions. This function prints what the macro expands to
+;; along with name and args (which you add by hand to the call):
+(defun tracemacro (name args expr)
+ (format t "Entered ~A with args:\n" name)
+ (pprint args)
+ (format t "Returned from ~A with expression:\n" name)
+ (pprint expr)
+ expr)
+|#
+
+
+;; we have at least 2 behaviors so we need the top level call to be
+;; a call to snd-multiseq or snd-seq. This macro constructs the call
+;; and uses recursion with seq3 to construct the remaining closures.
+;;
+(defun seq2 (seq-prim behlist)
+ `(,seq-prim first%sound
+ (prog1 ,(seq3 seq-prim behlist) ; <- passed to seq-prim
+ ;; we need to remove first%sound from the closure
+ ;; to avoid accumulating samples due to an unnecessary
+ ;; reference:
+ (setf first%sound nil))))
+
+;; construct a closure that evaluates to a sequence of behaviors.
+;; behlist has at least one behavior in it.
+;;
+(defun seq3 (seq-prim behlist)
+ `(lambda (t0)
+ (setf first%sound (eval-seq-behavior ,(car behlist) "SEQ"))
+ ,(progn (setf behlist (cdr behlist))
+ (if (null behlist) 'first%sound
+ (seq2 seq-prim behlist)))))
+
+
+; we have to use the real loop variable name since it could be
+; referred to by the sound expression, so we avoid name collisions
+; by using % in all the macro variable names
+;
+(defmacro seqrep (loop-control snd-expr)
+ ;(tracemacro "SEQREP" (list loop-control snd-expr)
+ `(let ((,(car loop-control) 0)
+ (loop%count ,(cadr loop-control))
+ (nyq%environment (nyq:the-environment))
+ s%rate seqrep%closure)
+ ; note: s%rate will tell whether we want a single or multichannel
+ ; sound, and what the sample rates should be.
+ (cond ((not (integerp loop%count))
+ (error "bad argument type" loop%count))
+ ((< loop%count 1)
+ (snd-zero (local-to-global 0) *sound-srate*))
+ ((= loop%count 1)
+ ,snd-expr)
+ (t ; more than 1 iterations
+ (setf loop%count (1- loop%count))
+ (setf first%sound ,snd-expr)
+ (setf s%rate (get-srates first%sound))
+ (setf nyq%environment (nyq:the-environment))
+ (if (arrayp first%sound)
+ (seqrep2 snd-multiseq ,loop-control ,snd-expr)
+ (seqrep2 snd-seq ,loop-control ,snd-expr))))));)
+
+
+(defmacro seqrep2 (seq-prim loop-control snd-expr)
+ ;(tracemacro "SEQREP2" (list seq-prim loop-control snd-expr)
+ `(progn (setf seqrep%closure
+ (lambda (t0) ,(seqrep-iterate seq-prim loop-control snd-expr)))
+ (,seq-prim (prog1 first%sound (setf first%sound nil))
+ seqrep%closure)));)
+
+
+(defun seqrep-iterate (seq-prim loop-control snd-expr)
+ (setf snd-expr `(eval-seq-behavior ,snd-expr "SEQREP"))
+ `(progn
+ (setf ,(car loop-control) (1+ ,(car loop-control))) ; incr. loop counter
+ (if (>= ,(car loop-control) loop%count) ; last iteration
+ ,snd-expr
+ (,seq-prim ,snd-expr seqrep%closure))))
+
+
+;; TRIGGER - sums instances of beh which are launched when input becomes
+;; positive (> 0). New in 2021: input is resampled to *sound-srate*.
+;; As before, beh sample rates must match, so now they must also be
+;; *sound-srate*. This implementation uses eval-seq-behavior to create
+;; a more helpful stack trace for SAL.
+(defmacro trigger (input beh)
+ `(let* ((nyq%environment (nyq:the-environment))
+ (s%rate *sound-srate*))
+ (snd-trigger (force-srate *sound-srate* ,input)
+ #'(lambda (t0) (eval-seq-behavior ,beh "TRIGGER")))))
+
+
+;; EVENT-EXPRESSION -- the sound of the event
+;;
+(setfn event-expression caddr)
+
+
+;; EVENT-HAS-ATTR -- test if event has attribute
+;;
+(defun event-has-attr (note attr)
+ (expr-has-attr (event-expression note)))
+
+
+;; EXPR-SET-ATTR -- new expression with attribute = value
+;;
+(defun expr-set-attr (expr attr value)
+ (cons (car expr) (list-set-attr-value (cdr expr) attr value)))
+
+(defun list-set-attr-value (lis attr value)
+ (cond ((null lis) (list attr value))
+ ((eq (car lis) attr)
+ (cons attr (cons value (cddr lis))))
+ (t
+ (cons (car lis)
+ (cons (cadr lis)
+ (list-set-attr-value (cddr lis) attr value))))))
+
+
+;; EXPAND-AND-EVAL-EXPR -- evaluate a note, chord, or rest for timed-seq
+;;
+(defun expand-and-eval-expr (expr)
+ (let ((pitch (member :pitch expr)))
+ (cond ((and pitch (cdr pitch) (listp (cadr pitch)))
+ (setf pitch (cadr pitch))
+ (simrep (i (length pitch))
+ (eval (expr-set-attr expr :pitch (nth i pitch)))))
+ (t
+ (eval expr)))))
+
+
+;; (timed-seq '((time1 stretch1 expr1) (time2 stretch2 expr2) ...))
+;; a timed-seq takes a list of events as shown above
+;; it sums the behaviors, similar to
+;; (sim (at time1 (stretch stretch1 expr1)) ...)
+;; but the implementation avoids starting all expressions at once
+;;
+;; Notes: (1) the times must be in increasing order
+;; (2) EVAL is used on each event, so events cannot refer to parameters
+;; or local variables
+;;
+;; If score events are very closely spaced (< 1020 samples), the block
+;; overlap can cause a ripple effect where to complete one block of the
+;; output, you have to compute part of the next score event, but then
+;; it in turn computes part of the next score event, and so on, until
+;; the stack overflows (if you have 1000's of events).
+;;
+;; This is really a fundamental problem in Nyquist because blocks are
+;; not aligned. To work around the problem (but not totally solve it)
+;; scores are evaluated up to a length of 100. If there are more than
+;; 100 score events, we form a balanced tree of adders so that maybe
+;; we will end up with a lot of sound in memory, but at least the
+;; stack will not overflow. Generally, we should not end up with more
+;; than 100 times as many blocks as we would like, but since the
+;; normal space required is O(1), we're still using constant space +
+;; a small constant * log(score-length).
+;;
+(setf MAX-LINEAR-SCORE-LEN 100)
+(defun timed-seq (score)
+ (must-be-valid-score "TIMED-SEQ" score)
+ (let ((len (length score))
+ pair)
+ (cond ((< len MAX-LINEAR-SCORE-LEN)
+ (timed-seq-linear score))
+ (t ;; split the score -- divide and conquer
+ (setf pair (score-split score (/ len 2)))
+ (sum (timed-seq (car pair)) (timed-seq (cdr pair)))))))
+
+;; score-split -- helper function: split score into two, with n elements
+;; in the first part; returns a dotted pair
+(defun score-split (score n)
+ ;; do the split without recursion to avoid stack overflow
+ ;; algorithm: modify the list destructively to get the first
+ ;; half. Copy it. Reassemble the list.
+ (let (pair last front back)
+ (setf last (nthcdr (1- n) score))
+ (setf back (cdr last))
+ (rplacd last nil)
+ (setf front (append score nil)) ; shallow copy
+ (rplacd last back)
+ (cons front back)))
+
+
+;; TIMED-SEQ-LINEAR - check to insure that times are strictly increasing
+;; and >= 0 and stretches are >= 0
+(defun timed-seq-linear (score)
+ (let ((start-time 0) error-msg rslt)
+ (dolist (event score)
+ (cond ((< (car event) start-time)
+ (error (format nil
+ "Out-of-order time in TIMED-SEQ: ~A, consider using SCORE-SORT"
+ event)))
+ ((< (cadr event) 0)
+ (error (format nil "Negative stretch factor in TIMED-SEQ: ~A" event)))
+ (t
+ (setf start-time (car event)))))
+ ;; remove rests (a rest has a :pitch attribute of nil)
+ (setf score (score-select score #'(lambda (tim dur evt)
+ (expr-get-attr evt :pitch t))))
+ (cond ((and score (car score)
+ (eq (car (event-expression (car score))) 'score-begin-end))
+ (setf score (cdr score)))) ; skip score-begin-end data
+ (cond ((null score) (s-rest 0))
+ (t
+ (at (caar score)
+ (seqrep (i (length score))
+ (progn
+ (cond (*sal-call-stack*
+ (sal-trace-enter (list "Score event:" (car score)) nil nil)
+ (setf *sal-line* 0)))
+ (setf rslt
+ (cond ((cdr score)
+ (prog1
+ (set-logical-stop
+ (stretch (cadar score)
+ (expand-and-eval-expr (caddar score)))
+ (- (caadr score) (caar score)))
+ (setf score (cdr score))))
+ (t
+ (stretch (cadar score) (expand-and-eval-expr
+ (caddar score))))))
+ (if *sal-call-stack* (sal-trace-exit))
+ rslt)))))))
diff --git a/Release/nyquist/seqfnint.lsp b/Release/nyquist/seqfnint.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..1f7b01bdee33ce33626bb32cf72c5bab583ab3fc
--- /dev/null
+++ b/Release/nyquist/seqfnint.lsp
@@ -0,0 +1,31 @@
+
+ (setfn seq-tag first)
+ (setfn seq-time second)
+ (setfn seq-line third)
+ (setfn seq-channel fourth)
+ (defun seq-value1 (e) (nth 4 e))
+ (setfn seq-pitch seq-value1) ; pitch of a note
+ (setfn seq-control seq-value1) ; control number of a control change
+ (setfn seq-program seq-value1) ; program number of a program change
+ (setfn seq-bend seq-value1) ; pitch bend amount
+ (setfn seq-touch seq-value1) ; aftertouch amount
+ (defun seq-value2 (e) (nth 5 e))
+ (setfn seq-velocity seq-value2) ; velocity of a note
+ (setfn seq-value seq-value2) ; value of a control change
+ (defun seq-duration (e) (nth 6 e))
+
+
+ (setf seq-done-tag 0)
+
+ (setf seq-other-tag 1)
+
+ (setf seq-note-tag 2)
+
+ (setf seq-ctrl-tag 3)
+
+ (setf seq-prgm-tag 4)
+
+ (setf seq-touch-tag 5)
+
+ (setf seq-bend-tag 6)
+
diff --git a/Release/nyquist/seqmidi.lsp b/Release/nyquist/seqmidi.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..bea71145daf1dd229d0f630ad727a2786fe76f1a
--- /dev/null
+++ b/Release/nyquist/seqmidi.lsp
@@ -0,0 +1,171 @@
+;; seqmidi.lsp -- functions to use MIDI files in Nyquist
+;
+; example call:
+;
+; (seq-midi my-seq
+; (note (chan pitch velocity) (= chan 2) (my-note pitch velocity))
+; (ctrl (chan control value) (...))
+; (bend (chan value) (...))
+; (touch (chan value) (...))
+; (prgm (chan value) (setf (aref my-prgm chan) value))
+
+;; seq-midi - a macro to create a sequence of sounds based on midi file
+;
+;
+(defmacro seq-midi (the-seq &rest cases)
+ (seq-midi-cases-syntax-check cases)
+ `(let (_the-event _next-time _the-seq _seq-midi-closure _nyq-environment
+ _the-seq _tag)
+ (setf _the-seq (seq-copy ,the-seq))
+ (setf _nyq-environment (nyq:the-environment))
+ (setf _seq-midi-closure #'(lambda (t0)
+ (format t "_seq_midi_closure: t0 = ~A~%" t0) ;DEBUG
+ (prog (_the-sound)
+loop ; go forward until we find note to play (we may be there)
+ ; then go forward to find time of next note
+ (setf _the-event (seq-get _the-seq))
+ ; (display "seq-midi" _the-event t0)
+ (setf _tag (seq-tag _the-event))
+ (cond ((= _tag seq-ctrl-tag)
+ ,(make-ctrl-handler cases))
+ ((= _tag seq-bend-tag)
+ ,(make-bend-handler cases))
+ ((= _tag seq-touch-tag)
+ ,(make-touch-handler cases))
+ ((= _tag seq-prgm-tag)
+ ,(make-prgm-handler cases))
+ ((= _tag seq-done-tag)
+ ; (format t "_seq_midi_closure: seq-done")
+ (cond (_the-sound ; this is the last sound of sequence
+ ; (format t "returning _the-sound~%")
+ (return _the-sound))
+ (t ; sequence is empty, return silence
+ ; (format t "returning snd-zero~%")
+ (return (snd-zero t0 *sound-srate*)))))
+ ((and (= _tag seq-note-tag)
+ ,(make-note-test cases))
+ (cond (_the-sound ; we now have time of next note
+ ; (display "note" (seq-time _the-event))
+ (setf _next-time (/ (seq-time _the-event) 1000.0))
+ (go exit-loop))
+ (t
+ (setf _the-sound ,(make-note-handler cases))))))
+ (seq-next _the-seq)
+ (go loop)
+exit-loop ; here, we know time of next note
+ (display "seq-midi" _next-time) ;DEBUG
+ (format t "seq-midi calling snd-seq\n") ;DEBUG
+ (return (snd-seq
+ (set-logical-stop-abs _the-sound
+ (local-to-global _next-time))
+ _seq-midi-closure)))))
+ (display "calling closure" (get-lambda-expression _seq-midi-closure)) ; DEBUG
+ (funcall _seq-midi-closure (local-to-global 0))))
+
+
+(defun seq-midi-cases-syntax-check (cases &aux n)
+ (cond ((not (listp cases))
+ (break "syntax error in" cases)))
+ (dolist (case cases)
+ (cond ((or (not (listp case))
+ (not (member (car case) '(NOTE CTRL BEND TOUCH PRGM)))
+ (not (listp (cdr case)))
+ (not (listp (cadr case)))
+ (not (listp (cddr case)))
+ (not (listp (last (cddr case)))))
+ (break "syntax error in" case))
+ ((/= (length (cadr case))
+ (setf n (cdr (assoc (car case)
+ '((NOTE . 3) (CTRL . 3) (BEND . 2)
+ (TOUCH . 2) (PRGM . 2))))))
+ (break (format nil "expecting ~A arguments in" n) case))
+ ((and (eq (car case) 'NOTE)
+ (not (member (length (cddr case)) '(1 2))))
+ (break
+ "note handler syntax is (NOTE (ch pitch vel) [filter] behavior)"
+ case)))))
+
+
+(defun make-ctrl-handler (cases)
+ (let ((case (assoc 'ctrl cases)))
+ (cond (case
+ `(let ((,(caadr case) (seq-channel _the-event))
+ (,(cadadr case) (seq-control _the-event))
+ (,(caddar (cdr case)) (seq-value _the-event)))
+ ,@(cddr case)))
+ (t nil))))
+
+(defun make-bend-handler (cases)
+ (let ((case (assoc 'bend cases)))
+ (cond (case
+ `(let ((,(caadr case) (seq-channel _the-event))
+ (,(cadadr case) (seq-value _the-event)))
+ ,@(cddr case)))
+ (t nil))))
+
+(defun make-touch-handler (cases)
+ (let ((case (assoc 'touch cases)))
+ (cond (case
+ `(let ((,(caadr case) (seq-channel _the-event))
+ (,(cadadr case) (seq-value _the-event)))
+ ,@(cddr case)))
+ (t nil))))
+
+(defun make-prgm-handler (cases)
+ (let ((case (assoc 'pgrm cases)))
+ (cond (case
+ `(let ((,(caadr case) (seq-channel _the-event))
+ (,(cadadr case) (seq-value _the-event)))
+ ,@(cddr case)))
+ (t nil))))
+
+(defun make-note-test (cases)
+ (let ((case (assoc 'note cases)))
+ (cond ((and case (cdddr case))
+ (caddr case))
+ (t t))))
+
+
+(defun make-note-handler (cases)
+ (let ((case (assoc 'note cases))
+ behavior)
+ (cond ((and case (cdddr case))
+ (setf behavior (cadddr case)))
+ (t
+ (setf behavior (caddr case))))
+ `(with%environment _nyq-environment
+ (with-note-args ,(cadr case) _the-event ,behavior))))
+
+
+(defmacro with-note-args (note-args the-event note-behavior)
+ ; (display "with-note-args" the-event)
+ `(let ((,(car note-args) (seq-channel ,the-event))
+ (,(cadr note-args) (seq-pitch ,the-event))
+ (,(caddr note-args) (seq-velocity ,the-event)))
+ (at (/ (seq-time ,the-event) 1000.0)
+ (stretch (/ (seq-duration ,the-event) 1000.0) ,note-behavior))))
+
+
+;(defun seq-next-note-time (the-seq find-first-flag)
+; (prog (event)
+; (if find-first-flag nil (seq-next the-seq))
+;loop
+; (setf event (seq-get the-seq))
+; (cond ((eq (seq-tag event) seq-done-tag)
+; (return (if find-first-flag 0.0 nil)))
+; ((eq (seq-tag event) seq-note-tag)
+; (return (/ (seq-time event) 1000.0))))
+; (seq-next the-seq)
+; (go loop)))
+;
+
+;; for SAL we can't pass in lisp expressions as arguments, so
+;; we pass in functions instead, using keyword parameters for
+;; ctrl, bend, touch, and prgm. The note parameter is required.
+;;
+(defun seq-midi-sal (seq note &optional ctrl bend touch prgm)
+ (seq-midi seq (note (chan pitch vel) (funcall note chan pitch vel))
+ (ctrl (chan num val) (if ctrl (funcall ctrl chan num val)))
+ (bend (chan val) (if bend (funcall bend chan val)))
+ (touch (chan val) (if touch (funcall touch chan val)))
+ (prgm (chan val) (if prgm (funcall prgm chan val)))))
diff --git a/Release/nyquist/sliders.lsp b/Release/nyquist/sliders.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..292e87c6e1a07457fc25e3e7bee61312317cc765
--- /dev/null
+++ b/Release/nyquist/sliders.lsp
@@ -0,0 +1,196 @@
+;; sliders.lsp -- communicate with NyquistIDE to implement control panels
+;; Roger B. Dannenberg
+;; April 2015
+
+;; (stop-on-zero s) -- a sound that returns 1 until s goes to zero, then
+;; the sound terminates. If s comes from a slider and you multiply
+;; a sound by (stop-on-zero s), you can interactively stop it
+;; (make-slider-panel "name" color) -- sets panel name for the following
+;; sliders
+;; (make-slider "param" [initial [low high]]) -- create slider named
+;; "param" with optional range and initial value. Also returns
+;; a sound.
+;; (make-button "param" normal) -- create a button named "param" with
+;; a starting value of normal (either 0 or 1). While the button
+;; in the panel is pressed, the value changes to 1 or 0.
+;; (get-slider-value "param") -- when called with a string, this looks up
+;; the slider value by name
+;; (slider-panel-close "name") -- close the panel window. Values of any
+;; existing sliders become undefined.
+;; (slider "panel" "name" [dur]) -- make a signal from slider value
+;; (slider "name" [dur]) -- make a signal from slider in current panel
+;; (get-slider-value "panel" "name") -- get a float value
+;; (get-slider-value "name") -- get a float in current panel
+
+;; *active-slider-panel* is the current panel to which sliders are added
+;;
+(if (not (boundp '*active-slider-panel*))
+ (setf *active-slider-panel* nil))
+
+;; *panels-in-use* is an assoc list of panels, where each panel
+;; is a list of allocated sliders stored as (name number)
+;;
+(if (not (boundp '*panels-in-use*))
+ (setf *panels-in-use* nil))
+
+;; allocate-slider-num -- find an unused slider number
+;; linear search is used to avoid maintaining a parallel structure
+;; for faster searching. We search starting at slider #10, leaving
+;; sliders 0-9 unused; for example, you might want to control them
+;; via open sound control, so this gives you 10 sliders that are
+;; off limits to allocation by the SLIDER function.
+;;
+;; This code takes advantage of the fact that dotimes and dolist
+;; return nil when they end normally, so we signal that we found
+;; or did not find i by explicitly returning. Note that RETURN
+;; returns from the innermost dotimes or dolist -- they do not
+;; return from allocate-slider-num.
+;;
+(defun allocate-slider-num ()
+ (dotimes (n 990)
+ (let ((i (+ n 10)))
+ (cond ((not (dolist (panel *panels-in-use*)
+ (cond ((dolist (pair (cdr panel))
+ (cond ((eql (second pair) i) (return t))))
+ (return t)))))
+ (return i))))))
+
+;; remove panel from list of panels
+(defun slider-panel-free (panel)
+ (setf *panels-in-use* (remove panel *panels-in-use* :test #'equal)))
+
+(setfn stop-on-zero snd-stoponzero)
+
+(defun make-slider-panel (name &optional (color 0))
+ (let ((panel (assoc name *panels-in-use* :test #'equal)))
+ ;; first find if panel already exists. If so, free the resources
+ (cond (panel
+ (slider-panel-free panel)))
+ (setf *active-slider-panel* (list name))
+ (setf *panels-in-use* (cons *active-slider-panel* *panels-in-use*))
+ (format t "slider-panel-create: \"~A\" ~A~%" name color)))
+
+(defun make-slider (name &optional (init 0) (low 0) (high 1))
+ (let ((num (allocate-slider-num)))
+ (cond ((null num)
+ (format t "WARNING: MAKE-SLIDER is out of slider numbers. ~A~%"
+ "No slider created."))
+ ((not (and (stringp name) (numberp init)
+ (numberp low) (numberp high)))
+ (display
+ "WARNING: MAKE-SLIDER called with bad arguments. No slider created"
+ name init low high)))
+ ;; make sure we have an active panel
+ (cond ((null *active-slider-panel*)
+ (make-slider-panel "Controls")))
+ ;; insert new slider into list of sliders in active panel. This
+ ;; is aliased with an element in the assoc list *panels-in-use*.
+ (rplacd *active-slider-panel* (cons (list name num)
+ (cdr *active-slider-panel*)))
+ (format t "slider-create: \"~A\" ~A ~A ~A ~A~%" name num init low high)
+ num))
+
+(defun make-button (name &optional (normal 0))
+ (let ((num (allocate-slider-num)))
+ (cond ((null num)
+ (format t "WARNING: MAKE-BUTTON is out of slider numbers. ~A~%"
+ "No button created."))
+ ((not (and (stringp name) (numberp normal)))
+ (display
+ "WARNING: MAKE-BUTTON called with bad arguments. No button created"
+ name normal)))
+ ;; make sure we have an active panel
+ (cond ((null *active-slider-panel*)
+ (slider-panel "Controls")))
+ ;; insert new button into list of controls in active panel. This
+ ;; is aliased with an element in the assoc list *panels-in-use*.
+ (rplacd *active-slider-panel* (cons (list name num)
+ (cdr *active-slider-panel*)))
+ (format t "button-create: \"~A\" ~A ~A~%" name num normal)
+ num))
+
+(defun close-slider-panel (name)
+ (let ((panel (assoc name *panels-in-use* :test #'equal)))
+ (cond ((not (stringp name))
+ (display "WARNING: SLIDER-PANEL-CLOSED called with bad argument."
+ name)))
+ (cond (panel
+ (slider-panel-free panel)
+ (format t "slider-panel-close: \"~A\"~%" name))
+ (t
+ (format t "WARNING: slider panel ~A not found.~%" name)))))
+
+;; SLIDER-LOOKUP - find the slider by name
+;;
+(defun slider-lookup (name slider)
+ (let ((panel (assoc name *panels-in-use* :test #'equal)) s)
+ (cond ((null panel)
+ (error "Could not find slider panel named" name)))
+ (setf s (assoc slider (cdr panel) :test #'equal))
+ (cond ((null s)
+ (error "Could not find slider named" s)))
+ (second s)))
+
+
+;; SLIDER - creates a signal from real-time slider input
+;;
+;; options are:
+;; (SLIDER number [dur])
+;; (SLIDER "name" [dur]) -- look up slider in current slider panel
+;; (SLIDER "panel" "name" [dur]) -- look up panel, then look up slider
+;;
+(defun slider (id &optional slider-name dur)
+ (cond ((and (numberp id) (null slider-name))
+ (setf dur 1.0))
+ ((and (numberp id) (numberp slider-name) (null dur))
+ (setf dur slider-name))
+ ((and (stringp id) (null slider-name))
+ (setf dur 1.0)
+ (setf id (slider-lookup (car *active-slider-panel*) id)))
+ ((and (stringp id) (numberp slider-name) (null dur))
+ (setf dur slider-name)
+ (setf id (slider-lookup (car *active-slider-panel*) id)))
+ ((and (stringp id) (stringp slider-name) (null dur))
+ (setf dur 1.0)
+ (setf id (slider-lookup id slider-name)))
+ ((and (stringp id) (stringp slider-name) (numberp dur))
+ (setf id (slider-lookup id slider-name)))
+ (t
+ (error "SLIDER called with invalid arguments")))
+ (setf dur (get-duration dur))
+ (setf id (round id)) ;; just to make sure it's an integer
+ (cond ((or (< id 0) (>= id 1000))
+ (error "SLIDER index out of bounds" id)))
+ (display "slider" id slider-name dur)
+ (snd-slider id *rslt* *sound-srate* dur))
+
+
+(if (not (boundp '*lpslider-cutoff*))
+ (setf *lpslider-cutoff* 20.0))
+
+(defun lpslider (id &optional slider-name dur)
+ (lp (slider id slider-name dur) 20.0))
+
+;; save built-in get-slider-value so we can redefine it
+(if (not (fboundp 'prim-get-slider-value))
+ (setfn prim-get-slider-value get-slider-value))
+
+(defun get-slider-value (id &optional slider-name)
+ (cond ((and (numberp id) (null slider-name)) nil)
+ ((and (stringp id) (null slider-name))
+ (setf id (slider-lookup (car *active-slider-pael*) id)))
+ ((and (stringp id) (stringp slider-name))
+ (setf id (slider-lookup id slider-name)))
+ (t
+ (error "GET-SLIDER-VALUE called with invalid arguments")))
+ ;; further parameter checking is done in get-slider-value:
+ (prim-get-slider-value id))
+
+(autonorm-off)
+(snd-set-latency 0.02)
+(print "**********sliders.lsp************************")
+(print "WARNING: AUTONORM IS NOW TURNED OFF")
+(print "WARNING: AUDIO LATENCY SET TO 20MS")
+(print "To restore settings, execute (autonorm-on) and")
+(print " (set-audio-latency 0.3)")
+(print "*********************************************")
diff --git a/Release/nyquist/sndfnint.lsp b/Release/nyquist/sndfnint.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..015191b241c368069aaee644c3f52acb095f5672
--- /dev/null
+++ b/Release/nyquist/sndfnint.lsp
@@ -0,0 +1,92 @@
+ (SETF MAX-STOP-TIME 10E20)
+
+ (SETF MIN-START-TIME -10E20)
+
+ (setf OP-AVERAGE 1) (setf OP-PEAK 2)
+
+ (setf snd-head-none 0)
+
+ (setf snd-head-AIFF 1)
+
+ (setf snd-head-IRCAM 2)
+
+ (setf snd-head-NeXT 3)
+
+ (setf snd-head-Wave 4)
+
+ (setf snd-head-PAF 5)
+
+ (setf snd-head-SVX 6)
+
+ (setf snd-head-NIST 7)
+
+ (setf snd-head-VOC 8)
+
+ (setf snd-head-W64 9)
+
+ (setf snd-head-MAT4 10)
+
+ (setf snd-head-MAT5 11)
+
+ (setf snd-head-PVF 12)
+
+ (setf snd-head-XI 13)
+
+ (setf snd-head-HTK 14)
+
+ (setf snd-head-SDS 15)
+
+ (setf snd-head-AVR 16)
+
+ (setf snd-head-SD2 17)
+
+ (setf snd-head-FLAC 18)
+
+ (setf snd-head-CAF 19)
+
+ (setf snd-head-raw 20)
+
+ (setf snd-head-OGG 21)
+
+ (setf snd-head-WAVEX 22)
+
+ (setf snd-head-channels 1)
+
+ (setf snd-head-mode 2)
+
+ (setf snd-head-bits 4)
+
+ (setf snd-head-srate 8)
+
+ (setf snd-head-dur 16)
+
+ (setf snd-head-latency 32)
+
+ (setf snd-head-type 64)
+
+ (setf snd-mode-adpcm 0)
+
+ (setf snd-mode-pcm 1)
+
+ (setf snd-mode-ulaw 2)
+
+ (setf snd-mode-alaw 3)
+
+ (setf snd-mode-float 4)
+
+ (setf snd-mode-upcm 5)
+
+ (setf snd-mode-unknown 6)
+
+ (setf snd-mode-double 7)
+
+ (setf snd-mode-GSM610 8)
+
+ (setf snd-mode-DWVW 9)
+
+ (setf snd-mode-DPCM 10)
+
+ (setf snd-mode-msadpcm 11)
+
+ (setf snd-mode-vorbis 11)
+
diff --git a/Release/nyquist/spec-plot.lsp b/Release/nyquist/spec-plot.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..a7651fbbb9da77bb5e5fce9aedd93278cf118ab5
--- /dev/null
+++ b/Release/nyquist/spec-plot.lsp
@@ -0,0 +1,47 @@
+;; spec-plot.lsp -- spectral plot function
+;;
+;; Roger B. Dannenberg, May 2016
+;;
+
+(setf *spec-plot-bw* 8000.0) ;; highest frequency to plot (default)
+(setf *spec-plot-res* 20.0) ;; bin size (default)
+(setf *spec-plot-db* nil) ;; plot dB? (default)
+
+;; We want to allow round-number bin-sizes so plot will be more readable
+;; Assuming 20Hz as an example, the FFT size would have to be
+;; 44100/20 = 2205, but that's not a power of 2, so we should resample
+;; the signal down so that the FFT size is 2048 (or up to 4096). This
+;; would result in sample rates of 2048*20 = 40960 or 81120. We should
+;; pick the smaller one if it is at least 2x *spec-plot-bw*.
+
+(defun spec-plot (sound &optional offset &key (res *spec-plot-res*)
+ (bw *spec-plot-bw*)
+ (db *spec-plot-db*))
+ (ny:typecheck (not (soundp sound))
+ (ny:error "SPEC-PLOT" 1 '((SOUND) nil) sound))
+ (ny:typecheck (not (or (null offset) (numberp offset)))
+ (ny:error "SPEC-PLOT" 2 '((NUMBER NULL) nil) offset))
+ (let (newsr sa fft-size power2)
+ (setf fft-size (/ (snd-srate sound) res))
+ (setf power2 8) ;; find integer size for FFT
+ (while (< power2 fft-size)
+ (setf power2 (* 2 power2)))
+ ;; now power2 >= fft-size
+ (cond ((> power2 fft-size) ;; not equal, must resample
+ ;; if half power2 * res is above 2 * bw,
+ ;; use half power2 as fft size
+ (cond ((> (* power2 res) (* 4 bw))
+ (setf power2 (/ power2 2))))
+ (setf sound (snd-resample sound (* power2 res)))
+ (setf fft-size power2)))
+ ;; we only need fft-dur samples, but allow an extra second just to
+ ;; avoid any rounding errors
+ (if offset
+ (setf sound (extract offset (+ 1.0 offset (/ (snd-srate sound)
+ fft-size)) sound)))
+ (setf sa (sa-init :resolution res :input sound))
+ (setf mag (sa-magnitude (sa-next sa)))
+ (setf mag (snd-from-array 0 (/ 1.0 res) mag))
+ (if db (setf mag (linear-to-db mag)))
+ (s-plot mag bw (round (/ (float bw) res)))))
+
diff --git a/Release/nyquist/spectral-analysis.lsp b/Release/nyquist/spectral-analysis.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..38ff748a0bcd0099c1b8dd753d56cf06884a15c3
--- /dev/null
+++ b/Release/nyquist/spectral-analysis.lsp
@@ -0,0 +1,289 @@
+;; spectral-analysis.lsp -- functions to simplify computing
+;; spectrogram data
+;;
+;; Roger B. Dannenberg and Gus Xia
+;; Jan 2013, modified Oct 2017
+
+;; API:
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; set sa-obj = sa-init(resolution: <nil or Hz>,
+;; fft-dur: <nil or seconds>,
+;; skip-period: <seconds>,
+;; window: <window type>,
+;; input: <filename or sound>)
+;;
+;; sa-init() creates a spectral-analysis object that can be used
+;; to obtain spectral data from a sound.
+;;
+;; resolution is the width of each spectral bin in Hz. If nil of
+;; not specified, the resolution is computed from fft-dur.
+;; The actual resolution will be finer than the specified
+;; resolution because fft sizes are rounded to a power of 2.
+;; fft-dur is the width of the FFT window in seconds. The actual
+;; FFT size will be rounded up to the nearest power of two
+;; in samples. If nil, fft-dur will be calculated from
+;; resolution. If both fft-size and resolution are nil
+;; or not specified, the default value of 1024 samples,
+;; corresponding to a duration of 1024 / signal-sample-rate,
+;; will be used. If both resolution and fft-dur are
+;; specified, the resolution parameter will be ignored.
+;; Note that fft-dur and resolution are reciprocals.
+;; skip-period specifies the time interval in seconds between
+;; successive spectra (FFT windows). Overlapping FFTs are
+;; possible. The default value overlaps windows by 50%.
+;; Non-overlapped and widely spaced windows that ignore
+;; samples by skipping over them entirely are also acceptable.
+;; window specifies the type of window. The default is raised
+;; cosine (Hann or "Hanning") window. Options include
+;; :hann, :hanning, :hamming, :none, nil, where :none and
+;; nil mean a rectangular window.
+;; input can be a string (which specifies a sound file to read)
+;; or a Nyquist SOUND to be analyzed.
+;; Return value is an XLISP object that can be called to obtain
+;; parameters as well as a sequence of spectral frames.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; set sa-frame = sa-next(sa-obj)
+;;
+;; sa-next() fetches the next spectrum from sa-obj.
+;;
+;; sa-obj is a spectral-analysis object returned by sa-init().
+;; Return value is an array of FLONUMS representing the discrete
+;; spectrum.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; exec sa-info(sa-obj)
+;;
+;; sa-info prints information about the spectral computation.
+;;
+;; sa-obj is a spectral-analysis object returned by sa-init().
+;; Return value is nil, but information is printed.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; set mag = sa-magnitude(frame)
+;;
+;; sa-magnitude computes the magnitude (amplitude) spectrum
+;; from a frame returned by sa-frame.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; exec sa-plot(sa-obj, sa-frame)
+;;
+;; sa-plot plots the amplitude (magnitude) spectrum of sa-frame.
+;;
+;; sa-obj is used to determine the bin width of data in sa-frame.
+;;
+;; sa-frame is a spectral frame (array) returned by sa-next()
+;;
+;; Return value is nil, but a plot is generated and displayed.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; set hz = sa-get-bin-width(sa-obj)
+;; set n = sa-get-fft-size(sa-obj)
+;; set secs = sa-get-fft-dur(sa-obj)
+;; set window = sa-get-fft-window(sa-obj)
+;; set skip-period = sa-get-skip-period(sa-obj)
+;; set m = sa-get-fft-skip-size(sa-obj)
+;; set sr = sa-get-sample-rate(sa-obj)
+;;
+;; These functions retrieve data from the sa-obj created by
+;; sa-init. The return values are:
+;; hz - the width of a frequency bin (also the separation
+;; of bin center frequencies). The center frequency of
+;; the i'th bin is i * hz.
+;; n - the size of the FFT, an integer, a power of two. The
+;; size of a spectral frame (an array returned by sa-next)
+;; is (n / 2) + 1.
+;; secs - the duration of an FFT window.
+;; window - the type of window used (:hann, :hamming, :none)
+;; skip-period - the time in seconds of the skip (the time
+;; difference between successive frames
+;; m - the size of the skip in samples.
+;; sr - the sample rate of the sound being analyzed (in Hz, a flonum)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;; define the class of spectral analysis objects
+(setf sa-class (send class :new '(sound length skip window window-type)))
+
+(send sa-class :answer :next '() '(
+ (snd-fft sound length skip window)))
+
+(defun sa-raised-cosine (alpha beta)
+ (sum (const alpha)
+ (scale beta (lfo 1.0 1.0 *sine-table* 270))))
+
+(defun sa-fft-window (frame-size alpha beta)
+ (abs-env (control-srate-abs frame-size
+ (sa-raised-cosine alpha beta))))
+
+(defun hann-window (frame-size) (sa-fft-window frame-size 0.5 0.5))
+(defun hamming-window (frame-size) (sa-fft-window frame-size 0.54 0.46))
+
+(defun sa-get-window-type (win-type)
+ (case win-type
+ ((:hann :hanning) :hann)
+ ((nil :none) :none)
+ (:hamming :hamming)
+ (t (print "Warning: invalid window-type parameter: ~A~%" win-type)
+ (print " Using :HAMMING instead.~%")
+ :hamming)))
+
+
+(defun sa-compute-window (len win-type)
+ (case win-type
+ (:hann (hann-window len))
+ (:none nil)
+ (:hamming (hamming-window len))
+ (t (print "Warning: invalid window-type parameter: ~A~%" win-type)
+ (print " Using :HAMMING instead.~%")
+ (hamming-window len))))
+
+
+(send sa-class :answer :isnew '(snd len skp win-type) '(
+ (setf sound snd)
+ (setf length len)
+ (setf skip skp)
+ (setf window-type (sa-get-window-type win-type))
+ (setf window (sa-compute-window length window-type))))
+
+
+;; sa-to-mono -- sum up the channels in an array
+;;
+(defun sa-to-mono (s)
+ (let ((mono (aref s 0)))
+ (dotimes (i (1- (length s)))
+ (setf mono (sum mono (aref s (1+ i)))))
+ mono))
+
+
+(defun sa-init (&key resolution fft-dur skip-period window input)
+ (let (len sr n skip)
+ (cond ((stringp input)
+ (setf input (s-read input))))
+ (cond ((arrayp input)
+ (format t "Warning: sa-init is converting stereo sound to mono~%")
+ (setf input (sa-to-mono input)))
+ ((soundp input) ;; so that variables are not "consumed" by snd-fft
+ (setf input (snd-copy input))))
+ (cond ((not (soundp input))
+ (error
+ (format nil
+ "Error: sa-init did not get a valid :input parameter~%"))))
+ (setf sr (snd-srate input))
+ (setf len 1024)
+ (cond (fft-dur
+ (setf len (* fft-dur sr)))
+ (resolution
+ (setf len (/ sr resolution))))
+ ;; limit fft size to between 4 and 2^16
+ (cond ((> len 65536)
+ (format t "Warning: fft-size reduced from ~A to 65536~%" len)
+ (setf len 65536))
+ ((< len 4)
+ (format t "Warning: fft-size increased from ~A to 4~%" len)
+ (setf len 4)))
+ ;; round up len to a power of two
+ (setf n 4)
+ (while (< n len)
+ (setf n (* n 2)))
+ (setf length n) ;; len is now an integer power of 2
+ ;(display "sa-init" length)
+ ;; compute skip length - default is len/2
+ (setf skip (if skip-period (round (* skip-period sr))
+ (/ length 2)))
+ (send sa-class :new input length skip window)))
+
+
+(defun sa-next (sa-obj)
+ (send sa-obj :next))
+
+(defun sa-info (sa-obj)
+ (send sa-obj :info))
+
+(send sa-class :answer :info '() '(
+ (format t "Spectral Analysis object (instance of sa-class):~%")
+ (format t " resolution (bin width): ~A Hz~%" (/ (snd-srate sound) length))
+ (format t " fft-dur: ~A s (~A samples)~%" (/ length (snd-srate sound)) length)
+ (format t " skip-period: ~A s (~A samples)~%" (/ skip (snd-srate sound)) skip)
+ (format t " window: ~A~%" window-type)
+ nil))
+
+
+(defun sa-plot (sa-obj frame)
+ (send sa-obj :plot frame))
+
+(defun sa-magnitude(frame)
+ (let* ((flen (length frame))
+ (n (/ (length frame) 2)) ; size of amplitude spectrum - 1
+ (as (make-array (1+ n)))) ; amplitude spectrum
+ ;; first compute an amplitude spectrum
+ (setf (aref as 0) (abs (aref frame 0))) ;; DC
+ ;; half_n is actually length/2 - 1, the number of complex pairs
+ ;; in addition there is the DC and Nyquist terms, which are
+ ;; real and in the first and last slots of frame
+ (setf half_n (1- n))
+ (dotimes (i half_n)
+ (let* ((i2 (+ i i 2)) ; index of the imag part
+ (i2m1 (1- i2)) ; index of the real part
+ (amp (sqrt (+ (* (aref frame i2m1) (aref frame i2m1))
+ (* (aref frame i2) (aref frame i2))))))
+ (setf (aref as (1+ i)) amp)))
+ (setf (aref as n) (aref frame (1- flen)))
+ as)) ;; return the amplitude spectrum
+
+
+(send sa-class :answer :plot '(frame) '(
+ (let* ((as (sa-magnitude frame))
+ (sr (snd-srate sound)))
+ (s-plot (snd-from-array 0 (/ length sr) as)
+ sr (length as)))))
+
+(defun sa-get-bin-width (sa-obj)
+ (send sa-obj :get-bin-width))
+
+(send sa-class :answer :get-bin-width '()
+ '((/ (snd-srate sound) length)))
+
+(defun sa-get-fft-size (sa-obj)
+ (send sa-obj :get-fft-size))
+
+(send sa-class :answer :get-fft-size '() '(length))
+
+(defun sa-get-fft-dur (sa-obj)
+ (send sa-obj :get-fft-dur))
+
+(send sa-class :answer :get-fft-dur '() '(/ length (snd-srate sound)))
+
+(defun sa-get-fft-window (sa-obj)
+ (send sa-obj :get-fft-window))
+
+(send sa-class :answer :get-fft-window '() '(window-type))
+
+(defun sa-get-fft-skip-period (sa-obj)
+ (send sa-obj :get-skip-period))
+
+(send sa-class :answer :get-skip-period '() '((/ skip (snd-srate sound))))
+
+(defun sa-get-fft-skip-size (sa-obj)
+ (send sa-obj :get-skip-size))
+
+(send sa-class :answer :get-fft-skip-size '() '(skip))
+
+(defun sa-get-sample-rate (sa-obj)
+ (send sa-obj :get-sample-rate))
+
+(send sa-class :answer :get-sample-rate '() '((snd-srate sound)))
+
+
+;;;;;;; TESTS ;;;;;;;;;;
+
+
+(defun plot-test ()
+ (let (frame)
+ (setf sa (sa-init :input "./rpd-cello.wav"))
+ (while t
+ (setf frame (sa-next sa))
+ (if (null sa) (return nil))
+ (sa-plot sa frame))))
+
diff --git a/Release/nyquist/stk.lsp b/Release/nyquist/stk.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..3eae1390851ba037c5ecbe8d6111dd9ee308ff34
--- /dev/null
+++ b/Release/nyquist/stk.lsp
@@ -0,0 +1,200 @@
+;; stk.lsp -- STK-based instruments
+;;
+;; currently clarinet and saxophony are implemented
+
+(defun instr-parameter (parm)
+ ;; coerce parameter into a *sound-srate* signal
+ (cond ((numberp parm)
+ (stretch 30 (control-srate-abs *sound-srate* (const (float parm)))))
+ (t
+ (force-srate *sound-srate* parm))))
+
+
+(defun clarinet (step breath-env)
+ (snd-clarinet (step-to-hz step) (force-srate *sound-srate* breath-env) *sound-srate*))
+
+
+(defun clarinet-freq (step breath-env freq-env)
+ ;; note that the parameters are in a different order -- I defined
+ ;; clarinet-freq this way so that the first two parameters are always
+ ;; step and breath. I didn't redo snd-clarinet-freq.
+ (snd-clarinet_freq (step-to-hz step)
+ (instr-parameter breath-env)
+ (instr-parameter freq-env)
+ *sound-srate*))
+
+
+
+(defun clarinet-all (step breath-env freq-env vibrato-freq vibrato-gain reed-stiffness noise)
+ ;; note that the parameters are not in the same order as snd-clarinet-all
+ (setf breath-env (instr-parameter breath-env))
+ (setf freq-env (instr-parameter freq-env))
+ (setf reed-stiffness (instr-parameter reed-stiffness))
+ (setf noise (instr-parameter noise))
+ (snd-clarinet_all (step-to-hz step)
+ breath-env freq-env
+ ;; STK scales 1.0 to 12Hz. Scale here so vibrato-freq is in Hz
+ (/ vibrato-freq 12.0) vibrato-gain
+ reed-stiffness noise
+ *sound-srate*))
+
+
+(defun sax (step breath-env)
+ (snd-sax (step-to-hz step) (force-srate *sound-srate* breath-env) *sound-srate*))
+
+(defun sax-freq (step breath-env freq-env)
+ (snd-sax_freq (step-to-hz step)
+ (instr-parameter breath-env)
+ (instr-parameter freq-env)
+ *sound-srate*))
+
+(defun sax-all (step breath-env freq-env vibrato-freq vibrato-gain reed-stiffness noise blow-pos reed-table-offset)
+ (snd-sax_all (step-to-hz step)
+ (instr-parameter freq-env)
+ (instr-parameter breath-env)
+ (instr-parameter (/ vibrato-freq 12.0))
+ (instr-parameter vibrato-gain)
+ (instr-parameter reed-stiffness)
+ (instr-parameter noise)
+ (instr-parameter blow-pos)
+ (instr-parameter reed-table-offset)
+ *sound-srate*)
+)
+
+; instr-parameter already defined in stk.lsp
+
+(defun flute (step breath-env)
+ (snd-flute (step-to-hz step) (force-srate *sound-srate* breath-env) *sound-srate*))
+
+(defun flute-freq (step breath-env freq-env)
+ (snd-flute_freq (step-to-hz step)
+ (instr-parameter breath-env)
+ (instr-parameter freq-env)
+ *sound-srate*))
+
+(defun flute-all (step breath-env freq-env vibrato-freq vibrato-gain jet-delay noise)
+ ;; note that the parameters are not in the same order as snd-clarinet-all
+ (setf breath-env (instr-parameter breath-env))
+ (setf freq-env (instr-parameter freq-env))
+ (setf jet-delay (instr-parameter jet-delay))
+ (setf noise (instr-parameter noise))
+ (snd-flute_all (step-to-hz step)
+ breath-env freq-env
+ ;; STK scales 1.0 to 12Hz. Scale here so vibrato-freq is in Hz
+ (/ vibrato-freq 12.0) vibrato-gain
+ jet-delay noise
+ *sound-srate*))
+
+
+(defun bowed (step bowpress-env)
+ (snd-bowed (step-to-hz step) (force-srate *sound-srate* bowpress-env) *sound-srate*))
+
+(defun bowed-freq (step bowpress-env freq-env)
+ (snd-bowed_freq (step-to-hz step)
+ (instr-parameter bowpress-env)
+ (instr-parameter freq-env)
+ *sound-srate*))
+
+(defun mandolin (step dur &optional (detune 4.0))
+ (let ((d (get-duration dur)))
+ (snd-mandolin *rslt* (step-to-hz step) d 1.0 detune *sound-srate*)))
+
+(defun wg-uniform-bar (step bowpress-env)
+ (snd-bandedwg (step-to-hz step) (force-srate *sound-srate* bowpress-env) 0 *sound-srate*))
+
+(defun wg-tuned-bar (step bowpress-env)
+ (snd-bandedwg (step-to-hz step) (force-srate *sound-srate* bowpress-env) 1 *sound-srate*))
+
+(defun wg-glass-harm (step bowpress-env)
+ (snd-bandedwg (step-to-hz step) (force-srate *sound-srate* bowpress-env) 2 *sound-srate*))
+
+(defun wg-tibetan-bowl (step bowpress-env)
+ (snd-bandedwg (step-to-hz step) (force-srate *sound-srate* bowpress-env) 3 *sound-srate*))
+
+(defun modalbar (preset step duration)
+ (let ((preset (case preset
+ (MARIMBA 0)
+ (VIBRAPHONE 1)
+ (AGOGO 2)
+ (WOOD1 3)
+ (RESO 4)
+ (WOOD2 5)
+ (BEATS 6)
+ (TWO-FIXED 7)
+ (CLUMP 8)
+ (t (error (format nil "Unknown preset for modalbar %A" preset)))))
+ (d (get-duration duration)))
+ (snd-modalbar *rslt* (step-to-hz step) preset d *sound-srate*)))
+
+(defun sitar (step dur)
+ (let ((d (get-duration dur)))
+ (snd-sitar *rslt* (step-to-hz step) d *sound-srate*)))
+
+(defun nyq:nrev (snd rev-time mix)
+ (snd-stkrev 0 snd rev-time mix))
+
+(defun nyq:jcrev (snd rev-time mix)
+ (snd-stkrev 1 snd rev-time mix))
+
+(defun nyq:prcrev (snd rev-time mix)
+ (snd-stkrev 2 snd rev-time mix))
+
+(defun nrev (snd rev-time mix)
+ (multichan-expand "NREV" #'nyq:nrev
+ '(((SOUND) "snd") ((NUMBER) "rev-time") ((NUMBER) "mix"))
+ snd rev-time mix))
+
+(defun jcrev (snd rev-time mix)
+ (multichan-expand "JCREV" #'nyq:jcrev
+ '(((SOUND) "snd") ((NUMBER) "rev-time") ((NUMBER) "mix"))
+ snd rev-time mix))
+
+(defun prcrev (snd rev-time mix)
+ (multichan-expand "PRCREV" #'nyq:prcrev
+ '(((SOUND) "snd") ((NUMBER) "rev-time") ((NUMBER) "mix"))
+ snd rev-time mix))
+
+(defun nyq:chorus (snd depth freq mix &optional (base-delay 6000))
+ (snd-stkchorus snd base-delay depth freq mix))
+
+(defun stkchorus (snd depth freq mix &optional (base-delay 6000))
+ (multichan-expand "STKCHORUS" #'nyq:chorus
+ '(((SOUND) "snd") ((NUMBER) "depth") ((NUMBER) "freq") ((NUMBER) "mix")
+ ((INTEGER) "base-delay"))
+ snd depth freq mix base-delay))
+
+(defun nyq:pitshift (snd shift mix)
+ (snd-stkpitshift snd shift mix))
+
+(defun pitshift (snd shift mix)
+ (multichan-expand "PITSHIFT" #'nyq:pitshift
+ '(((SOUND) "snd") ((NUMBER) "shift") ((NUMBER) "mix"))
+ snd shift mix))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; HELPER FUNCTIONS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; pass in rates of increase/decrease in begin/end... this is like noteOn and noteOff
+;
+; STK uses setRate but the actual ramp time is also a function of the sample rate.
+; I will assume the clarinet was run at 44100Hz and fix things so that the envelope
+; is sample-rate independent.
+;
+; STK seemed to always give a very fast release, so I changed the numbers so that
+; note-off values from 0.01 to 1 give an interesting range of articulations.
+;
+; IMPORTANT: the returned envelope is 0.1s longer than dur. There is 0.1s of silence
+; at the end so that the clarinet can "ring" after the driving force is removed.
+;
+(defun stk-breath-env (dur note-on note-off)
+ (let* ((target (+ 0.55 (* 0.3 note-on)))
+ (on-time (/ (* target 0.0045) note-on))
+ (off-time (/ (* target 0.02) note-off)))
+ ;(display "clarinet-breath-env" target on-time off-time)
+ (pwl on-time target
+ (- dur off-time) target
+ dur 0 (+ dur 0.1))))
+
+
diff --git a/Release/nyquist/system.lsp b/Release/nyquist/system.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..b750fe66693d86af2fe6d49e2423aad2fcefde25
--- /dev/null
+++ b/Release/nyquist/system.lsp
@@ -0,0 +1,131 @@
+; machine.lsp -- machine/system-dependent definitions
+; Windows
+
+;; default behavior is to call SETUP-CONSOLE to get large white typescript
+;;
+;; set *setup-console* to nil in your personal init.lsp to override this behavior
+;; (this may be necessary to work with emacs)
+;;
+(if (not (boundp '*setup-console*)) (setf *setup-console* t))
+(if *setup-console* (setup-console))
+
+(if (not (boundp '*default-sf-format*))
+ (setf *default-sf-format* snd-head-Wave))
+
+(if (not (boundp '*default-sound-file*))
+ (compute-default-sound-file))
+
+(if (not (boundp '*default-sf-dir*))
+ (setf *default-sf-dir* ""))
+
+(if (not (boundp '*default-sf-mode*))
+ (setf *default-sf-mode* snd-mode-pcm))
+
+(if (not (boundp '*default-sf-bits*))
+ (setf *default-sf-bits* 16))
+
+(if (not (boundp '*default-plot-file*))
+ (setf *default-plot-file* "points.dat"))
+
+;(if (not (boundp '*plotscript-file*))
+; (setf *plotscript-file* "sys/unix/rs6k/plotscript"))
+
+; local definition for play
+(defmacro play (expr)
+ `(s-save-autonorm ,expr NY:ALL *default-sound-file* :play *soundenable*))
+
+
+(defun r ()
+ (s-save (s-read *default-sound-file*) NY:ALL "" :play t)
+)
+
+
+; PLAY-FILE -- play a file
+(defun play-file (name)
+ (s-save (s-read name) NY:ALL "" :play t))
+
+
+; FULL-NAME-P -- test if file name is a full path or relative path
+;
+; (otherwise the *default-sf-dir* will be prepended
+;
+(defun full-name-p (filename)
+ (or (eq (char filename 0) #\\)
+ (eq (char filename 0) #\/)
+ (eq (char filename 0) #\.)
+ (and (> (length filename) 2)
+ (both-case-p (char filename 0))
+ (equal (char filename 1) #\:))))
+
+; RELATIVE-PATH-P -- test if filename or path is a relative path
+;
+; note that properly converting a Windows path from relative to
+; absolute is complicated by paths like: E:MYFILE.LSP
+; Nyquist assumes that if there is a drive letter, the path is
+; absolute, e.g. E:\TMP\MYFILE.LSP and if there is no drive,
+; the path is relative, e.g. you cannot have \TMP\MYFILE.LSP
+;
+(defun relative-path-p (filename)
+ (or (< (length filename) 2)
+ (not (both-case-p (char filename 0)))
+ (not (equal (char filename 1) #\:))))
+
+
+(setf *file-separator* #\\)
+
+(defun ny:load-file () (load "*.*"))
+(defun ny:reload-file () (load "*"))
+
+
+; save the standard function to write points to a file
+;
+;(setfn s-plot-points s-plot)
+
+;(defun array-max-abs (points)
+; (let ((m 0.0))
+; (dotimes (i (length points))
+; (setf m (max m (abs (aref points i)))))
+; m))
+
+;(setf graph-width 600)
+;(setf graph-height 220)
+
+;(defun s-plot (snd &optional (n 600))
+; (show-graphics)
+; (clear-graphics)
+; (cond ((soundp snd)
+; (s-plot-2 snd n (/ graph-height 2) graph-height))
+; (t
+; (let ((gh (/ graph-height (length snd)))
+; hs)
+; (dotimes (i (length snd))
+; (setf hs (s-plot-2 (aref snd i) n (+ (/ gh 2) (* i gh)) gh hs)))))))
+;
+;
+;(defun s-plot-2 (snd n y-offset graph-height horizontal-scale)
+; (prog ((points (snd-samples snd n))
+; maxpoint horizontal-scale vertical-scale)
+; (setf maxpoint (array-max-abs points))
+; (moveto 0 y-offset)
+; (lineto graph-width y-offset)
+; (moveto 0 y-offset)
+; (cond ((null horizontal-scale)
+; (setf horizontal-scale (/ (float graph-width) (length points)))))
+; (setf vertical-scale (- (/ (float graph-height) 2 maxpoint)))
+; (dotimes (i (length points))
+; (lineto (truncate (* horizontal-scale i))
+; (+ y-offset (truncate (* vertical-scale (aref points i))))))
+; (format t "X Axis: ~A to ~A (seconds)\n" (snd-t0 snd) (/ (length points) (snd-srate snd)))
+; (format t "Y Axis: ~A to ~A\n" (- maxpoint) maxpoint)
+; (format t "~A samples plotted.\n" (length points))
+; (return horizontal-scale)
+; ))
+;
+; S-EDIT - run the audio editor on a sound
+;
+;(defmacro s-edit (&optional expr)
+; `(prog ()
+; (if ,expr (s-save ,expr 1000000000 *default-sound-file*))
+; (system (format nil "audio_editor ~A &"
+; (soundfilename *default-sound-file*)))))
+
diff --git a/Release/nyquist/test.lsp b/Release/nyquist/test.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..3bacbc62aba7d5128fddc510c084cf2670472632
--- /dev/null
+++ b/Release/nyquist/test.lsp
@@ -0,0 +1,43 @@
+
+(defun ss () (osc c5))
+
+(defun tt () (stretch 2 (snd-tapv (ss) 1.1 (scale *d* (lfo 10)) 2.2)))
+(setf *d* .01)
+
+(defun g () (play (tt)))
+
+;(set-sound-srate 10)
+;(set-control-srate 10)
+(defun rr () (stretch 10 (ramp)))
+(defun ll () (stretch 10 (lfo .5)))
+(defun xx () (snd-tapv (rr) 1.1 (ll) 2.2))
+(defun h () (snd-samples (xx) 150))
+
+(defun chorus (sound maxdepth depth rate saturation)
+ (let ((modulation (prod depth (stretch-abs 10000.0 (general-lfo rate))))
+ (offset (/ maxdepth 2.0))
+ chor)
+ (setf chor (snd-tapv sound offset modulation maxdepth))
+ (sum (prod chor saturation) (prod (seq (s-rest offset) sound)
+ (sum 1.0 (prod -1.0 saturation))))))
+
+
+(set-sound-srate 22050.0)
+
+(defun f ()
+ (chorus (s-read "runtime\\ah.wav") .1 .1 1 .5))
+
+(defun e ()
+ (seq (s-rest .05) (chorus (s-read "rpd.wav") .07 .07 .7 .5)))
+
+(defun d () (sum (e) (f)))
+
+(defun rou () (s-read "round.wav" :time-offset 1.18 :dur (- 8.378 1.18)))
+
+(defun rou4 () (sim (rou)
+ (at *rd* (rou))
+ (at (* *rd* 2) (rou))
+ (at (* *rd* 3) (rou))))
+
+
+
diff --git a/Release/nyquist/velocity.lsp b/Release/nyquist/velocity.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..aa5226d638d2d92f8a45f7ab595e3e56fce9c5b5
--- /dev/null
+++ b/Release/nyquist/velocity.lsp
@@ -0,0 +1,24 @@
+;; velocity.lsp -- conversion routines for MIDI velocity
+;;
+;; Roger B. Dannenberg
+;; July, 2012
+
+
+(defun db-to-vel (x &optional float)
+ (linear-to-vel (db-to-linear x) float))
+
+
+(defun linear-to-vel (x &optional float)
+ (setf x (/ (- (sqrt (abs x)) 0.0239372) 0.00768553))
+ (cond (float x)
+ (t
+ (setf x (round x))
+ (max 1 (min 127 x)))))
+
+
+(defun vel-to-db (v)
+ (linear-to-db (vel-to-linear v)))
+
+
+(defun vel-to-linear (v)
+ (power (+ (* v 0.00768553) 0.0239372) 2))
diff --git a/Release/nyquist/xlinit.lsp b/Release/nyquist/xlinit.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..ae2cfda222d686d1ab6c9af64924d69fae5e883d
--- /dev/null
+++ b/Release/nyquist/xlinit.lsp
@@ -0,0 +1,67 @@
+;; xlinit.lsp -- standard definitions and setup code for XLisp
+;;
+
+
+(defun bt () (baktrace 6))
+
+(defmacro setfn (a b)
+ `(setf (symbol-function ',a) (symbol-function ',b)))
+
+(setfn co continue)
+(setfn top top-level)
+(setfn res clean-up)
+(setfn up clean-up)
+
+;## display -- debugging print macro
+;
+; call like this (display "heading" var1 var2 ...)
+; and get printout like this:
+; "heading : VAR1 = <value> VAR2 = <value> ...<CR>"
+;
+; returns:
+; (let ()
+; (format t "~A: " ,label)
+; (format t "~A = ~A " ',item1 ,item1)
+; (format t "~A = ~A " ',item2 ,item2)
+; ...)
+;
+(defmacro display-macro (label &rest items)
+ (let ($res$)
+ (dolist ($item$ items)
+ (setq $res$ (cons
+ `(format t "~A = ~A " ',$item$ ,$item$)
+ $res$)))
+ (append (list 'let nil `(format t "~A : " ,label))
+ (reverse $res$)
+ '((terpri)))))
+
+
+(defun display-on () (setfn display display-macro) t)
+(defun display-off () (setfn display or) nil)
+(display-on)
+
+; (objectp expr) - object predicate
+;
+;this is built-in: (defun objectp (x) (eq (type-of x) 'OBJ))
+
+
+; (filep expr) - file predicate
+;
+(defun filep (x) (eq (type-of x) 'FPTR))
+
+(load "profile.lsp" :verbose NIL)
+
+; (setf *breakenable* t) -- good idea, but set it in init.lsp, so user can decide
+(setq *tracenable* nil)
+
+(defmacro defclass (name super locals class-vars)
+ (if (not (boundp name))
+ (if super
+ `(setq ,name (send class :new ',locals ',class-vars ,super))
+ `(setq ,name (send class :new ',locals ',class-vars)))))
+
+;(cond ((boundp 'application-file-name)
+; (load application-file-name)))
+
+(setq *gc-flag* t)
+
diff --git a/Release/nyquist/xm.lsp b/Release/nyquist/xm.lsp
new file mode 100644
index 0000000000000000000000000000000000000000..75bdea2c1bed61087aaa3159f65e3a63be9cf60b
--- /dev/null
+++ b/Release/nyquist/xm.lsp
@@ -0,0 +1,2767 @@
+;; X-Music, inspired by Commmon Music
+
+#|
+PATTERN SEMANTICS
+
+Patterns are objects that are generally accessed by calling (next
+pattern). Each call returns the next item in an infinite sequence
+generated by the pattern. Items are organized into periods. You can
+access all (remaining) items in the current period using (next pattern
+t).
+
+Patterns mark the end-of-period with +eop+, a distinguished atom. The
++eop+ markers are filtered out by the next() function but returned by
+the :next method.
+
+Pattern items may be patterns. This is called a nested pattern. When
+patterns are nested, you return a period from the innermost pattern,
+i.e. traversal is depth-first. This means when you are using something
+like random, you select a random pattern and get an item from it. The
+next time you handle :next, you get another item from the same pattern
+until the pattern returns +eonp+, which you can read as "end of nested
+pattern". Random would then advance to the next random pattern and get
+an item from it.
+
+While generating from a nested pattern, you might return many periods
+including +eop+, but you do not advance to the next pattern at any
+given level until that level receives +eonp+ from the next level down.
+
+With nested patterns, i.e. patterns with items that are patterns, the
+implementation requires that *all* items must be patterns. The
+application does *not* have to make every item a pattern, so the
+implementation "cleans up" the item list: Any item that is not a
+pattern is be replaced with a cycle pattern whose list contains just
+the one item.
+
+PATTERN LENGTH
+
+There are two sorts of cycles and lengths. The nominal pattern
+behavior, illustrated by cycle patterns, is to cycle through a
+list. There is a "natural" length computed by :start-period and stored
+in count that keeps track of this.
+
+The second cycle and length is established by the :for parameter,
+which is optional. If a number or pattern is provided, it controls the
+period length and overrides any default periods. When :for is given,
+count is set and used as a counter to count the items remaining in
+a period.
+
+To summarize, there are 3 ways to determine lengths:
+
+1) The length is implicit. The length can be computed by :start-period
+and turned into an explicit length stored in count.
+
+2) The length is explicitly set with :for. This overrides the implicit
+length. The explicit length is stored as count that tells how many
+more items to generate in the current period.
+
+3) The length can be generated by a pattern. The pattern is evaluated
+in :start-period to generate an explicit length.
+
+In case (1), a pattern object does not return +eonp+ to the next level
+up unless it receives an +eonp+ from one level down *and* is at the
+end of its period. E.g. in the random pattern, if there are three
+nested patterns, random must see +eonp+ three times and make three
+random pattern selections before returning +eonp+ to the next level
+up. This is the basic mechanism for achieving a "depth-first"
+expansion of patterns.
+
+However, there is still the question of periods. When a nested pattern
+returns a period, do the containing pattern return that period or
+merge the period with other periods from other nested patterns? The
+default is to return periods as they are generated by sub-patterns. In
+other words, when a nested pattern returns +eop+ (end of period), that
+token is returned by the :next message. Thus, in one "natural" cycle
+of a pattern of patterns, there can be many periods (+eop+'s) before
++eonp+ is returned, marking the end of the "natural" pattern at this
+level.
+
+The alternative strategy, which is to filter out all the +eop+'s and
+form one giant pattern that runs up to the natural length (+eonp+) for
+this level, can be selected by setting the :merge parameter to true.
+Note that :merge is ignored if :for is specified because :for says
+exactly how many items are in each period.
+
+The Copier pattern is an interesting case. It's :start-pattern should
+get the next period from its sub-pattern, a repeat count from the
+:repeat pattern, and a boolean from the :merge pattern. Then, it
+should make that many copies, returning them as multiple periods or as
+one merged one, depending on :merge, followed by +eonp+, after which
+:start-pattern is called and the process repeats. But if :for 10 is
+provided, this means we need to return a single period of 10 items. We
+call :start-pattern, then repeat the sub-pattern's period until we
+have 10 items. Thus, we ignore the :merge flag and :repeat count.
+This makes Copier with a :for parameter equivalent to Cycle with a
+single sub-pattern in a list. If you think :for should not override
+these parameters (:repeat and :merge), you can probably get what you
+want by using a Length pattern to regroup the output of a Copier.
+
+IMPLEMENTATION
+
+Most pattern behavior is implemented in a few inherited methods.
+
+:next gets the next item or period. If there is a length-pattern
+(from :for), :next groups items into periods, filtering out +eop+ and
++eonp+. If there is no length-pattern, :next passes +eop+ through and
+watches for +eonp+ to cause the pattern to re-evaluate pattern
+parameters.
+
+Several methods are implemented by subclasses of pattern-class:
+
+:START-PERIOD is called before the first advance and before the first
+item of a period controlled by :for. It sets count to the "natural"
+length of the period. HAVE-CURRENT will be set to false.
+
+:ADVANCE advances to the next item in the pattern. If there are nested
+patterns, advance is called to select the first nested pattern, then
+items are returned until +eonp+ is seen, then we advance to the next
+pattern, etc. After :ADVANCE, HAVE-CURRENT is true.
+
+CURRENT is set by advance to the current item. If this has nested
+patterns, current is set to a pattern, and the pattern stays there in
+current until advance is called, either at the end of period or when
++eonp+ is seen.
+
+HAVE-CURRENT is a boolean to tell when CURRENT is valid.
+
+IS-NESTED - set when there are nested patterns. If there are, make all
+items of any nested pattern be patterns (no mix of patterns and
+non-patterns is allowed; use
+ (MAKE-CYCLE (LIST item))
+to convert a non-pattern to a pattern).
+
+Patterns may be shared, so the state machines may be advanced by more
+than one less-deeply nested pattern. Thus, patterns are really DAGs
+and not trees. Since patterns are hard enough to understand, the
+precise order of evaluation and therefore the behavior of shared
+patterns in DAGs may not be well-defined. In this implementation
+though, we only call on state machines to advance as needed (we try
+not to read out whole periods).
+
+The next() function gets an item or period by calling :next.
+
+The :next method is shared by all pattern sub-classes and behaves
+differently with :for vs. no :for parameter. With the :for parameter,
+we just get items until the count is reached, but getting items is
+a bit tricky, because the normal behavior (without :for) might reach
+the end of the "natural" period (+eonp+) before count is
+reached. So somehow, we need to override count. We could just set
+count the count, but count is going to count items and due to
+empty periods, count could go to zero before count does. We could
+set count = 1000 * count with the idea that we're probably in an
+infinite loop generating empty periods forever if count ever reaches
+zero.
+
+But then what about the Heap pattern? If count is greater than the
+heap size, what happens when the heap is empty? Or should Heap not
+allow :for? There are other "problem" patterns, and not all Vers. 1
+patterns allowed :for, so let's make list of patterns that could use
+:for:
+
+:for is OK :for is not OK
+---------- --------------
+cycle heap
+line accumulation
+random copier
+palindrome length
+accumulate window
+sum
+product
+eval
+markov
+
+It seems that we could use :for for all patterns and just extend the
+behavior a bit, e.g. when the heap runs out, replenish it (without
+getting another period from a sub-pattern, if any; accumulation could
+just start over; copier could cycle as described earlier; length
+really should not allow :for, and window could just generate :for
+items before reevaluating :skip and :pattern-length parameters.
+
+To implement this, the subclass patterns need :advance to do the right
+next thing even if we are beyond the "natural" period. :advance should
+go to the next sub-pattern or item without returning +eop+ or getting
+the next item from any sub-pattern.
+
+state transitions are based on count and something like this:
+count
+nil -> actions: :start-period, don't return, set count
+N -> N-1, actions: :advance if not have-current, return next item
+0 -> -1, actions: return +eop+
+-1 -> nil, actions: return +eonp+
+
+
+def :next()
+ if length-pattern: // the :for parameter value
+ if null(count): // initial state before every period
+ var forcount = next(length-pattern) // must be a number
+ // compute forcount first and pass to start-period in case there
+ // is no "natural" period length. If there is a "natural" period,
+ // the forcount parameter is ignored (the usual case)
+ self.:start-period(forcount)
+ have-current = false
+ // :start-period() sets count, but we replace it with :for parameter
+ count = forcount
+ if count == 0:
+ count = -1
+ return +eop+
+ if count == -1:
+ count = nil
+ return +eonp+
+ while true
+ // otherwise, here is where we return N items
+ if not have-current
+ self.:advance()
+ if not is-nested
+ // now current is updated
+ have-current = false
+ count = count - 1
+ return current
+ // nested, so get item from sub-pattern
+ rslt = current.:next
+ if rslt == +eonp+
+ // time to advance because sub-pattern has played out
+ have-current = false
+ elif rslt == +eop+
+ nil // skip ends of periods, we're merging them
+ // we got a real item to return
+ else
+ count = count - 1
+ return rslt
+ // here, we have no length-pattern, so use "natural" periods
+ // count is null, and we use count
+ while true
+ if null(count):
+ have-current = false
+ self.:start-period()
+ if is-nested:
+ if count == 0:
+ if merge-flag: // we filtered out +eop+ so return one here
+ count == -1
+ return +eop+
+ else
+ count = nil
+ return +eonp+
+ if count == -1
+ count = nil
+ return +eonp+
+ else
+ if count = 0:
+ count = -1
+ return +eop+
+ if count == -1:
+ count = nil
+ return +eonp+
+ // count is a number > 0
+ if not have-current:
+ self.:advance
+ have-current = true
+ if not is-nested
+ have-current = false
+ count = count - 1
+ return current
+ // nested, so get sub-pattern's next item or +eonp+ or +eop+
+ rslt = current.:next
+ if rslt == +eonp+
+ have-current = false // force advance next time, don't
+ // return +eonp+ until count == 0
+ else if rslt == +eop+ and merge-flag:
+ nil // iterate, skipping this +eop+ to merge periods
+ else
+ return rslt // either +eop+ or a real item
+
+
+If the input is a list of patterns, then the pattern selects patterns
+from the list, and the internal state advances as each selected
+pattern completes a period. In this case, there is no way to control
+the number of elements drawn from each selected pattern -- the number
+is always the length of the period returned by the selected
+pattern. If :for is specified, this controls the length of the period
+delivered to the next less deeply nested pattern, but the delivered
+period may be a mix of elements from the more deeply nested patterns.
+|#
+
+(setf SCORE-EPSILON 0.000001)
+
+(setf pattern-class
+ (send class :new '(current have-current is-nested name count merge-flag
+ merge-pattern length-pattern trace)))
+
+;; sub-classes should all call (send-super :isnew length-pattern name trace)
+;;
+(send pattern-class :answer :isnew '(mp lp nm tr)
+ '((setf merge-pattern mp length-pattern lp name nm trace tr)
+ (xm-traceif "pattern-class :isnew nm" nm "name" name)))
+
+(defun patternp (x)
+ (and (objectp x) (send x :isa pattern-class)))
+
+(setf +eop+ '+eop+)
+(setf +eonp+ '+eonp+) ;; end of nested period, this indicates you
+ ;; should advance yourself and call back to get the next element
+
+(defun check-for-list (lis name)
+ (if (not (listp lis))
+ (error (format nil "~A, requires a list of elements" name))))
+
+(defun check-for-list-or-pattern (lis name)
+ (if (not (or (listp lis) (patternp lis)))
+ (error (format nil "~A, requires a list of elements or a pattern" name))))
+
+(defun list-has-pattern (lis)
+ (dolist (e lis)
+ (if (patternp e) (return t))))
+
+(defun is-homogeneous (lis)
+ (let (type)
+ (dolist (elem lis t)
+ (cond ((null type)
+ (setf type (if (patternp elem) 'pattern 'atom)))
+ ((and (eq type 'pattern)
+ (not (patternp elem)))
+ (return nil))
+ ((and (eq type 'atom)
+ (patternp elem))
+ (return nil))))))
+
+(defun make-homogeneous (lis traceflag)
+ (cond ((is-homogeneous lis) lis)
+ (t
+ (mapcar #'(lambda (item)
+ (if (patternp item) item
+ (make-cycle (list item)
+ ;; help debugging by naming the new pattern
+ ;; probably, the name could be item, but
+ ;; here we coerce item to a string to avoid
+ ;; surprises in code that assumes string names.
+ :name (format nil "~A" item) :trace traceflag)))
+ lis))))
+
+
+;; used for both "advanced to" and ":next returns" messages
+;;
+(send pattern-class :answer :write-trace '(verb value)
+ '((format t "pattern ~A ~A ~A~%"
+ (if name name "<no-name>")
+ verb
+ (if (patternp value)
+ (if (send value :name)
+ (send value :name)
+ "<a-pattern>")
+ value))))
+
+
+;; :next returns the next value, including +eop+ and +eonp+ markers
+;;
+(send pattern-class :answer :next '()
+ '((xm-traceif ":next of" name "is-nested" is-nested "length-pattern" length-pattern)
+ (incf xm-next-nesting)
+ (let ((rslt
+ (cond (length-pattern (send self :next-for))
+ (t (send self :next-natural)))))
+ (if trace (send self :write-trace ":next returns" rslt))
+ (xm-traceif-return ":next" self rslt))))
+
+
+;; :next-for returns the next value, including +eop+ and +eonp+ markers
+;; this code handles the cases where :for is specified, so the length
+;; of each period is explicitly given, non intrinsic to the pattern
+;;
+(send pattern-class :answer :next-for '()
+ '((block pattern:next-for-block ;; so we can return from inside while loop
+ (cond ((null count)
+ (let ((forcount (next length-pattern)))
+ ;; in the case of window-class, there is no "natural" length
+ ;; so for that case, we pass in forcount
+ (send self :start-period forcount) ;; :start-period sets count,
+ (setf count forcount) ;; but it is replaced here by a number
+ (setf have-current nil))))
+ ;; note that merge-flag is ignored if length-pattern
+ (cond ((zerop count)
+ (setf count -1)
+ (return-from pattern:next-for-block +eop+))
+ ((eql count -1)
+ (setf count nil)
+ (return-from pattern:next-for-block +eonp+)))
+ (while t ;; after rejecting special cases, here is where we return N items
+ (cond ((not have-current)
+ (send self :advance)
+ (setf have-current t)
+ (if trace (send self :write-trace "advanced to" current))))
+ (cond ((not is-nested) ;; now current is updated
+ (setf have-current nil)
+ (decf count)
+ (return-from pattern:next-for-block current)))
+ ;; is-nested, so get item from sub-pattern
+ (let ((rslt (send current :next)))
+ (cond ((eq rslt +eonp+)
+ ;; time to advance because sub-pattern has played out
+ (setf have-current nil))
+ ((eq rslt +eop+)) ;; skip ends of periods; we merge them
+ (t
+ (decf count)
+ (return-from pattern:next-for-block rslt))))))))
+
+;; :next-natural returns the next value, including +eop+ and +eonp+ markers
+;; this code handles the cases where :for is not specified, so the length
+;; of each period is implicitly determined from the pattern
+;;
+(send pattern-class :answer :next-natural '()
+ '((block pattern:next-natural-block ;; so we can return from inside while loop
+ (xm-traceif ":next-natural current" current)
+ (while t
+ (cond ((null count)
+ (setf have-current nil)
+ ;; :merge parameter is not used by every pattern, but it does not
+ ;; hurt to evaluate it here
+ (setf merge-flag (if merge-pattern (next merge-pattern)))
+ (send self :start-period nil))) ;; sets count
+ (xm-traceif "count" count "is-nested" is-nested)
+ (cond (is-nested
+ (cond ((zerop count)
+ (cond (merge-flag ;; we filtered out +eop+; return one here
+ (setf count -1)
+ (return-from pattern:next-natural-block +eop+))
+ (t
+ (setf count nil)
+ (return-from pattern:next-natural-block +eonp+))))
+ ((eql count -1)
+ (setf count nil)
+ (return-from pattern:next-natural-block +eonp+))))
+ (t
+ (cond ((zerop count)
+ (setf count -1)
+ (return-from pattern:next-natural-block +eop+))
+ ((eql count -1)
+ (setf count nil)
+ (return-from pattern:next-natural-block +eonp+)))))
+ (cond ((not have-current)
+ (send self :advance)
+ (setf have-current t)
+ (if trace (send self :write-trace "advanced to" current))
+ (xm-traceif ":advance current" current)))
+ (cond ((not is-nested)
+ (setf have-current nil)
+ (decf count)
+ (return-from pattern:next-natural-block current)))
+ ;; nested, so get sub-pattern's next item or +eonp+ or +eop+
+ (let ((rslt (send current :next)))
+ (xm-traceif "in :next-natural got from sub-pattern " rslt)
+ (cond ((eq rslt +eonp+)
+ (setf have-current nil) ;; force advance next time, don't
+ ;; return +eonp+ until count == 0
+ (decf count))
+ ((and (eq rslt +eop+) merge-flag)) ;; iterate, skip +eop+
+ (t
+ (return-from pattern:next-natural-block rslt))))))))
+
+
+
+(send pattern-class :answer :is-nested '() '(is-nested))
+
+
+(send pattern-class :answer :name '() '(name))
+
+
+(send pattern-class :answer :set-current '(c)
+ '((setf current c)
+ (let ((value
+ (if (patternp current)
+ (send current :name)
+ current)))
+ (xm-traceif ":set-current" name "value" value)
+ )))
+
+
+;; get-pattern-name - used for debugging, handles non-patterns safely
+;;
+(defun get-pattern-name (pattern)
+ (cond ((patternp pattern) (send pattern :name))
+ (t pattern)))
+
+
+;; more debugging support
+(setf xm-next-nesting -1)
+(setf *xm-trace* nil)
+
+;; use xm-traceif for verbose printing. It only prints if *xm-trace*
+;;
+(defun xm-traceif (&rest items)
+ (if *xm-trace* (apply #'xm-trace items)))
+
+;; use xm-traceif-return for verbose printing of return values.
+;; It only prints if *xm-trace*. Includes decrement of xm-next-nesting.
+;;
+(defun xm-traceif-return (method pattern val)
+ (xm-traceif method (get-pattern-name pattern) "returning" val)
+ (decf xm-next-nesting)
+ val)
+
+;; use xm-trace for normal tracing enabled by the trace flag in patterns
+;;
+(defun xm-trace (&rest items)
+ (princ "|")
+ (dotimes (i xm-next-nesting) (princ " |"))
+ (dolist (item items) (princ item) (princ " "))
+ (terpri))
+
+
+;; next -- get the next element in a pattern
+;;
+;; any non-pattern value is simply returned
+;;
+(defun next (pattern &optional period-flag)
+ (incf xm-next-nesting)
+ (xm-traceif "next" (get-pattern-name pattern) period-flag)
+ (cond ((and period-flag (patternp pattern))
+ (let (rslt elem)
+ (incf xm-next-nesting)
+ (xm-traceif "next sending :next to" (get-pattern-name pattern))
+ (while (not (eq (setf elem (send pattern :next)) +eop+))
+ (xm-traceif "next got" elem "from" (get-pattern-name pattern))
+ (if (not (eq elem +eonp+))
+ (push elem rslt))
+ (if (null elem) (error "got null elem"))) ;;;;;;;; DEBUG ;;;;;;;;;;;
+ (decf xm-next-nesting)
+ (xm-traceif-return "next" pattern (reverse rslt))))
+ (period-flag
+ (xm-traceif "next with period-flag" (get-pattern-name pattern))
+ (error (format nil "~A, next expected a pattern"
+ (get-pattern-name pattern))))
+ ((patternp pattern)
+ (xm-traceif "next with pattern" (get-pattern-name pattern) pattern)
+ (let (rslt)
+ (dotimes (i 10000 (error
+ (format nil
+ "~A, just retrieved 10000 empty periods -- is there a bug?"
+ (get-pattern-name pattern))))
+ (if (not (member (setf rslt (send pattern :next))
+ '(+eop+ +eonp+)))
+ (return (xm-traceif-return "next" pattern rslt))))))
+ (t ;; pattern not a pattern, so just return it:
+ (xm-traceif "next not pattern" pattern)
+ (xm-traceif-return "next" pattern pattern))))
+
+;; ---- LENGTH Class ----
+
+(setf length-class
+ (send class :new '(pattern length-pattern) '() pattern-class))
+
+(send length-class :answer :isnew '(p l nm tr)
+ '((send-super :isnew nil l nm tr) ;; note: no merge pattern is applicable
+ (setf pattern p)))
+
+;; note that count is used as a flag as well as a counter.
+;; If count is nil, then the pattern-length has not been
+;; determined. Count is nil intitially and again at the
+;; end of each period. Otherwise, count is an integer
+;; used to count down the number of items remaining in
+;; the period.
+
+(send length-class :answer :start-period '(forcount)
+ '((setf count (next length-pattern))))
+
+(send length-class :answer :advance '()
+ '((send self :set-current (next pattern))))
+
+(defun make-length (pattern length-pattern &key (name "length") trace)
+ (send length-class :new pattern length-pattern name trace))
+
+;; ---- CYCLE Class ---------
+
+(setf cycle-class (send class :new
+ '(lis cursor lis-pattern)
+ '() pattern-class))
+
+(send cycle-class :answer :isnew '(l mp for nm tr)
+ '((send-super :isnew mp for nm tr)
+ (cond ((patternp l)
+ (setf lis-pattern l))
+ ((listp l)
+ (send self :set-list l tr))
+ (t
+ (error (format nil "~A, expected list" nm) l)))))
+
+
+(send cycle-class :answer :set-list '(l tr)
+ '((setf lis l)
+ (check-for-list lis "cycle-class :set-list")
+ (setf is-nested (list-has-pattern lis))
+ (setf lis (make-homogeneous lis tr))))
+
+
+(send cycle-class :answer :start-period '(forcount)
+ '((xm-traceif "cycle-class :start-period" "lis-pattern"
+ (get-pattern-name lis-pattern) "lis" lis "count" count
+ "length-pattern" (get-pattern-name length-pattern))
+ (cond (lis-pattern
+ (send self :set-list (next lis-pattern t) trace)))
+ ;; notice that list gets reset at the start of the period
+ (setf cursor lis)
+ (if (null count)
+ (setf count (length lis)))))
+
+
+(send cycle-class :answer :advance '()
+ '((cond ((and (null cursor) lis)
+ (setf cursor lis))
+ ((null cursor)
+ (error (format nil "~A, :advance - no items" name))))
+ (send self :set-current (car cursor))
+ (pop cursor)))
+
+
+(defun make-cycle (lis &key merge for (name "cycle") trace)
+ (check-for-list-or-pattern lis "make-cycle")
+ (send cycle-class :new lis merge for name trace))
+
+;; ---- LINE class ----
+
+(setf line-class (send class :new '(lis cursor lis-pattern)
+ '() pattern-class))
+
+(send line-class :answer :isnew '(l mp for nm tr)
+ '((send-super :isnew mp for nm tr)
+ (cond ((patternp l)
+ (setf lis-pattern l))
+ ((listp l)
+ (send self :set-list l tr))
+ (t
+ (error (format nil "~A, expected list" nm) l)))))
+
+
+(send line-class :answer :set-list '(l tr)
+ '((setf lis l)
+ (check-for-list lis "line-class :set-list")
+ (setf is-nested (list-has-pattern lis))
+ (setf lis (make-homogeneous l tr))
+ (setf cursor lis)))
+
+
+(send line-class :answer :start-period '(forcount)
+ '((cond (lis-pattern
+ (send self :set-list (next lis-pattern t) trace)
+ (setf cursor lis)))
+ (if (null count)
+ (setf count (length lis)))))
+
+
+(send line-class :answer :advance '()
+ '((cond ((null cursor)
+ (error (format nil "~A, :advance - no items" name))))
+ (send self :set-current (car cursor))
+ (if (cdr cursor) (pop cursor))))
+
+
+(defun make-line (lis &key merge for (name "line") trace)
+ (check-for-list-or-pattern lis "make-line")
+ (send line-class :new lis merge for name trace))
+
+
+;; ---- RANDOM class -----
+
+(setf random-class (send class :new
+ '(lis lis-pattern len previous repeats mincnt maxcnt)
+ '() pattern-class))
+
+;; the structure is (value weight weight-pattern max max-pattern min min-pattern)
+(setfn rand-item-value car)
+(defun set-rand-item-value (item value) (setf (car item) value))
+
+(setfn rand-item-weight cadr)
+(defun set-rand-item-weight (item weight) (setf (car (cdr item)) weight))
+(setfn rand-item-weight-pattern caddr)
+
+(setfn rand-item-max cadddr)
+(defun set-rand-item-max (item max) (setf (car (cdddr item)) max))
+(defun rand-item-max-pattern(item) (car (cddddr item)))
+
+(defun rand-item-min (lis) (cadr (cddddr lis)))
+(defun set-rand-item-min (item min) (setf (car (cdr (cddddr item))) min))
+(defun rand-item-min-pattern(item) (car (cddr (cddddr item))))
+
+
+(defun select-random (len lis previous repeats mincnt maxcnt)
+ (let (sum items r)
+ (cond ((zerop len)
+ (break "random-class has no list to choose from")
+ nil)
+ (t
+ (setf sum 0)
+ (dolist (item lis)
+ (setf sum (+ sum (rand-item-weight item))))
+ (setf items lis)
+ (setf r (rrandom))
+ (setf sum (* sum r))
+ (loop
+ (setf sum (- sum (rand-item-weight (car items))))
+ (if (<= sum 0) (return (car items)))
+ (setf items (cdr items)))))))
+
+
+(defun random-convert-spec (item)
+ ;; convert (value :weight wp :min min :max max) to (value nil wp max min)
+ (let (value (wp 1) minpat maxpat lis)
+ (setf value (car item))
+ (setf lis (cdr item))
+ (while lis
+ (cond ((eq (car lis) :weight)
+ (setf wp (cadr lis)))
+ ((eq (car lis) :min)
+ (setf minpat (cadr lis)))
+ ((eq (car lis) :max)
+ (setf maxpat (cadr lis)))
+ (t
+ (error "(make-random) item syntax error" item)))
+ (setf lis (cddr lis)))
+ (list value nil wp nil maxpat nil minpat)))
+
+
+(defun random-atom-to-list (a)
+ (if (atom a)
+ (list a nil 1 nil nil nil nil)
+ (random-convert-spec a)))
+
+
+(send random-class :answer :isnew '(l mp for nm tr)
+ ;; there are two things we have to normalize:
+ ;; (1) make all items lists
+ ;; (2) if any item is a pattern, make all items patterns
+ '((xm-traceif "random :isnew list" l "merge" mp "for" for "name" nm "trace" tr)
+ (send-super :isnew mp for nm tr)
+ (cond ((patternp l)
+ (setf lis-pattern l))
+ ((listp l)
+ (send self :set-list l))
+ (t
+ (error (format nil "~A, expected list") l)))))
+
+
+(send random-class :answer :set-list '(l)
+ '((check-for-list l "random-class :set-list")
+ (setf lis (mapcar #'random-atom-to-list l))
+ ; (display "random set-list" lis)
+ (dolist (item lis)
+ (if (patternp (rand-item-value item))
+ (setf is-nested t)))
+ (if is-nested
+ (mapcar #'(lambda (item)
+ (if (not (patternp (rand-item-value item)))
+ (set-rand-item-value item
+ (make-cycle (list (rand-item-value item))))))
+ lis))
+ (xm-traceif "random is-new" name lis)
+ (setf repeats 0)
+ (setf len (length lis))))
+
+
+(send random-class :answer :start-period '(forcount)
+ '((xm-traceif "random-class :start-period" name "count" count "len" len
+ "lis" lis "lis-pattern" (get-pattern-name lis-pattern))
+ (cond (lis-pattern
+ (send self :set-list (next lis-pattern t))))
+ (if (null count)
+ (setf count len))
+ (dolist (item lis)
+ (set-rand-item-weight item (next (rand-item-weight-pattern item)))
+ (set-rand-item-max item (next (rand-item-max-pattern item)))
+ (set-rand-item-min item (next (rand-item-min-pattern item))))
+ ; (display "random start-period" lis-pattern lis)
+ ))
+
+
+(send random-class :answer :advance '()
+ '((let (selection (iterations 0))
+ (xm-traceif "random-class :advance" name "mincnt" mincnt
+ "repeats" repeats)
+ (cond ((and mincnt (< repeats mincnt))
+ (setf selection previous))
+ (t
+ (setf selection
+ (select-random len lis previous repeats mincnt maxcnt))))
+ (loop ; make sure selection is ok, otherwise try again
+ (cond ((and (eq selection previous)
+ maxcnt
+ (>= repeats maxcnt)) ; hit maximum limit, try again
+ (setf selection
+ (select-random len lis previous repeats mincnt maxcnt))
+ (incf iterations)
+ (cond ((> iterations 10000)
+ (error
+ (format nil
+ "~A, unable to pick next item after 10000 tries"
+ name)
+ lis))))
+ (t (return)))) ; break from loop, we found a selection
+
+ ; otherwise, we are ok
+ ; notice that we could have selected based on an older maxcnt and
+ ; maxcnt may now be smaller. This is allowed. Perhaps another
+ ; rule would be better, e.g. update maxcnt and check against it
+ ; with each selection.
+ (if (not (eq selection previous))
+ (setf repeats 1)
+ (incf repeats))
+ (setf mincnt (rand-item-min selection))
+ (setf maxcnt (rand-item-max selection))
+ (setf previous selection)
+ (xm-traceif "new selection" name "repeats" repeats "mincnt" mincnt
+ "maxcnt" maxcnt "selection" selection)
+ (send self :set-current (rand-item-value selection)))))
+
+
+(defun make-random (lis &key merge for (name "random") trace)
+ (check-for-list-or-pattern lis "make-random")
+ (send random-class :new lis merge for name trace))
+
+
+;; ---- PALINDROME class -----
+
+#| Palindrome includes elide, which is either t, nil, :first, or :last.
+The pattern length is the "natural" length of the pattern, which goes
+forward and backward through the list. Thus, if the list is of length N,
+the palindrome length depends on elide as follows:
+ elide length
+ nil 2N
+ t 2N - 2
+ :first 2N - 1
+ :last 2N - 1
+If elide is a pattern, and if length is not specified, then length should
+be computed based on elide.
+|#
+
+
+(setf palindrome-class (send class :new
+ '(lis revlis lis-pattern
+ direction elide-pattern
+ elide cursor)
+ '() pattern-class))
+
+(send palindrome-class :answer :set-list '(l tr)
+ '((setf lis l)
+ (check-for-list lis "palindrome-class :start-period")
+ (setf is-nested (list-has-pattern lis))
+ (setf lis (make-homogeneous l tr))
+ (send self :set-cursor)))
+
+(send palindrome-class :answer :set-cursor '()
+ '((setf revlis (reverse lis)
+ direction t
+ cursor lis)))
+
+
+(send palindrome-class :answer :isnew '(l e mp for nm tr)
+ '((send-super :isnew mp for nm tr)
+ (cond ((patternp l)
+ (setf lis-pattern l))
+ ((listp l)
+ (send self :set-list l tr))
+ (t
+ (error (format nil "~A, expected list" nm) l)))
+ (setf elide-pattern e)))
+
+
+(send palindrome-class :answer :start-period '(forcount)
+ '((cond (lis-pattern
+ (send self :set-list (next lis-pattern t) trace)))
+ ;; like cycle, list is reset at the start of the period
+ (send self :set-cursor)
+ (setf elide (next elide-pattern))
+ (if (and elide (null lis))
+ (error (format nil "~A, cannot elide if list is empty" name)))
+ (if (null count)
+ (setf count (- (* 2 (length lis))
+ (if (member elide '(:first :last))
+ 1
+ (if elide 2 0)))))
+ (if (<= count 0)
+ (error (format nil "palindrome ~A period is <= 0"
+ (get-pattern-name self))))))
+
+
+(send palindrome-class :answer :next-item '()
+ '((send self :set-current (car cursor))
+ (pop cursor)
+ (cond ((and cursor (not (cdr cursor))
+ (or (and direction (member elide '(:last t)))
+ (and (not direction) (member elide '(:first t)))))
+ (pop cursor)))))
+
+
+(send palindrome-class :answer :advance '()
+ '(
+ (cond (cursor
+ (send self :next-item))
+ (direction ;; we're going forward
+ (setf direction nil) ;; now going backward
+ (setf cursor revlis)
+ (xm-traceif "palindrome at end" (get-pattern-name self)
+ "current" (get-pattern-name (car cursor)))
+ (send self :next-item))
+ (t ;; direction is reverse
+ (setf direction t)
+ (setf cursor lis)
+ (send self :next-item)))))
+
+
+(defun make-palindrome (lis &key elide merge for (name "palindrome") trace)
+ (check-for-list-or-pattern lis "make-palindrome")
+ (send palindrome-class :new lis elide merge for name trace))
+
+
+;; ================= HEAP CLASS ======================
+
+;; to handle the :max keyword, which tells the object to avoid
+;; repeating the last element of the previous period:
+;;
+;; maxcnt = 1 means "avoid the repetition"
+;; check-repeat signals we are at the beginning of the period and must check
+;; prev holds the previous value (initially nil)
+;; after each item is generated, check-repeat is cleared. It is
+;; recalculated when a new period is started.
+
+(setf heap-class (send class :new '(lis used maxcnt maxcnt-pattern prev
+ check-repeat lis-pattern len)
+ '() pattern-class))
+
+(send heap-class :answer :isnew '(l mp for mx nm tr)
+ '((send-super :isnew mp for nm tr)
+ (cond ((patternp l)
+ (setf lis-pattern l))
+ ((listp l)
+ ; make a copy of l to avoid side effects
+ (send self :set-list (append l nil) tr))
+ (t
+ (error (format nil "~A, expected list" nm) l)))
+ (cond ((patternp mx)
+ (setf maxcnt-pattern mx))
+ ((not (numberp mx))
+ (error (format nil "~A, expected number" nm) mx))
+ (t
+ (setf maxcnt mx)))))
+
+
+(send heap-class :answer :set-list '(l tr)
+ '((setf lis l)
+ (check-for-list lis "heap-class :set-list")
+ (setf is-nested (list-has-pattern lis))
+ (setf lis (make-homogeneous lis tr))
+ (setf len (length lis))))
+
+
+(send heap-class :answer :start-period '(forcount)
+ '((xm-traceif "heap-class :start-period" name "lis-pattern"
+ (get-pattern-name lis-pattern) "count" count "lis" lis)
+ (cond (lis-pattern
+ (send self :set-list (next lis-pattern t) trace)))
+ (cond (maxcnt-pattern
+ (setf maxcnt (next maxcnt-pattern))))
+ ; start of period -- may need to avoid repeating previous item
+ (if (= maxcnt 1) (setf check-repeat t))
+ (if (null count)
+ (setf count len))))
+
+
+(defun delete-first (elem lis)
+ (cond ((null lis) nil)
+ ((eq elem (car lis))
+ (cdr lis))
+ (t
+ (cons (car lis) (delete-first elem (cdr lis))))))
+
+
+;; NO-DISTINCT-ELEM -- check if any element of list is not val
+;;
+(defun no-distinct-elem (lis val)
+ (not
+ (dolist (elem lis)
+ (if (not (equal elem val))
+ ;; there is a distinct element, return t from dolist
+ (return t)))))
+ ;; if no distinct element, dolist returns nil, but this is negated
+ ;; by the NOT so the function will return t
+
+
+(send heap-class :answer :advance '()
+ '((cond ((null lis)
+ (setf lis used)
+ (setf used nil)))
+ (let (n elem)
+ (cond ((and check-repeat (no-distinct-elem lis prev))
+ (error (format nil "~A, cannot avoid repetition, but :max is 1"
+ name))))
+ (loop
+ (setf n (random (length lis)))
+ (setf elem (nth n lis))
+ (if (or (not check-repeat) (not (equal prev elem)))
+ (return))) ;; loop until suitable element is chosen
+ (setf lis (delete-first elem lis))
+ (push elem used)
+ (setf check-repeat nil)
+ (setf prev elem)
+ (send self :set-current elem))))
+
+(defun make-heap (lis &key merge for (max 2) (name "heap") trace)
+ (send heap-class :new lis merge for max name trace))
+
+;;================== COPIER CLASS ====================
+
+(setf copier-class (send class :new '(sub-pattern repeat repeat-pattern
+ period cursor)
+ '() pattern-class))
+
+(send copier-class :answer :isnew '(p r m for nm tr)
+ '((send-super :isnew m for nm tr)
+ (setf sub-pattern p repeat-pattern r)))
+
+
+#| copier-class makes copies of periods from sub-pattern
+
+If merge is true, the copies are merged into one big period.
+If merge is false, then repeat separate periods are returned.
+If repeat is negative, then -repeat periods of sub-pattern
+are skipped.
+
+merge-flag and repeat are computed from merge-pattern and
+repeat-pattern initially and after making repeat copies
+
+To repeat individual items, set the :for keyword parameter of
+the sub-pattern to 1.
+|#
+
+(send copier-class :answer :start-period '(forcount)
+ '((cond ((null count)
+ (cond ((or (null repeat) (zerop repeat))
+ (send self :really-start-period))
+ (t
+ (setf count (length period))))))))
+
+
+(send copier-class :answer :really-start-period '()
+ '((xm-traceif "copier-class :really-start-period" name "count" count)
+ (setf repeat (next repeat-pattern))
+ (while (minusp repeat)
+ (dotimes (i (- repeat))
+ (setf period (next sub-pattern t)))
+ (setf repeat (next repeat-pattern))
+ (setf merge-flag (next merge-pattern)))
+
+; (print "** STARTING NEXT PATTERN IN COPIER-CLASS")
+
+ (setf period (next sub-pattern t))
+
+; (display "copier-class really-start-period got" period)
+; (print "** ENDING NEXT PATTERN IN COPIER-CLASS")
+
+ (setf cursor nil)
+ (if (null count)
+ (setf count (* (if merge-flag repeat 1)
+ (length period))))))
+
+
+(send copier-class :answer :advance '()
+ '((let ((loop-count 0))
+ (loop
+ (xm-traceif "copier loop" name "repeat" repeat "cursor" cursor
+ "period" period)
+ (cond (cursor
+ (send self :set-current (car cursor))
+ (pop cursor)
+ (return))
+ ((plusp repeat)
+ (decf repeat)
+ (setf cursor period))
+ ((> loop-count 10000)
+ (error (format nil
+ "~A, copier-class :advance encountered 10000 empty periods"
+ name)))
+ (t
+ (send self :really-start-period)))
+ (incf loop-count)))))
+
+
+(defun make-copier (sub-pattern &key for (repeat 1) merge (name "copier") trace)
+ (send copier-class :new sub-pattern repeat merge for name trace))
+
+;; ================= ACCUMULATE-CLASS ===================
+
+(setf accumulate-class (send class :new '(sub-pattern period cursor sum
+ mini maxi minimum maximum)
+ '() pattern-class))
+
+
+(send accumulate-class :answer :isnew '(p mp for nm tr mn mx)
+ '((send-super :isnew mp for nm tr)
+ (setf sub-pattern p sum 0 mini mn maxi mx)
+ ;(xm-trace "accumulate isnew" self nm)
+ ))
+
+
+#|
+accumulate-class creates sums of numbers from another pattern
+The output periods are the same as the input periods (by default).
+
+(send accumulate-class :answer :start-period '(forcount)
+ '((cond ((null count)
+ (send self :really-start-period)))))
+
+(send accumulate-class :answer :really-start-period '()
+|#
+
+
+(send accumulate-class :answer :start-period '(forcount)
+ '((setf period (next sub-pattern t))
+ (setf cursor period)
+ (xm-traceif "accumulate-class :start-period" name "period" period
+ "cursor" cursor "count" count)
+ (if maxi (setf maximum (next maxi)))
+ (if mini (setf minimum (next mini)))
+ (if (null count)
+ (setf count (length period)))))
+
+
+(send accumulate-class :answer :advance '()
+ '((let ((loop-count 0))
+ (loop
+ (cond (cursor
+ (setf sum (+ sum (car cursor)))
+ (cond ((and (numberp minimum) (< sum minimum))
+ (setf sum minimum)))
+ (cond ((and (numberp maximum) (> sum maximum))
+ (setf sum maximum)))
+ (send self :set-current sum)
+ (pop cursor)
+ (return))
+ ((> loop-count 10000)
+ (error (format nil
+ "~A, :advance encountered 10000 empty periods" name)))
+ (t
+ (send self :start-period nil)))
+ (incf loop-count)))))
+
+
+(defun make-accumulate (sub-pattern &key merge for min max (name "accumulate") trace)
+ (send accumulate-class :new sub-pattern merge for name trace min max))
+
+;;================== ACCUMULATION CLASS ===================
+
+;; for each item, generate all items up to and including the item, e.g.
+;; (a b c) -> (a a b a b c)
+
+(setf accumulation-class (send class :new '(lis lis-pattern outer inner len)
+ '() pattern-class))
+
+(send accumulation-class :answer :isnew '(l mp for nm tr)
+ '((send-super :isnew mp for nm tr)
+ (cond ((patternp l)
+ (setf lis-pattern l))
+ ((listp l)
+ (send self :set-list l))
+ (t
+ (error (format nil "~A, expected list" nm) l)))))
+
+
+(send accumulation-class :answer :set-list '(l)
+ '((setf lis l)
+ (check-for-list lis "heap-class :set-list")
+ (setf lis (make-homogeneous lis trace))
+ (setf inner lis)
+ (setf outer lis)
+ (setf len (length lis))))
+
+(send accumulation-class :answer :start-period '(forcount)
+ '((cond (lis-pattern
+ (send self :set-list (next lis-pattern t))))
+ ; start of period, length = (n^2 + n) / 2
+ (if (null count) (setf count (/ (+ (* len len) len) 2)))))
+
+(send accumulation-class :answer :advance '()
+ ;; inner traverses lis from first to outer
+ ;; outer traverses lis
+ '((let ((elem (car inner)))
+ (cond ((eq inner outer)
+ (setf outer (rest outer))
+ (setf outer (if outer outer lis))
+ (setf inner lis))
+ (t
+ (setf inner (rest inner))))
+ (send self :set-current elem))))
+
+(defun make-accumulation (lis &key merge for (name "accumulation") trace)
+ (send accumulation-class :new lis merge for name trace))
+
+
+;;================== SUM CLASS =================
+
+(setf sum-class (send class :new '(x y period cursor fn) '() pattern-class))
+
+(send sum-class :answer :isnew '(xx yy mp for nm tr)
+ '((send-super :isnew mp for nm tr)
+ (setf x xx y yy fn #'+)))
+
+#|
+sum-class creates pair-wise sums of numbers from 2 streams.
+The output periods are the same as the input periods of the first
+pattern argument (by default).
+|#
+
+(send sum-class :answer :start-period '(forcount)
+ '((cond ((null count)
+ (send self :really-start-period)))))
+
+(send sum-class :answer :really-start-period '()
+ '((setf period (next x t))
+ (setf cursor period)
+ (if (null count)
+ (setf count (length period)))))
+
+(send sum-class :answer :advance '()
+ '((let ((loop-count 0) rslt)
+ (loop
+ (cond (cursor
+ (setf rslt (funcall fn (car cursor) (next y)))
+ (send self :set-current rslt)
+ (pop cursor)
+ (return))
+ ((> loop-count 10000)
+ (error (format nil
+ "~A, :advance encountered 10000 empty periods" name)))
+ (t
+ (send self :really-start-period)))
+ (incf loop-count)))))
+
+
+(defun make-sum (x y &key merge for (name "sum") trace)
+ (send sum-class :new x y merge for name trace))
+
+
+;;================== PRODUCT CLASS =================
+
+(setf product-class (send class :new '() '() sum-class))
+
+(send product-class :answer :isnew '(xx yy mp for nm tr)
+ '((send-super :isnew xx yy mp for nm tr)
+ (setf x xx y yy fn #'*)))
+
+(defun make-product (x y &key merge for (name "product") trace)
+ (send product-class :new x y merge for name trace))
+
+
+;;================== EVAL CLASS =================
+;;
+;; (1) if :for, then period is determined by :for and we should
+;; just fetch the next item from expr-pattern or use expr
+;; (this case is length-pattern)
+;; (2) if expr-pattern and not :for, then we should fetch a whole
+;; period from expr-pattern and use it to determine period len
+;; (this case is (and expr-pattern (not length-pattern)))
+;; (3) if not expr-pattern and not :for, then the pattern len is 1
+;; (this case is (and (not expr-pattern) (not length-pattern)))
+
+(setf eval-class (send class :new '(expr expr-pattern)
+ '() pattern-class))
+
+(send eval-class :answer :isnew '(e mp for nm tr)
+ '((send-super :isnew mp for nm tr)
+ (cond ((patternp e)
+ (setf expr-pattern e))
+ (t
+ (setf expr e)))))
+
+
+(send eval-class :answer :start-period '(forcount)
+ '((xm-traceif "eval-class :start-period" name "lis-pattern"
+ (get-pattern-name expr-pattern) "expr" expr "count" count
+ "length-pattern" (get-pattern-name expr-pattern))
+ (cond (length-pattern t) ;; case 1
+ (expr-pattern ;; case 2
+ (setf expr (next expr-pattern t))
+ (setf count (length expr)))
+ (t ;; case 3
+ (setf count 1)))))
+
+
+(send eval-class :answer :advance '()
+ '((send self :set-current
+ (cond ((and length-pattern expr-pattern)
+ (eval (next expr-pattern)))
+ (length-pattern
+ (eval expr))
+ (expr-pattern
+ (let ((item (car expr)))
+ (setf expr (cdr expr))
+ item))
+ (t (eval expr))))))
+
+
+(defun make-eval (expr &key merge (for 1) (name "eval") trace)
+ (send eval-class :new expr merge for name trace))
+
+;;================== MARKOV CLASS ====================
+
+(setf markov-class (send class :new
+ '(rules order state produces pattern len)
+ '() pattern-class))
+
+
+(defun is-produces-homogeneous (produces)
+ (let (type elem)
+ (setf *rslt* nil)
+ (loop
+ (cond ((or (null produces) (eq produces :eval) (null (cadr produces)))
+ (return t)))
+ (setf elem (cadr produces))
+ (cond ((null type)
+ (setf type (if (patternp elem) 'pattern 'atom))
+ (xm-traceif "is-produces-homogeneous type" type)
+ (setf *rslt* (eq type 'pattern))
+ (xm-traceif "is-produces-homogeneous *rslt*" *rslt*)
+ )
+ ((and (eq type 'pattern) (not (patternp elem)))
+ (return nil))
+ ((and (eq type 'atom)
+ (patternp elem))
+ (return nil)))
+ (setf produces (cddr produces)))))
+
+
+(defun make-produces-homogeneous (produces)
+ (let (result item)
+ (loop
+ (if (null produces) (return nil))
+ (push (car produces) result)
+ (setf produces (cdr produces))
+ (setf item (car produces))
+ (setf produces (cdr produces))
+ (if (not (patternp item))
+ (setf item (make-cycle (list item))))
+ (push item result))
+ (reverse result)))
+
+
+(send markov-class :answer :isnew '(r o s p mp for nm tr)
+ ;; input parameters are rules, order, state, produces, for, name, trace
+ '((send-super :isnew mp for nm tr)
+ (setf order o state s produces p)
+ (setf len (length r))
+ ;; input r looks like this:
+ ;; ((prev1 prev2 -> next1 next2 (next3 weight) ... ) ...)
+ ;; transition table will look like a list of these:
+ ;; ((prev1 prev2 ... prevn) (next1 weight weight-pattern) ...)
+ (dolist (rule r)
+ (let ((targets (cdr (nthcdr order rule)))
+ entry pattern)
+ ;; build entry in reverse order
+ (dolist (target targets)
+ (push (if (atom target)
+ (list target 1 1)
+ (list (first target)
+ (next (second target))
+ (second target)))
+ entry))
+ (xm-traceif "markov-class isnew" name "entry" entry "rule" rule
+ "targets" targets "order" order (nthcdr order rule))
+ (dotimes (i order)
+ (push (nth i rule) pattern))
+ (push (cons (reverse pattern) entry) rules)))
+ (setf rules (reverse rules)) ;; keep rules in original order
+ (setf *rslt* nil) ;; in case produces is nil
+ (cond ((and produces (not (is-produces-homogeneous produces)))
+ (setf produces (make-produces-homogeneous produces))))
+ (xm-traceif "markov-class :isnew" name "is-nested" *rslt*)
+ (setf is-nested *rslt*) ;; returned by is-produces-homogeneous
+ ))
+
+
+(defun markov-match (state pattern)
+ (dolist (p pattern t) ;; return true if no mismatch
+ ;; compare element-by-element
+ (cond ((eq p '*)) ; anything matches '*
+ ((eql p (car state)))
+ (t (return nil))) ; a mismatch: return false
+ (setf state (cdr state))))
+
+
+(defun markov-pick-target (sum rule)
+ (let ((total 0.0)
+ ;; want to choose a value in the interval [0, sum)
+ ;; but real-random is not open on the right, so fudge
+ ;; the range by a small amount:
+ (r (real-random 0.0 (- sum SCORE-EPSILON))))
+ (dolist (target (cdr rule))
+ (setf total (+ total (second target)))
+ (cond ((> total r) (return (car target)))))))
+
+
+(defun markov-update-weights (rule)
+ (dolist (target (cdr rule))
+ (setf (car (cdr target)) (next (caddr target)))))
+
+
+(defun markov-map-target (target produces)
+ (while (and produces (not (eq target (car produces))))
+ (setf produces (cddr produces)))
+ (let ((rslt (cadr produces)))
+ (if (not rslt) (setf rslt target)) ;; if lookup fails return target
+ (if (patternp rslt) (setf rslt (next rslt)))
+ rslt))
+
+
+(send markov-class :answer :sum-of-weights '(rule)
+ '((let ((sum 0.0))
+ (dolist (target (cdr rule))
+ (xm-traceif "markov-sum-of-weights" name "target" target)
+ (setf sum (+ sum (second target))))
+ sum)))
+
+
+(send markov-class :answer :find-rule '()
+ '((let (rslt)
+ (xm-traceif "markov-class find-rule" name "rules" rules)
+ (dolist (rule rules)
+ (xm-traceif "markov find-rule" name "state" state "rule" rule)
+ (cond ((markov-match state (car rule))
+ (setf rslt rule)
+ (return rslt))))
+ (cond ((null rslt)
+ (display "Error, no matching rule found" state rules)
+ (error (format nil "~A, (markov-class)" name))))
+ rslt)))
+
+
+(send markov-class :answer :start-period '(forcount)
+ '((if (null count)
+ (setf count len))))
+
+(defun markov-general-rule-p (rule)
+ (let ((pre (car rule)))
+ (cond ((< (length pre) 2) nil) ;; 1st-order mm
+ (t
+ ;; return false if any member not *
+ ;; return t if all members are *
+ (dolist (s pre t)
+ (if (eq s '*) t (return nil)))))))
+
+(defun markov-find-state-leading-to (target rules)
+ (let (candidates)
+ (dolist (rule rules)
+ (let ((targets (cdr rule)))
+ (dolist (targ targets)
+ (cond ((eql (car targ) target)
+ (push (car rule) candidates))))))
+ (cond (candidates ;; found at least one
+ (nth (random (length candidates)) candidates))
+ (t
+ nil))))
+
+(send markov-class :answer :advance '()
+ '((let (rule sum target rslt new-state)
+ (xm-traceif "markov :advance" name "pattern" pattern "rules" rules)
+ (setf rule (send self :find-rule))
+ (markov-update-weights rule)
+ (xm-traceif "markov sum-of-weights" name "rule" rule)
+ (setf sum (send self :sum-of-weights rule))
+ ;; the target can be a pattern, so apply NEXT to it
+ (setf target (next (markov-pick-target sum rule)))
+ ;; if the matching rule is multiple *'s, then this
+ ;; is a higher-order Markov model, and we may now
+ ;; wander around in parts of the state space that
+ ;; never appeared in the training data. To avoid this
+ ;; we violate the strict interpretation of the rules
+ ;; and pick a random state sequence from the rule set
+ ;; that might have let to the current state. We jam
+ ;; this state sequence into state so that when we
+ ;; append target, we'll have a history that might
+ ;; have a corresponding rule next time.
+ (cond ((markov-general-rule-p rule)
+ (setf new-state (markov-find-state-leading-to target rules))
+ (cond (new-state
+ (xm-trace "markov state replacement" name
+ "new-state" new-state "target" target)
+ (setf state new-state)))))
+ (setf state (append (cdr state) (list target)))
+ (xm-traceif "markov next" name "rule" rule "sum" sum "target" target
+ "state" state)
+ ;; target is the symbol for the current state. We can
+ ;; return target (default), the value of target, or a
+ ;; mapped value:
+ (cond ((eq produces :eval)
+ (setf target (eval target)))
+ ((and produces (listp produces))
+ (xm-traceif "markov-produce" name "target" target
+ "produces" produces)
+ (setf target (markov-map-target target produces))))
+ (if (not (eq is-nested (patternp target)))
+ (error (format nil
+ "~A :is-nested keyword (~A) not consistent with result (~A)"
+ name is-nested target)))
+ (send self :set-current target))))
+
+
+(defun make-markov (rules &key produces past merge for (name "markov") trace)
+ ;; check to make sure past and rules are consistent
+ (let ((order (length past)))
+ (dolist (rule rules)
+ (dotimes (i order)
+ (if (eq (car rule) '->)
+ (error (format nil "~A, a rule does not match the length of :past"
+ name)))
+ (pop rule))
+ (if (eq (car rule) '->) nil
+ (error (format nil "~A, a rule does not match the length of :past"
+ name)))))
+ (cond ((null for)
+ (setf for (length rules))))
+ (send markov-class :new rules (length past) past produces merge for name trace))
+
+
+(defun markov-rule-match (rule state)
+ (cond ((null state) t)
+ ((eql (car rule) (car state))
+ (markov-rule-match (cdr rule) (cdr state)))
+ (t nil)))
+
+
+(defun markov-find-rule (rules state)
+ (dolist (rule rules)
+ (xm-traceif "markov find-rule" name "rule" rule)
+ (cond ((markov-rule-match rule state)
+ (return rule)))))
+
+;; ------- functions below are for MARKOV-CREATE-RULES --------
+
+;; MARKOV-FIND-CHOICE -- given a next state, find it in rule
+;;
+;; use state to get the order of the Markov model, e.g. how
+;; many previous states to skip in the rule, (add 1 for '->).
+;; then use assoc to do a quick search
+;;
+;; example:
+;; (markov-find-choice '(a b -> (c 1) (d 2)) '(a b) 'd)
+;; returns (d 2) from the rule
+;;
+(defun markov-find-choice (rule state next)
+ (assoc next (nthcdr (1+ (length state)) rule)))
+
+(defun markov-update-rule (rule state next)
+ (let ((choice (markov-find-choice rule state next)))
+ (cond (choice
+ (setf (car (cdr choice)) (1+ (cadr choice))))
+ (t
+ (nconc rule (list (list next 1)))))
+ rule))
+
+
+(defun markov-update-rules (rules state next)
+ (let ((rule (markov-find-rule rules state)))
+ (cond (rule
+ (markov-update-rule rule state next))
+ (t
+ (setf rules
+ (nconc rules
+ (list (append state
+ (cons '-> (list
+ (list next 1)))))))))
+ rules))
+
+
+;; MARKOV-UPDATE-HISTOGRAM -- keep a list of symbols and counts
+;;
+;; This histogram will become the right-hand part of a rule, so
+;; the format is ((symbol count) (symbol count) ...)
+;;
+(defun markov-update-histogram (histogram next)
+ (let ((pair (assoc next histogram)))
+ (cond (pair
+ (setf (car (cdr pair)) (1+ (cadr pair))))
+ (t
+ (setf histogram (cons (list next 1) histogram))))
+ histogram))
+
+
+(defun markov-create-rules (sequence order &optional generalize)
+ (let ((seqlen (length sequence)) state rules next histogram rule)
+ (cond ((<= seqlen order)
+ (error "markov-create-rules: sequence must be longer than order"))
+ ((< order 1)
+ (error "markov-create-rules: order must be 1 or greater")))
+ ; build initial state sequence
+ (dotimes (i order)
+ (setf state (nconc state (list (car sequence))))
+ (setf sequence (cdr sequence)))
+ ; for each symbol, either update a rule or add a rule
+ (while sequence
+ (setf next (car sequence))
+ (setf sequence (cdr sequence))
+ (setf rules (markov-update-rules rules state next))
+ (setf histogram (markov-update-histogram histogram next))
+ ; shift next state onto current state list
+ (setf state (nconc (cdr state) (list next))))
+ ; generalize?
+ (cond (generalize
+ (setf rule (cons '-> histogram))
+ (dotimes (i order)
+ (setf rule (cons '* rule)))
+ (setf rules (nconc rules (list rule)))))
+ rules))
+
+
+;; ----- WINDOW Class ---------
+
+(setf window-class (send class :new
+ '(pattern skip-pattern lis cursor)
+ '() pattern-class))
+
+(send window-class :answer :isnew '(p for sk nm tr)
+ '((send-super :isnew nil for nm tr)
+ (setf pattern p skip-pattern sk)))
+
+
+(send window-class :answer :start-period '(forcount)
+ '((if (null length-pattern)
+ (error (format nil "~A, :start-period -- length-pattern is null"
+ name)))
+ (setf count forcount)
+ (cond ((null lis) ;; first time
+ (dotimes (i count)
+ (push (next pattern) lis))
+ (setf lis (reverse lis))
+ (setf cursor lis))
+ (t
+ (let ((skip (next skip-pattern)))
+ (dotimes (i skip)
+ (if lis (pop lis) (next pattern))))
+ (setf lis (reverse lis))
+ ;; now lis is in reverse order; if not long enough, push
+ (let ((len (length lis)) rslt)
+ (while (< len count)
+ (incf len)
+ (push (next pattern) lis))
+ (setf lis (reverse lis))
+ ;; lis is in order, copy it to rstl and take what we need
+ (setf rslt (reverse (append lis nil))) ;; copy lis
+ (while (> len count)
+ (decf len)
+ (pop rslt))
+ (setf cursor (reverse rslt)))))
+ (xm-traceif "window start-period cursor" cursor "lis" lis)))
+
+
+(send window-class :answer :advance '()
+ '((send self :set-current (car cursor))
+ (pop cursor)))
+
+(defun make-window (pattern length-pattern skip-pattern
+ &key (name "window") trace)
+ (send window-class :new pattern length-pattern skip-pattern name trace))
+
+;; SCORE-SORTED -- test if score is sorted
+;;
+(defun score-sorted (score)
+ (let ((result t))
+ (while (cdr score)
+ (cond ((event-before (cadr score) (car score))
+ (setf result nil)
+ (return nil)))
+ (setf score (cdr score)))
+ result))
+
+
+(defmacro score-gen (&rest args)
+ (let (key val tim dur (name ''note) ioi trace save
+ score-len score-dur others pre post
+ next-expr (score-begin 0) score-end)
+ (while (and args (cdr args))
+ (setf key (car args))
+ (setf val (cadr args))
+ (setf args (cddr args))
+ (case key
+ (:time (setf tim val))
+ (:dur (setf dur val))
+ (:name (setf name val))
+ (:ioi (setf ioi val))
+ (:trace (setf trace val))
+ (:save (setf save val))
+ (:pre (setf pre val))
+ (:post (setf post val))
+ (:score-len (setf score-len val))
+ (:score-dur (setf score-dur val))
+ (:begin (setf score-begin val))
+ (:end (setf score-end val))
+ (t (setf others (cons key (cons val others))))))
+ ;; make sure at least one of score-len, score-dur is present
+ (cond ((and (null score-len) (null score-dur))
+ (error
+ "score-gen needs either :score-len or :score-dur to limit length")))
+ ;; compute expression for dur
+ (cond ((null dur)
+ (setf dur 'sg:ioi)))
+ ;; compute expression for ioi
+ (cond ((null ioi)
+ (setf ioi 1)))
+ ;; compute expression for next start time
+ (setf next-expr '(+ sg:start sg:ioi))
+ ; (display "score-gen" others)
+ `(let (sg:seq (sg:start ,score-begin) sg:ioi
+ (sg:score-len ,score-len) (sg:score-dur ,score-dur)
+ (sg:count 0) (sg:save ,save)
+ (sg:begin ,score-begin) (sg:end ,score-end) sg:det-end)
+ ;; sg:det-end is a flag that tells us to determine the end time
+ (cond ((null sg:end) (setf sg:end 0 sg:det-end t)))
+ ;; make sure at least one of score-len, score-dur is present
+ (loop
+ (cond ((or (and sg:score-len (<= sg:score-len sg:count))
+ (and sg:score-dur (<= (+ sg:begin sg:score-dur) sg:start)))
+ (return)))
+ ,pre
+ ,(cond (tim (list 'setf 'sg:start tim)))
+ (setf sg:ioi ,ioi)
+ (setf sg:dur ,dur)
+ (push (list sg:start sg:dur (list ,name ,@others))
+ sg:seq)
+ ,post
+ (cond (,trace
+ (format t "get-seq trace at ~A stretch ~A: ~A~%"
+ sg:start sg:dur (car sg:seq))))
+ (incf sg:count)
+ (setf sg:start ,next-expr)
+ ;; end time of score will be max over start times of the next note
+ ;; this bases the score duration on ioi's rather than durs. But
+ ;; if user specified sg:end, sg:det-end is false and we do not
+ ;; try to compute sg:end.
+ (cond ((and sg:det-end (> sg:start sg:end))
+ (setf sg:end sg:start))))
+ (setf sg:seq (reverse sg:seq))
+ ;; avoid sorting a sorted list -- XLisp's quicksort can overflow the
+ ;; stack if the list is sorted because (apparently) the pivot points
+ ;; are not random.
+ (cond ((not (score-sorted sg:seq))
+ (setf sg:seq (bigsort sg:seq #'event-before))))
+ (push (list 0 0 (list 'SCORE-BEGIN-END ,score-begin sg:end)) sg:seq)
+ (cond (sg:save (set sg:save sg:seq)))
+ sg:seq)))
+
+;; ============== score manipulation ===========
+
+(defun must-be-valid-score (caller score)
+ (if (not (score-validp score))
+ (error (strcat "In " caller ", not a valid score") score)))
+
+(defun invalid-score () (return-from validp nil))
+(defun score-validp (score)
+ (block validp
+ (if (listp score) nil (invalid-score)) ;; tricky: return nil if NOT condition
+ (dolist (event score)
+ (if (listp event) nil (invalid-score))
+ (if (and (event-time event) (numberp (event-time event))) nil
+ (invalid-score))
+ (if (and (event-dur event) (numberp (event-dur event))) nil
+ (invalid-score))
+ (if (and (event-expression event) (consp (event-expression event))) nil
+ (invalid-score)))
+ t))
+
+(defun event-before (a b)
+ (< (car a) (car b)))
+
+;; EVENT-END -- get the ending time of a score event
+;;
+(defun event-end (e) (+ (car e) (cadr e)))
+
+;; EVENT-TIME -- time of an event
+;;
+(setfn event-time car)
+
+;; EVENT-DUR -- duration of an event
+;;
+(setfn event-dur cadr)
+
+;; EVENT-SET-TIME -- new event with new time
+;;
+(defun event-set-time (event time)
+ (cons time (cdr event)))
+
+
+;; EVENT-SET-DUR -- new event with new dur
+;;
+(defun event-set-dur (event dur)
+ (list (event-time event)
+ dur
+ (event-expression event)))
+
+
+;; EVENT-SET-EXPRESSION -- new event with new expression
+;;
+(defun event-set-expression (event expression)
+ (list (event-time event)
+ (event-dur event)
+ expression))
+
+;; EXPR-HAS-ATTR -- test if expression has attribute
+;;
+(defun expr-has-attr (expression attr)
+ (member attr expression))
+
+
+;; EXPR-GET-ATTR -- get value of attribute from expression
+;;
+(defun expr-get-attr (expression attr &optional default)
+ (let ((m (member attr expression)))
+ (if m (cadr m) default)))
+
+
+;; EXPR-SET-ATTR -- set value of an attribute in expression
+;; (returns new expression)
+(defun expr-set-attr (expr attr value)
+ (cons (car expr) (expr-parameters-set-attr (cdr expr) attr value)))
+
+(defun expr-parameters-set-attr (lis attr value)
+ (cond ((null lis) (list attr value))
+ ((eq (car lis) attr) (cons attr (cons value (cddr lis))))
+ (t (cons (car lis)
+ (cons (cadr lis)
+ (expr-parameters-set-attr (cddr lis) attr value))))))
+
+
+;; EXPR-REMOVE-ATTR -- expression without attribute value pair
+(defun expr-remove-attr (event attr)
+ (cons (car expr) (expr-parameters-remove-attr (cdr expr) attr)))
+
+(defun expr-parameters-remove-attr (lis attr)
+ (cond ((null lis) nil)
+ ((eq (car lis) attr) (cddr lis))
+ (t (cons (car lis)
+ (cons (cadr lis)
+ (expr-parameters-remove-attr (cddr lis) attr))))))
+
+
+;; EVENT-GET-ATTR -- get value of attribute from event
+;;
+(defun event-get-attr (note attr &optional default)
+ (expr-get-attr (event-expression note) attr default))
+
+
+;; EVENT-SET-ATTR -- new event with attribute = value
+(defun event-set-attr (event attr value)
+ (event-set-expression
+ event
+ (expr-set-attr (event-expression event) attr value)))
+
+
+;; EVENT-REMOVE-ATTR -- new event without attribute value pair
+(defun event-remove-attr (event attr)
+ (event-set-expression
+ event
+ (event-remove-attr (event-expression event) attr)))
+
+
+;; SCORE-GET-BEGIN -- get the begin time of a score
+;;
+(defun score-get-begin (score)
+ (setf score (score-must-have-begin-end score))
+ (cadr (event-expression (car score))))
+
+
+;; SCORE-SET-BEGIN -- set the begin time of a score
+;;
+(defun score-set-begin (score time)
+ (setf score (score-must-have-begin-end score))
+ (cons (list 0 0 (list 'score-begin-end time
+ (caddr (event-expression (car score)))))
+ (cdr score)))
+
+
+;; SCORE-GET-END -- get the end time of a score
+;;
+(defun score-get-end (score)
+ (setf score (score-must-have-begin-end score))
+ (caddr (event-expression (car score))))
+
+
+;; SCORE-SET-END -- set the end time of a score
+;;
+(defun score-set-end (score time)
+ (setf score (score-must-have-begin-end score))
+ (cons (list 0 0 (list 'score-begin-end
+ (cadr (event-expression (car score))) time))
+ (cdr score)))
+
+
+;; FIND-FIRST-NOTE -- use keywords to find index of first selected note
+;;
+(defun find-first-note (score from-index from-time)
+ (let ((s (cdr score)))
+ ;; offset by one because we removed element 0
+ (setf from-index (if from-index (max 0 (- from-index 1)) 0))
+ (setf from-time (if from-time
+ (- from-time SCORE-EPSILON)
+ (- SCORE-EPSILON)))
+ (if s (setf s (nthcdr from-index s)))
+
+ (while (and s (>= from-time (event-time (car s))))
+ (setf s (cdr s))
+ (incf from-index))
+ (1+ from-index)))
+
+
+;; EVENT-BEFORE -- useful function for sorting scores
+;;
+(defun event-before (a b)
+ (< (car a) (car b)))
+
+;; bigsort -- a sort routine that avoids recursion in order
+;; to sort large lists without overflowing the evaluation stack
+;;
+;; Does not modify input list. Does not minimize cons-ing.
+;;
+;; Algorithm: first accumulate sorted sub-sequences into lists
+;; Then merge pairs iteratively until only one big list remains
+;;
+(defun bigsort (lis cmp) ; sort lis using cmp function
+ ;; if (funcall cmp a b) then a and b are in order
+ (prog (rslt sub pairs)
+ ;; first, convert to sorted sublists stored on rslt
+ ;; accumulate sublists in sub
+ get-next-sub
+ (if (null lis) (go done-1))
+ (setf sub (list (car lis)))
+ (setf lis (cdr lis))
+ fill-sub
+ ;; invariant: sub is non-empty, in reverse order
+ (cond ((and lis (funcall cmp (car sub) (car lis)))
+ (setf sub (cons (car lis) sub))
+ (setf lis (cdr lis))
+ (go fill-sub)))
+ (setf sub (reverse sub)) ;; put sub in correct order
+ (setf rslt (cons sub rslt)) ;; build rslt in reverse order
+ (go get-next-sub)
+ done-1
+ ;; invariant: rslt is list of sorted sublists
+ (if (cdr rslt) nil (go done-2))
+ ;; invariant: rslt has at least one list
+ (setf pairs rslt)
+ (setf rslt nil)
+ merge-pairs ;; merge a pair and save on rslt
+ (if (car pairs) nil (go end-of-pass)) ;; loop until all pairs merged
+ ;; invariant: pairs has at least one list
+ (setf list1 (car pairs)) ;; list1 is non-empty
+ (setf list2 (cadr pairs)) ;; list2 could be empty
+ (setf pairs (cddr pairs))
+ (cond (list2
+ (setf rslt (cons (list-merge list1 list2 cmp) rslt)))
+ (t
+ (setf rslt (cons list1 rslt))))
+ (go merge-pairs)
+ end-of-pass
+ (go done-1)
+ done-2
+ ;; invariant: rslt has one sorted list!
+ (return (car rslt))))
+
+(defun list-merge (list1 list2 cmp)
+ (prog (rslt)
+ merge-loop
+ (cond ((and list1 list2)
+ (cond ((funcall cmp (car list1) (car list2))
+ (setf rslt (cons (car list1) rslt))
+ (setf list1 (cdr list1)))
+ (t
+ (setf rslt (cons (car list2) rslt))
+ (setf list2 (cdr list2)))))
+ (list1
+ (return (nconc (reverse rslt) list1)))
+ (t
+ (return (nconc (reverse rslt) list2))))
+ (go merge-loop)))
+
+
+;; SCORE-SORT -- sort a score into time order
+;;
+;; If begin-end exists, preserve it. If not, compute
+;; it from the sorted score.
+;;
+(defun score-sort (score &optional (copy-flag t))
+ (let* ((score1 (score-must-have-begin-end score))
+ (begin-end (car score1))
+ ;; if begin-end already existed, then it will
+ ;; be the first of score. Otherwise, one must
+ ;; have been generated above by score-must-have-begin-end
+ ;; in which case we should create it again after sorting.
+ (needs-begin-end (not (eq begin-end (first score)))))
+ (setf score1 (cdr score1)) ;; don't include begin-end in sort.
+ (if copy-flag (setf score1 (append score1 nil)))
+ (setf score1 (bigsort score1 #'event-before))
+ (if needs-begin-end (score-must-have-begin-end score1)
+ (cons begin-end score1))
+ ))
+
+
+;; PUSH-SORT -- insert an event in (reverse) sorted order
+;;
+;; Note: Score should NOT have a score-begin-end expression
+;;
+(defun push-sort (event score)
+ (let (insert-after)
+ (cond ((null score) (list event))
+ ((event-before (car score) event)
+ (cons event score))
+ (t
+ (setf insert-after score)
+ (while (and (cdr insert-after)
+ (event-before event (cadr insert-after)))
+ (setf insert-after (cdr insert-after)))
+ (setf (cdr insert-after) (cons event (cdr insert-after)))
+ score))))
+
+
+(setf FOREVER 3600000000.0) ; 1 million hours
+
+;; FIND-LAST-NOTE -- use keywords to find index beyond last selected note
+;;
+;; note that the :to-index keyword is the index of the last note (numbered
+;; from zero), whereas this function returns the index of the last note
+;; plus one, i.e. selected notes have an index *less than* this one
+;;
+(defun find-last-note (score to-index to-time)
+ ;; skip past score-begin-end event
+ (let ((s (cdr score))
+ (n 1))
+ (setf to-index (if to-index (1+ to-index) (length score)))
+ (setf to-time (if to-time (- to-time SCORE-EPSILON) FOREVER))
+ (while (and s (< n to-index) (< (event-time (car s)) to-time))
+ (setf s (cdr s))
+ (incf n))
+ n))
+
+
+;; SCORE-MUST-HAVE-BEGIN-END -- add score-begin-end event if necessary
+;;
+(defun score-must-have-begin-end (score)
+ (cond ((null score)
+ (list (list 0 0 (list 'SCORE-BEGIN-END 0 0))))
+ ((eq (car (event-expression (car score))) 'SCORE-BEGIN-END)
+ score)
+ (t (cons (list 0 0 (list 'SCORE-BEGIN-END (event-time (car score))
+ (event-end (car (last score)))))
+ score))))
+
+
+;; SCORE-SHIFT -- add offset to times of score events
+;;
+(defun score-shift (score offset &key from-index to-index from-time to-time)
+ (setf score (score-must-have-begin-end score))
+ (let ((i 1)
+ (start (find-first-note score from-index from-time))
+ (stop (find-last-note score to-index to-time))
+ (begin (cadr (event-expression (car score))))
+ (end (caddr (event-expression (car score))))
+ result)
+ (dolist (event (cdr score))
+ (cond ((and (<= start i) (< i stop))
+ (setf event (event-set-time
+ event (+ (event-time event) offset)))
+ (setf begin (min begin (event-time event)))
+ (setf end (max end (event-end event)))))
+ (setf result (push-sort event result))
+ (incf i))
+ (cons (list 0 0 (list 'SCORE-BEGIN-END begin end))
+ (reverse result))))
+
+
+;; TIME-STRETCH -- map a timestamp according to stretch factor
+;;
+(defun time-stretch (time stretch start-time stop-time)
+ (cond ((< time start-time) time)
+ ((< time stop-time)
+ (+ start-time (* stretch (- time start-time))))
+ (t ; beyond stop-time
+ (+ (- time stop-time) ; how much beyond stop-time
+ start-time
+ (* stretch (- stop-time start-time))))))
+
+
+;; EVENT-STRETCH -- apply time warp to an event
+(defun event-stretch (event stretch dur-flag time-flag start-time stop-time)
+ (let* ((new-time (event-time event))
+ (new-dur (event-dur event))
+ (end-time (+ new-time new-dur)))
+ (cond (time-flag
+ (setf new-time (time-stretch new-time stretch
+ start-time stop-time))))
+ (cond ((and time-flag dur-flag)
+ ;; both time and dur are stretched, so map the end time just
+ ;; like the start time, then subtract to get new duration
+ (setf end-time (time-stretch end-time stretch
+ start-time stop-time))
+ (setf new-dur (- end-time new-time)))
+ ((and dur-flag (>= new-time start-time) (< new-time stop-time))
+ ;; stretch only duration, not time. If note starts in range
+ ;; scale to get the new duration.
+ (setf new-dur (* stretch new-dur))))
+ (list new-time new-dur (event-expression event))))
+
+
+;; SCORE-STRETCH -- stretch a region of the score
+;;
+(defun score-stretch (score factor &key (dur t) (time t)
+ from-index to-index (from-time 0) (to-time FOREVER))
+ (if (zerop factor) (print "WARNING: score-stretch called with zero stretch factor."))
+ (setf score (score-must-have-begin-end score))
+ (let ((begin-end (event-expression (car score)))
+ (i 1))
+ (if from-index
+ (setf from-time (max from-time
+ (event-time (nth from-index score)))))
+ (if to-index
+ (setf to-time (min to-time
+ (event-end (nth to-index score)))))
+ ; stretch from start-time to stop-time
+ (cons (list 0 0 (list 'SCORE-BEGIN-END
+ (time-stretch (cadr begin-end) factor
+ from-time to-time)
+ (time-stretch (caddr begin-end) factor
+ from-time to-time)))
+ (mapcar #'(lambda (event)
+ (event-stretch event factor dur time
+ from-time to-time))
+ (cdr score)))))
+
+
+;; Turn a value field into a numeric value if possible
+;; (by looking up a global variable binding). This
+;; allows scores to say C4 instead of 60.
+;;
+(defun get-numeric-value (v)
+ (cond ((and v (symbolp v) (boundp v) (numberp (symbol-value v)))
+ (symbol-value v))
+ (t v)))
+
+
+(defun params-transpose (params keyword amount)
+ (cond ((null params) nil)
+ ((eq keyword (car params))
+ (let ((v (get-numeric-value (cadr params))))
+ (cond ((numberp v)
+ (setf v (+ v amount)))
+ ((and (eq keyword :pitch) (listp v))
+ (setf v (mapcar #'(lambda (x) (setf x (get-numeric-value x))
+ (+ x amount)) v))))
+ (cons (car params)
+ (cons v (cddr params)))))
+ (t (cons (car params)
+ (cons (cadr params)
+ (params-transpose (cddr params) keyword amount))))))
+
+
+(defun score-transpose (score keyword amount &key
+ from-index to-index from-time to-time)
+ (score-apply score
+ #'(lambda (time dur expression)
+ (list time dur
+ (cons (car expression)
+ (params-transpose (cdr expression)
+ keyword amount))))
+ :from-index from-index :to-index to-index
+ :from-time from-time :to-time to-time))
+
+
+(defun params-scale (params keyword amount)
+ (cond ((null params) nil)
+ ((eq keyword (car params))
+ (let ((v (get-numeric-value (cadr params))))
+ (cond ((numberp v)
+ (setf v (* v amount))))
+ (cons (car params)
+ (cons v (cddr params)))))
+ (t (cons (car params)
+ (cons (cadr params)
+ (params-scale (cddr params) keyword amount))))))
+
+
+(defun score-scale (score keyword amount &key
+ from-index to-index from-time to-time)
+ (score-apply score
+ #'(lambda (time dur expression)
+ (list time dur
+ (cons (car expression)
+ (params-scale (cdr expression)
+ keyword amount))))
+ :from-index from-index :to-index to-index
+ :from-time from-time :to-time to-time))
+
+
+(defun score-sustain (score factor &key
+ from-index to-index from-time to-time)
+ (setf score (score-must-have-begin-end score))
+ (let ((i 0)
+ (start (find-first-note score from-index from-time))
+ (stop (find-last-note score to-index to-time))
+ result)
+ (dolist (event score)
+ (cond ((and (<= start i) (< i stop))
+ (setf event (event-set-dur
+ event (* (event-dur event) factor)))))
+ (push event result)
+ (incf i))
+ (reverse result)))
+
+
+;; MAP-VOICE - helper function for SCORE-VOICE
+;; input: a score expression, e.g. '(note :pitch 60 :vel 100)
+;; a replacement list, e.g. '((note foo) (* bar))
+;; output: the score expression with substitutions, e.g.
+;; '(foo :pitch 60 :vel 100)
+;;
+(defun map-voice (expression replacement-list)
+ (cond (replacement-list
+ (cond ((or (eq (car expression) (caar replacement-list))
+ (eq (caar replacement-list) '*))
+ (cons (cadar replacement-list) (cdr expression)))
+ (t (map-voice expression (cdr replacement-list)))))
+ (t expression)))
+
+
+(defun ny:assert-replacement-list (fun-name index formal actual)
+ (let ((lis actual) r)
+ (while lis
+ (if (not (consp actual))
+ (error (format nil "In ~A,~A argument (~A) should be a list, got ~A"
+ fun-name (index-to-string index) formal actual)))
+ (setf r (car lis))
+ (if (not (and (listp r) (= 2 (length r)) (symbolp (car r)) (symbolp (cadr r))))
+ (error (format nil
+ "In ~A,~A argument (~A) should be a list of lists of two symbols, got ~A"
+ fun-name (index-to-string index) formal actual)))
+ (setf lis (cdr lis)) )))
+
+
+(defun score-voice (score replacement-list &key
+ from-index to-index from-time to-time)
+ (ny:assert-replacement-list 'SCORE-VOICE 2 "replacement-list" replacement-list)
+ (setf score (score-must-have-begin-end score))
+ (let ((i 0)
+ (start (find-first-note score from-index from-time))
+ (stop (find-last-note score to-index to-time))
+ result)
+ (dolist (event score)
+ (cond ((and (<= start i) (< i stop))
+ (setf event (event-set-expression
+ event (map-voice (event-expression event)
+ replacement-list)))))
+ (push event result)
+ (incf i))
+ (reverse result)))
+
+
+(defun score-merge (&rest scores)
+ ;; scores is a list of scores
+ (cond ((null scores) nil)
+ (t
+ (score-merge-1 (car scores) (cdr scores)))))
+
+
+;; SCORE-MERGE-1 -- merge list of scores into score
+;;
+(defun score-merge-1 (score scores)
+ ;; scores is a list of scores to merge
+ (cond ((null scores) score)
+ (t (score-merge-1 (score-merge-2 score (car scores))
+ (cdr scores)))))
+
+;; SCORE-MERGE-2 -- merge 2 scores
+;;
+(defun score-merge-2 (score addin)
+ ;(display "score-merge-2 before" score addin)
+ (setf score (score-must-have-begin-end score))
+ (setf addin (score-must-have-begin-end addin))
+ ;(display "score-merge-2" score addin)
+ (let (start1 start2 end1 end2)
+ (setf start1 (score-get-begin score))
+ (setf start2 (score-get-begin addin))
+ (setf end1 (score-get-end score))
+ (setf end2 (score-get-end addin))
+
+ ;; note: score-sort is destructive, but append copies score
+ ;; and score-shift copies addin
+ (score-sort
+ (cons (list 0 0 (list 'SCORE-BEGIN-END (min start1 start2)
+ (max end1 end2)))
+ (append (cdr score) (cdr addin) nil)))))
+
+
+
+;; SCORE-APPEND -- append scores together in sequence
+;;
+(defun score-append (&rest scores)
+ ;; scores is a list of scores
+ (cond ((null scores) nil)
+ (t
+ (score-append-1 (car scores) (cdr scores)))))
+
+
+;; SCORE-APPEND-1 -- append list of scores into score
+;;
+(defun score-append-1 (score scores)
+ ;; scores is a list of scores to append
+ (cond ((null scores) score)
+ (t (score-append-1 (score-append-2 score (car scores))
+ (cdr scores)))))
+
+
+;; SCORE-APPEND-2 -- append 2 scores
+;;
+(defun score-append-2 (score addin)
+ ;(display "score-append-2" score addin)
+ (setf score (score-must-have-begin-end score))
+ (setf addin (score-must-have-begin-end addin))
+ (let (end1 start2 begin-end1 begin-end2)
+ (setf start1 (score-get-begin score))
+ (setf end1 (score-get-end score))
+ (setf start2 (score-get-begin addin))
+ (setf end2 (score-get-end addin))
+ (setf begin-end1 (event-expression (car score)))
+ (setf begin-end2 (event-expression (car addin)))
+ (setf addin (score-shift addin (- end1 start2)))
+ ;; note: score-sort is destructive, but append copies score
+ ;; and score-shift copies addin
+ (score-sort
+ (cons (list 0 0 (list 'SCORE-BEGIN-END start1 (+ end1 (- end2 start2))))
+ (append (cdr score) (cdr addin) nil)))))
+
+
+(defun score-select (score predicate &key
+ from-index to-index from-time to-time reject)
+ (setf score (score-must-have-begin-end score))
+ (let ((begin-end (car score))
+ (i 1)
+ (start (find-first-note score from-index from-time))
+ (stop (find-last-note score to-index to-time))
+ result)
+ ;; selected if start <= i AND i < stop AND predicate(...)
+ ;; choose if not reject and selected or reject and not selected
+ ;; so in other words choose if reject != selected. Use NULL to
+ ;; coerce into boolean values and then use NOT EQ to compare
+ (dolist (event (cdr score))
+ (cond ((not (eq (null reject)
+ (null (and (<= start i) (< i stop)
+ (or (eq predicate t)
+ (funcall predicate
+ (event-time event)
+ (event-dur event)
+ (event-expression event)))))))
+ (push event result)))
+ (incf i))
+ (cons begin-end (reverse result))))
+
+
+;; SCORE-FILTER-LENGTH -- remove notes beyond cutoff time
+;;
+(defun score-filter-length (score cutoff)
+ (let (result)
+ (dolist (event score)
+ (cond ((<= (event-end event) cutoff)
+ (push event result))))
+ (reverse result)))
+
+
+;; SCORE-REPEAT -- make n copies of score in sequence
+;;
+(defun score-repeat (score n)
+ (let (result)
+ (dotimes (i n)
+ (setf result (score-append result score)))
+ result))
+
+
+;; SCORE-STRETCH-TO-LENGTH -- stretch score to have given length
+;;
+(defun score-stretch-to-length (score length)
+ (let ((begin-time (score-get-begin score))
+ (end-time (score-get-end score))
+ duration stretch)
+ (setf duration (- end-time begin-time))
+ (cond ((< 0 duration)
+ (setf stretch (/ length (- end-time begin-time)))
+ (score-stretch score stretch))
+ (t score))))
+
+
+(defun score-filter-overlap (score)
+ (setf score (score-must-have-begin-end score))
+ (prog (event end-time filtered-score
+ (begin-end (car score)))
+ (setf score (cdr score))
+ (cond ((null score) (return (list begin-end))))
+ loop
+ ;; get event from score
+ (setf event (car score))
+ ;; add a note to filtered-score
+ (push event filtered-score)
+ ;; save the end-time of this event: start + duration
+ (setf end-time (+ (car event) (cadr event)))
+ ;; now skip everything until end-time in score
+ loop2
+ (pop score) ;; move to next event in score
+ (cond ((null score)
+ (return (cons begin-end (reverse filtered-score)))))
+ (setf event (car score)) ;; examine next event
+ (setf start-time (car event))
+ ;(display "overlap" start-time (- end-time SCORE-EPSILON))
+ (cond ((< start-time (- end-time SCORE-EPSILON))
+ ;(display "toss" event start-time end-time)
+ (go loop2)))
+ (go loop)))
+
+
+(defun score-print (score &optional lines)
+ (let ((len (length score))) ;; len will be how many events left
+ (format t "(")
+ (cond (lines
+ (setf lines (max lines 3))) ;; always allow up to 3 lines
+ (t ;; no limit on lines, pick a conservatively large number
+ (setf lines (+ 100 len))))
+ (dolist (event score)
+ (cond ((or (> lines 2) (= 1 len))
+ ;; print if we have more than 2 lines left to print or
+ ;; if we are at the last line (always printed)
+ (format t "~S~%" event)
+ (setf lines (1- lines)))
+ ((and (= lines 2) (> len 2)) ;; need ellipsis
+ (format t "... skipping ~A events ...~%" (- len lines))
+ (setf lines (1- lines)))
+ (t nil)) ;; print nothing until end if lines is 1
+ (setf len (1- len)))
+ (format t ")~%")))
+
+(defun score-play (score)
+ (play (timed-seq score)))
+
+
+(defun score-adjacent-events (score function &key
+ from-index to-index from-time to-time)
+ (setf score (score-must-have-begin-end score))
+ (let ((begin-end (car score))
+ (a nil)
+ (b (second score))
+ (c-list (cddr score))
+ r newscore
+ (i 1)
+ (start (find-first-note score from-index from-time))
+ (stop (find-last-note score to-index to-time)))
+ (dolist (event (cdr score))
+ (setf r b)
+ (cond ((and (<= start i) (< i stop))
+ (setf r (funcall function a b (car c-list)))))
+ (cond (r
+ (push r newscore)
+ (setf a r)))
+ (setf b (car c-list))
+ (setf c-list (cdr c-list))
+ (incf i))
+ (score-sort (cons begin-end newscore))))
+
+
+(defun score-apply (score fn &key
+ from-index to-index from-time to-time)
+
+ (setf score (score-must-have-begin-end score))
+ (let ((begin-end (car score))
+ (i 1)
+ (start (find-first-note score from-index from-time))
+ (stop (find-last-note score to-index to-time))
+ result)
+ (dolist (event (cdr score))
+ (push
+ (cond ((and (<= start i) (< i stop))
+ (funcall fn (event-time event)
+ (event-dur event) (event-expression event)))
+ (t event))
+ result)
+ (incf i))
+ (score-sort (cons begin-end result))))
+
+
+(defun score-indexof (score fn &key
+ from-index to-index from-time to-time)
+ (setf score (score-must-have-begin-end score))
+ (let ((i 1)
+ (start (find-first-note score from-index from-time))
+ (stop (find-last-note score to-index to-time))
+ result)
+ (dolist (event (cdr score))
+ (cond ((and (<= start i) (< i stop)
+ (funcall fn (event-time event)
+ (event-dur event)
+ (event-expression event)))
+ (setf result i)
+ (return)))
+ (incf i))
+ result))
+
+
+(defun score-last-indexof (score fn &key
+ from-index to-index from-time to-time)
+ (setf score (score-must-have-begin-end score))
+ (let ((i 1)
+ (start (find-first-note score from-index from-time))
+ (stop (find-last-note score to-index to-time))
+ result)
+ (dolist (event (cdr score))
+ (cond ((and (<= start i) (< i stop)
+ (funcall fn (event-time event)
+ (event-dur event)
+ (event-expression event)))
+ (setf result i)))
+ (incf i))
+ result))
+
+
+;; SCORE-RANDOMIZE-START -- alter start times with offset
+;; keywords: jitter, offset, feel factor
+;;
+(defun score-randomize-start (score amt &key
+ from-index to-index from-time to-time)
+ (score-apply score
+ (lambda (time dur expr)
+ (setf time (+ (real-random (- amt) amt) time))
+ (setf time (max 0.0 time))
+ (list time dur expr))))
+
+
+;; SCORE-READ-SMF -- read a standard MIDI file to a score
+;;
+(defun score-read-smf (filename)
+ (let ((seq (seq-create))
+ (file (open-binary filename)))
+ (cond (file
+ (seq-read-smf seq file)
+ (close file)
+ (score-from-seq seq))
+ (t nil))))
+
+
+;; SCORE-READ -- read a standard MIDI file to a score
+;;
+(defun score-read (filename)
+ (let ((seq (seq-create))
+ (file (open filename)))
+ (cond (file
+ (seq-read seq file)
+ (close file)
+ (score-from-seq seq))
+ (t nil))))
+
+
+;; SET-PROGRAM-TO -- a helper function to set a list value
+(defun set-program-to (lis index value default)
+ ;; if length or lis <= index, extend the lis with default
+ (while (<= (length lis) index)
+ (setf lis (nconc lis (list default))))
+ ;; set the nth element
+ (setf (nth index lis) value)
+ ;; return the list
+ lis)
+
+
+(defun score-from-seq (seq)
+ (prog (event tag score programs)
+ (seq-reset seq)
+loop
+ (setf event (seq-get seq))
+ (setf tag (seq-tag event))
+ (cond ((= tag seq-done-tag)
+ (go exit))
+ ((= tag seq-prgm-tag)
+ (let ((chan (seq-channel event))
+ (when (seq-time event))
+ (program (seq-program event)))
+ (setf programs (set-program-to programs chan program 0))
+ (push (list (* when 0.001) 1
+ (list 'NOTE :pitch nil :program program))
+ score)))
+ ((= tag seq-note-tag)
+ (let ((chan (seq-channel event))
+ (pitch (seq-pitch event))
+ (vel (seq-velocity event))
+ (when (seq-time event))
+ (dur (seq-duration event)))
+ (push (list (* when 0.001) (* dur 0.001)
+ (list 'NOTE :chan (1- chan) :pitch pitch :vel vel))
+ score))))
+ (seq-next seq)
+ (go loop)
+exit
+ (setf *rslt* programs) ;; extra return value
+ (return (score-sort score))))
+
+
+(defun score-write (score filename &optional programs absolute)
+ (score-write-smf score filename programs t absolute))
+
+(defun score-write-smf (score filename &optional programs as-adagio absolute)
+ (let ((file (if as-adagio (open filename :direction :output)
+ (open-binary filename :direction :output)))
+ (seq (seq-create))
+ (chan 1))
+ (cond (file
+ (dolist (program programs)
+ ;; 6 = SEQ_PROGRAM
+ (seq-insert-ctrl seq 0 0 6 chan program)
+ ;(display "insert ctrl" seq 0 0 6 chan program)
+ (incf chan))
+
+ (dolist (event (cdr (score-must-have-begin-end score)))
+ (let ((time (event-time event))
+ (dur (event-dur event))
+ (chan (event-get-attr event :chan 0))
+ (pitch (event-get-attr event :pitch))
+ (program (event-get-attr event :program))
+ (vel (event-get-attr event :vel 100)))
+ (cond (program
+ ;(display "score-write-smf program" chan program)
+ (seq-insert-ctrl seq (round (* time 1000))
+ 0 6 (1+ chan)
+ (round program))))
+ (cond ((consp pitch)
+ (dolist (p pitch)
+ (seq-insert-note seq (round (* time 1000))
+ 0 (1+ chan) (round p)
+ (round (* dur 1000)) (round vel))))
+ (pitch
+ (seq-insert-note seq (round (* time 1000))
+ 0 (1+ chan) (round pitch)
+ (round (* dur 1000)) (round vel))))))
+ (cond (as-adagio
+ (seq-write seq file absolute)
+ (close file)) ;; seq-write does not close file, so do it here
+ (t
+ (seq-write-smf seq file))))))) ; seq-write-smf closes file
+
+
+
+;; make a default note function for scores
+;;
+(defun note (&key (pitch 60) (vel 100))
+ ;; load the piano if it is not loaded already
+ (if (not (boundp '*piano-srate*))
+ (abs-env (load "piano/pianosyn")))
+ (piano-note-2 pitch vel))
+
+;;================================================================
+
+;; WORKSPACE functions have moved to envelopes.lsp
+
+
+;; DESCRIBE -- add a description to a global variable
+;;
+(defun describe (symbol &optional description)
+ (add-to-workspace symbol)
+ (cond (description
+ (putprop symbol description 'description))
+ (t
+ (get symbol 'description))))
+
+;; INTERPOLATE -- linear interpolation function
+;;
+;; compute y given x by interpolating between points (x1, y1) and (x2, y2)
+(defun interpolate (x x1 y1 x2 y2)
+ (cond ((= x1 x2) x1)
+ (t (+ y1 (* (- x x1) (/ (- y2 y1) (- x2 (float x1))))))))
+
+
+;; INTERSECTION -- set intersection
+;;
+;; compute the intersection of two lists
+(defun intersection (a b)
+ (let (result)
+ (dolist (elem a)
+ (if (member elem b) (push elem result)))
+ result))
+
+;; UNION -- set union
+;;
+;; compute the union of two lists
+(defun union (a b)
+ (let (result)
+ (dolist (elem a)
+ (if (not (member elem result)) (push elem result)))
+ (dolist (elem b)
+ (if (not (member elem result)) (push elem result)))
+ result))
+
+;; SET-DIFFERENCE -- set difference
+;;
+;; compute the set difference between two sets
+(defun set-difference (a b)
+ (remove-if (lambda (elem) (member elem b)) a))
+
+;; SUBSETP -- test is list is subset
+;;
+;; test if a is subset of b
+(defun subsetp (a b)
+ (let ((result t))
+ (dolist (elem a)
+ (cond ((not (member elem b))
+ (setf result nil)
+ (return nil))))
+ result))
+
+;; functions to support score editing in NyquistIDE
+
+(if (not (boundp '*default-score-file*))
+ (setf *default-score-file* "score.dat"))
+
+;; SCORE-EDIT -- save a score for editing by NyquistIDE
+;;
+;; file goes to a data file to be read by NyquistIDE
+;; Note that the parameter is a global variable name, not a score,
+;; but you do not quote the global variable name, e.g. call
+;; (score-edit my-score)
+;;
+(defmacro score-edit (score-name)
+ `(score-edit-symbol (quote ,score-name)))
+
+(defun score-edit-symbol (score-name)
+ (prog ((f (open *default-score-file* :direction :output))
+ score expr)
+ (cond ((symbolp score-name)
+ (setf score (eval score-name)))
+ (t
+ (error "score-edit expects a symbol naming the score to edit")))
+ (cond ((null f)
+ (format t "score-edit: error in output file ~A!~%" *default-score-file*)
+ (return nil)))
+
+ (format t "score-edit: writing ~A ...~%" *default-score-file*)
+ (format f "~A~%" score-name) ; put name on first line
+ (dolist (event score) ;cdr scor
+ (format f "~A " (event-time event)) ; print start time
+ (format f "~A " (event-dur event)) ; print duration
+
+ (setf expr (event-expression event))
+
+ ; print the pitch and the rest of the attributes
+ (format f "~A " (expr-get-attr expr :pitch))
+ (format f "~A~%" (expr-parameters-remove-attr expr :pitch)))
+ (close f)
+ (format t "score-edit: wrote ~A events~%" (length score))))
+
+
+;; Read in a data file stored in the score-edit format and save
+;; it to the global variable it came from
+(defun score-restore ()
+ (prog ((inf (open *default-score-file*))
+ name start dur pitch expr score)
+ (cond ((null inf)
+ (format t "score-restore: could not open ~A~%" *default-score-file*)
+ (return nil)))
+ (setf name (read inf)) ;; score name
+ (loop
+ (setf start (read inf))
+ (cond ((null start) (return)))
+ (setf dur (read inf))
+ (setf pitch (read inf))
+ (setf expr (read inf))
+ (cond (pitch
+ (setf expr (expr-set-attr expr :pitch pitch)))))
+ (close inf)
+ (setf (symbol-value name) score)))
diff --git a/Release/plug-ins/ShelfFilter.ny b/Release/plug-ins/ShelfFilter.ny
new file mode 100644
index 0000000000000000000000000000000000000000..0fa4e95be501f9a1a76097d182839b93baec1445
--- /dev/null
+++ b/Release/plug-ins/ShelfFilter.ny
@@ -0,0 +1,34 @@
+$nyquist plug-in
+$version 4
+$type process
+$preview linear
+$name (_ "Shelf Filter")
+$debugbutton disabled
+$author (_ "Steve Daulton")
+$release 2.4.0-1
+$copyright (_ "GNU General Public License v2.0")
+
+;; License: GPL v2
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control TYPE (_ "Filter type") choice (("Low" (_ "Low-shelf"))
+ ("High" (_ "High-shelf"))) 0
+$control HZ (_ "Frequency (Hz)") int "" 1000 10 10000
+$control GAIN (_ "Amount (dB)") int "" -6 -72 72
+
+
+(cond ((> HZ (/ *sound-srate* 2))
+ (format nil (_ "Error.~%Frequency set too high for selected track.")))
+ ((> HZ (/ *sound-srate* 2.1)) ;Handle edge case close to Nyquist frequency.
+ (setf *track* (force-srate (* 2 *sound-srate*) *track*))
+ (if (= TYPE 0)
+ (force-srate *sound-srate* (eq-lowshelf *track* HZ GAIN))
+ (force-srate *sound-srate* (eq-highshelf *track* HZ GAIN))))
+ ((= GAIN 0) "") ; no-op
+ (t (if (= TYPE 0)
+ (eq-lowshelf *track* HZ GAIN)
+ (eq-highshelf *track* HZ GAIN))))
diff --git a/Release/plug-ins/SpectralEditMulti.ny b/Release/plug-ins/SpectralEditMulti.ny
new file mode 100644
index 0000000000000000000000000000000000000000..6e62a6897a0f74664b8edfbb21c184a428d2afb0
--- /dev/null
+++ b/Release/plug-ins/SpectralEditMulti.ny
@@ -0,0 +1,70 @@
+$nyquist plug-in
+$version 4
+$type process spectral
+$name (_ "Spectral Edit Multi Tool")
+$author (_ "Paul Licameli")
+$release 2.3.0-1
+$copyright (_ "GNU General Public License v2.0")
+
+;; License: GPL v2
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+;; SpectralEditMulti.ny by Paul Licameli, November 2014.
+;; Updated by Steve Daulton 2014 / 2015.
+
+
+(defun wet (sig f0 f1 fc)
+ (cond
+ ((not f0) (highpass2 sig f1))
+ ((not f1) (lowpass2 sig f0))
+ (T (let ((q (/ fc (- f1 f0))))
+ (notch2 sig fc q)))))
+
+(defun result (sig)
+ (let* ((f0 (get '*selection* 'low-hz))
+ (f1 (get '*selection* 'high-hz))
+ (fc (get '*selection* 'center-hz))
+ (bw (get '*selection* 'bandwidth))
+ (tn (truncate len))
+ (rate (snd-srate sig))
+ (transition (truncate (* 0.01 rate))) ; 10 ms
+ (t1 (min transition (/ tn 2))) ; fade in length (samples)
+ (t2 (max (- tn transition) (/ tn 2))) ; length before fade out (samples)
+ (breakpoints (list t1 1.0 t2 1.0 tn))
+ (env (snd-pwl 0.0 rate breakpoints)))
+ (cond
+ ((not (or f0 f1)) ; This should never happen for a 'spectral' effect.
+ (throw 'error-message
+ (format nil (_ "~aPlease select frequencies.") p-err)))
+ ((and f0 f1 (= f0 f1))
+ (throw 'error-message
+ (format nil (_ "~aBandwidth is zero (the upper and lower~%~
+ frequencies are both ~a Hz).~%~
+ Please select a frequency range.")
+ p-err f0)))
+ ;; Biqud filter fails if centre frequency is very low and bandwidth very high.
+ ;; 'Magic numbers' 10 Hz and 10 octaves are experimental.
+ ((and f0 (< f0 10) bw (> bw 10))
+ (throw 'error-message
+ (format nil (_ "~aNotch filter parameters cannot be applied.~%~
+ Try increasing the low frequency bound~%~
+ or reduce the filter 'Width'.")
+ p-err)))
+ ;; low pass frequency is above Nyquist so do nothing
+ ((and (not f1) (>= f0 (/ *sound-srate* 2.0)))
+ nil)
+ ;; notch frequency is above Nyquist so do nothing
+ ((and f0 f1 (>= fc (/ *sound-srate* 2.0)))
+ nil)
+ ;; high-pass above Nyquist so fade to silence
+ ((and (not f0) (>= f1 (/ *sound-srate* 2.0)))
+ (mult sig (diff 1.0 env)))
+ (T (sum (prod env (wet sig f0 f1 fc))
+ (prod (diff 1.0 env) sig))))))
+
+(catch 'error-message
+ (setf p-err (format nil (_ "Error.~%")))
+ (multichan-expand #'result *track*))
diff --git a/Release/plug-ins/SpectralEditParametricEQ.ny b/Release/plug-ins/SpectralEditParametricEQ.ny
new file mode 100644
index 0000000000000000000000000000000000000000..8f78788ad1defd0731d70d17a157616b59077216
--- /dev/null
+++ b/Release/plug-ins/SpectralEditParametricEQ.ny
@@ -0,0 +1,70 @@
+$nyquist plug-in
+$version 4
+$type process spectral
+$preview linear
+$name (_ "Spectral Edit Parametric EQ")
+$debugbutton false
+$author (_ "Paul Licameli")
+$release 2.3.0-2
+$copyright (_ "GNU General Public License v2.0")
+
+;; License: GPL v2
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+;; SpectralEditParametricEQ.ny by Paul Licameli, November 2014.
+;; Updated by Steve Daulton 2014 / 2015.
+
+
+$control CONTROL-GAIN (_ "Gain (dB)") real "" 0 -24 24
+
+(defun wet (sig gain fc bw)
+ (eq-band sig fc gain (/ bw 2)))
+
+(defun result (sig)
+ (let*
+ ((f0 (get '*selection* 'low-hz))
+ (f1 (get '*selection* 'high-hz))
+ (fc (get '*selection* 'center-hz))
+ (bw (get '*selection* 'bandwidth))
+ (tn (truncate len))
+ (rate (snd-srate sig))
+ (transition (truncate (* 0.01 rate))) ; 10 ms
+ (t1 (min transition (/ tn 2))) ; fade in length (samples)
+ (t2 (max (- tn transition) (/ tn 2))) ; length before fade out (samples)
+ (breakpoints (list t1 1.0 t2 1.0 tn))
+ (env (snd-pwl 0.0 rate breakpoints)))
+ (cond
+ ((not (or f0 f1)) ; This should never happen for a 'spectral' effect.
+ (throw 'error-message (format nil (_ "~aPlease select frequencies.") p-err)))
+ ((not f0)
+ (throw 'error-message (format nil (_ "~aLow frequency is undefined.") p-err)))
+ ((not f1)
+ (throw 'error-message (format nil (_ "~aHigh frequency is undefined.") p-err)))
+ ((and fc (= fc 0))
+ (throw 'error-message (format nil (_ "~aCenter frequency must be above 0 Hz.") p-err)))
+ ((and f1 (> f1 (/ *sound-srate* 2)))
+ (throw 'error-message
+ (format nil (_ "~aFrequency selection is too high for track sample rate.~%~
+ For the current track, the high frequency setting cannot~%~
+ be greater than ~a Hz")
+ p-err (/ *sound-srate* 2))))
+ ((and bw (= bw 0))
+ (throw 'error-message
+ (format nil (_ "~aBandwidth is zero (the upper and lower~%~
+ frequencies are both ~a Hz).~%~
+ Please select a frequency range.")
+ p-err f0)))
+ ;; If centre frequency band is above Nyquist, do nothing.
+ ((and fc (>= fc (/ *sound-srate* 2.0)))
+ nil)
+ (t (sum (prod env (wet sig CONTROL-GAIN fc bw))
+ (prod (diff 1.0 env) sig))))))
+
+(catch 'error-message
+ (setf p-err (format nil (_ "Error.~%")))
+ (if (= CONTROL-GAIN 0)
+ "" ; No-op
+ (multichan-expand #'result *track*)))
diff --git a/Release/plug-ins/SpectralEditShelves.ny b/Release/plug-ins/SpectralEditShelves.ny
new file mode 100644
index 0000000000000000000000000000000000000000..9a3135f90ab0201856f8efa83e9569e44672638f
--- /dev/null
+++ b/Release/plug-ins/SpectralEditShelves.ny
@@ -0,0 +1,77 @@
+$nyquist plug-in
+$version 4
+$type process spectral
+$preview linear
+$name (_ "Spectral Edit Shelves")
+$debugbutton false
+$author (_ "Paul Licameli")
+$release 2.3.0-2
+$copyright (_ "GNU General Public License v2.0 or later")
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+;; SpectralEditShelves.ny by Paul Licameli, November 2014.
+;; Updated by Steve Daulton 2014 / 2015.
+
+
+$control CONTROL-GAIN (_ "Gain (dB)") real "" 0 -24 24
+
+(defmacro validate (hz)
+"If frequency is above Nyquist, don't use it"
+ `(if (or (>= ,hz (/ *sound-srate* 2.0))
+ (<= ,hz 0))
+ (setf ,hz nil)))
+
+(defun mid-shelf (sig lf hf gain)
+ "Combines high shelf and low shelf filters"
+ (let ((invg (- gain)))
+ (scale (db-to-linear gain)
+ (eq-highshelf (eq-lowshelf sig lf invg)
+ hf invg))))
+
+(defun wet (sig gain f0 f1)
+ "Apply appropriate filter"
+ (cond
+ ((not f0) (eq-lowshelf sig f1 gain))
+ ((not f1) (eq-highshelf sig f0 gain))
+ (t (mid-shelf sig f0 f1 gain))))
+
+(defun result (sig)
+ (let*
+ ((f0 (get '*selection* 'low-hz))
+ (f1 (get '*selection* 'high-hz))
+ (tn (truncate len))
+ (rate (snd-srate sig))
+ (transition (truncate (* 0.01 rate))) ; 10 ms
+ (t1 (min transition (/ tn 2))) ; fade in length (samples)
+ (t2 (max (- tn transition) (/ tn 2))) ; length before fade out (samples)
+ (breakpoints (list t1 1.0 t2 1.0 tn))
+ (env (snd-pwl 0.0 rate breakpoints)))
+ (cond
+ ((not (or f0 f1)) ; This should never happen for a 'spectral' effect.
+ (throw 'error-message (format nil (_ "~aPlease select frequencies.") p-err)))
+ ((and f0 (>= f0 (/ *sound-srate* 2.0)))
+ ; Shelf is above Nyquist frequency so do nothing.
+ nil)
+ ((and f0 f1 (= f0 f1))
+ (throw 'error-message
+ (format nil (_ "~aBandwidth is zero (the upper and lower~%~
+ frequencies are both ~a Hz).~%~
+ Please select a frequency range.")
+ p-err f0)))
+ (T (if f0 (validate f0))
+ (if f1 (validate f1))
+ (if (not (or f0 f1)) ; 'validate' may return nil
+ nil ; Do nothing
+ (sum (prod env (wet sig CONTROL-GAIN f0 f1))
+ (prod (diff 1.0 env) sig)))))))
+
+(catch 'error-message
+ (setf p-err (format nil (_ "Error.~%")))
+ (if (= CONTROL-GAIN 0)
+ "" ; No-op
+ (multichan-expand #'result *track*)))
diff --git a/Release/plug-ins/StudioFadeOut.ny b/Release/plug-ins/StudioFadeOut.ny
new file mode 100644
index 0000000000000000000000000000000000000000..b4812d9b8e36e3c6ab1a04993fd463d1c30efa8d
--- /dev/null
+++ b/Release/plug-ins/StudioFadeOut.ny
@@ -0,0 +1,43 @@
+$nyquist plug-in
+$version 4
+$type process
+$name (_ "Studio Fade Out")
+$author (_ "Steve Daulton")
+$release 3.0.4-1
+$copyright (_ "GNU General Public License v2.0 or later")
+
+;; Produce a smooth and musical sounding fade out.
+;; Applies a sinusoidal fade out with a progressive low-pass
+;; filter from full spectrum at start to 100 Hz at end.
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+;;; sweeping low pass filter
+ (defun filter (sig dur)
+ (abs-env
+ ;; cross-fade the filter
+ (let* ((nyq-hz (/ *sound-srate* 2))
+ (f-out (r-cos (min (/ dur 2.0) 0.5)))
+ (f-in (diff (snd-const 1 0 *sound-srate* dur) f-out)))
+ (sim
+ (mult f-out sig)
+ (mult f-in (lp sig (pwlv nyq-hz dur 100)))))))
+
+;;; raised cosine
+(defun r-cos (dur)
+ (abs-env
+ (mult 0.5
+ (sum 1
+ (osc (hz-to-step (/ (* dur 2))) dur *table* 90)))))
+
+(let ((dur (get-duration 1)))
+ (cond
+ ((< len 3) (format nil (_ "Selection too short.~%It must be more than 2 samples.")))
+ ((< dur 0.2) (mult *track* (r-cos dur)))
+ (t (mult (filter *track* dur)(r-cos dur)))))
+
diff --git a/Release/plug-ins/adjustable-fade.ny b/Release/plug-ins/adjustable-fade.ny
new file mode 100644
index 0000000000000000000000000000000000000000..4ee7bbe355c8c883f5034393fdbe684f14c23412
--- /dev/null
+++ b/Release/plug-ins/adjustable-fade.ny
@@ -0,0 +1,211 @@
+$nyquist plug-in
+$version 4
+$type process
+$preview linear
+$preview selection
+$name (_ "Adjustable Fade")
+$debugbutton false
+$author (_ "Steve Daulton")
+$release 3.0.4-2
+$copyright (_ "GNU General Public License v2.0 or later")
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control TYPE (_ "Fade Type") choice (("Up" (_ "Fade Up"))
+ ("Down" (_ "Fade Down"))
+ ("SCurveUp" (_ "S-Curve Up"))
+ ("SCurveDown" (_ "S-Curve Down"))) 0
+$control CURVE (_ "Mid-fade Adjust (%)") real "" 0 -100 100
+$control UNITS (_ "Start/End as") choice (("Percent" (_ "% of Original"))
+ ("dB" (_ "dB Gain"))) 0
+$control GAIN0 (_ "Start (or end)") float-text "" 0 nil nil
+$control GAIN1 (_ "End (or start)") float-text "" 100 nil nil
+$control PRESET (_ "Handy Presets (override controls)") choice (("None" (_ "None Selected"))
+ ("LinearIn" (_ "Linear In"))
+ ("LinearOut" (_ "Linear Out"))
+ ("ExponentialIn" (_ "Exponential In"))
+ ("ExponentialOut" (_ "Exponential Out"))
+ ("LogarithmicIn" (_ "Logarithmic In"))
+ ("LogarithmicOut" (_ "Logarithmic Out"))
+ ("RoundedIn" (_ "Rounded In"))
+ ("RoundedOut" (_ "Rounded Out"))
+ ("CosineIn" (_ "Cosine In"))
+ ("CosineOut" (_ "Cosine Out"))
+ ("SCurveIn" (_ "S-Curve In"))
+ ("SCurveOut" (_ "S-Curve Out"))) 0
+
+;;; Preview takes the entire selection so that we know the correct
+;;; selection length, but preview only needs to process preview length."
+(defun get-input (sig)
+ (if *previewp*
+ (multichan-expand #'trim-input sig)
+ sig))
+
+
+;;; Trim input when previewing."
+(defun trim-input (sig)
+ (let ((dur (min (get-duration 1)
+ (get '*project* 'preview-duration))))
+ (setf sig (extract-abs 0 dur sig))))
+
+
+;;; Check gain values are in valid range.
+(defun validate-gain ()
+ (setf err (format nil (_ "Error~%~%")))
+ (if (= UNITS 0) ;percentage values
+ (cond
+ ((or (< GAIN0 0)(< GAIN1 0))
+ (throw 'err (format nil (_ "~aPercentage values cannot be negative.") err)))
+ ((or (> GAIN0 1000)(> GAIN1 1000))
+ (throw 'err (format nil (_ "~aPercentage values cannot be more than 1000 %.") err))))
+ (cond ;dB values
+ ((or (> GAIN0 100)(> GAIN1 100))
+ (throw 'err (format nil (_ "~adB values cannot be more than +100 dB.~%~%~
+ Hint: 6 dB doubles the amplitude~%~
+ -6 dB halves the amplitude.") err))))))
+
+
+;;; Select and apply fade
+(defun fade (sig)
+ (when (= PRESET 0)
+ ; Can't use widget validation for gain as range depends on units.
+ (validate-gain))
+ (psetq curve-ratio (/ CURVE 100.0)
+ g0 (gainscale GAIN0)
+ g1 (gainscale GAIN1))
+ (mult (get-input sig)
+ (case PRESET
+ (0 (case TYPE ; Custom fade
+ (0 (simple (min g0 g1) (max g0 g1) curve-ratio))
+ (1 (simple (max g0 g1) (min g0 g1) curve-ratio))
+ (2 (raised-cos (min g0 g1)(max g0 g1) curve-ratio))
+ (T (raised-cos (max g0 g1) (min g0 g1) curve-ratio))))
+ (1 (linear 0 1)) ; Linear In
+ (2 (linear 1 0)) ; Linear Out
+ (3 (log-exp-curve -60 0)) ; Exponential In
+ (4 (log-exp-curve -60 1)) ; ExponentialOut
+ (5 (log-exp-curve 15.311 0)) ; Logarithmic In
+ (6 (log-exp-curve 15.311 1)) ; Logarithmic Out
+ (7 (simple-curve 0 1 0.5)) ; Rounded In
+ (8 (simple-curve 1 0 0.5)) ; Rounded Out
+ (9 (cosine-curve 0 1)) ; Cosine In
+ (10 (cosine-curve 1 0)) ; Cosine Out
+ (11 (raised-cos 0 1 0.0)) ; S-Curve In
+ (t (raised-cos 1 0 0.0))))) ; S-Curve Out
+
+
+;;; Simple Curve:
+;;; Use cosine for + values and linear for -ve.
+(defun simple (g0 g1 curve-ratio)
+ (cond
+ ((= g0 g1) g0) ; amplify
+ ((and (> curve-ratio 0)(< curve-ratio 0.5)) ; +ve curve less than 0.5, lin to cosine
+ (let ((curve-ratio (* curve-ratio 2)))
+ (sim (mult (scale-curve g0 g1 (linear g0 g1))
+ (- 1 curve-ratio)) ; linear
+ (mult (scale-curve g0 g1 (cosine-curve g0 g1))
+ curve-ratio)))) ; cosine curve
+ ((> curve-ratio 0)
+ (cos-curve g0 g1 (- 1.5 curve-ratio))) ; +ve curve > 0.5
+ (t (simple-curve g0 g1 (- 1 (* 2 curve-ratio)))))) ; -ve curve
+
+
+;;; Linear fade to the power of 'pow'.
+(defun simple-curve (g0 g1 pow)
+ (curve-adjust g0 g1 pow (linear g0 g1)))
+
+
+;;; Cosine fade to the power of 'pow'.
+(defun cos-curve (g0 g1 pow)
+ (curve-adjust g0 g1 pow (cosine-curve g0 g1)))
+
+
+(defun curve-adjust (g0 g1 pow env)
+ (scale-curve g0 g1
+ (if (= pow 1)
+ env
+ (snd-exp (mult pow (snd-log env))))))
+
+
+;;; Scale curves to min, max.
+(defun scale-curve (g0 g1 env)
+ (sum (min g0 g1)
+ (mult (abs (- g0 g1)) env)))
+
+
+;;; Cosine curve.
+(defun cosine-curve (g0 g1)
+ (let ((step (hz-to-step (/ 0.25 (get-duration 1))))
+ (phase (if (> g0 g1) 90 0)))
+ (osc step 1 *sine-table* phase)))
+
+
+;;; Linear fade in, out.
+(defun linear (g0 g1)
+ (control-srate-abs *sound-srate*
+ (if (> g0 g1) ; g0 = g1 does not occur here.
+ (pwlv 1 1 0) ; fade out
+ (pwlv 0 1 1)))) ; else fade in
+
+
+;;; Raised cosine fades.
+(defun raised-cos (g0 g1 curve-ratio)
+ (setq curve-ratio
+ (if (> curve-ratio 0)
+ (exp-scale-mid (* 2 curve-ratio)) ; mid-point -3dB @ Adjust = 50%
+ (exp-scale-mid (* 1.63 curve-ratio)))) ; mid-point -12dB @ Adjust = -50%
+ (setf env
+ ;; sound srate required for accuracy.
+ (control-srate-abs *sound-srate*
+ (cond
+ ((= g0 g1) g0) ; amplify
+ ((> g0 g1) ; fade down
+ (snd-exp
+ (mult (pwlv (- 1 curve-ratio) 1 1)
+ (snd-log (raised-cosin 90)))))
+ (t (snd-exp ; fade up
+ (mult (pwlv 1 1 (- 1 curve-ratio))
+ (snd-log (raised-cosin -90))))))))
+ (sum (min g0 g1)
+ (mult (abs (- g0 g1)) env)))
+
+
+;;; Raised cosine curve.
+(defun raised-cosin (phase)
+ (let ((hz (hz-to-step (/ (get-duration 2)))))
+ (mult 0.5
+ (sum 1 (osc hz 1 *sine-table* phase)))))
+
+
+;;; log or exponential curve scaled 0 to 1
+;;; x is the minimum level in dB before scaling.
+(defun log-exp-curve (x direction)
+ (control-srate-abs *sound-srate*
+ (let ((x (db-to-linear x)))
+ ;; If direction=0 fade-in else fade-out
+ (if (= direction 0)
+ (setf env (pwev x 1 1))
+ (setf env (pwev 1 1 x)))
+ (mult (/ (- 1 x)) ; normalize to 0 dB
+ (diff env x))))) ; drop down to silence
+
+
+;;; Curve scaling for S-curve.
+(defun exp-scale-mid (x)
+ (let ((e (exp 1.0)))
+ (/ (- (exp (- 1 x)) e)
+ (- 1 e))))
+
+
+(defun gainscale (gain)
+ (if (= UNITS 0) ; percent
+ (/ gain 100.0)
+ (db-to-linear gain)))
+
+
+(catch 'err (fade *track*))
diff --git a/Release/plug-ins/beat.ny b/Release/plug-ins/beat.ny
new file mode 100644
index 0000000000000000000000000000000000000000..208f7134722131bd7129829211f1c5ec0f5cfe66
--- /dev/null
+++ b/Release/plug-ins/beat.ny
@@ -0,0 +1,43 @@
+$nyquist plug-in
+$version 4
+$type analyze
+$name (_ "Beat Finder")
+$debugbutton false
+$author (_ "Audacity")
+$release 2.3.2-2
+$copyright (_ "GNU General Public License v2.0")
+
+;; License: GPL v2
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control THRESVAL (_ "Threshold Percentage") int "" 65 5 100
+
+(setf threshold (/ THRESVAL 100.0))
+
+(defun mix-to-mono (sig)
+ (if (arrayp sig)
+ (sum (aref sig 0) (aref sig 1))
+ sig))
+
+(defun bass-tracker (sig)
+ (let* ((bass (lp sig 50))
+ ;(snd-follow sound floor risetime falltime lookahead)
+ (follower (snd-follow bass 0.001 0.01 0.1 512)))
+ (force-srate 1000 (lp follower 10))))
+
+
+(let ((beats (bass-tracker (mix-to-mono *track*))))
+ (setf peak-sig (peak beats ny:all))
+ (setf threshold (* threshold peak-sig))
+ (do ((time 0.0 (+ time 0.001))
+ (val (snd-fetch beats) (snd-fetch beats))
+ (flag T)
+ labels)
+ ((not val) labels)
+ (when (and flag (> val threshold))
+ (push (list time "B") labels))
+ (setf flag (< val threshold))))
diff --git a/Release/plug-ins/clipfix.ny b/Release/plug-ins/clipfix.ny
new file mode 100644
index 0000000000000000000000000000000000000000..d2edf3b8a4709936ae81d31fe874e4096387fdc0
--- /dev/null
+++ b/Release/plug-ins/clipfix.ny
@@ -0,0 +1,108 @@
+$nyquist plug-in
+$version 4
+$type process
+$preview enabled
+$name (_ "Clip Fix")
+$debugbutton false
+$author (_ "Benjamin Schwartz and Steve Daulton")
+$release 2.3.0-2
+$copyright (_ "GNU General Public License v2.0")
+
+;; License: GPL v2
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+;; Algorithm by Benjamin Schwartz
+;; Clip Fix is a simple, stupid (but not blind) digital-clipping-corrector
+;; The algorithm is fairly simple:
+;; 1. Find all clipped regions
+;; 2. Get the slope immediately on either side of the region
+;; 3. Do a cubic spline interpolation.
+;; 4. Go to next region
+
+
+$control THRESHOLD (_ "Threshold of Clipping (%)") float "" 95 0 100
+$control GAIN (_ "Reduce amplitude to allow for restored peaks (dB)") float "" -9 -30 0
+
+(setf thresh-ratio (/ THRESHOLD 100))
+(setf gain-lin (db-to-linear GAIN))
+(setf buffersize 100000)
+(setf slopelength 4) ; number of samples used to calculate the exit / re-entry slope
+
+
+(defun declip (sig thresh peak)
+ (let* ((thresh (* thresh peak))
+ (ln (truncate len))
+ (finalbufsize (rem ln buffersize)))
+ ;; Calculate the number of buffers we can process.
+ ;; if final buffer is not large enough for de-clipping we
+ ;; will just add it on the end as is.
+ (if (>= finalbufsize slopelength)
+ (setf buffercount (1+ (/ ln buffersize)))
+ (setf buffercount (/ ln buffersize)))
+ ;;; Make output sequence from processed buffers
+ (setf out
+ (seqrep (i buffercount)
+ (let* ((step (min buffersize (- ln (* i buffersize))))
+ (buffer (snd-fetch-array sig step step))
+ (processed (process buffer thresh step)))
+ (cue (mult gain-lin
+ (snd-from-array 0 *sound-srate* processed))))))
+ ;;; If there's unprocessed audio remaining, add it to the end
+ (if (and (> finalbufsize 0)(< finalbufsize slopelength))
+ (seq out (cue (getfinalblock sig finalbufsize gain-lin)))
+ out)))
+
+
+(defun getfinalblock (sig step gain-lin)
+ (let ((block (snd-fetch-array sig step step)))
+ (mult gain-lin (snd-from-array 0 *sound-srate* block))))
+
+
+(defun process (buffer thresh bufferlength)
+ ;;; Find threshold crossings
+ (setf exit-list ()) ; list of times when waveform exceeds threshold
+ (setf return-list ()) ; list of times when waveform returns below threshold
+ ;; Limitation of algorithm: the first and last 'slopelength' at ends of buffer are ignored
+ ;; so that we have enough samples beyond the threshold crossing to calculate the slope.
+ (let ((last-sample (- bufferlength slopelength)))
+ (do ((i slopelength (1+ i)))
+ ((>= i last-sample))
+ (if (>= (abs (aref buffer i)) thresh)
+ (when (< (abs (aref buffer (- i 1))) thresh) ; we just crossed threshold
+ (push (- i 1) exit-list))
+ (when (>= (abs (aref buffer (- i 1))) thresh) ; we just got back in range
+ (push i return-list)))))
+ ;; Reverse lists back into chronological order.
+ ;; This is faster than appending values in chronological order.
+ (setf exit-list (reverse exit-list))
+ (setf return-list (reverse return-list))
+ ;; If the audio begins in a clipped region, discard the first return
+ (when (>= (abs (aref buffer (1- slopelength))) thresh)
+ (setq return-list (cdr return-list)))
+ ;; Interpolate between each pair of exit / entry points
+ (let ((slopelen (1- slopelength)))
+ (mapc (lambda (t0 t1)
+ (interpolate buffer t0 t1 slopelen))
+ exit-list return-list))
+ buffer)
+
+
+(defun interpolate (buffer t0 t1 dur)
+ "Cubic spline interpolation"
+ (let* ((d0 (/ (- (aref buffer t0) (aref buffer (- t0 dur))) dur)) ; slope at start
+ (d1 (/ (- (aref buffer (+ t1 dur)) (aref buffer t1)) dur)) ; slope at end
+ (m (/ (+ d1 d0) (* (- t1 t0) (- t1 t0))))
+ (b (- (/ d1 (- t1 t0)) (* m t1))))
+ (do ((j (1+ t0) (1+ j)))
+ ((= j t1))
+ (setf (aref buffer j)
+ (+ (* (- t1 j) (/ (aref buffer t0) (- t1 t0)))
+ (* (- j t0) (/ (aref buffer t1) (- t1 t0)))
+ (* (- j t0) (- j t1) (+ (* m j) b)))))))
+
+
+;; (get '*selection* 'peak) introduced in Audacity 2.1.3
+(multichan-expand #'declip *track* thresh-ratio (get '*selection* 'peak))
diff --git a/Release/plug-ins/crossfadeclips.ny b/Release/plug-ins/crossfadeclips.ny
new file mode 100644
index 0000000000000000000000000000000000000000..e8bbe8ccaf839469dd25f6b9d93945ff8ba96290
--- /dev/null
+++ b/Release/plug-ins/crossfadeclips.ny
@@ -0,0 +1,132 @@
+$nyquist plugin
+$version 4
+$type process
+$mergeclips 1
+$restoresplits 0
+$name (_ "Crossfade Clips")
+$author (_ "Steve Daulton")
+$release 3.0.4-1
+$copyright (_ "GNU General Public License v2.0 or later")
+
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+;; Instructions:
+;; Place two audio clips into the same track.
+;; Select (approximately) the same amount of audio from the
+;; end of one clip and the start of the other.
+;; Apply the effect.
+;; The selected regions will be crossfaded.
+;;
+;; Note, the audio clips do not need to be touching. Any
+;; white-space between the clips is ignored.
+;;
+;; If the selected region is continuous audio (no splits),
+;; the the first and last halves of the selected audio
+;; will be crossfaded.
+;;
+;; Advanced Tip:
+;; A discontinuity in a waveform may be smoothed by applying
+;; a short crossfade across the glitch.
+
+;; Limitations (should not occur in normal usage).
+;; 1) There may be no more than two clips selected in each channel.
+;; 2) The selection may not start or end in white-space.
+
+
+(setf err1 (format nil (_ "Error.~%Invalid selection.~%More than 2 audio clips selected.")))
+(setf err2 (format nil (_ "Error.~%Invalid selection.~%Empty space at start/ end of the selection.")))
+
+
+(defun find-ends (T0 T1 clips)
+"Look for a split or gap within the selection, or return the mid-point"
+ (let ((trk-ends ()) ;starts of clips
+ (trk-starts ())) ;ends of clips
+ (dolist (clip clips)
+ ;; look for clip enclosing the selection.
+ (when (and (>= (second clip) T1) (<= (first clip) T0))
+ (psetq trk-ends (list (/ (+ T0 T1) 2))
+ trk-starts (list (/ (+ T0 T1) 2)))
+ (return))
+ ;; look for track starts.
+ (when (and (> (first clip) T0) (< (first clip) T1))
+ (push (first clip) trk-starts))
+ ;; look for track ends.
+ (when (and (> (second clip) T0) (< (second clip) T1))
+ (push (second clip) trk-ends))
+ ; stop looking when we have passed end of selection.
+ (when (> (first clip) T1) (return)))
+ ;; if exactly one split position for crossfading,
+ ;; return clip positions, else error.
+ (cond
+ ((and (= (length trk-ends) 1)
+ (= (length trk-starts) 1)
+ (<= (car trk-ends) (car trk-starts)))
+ (list (car trk-ends)(car trk-starts)))
+ ((or (> (length trk-ends) 1)
+ (> (length trk-starts) 1))
+ (throw 'error err1))
+ (T (throw 'error err2)))))
+
+(defun crossfade (sig out-end in-start end)
+"Do the crossfade"
+ (abs-env
+ (control-srate-abs *sound-srate*
+ (let* ((fade-out (mult sig (env out-end 0)))
+ (cflen (max out-end (- end in-start))) ;crossfade length
+ (finstart (max (- out-end (- end in-start)) 0))
+ (fade-in (mult (extract (- end cflen) end sig)
+ (env (- cflen finstart) 1 finstart))))
+ (sim fade-out fade-in)))))
+
+(defun env (dur direction &optional (offset 0))
+"Generate envelope for crossfade"
+ (abs-env
+ (if (< dur 0.01) ;make it linear
+ (control-srate-abs *sound-srate*
+ (if (= direction 0)
+ (pwlv 1 dur 0) ;fade out
+ (pwlv 0 offset 0 (+ offset dur) 1))) ;fade in
+ (if (= direction 0) ;cosine curve
+ (cos-curve dur 0)
+ (seq (s-rest offset)
+ (cos-curve dur 1))))))
+
+(defun cos-curve (dur direction)
+"Generate cosine curve"
+ (if (= direction 0) ;fade out
+ (osc (hz-to-step (/ 0.25 dur)) dur *sine-table* 90)
+ (osc (hz-to-step (/ 0.25 dur)) dur *sine-table* 0)))
+
+(defun process (sig t0 t1 clips)
+"Find the split positions and crossfade"
+ (setf fadeclips
+ (multichan-expand #'find-ends t0 t1 clips))
+ (if (arrayp fadeclips)
+ (prog ((fade-out-end (min (first (aref fadeclips 0))
+ (first (aref fadeclips 1))))
+ (fade-in-start (max (second (aref fadeclips 0))
+ (second (aref fadeclips 1)))))
+ (return
+ (multichan-expand #'crossfade sig
+ (- fade-out-end t0)
+ (- fade-in-start t0)
+ (- t1 t0))))
+ (crossfade sig
+ (- (first fadeclips) t0)
+ (- (second fadeclips) t0)
+ (- t1 t0))))
+
+
+;;; Run the program.
+(if (= (length (get '*selection* 'tracks)) 1)
+ (catch 'error
+ (process *track*
+ (get '*selection* 'start)
+ (get '*selection* 'end)
+ (get '*track* 'clips)))
+ (format nil (_ "Error.~%Crossfade Clips may only be applied to one track.")))
diff --git a/Release/plug-ins/crossfadetracks.ny b/Release/plug-ins/crossfadetracks.ny
new file mode 100644
index 0000000000000000000000000000000000000000..8ca26be32f1636b066f50277d5612220bbdb11f1
--- /dev/null
+++ b/Release/plug-ins/crossfadetracks.ny
@@ -0,0 +1,85 @@
+$nyquist plug-in
+$version 4
+$type process
+$name (_ "Crossfade Tracks")
+$debugbutton disabled
+$preview selection
+$author (_ "Steve Daulton")
+$release 3.0.4-2
+$copyright (_ "GNU General Public License v2.0 or later")
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+$control TYPE (_ "Fade TYPE") choice (
+ ("ConstantGain" (_ "Constant Gain"))
+ ("ConstantPower1" (_ "Constant Power 1"))
+ ("ConstantPower2" (_ "Constant Power 2"))
+ ("CustomCurve" (_ "Custom Curve"))) 0
+$control CURVE (_ "Custom curve") real "" 0 0 1
+$control DIRECTION (_ "Fade direction") choice (
+ (_ "Automatic")
+ ("OutIn" (_ "Alternating Out / In"))
+ ("InOut" (_ "Alternating In / Out"))) 0
+
+
+(defun crossfade ()
+ (setf fade-out
+ (case DIRECTION
+ (0 (equal (guessdirection) 'OUT)) ; auto
+ (1 (oddp (get '*track* 'index))) ; fade out odd
+ (T (evenp (get '*track* 'index))))) ; fade out even
+ ; Set control rate to sound rate to ensure length is exact.
+ (setf *control-srate* *sound-srate*)
+ (mult *track*
+ (cond
+ (fade-out
+ (case TYPE
+ (0 (pwlv 1 1 0))
+ (1 (osc (hz-to-step (/ (get-duration 4))) 1 *sine-table* 90))
+ (2 (s-sqrt (pwlv 1 1 0)))
+ (T (custom 0))))
+ (T ; else fade in.
+ (case TYPE
+ (0 (pwlv 0 1 1))
+ (1 (osc (hz-to-step (/ (get-duration 4))) 1))
+ (2 (s-sqrt (pwlv 0 1 1)))
+ (T (custom 1)))))))
+
+(defun custom (inout)
+ ;; 'epsilon' defines the curvature of a logarithmc curve.
+ ;; To avoid log 0 or /0 it must be > 0 and < 1.
+ (let* ((ccurve (+ 0.99 (* -0.98 CURVE)))
+ ; magic number 2.7 gives approx 'constant power' curve at 50% setting.
+ (epsilon (power ccurve 2.7)))
+ (if (= inout 0)
+ (setf logcurve (pwev epsilon 1 1))
+ (setf logcurve (pwev 1 1 epsilon)))
+ ; Scale and invert curve for 0 to unity gain.
+ (sum 1
+ (mult (/ -1 (- 1 epsilon))
+ (diff logcurve epsilon)))))
+
+(defun guessdirection ()
+ ;;; If the selection is closer to the start of the
+ ;;; audio clip, fade in, otherwise fade out.
+ ;;; Use `inclips`, i.e., the clip boundaries before the stretch-rendering pre-processing step.
+ (let* ((start (get '*selection* 'start))
+ (end (get '*selection* 'end))
+ (clips (get '*track* 'inclips))
+ (in-dist end)
+ (out-dist end))
+ (if (arrayp clips)
+ (setf clips (append (aref clips 0)(aref clips 1))))
+ (dotimes (i (length clips))
+ (setf in-dist (min in-dist (abs (- start (first (nth i clips))))))
+ (setf out-dist (min out-dist (abs (- end (second (nth i clips)))))))
+ (if (< in-dist out-dist) 'in 'out)))
+
+
+(if (< (length (get '*selection* 'tracks)) 2)
+ (format nil (_ "Error.~%Select 2 (or more) tracks to crossfade."))
+ (crossfade))
diff --git a/Release/plug-ins/delay.ny b/Release/plug-ins/delay.ny
new file mode 100644
index 0000000000000000000000000000000000000000..94bda9db1c72a865d02bdb9de8e238b8cb3a8903
--- /dev/null
+++ b/Release/plug-ins/delay.ny
@@ -0,0 +1,139 @@
+$nyquist plug-in
+$version 4
+$type process
+$preview linear
+$name (_ "Delay")
+$debugbutton false
+$author (_ "Steve Daulton")
+$release 2.4.2-2
+$copyright (_ "GNU General Public License v2.0")
+
+
+;; License: GPL v2 or later.
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;; based on 'Delay' by David R. Sky
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control DELAY-TYPE (_ "Delay type") choice ((_ "Regular")
+ ("BouncingBall" (_ "Bouncing Ball"))
+ ("ReverseBouncingBall" (_ "Reverse Bouncing Ball"))) 0
+$control DGAIN (_ "Delay level per echo (dB)") real "" -6 -30 1
+$control DELAY (_ "Delay time (seconds)") real "" 0.3 0 5
+$control PITCH-TYPE (_ "Pitch change effect") choice (("PitchTempo" (_ "Pitch/Tempo"))
+ ("LQPitchShift" (_ "Low-quality Pitch Shift"))
+ ("HQPitchShift" (_ "High-quality Pitch Shift"))) 0
+$control SHIFT (_ "Pitch change per echo (semitones)") real "" 0 -2 2
+$control NUMBER (_ "Number of echoes") int "" 5 1 30
+$control CONSTRAIN (_ "Allow duration to change") choice ((_ "Yes")(_ "No")) 0
+
+
+;; High-quality Pitch Shift option added, March 2023.
+;;
+;; "High-quality Pitch Shift" is accomplished with a phase vocoder.
+;; "Pitch/Tempo" and "Low-quality Pitch Shift" remain identical
+;; to previous version of Audacity.
+;;
+;; "Pitch/Tempo" is simple resampling, so both pitch and tempo
+;; of the delayed audio will change (as in Audacity's
+;; "Change Speed" effect).
+;;
+;; "Low-quality Pitch Shift" changes the pitch without changing
+;; the tempo, but has relatively poor sound quality.
+
+
+;;; Pitch shift audio.
+(defun p-shift (sig snd-len ratio)
+ (when (= SHIFT 0)
+ ; no-op.
+ (return-from p-shift sig))
+ (case PITCH-TYPE (0 (change-speed sig ratio))
+ (1 (lq-pitch sig ratio))
+ (t (hq-pitch sig snd-len ratio))))
+
+
+;;; Change speed.
+(defun change-speed (sig ratio)
+ (force-srate *sound-srate*
+ (stretch-abs (/ ratio) (sound sig))))
+
+
+;;; Low quality pitch shift.
+;; This uses the ancient "Synthesis Toolkit" pitch shifter.
+;; STK_PITSHIFT: a simple pitch shifter using delay lines.
+;; Filtering and fixed sample rate are used to squeeze slightly
+;; better sound quality out of this old library.
+(defun lq-pitch(sig ratio)
+ ; pitshift quality best at 44100
+ (let ((sig (force-srate 44100 sig))
+ ; anti-alias filter frequency
+ (minrate (* 0.5 (min *sound-srate* 44100))))
+ (force-srate *sound-srate*
+ ; pitshift requires rates to match
+ (progv '(*sound-srate*) (list 44100)
+ (cond
+ ((> SHIFT 5) ; reduce aliasing
+ (pitshift (lp-wall sig (/ minrate ratio)) ratio 1))
+ ((< SHIFT -2) ; reduce sub-sonic frequencies
+ (pitshift (hp sig 20) ratio 1))
+ (T (pitshift sig ratio 1)))))))
+
+
+;;; Anti-alias low pass filter
+(defun lp-wall (sig freq)
+ (do ((count 0 (1+ count))
+ (freq (* 0.94 freq)))
+ ((= count 10) sig)
+ (setf sig (lowpass8 sig freq))))
+
+
+;;; High quality pitch shift.
+(defun hq-pitch(sig snd-len shift-ratio)
+ (let ((stretchfn (const 1))
+ (pitchfn (const shift-ratio)))
+ (pv-time-pitch sig stretchfn pitchfn snd-len)))
+
+
+;;; Apply effects to echo
+(defun modify (sig echo-num snd-len)
+ (let ((gain (db-to-linear (* echo-num DGAIN)))
+ ; convert semitone shift to ratio.
+ (ratio (power 2.0 (/ (* echo-num SHIFT) 12.0))))
+ (if (= PITCH-TYPE 0)
+ (mult gain (change-speed sig ratio))
+ (mult gain (p-shift sig snd-len ratio)))))
+
+
+;;; Compute echoes.
+(defun delays (sig snd-len)
+ (if (>= DELAY-TYPE 1) ; Bouncing delay.
+ (setf time-shift (/ DELAY NUMBER))
+ (setf time-shift DELAY))
+ ;; The echo loop.
+ (let ((echo (s-rest 0)))
+ (do ((count 1 (1+ count))
+ (dly 0))
+ ((> count NUMBER)(sim echo sig))
+ (let ((modified-sig (modify sig count snd-len)))
+ (setq dly
+ (case DELAY-TYPE
+ (0 (+ dly time-shift))
+ (1 (+ dly (* time-shift (- (1+ NUMBER) count))))
+ (2 (+ dly (* time-shift count)))))
+ (setf echo (sim
+ (at 0 (cue echo))
+ (at-abs dly
+ (cue modified-sig))))))))
+
+
+(defun constrain-abs (sig dur)
+ (extract-abs 0 dur (cue sig)))
+
+
+(let* ((dur (get-duration 1))
+ (output (multichan-expand #'delays *track* dur)))
+ (if (= CONSTRAIN 1)
+ (multichan-expand #'constrain-abs output dur)
+ output))
diff --git a/Release/plug-ins/equalabel.ny b/Release/plug-ins/equalabel.ny
new file mode 100644
index 0000000000000000000000000000000000000000..7e98b80a27c24eee1b571032ef0267029bc13895
--- /dev/null
+++ b/Release/plug-ins/equalabel.ny
@@ -0,0 +1,167 @@
+$nyquist plug-in
+$version 4
+$type tool analyze
+$debugbutton false
+$debugflags trace
+$name (_ "Regular Interval Labels")
+$author (_ "Steve Daulton")
+$release 2.3.1-2
+$copyright (_ "GNU General Public License v2.0 or later")
+
+
+;; Original version by David R. Sky (http://www.garyallendj.com/davidsky/) 2007.
+;; Based on an idea by Sami Jumppanen, with contributions from
+;; Alex S.Brown, Dominic Mazzoni, Pierre M.I., Gale Andrews.
+;;
+;; TODO: Rewrite as an AUD-DO script so as to remove the requirement for
+;; an audio selection.
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+; i18n-hint: Refers to the controls 'Number of labels' and 'Label interval'.
+$control MODE (_ "Create labels based on") choice (("Both" (_ "Number and Interval"))
+ ("Number" (_ "Number of Labels"))
+ ("Interval" (_ "Label Interval"))) 0
+$control TOTALNUM (_ "Number of labels") int-text "" 10 1 1000
+$control INTERVAL (_ "Label interval (seconds)") float-text "" 10 0.001 3600
+$control REGION (_ "Length of label region (seconds)") float-text "" 0 0 3600
+$control ADJUST (_ "Adjust label interval to fit length") choice ((_ "No")
+ (_ "Yes")) 0
+$control LABELTEXT (_ "Label text") string "" (_ "Label")
+$control ZEROS (_ "Minimum number of digits in label") choice (("TextOnly" (_ "None - Text Only"))
+ ("OneBefore" (_ "1 (Before Label)"))
+ ("TwoBefore" (_ "2 (Before Label)"))
+ ("ThreeBefore" (_ "3 (Before Label)"))
+ ("OneAfter" (_ "1 (After Label)"))
+ ("TwoAfter" (_ "2 (After Label)"))
+ ("ThreeAfter" (_ "3 (After Label)"))) 2
+$control FIRSTNUM (_ "Begin numbering from") int-text "" 1 0 nil
+$control VERBOSE (_ "Message on completion") choice ((_ "Details")
+ ("Warnings" (_ "Warnings only"))
+ (_ "None")) 0
+
+
+(defun make-labels (num-txt zeropad &aux labels)
+"Generate labels at regular intervals"
+ ;; Get parameters
+ (case MODE
+ (1 ; Based on Number
+ (setf intervals
+ (if (= REGION 0)
+ (/ (get-safe-duration) TOTALNUM)
+ (/ (get-safe-duration) (1- TOTALNUM))))
+ (setf total TOTALNUM))
+ (2 ; Based on Interval
+ (setf total (get-interval-count))
+ (if (= ADJUST 1)
+ (setf intervals (/ (get-safe-duration) total))
+ (setf intervals INTERVAL)))
+ (t ; Number and Interval
+ (psetq total TOTALNUM
+ intervals INTERVAL)))
+ ;; Loop for required number of labels
+ (do* ((count 0 (1+ count))
+ (time 0 (* count intervals)))
+ ((= count total))
+ (push (make-one-label time (+ FIRSTNUM count) num-txt zeropad)
+ labels))
+
+ (when (and (> REGION 0)(= MODE 2)(= ADJUST 1))
+ (push (make-one-label (get-safe-duration)
+ (+ FIRSTNUM total)
+ num-txt
+ zeropad)
+ labels))
+ ;; Create confirmation message
+ (when (< VERBOSE 2)
+ (message total intervals))
+ labels)
+
+
+(defun message (number intervals)
+"Generate output message in debug window."
+ (if (= number 0)
+ (setf msg (format nil( _ "Error: There is insufficient space to create labels.~%")))
+ (if (> REGION intervals)
+ (setf msg (format nil (_ "Warning: Overlapping region labels.~%")))
+ (setf msg "")))
+ (cond
+ ((= VERBOSE 1) ; Warnings only
+ (format t msg))
+ (t (if (> REGION 0)
+ ; i18n-hint: Type of label
+ (setf labeltype (_ "region labels"))
+ (setf labeltype (_ "point labels")))
+ (when (and (> REGION 0)(= MODE 2)(= ADJUST 1))
+ (setf number (1+ number)))
+ (setf msg
+ ; i18n-hint: Number of labels produced at specified intervals.
+ (format nil (_ "~a~a ~a at intervals of ~a seconds.~%")
+ msg number labeltype intervals))
+ (if (> REGION 0)
+ (format t (_ "~aRegion length = ~a seconds.")
+ msg REGION)
+ (format t msg)))))
+
+
+(defun get-interval-count (&aux dur)
+"Number of labels when interval is specified"
+ (setf dur (get-safe-duration))
+ (case ADJUST
+ ;; Interval is user input value
+ (0 (let ((n (truncate (/ dur INTERVAL))))
+ (if (< (* n INTERVAL) dur)
+ (1+ n)
+ n)))
+ ;; Adjust space between labels to fit length
+ (1 (let* ((min-num (truncate (/ dur INTERVAL)))
+ (max-num (1+ min-num)))
+ (if (and (> min-num 0)
+ (< (abs (- INTERVAL (/ dur min-num)))
+ (abs (- INTERVAL (/ dur max-num)))))
+ min-num
+ max-num)))))
+
+
+(defun make-one-label (time num num-txt zeropad)
+"Make a single label"
+ (let* ((num-text (format nil "~a" num))
+ (non-zero-digits (length num-text)))
+ (if (= zeropad 0)
+ (setf num-text "")
+ (dotimes (i (max 0 (- zeropad non-zero-digits)))
+ (setf num-text (format nil "~a~a" "0" num-text))))
+ (if num-txt ; Number before text in label.
+ (setf text (format nil "~a~a" num-text LABELTEXT))
+ (setf text (format nil "~a~a" LABELTEXT num-text)))
+ (list time (+ time REGION) text)))
+
+
+(defun lasttrackp ()
+"True when processing the final selected track"
+ (let ((index (get '*track* 'index))
+ (num (length (get '*selection* 'tracks))))
+ (= index num)))
+
+
+(defun get-safe-duration ()
+ "Returns a safe duration for the labels to be distributed in"
+ (let ((duration (- (get-duration 1) REGION)))
+ (if (< duration 0)
+ 0
+ duration)))
+
+
+(setf num-before-text (<= ZEROS 3))
+(setf zeropad (1+ (rem (1- ZEROS) 3)))
+
+;; Analyze plug-ins may return text message per track but
+;; we only want error messages once, and only one set of labels.
+(if (lasttrackp)
+ (make-labels num-before-text zeropad)
+ "") ; No-op
diff --git a/Release/plug-ins/highpass.ny b/Release/plug-ins/highpass.ny
new file mode 100644
index 0000000000000000000000000000000000000000..466c945230736f6accd1b8bc78f8ab7b6b7de4a1
--- /dev/null
+++ b/Release/plug-ins/highpass.ny
@@ -0,0 +1,40 @@
+$nyquist plug-in
+$version 4
+$type process
+$preview linear
+$name (_ "High-Pass Filter")
+$debugbutton disabled
+$author (_ "Dominic Mazzoni")
+$release 2.3.0-2
+$copyright (_ "GNU General Public License v2.0")
+
+;; License: GPL v2
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control FREQUENCY (_ "Frequency (Hz)") float-text "" 1000 0 nil
+$control ROLLOFF (_ "Roll-off (dB per octave)") choice (("dB6" (_ "6 dB"))
+ ("dB12" (_ "12 dB"))
+ ("dB24" (_ "24 dB"))
+ ("dB36" (_ "36 dB"))
+ ("dB48" (_ "48 dB"))) 0
+
+
+(cond
+ ; Validate minimum frequency at run time so we can give a
+ ; less cryptic error message than built-in widget validation.
+ ((< FREQUENCY 0.1)
+ (_ "Frequency must be at least 0.1 Hz."))
+ ((>= FREQUENCY (/ *sound-srate* 2.0))
+ (format nil
+ (_ "Error:~%~%Frequency (~a Hz) is too high for track sample rate.~%~%~
+ Track sample rate is ~a Hz~%~
+ Frequency must be less than ~a Hz.")
+ FREQUENCY
+ *sound-srate*
+ (/ *sound-srate* 2.0)))
+ (T (funcall (nth ROLLOFF '(hp highpass2 highpass4 highpass6 highpass8))
+ *track* FREQUENCY)))
diff --git a/Release/plug-ins/label-sounds.ny b/Release/plug-ins/label-sounds.ny
new file mode 100644
index 0000000000000000000000000000000000000000..d21d583b76f5166f13abcd6d0f105f1eb238954b
--- /dev/null
+++ b/Release/plug-ins/label-sounds.ny
@@ -0,0 +1,259 @@
+$nyquist plug-in
+$version 4
+$type analyze
+;i18n-hint: Name of effect that labels sounds
+$name (_ "Label Sounds")
+$debugbutton false
+$author (_ "Steve Daulton")
+$release 3.0.4-2
+$copyright (_ "GNU General Public License v2.0 or later")
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control THRESHOLD (_ "Threshold level (dB)") float "" -30 -100 0
+$control MEASUREMENT (_ "Threshold measurement") choice (("peak" (_ "Peak level"))
+ ("avg" (_ "Average level"))
+ ("rms" (_ "RMS level"))) 0
+$control SIL-DUR (_ "Minimum silence duration") time "" 1 0.01 3600
+$control SND-DUR (_ "Minimum label interval") time "" 1 0.01 7200
+$control TYPE (_ "Label type") choice (("before" (_ "Point before sound"))
+ ("after" (_ "Point after sound"))
+ ("around" (_ "Region around sounds"))
+ ("between" (_ "Region between sounds"))) 2
+$control PRE-OFFSET (_ "Maximum leading silence") time "" 0 0 nil
+$control POST-OFFSET (_ "Maximum trailing silence") time "" 0 0 nil
+;i18n-hint: Do not translate '##1'
+$control TEXT (_ "Label text") string "" (_ "Sound ##1")
+
+
+(setf thresh-lin (db-to-linear THRESHOLD))
+(setf max-labels 10000) ;max number of labels to return
+
+
+(defun format-time (s)
+ ;;; format time in seconds as h m s.
+ ;;; (Only used for error message if selection > 2^31 samples.)
+ (let* ((hh (truncate (/ s 3600)))
+ (mm (truncate (/ s 60))))
+ ;i18n-hint: hours minutes and seconds. Do not translate "~a".
+ (format nil (_ "~ah ~am ~as")
+ hh (- mm (* hh 60)) (rem (truncate s) 60))))
+
+
+(defun parse-label-text ()
+ ;;; Special character '#' represents an incremental digit.
+ ;;; Return '(digits num pre-txt post-txt) for
+ ;;; (number-of-digits, initial-value, text-before-number, text-after-number),
+ ;;; or NIL.
+ ;;; 'initial-value' is a positive integer or zero (default).
+ ;;; Only the first instance of #'s are considered 'special'.
+ (let ((hashes 0)
+ (num nil)
+ (negative nil)
+ (pre-txt "")
+ (post-txt "")
+ ch)
+ (dotimes (i (length TEXT))
+ (setf ch (char TEXT i))
+ (cond
+ ((and (string= post-txt "") (char= ch #\#))
+ (incf hashes))
+ ((and (> hashes 0) (string= post-txt ""))
+ (cond
+ ((digit-char-p ch)
+ (if num
+ (setf num (+ (* num 10) (digit-char-p ch)))
+ (setf num (digit-char-p ch))))
+ ((and (not num)(char= ch #\-))
+ (setf negative t))
+ (t (setf post-txt (string ch)))))
+ ((= hashes 0) ;special '#' not yet found
+ (string-append pre-txt (string ch)))
+ (t ;run out of #'s and digit characters.
+ (string-append post-txt (string ch)))))
+ (when negative
+ (setf num (- num)))
+ ;; Replace string literal hash characters.
+ (when (and (> hashes 0) (not num))
+ (dotimes (i hashes)
+ (string-append pre-txt "#")))
+ (list hashes num pre-txt post-txt)))
+
+
+(defun pad (n d)
+ ;;; Return string, int 'n' padded to 'd' digits, or empty string.
+ ;;; Used in formatting label text.
+ (cond
+ (n
+ (let ((negative (minusp n))
+ (n (format nil "~a" (abs n))))
+ (while (< (length n) d)
+ (setf n (format nil "0~a" n)))
+ (if negative
+ (format nil "-~a" n)
+ n)))
+ (t "")))
+
+
+(defun to-mono (sig)
+ ;;; Coerce sig to mono.
+ (if (arrayp sig)
+ (s-max (s-abs (aref sig 0))
+ (s-abs (aref sig 1)))
+ sig))
+
+
+(defun to-avg-mono (sig)
+ ;;; Average of stereo channels
+ (if (arrayp sig)
+ (mult 0.5 (sum (aref sig 0)(aref sig 1)))
+ sig))
+
+
+(defun reduce-srate (sig)
+ ;;; Reduce sample rate to (about) 100 Hz.
+ (let ((ratio (round (/ *sound-srate* 100))))
+ (cond
+ ((= MEASUREMENT 0) ;Peak
+ (let ((sig (to-mono sig)))
+ (snd-avg sig ratio ratio OP-PEAK)))
+ ((= MEASUREMENT 1) ;Average absolute level
+ (let ((sig (to-avg-mono (s-abs sig))))
+ (snd-avg sig ratio ratio OP-AVERAGE)))
+ (t ;RMS
+ (if (arrayp sig)
+ ;; Stereo RMS is the root mean of all (samples ^ 2) [both channels]
+ (let* ((sig (mult sig sig))
+ (left-mean-sq (snd-avg (aref sig 0) ratio ratio OP-AVERAGE))
+ (right-mean-sq (snd-avg (aref sig 1) ratio ratio OP-AVERAGE)))
+ (s-sqrt (mult 0.5 (sum left-mean-sq right-mean-sq))))
+ (rms sig))))))
+
+
+(defun find-sounds (sig srate)
+ ;;; Return a list of sounds that are at least 'SND-DUR' long,
+ ;;; separated by silences of at least 'SIL-DUR'.
+ (let ((sel-start (get '*selection* 'start))
+ (snd-list ())
+ (sample-count 0)
+ (sil-count 0)
+ (snd-count 0)
+ (snd-start 0)
+ (label-count 0)
+ (snd-samples (* SND-DUR srate))
+ (sil-samples (* SIL-DUR srate)))
+ ;;Ignore samples before time = 0
+ (when (< sel-start 0)
+ (setf sample-count (truncate (* (abs sel-start) srate)))
+ (dotimes (i sample-count)
+ (snd-fetch sig)))
+ ;;Main loop to find sounds.
+ (do ((val (snd-fetch sig) (snd-fetch sig)))
+ ((not val) snd-list)
+ (cond
+ ((< val thresh-lin)
+ (when (and (>= sil-count sil-samples)(>= snd-count snd-samples))
+ ;convert sample counts to seconds and push to list.
+ (push (list (/ snd-start srate)
+ (/ (- sample-count sil-count) srate))
+ snd-list)
+ (incf label-count)
+ (when (= label-count max-labels)
+ (format t (_ "Too many silences detected.~%Only the first 10000 labels added."))
+ (return-from find-sounds snd-list))
+ (setf snd-count 0)) ;Pushed to list, so reset sound sample counter.
+ (when (> snd-count 0) ;Sound is shorter than snd-samples, so keep counting.
+ (incf snd-count))
+ (incf sil-count))
+ ;; Above threshold.
+ (t (when (= snd-count 0) ;previous sound was push, so this is a new sound.
+ (setf snd-start sample-count))
+ (setf sil-count 0)
+ (incf snd-count)))
+ (incf sample-count))
+ ;; Check for final sound
+ (when (> snd-count 0)
+ (push (list (/ snd-start srate)
+ (/ (- sample-count sil-count) srate))
+ snd-list))
+ snd-list))
+
+
+(defun return-labels (snd-list)
+ (setf textstr (parse-label-text))
+ ; Selection may extend before t=0
+ ; Find t=0 relative to selection so we can ensure
+ ; that we don't create hidden labels.
+ (setf t0 (- (get '*selection* 'start)))
+ (setf t1 (- (get '*selection* 'end)))
+ (let ((label-start t0)
+ (label-end t1)
+ (label-text "")
+ (labels ())
+ (final-sound (if (= TYPE 3) 1 0)) ;TYPE 3 = regions between sounds.
+ ;; Assign variables to parsed label text
+ (digits (first textstr))
+ (num (second textstr))
+ (pre-txt (third textstr))
+ (post-txt (fourth textstr)))
+ ;snd-list is in reverse chronological order
+ (do ((i (1- (length snd-list)) (1- i)))
+ ((< i final-sound) labels)
+ (case TYPE
+ (3 ;;label silences.
+ (setf start-time (second (nth i snd-list)))
+ (setf end-time (first (nth (1- i) snd-list)))
+ ;don't overlap next sound
+ (setf label-start (min end-time (+ start-time PRE-OFFSET)))
+ ;don't overlap previous sound
+ (setf label-end (max start-time (- end-time POST-OFFSET)))
+ ;ensure end is not before start
+ (when (< (- label-end label-start) 0)
+ (setf label-start (/ (+ label-end label-start) 2.0))
+ (setf label-end label-start)))
+ (t ;; labelling sounds
+ (setf start-time (first (nth i snd-list)))
+ (setf end-time (second (nth i snd-list)))
+ ;don't overlap t0 or previous sound.
+ (setf label-start (max t0 label-start (- start-time PRE-OFFSET)))
+ (setf label-end (+ end-time POST-OFFSET))
+ ;; Don't overlap following sounds.
+ (when (> i 0)
+ (setf label-end (min label-end (first (nth (1- i) snd-list)))))))
+ (setf label-text (format nil
+ "~a~a~a"
+ pre-txt
+ (pad num digits)
+ post-txt))
+ (case TYPE
+ (0 (push (list label-start label-text) labels)) ;point label before sound
+ (1 (push (list label-end label-text) labels)) ;point label after sound
+ (2 (push (list label-start label-end label-text) labels)) ;sound region
+ (t (push (list label-start label-end label-text) labels)));silent region
+ ;Earliest allowed start time for next label.
+ (setf label-start end-time)
+ ;num is either an int or nil
+ (when num (incf num)))))
+
+
+(let ((sig (reduce-srate *track*)))
+ (setf *track* nil)
+ (setf snd-list (find-sounds sig (snd-srate sig)))
+ (cond
+ ((= (length snd-list) 0)
+ (format nil
+ (_ "No sounds found.~%~
+ Try lowering 'Threshold level (dB)'.")))
+ ((and (= TYPE 3)
+ (= (length snd-list) 1))
+ (format nil
+ (_ "Labelling regions between sounds requires~%~
+ at least two sounds.~%~
+ Only one sound detected.")))
+ (t
+ (return-labels snd-list))))
diff --git a/Release/plug-ins/limiter.ny b/Release/plug-ins/limiter.ny
new file mode 100644
index 0000000000000000000000000000000000000000..327331747aae18fe8e3f80e9fcb651a07eb87f81
--- /dev/null
+++ b/Release/plug-ins/limiter.ny
@@ -0,0 +1,135 @@
+$nyquist plug-in
+$version 4
+$type process
+$name (_ "Limiter")
+$debugbutton false
+$preview enabled
+$author (_ "Steve Daulton")
+$release 3.0.4-2
+$copyright (_ "GNU General Public License v2.0 or later")
+
+;; limiter.ny by Steve Daulton November 2011, updated May 2015.
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control TYPE (_ "Type") choice (("SoftLimit" (_ "Soft Limit"))
+ ("HardLimit" (_ "Hard Limit"))
+;i18n-hint: clipping of wave peaks and troughs, not division of a track into clips
+ ("SoftClip" (_ "Soft Clip"))
+ ("HardClip" (_ "Hard Clip"))) 0
+
+;; Translations don't support "\n", and widgets need a literal string,
+;; so the next two controls must be written on two lines.
+$control GAIN-L (_ "Input Gain (dB)
+mono/Left") real "" 0 0 10
+
+$control GAIN-R (_ "Input Gain (dB)
+Right channel") real "" 0 0 10
+
+$control THRESH (_ "Limit to (dB)") real "" -3 -10 0
+$control HOLD (_ "Hold (ms)") real "" 10 1 50
+$control MAKEUP (_ "Apply Make-up Gain") choice ((_ "No") (_ "Yes")) 0
+
+
+(setf gain-left (db-to-linear GAIN-L))
+(setf gain-right (db-to-linear GAIN-R))
+(setf thresh-lin (db-to-linear THRESH))
+(setf bmakeup (= MAKEUP 1))
+
+
+;;; brick wall limiter
+(defun hardlimit (sig limit)
+ (let* ((time (/ HOLD 3000.0)) ; lookahead time (seconds)
+ (samples (round (* time *sound-srate*))) ; lookahead in samples
+ (peak-env (get-env sig samples time limit)))
+ (mult sig
+ (snd-exp (mult -1 (snd-log peak-env))))))
+
+
+;;; Envelope follower for brick wall limiter
+(defun get-env (sig step lookahead limit)
+ (let* ((sig (mult (/ limit) sig))
+ (pad-time (* 3 lookahead)) ; padding required at start (seconds)
+ (pad-s (* 3 step)) ; padding samples
+ (padding (snd-const (peak sig pad-s) 0 *sound-srate* pad-time))
+ (peak-env (snd-avg sig (* 4 step) step OP-PEAK)))
+ (extract 0 1
+ (s-max 1
+ (sim padding
+ (at-abs pad-time (cue peak-env)))))))
+
+
+(defun softlimit (sig threshold)
+ (let* ((sig (hardlimit sig 1))
+ (step (truncate (* (/ HOLD 3000.0) *sound-srate*)))
+ (waveshape (snd-avg sig (* 4 step) step op-peak))
+ (env (sum threshold (mult threshold (diff 1 waveshape))))
+ (env (clip env 1))
+ (offset (/ (* 3 step) *sound-srate*))
+ (initial (peak sig (* 2 step)))
+ (pause-lev (sum threshold (mult threshold (diff 1 initial))))
+ (pause-lev (clip pause-lev 0.9))
+ (pause (snd-const pause-lev 0 *sound-srate* offset)))
+ (setf env (sim pause
+ (at-abs offset (cue env))))
+ (mult sig env)))
+
+
+(defun soft-clip-table ()
+ ;;; Lookup table for soft clipping wave-shaper.
+ (abs-env
+ (sound-srate-abs 44100
+ (control-srate-abs 44100
+ (let* ((knee (- 1 (/ 1.0 pi)))
+ (kcurve (mult knee (osc (hz-to-step (/ (* 4 knee))) knee)))
+ (ikcurve (mult knee (osc (hz-to-step (/ (* 4 knee))) knee *sine-table* -90)))
+ (lin (pwlv -0.5 knee -0.5
+ (+ knee (/ 2.0 pi)) 0.5
+ 2.0 0.5
+ 2.0 (+ 0.5 knee)
+ 2.1 (+ 0.5 knee))))
+ (mult (/ 2.0 pi)
+ (sim (at-abs 0 (cue ikcurve))
+ (at-abs 0 (cue lin))
+ (at-abs (+ knee (/ 2.0 pi)) (cue kcurve)))))))))
+
+
+(defun soft-clip (sig threshold)
+ (let* ((knee (- 1 (/ 1.0 pi)))
+ (clip-level (* (+ 0.5 knee)(/ 2.0 pi)))
+ (sig (mult clip-level (/ threshold) sig)))
+ (if bmakeup
+ ; Allow a little overhead to avoid hitting 0dB.
+ (mult (/ 0.999 clip-level)
+ (shape sig (soft-clip-table) 1.0))
+ (mult (/ threshold clip-level)
+ (shape sig (soft-clip-table) 1.0)))))
+
+
+(defun makeupgain (sig threshold)
+ (if bmakeup
+ (mult (/ 0.999 threshold) sig) ;keep below 0dB
+ sig))
+
+
+;; Pre-gain
+(setf *track*
+ (if (arrayp *track*)
+ (vector (mult (aref *track* 0) gain-left)
+ (mult (aref *track* 1) gain-right))
+ (mult *track* gain-left)))
+
+
+(case TYPE
+ (0 (makeupgain (multichan-expand #'softlimit *track* thresh-lin)
+ thresh-lin))
+ (1 (makeupgain (multichan-expand #'hardlimit *track* thresh-lin)
+ thresh-lin))
+ (2 (soft-clip *track* thresh-lin))
+ (T (makeupgain (clip *track* thresh-lin)
+ thresh-lin)))
diff --git a/Release/plug-ins/lowpass.ny b/Release/plug-ins/lowpass.ny
new file mode 100644
index 0000000000000000000000000000000000000000..a2a44194176f75e8b9c9a1006c32664829600a90
--- /dev/null
+++ b/Release/plug-ins/lowpass.ny
@@ -0,0 +1,40 @@
+$nyquist plug-in
+$version 4
+$type process
+$preview linear
+$name (_ "Low-Pass Filter")
+$debugbutton disabled
+$author (_ "Dominic Mazzoni")
+$release 2.3.0-2
+$copyright (_ "GNU General Public License v2.0")
+
+;; License: GPL v2
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control FREQUENCY (_ "Frequency (Hz)") float-text "" 1000 0 nil
+$control ROLLOFF (_ "Roll-off (dB per octave)") choice (("dB6" (_ "6 dB"))
+ ("dB12" (_ "12 dB"))
+ ("dB24" (_ "24 dB"))
+ ("dB36" (_ "36 dB"))
+ ("dB48" (_ "48 dB"))) 0
+
+
+(cond
+ ; Validate minimum frequency at run time so we can give a
+ ; less cryptic error message than built-in widget validation.
+ ((< FREQUENCY 0.1)
+ (_ "Frequency must be at least 0.1 Hz."))
+ ((>= FREQUENCY (/ *sound-srate* 2.0))
+ (format nil
+ (_ "Error:~%~%Frequency (~a Hz) is too high for track sample rate.~%~%~
+ Track sample rate is ~a Hz~%~
+ Frequency must be less than ~a Hz.")
+ FREQUENCY
+ *sound-srate*
+ (/ *sound-srate* 2.0)))
+ (T (funcall (nth ROLLOFF '(lp lowpass2 lowpass4 lowpass6 lowpass8))
+ *track* FREQUENCY)))
diff --git a/Release/plug-ins/noisegate.ny b/Release/plug-ins/noisegate.ny
new file mode 100644
index 0000000000000000000000000000000000000000..480539cb54c8091ff1bc736f324a22b911188f60
--- /dev/null
+++ b/Release/plug-ins/noisegate.ny
@@ -0,0 +1,174 @@
+$nyquist plug-in
+$version 4
+$type process
+$name (_ "Noise Gate")
+$debugbutton false
+$preview enabled
+$author (_ "Steve Daulton")
+$release 3.0.4-2
+$copyright (_ "GNU General Public License v2.0 or later")
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html .
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control MODE (_ "Select Function") choice (("Gate" (_ "Gate"))
+ ("Analyze" (_ "Analyze Noise Level"))) 0
+$control STEREO-LINK (_ "Stereo Linking") choice (("LinkStereo" (_ "Link Stereo Tracks"))
+ ("DoNotLink" (_ "Don't Link Stereo"))) 0
+;; Work around bug 2336 - Text after control is not read by screen reader.
+$control THRESHOLD (_ "Gate threshold (dB)") float "" -40 -96 -6
+$control GATE-FREQ (_ "Gate frequencies above (kHz)") float "" 0 0 10
+$control LEVEL-REDUCTION (_ "Level reduction (dB)") float "" -24 -100 0
+$control ATTACK (_ "Attack (ms)") float "" 10 1 1000
+$control HOLD (_ "Hold (ms)") float "" 50 0 2000
+$control DECAY (_ "Decay (ms)") float "" 100 10 4000
+
+
+;; The gain envelope for the noisegate function may be a mono sound (STEREO-LINK = 1, or *track* is mono)
+;; or an array of sounds (STEREO-LINK = 0 and *track* is stereo).
+;; 'Level Reduction' is similar to "Range" or "Floor", but is a (negative) amount of gain
+;; rather than a fixed level.
+;;
+;; To create the gain envelope:
+;; 1. If stereo track and STEREO-LINK = 1, get the max of left and right.
+;; 2. Add 'hold' signal when level > THRESHOLD.
+;; This adds a high level signal for 'HOLD' seconds when the level
+;; falls below the THRESHOLD.
+;; 3. Nyquist GATE function to generate exponential rise and decay.
+;; Unlike analog noise gates, lookahead is used so that the gate
+;; begins to open before the signal rises above the THRESHOLD.
+;; When the THRESHOLD is reached, the gate is fully open.
+;; This prevents the gate from clipping the beginning of words / sounds.
+;; 4. Scale level of envelope and offset so that we have unity gain above
+;; THRESHOLD, and 'LEVEL-REDUCTION' below the THRESHOLD.
+;; If SILENCE-FLAG is set (= 1), gain below the THRESHOLD is zero.
+
+
+; Global variables (treat as constants).
+(setf SILENCE-FLAG (if (> LEVEL-REDUCTION -96) 0 1))
+(setf GATE-FREQ (* 1000.0 GATE-FREQ))
+(setf FLOOR (db-to-linear LEVEL-REDUCTION))
+(setf THRESHOLD (db-to-linear THRESHOLD))
+(setf ATTACK (/ ATTACK 1000.0))
+(setf LOOKAHEAD ATTACK)
+(setf DECAY (/ DECAY 1000.0))
+(setf HOLD (/ HOLD 1000.0))
+
+
+(defun error-check ()
+ (let ((max-hz (* *sound-srate* 0.45)) ;10% below Nyquist should be safe maximum.
+ (max-khz (roundn (* 0.00045 *sound-srate*) 1))
+ (gate-freq-khz (roundn (/ GATE-FREQ 1000.0) 1)))
+ (when (>= GATE-FREQ max-hz)
+ (throw 'err (format nil
+ (_ "Error.~%~
+ Gate frequencies above: ~s kHz~%~
+ is too high for selected track.~%~
+ Set the control below ~a kHz.")
+ gate-freq-khz
+ max-khz))))
+ (when (< len 100) ;100 samples required
+ (throw 'err (format nil
+ (_ "Error.~%~
+ Insufficient audio selected.~%~
+ Make the selection longer than ~a ms.")
+ (round-up (/ 100000 *sound-srate*))))))
+
+
+;;; Analysis functions:
+;; Measure the peak level (dB) and suggest setting threshold a little higher.
+
+(defun analyze (sig)
+ ; Return analysis text.
+ (let* ((test-length (truncate (min len (/ *sound-srate* 2.0))))
+ (peakdb (peak-db sig test-length))
+ (target (+ 1.0 peakdb))) ;suggest 1 dB above noise level
+ (format nil
+ (_ "Peak based on first ~a seconds ~a dB~%~
+ Suggested Threshold Setting ~a dB.")
+ (roundn (/ test-length *sound-srate*) 2)
+ (roundn peakdb 2)
+ (roundn target 0))))
+
+
+(defun peak-db (sig test-len)
+ ;; Return absolute peak (dB).
+ ;; For stereo tracks, return the maximum of the channels.
+ (if (arrayp sig)
+ (let ((peakL (peak (aref sig 0) test-len))
+ (peakR (peak (aref sig 1) test-len)))
+ (linear-to-db (max peakL peakR)))
+ (linear-to-db (peak sig test-len))))
+
+
+;;; Utility functions
+
+(defun round-up (num)
+ (round (+ num 0.5)))
+
+
+(defun roundn (num places)
+ ;; Return number rounded to specified decimal places.
+ (if (= places 0)
+ (round num)
+ (let* ((x (format NIL "~a" places))
+ (ff (strcat "%#1." x "f")))
+ (setq *float-format* ff)
+ (format NIL "~a" num))))
+
+
+(defun format-time (s)
+ ;;; format time in seconds as h m.
+ (let* ((hh (truncate (/ s 3600)))
+ (mm (truncate (/ s 60))))
+ ;i18n-hint: hours and minutes. Do not translate "~a".
+ (format nil (_ "~ah ~am") hh (- mm (* hh 60)))))
+
+
+;;; Gate Functions
+
+(defun noisegate (sig follow)
+ ;; Takes a sound and a 'follow' sound as arguments.
+ ;; Returns the gated audio.
+ (let ((gain (/ (- 1 (* SILENCE-FLAG FLOOR)))) ; SILENCE-FLAG is 0 or 1.
+ (env (get-env follow)))
+ (if (> GATE-FREQ 20)
+ (let* ((high (highpass8 sig GATE-FREQ))
+ (low (lowpass8 sig (* 0.91 GATE-FREQ)))) ;magic number 0.91 improves crossover.
+ (sim (mult high gain env) low))
+ (mult sig gain env))))
+
+
+(defun get-env (follow)
+ ;; Return gate's envelope
+ (let* ((gate-env (gate follow LOOKAHEAD ATTACK DECAY FLOOR THRESHOLD))
+ (gate-env (clip gate-env 1.0))) ;gain must not exceed unity.
+ (diff gate-env (* SILENCE-FLAG FLOOR))))
+
+
+(defun peak-follower (sig)
+ ;; Return signal that gate will follow.
+ (setf sig (multichan-expand #'snd-abs sig))
+ (when (and (arrayp sig)(= STEREO-LINK 0))
+ (setf sig (s-max (aref sig 0) (aref sig 1))))
+ (if (> HOLD 0)
+ (multichan-expand #'snd-oneshot sig THRESHOLD HOLD)
+ sig))
+
+
+(defun process ()
+ (error-check)
+ ;; For stereo tracks, 'peak-follower' may return a sound
+ ;; or array of sounds, so pass it to 'noisegate' rather than
+ ;; calculating in 'noisegate'.
+ (multichan-expand #' noisegate *track* (peak-follower *track*)))
+
+
+;; Run program
+(case MODE
+ (0 (catch 'err (process)))
+ (T (analyze *track*)))
diff --git a/Release/plug-ins/notch.ny b/Release/plug-ins/notch.ny
new file mode 100644
index 0000000000000000000000000000000000000000..e81fd7c4c062220df18f7772af1068c771916007
--- /dev/null
+++ b/Release/plug-ins/notch.ny
@@ -0,0 +1,32 @@
+$nyquist plug-in
+$version 4
+$type process
+$preview linear
+$name (_ "Notch Filter")
+$debugbutton false
+$author (_ "Steve Daulton and Bill Wharrie")
+$release 2.3.0-2
+$copyright (_ "GNU General Public License v2.0 or later")
+
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control FREQUENCY (_ "Frequency (Hz)") float-text "" 60 0 nil
+$control Q (_ "Q (higher value reduces width)") float-text "" 1 0.1 1000
+
+(cond
+ ((< FREQUENCY 0.1) (_ "Frequency must be at least 0.1 Hz."))
+ ((>= FREQUENCY (/ *sound-srate* 2.0))
+ (format nil
+ (_ "Error:~%~%Frequency (~a Hz) is too high for track sample rate.~%~%~
+ Track sample rate is ~a Hz.~%~
+ Frequency must be less than ~a Hz.")
+ FREQUENCY
+ *sound-srate*
+ (/ *sound-srate* 2.0)))
+ (T (notch2 *track* FREQUENCY Q)))
diff --git a/Release/plug-ins/nyquist-plug-in-installer.ny b/Release/plug-ins/nyquist-plug-in-installer.ny
new file mode 100644
index 0000000000000000000000000000000000000000..8a5502b90ff1ba4d9bdf4c50b33f338fa8e5b5b5
--- /dev/null
+++ b/Release/plug-ins/nyquist-plug-in-installer.ny
@@ -0,0 +1,257 @@
+$nyquist plug-in
+$version 4
+$type tool
+$name (_ "Nyquist Plugin Installer")
+$debugbutton false
+$preview disabled
+$author "Steve Daulton"
+$release 2.4.0-2
+$copyright (_ "GNU General Public License v2.0 or later")
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+;i18n-hint: "Browse..." is text on a button that launches a file browser.
+$control FILES (_ "Select file(s) to install") file (_ "Browse...") "~/Desktop/" (((_ "Plug-in") (ny NY))
+ ((_ "Lisp file") (lsp LSP))
+ ((_ "HTML file") (htm HTM html HTML))
+ ((_ "Text file") (txt TXT))
+ ((_ "All supported") (ny NY lsp LSP htm HTM html HTML txt TXT))
+ ((_ "All files") (""))) "open,exists,multiple"
+$control OVERWRITE (_ "Allow overwriting") choice ((_ "Disallow") (_ "Allow")) 0
+
+
+(defun audacity-version-ok (min-version)
+ ;; No longer required as this plug-in is shipped with Audacity.
+ ;; Left in for illustration purposes.
+ ;; min-version is a list of three numbers (the minimum Audacity version number).
+ ;; Example, if the minimum version required is Audacity 2.4.0, then
+ ;; call (audacity-version-ok '(2 4 0))
+ ;; Returns t if plug-in is running on 2.4.0 or later, otherwise nil.
+ (cond
+ ((get '*audacity* 'version)
+ (mapc (lambda (x y)
+ (cond
+ ((boundp 'isok))
+ ((> x y) (setf isok t))
+ ((< x y) (setf isok nil))))
+ (get '*audacity* 'version)
+ min-version)
+ (or (not (boundp 'isok)) isok))
+ (t nil)))
+
+
+(defun get-file-name (fqname &aux (fname ""))
+ ;; Return file name . extension from fully qualified file name.
+ (dotimes (i (length fqname) fname)
+ (if (char= (char fqname i) *file-separator*)
+ (setf fname "")
+ (setf fname (format nil "~a~a" fname (char fqname i))))))
+
+
+(defun isfilename (fname)
+ ;; Return t if fname looks like valid file name, else nil.
+ (let ((ln (length fname)))
+ (cond
+ ((= ln 0) nil)
+ ((char= (char fname (- ln 1)) *file-separator*) nil)
+ (t t))))
+
+
+(defun existsp (fname)
+ ;; Return t if file exists, else nil.
+ (let ((fp (open fname)))
+ (cond
+ (fp (close fp)
+ t)
+ (t nil))))
+
+
+(defun writeablep (fname)
+ ;; Return t if file is writeable.
+ (let ((fp (open fname :direction :output)))
+ (cond
+ (fp (close fp) t)
+ (t nil))))
+
+
+(defun copy-file (input output)
+ ;; Copy from input file to output file.
+ (let ((ifp (open input :direction :input))
+ (ofp (open output :direction :output)))
+ (do ((line (read-line ifp)(read-line ifp)))
+ ((not line))
+ (format ofp "~a~%" line))
+ (close ifp)
+ (close ofp)))
+
+
+(defun issupported (fname)
+ ;; Return true if it looks like a supported file.
+ ;; For .lsp and .html files, we only check the file extension.
+ ;; For .ny files, we have additional sanity checks that it is a
+ ;; plug-in and not just a Nyquist Prompt script.
+ (let ((goodfname (fix-ext fname)))
+ (cond
+ ((check-ext goodfname ".lsp") t)
+ ((check-ext goodfname ".htm") t)
+ ((check-ext goodfname ".html") t)
+ ((check-ext goodfname ".txt") t)
+ ((not (check-ext goodfname ".ny")) nil)
+ ((has-plugin-header fname) t)
+ (t nil))))
+
+
+(defun check-ext (fname ext)
+ ;; Return true if fname has extension ext.
+ (let* ((fnameln (length fname))
+ (extln (length ext))
+ (restln (- fnameln extln)))
+ (cond
+ ((< fnameln (1+ extln)) nil) ; Too short to be valid.
+ ((string-equal (subseq fname restln fnameln) ext) t)
+ (t nil))))
+
+
+(defun fix-ext (fname)
+ ;; If string ends in ".ny.txt" or ".lsp.txt", strip off ".txt"
+ (macrolet ((striptxt (fname) `(setf ,fname (subseq ,fname 0 (- ln 4)))))
+ (let ((ln (length fname)))
+ (cond
+ ((and (> ln 8) (string-equal (subseq fname (- ln 8) ln) ".lsp.txt"))
+ (striptxt fname))
+ ((and (> ln 7) (string-equal (subseq fname (- ln 7) ln) ".ny.txt"))
+ (striptxt fname)))
+ fname)))
+
+
+(defun has-plugin-header (fname)
+ ;; Return t if file looks like valid Nyquist plug-in, else nil.
+ (let ((fp (open fname))
+ (teststring "nyquist plug-in"))
+ ; First char may be #\; or #\$
+ (setf b (read-byte fp))
+ (cond
+ ((and (/= b (char-code #\;))(/= b (char-code #\$)))
+ (close fp)
+ nil)
+ ((do* ((i 0 (1+ i))
+ (b (read-byte fp) (read-byte fp))
+ (test (char-code (char teststring i))
+ (char-code (char teststring i))))
+ ((= i (1- (length teststring))) t)
+ (when (/= b test)
+ (return)))
+ (close fp)
+ t)
+ (t
+ (close fp)
+ nil))))
+
+
+(defun get-file-list (file-string)
+ ;; See https://wiki.audacityteam.org/wiki/Nyquist_File-Button_Tutorial#Open_Multiple_Files
+ (let ((path-string (format nil "(list ~s )" (string-trim "\"" file-string))))
+ (eval-string path-string)))
+
+
+(defun install (fname)
+ ;; Install file fname (fully qualified file name).
+ ;; Push result to list install-success or install-fail.
+ (setf out-path (get '*system-dir* 'user-plug-in))
+ (setf short-name (get-file-name fname))
+ (cond
+ ((not (existsp fname))
+ (push (list 3 fname) install-fail))
+ ((not (issupported fname))
+ (push (list 4 fname) install-fail))
+ (t
+ (setf short-name (fix-ext short-name))
+ (setf out-fname
+ (format nil "~a~a~a" out-path *file-separator* short-name))
+ (setf out-file-exists (existsp out-fname))
+ (cond
+ ;; Check for fails
+ ((and out-file-exists
+ (= OVERWRITE 0))
+ (push (list 5 short-name) install-fail))
+ ((not (writeablep out-fname))
+ (push (list 6 short-name) install-fail))
+ ;; Now the successes
+ ((check-ext short-name ".ny")
+ (copy-file fname out-fname)
+ (if (and out-file-exists
+ (= OVERWRITE 1))
+ (push (list 1 short-name) install-success)
+ (push (list 0 short-name) install-success)))
+ ;; Output file is writeable and did not previously exist.
+ (t (copy-file fname out-fname)
+ (push (list 2 short-name) install-success))))))
+
+
+(defun print-results (&aux msg results)
+ ;; Format results and display in human readable form.
+ (cond
+ ((isempty install-success)
+ (setf msg (format nil (_ "Error.~%"))))
+ ((isempty install-fail)
+ (setf msg (format nil (_ "Success.~%Files written to:~%~s~%")
+ (get '*system-dir* 'user-plug-in))))
+ (t (setf msg (format nil (_ "Warning.~%Failed to copy some files:~%")))))
+ (setf results (append install-success install-fail))
+ (setf results (sort-results results))
+ (let ((status -1))
+ (dolist (m results msg)
+ (when (/= (first m) status)
+ (setf msg (format nil "~a~%~a~%" msg (status (first m))))
+ (setf status (first m)))
+ (setf msg (format nil "~a~a~%" msg (second m))))))
+
+
+(defun isempty (x)
+ ;;Return t if x is an empty list.
+ (unless (listp x)
+ (error "Not a list" x))
+ (if (= (length x) 0) t nil))
+
+
+(defun isnotempty (x)
+ (not (isempty x)))
+
+
+(defun status (num)
+ ;; Return status message corresponding to the installation status number.
+ ;; This allows result messages to be grouped according to installation status.
+ (case num ; Success
+ ; Translations fail when strings contain control characters, so
+ ; use FORMAT directive "~%" instead of "\n" for new line.
+ (0 (format nil (_ "Plug-ins installed.~%(Use the Plug-in Manager to enable effects):")))
+ (1 (_ "Plug-ins updated:"))
+ (2 (_ "Files copied to plug-ins folder:"))
+ ;; Fail
+ (3 (_ "Not found or cannot be read:"))
+ (4 (_ "Unsupported file type:"))
+ (5 (_ "Files already installed ('Allow Overwriting' disabled):"))
+ (6 (_ "Cannot be written to plug-ins folder:"))))
+
+
+(defun sort-results (results)
+ ;; 'results' are either 'install-success' or 'install-fail'.
+ ;; Each item in results is (list status file-name).
+ ;; Returns 'results' sorted by status number.
+ (sort results #'(lambda (x y) (< (car x) (car y)))))
+
+
+;; Global lists
+(setf install-success ())
+(setf install-fail ())
+
+(let ((file-list (get-file-list FILES)))
+ (if (= (length file-list) 0)
+ (format nil (_ "Error.~%No file selected."))
+ (dolist (file file-list (print-results))
+ (install file))))
diff --git a/Release/plug-ins/pluck.ny b/Release/plug-ins/pluck.ny
new file mode 100644
index 0000000000000000000000000000000000000000..d95313c9920d1f41cd0c0f2f3f6aee0dc112feba
--- /dev/null
+++ b/Release/plug-ins/pluck.ny
@@ -0,0 +1,48 @@
+$nyquist plug-in
+$version 4
+$type generate
+$name (_ "Pluck")
+$debugbutton false
+$preview linear
+$author (_ "David R.Sky")
+$release 2.4.2
+$copyright (_ "GNU General Public License v2.0")
+
+
+;;MIDI values for C notes: 36, 48, 60 [middle C], 72, 84, 96.
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control PITCH (_ "Pluck MIDI pitch") int "" 60 1 120
+$control FADE (_ "Fade-out type") choice ((_ "Abrupt") (_ "Gradual")) 0
+$control DUR (_ "Duration (60s max)") time "" 1 0 60
+
+
+; set final-amp for abrupt or gradual fade
+(setf final-amp (if (= FADE 1) 0.001 0.000001))
+
+(cond
+ ((> DUR 0)
+ ;; Get length of preview
+ (setq pdur
+ (if *previewp*
+ (get '*project* 'preview-duration)
+ DUR))
+
+ (let* ((pluck-sound (snd-pluck *sound-srate* (step-to-hz PITCH) 0 DUR final-amp))
+ (pluck-sound (extract-abs 0 pdur pluck-sound)) ; shorten if necessary for preview.
+ (max-peak (peak pluck-sound ny:all)))
+ ;; snd-pluck has a random element and will occasionally produce
+ ;; zero amplitude at very high pitch settings. Avoid division by zero.
+ (if (> max-peak 0)
+ (scale (/ 0.8 max-peak) pluck-sound)
+ pluck-sound)))
+ ;; Length of sound is zero!
+ ;; If previewing give Audacity a bit of silence, else return null string.
+ (*previewp* (s-rest 0.1))
+ (t ""))
diff --git a/Release/plug-ins/rhythmtrack.ny b/Release/plug-ins/rhythmtrack.ny
new file mode 100644
index 0000000000000000000000000000000000000000..981188f7bd7a8cc3dfd6229f3c395173aeac0acb
--- /dev/null
+++ b/Release/plug-ins/rhythmtrack.ny
@@ -0,0 +1,247 @@
+$nyquist plug-in
+$version 4
+$type generate
+$name (_ "Rhythm Track")
+$debugbutton false
+$preview linear
+$author (_ "Dominic Mazzoni, David R. Sky and Steve Daulton")
+$release 3.0.0-2
+$copyright (_ "GNU General Public License v2.0")
+
+
+;; Drip sound generator by Paul Beach
+
+;; TODO: add more drum sounds
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control TEMPO (_ "Tempo (bpm)") real (_ "30 - 300 beats/minute") 120 30 300
+$control TIMESIG (_ "Beats per bar") int (_ "1 - 20 beats/measure") 4 1 20
+$control SWING (_ "Swing amount") float (_ "+/- 1") 0 -1 1
+$control text (_ "Set 'Number of bars' to zero to enable the 'Rhythm track duration'.")
+$control BARS (_ "Number of bars") int (_ "1 - 1000 bars") 16 0 1000
+$control CLICK-TRACK-DUR (_ "Rhythm track duration") time (_ "Used if 'Number of bars' = 0") 0 0 nil
+$control OFFSET (_ "Start time offset") time (_ "Silence before first beat") 0 0 nil
+$control CLICK-TYPE (_ "Beat sound") choice (("Metronome" (_ "Metronome Tick"))
+ (_ "Ping (short)")
+ (_ "Ping (long)")
+ (_ "Cowbell")
+ ("ResonantNoise" (_ "Resonant Noise"))
+ ("NoiseClick" (_ "Noise Click"))
+ (_ "Drip (short)")
+ (_ "Drip (long)")) 0
+
+$control HIGH (_ "MIDI pitch of strong beat") int (_ "18 - 116") 84 18 116
+$control LOW (_ "MIDI pitch of weak beat") int (_ "18 - 116") 80 18 116
+
+
+;; Helper functions:
+
+(defun round-up (x)
+ (if (> x (truncate x))
+ (truncate (1+ x))
+ (truncate x)))
+
+
+;; Filtering causes changes amplitude, so we normalize to
+;; achieve a predictable level.
+(defun normalize (sig)
+ (scale (/ (peak sig ny:all)) sig))
+
+
+(defun s-rest-abs (d)
+ (abs-env (s-rest d)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Click sound synthesis
+;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;; Drip sound by Paul Beach www.proviewlandscape.com/liss/
+(defun drip (p) ;p is pitch in hz
+ (let* ((maxhz (/ *sound-srate* 2.1))
+ (hz1 (min maxhz (* 2.40483 p)))
+ (hz2 (min maxhz (* 5.52008 p)))
+ (hz3 (min maxhz (* 8.653 p)))
+ (hz4 (min maxhz (* 11.8 p))))
+ (lp
+ (stretch-abs 1
+ (mult (exp-dec 0 0.015 0.25)
+ (sim
+ (mult (hzosc hz1) 0.5)
+ (mult (hzosc hz2) 0.25)
+ (mult (hzosc hz3) 0.125)
+ (mult (hzosc hz4) 0.0625))))
+ 440)))
+
+
+;; Metronome tick by Steve Daulton.
+(defun metronome-tick (hz peak)
+ (let* ((ln 300)
+ (sig-array (make-array ln))
+ (x 1))
+ ;; generate some 'predictable' white noise
+ (dotimes (i ln)
+ (setf x (rem (* 479 x) 997))
+ (setf (aref sig-array i) (- (/ x 500.0) 1)))
+ (setf sig (sim (s-rest-abs 0.2)
+ (snd-from-array 0 44100 sig-array)))
+ (setf sig
+ (mult (abs-env (pwev 10 (/ ln 44100.0) 2 1 0))
+ (highpass8 (lowpass2 sig (* 2 hz) 6)
+ hz)))
+ (let ((gain (/ (peak sig 300))))
+ ; The '1.11' factor makes up for gain reduction in 'resample'
+ (mult (abs-env (pwlv 1.11 0.02 1.11 0.05 0 ))
+ (jcrev (mult peak gain sig) 0.01 0.1)))))
+
+
+;; Cowbell by Steve Daulton.
+(defun cowbell (hz)
+ (sim
+ (mult (pwev 0.3 0.8 0.0005)
+ (hzosc hz *tri-table*)
+ (hzosc (* hz 3.46) *tri-table*))
+ (mult (pwev 0.7 0.2 0.01)
+ (hzosc (* hz 7.3) *tri-table*)
+ (hzosc (* hz 1.52) *tri-table*))))
+
+
+;; Single tick generators:
+
+(defun get-metronome-tick (hz gain)
+ (resample
+ (sound-srate-abs 44100 (metronome-tick hz gain))
+ *sound-srate*))
+
+
+(defun get-ping (pitch ticklen)
+ (stretch-abs ticklen
+ (mult
+ (control-srate-abs *sound-srate* (pwl 0.005 amp 0.995 amp 1))
+ (osc pitch))))
+
+
+(defun get-resonant-noise (pitch)
+ (stretch-abs 0.05 ; 50 milliseconds
+ (mult
+ (control-srate-abs *sound-srate* (pwl 0.05 amp 0.95 amp 1))
+ (normalize (lowpass2 (noise 1) (step-to-hz pitch) 20)))))
+
+
+(defun get-noise-click (pitch)
+ (stretch-abs 0.005
+ (mult
+ (control-srate-abs *sound-srate* (pwl 0.005 amp 0.995 amp 1))
+ (normalize (lowpass2 (noise 1) (step-to-hz pitch) 2)))))
+
+
+(defun get-drip (pitch ticklen)
+ (stretch-abs ticklen
+ (mult
+ (control-srate-abs *sound-srate* (pwl 0.005 amp 0.995 amp 1))
+ (normalize (drip (step-to-hz pitch))))))
+
+
+(defun get-cowbell (pitch)
+ (mult 0.8 (cowbell (step-to-hz pitch))))
+
+
+;; Make selected click
+(defun click (accent)
+ (setq pitch (if (= accent 1) HIGH LOW))
+ (setq amp (if (= accent 1) 0.75 0.5))
+ (case CLICK-TYPE
+ (0 (get-metronome-tick (step-to-hz pitch) amp))
+ (1 (get-ping pitch 0.01))
+ (2 (get-ping pitch 0.08))
+ (3 (get-cowbell pitch))
+ (4 (get-resonant-noise pitch))
+ (5 (get-noise-click pitch))
+ (6 (get-drip pitch 0.007))
+ (t (get-drip pitch 0.1))))
+
+
+(defun swing-adjust (i val)
+ (* val (/ 3.0) (rem (1+ i) 2)))
+
+
+;Make one measure and save it in the global *measure*
+(defun makemeasure ()
+ (setf *measure*
+ (sim
+ (s-rest (* TIMESIG beatlen)) ;required for trailing silence
+ (click 1) ;accented beat
+ (simrep (count (- TIMESIG 1))
+ (at-abs (* beatlen (+ count 1 (swing-adjust count SWING)))
+ (cue (click 0))))))) ;unaccented beat
+
+
+(defun samplecount (total)
+ ;;; Return number of samples required to reach target
+ (defun lastsample (target)
+ (let ((required (- target total)))
+ (setf total target)
+ required))
+ (function lastsample))
+
+
+(defun get-measure (barnum)
+ (let ((end (* (1+ barnum) (* TIMESIG beatlen)))
+ required-samples)
+ ;; Actual end time is integer samples
+ (setf end (round (* end *sound-srate*)))
+ (setf required-samples (funcall addsamples end))
+ (setf *measure* (set-logical-stop (cue *measure*)
+ (/ required-samples *sound-srate*))))
+ *measure*)
+
+
+(defun make-click-track (barcount mdur)
+ (seqrep (i barcount) (cue (get-measure i))))
+
+
+;;;;;;;;;;;;;;;;;
+;; MAIN PROGRAM
+;;;;;;;;;;;;;;;;;
+
+
+(setf beatlen (/ 60.0 TEMPO))
+
+;call function to make one measure
+(makemeasure)
+
+; If 'Number of bars' = 0, calculate bars from 'Rhythm track duration'.
+(if (= BARS 0)
+ (setq barcount (/ CLICK-TRACK-DUR (* TIMESIG beatlen)))
+ (setf barcount BARS))
+
+;if previewing, restrict number of bars
+(let ((preview (/ (get '*project* 'preview-duration)
+ (* TIMESIG beatlen))))
+ (if *previewp*
+ (setf barcount (min preview barcount))))
+
+;round up number of bars
+(setf barcount (round-up barcount))
+
+;; Calculate LEN for progress bar.
+(setf len (/ (* 60.0 *sound-srate* TIMESIG barcount) TEMPO))
+
+;; Initialize sample count
+(setf addsamples (samplecount 0))
+
+(if (< barcount 1)
+ (format nil (_ "Set either 'Number of bars' or~%~
+ 'Rhythm track duration' to greater than zero."))
+ (if *previewp*
+ ;; Don't preview the offset (silence).
+ (make-click-track barcount (* TIMESIG beatlen))
+ (seq (s-rest OFFSET)
+ (make-click-track barcount (* TIMESIG beatlen)))))
diff --git a/Release/plug-ins/rissetdrum.ny b/Release/plug-ins/rissetdrum.ny
new file mode 100644
index 0000000000000000000000000000000000000000..e6b1fe95a98050b4ca315675a6b882baad3c40b2
--- /dev/null
+++ b/Release/plug-ins/rissetdrum.ny
@@ -0,0 +1,82 @@
+$nyquist plug-in
+$version 4
+$type generate
+$preview linear
+$i18n-hint named for Jean-Claude Risset (silent t)
+$name (_ "Risset Drum")
+$debugbutton false
+$author (_ "Steven Jones")
+$release 2.3.0-2
+$copyright (_ "GNU General Public License v2.0 or later")
+
+;; rissetdrum.ny by Steven Jones, after Jean Claude Risset.
+;; Updated by Steve Daulton 2012 and May 2015.
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control FREQ (_ "Frequency (Hz)") real "" 100 50 2000
+$control DECAY (_ "Decay (seconds)") real "" 2 0.1 60
+$control CF (_ "Center frequency of noise (Hz)") real "" 500 100 5000
+$control BW (_ "Width of noise band (Hz)") real "" 400 10 1000
+$control NOISE (_ "Amount of noise in mix (percent)") real "" 25 0 100
+$control GAIN (_ "Amplitude (0 - 1)") real "" 0.8 0 1
+
+
+;; Reduce length when previewing.
+(setq pdur
+ (if *previewp*
+ (get '*project* 'preview-duration)
+ DECAY))
+
+
+(setq *rdrum-table*
+ (list
+ (mult 0.17
+ (sum
+ (scale 1.00 (build-harmonic 10 2048))
+ (scale 1.50 (build-harmonic 16 2048))
+ (scale 2.00 (build-harmonic 22 2048))
+ (scale 1.50 (build-harmonic 23 2048))))
+ (hz-to-step 1) t))
+
+
+(defun log2 (n)
+ (/ (log (float n))(log 2.0)))
+
+
+(defun percussion-env (dur)
+ (let* ((half-life (expt 2.0 (- (log2 dur) 3))))
+ (exp-dec 0 half-life dur)))
+
+
+(defun risset-drum ()
+ (let* ((decay2 (* DECAY 0.50))
+ (low-note (* FREQ 0.10))
+ (tone-gain (- 1 NOISE)))
+ (setf pink (lowpass6 (noise decay2) BW))
+ (setf rdrum
+ (mult tone-gain
+ (osc (hz-to-step low-note) decay2 *rdrum-table*)))
+ (setf noise-band
+ (mult NOISE
+ (sine (hz-to-step CF) decay2)
+ pink))
+ (sum
+ (mult
+ (percussion-env decay2)
+ (sum noise-band rdrum ))
+ (mult tone-gain
+ (percussion-env DECAY)
+ (sine (hz-to-step FREQ) DECAY)))))
+
+
+;; Generate and normalize
+(let* ((output (risset-drum))
+ (output (extract-abs 0 pdur output)) ; shorten if necessary for preview.
+ (peakval (peak output ny:all)))
+ (scale (/ GAIN peakval) output))
diff --git a/Release/plug-ins/rms.ny b/Release/plug-ins/rms.ny
new file mode 100644
index 0000000000000000000000000000000000000000..a39d61382faa1e622e7fb228f874bfc1b0ba23ea
--- /dev/null
+++ b/Release/plug-ins/rms.ny
@@ -0,0 +1,67 @@
+;nyquist plug-in
+;version 4
+;type analyze
+;name "Measure RMS"
+;debugbutton false
+;author "Steve Daulton"
+;release 2.3.1-1
+$copyright (_ "GNU General Public License v2.0 or later")
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+;; This plug-in demonstrates how authors of Nyquist plug-ins may add translations
+;; for output messages. It is not currently possible to provide translations for strings
+;; in the header comments (such as the plug-in name) of 3rd party plug-ins.
+
+
+;; Translations strings:
+;; The "en" translation is not normally required unless the original text is in another
+;; language, but it can make testing easier.
+(setf *locale*
+ '(("en" (("Left" "Left")
+ ("Right" "Right")
+ ("Stereo" "Stereo")
+ ("Mono" "Mono")
+ ("dB" "dB")))
+ ("de" (("Left" "Links")
+ ("Right" "Rechts")
+ ("Stereo" "Stereo")
+ ("Mono" "Mono")
+ ("dB" "dB")))
+ ("es" (("Left" "Izquierda")
+ ("Right" "Derecha")
+ ("Stereo" "Estéreo")
+ ("Mono" "Mono")
+ ("dB" "dB")))
+ ("fr" (("Left" "Gauche")
+ ("Right" "Droite")
+ ("Stereo" "Stéréo")
+ ("Mono" "Mono")
+ ("dB" "dB")))
+ ("ru" (("Left" "Левый")
+ ("Right" "Правый")
+ ("Stereo" "Стерео")
+ ("Mono" "Моно")
+ ("dB" "дБ")))))
+
+
+(defun stereo-rms(ar)
+ ;;; Stereo RMS is the root mean of all (samples ^ 2) [both channels]
+ (let ((left-mean-sq (* (aref ar 0)(aref ar 0)))
+ (right-mean-sq (* (aref ar 1)(aref ar 1))))
+ (sqrt (/ (+ left-mean-sq right-mean-sq) 2.0))))
+
+
+(let ((rms (get '*selection* 'rms)))
+ (if (arrayp rms)
+ (format nil "~a: \t~a ~a~%~
+ ~a: \t~a ~a~%~
+ ~a: \t~a ~a"
+ (_ "Left") (linear-to-db (aref rms 0)) (_ "dB")
+ (_ "Right") (linear-to-db (aref rms 1)) (_ "dB")
+ (_ "Stereo") (linear-to-db (stereo-rms rms)) (_ "dB"))
+ (format nil "~a: \t~a ~a" (_ "Mono")(linear-to-db rms)(_ "dB"))))
diff --git a/Release/plug-ins/sample-data-export.ny b/Release/plug-ins/sample-data-export.ny
new file mode 100644
index 0000000000000000000000000000000000000000..0f173b86029392d7bc1a19697451f4172016b020
--- /dev/null
+++ b/Release/plug-ins/sample-data-export.ny
@@ -0,0 +1,510 @@
+$nyquist plug-in
+$version 4
+$type tool analyze
+$name (_ "Sample Data Export")
+$debugbutton false
+$author (_ "Steve Daulton")
+$release 3.0.4-2
+$copyright (_ "GNU General Public License v2.0 or later")
+
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+;; To enable L/R prefix before alternate L/R channels
+;; (text output with header only)
+;; remove the semicolon from the start of the next line:
+;(setq LR-PREFIX '("L: " "R: "))
+
+$control NUMBER (_ "Limit output to first") int-text (_ "samples") 100 1 1000000
+$control UNITS (_ "Measurement scale") choice ((_ "dB") (_ "Linear")) 0
+$control FILENAME (_ "Export data to") file (_ "Select a file") "*default*/sample-data.txt" (((_ "Text file") (txt TXT))
+ ((_ "CSV files") (csv CSV))
+ ((_ "HTML files") (html HTML htm HTM))
+ ((_ "All files") (""))) "save,overwrite"
+$control FILEFORMAT (_ "Index (text files only)") choice ((_ "None")
+ ("Count" (_ "Sample Count"))
+ ("Time" (_ "Time Indexed")))
+$control HEADER (_ "Include header information") choice ((_ "None")
+ (_ "Minimal")
+ (_ "Standard")
+ (_ "All")) 0
+$control OPTEXT (_ "Optional header text") string "" ""
+$control CHANNEL-LAYOUT (_ "Channel layout for stereo") choice (;i18n-hint: Left and Right
+ ("SameLine" (_ "L-R on Same Line"))
+ ("Alternate" (_ "Alternate Lines"))
+ ;i18n-hint: L for Left
+ ("LFirst" (_ "L Channel First"))) 0
+$control MESSAGES (_ "Show messages") choice ((_ "Yes")
+ ("Errors" (_ "Errors Only"))
+ (_ "None")) 0
+
+
+;; Global constants
+(setf NUMBER (min (truncate len) NUMBER))
+(when (not (boundp 'LR-PREFIX))(setq LR-PREFIX nil))
+(setq *float-format* "%1.5f") ; 5 decimal places
+
+
+;;; Return file extension or empty string
+(defun get-extension (fname)
+ (let ((n (1- (length fname)))
+ (ext ""))
+ (do ((i n (1- i)))
+ ((= i 0) ext)
+ (when (char= (char fname i) #\.)
+ (setf ext (subseq fname (1+ i)))
+ (return ext)))))
+
+
+;;; stereo peak
+(defun stereomax (snd)
+ (if (arrayp *track*)
+ (max (peak (aref *track* 0) NUMBER)
+ (peak (aref *track* 1) NUMBER))
+ (peak *track* NUMBER)))
+
+
+;;; stereo rms
+(defun srms (snd)
+ (if (arrayp snd)
+ (let* ((sql (mult (aref *track* 0)(aref *track* 0)))
+ (sqr (mult (aref *track* 1)(aref *track* 1)))
+ (avgsq (mult 0.5 (sum sql sqr)))
+ (avgsq (snd-avg avgsq NUMBER NUMBER op-average)))
+ (lin-to-db (peak (snd-sqrt avgsq) 1)))
+ (let* ((sndsq (mult snd snd))
+ (avgsq (snd-avg sndsq NUMBER NUMBER op-average)))
+ (lin-to-db (peak (snd-sqrt avgsq) 1)))))
+
+
+;;; DC off-set mono
+(defun dc-off-mon (sig len)
+ (let* ((total 0)
+ (sig (snd-copy sig))
+ (ln (truncate len)))
+ (dotimes (num ln)
+ (setq total (+ total (snd-fetch sig))))
+ (/ total (float len))))
+
+
+;;; DC offset (mono/stereo)
+(defun dc-off (sig)
+ (if (arrayp sig)
+ (let ((lin0 (dc-off-mon (aref sig 0) NUMBER))
+ (lin1 (dc-off-mon (aref sig 1) NUMBER)))
+ (list lin0 (lin-to-db (abs lin0)) lin1 (lin-to-db (abs lin1))))
+ (let ((lin (dc-off-mon sig NUMBER)))
+ (list lin (lin-to-db (abs lin))))))
+
+
+;;; Platform independent representation of negative infinity
+(defun lin-to-db (val)
+ (if (= val 0)
+ ;i18n-hint abbreviates negative infinity
+ (_ "[-inf]")
+ (linear-to-db val)))
+
+
+;;; Get sample and convert to dB if required
+(defun snd-get (snd &optional (dB 0))
+ (if (= dB 0) ; dB scale
+ (lin-to-db (abs (snd-fetch snd)))
+ (snd-fetch snd))) ; linear scale
+
+
+;; FILEFORMAT 0=Text List, 1=Sample count index, 2=Time index, 3=CSV,
+;; (4=html but not used here).
+;; Optional 'same' [line] argument is either 'true' or 'nil'
+(defun formatprint (val snd &optional same)
+ (case FILEFORMAT
+ (0 (format fp "~a~a" ; plain list
+ (snd-get snd UNITS)
+ (if same "\t" "\n")))
+ (1 (format fp "~a\t~a~a" ; count index
+ val
+ (snd-get snd UNITS)
+ (if same "\t" "\n")))
+ (2 (format fp "~a\t~a~a" ; time index
+ (/ (1- val) *sound-srate*)
+ (snd-get snd UNITS)
+ (if same "\t" "\n")))
+ (3 (format fp "~a~a" ; csv
+ (snd-get snd UNITS)
+ (if (or (= CHANNEL-LAYOUT 2) same) "," "\n")))))
+
+
+;;; Print sample data to file
+(defun print-text (sig)
+ (do ((n 1 (1+ n)))
+ ((> n NUMBER))
+ (if (arrayp sig) ; Stereo (alternate lines)
+ (progn
+ ;; option to prefix alternate lines with L/R
+ (when LR-PREFIX
+ (unless (or (= HEADER 0)(= FILEFORMAT 3))
+ (format fp "~a" (first LR-PREFIX))))
+ (if (= CHANNEL-LAYOUT 0) ; IF 'Same Line' then "True"
+ (formatprint n (aref sig 0) T)
+ (formatprint n (aref sig 0)))
+ (when LR-PREFIX
+ (unless (or (= HEADER 0)(= FILEFORMAT 3))
+ (format fp "~a" (second LR-PREFIX))))
+ (formatprint n (aref sig 1)))
+ (formatprint n sig))))
+
+
+;; Print to file
+(defun printdata ()
+ (case HEADER
+ (0 (format t (normhead))(format fp (nohead)))
+ (1 (format t (normhead))(format fp (minhead)))
+ (2 (format t (normhead))(format fp (normhead)))
+ (3 (format t (normhead))(format fp (fullhead))))
+ (if (and (arrayp *track*)(= CHANNEL-LAYOUT 2))
+ ;; Stereo and left channel first
+ (progn
+ (unless (= HEADER 0) ; Don't print 'channel' if no header
+ (format fp (_ "Left Channel.~%~%")))
+ (print-text (aref *track* 0))
+ (if (= HEADER 0) ; Don't print 'channel' if no header
+ (format fp "~%")
+ (format fp (_ "~%~%Right Channel.~%~%")))
+ (print-text (aref *track* 1)))
+ ;; mono or alternate
+ (print-text *track*))
+ (close fp)
+ (if (= MESSAGES 0)
+ (format nil (_ "~aData written to:~%~a") (normhead) FILENAME)
+ (progn
+ (format t (_ "~aData written to:~%~a") (normhead) FILENAME)
+ "")))
+
+
+;;; Header text
+
+(defun nohead ()
+ (if (> (length OPTEXT) 0)
+ (format nil "~a~%~a~%"
+ OPTEXT
+ (get 'info 'chan-order))
+ ""))
+
+
+(defun minhead ()
+ (format nil (_ "Sample Rate: ~a Hz. Sample values on ~a scale.~%~a~%~a")
+ (get 'info 'srate) ; sample rate
+ (get 'info 'units) ; units
+ (get 'info 'chan-order) ; Channel Order
+ (if (> (length OPTEXT) 0)
+ (format nil "~a~%~%~%" OPTEXT) ; optional text
+ (format nil "~%")))) ; no optional text
+
+
+(defun normhead ()
+ (if (= FILEFORMAT 4) ; html
+ (format nil (_ "~a ~a~%~aSample Rate: ~a Hz.~%Length processed: ~a samples ~a seconds.~a")
+ FILENAME ; file name
+ (get 'info 'channels) ; mono/stereo
+ (get 'info 'chan-order) ; Channel Order
+ (get 'info 'srate) ; sample rate
+ NUMBER ; number of samples
+ (get 'info 'duration) ; duration (seconds)
+ (if (> (length OPTEXT)0)
+ (format nil "~%~a~%~%" OPTEXT) ; optional text
+ (format nil "~%~%"))) ; no optional text
+ (format nil (_ "~a ~a~%~aSample Rate: ~a Hz. Sample values on ~a scale.~%~
+ Length processed: ~a samples ~a seconds.~a")
+ FILENAME ; file name
+ (get 'info 'channels) ; mono/stereo
+ (get 'info 'chan-order) ; Channel Order
+ (get 'info 'srate) ; sample rate
+ (get 'info 'units) ; units
+ NUMBER ; number of samples
+ (get 'info 'duration) ; duration (seconds)
+ (if (> (length OPTEXT)0)
+ (format nil "~%~a~%~%" OPTEXT) ; optional text
+ (format nil "~%~%"))))) ; no optional text
+
+
+(defun fullhead ()
+ (format nil (_ "~a~%Sample Rate: ~a Hz. Sample values on ~a scale. ~a.~%~aLength processed: ~a ~
+ samples, ~a seconds.~%Peak amplitude: ~a (linear) ~a dB. Unweighted RMS: ~a dB.~%~
+ DC offset: ~a~a")
+ FILENAME ; file name
+ (get 'info 'srate) ; sample rate
+ (get 'info 'units) ; units
+ (get 'info 'channels) ; mono/stereo
+ (get 'info 'chan-order) ; Channel Order
+ NUMBER ; number of samples
+ (get 'info 'duration) ; duration (seconds)
+ (setq smax (stereomax *track*)) ; peak amplitude linear
+ (lin-to-db smax) ; peak amplitude dB
+ (srms *track*) ; rms
+ (let ((vals (dc-off *track*))) ; DC offset
+ (if (= (length vals) 2) ; mono
+ (format nil (_ "~a linear, ~a dB.")
+ (first vals) (second vals))
+ (format nil (_ "Left: ~a lin, ~a dB | Right: ~a lin, ~a dB.")
+ (first vals) (second vals) (third vals) (fourth vals))))
+ (if (> (length OPTEXT)0)
+ (format nil "~%~a~%~%~%" OPTEXT) ; optional text
+ (format nil "~%~%~%")))) ; no optional text
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; HTML Output ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun html-head () (strcat
+"<!DOCTYPE html>
+<html>
+<head>
+<meta name=\"generator\" content=
+\"Sample Data Export by Steve Daulton, (https://www.audionyq.com). Released under GPL v2.0+\">
+<meta name=\"description\" content=\"Sample Printer, Free Audacity plug-in\" />
+<meta name=\"keywords\" content=\"sample printer,Audacity,plug-ins,plugins,effects,audio,audio processing,music,analyze\" />
+<meta name=\"author\" content=\"Steve Daulton\" />
+<meta charset=\"UTF-8\">
+
+<style type=\"text/css\">
+body {
+ margin: 1em 5%;
+ background-color: #dda;
+ font-family:Arial,Helvetica,sans-serif;
+ }
+table,th,td {
+ background-color: #fff;
+ border:1px solid black;
+ text-align: center;
+}
+table {
+ width: auto;
+ border: 2px;
+ border-style:ridge;
+ border-collapse:collapse;
+}
+td {
+ text-align: right;
+ padding-right: 0.5em;
+}
+tr:hover td {
+ background-color:#fcd;
+}
+th {
+ padding: 0 0.5em;
+ background-color: #ddf;
+ border-bottom-width: 2px;
+ border-bottom-style:ridge;
+}
+h1 {
+ font-size: 1.6em;
+ color: #633;
+}
+h2 {
+ font-size: 1.4em;
+ color: #633;
+}
+h3 {
+ font-size: 1em;
+ color: #366;
+}
+h4 {
+ font-size: 1em;
+ color: #000;
+}
+ul {
+ position:relative;
+ top: -0.5em;
+ }
+#footer {
+ font-size: 0.8em;
+ position:relative;
+ top: 0.5em;
+ left: 2%;
+ }
+#footer span {
+ font-style:italic;
+ font-weight: bold;
+ color: #633;
+ }
+#footer a:link,a:visited {
+ color: #639;
+ text-decoration: none;
+ }
+#footer a:hover,a:active {
+ text-decoration: underline;
+ color: blue;
+ }
+</style>
+<title>" (_ "Sample Data Export") "</title>
+</head>
+"))
+
+
+;;; document headings
+(defun doc-head ()
+ (format nil
+(strcat "<body>
+<h1>" (_ "Sample Data Export") " - ~a</h1>
+~a
+<h4>~a. " (_ "~a samples.") " " (_ "~a seconds.") "<br></h4>
+<h3>" (_ "Audio data analysis:") "</h3>
+<ul>
+<li>" (_ "<b>Sample Rate:</b> ~a Hz.") "</li>"
+; i18n-hint: abbreviates "decibels"
+"<li>" (_ "<b>Peak Amplitude:</b> ~a (linear) ~a dB.") "</li>"
+; i18n-hint: RMS abbreviates root-mean-square, a method of averaging a signal; there also "weighted" versions of it but this isn't that
+"<li>" (_ "<b>RMS</b> (unweighted): ~a dB.") "</li>"
+; i18n-hint: DC derives from "direct current" in electronics, really means the zero frequency component of a signal
+"<li>" (_ "<b>DC Offset:</b> ~a") "</li>
+</ul>
+") ; end concatenated format string with inserted translations
+ (string-right-trim ".html" FILENAME)
+ (format nil "<h2>~a</h2>" OPTEXT) ; Optional heading
+ (get 'info 'channels) ; mono/stereo
+ NUMBER ; number of samples
+ (get 'info 'duration) ; duration (seconds)
+ (get 'info 'srate) ; sample rate
+ (setq smax (stereomax *track*)) ; peak amplitude linear
+ (lin-to-db smax) ; peak amplitude dB
+ (srms *track*) ; rms
+ (let ((vals (dc-off *track*))) ; DC offset
+ (if (= (length vals) 2) ; mono
+ (format nil (_ "~a linear, ~a dB.")
+ (first vals)(second vals))
+ (format nil (_ "Left: ~a lin, ~a dB | Right: ~a linear, ~a dB.")
+ (first vals)(second vals)(third vals)(fourth vals))))))
+
+
+;;; table headings (mono)
+(defun table-head-mono ()
+(strcat "<table title=\"" (_ "sample data") "\">
+<tr>
+<th>" (_ "Sample #") "</th>
+<th>" (_ "Seconds") "</th>
+<th>" (_ "Value (linear)") "</th>
+<th>" (_ "Value (dB)") "</th>
+</tr>"))
+
+
+;;; table headings (stereo)
+(defun table-head-stereo ()
+(strcat "<table title=\"" (_ "audio sample value analysis") "\">
+<tr>
+<th>" (_ "Sample #") "</th>
+<th>" (_ "Seconds") "</th>
+<th>" (_ "Left (linear)") "</th>
+<th>" (_ "Right (linear)") "</th>
+<th>" (_ "Left (dB)") "</th>
+<th>" (_ "Right (dB)") "</th>
+</tr>"))
+
+
+(defun html-foot ()
+ (format nil (strcat
+"</table>
+<p id=\"footer\">" (_ "Produced with <span>Sample Data Export</span> for
+<a href=\"~a\">Audacity</a> by Steve
+Daulton") " (<a href=
+\"https://audionyq.com\">audionyq.com</a>)</p>
+</body>
+</html>") "https://www.audacityteam.org/"))
+
+
+;;; html generator
+(defun make-htm (id val1 &optional val2)
+ (if val2
+ ;; stereo
+ (let ((time (/ (1- id) *sound-srate*))
+ (db1 (lin-to-db (abs val1)))
+ (db2 (lin-to-db (abs val2))))
+ (format fp
+ "<tr>~%<td>~a</td>~%<td>~a</td>~%<td>~a</td>~%<td>~a</td>~%~
+ <td>~a</td>~%<td>~a</td>~%</tr>~%"
+ id time val1 val2 db1 db2))
+ ;; mono
+ (let ((time (/ (1- id) *sound-srate*))
+ (db (lin-to-db (abs val1))))
+ (format fp
+ "<tr>~%<td>~a</td>~%<td>~a</td>~%<td>~a</td>~%<td>~a</td>~%</tr>~%"
+ id time val1 db))))
+
+
+(defun printhtml ()
+ (format fp (html-head))
+ (format fp (doc-head))
+ (if (arrayp *track*)
+ (progn
+ (format fp (table-head-stereo))
+ (do ((i 1 (1+ i)))
+ ((> i NUMBER))
+ (make-htm i
+ (snd-fetch (aref *track* 0))
+ (snd-fetch (aref *track* 1)))))
+ (progn
+ (format fp (table-head-mono))
+ (do ((i 1 (1+ i)))
+ ((> i NUMBER))
+ (make-htm i (snd-fetch *track*)))))
+ (format fp (html-foot))
+ (close fp)
+ (if (= MESSAGES 0)
+ (format nil (_ "~aData written to:~%~a") (normhead) FILENAME)
+ (progn
+ (format t (_ "~aData written to:~%~a") (normhead) FILENAME)
+ "")))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; END OF HTML ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;; basic info for headers
+(defun put-head-info ()
+ (putprop 'info (truncate *sound-srate*) 'srate)
+ (putprop 'info (if (= UNITS 0) (_ "dB") (_ "linear")) 'units)
+ (putprop 'info (/ NUMBER *sound-srate*) 'duration)
+ (putprop 'info
+ (if (arrayp *track*)
+ (_ "2 channels (stereo)") (_ "1 channel (mono)"))
+ 'channels)
+ ;; stereo sample order
+ (putprop 'info
+ (cond
+ ((and (= FILEFORMAT 3)(= CHANNEL-LAYOUT 0)) ; csv, channel in column
+ (format nil (_ "One column per channel.~%")))
+ ((and (= FILEFORMAT 3)(= CHANNEL-LAYOUT 2)) ; csv, channel in row
+ (format nil (_ "One row per channel.~%")))
+ ((or (soundp *track*)(= FILEFORMAT 4)) ; mono sound or HTML
+ "")
+ ((= CHANNEL-LAYOUT 0) (format nil (_ "Left channel then Right channel on same line.~%")))
+ ((= CHANNEL-LAYOUT 1) (format nil (_ "Left and right channels on alternate lines.~%")))
+ ((= CHANNEL-LAYOUT 2) (format nil (_ "Left channel first then right channel.~%")))
+ (T (_ "Unspecified channel order")))
+ 'chan-order))
+
+
+;;; Specifying a CSV or HTML file overrides the (text only) format selection.
+(let ((file-extension (get-extension FILENAME)))
+ (cond
+ ((string-equal file-extension "csv")
+ (setf FILEFORMAT 3))
+ ((string-equal file-extension "html")
+ (setf FILEFORMAT 4))
+ ((string-equal file-extension "htm")
+ (setf FILEFORMAT 4))))
+
+
+(setq fp (open FILENAME :direction :output))
+(cond
+ (fp (put-head-info)
+ (if (= FILEFORMAT 4)
+ (printhtml) ; html output
+ (printdata))) ; text output
+ (t (if (= MESSAGES 2)
+ (format t (_ "Error.~%\"~a\" cannot be written.") FILENAME)
+ (format nil (_ "Error.~%\"~a\" cannot be written.") FILENAME))))
diff --git a/Release/plug-ins/sample-data-import.ny b/Release/plug-ins/sample-data-import.ny
new file mode 100644
index 0000000000000000000000000000000000000000..beb699f327f00b5eff0f9b2ad9df468d4181aeb5
--- /dev/null
+++ b/Release/plug-ins/sample-data-import.ny
@@ -0,0 +1,107 @@
+$nyquist plug-in
+$version 4
+$type tool generate
+$name (_ "Sample Data Import")
+$debugbutton false
+$author (_ "Steve Daulton")
+$release 3.0.4-1
+$copyright (_ "GNU General Public License v2.0 or later")
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control FILENAME (_ "Select file") file "" "*default*/sample-data.txt" (((_ "Text file") (txt TXT))
+ ((_ "All files") (""))) "open,exists"
+$control BAD-DATA (_ "Invalid data handling") choice (("ThrowError" (_ "Throw Error"))
+ ("ReadAsZero" (_ "Read as Zero"))) 0
+
+
+;; Check file can be opened
+(defun fileopensp (fname)
+ (cond
+ ((not (setf fstream (open fname)))
+ (throw 'err (format nil (_ "Error~%~
+ '~a' could not be opened.~%~
+ Check that file exists.")
+ fname)))
+ ; File opened OK, so check for normal ASCII, then close it and return 'true'
+ (t (do ((j 0 (1+ j))(b (read-byte fstream)(read-byte fstream)))
+ ((or (> j 100000)(not b)))
+ (when (> b 127)
+ (throw 'err (format nil (_ "Error:~%~
+ The file must contain only plain ASCII text.~%~
+ (Invalid byte '~a' at byte number: ~a)") b (1+ j) ))))
+ (close fstream)
+ t)))
+
+;; ':new' creates a new class 'streamreader'
+;; 'filestream' and 'channel' are its instance variables.
+;; (every object of class 'streamreader' has its own
+;; copy of these variables)
+(setq streamreader
+ (send class :new '(filestream channel)))
+
+;; Initialize class 'streamreader'
+(send streamreader :answer :isnew '(stream ch) '(
+ (setq filestream stream)
+ (setq channel ch)))
+
+;; Create ':next' method.
+;; Snd-fromobject calls this method to obtain the
+;; next sound sample until it receives 'nil'
+(send streamreader :answer :next '() '(
+ (case channel
+ (0 ;mono
+ (read-and-verify filestream))
+ (1 ;left channel
+ ;Note, we still need to verify data even if skipping it.
+ (let ((val (read-and-verify filestream)))
+ (read-and-verify filestream) ;skip right channel sample
+ val))
+ (t ;right channel
+ (read-and-verify filestream) ;skip left channel sample
+ (read-and-verify filestream)))))
+
+(defun read-and-verify (stream)
+"snd-fromobject requires float values, nil to terminate"
+ (let ((val (read stream)))
+ (cond
+ ((not val) nil) ;end of file
+ ((numberp val) (float val)) ;valid.
+ ((= BAD-DATA 0) ;invalid. Throw error and quit
+ (throw 'err (format nil (_ "Error~%~
+ Data must be numbers in plain ASCII text.~%~
+ '~a' is not a numeric value.") val)))
+ (t 0.0)))) ;invalid. Replace with zero.
+
+;; Instantiate a new sound object
+(defun make-sound-object (stream chan)
+ (send streamreader :new stream chan))
+
+(defun sound-from-file ()
+ ;; Set path. fileopenp should return 'true'
+ (if (not (fileopensp FILENAME))
+ (throw 'err (format nil (_ "Error.~%Unable to open file"))))
+ ; Note: we can't use (arrayp *track*) because
+ ; *track* is nil in generate type plug-ins.
+ (cond
+ ((= (get '*track* 'channels) 2)
+ (let ((left-snd (get-sound FILENAME 1))
+ (right-snd (get-sound FILENAME 2)))
+ (vector left-snd right-snd)))
+ (t ;; Mono track
+ (get-sound FILENAME 0))))
+
+(defun get-sound (fname chan)
+ (let* ((stream (open fname :direction :input))
+ (left (make-sound-object stream chan)))
+ (setf audio-out (snd-fromobject 0 *sound-srate* left))
+ (snd-play audio-out) ;force samples to be calculated now.
+ (close stream)
+ audio-out))
+
+(catch 'err (sound-from-file))
diff --git a/Release/plug-ins/spectral-delete.ny b/Release/plug-ins/spectral-delete.ny
new file mode 100644
index 0000000000000000000000000000000000000000..befe4af254a283c348098cdf297daf2214ed93cf
--- /dev/null
+++ b/Release/plug-ins/spectral-delete.ny
@@ -0,0 +1,136 @@
+$nyquist plug-in
+$version 4
+$type process spectral
+$name (_ "Spectral Delete")
+$author (_ "Steve Daulton")
+$release 3.0.4-1
+$copyright (_ "GNU General Public License v2.0 or later")
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+(defun sinc (x fc)
+ ;; http://www.dspguide.com/ch16/1.htm
+ ;; Note that fc is a fraction of the sample rate.
+ (if (= x 0)
+ (* 2 pi fc)
+ (/ (sin (* 2 pi fc x)) x)))
+
+(defun blackman (i M)
+ ;; Where: 0 <= i <= M
+ (+ 0.42
+ (* -0.5 (cos (/ (* 2.0 pi i) M)))
+ (* 0.08 (cos (/ (* 4 pi i) M)))))
+
+(defun calc-kernel (size fc)
+ ;; Generate windowed sinc kernel impulse
+ (when (oddp size)
+ (error "Size of sinc filter must be even"))
+ (let ((ar (make-array (1+ size)))
+ (norm 0) ;Normalization factor
+ val)
+ (do ((i 0 (1+ i))
+ (j size (1- j))
+ (x (- halfk) (1+ x)))
+ ((> i j))
+ (setf val (* (sinc x fc)(blackman i size)))
+ (setf norm (+ norm val))
+ (setf (aref ar i) val)
+ (setf (aref ar j) val))
+ ;; norm is sum of all samples, but don't count middle value twice.
+ (setf norm (- (* norm 2)(aref ar halfk)))
+ (dotimes (i size ar)
+ (setf (aref ar i)(/ (aref ar i) norm)))))
+
+(defun get-kernel (size fc type)
+ ;; type: 0 (low pass) or 1 (highpass)
+ ;; Returns filter kernel as a sound.
+ (let ((kernel (calc-kernel size fc)))
+ (when (= type 1)
+ ;; Convert kernel to high pass
+ ;; https://tomroelandts.com/articles/how-to-create-a-simple-high-pass-filter
+ (dotimes (i size kernel)
+ (setf (aref kernel i)(* -1 (aref kernel i))))
+ (incf (aref kernel halfk)))
+ (snd-from-array 0 *sound-srate* kernel)))
+
+(defun sinc-filter (sig start end impulse)
+ (extract-abs start end (convolve sig impulse)))
+
+(defmacro validate-low-hz (hz fmin fmax)
+ ;; Discard if out of valid range.
+ ;; Do NOT coerce into range if too high - if multiple tracks with
+ ;; different sample rates, that could cause very unexpected results.
+ `(if (or (not ,hz) (< ,hz fmin) (> ,hz fmax))
+ (setf ,hz nil)))
+
+(defmacro validate-high-hz (hz fmin fmax)
+ ;; Discard if too high. Coerce into range if too low.
+ `(if (or (not ,hz) (>= ,hz fmax))
+ (setf ,hz nil)
+ (setf ,hz (max ,hz fmin))))
+
+(defun dofilter (cf bw type)
+ ;; type: 0 (low pass) or 1 (highpass)
+ ;; Calculate kernel length (must be even)
+ ;; http://www.dspguide.com/ch16/2.htm
+ (setf klength (/ 4.0 bw))
+ (setf halfk (round (/ klength 2)))
+ (setf klength (* 2 halfk))
+ (let ((imp (get-kernel klength cf type))
+ (start (/ halfk *sound-srate*))
+ (dur (get-duration 1)))
+ (multichan-expand #'sinc-filter *track* start (+ start dur) imp)))
+
+(defun bandwidth (hz)
+ ;; Set bandwidth ratio of each filter as 1% of filter frequency.
+ (* hz 0.01))
+
+(defun bw-ratio (hz)
+ ;; Bandwidth ratio is required as a fraction of the sampling rate
+ (/ (bandwidth hz) *sound-srate*))
+
+(defun filter ()
+ (when (< *sound-srate* 100)
+ (throw 'err (_ "Error.~%Track sample rate below 100 Hz is not supported.")))
+ (let* ((f0 (get '*selection* 'low-hz))
+ (f1 (get '*selection* 'high-hz))
+ (fc (get '*selection* 'center-hz))
+ ; If frequency too low, filter length is too large.
+ (fmin (* 0.002 *sound-srate*))
+ (fmax (* 0.498 *sound-srate*))
+ (tn (truncate len))
+ (transition (truncate (* 0.01 *sound-srate*))) ; 10 ms
+ (t1 (min transition (/ tn 2))) ; fade in length (samples)
+ (t2 (max (- tn transition) (/ tn 2))) ; length before fade out (samples)
+ (breakpoints (list t1 1.0 t2 1.0 tn))
+ (env (snd-pwl 0.0 *sound-srate* breakpoints)))
+ (validate-low-hz f0 fmin fmax)
+ (validate-high-hz f1 fmin fmax)
+ ;; Handle very narrow selections.
+ ;; This may cause f0 or f1 to 'slightly' exceed fmin fmax.
+ (when (and f0 f1 (< (- f1 f0) (* fc 0.02)))
+ (setf f0 (* fc 0.99))
+ (setf f1 (* fc 1.01)))
+ (when f0
+ (setf lp-width (bw-ratio f0))
+ (setf f0 (/ f0 *sound-srate*)))
+ (when f1
+ (setf hp-width (bw-ratio f1))
+ (setf f1 (/ f1 *sound-srate*)))
+ ;(format t "Low: ~a High: ~a" (if f0 (* f0 *sound-srate*) nil) (if f1 (* f1 *sound-srate*) nil))
+ (if (not (or f0 f1))
+ "" ;may occur if multiple tracks with different sample rates
+ (sim
+ (mult env
+ (if f0 (dofilter f0 lp-width 0) 0))
+ (mult env
+ (if f1 (dofilter f1 hp-width 1) 0))
+ (mult (diff 1.0 env) *track*)))))
+
+
+(catch 'err (filter))
diff --git a/Release/plug-ins/tremolo.ny b/Release/plug-ins/tremolo.ny
new file mode 100644
index 0000000000000000000000000000000000000000..d0ee70e2522da8d8b974e24e0e374c8326f8f80c
--- /dev/null
+++ b/Release/plug-ins/tremolo.ny
@@ -0,0 +1,57 @@
+$nyquist plug-in
+$version 4
+$type process
+$preview linear
+$name (_ "Tremolo")
+$debugbutton disabled
+$author (_ "Steve Daulton")
+$release 2.4.0
+$copyright (_ "GNU General Public License v2.0 or later")
+
+;; tremolo.ny by Steve Daulton (www.easyspacepro.com) July 2012.
+;; Based on Tremolo by Dominic Mazzoni and David R. Sky."
+
+;; License: GPL v2+
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control WAVE (_ "Waveform type") choice ((_ "Sine")
+ (_ "Triangle" "waveform")
+ (_ "Sawtooth")
+ ("InverseSawtooth" (_ "Inverse Sawtooth"))
+ (_ "Square")) 0
+
+$control PHASE (_ "Starting phase (degrees)") int "" 0 -180 180
+$control WET (_ "Wet level (percent)") int "" 40 1 100
+$control LFO (_ "Frequency (Hz)") float-text "" 4 0.001 1000
+
+
+; set tremolo waveform
+(setf waveform
+ (abs-env
+ (case WAVE
+ (0 *sine-table*)
+ (1 *tri-table*)
+ ; sawtooth
+ (2 (maketable (pwlv -1 0.995 1 1 -1)))
+ ; inverse sawtooth
+ (3 (maketable (pwlv -1 0.005 1 1 -1)))
+ ; square
+ (4 (maketable (pwlv -1 0.005 1 0.5 1 0.505 -1 1 -1))))))
+
+
+;;; Generate modulation wave
+(defun mod-wave (level)
+ ; *sine-table* is 90 degrees rotated compared to other tables.
+ (if (= WAVE 0)
+ (setf phase-shift (- PHASE 90))
+ (setf phase-shift PHASE))
+ (sum (- 1 level)
+ (mult level
+ (osc (hz-to-step LFO) 1.0 waveform phase-shift))))
+
+
+(mult *track* (mod-wave (/ WET 200.0)))
diff --git a/Release/plug-ins/vocoder.ny b/Release/plug-ins/vocoder.ny
new file mode 100644
index 0000000000000000000000000000000000000000..6dac03651c05b923499b39b0f512b05efde9d5dd
--- /dev/null
+++ b/Release/plug-ins/vocoder.ny
@@ -0,0 +1,117 @@
+$nyquist plug-in
+$version 4
+$type process
+$preview enabled
+$name (_ "Vocoder")
+$debugbutton false
+$author (_ "Edgar-RFT and Steve Daulton")
+$release 3.1.2-1
+$copyright (_ "GNU General Public License v2.0")
+
+
+;; If selected track is mono, the vocoder uses sine waves as the modulation
+;; carrier, mixed with noise and radar needles according to slider settings.
+;; If selected track is stereo, the right channel is used as the carrier wave.
+
+;; License: GPL v2
+;; http://www.gnu.org/licenses/old-licenses/gpl-2.0.html
+;;
+;; For information about writing and modifying Nyquist plug-ins:
+;; https://wiki.audacityteam.org/wiki/Nyquist_Plug-ins_Reference
+
+
+$control DST (_ "Distance: (1 to 120, default = 20)") float "" 20 1 120
+$control MST (_ "Output choice") choice (("BothChannels" (_ "Both Channels"))
+ ("RightOnly" (_ "Right Only"))) 0
+$control BANDS (_ "Number of vocoder bands") int "" 40 10 240
+$control TRACK-VL (_ "Amplitude of carrier wave (percent)") float "" 100 0 100
+$control NOISE-VL (_ "Amplitude of white noise (percent)") float "" 0 0 100
+$control RADAR-VL (_ "Amplitude of Radar Needles (percent)") float "" 0 0 100
+$control RADAR-F (_ "Frequency of Radar Needles (Hz)") float "" 30 1 100
+
+
+;; Return log to base 2 of x.
+(defun log2 (x)
+ (/ (log (float x)) (log 2.0)))
+
+
+;; Global constants.
+;; Scale slider values for better control.
+(setf TRACK-VOL (sqrt (/ TRACK-VL 100.0)))
+(setf NOISE-VOL (expt (/ NOISE-VL 100.0) 2.0))
+(setf RADAR-VOL (sqrt (/ RADAR-VL 100.0)))
+
+;; number of octaves from 20 Hz.
+;; Maximum number of octaves is: log2(high-hz / low-hz)
+;; "2.205" is for compatibility with older versions of vocoder effect.
+(setf OCTAVES (log2 (/ (/ *sound-srate* 2.205) 20)))
+
+;; interval - number of semitones per vocoder band
+(setf INTERVAL (/ (* OCTAVES 12.0) BANDS))
+
+
+(defun make-radar-table (hz)
+ (let ((one (/ *sound-srate*)) ;one sample period
+ radar-table)
+ (setf radar-table
+ (stretch-abs 1 (sim (snd-const 1 one *sound-srate* one)
+ (s-rest (/ 1.0 hz)))))
+ (list radar-table (hz-to-step hz) T)))
+
+
+;;; The Mixer
+(defun mix-noise (sig)
+ (sum (cond ((= TRACK-VOL 0) 0)
+ ((< TRACK-VOL 1) (mult TRACK-VOL sig))
+ (t sig))
+ (if (> RADAR-VL 0)
+ (let ((r-table (make-radar-table RADAR-F)))
+ (mult RADAR-VOL
+ (osc (hz-to-step RADAR-F) 1 r-table)))
+ 0)
+ (if (> NOISE-VL 0)
+ (mult NOISE-VOL (noise 1))
+ 0)))
+
+
+;; Raise 'hz' by 'INTERVAL' semitones.
+(defmacro next-hz (hz INTERVAL)
+ `(let* ((prev-step (hz-to-step ,hz))
+ (next-step (+ prev-step ,INTERVAL)))
+ (step-to-hz next-step)))
+
+
+(defmacro sumto (x y)
+ `(setf ,x (sum ,x ,y)))
+
+
+;;; Stereo Vocoder - returns mono sound.
+(defun vocoder (sig is-mono-track)
+ (let (mod-envelope
+ band
+ (result 0))
+ (do ((i 0 (1+ i))
+ (q (/ (sqrt 2.0) (/ OCTAVES BANDS))) ; quick approximation of q
+ (f (next-hz 20 (/ INTERVAL 2.0))
+ (next-hz f INTERVAL)))
+ ((= i BANDS) result)
+ (when is-mono-track
+ (sumto (aref sig 1) (mult 0.5 (/ TRACK-VOL BANDS) (hzosc f))))
+ (setf band (bandpass2 sig f q)) ; intermediate results (2 channels)
+ (setf mod-envelope (lowpass8 (s-abs (aref band 0)) (/ f DST)))
+ (sumto result (bandpass2 (mult mod-envelope (aref band 1)) f q)))))
+
+
+;;; The Program
+(if (= (+ TRACK-VOL NOISE-VOL RADAR-VOL) 0)
+ (format nil (_ "Error.~%No modulation carrier."))
+ (progn
+ (if (arrayp *track*)
+ (setf sig (vector (aref *track* 0) (mix-noise (aref *track* 1))))
+ (setf sig (vector *track* (mix-noise (s-rest 0)))))
+ (setf sig (vocoder sig (soundp *track*)))
+ ;; Normalize *track* to 0 db peak based on first 10 million samples.
+ (setf sig (scale (/ (peak sig 10000000)) sig))
+ (if (or MST (soundp *track*))
+ sig
+ (vector (aref *track* 0) sig))))