diff --git a/Release.zip b/Release.zip
new file mode 100644
index 0000000000000000000000000000000000000000..e860ec6b4e1d435368cd6eaa79fd7fd242153c0f
Binary files /dev/null and b/Release.zip differ
diff --git a/Release/EffectsMenuDefaults.xml b/Release/EffectsMenuDefaults.xml
deleted file mode 100644
index a6d55e94ce88704bea60dd5061da791559c72779..0000000000000000000000000000000000000000
--- a/Release/EffectsMenuDefaults.xml
+++ /dev/null
@@ -1,98 +0,0 @@
-<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
deleted file mode 100644
index 970a3108a5d3c06060accf665d4c44bece03cfa4..0000000000000000000000000000000000000000
Binary files a/Release/Languages/af/audacity.mo and /dev/null differ
diff --git a/Release/Languages/ar/audacity.mo b/Release/Languages/ar/audacity.mo
deleted file mode 100644
index 145839f308bab09a821b4e99e7c6bad77f749f77..0000000000000000000000000000000000000000
Binary files a/Release/Languages/ar/audacity.mo and /dev/null differ
diff --git a/Release/Languages/be/audacity.mo b/Release/Languages/be/audacity.mo
deleted file mode 100644
index 1bdba3c3c531919df9817fb767f89704f70cb179..0000000000000000000000000000000000000000
Binary files a/Release/Languages/be/audacity.mo and /dev/null differ
diff --git a/Release/Languages/bg/audacity.mo b/Release/Languages/bg/audacity.mo
deleted file mode 100644
index c75306e8041b0038954068efafd17061dab8b193..0000000000000000000000000000000000000000
Binary files a/Release/Languages/bg/audacity.mo and /dev/null differ
diff --git a/Release/Languages/bn/audacity.mo b/Release/Languages/bn/audacity.mo
deleted file mode 100644
index 10302253e6120235c115e80167e71eb6c51c6d33..0000000000000000000000000000000000000000
Binary files a/Release/Languages/bn/audacity.mo and /dev/null differ
diff --git a/Release/Languages/bs/audacity.mo b/Release/Languages/bs/audacity.mo
deleted file mode 100644
index d160e5bc7992afb503d05a2b043023a0a90c704e..0000000000000000000000000000000000000000
Binary files a/Release/Languages/bs/audacity.mo and /dev/null differ
diff --git a/Release/Languages/ca/audacity.mo b/Release/Languages/ca/audacity.mo
deleted file mode 100644
index fd622b2409055711355f5eddf84a474e402a31b4..0000000000000000000000000000000000000000
Binary files a/Release/Languages/ca/audacity.mo and /dev/null differ
diff --git a/Release/Languages/ca_ES@valencia/audacity.mo b/Release/Languages/ca_ES@valencia/audacity.mo
deleted file mode 100644
index d92359b54c6cb1e972ec36ec98010fa9b7dd60e8..0000000000000000000000000000000000000000
Binary files a/Release/Languages/ca_ES@valencia/audacity.mo and /dev/null differ
diff --git a/Release/Languages/co/audacity.mo b/Release/Languages/co/audacity.mo
deleted file mode 100644
index bb7e30a6a55c6fb4d2026d814b7f140385109069..0000000000000000000000000000000000000000
Binary files a/Release/Languages/co/audacity.mo and /dev/null differ
diff --git a/Release/Languages/cs/audacity.mo b/Release/Languages/cs/audacity.mo
deleted file mode 100644
index 05f3b60ae4abf0665b9219406f78484a3d5ce9d4..0000000000000000000000000000000000000000
Binary files a/Release/Languages/cs/audacity.mo and /dev/null differ
diff --git a/Release/Languages/cy/audacity.mo b/Release/Languages/cy/audacity.mo
deleted file mode 100644
index d0ad28dd94039c1f4d176cabc939c5e5355f2154..0000000000000000000000000000000000000000
Binary files a/Release/Languages/cy/audacity.mo and /dev/null differ
diff --git a/Release/Languages/da/audacity.mo b/Release/Languages/da/audacity.mo
deleted file mode 100644
index 3a88d48622acd6df000b0bc5564c83e535bba131..0000000000000000000000000000000000000000
Binary files a/Release/Languages/da/audacity.mo and /dev/null differ
diff --git a/Release/Languages/de/audacity.mo b/Release/Languages/de/audacity.mo
deleted file mode 100644
index e2bf17fd1fe76bf33205afb32bbad28451861935..0000000000000000000000000000000000000000
Binary files a/Release/Languages/de/audacity.mo and /dev/null differ
diff --git a/Release/Languages/el/audacity.mo b/Release/Languages/el/audacity.mo
deleted file mode 100644
index b5417eefacc193dfb17025964d9e865068309c15..0000000000000000000000000000000000000000
Binary files a/Release/Languages/el/audacity.mo and /dev/null differ
diff --git a/Release/Languages/es/audacity.mo b/Release/Languages/es/audacity.mo
deleted file mode 100644
index 0b62b6b64e31c1a8050acb06f9afd117dfd6b206..0000000000000000000000000000000000000000
Binary files a/Release/Languages/es/audacity.mo and /dev/null differ
diff --git a/Release/Languages/eu/audacity.mo b/Release/Languages/eu/audacity.mo
deleted file mode 100644
index 40d5ae1d88b3c0ebfb376ceedb56c18a68ef9871..0000000000000000000000000000000000000000
Binary files a/Release/Languages/eu/audacity.mo and /dev/null differ
diff --git a/Release/Languages/eu_ES/audacity.mo b/Release/Languages/eu_ES/audacity.mo
deleted file mode 100644
index 473499ac3348f6e7c1e71e6dfd470845a8231782..0000000000000000000000000000000000000000
Binary files a/Release/Languages/eu_ES/audacity.mo and /dev/null differ
diff --git a/Release/Languages/fa/audacity.mo b/Release/Languages/fa/audacity.mo
deleted file mode 100644
index 4bcabb9d5026e8e341c9c7b2f9bbac834a1c3736..0000000000000000000000000000000000000000
Binary files a/Release/Languages/fa/audacity.mo and /dev/null differ
diff --git a/Release/Languages/fi/audacity.mo b/Release/Languages/fi/audacity.mo
deleted file mode 100644
index b3b2eee00e682f941a53a282f439facc6740208f..0000000000000000000000000000000000000000
Binary files a/Release/Languages/fi/audacity.mo and /dev/null differ
diff --git a/Release/Languages/fr/audacity.mo b/Release/Languages/fr/audacity.mo
deleted file mode 100644
index 8621984b56ce0ef75a4b10674aa88c0ed77b539b..0000000000000000000000000000000000000000
Binary files a/Release/Languages/fr/audacity.mo and /dev/null differ
diff --git a/Release/Languages/ga/audacity.mo b/Release/Languages/ga/audacity.mo
deleted file mode 100644
index 6c18dbd40550ccdd8011e66679a96ba76c2bf4fc..0000000000000000000000000000000000000000
Binary files a/Release/Languages/ga/audacity.mo and /dev/null differ
diff --git a/Release/Languages/gl/audacity.mo b/Release/Languages/gl/audacity.mo
deleted file mode 100644
index 0fbf0e0655d66532742295688eb1e5093da37431..0000000000000000000000000000000000000000
Binary files a/Release/Languages/gl/audacity.mo and /dev/null differ
diff --git a/Release/Languages/he/audacity.mo b/Release/Languages/he/audacity.mo
deleted file mode 100644
index a5bf9570a24ac12d7ec4f0fbe0cf95bbd900474b..0000000000000000000000000000000000000000
Binary files a/Release/Languages/he/audacity.mo and /dev/null differ
diff --git a/Release/Languages/hi/audacity.mo b/Release/Languages/hi/audacity.mo
deleted file mode 100644
index f3b2e08e3ba1ceac7dffeec06e77bce5bca6ae54..0000000000000000000000000000000000000000
Binary files a/Release/Languages/hi/audacity.mo and /dev/null differ
diff --git a/Release/Languages/hr/audacity.mo b/Release/Languages/hr/audacity.mo
deleted file mode 100644
index 316678e61d8d8371c372141f9d6f2d3e72e3efcd..0000000000000000000000000000000000000000
Binary files a/Release/Languages/hr/audacity.mo and /dev/null differ
diff --git a/Release/Languages/hu/audacity.mo b/Release/Languages/hu/audacity.mo
deleted file mode 100644
index 005db52746e3cbfc75aa690de671b864ecd0e8fa..0000000000000000000000000000000000000000
Binary files a/Release/Languages/hu/audacity.mo and /dev/null differ
diff --git a/Release/Languages/hy/audacity.mo b/Release/Languages/hy/audacity.mo
deleted file mode 100644
index fe91b5386d5db6e80d66af432a93681a2b30c54e..0000000000000000000000000000000000000000
Binary files a/Release/Languages/hy/audacity.mo and /dev/null differ
diff --git a/Release/Languages/id/audacity.mo b/Release/Languages/id/audacity.mo
deleted file mode 100644
index 49daf2b5ac1f12a6044ad580efc8ae91c1944b4f..0000000000000000000000000000000000000000
Binary files a/Release/Languages/id/audacity.mo and /dev/null differ
diff --git a/Release/Languages/it/audacity.mo b/Release/Languages/it/audacity.mo
deleted file mode 100644
index 4a53e043bf5b363f9cfe991cd47b8ce544617496..0000000000000000000000000000000000000000
Binary files a/Release/Languages/it/audacity.mo and /dev/null differ
diff --git a/Release/Languages/ja/audacity.mo b/Release/Languages/ja/audacity.mo
deleted file mode 100644
index c7d338e96a93e35482ac9d3368e072173f4b6ecc..0000000000000000000000000000000000000000
Binary files a/Release/Languages/ja/audacity.mo and /dev/null differ
diff --git a/Release/Languages/ka/audacity.mo b/Release/Languages/ka/audacity.mo
deleted file mode 100644
index 31cc3243c6ac79c856628862c1ce460340e761a5..0000000000000000000000000000000000000000
Binary files a/Release/Languages/ka/audacity.mo and /dev/null differ
diff --git a/Release/Languages/km/audacity.mo b/Release/Languages/km/audacity.mo
deleted file mode 100644
index c178d483a6f80dc9ca9c5307761a4899c89c33d2..0000000000000000000000000000000000000000
Binary files a/Release/Languages/km/audacity.mo and /dev/null differ
diff --git a/Release/Languages/ko/audacity.mo b/Release/Languages/ko/audacity.mo
deleted file mode 100644
index 0391d3dfb07a45814005d20666812008111f7829..0000000000000000000000000000000000000000
Binary files a/Release/Languages/ko/audacity.mo and /dev/null differ
diff --git a/Release/Languages/lt/audacity.mo b/Release/Languages/lt/audacity.mo
deleted file mode 100644
index 6fdfbe025623b17d0a08f8c8ecaaaf6274cd820f..0000000000000000000000000000000000000000
Binary files a/Release/Languages/lt/audacity.mo and /dev/null differ
diff --git a/Release/Languages/mk/audacity.mo b/Release/Languages/mk/audacity.mo
deleted file mode 100644
index 2f9d3cfdf1b71585ec0a076ac3d33a2aeb087daa..0000000000000000000000000000000000000000
Binary files a/Release/Languages/mk/audacity.mo and /dev/null differ
diff --git a/Release/Languages/mr/audacity.mo b/Release/Languages/mr/audacity.mo
deleted file mode 100644
index 931fdb275ce88bc9506645b347ffc3601b444bf7..0000000000000000000000000000000000000000
Binary files a/Release/Languages/mr/audacity.mo and /dev/null differ
diff --git a/Release/Languages/my/audacity.mo b/Release/Languages/my/audacity.mo
deleted file mode 100644
index 5226392ed5da27b5f7c836bb6f56a27e95e024eb..0000000000000000000000000000000000000000
Binary files a/Release/Languages/my/audacity.mo and /dev/null differ
diff --git a/Release/Languages/nb/audacity.mo b/Release/Languages/nb/audacity.mo
deleted file mode 100644
index db3c3c18ba1a4e2a749e7a0de27d806f068a030f..0000000000000000000000000000000000000000
Binary files a/Release/Languages/nb/audacity.mo and /dev/null differ
diff --git a/Release/Languages/nl/audacity.mo b/Release/Languages/nl/audacity.mo
deleted file mode 100644
index 3e83e1d73e52f322900a698977367171502850c5..0000000000000000000000000000000000000000
Binary files a/Release/Languages/nl/audacity.mo and /dev/null differ
diff --git a/Release/Languages/oc/audacity.mo b/Release/Languages/oc/audacity.mo
deleted file mode 100644
index a90bc1eb7f99b6badec05e133bfc0d7e0ad8466e..0000000000000000000000000000000000000000
Binary files a/Release/Languages/oc/audacity.mo and /dev/null differ
diff --git a/Release/Languages/pl/audacity.mo b/Release/Languages/pl/audacity.mo
deleted file mode 100644
index 95203ebbf1d7af0fc25a33855d3d55f93d69d340..0000000000000000000000000000000000000000
Binary files a/Release/Languages/pl/audacity.mo and /dev/null differ
diff --git a/Release/Languages/pt_BR/audacity.mo b/Release/Languages/pt_BR/audacity.mo
deleted file mode 100644
index 00d56a97e46d5226ae9fa3565afa04f635dd5cb8..0000000000000000000000000000000000000000
Binary files a/Release/Languages/pt_BR/audacity.mo and /dev/null differ
diff --git a/Release/Languages/pt_PT/audacity.mo b/Release/Languages/pt_PT/audacity.mo
deleted file mode 100644
index 87cd0b56e1733fbc2c25bd8273a9a3fb228811af..0000000000000000000000000000000000000000
Binary files a/Release/Languages/pt_PT/audacity.mo and /dev/null differ
diff --git a/Release/Languages/ro/audacity.mo b/Release/Languages/ro/audacity.mo
deleted file mode 100644
index bcdd446eeea043b75af8e0624e270d833eb4e59f..0000000000000000000000000000000000000000
Binary files a/Release/Languages/ro/audacity.mo and /dev/null differ
diff --git a/Release/Languages/ru/audacity.mo b/Release/Languages/ru/audacity.mo
deleted file mode 100644
index d59648b9dfaa5217b50e4ae468e477f09b95c51f..0000000000000000000000000000000000000000
Binary files a/Release/Languages/ru/audacity.mo and /dev/null differ
diff --git a/Release/Languages/sk/audacity.mo b/Release/Languages/sk/audacity.mo
deleted file mode 100644
index 6c7ba98fd1925616177bb65647b53453555519b4..0000000000000000000000000000000000000000
Binary files a/Release/Languages/sk/audacity.mo and /dev/null differ
diff --git a/Release/Languages/sl/audacity.mo b/Release/Languages/sl/audacity.mo
deleted file mode 100644
index eb01b59051512703f5c8c1798c49e7b03653bd75..0000000000000000000000000000000000000000
Binary files a/Release/Languages/sl/audacity.mo and /dev/null differ
diff --git a/Release/Languages/sr_RS/audacity.mo b/Release/Languages/sr_RS/audacity.mo
deleted file mode 100644
index be8e9fae57149e61f99f8c597e6e046e5841aa0d..0000000000000000000000000000000000000000
Binary files a/Release/Languages/sr_RS/audacity.mo and /dev/null differ
diff --git a/Release/Languages/sr_RS@latin/audacity.mo b/Release/Languages/sr_RS@latin/audacity.mo
deleted file mode 100644
index c030cc81c6f1776970921d73d70c5ef0fe47fa1d..0000000000000000000000000000000000000000
Binary files a/Release/Languages/sr_RS@latin/audacity.mo and /dev/null differ
diff --git a/Release/Languages/sv/audacity.mo b/Release/Languages/sv/audacity.mo
deleted file mode 100644
index 77085ad35ad2dcd886f611079ba9669274ffd1c1..0000000000000000000000000000000000000000
Binary files a/Release/Languages/sv/audacity.mo and /dev/null differ
diff --git a/Release/Languages/ta/audacity.mo b/Release/Languages/ta/audacity.mo
deleted file mode 100644
index c1b4ab02d8c428ad1a870e517fa778296f632edc..0000000000000000000000000000000000000000
Binary files a/Release/Languages/ta/audacity.mo and /dev/null differ
diff --git a/Release/Languages/tg/audacity.mo b/Release/Languages/tg/audacity.mo
deleted file mode 100644
index 8badb1cad64b05d562e4a7e9f4dee9192cc247ef..0000000000000000000000000000000000000000
Binary files a/Release/Languages/tg/audacity.mo and /dev/null differ
diff --git a/Release/Languages/tr/audacity.mo b/Release/Languages/tr/audacity.mo
deleted file mode 100644
index ed416dc2ec7f8d1620773da5ae1e4bc560d887a1..0000000000000000000000000000000000000000
Binary files a/Release/Languages/tr/audacity.mo and /dev/null differ
diff --git a/Release/Languages/uk/audacity.mo b/Release/Languages/uk/audacity.mo
deleted file mode 100644
index 278ebe41918685d8be5e15816e6a185538ee23c3..0000000000000000000000000000000000000000
Binary files a/Release/Languages/uk/audacity.mo and /dev/null differ
diff --git a/Release/Languages/vi/audacity.mo b/Release/Languages/vi/audacity.mo
deleted file mode 100644
index c34aba21c9245d9d4a91fea032992e8853d92d48..0000000000000000000000000000000000000000
Binary files a/Release/Languages/vi/audacity.mo and /dev/null differ
diff --git a/Release/Languages/zh_CN/audacity.mo b/Release/Languages/zh_CN/audacity.mo
deleted file mode 100644
index 42b2bba6c973650f95ba433e3970ee71709cfc24..0000000000000000000000000000000000000000
Binary files a/Release/Languages/zh_CN/audacity.mo and /dev/null differ
diff --git a/Release/Languages/zh_TW/audacity.mo b/Release/Languages/zh_TW/audacity.mo
deleted file mode 100644
index 953ec249a1a179e1d5d59fdb604fb0bb5071234f..0000000000000000000000000000000000000000
Binary files a/Release/Languages/zh_TW/audacity.mo and /dev/null differ
diff --git a/Release/nyquist/aud-do-support.lsp b/Release/nyquist/aud-do-support.lsp
deleted file mode 100644
index 23981f5796a210f89ffd49a30fd9b7a6f6f5c79a..0000000000000000000000000000000000000000
--- a/Release/nyquist/aud-do-support.lsp
+++ /dev/null
@@ -1,236 +0,0 @@
-;;; 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
deleted file mode 100644
index 2085556acfee43c961dd63431fa3b49c763796bc..0000000000000000000000000000000000000000
--- a/Release/nyquist/dspprims.lsp
+++ /dev/null
@@ -1,728 +0,0 @@
-;; 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
deleted file mode 100644
index 18e6a6f6524e4d76aa3fadfe84a521ed6389cd24..0000000000000000000000000000000000000000
--- a/Release/nyquist/envelopes.lsp
+++ /dev/null
@@ -1,163 +0,0 @@
-;; 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
deleted file mode 100644
index 12ff4873c8623860c2e1a89ee8708c0eb776e9f4..0000000000000000000000000000000000000000
--- a/Release/nyquist/equalizer.lsp
+++ /dev/null
@@ -1,75 +0,0 @@
-;; 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
deleted file mode 100644
index da8ce76896465cd4ff3a928df4992449675ebef7..0000000000000000000000000000000000000000
--- a/Release/nyquist/evalenv.lsp
+++ /dev/null
@@ -1,36 +0,0 @@
-;;
-;; 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
deleted file mode 100644
index f09914b84743cafc765416f66058382146a827dd..0000000000000000000000000000000000000000
--- a/Release/nyquist/fileio.lsp
+++ /dev/null
@@ -1,417 +0,0 @@
-;; 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
deleted file mode 100644
index 102d0ab82fc8f3420b0aac65c3a5160212c29d36..0000000000000000000000000000000000000000
--- a/Release/nyquist/init.lsp
+++ /dev/null
@@ -1,88 +0,0 @@
-; 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
deleted file mode 100644
index c81726ca80c009373b40f2df34ff59ba540da5d8..0000000000000000000000000000000000000000
--- a/Release/nyquist/misc.lsp
+++ /dev/null
@@ -1,235 +0,0 @@
-;## 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
deleted file mode 100644
index 352844575b500bf7dd21c3cc268213467cf8bb05..0000000000000000000000000000000000000000
--- a/Release/nyquist/nyinit-dbg.lsp
+++ /dev/null
@@ -1,38 +0,0 @@
-(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
deleted file mode 100644
index 47b2cbdb5d8f54def8ab690a33e98e7171718680..0000000000000000000000000000000000000000
--- a/Release/nyquist/nyinit.lsp
+++ /dev/null
@@ -1,36 +0,0 @@
-(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
deleted file mode 100644
index 3905d33c5ade1b4b7d9039e2ab11411ad3653612..0000000000000000000000000000000000000000
--- a/Release/nyquist/nyqmisc.lsp
+++ /dev/null
@@ -1,27 +0,0 @@
-;; 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
deleted file mode 100644
index 003e6e0f457b88eba3c2a3f76a9d94865521678f..0000000000000000000000000000000000000000
--- a/Release/nyquist/nyquist-plot.txt
+++ /dev/null
@@ -1,3 +0,0 @@
-set nokey
-plot "points.dat" with lines
-
diff --git a/Release/nyquist/nyquist.lsp b/Release/nyquist/nyquist.lsp
deleted file mode 100644
index dcd30c35969a163292b93020a6754ffe0125ff99..0000000000000000000000000000000000000000
--- a/Release/nyquist/nyquist.lsp
+++ /dev/null
@@ -1,2482 +0,0 @@
-;;;
-;;; ###########################################################
-;;; ### 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
deleted file mode 100644
index 4ca17bbc9d1ccce28c0cf97b13f93ad4b8e719ef..0000000000000000000000000000000000000000
--- a/Release/nyquist/printrec.lsp
+++ /dev/null
@@ -1,30 +0,0 @@
-; 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
deleted file mode 100644
index 0f7038b61db28abede72980faf2da4b45292b1da..0000000000000000000000000000000000000000
--- a/Release/nyquist/profile.lsp
+++ /dev/null
@@ -1,27 +0,0 @@
-
-; 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
deleted file mode 100644
index bc04a0583599515565866453df6016d6d1c27694..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/mand1.raw and /dev/null differ
diff --git a/Release/nyquist/rawwaves/mand10.raw b/Release/nyquist/rawwaves/mand10.raw
deleted file mode 100644
index 4b35376aeacdfc50cbef89ea76259403ac542b69..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/mand10.raw and /dev/null differ
diff --git a/Release/nyquist/rawwaves/mand11.raw b/Release/nyquist/rawwaves/mand11.raw
deleted file mode 100644
index 94889be6f0d6dfeaa63449e06a39df1356508dac..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/mand11.raw and /dev/null differ
diff --git a/Release/nyquist/rawwaves/mand12.raw b/Release/nyquist/rawwaves/mand12.raw
deleted file mode 100644
index a128642bf6de4fdac74a1fa03bf32bc6003bb685..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/mand12.raw and /dev/null differ
diff --git a/Release/nyquist/rawwaves/mand2.raw b/Release/nyquist/rawwaves/mand2.raw
deleted file mode 100644
index 62080081d289b7dfa042b787190b99b0399fe81e..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/mand2.raw and /dev/null differ
diff --git a/Release/nyquist/rawwaves/mand3.raw b/Release/nyquist/rawwaves/mand3.raw
deleted file mode 100644
index 8857f862298c1fd4516047ce8f0daa096a08ebf4..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/mand3.raw and /dev/null differ
diff --git a/Release/nyquist/rawwaves/mand4.raw b/Release/nyquist/rawwaves/mand4.raw
deleted file mode 100644
index 6058eb10081839bb84810134acd9252f873b8bfc..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/mand4.raw and /dev/null differ
diff --git a/Release/nyquist/rawwaves/mand5.raw b/Release/nyquist/rawwaves/mand5.raw
deleted file mode 100644
index 9b308a860b4966a4bfa6148f01bdfa70fdc99495..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/mand5.raw and /dev/null differ
diff --git a/Release/nyquist/rawwaves/mand6.raw b/Release/nyquist/rawwaves/mand6.raw
deleted file mode 100644
index 05f083d8912b7622d17e058ced75e9c06d65f25d..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/mand6.raw and /dev/null differ
diff --git a/Release/nyquist/rawwaves/mand7.raw b/Release/nyquist/rawwaves/mand7.raw
deleted file mode 100644
index 64941e9f98421aa1b2b353abbfa5a25cd9942295..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/mand7.raw and /dev/null differ
diff --git a/Release/nyquist/rawwaves/mand8.raw b/Release/nyquist/rawwaves/mand8.raw
deleted file mode 100644
index 52027bf695e8053eb0511e36ac16a38a500d7973..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/mand8.raw and /dev/null differ
diff --git a/Release/nyquist/rawwaves/mand9.raw b/Release/nyquist/rawwaves/mand9.raw
deleted file mode 100644
index 9e88a0c91317db8a3f2ba7969fe7aa0e0b2e029f..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/mand9.raw and /dev/null differ
diff --git a/Release/nyquist/rawwaves/mandpluk.raw b/Release/nyquist/rawwaves/mandpluk.raw
deleted file mode 100644
index 162a0da9e1d448ee915c7b4ba441c8da46b6298a..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/mandpluk.raw and /dev/null differ
diff --git a/Release/nyquist/rawwaves/marmstk1.raw b/Release/nyquist/rawwaves/marmstk1.raw
deleted file mode 100644
index 185b4452613d748bf21d19614a54cd139e7d4b40..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/marmstk1.raw and /dev/null differ
diff --git a/Release/nyquist/rawwaves/sinewave.raw b/Release/nyquist/rawwaves/sinewave.raw
deleted file mode 100644
index a5cb34991bc7de10b0f342dc72b9f295a4eff628..0000000000000000000000000000000000000000
Binary files a/Release/nyquist/rawwaves/sinewave.raw and /dev/null differ
diff --git a/Release/nyquist/sal-parse.lsp b/Release/nyquist/sal-parse.lsp
deleted file mode 100644
index 461ce057dc0792a80c0ac4efc80f1deaae3d7993..0000000000000000000000000000000000000000
--- a/Release/nyquist/sal-parse.lsp
+++ /dev/null
@@ -1,1899 +0,0 @@
-;; 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
deleted file mode 100644
index cbb451b1f268ad81a26ee0641316dcdf2f4c9689..0000000000000000000000000000000000000000
--- a/Release/nyquist/sal.lsp
+++ /dev/null
@@ -1,630 +0,0 @@
-;;; **********************************************************************
-;;; 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
deleted file mode 100644
index d360256057e98a2ae65ae008424961bdf4a3926d..0000000000000000000000000000000000000000
--- a/Release/nyquist/seq.lsp
+++ /dev/null
@@ -1,336 +0,0 @@
-;; 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
deleted file mode 100644
index 1f7b01bdee33ce33626bb32cf72c5bab583ab3fc..0000000000000000000000000000000000000000
--- a/Release/nyquist/seqfnint.lsp
+++ /dev/null
@@ -1,31 +0,0 @@
-
- (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
deleted file mode 100644
index bea71145daf1dd229d0f630ad727a2786fe76f1a..0000000000000000000000000000000000000000
--- a/Release/nyquist/seqmidi.lsp
+++ /dev/null
@@ -1,171 +0,0 @@
-;; 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
deleted file mode 100644
index 292e87c6e1a07457fc25e3e7bee61312317cc765..0000000000000000000000000000000000000000
--- a/Release/nyquist/sliders.lsp
+++ /dev/null
@@ -1,196 +0,0 @@
-;; 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
deleted file mode 100644
index 015191b241c368069aaee644c3f52acb095f5672..0000000000000000000000000000000000000000
--- a/Release/nyquist/sndfnint.lsp
+++ /dev/null
@@ -1,92 +0,0 @@
- (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
deleted file mode 100644
index a7651fbbb9da77bb5e5fce9aedd93278cf118ab5..0000000000000000000000000000000000000000
--- a/Release/nyquist/spec-plot.lsp
+++ /dev/null
@@ -1,47 +0,0 @@
-;; 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
deleted file mode 100644
index 38ff748a0bcd0099c1b8dd753d56cf06884a15c3..0000000000000000000000000000000000000000
--- a/Release/nyquist/spectral-analysis.lsp
+++ /dev/null
@@ -1,289 +0,0 @@
-;; 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
deleted file mode 100644
index 3eae1390851ba037c5ecbe8d6111dd9ee308ff34..0000000000000000000000000000000000000000
--- a/Release/nyquist/stk.lsp
+++ /dev/null
@@ -1,200 +0,0 @@
-;; 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
deleted file mode 100644
index b750fe66693d86af2fe6d49e2423aad2fcefde25..0000000000000000000000000000000000000000
--- a/Release/nyquist/system.lsp
+++ /dev/null
@@ -1,131 +0,0 @@
-; 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
deleted file mode 100644
index 3bacbc62aba7d5128fddc510c084cf2670472632..0000000000000000000000000000000000000000
--- a/Release/nyquist/test.lsp
+++ /dev/null
@@ -1,43 +0,0 @@
-
-(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
deleted file mode 100644
index aa5226d638d2d92f8a45f7ab595e3e56fce9c5b5..0000000000000000000000000000000000000000
--- a/Release/nyquist/velocity.lsp
+++ /dev/null
@@ -1,24 +0,0 @@
-;; 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
deleted file mode 100644
index ae2cfda222d686d1ab6c9af64924d69fae5e883d..0000000000000000000000000000000000000000
--- a/Release/nyquist/xlinit.lsp
+++ /dev/null
@@ -1,67 +0,0 @@
-;; 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
deleted file mode 100644
index 75bdea2c1bed61087aaa3159f65e3a63be9cf60b..0000000000000000000000000000000000000000
--- a/Release/nyquist/xm.lsp
+++ /dev/null
@@ -1,2767 +0,0 @@
-;; 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
deleted file mode 100644
index 0fa4e95be501f9a1a76097d182839b93baec1445..0000000000000000000000000000000000000000
--- a/Release/plug-ins/ShelfFilter.ny
+++ /dev/null
@@ -1,34 +0,0 @@
-$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
deleted file mode 100644
index 6e62a6897a0f74664b8edfbb21c184a428d2afb0..0000000000000000000000000000000000000000
--- a/Release/plug-ins/SpectralEditMulti.ny
+++ /dev/null
@@ -1,70 +0,0 @@
-$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
deleted file mode 100644
index 8f78788ad1defd0731d70d17a157616b59077216..0000000000000000000000000000000000000000
--- a/Release/plug-ins/SpectralEditParametricEQ.ny
+++ /dev/null
@@ -1,70 +0,0 @@
-$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
deleted file mode 100644
index 9a3135f90ab0201856f8efa83e9569e44672638f..0000000000000000000000000000000000000000
--- a/Release/plug-ins/SpectralEditShelves.ny
+++ /dev/null
@@ -1,77 +0,0 @@
-$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
deleted file mode 100644
index b4812d9b8e36e3c6ab1a04993fd463d1c30efa8d..0000000000000000000000000000000000000000
--- a/Release/plug-ins/StudioFadeOut.ny
+++ /dev/null
@@ -1,43 +0,0 @@
-$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
deleted file mode 100644
index 4ee7bbe355c8c883f5034393fdbe684f14c23412..0000000000000000000000000000000000000000
--- a/Release/plug-ins/adjustable-fade.ny
+++ /dev/null
@@ -1,211 +0,0 @@
-$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
deleted file mode 100644
index 208f7134722131bd7129829211f1c5ec0f5cfe66..0000000000000000000000000000000000000000
--- a/Release/plug-ins/beat.ny
+++ /dev/null
@@ -1,43 +0,0 @@
-$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
deleted file mode 100644
index d2edf3b8a4709936ae81d31fe874e4096387fdc0..0000000000000000000000000000000000000000
--- a/Release/plug-ins/clipfix.ny
+++ /dev/null
@@ -1,108 +0,0 @@
-$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
deleted file mode 100644
index e8bbe8ccaf839469dd25f6b9d93945ff8ba96290..0000000000000000000000000000000000000000
--- a/Release/plug-ins/crossfadeclips.ny
+++ /dev/null
@@ -1,132 +0,0 @@
-$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
deleted file mode 100644
index 8ca26be32f1636b066f50277d5612220bbdb11f1..0000000000000000000000000000000000000000
--- a/Release/plug-ins/crossfadetracks.ny
+++ /dev/null
@@ -1,85 +0,0 @@
-$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
deleted file mode 100644
index 94bda9db1c72a865d02bdb9de8e238b8cb3a8903..0000000000000000000000000000000000000000
--- a/Release/plug-ins/delay.ny
+++ /dev/null
@@ -1,139 +0,0 @@
-$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
deleted file mode 100644
index 7e98b80a27c24eee1b571032ef0267029bc13895..0000000000000000000000000000000000000000
--- a/Release/plug-ins/equalabel.ny
+++ /dev/null
@@ -1,167 +0,0 @@
-$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
deleted file mode 100644
index 466c945230736f6accd1b8bc78f8ab7b6b7de4a1..0000000000000000000000000000000000000000
--- a/Release/plug-ins/highpass.ny
+++ /dev/null
@@ -1,40 +0,0 @@
-$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
deleted file mode 100644
index d21d583b76f5166f13abcd6d0f105f1eb238954b..0000000000000000000000000000000000000000
--- a/Release/plug-ins/label-sounds.ny
+++ /dev/null
@@ -1,259 +0,0 @@
-$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
deleted file mode 100644
index 327331747aae18fe8e3f80e9fcb651a07eb87f81..0000000000000000000000000000000000000000
--- a/Release/plug-ins/limiter.ny
+++ /dev/null
@@ -1,135 +0,0 @@
-$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
deleted file mode 100644
index a2a44194176f75e8b9c9a1006c32664829600a90..0000000000000000000000000000000000000000
--- a/Release/plug-ins/lowpass.ny
+++ /dev/null
@@ -1,40 +0,0 @@
-$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
deleted file mode 100644
index 480539cb54c8091ff1bc736f324a22b911188f60..0000000000000000000000000000000000000000
--- a/Release/plug-ins/noisegate.ny
+++ /dev/null
@@ -1,174 +0,0 @@
-$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
deleted file mode 100644
index e81fd7c4c062220df18f7772af1068c771916007..0000000000000000000000000000000000000000
--- a/Release/plug-ins/notch.ny
+++ /dev/null
@@ -1,32 +0,0 @@
-$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
deleted file mode 100644
index 8a5502b90ff1ba4d9bdf4c50b33f338fa8e5b5b5..0000000000000000000000000000000000000000
--- a/Release/plug-ins/nyquist-plug-in-installer.ny
+++ /dev/null
@@ -1,257 +0,0 @@
-$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
deleted file mode 100644
index d95313c9920d1f41cd0c0f2f3f6aee0dc112feba..0000000000000000000000000000000000000000
--- a/Release/plug-ins/pluck.ny
+++ /dev/null
@@ -1,48 +0,0 @@
-$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
deleted file mode 100644
index 981188f7bd7a8cc3dfd6229f3c395173aeac0acb..0000000000000000000000000000000000000000
--- a/Release/plug-ins/rhythmtrack.ny
+++ /dev/null
@@ -1,247 +0,0 @@
-$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
deleted file mode 100644
index e6b1fe95a98050b4ca315675a6b882baad3c40b2..0000000000000000000000000000000000000000
--- a/Release/plug-ins/rissetdrum.ny
+++ /dev/null
@@ -1,82 +0,0 @@
-$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
deleted file mode 100644
index a39d61382faa1e622e7fb228f874bfc1b0ba23ea..0000000000000000000000000000000000000000
--- a/Release/plug-ins/rms.ny
+++ /dev/null
@@ -1,67 +0,0 @@
-;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
deleted file mode 100644
index 0f173b86029392d7bc1a19697451f4172016b020..0000000000000000000000000000000000000000
--- a/Release/plug-ins/sample-data-export.ny
+++ /dev/null
@@ -1,510 +0,0 @@
-$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
deleted file mode 100644
index beb699f327f00b5eff0f9b2ad9df468d4181aeb5..0000000000000000000000000000000000000000
--- a/Release/plug-ins/sample-data-import.ny
+++ /dev/null
@@ -1,107 +0,0 @@
-$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
deleted file mode 100644
index befe4af254a283c348098cdf297daf2214ed93cf..0000000000000000000000000000000000000000
--- a/Release/plug-ins/spectral-delete.ny
+++ /dev/null
@@ -1,136 +0,0 @@
-$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
deleted file mode 100644
index d0ee70e2522da8d8b974e24e0e374c8326f8f80c..0000000000000000000000000000000000000000
--- a/Release/plug-ins/tremolo.ny
+++ /dev/null
@@ -1,57 +0,0 @@
-$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
deleted file mode 100644
index 6dac03651c05b923499b39b0f512b05efde9d5dd..0000000000000000000000000000000000000000
--- a/Release/plug-ins/vocoder.ny
+++ /dev/null
@@ -1,117 +0,0 @@
-$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))))