From 586b86a77fccf91c3060432e23a15eb794ba6b4f Mon Sep 17 00:00:00 2001 From: Leland Lucius Date: Thu, 28 Jan 2021 02:13:05 -0600 Subject: [PATCH] Update Nyquist to SVN r331 --- nyquist/dspprims.lsp | 57 +++++---- nyquist/fileio.lsp | 162 +++++++++++++++++--------- nyquist/init.lsp | 83 +------------ nyquist/nyinit.lsp | 7 +- nyquist/nyquist.lsp | 156 ++++++++++++++----------- nyquist/sal-parse.lsp | 56 +++++++-- nyquist/seq.lsp | 265 +++++++++++++++++++++++------------------- nyquist/seqfnint.lsp | 30 ++--- nyquist/sndfnint.lsp | 18 +-- nyquist/system.lsp | 3 - nyquist/xlinit.lsp | 2 +- 11 files changed, 453 insertions(+), 386 deletions(-) diff --git a/nyquist/dspprims.lsp b/nyquist/dspprims.lsp index 42ad02fda..ea0ff77c5 100644 --- a/nyquist/dspprims.lsp +++ b/nyquist/dspprims.lsp @@ -202,6 +202,14 @@ (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) @@ -245,22 +253,19 @@ (defun noise-gate (snd &optional (lookahead 0.5) (risetime 0.02) (falltime 0.5) - (floor 0.01) (threshold 0.01)) - (ny:typecheck (not (soundp snd)) - (ny:error "NOISE-GATE" 1 '((SOUND) "snd") snd)) - (ny:typecheck (not (numberp lookahead)) - (ny:error "NOISE-GATE" 2 '((NUMBER) "lookahead") lookahead)) - (ny:typecheck (not (numberp risetime)) - (ny:error "NOISE-GATE" 3 '((NUMBER) "risetime") risetime)) - (ny:typecheck (not (numberp falltime)) - (ny:error "NOISE-GATE" 4 '((NUMBER) "falltime") falltime)) - (ny:typecheck (not (numberp floor)) - (ny:error "NOISE-GATE" 5 '((NUMBER) "floor") floor)) - (ny:typecheck (not (numberp threshold)) - (ny:error "NOISE-GATE" 6 '((NUMBER) "threshold") threshold)) - (let ((rms (lp (mult snd snd) (/ *control-srate* 10.0)))) - (setf threshold (* threshold threshold)) - (mult snd (gate rms floor risetime falltime lookahead threshold "NOISE-GATE")))) + (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 @@ -286,18 +291,26 @@ ;; RMS -- compute the RMS of a sound ;; -(defun rms (s &optional (rate 100.0) window-size) +(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 (soundp s)) - (ny:error "RMS" 1 number-anon s)) + (ny:typecheck (not (or (soundp s) (multichannel-soundp s))) + (ny:error source 1 '((SOUND) NIL) s t)) (ny:typecheck (not (numberp rate)) - (ny:error "RMS" 2 '((NUMBER) "rate") 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)) - (error "In RMS, 2nd argument (window-size) must be an integer" - 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 diff --git a/nyquist/fileio.lsp b/nyquist/fileio.lsp index fb2b79f03..f09914b84 100644 --- a/nyquist/fileio.lsp +++ b/nyquist/fileio.lsp @@ -34,56 +34,103 @@ ;; s-save -- saves a file (setf *in-s-save* nil) -(setf NY:ALL 1000000000) ; 1GIG constant for maxlen -(defmacro s-save (expression &optional (maxlen NY:ALL) filename - &key (format '*default-sf-format*) - (mode '*default-sf-mode*) (bits '*default-sf-bits*) - (endian NIL) ; nil, :big, or :little -- specifies file format - (play nil)) - `(let ((ny:fname ,filename) - (ny:maxlen ,maxlen) - (ny:endian ,endian) - (ny:swap 0) - max-sample) ; return value - (cond (*in-s-save* - (error "Recursive call to s-save (maybe play?) detected!"))) - (progv '(*in-s-save*) '(t) - ; allow caller to omit maxlen, in which case the filename will - ; be a string in the maxlen parameter position and filename will be null - (cond ((null ny:fname) - (cond ((stringp ny:maxlen) - (setf ny:fname ny:maxlen) - (setf ny:maxlen NY:ALL)) - (t - (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 (,play - (cond ((not (boundp '*snd-list-devices*)) - (setf *snd-list-devices* t))))) ; one-time show - (setf max-sample - (snd-save ',expression ny:maxlen ny:fname ,format - ,mode ,bits ny:swap ,play)) - ; more information if *snd-list-devices* was unbound: - (cond (,play - (cond (*snd-list-devices* - (format t "\nSet *snd-list-devices* = t\n~A\n~A\n~A\n~A\n\n" - " and call play to see device list again." - "Set *snd-device* to a fixnum to select an output device" - " or set *snd-device* to a substring of a device name" - " to select the first device containing the substring."))) - (setf *snd-list-devices* nil))) ; normally nil - max-sample))) +(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 ;; @@ -226,7 +273,7 @@ ;; s-read -- reads a file (defun s-read (filename &key (time-offset 0) (srate *sound-srate*) - (dur 10000.0) (nchans 1) (format *default-sf-format*) + (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) @@ -319,7 +366,6 @@ (defun snd-read-srate (rslt) (cadr (cddddr rslt))) (defun snd-read-dur (rslt) (caddr (cddddr rslt))) (defun snd-read-flags (rslt) (cadddr (cddddr rslt))) -(defun snd-read-byte-offset (rslt) (cadr (cddddr (cddddr rslt)))) ;; round is tricky because truncate rounds toward zero as does C ;; in other words, rounding is down for positive numbers and up @@ -339,7 +385,8 @@ (defun coterm (snd1 snd2) (multichan-expand #'snd-coterm snd1 snd2)) -(defmacro s-add-to (expr maxlen filename &optional (time-offset 0.0)) +(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~%" @@ -350,19 +397,18 @@ :time-offset ny:offset) ny:addend) ny:addend)) - ,maxlen ny:fname ny:offset SND-HEAD-NONE 0 0 0)) + ,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)) +(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:offset (snd-read-byte-offset ny:rslt)) - (setf ny:peak (snd-overwrite `,expr ,maxlen ny:fname ny:offset - SND-HEAD-NONE 0 0 0)) + (setf ny:peak (snd-overwrite `,expr ,maxlen ny:fname ny:offset ,progress)) (format t "Duration written: ~A~%" (car *rslt*)) ny:peak)) diff --git a/nyquist/init.lsp b/nyquist/init.lsp index a90ab250b..0a8f75680 100644 --- a/nyquist/init.lsp +++ b/nyquist/init.lsp @@ -1,4 +1,6 @@ ; init.lsp -- default Nyquist startup file + +(setf *breakenable* t) (load "nyinit.lsp" :verbose nil) ; add your customizations here: @@ -6,84 +8,3 @@ ; (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)))) - -(defun escape-backslash (in-string) - ;;; Escape backslashes - (let (ch (out-string "")) - (dotimes (i (length in-string) out-string) - (setf ch (subseq in-string i (1+ i))) - (if (string= ch "\\") - (string-append out-string "\\\\") - (string-append out-string ch))))) - -(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-backslash info-string))) - (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/nyquist/nyinit.lsp b/nyquist/nyinit.lsp index 9846fb65d..47b2cbdb5 100644 --- a/nyquist/nyinit.lsp +++ b/nyquist/nyinit.lsp @@ -11,7 +11,8 @@ (load "seqfnint.lsp" :verbose NIL) (load "velocity.lsp" :verbose NIL) ; linear-to-vel etc -(load "system.lsp" :verbose NIL) +(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) @@ -26,8 +27,8 @@ (format t "~%Nyquist -- A Language for Sound Synthesis and Composition~%") -(format t " Copyright (c) 1991,1992,1995,2007-2018 by Roger B. Dannenberg~%") -(format t " Version 3.15~%~%") +(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/nyquist/nyquist.lsp b/nyquist/nyquist.lsp index 86fa33150..0ab16485e 100644 --- a/nyquist/nyquist.lsp +++ b/nyquist/nyquist.lsp @@ -253,6 +253,7 @@ functions assume durations are always positive."))) (load "dspprims.lsp" :verbose NIL) (load "fileio.lsp" :verbose NIL) + ;;;;;;;;;;;;;;;;;;;;;; ;; OSCILATORS ;;;;;;;;;;;;;;;;;;;;;; @@ -267,6 +268,7 @@ functions assume durations are always positive."))) (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)) @@ -920,8 +922,8 @@ loop (let* ((len (length x)) (result (make-array len))) (dotimes (i len) - (setf (aref result i) - (snd-exp (snd-scale ln10over20 (aref x i))))) + (setf (aref result i) + (snd-exp (snd-scale ln10over20 (aref x i))))) result)) (t (snd-exp (snd-scale ln10over20 x))))) @@ -936,8 +938,8 @@ loop (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))))) + (setf (aref result i) + (snd-scale (/ 1.0 ln10over20) (snd-log (aref x i))))) result)) (t (snd-scale (/ 1.0 ln10over20) (snd-log x))))) @@ -1034,7 +1036,7 @@ loop (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)) @@ -1064,6 +1066,7 @@ loop (list ld)) ,s)) + ;(defun must-be-sound (x) ; (cond ((soundp x) x) ; (t @@ -1304,8 +1307,8 @@ loop (let* ((len (length sound)) (result (make-array len))) (dotimes (i len) - (setf (aref result i) - (cue-sound (aref sound i)))) + (setf (aref result i) + (cue-sound (aref sound i)))) result)) (t (cue-sound sound)))) @@ -1426,7 +1429,7 @@ loop ;; ;; 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 determing absolute duration. +;; the begining of the envelope is used to determing 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 @@ -1458,36 +1461,80 @@ loop 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:error "GATE" 1 '((SOUND) "sound") sound)) - (ny:typecheck (not (numberp lookahead)) - (ny:error "GATE" 2 '((NUMBER) "lookahead") lookahead)) - (ny:typecheck (not (numberp risetime)) - (ny:error "GATE" 3 '((NUMBER) "risetime") risetime)) - (ny:typecheck (not (numberp falltime)) - (ny:error "GATE" 4 '((NUMBER) "falltime") falltime)) - (ny:typecheck (not (numberp floor)) - (ny:error "GATE" 5 '((NUMBER) "floor") floor)) - (ny:typecheck (not (numberp threshold)) - (ny:error "GATE" 6 '((NUMBER) "threshold") threshold)) - (cond ((< lookahead risetime) - (format t "WARNING: lookahead must be greater than risetime in ~A function; setting lookahead to ~A.\n" source risetime) - (setf lookahead risetime))) - (cond ((< risetime 0) - (format t "WARNING: risetime must be greater than zero in ~A function; setting risetime to 0.0.\n" source) - (setf risetime 0.0))) - (cond ((< falltime 0) - (format t "WARNING: falltime must be greater than zero in ~A function; setting falltime to 0.0.\n" source) - (setf falltime 0.0))) - (cond ((< floor 0) - (format t "WARNING: floor must be greater than zero in ~A function; setting floor to 0.0.\n" source) - (setf floor 0.0))) - (let ((s (snd-gate (seq (cue sound) (abs-env (s-rest lookahead))) - lookahead risetime falltime floor threshold))) - (snd-xform s (snd-srate s) (snd-t0 sound) - (+ (snd-t0 sound) lookahead) MAX-STOP-TIME 1.0))) + ;(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.001) + (format t "WARNING: ~A ~A function; setting floor to 0.001.\n" + "floor must be greater than zero in" source) + (setf floor 0.001))) + (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 evaluted. 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) @@ -2024,7 +2071,7 @@ loop (defmacro simrep (pair sound) `(let (_snds) (dotimes ,pair (push ,sound _snds)) - (sim-list _snds "SIMREP"))) + (sim-list _snds "SIMREP"))) (defun sim (&rest snds) (sim-list snds "SIM or SUM (or + in SAL)")) @@ -2179,40 +2226,7 @@ loop ;; 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) +(defun multichan-expand (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) diff --git a/nyquist/sal-parse.lsp b/nyquist/sal-parse.lsp index 34817b6f3..1f9641644 100644 --- a/nyquist/sal-parse.lsp +++ b/nyquist/sal-parse.lsp @@ -102,7 +102,7 @@ (:WHEN "when") (:UNLESS "unless") (:SET "set") (:= "=") (:+= "+=") (:*= "*=") (:&= "&=") (:@= "@=") (:^= "^=") (:<= "<=") (:>= ">=") (:PRINT "print") - (:LOOP "loop") + (: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") @@ -110,8 +110,10 @@ (:FINALLY "finally") (:RETURN "return") (:WAIT "wait") (:BEGIN "begin") (:WITH "with") (:END "end") (:VARIABLE "variable") - (:FUNCTION "function") (:PROCESS "process") - (:CHDIR "chdir") (:DEFINE "define") (:LOAD "load") + (:FUNCTION "function") + ; not in nyquist: (:PROCESS "process") + (:CHDIR "chdir") + (:DEFINE "define") (:LOAD "load") (:PLAY "play") (:PLOT "plot") (:EXEC "exec") (:exit "exit") (:DISPLAY "display") (:~ "~") (:~~ "~~") (:@ ":@") (:@@ ":@@"))) @@ -772,7 +774,7 @@ ;; class token has <> removed! (if tok (progn (set-token-type tok ':class) tok) - (errexit "Not a class identifer" pos))) + (errexit "Not a class identifier" pos))) (errexit "Not a class identifer" pos))) nil))) @@ -1114,7 +1116,7 @@ ;; SAL returns nil from begin-end statement lists ;; (defun returnize (stmt) - (let (rev) + (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)) @@ -1672,7 +1674,7 @@ ;; to do term-1 followed by indexing operations ;; (defun parse-term-1 () - (let (sexpr id) + (let (sexpr id vars loopvar n) (cond ((token-is '(:- :!)) (list (token-lisp (parse-token)) (parse-term))) ((token-is :lp) @@ -1701,10 +1703,50 @@ (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)) @@ -1752,7 +1794,7 @@ (loop ; look for one or more [keyword] sexpr ; optional keyword test (setf keyword nil) - ;(display "pargs" (car *sal-tokens*)) + ; (display "pargs" (car *sal-tokens*)) (if (token-is :key) (setf keyword (token-lisp (parse-token)))) ; (display "parse-pargs" keyword) diff --git a/nyquist/seq.lsp b/nyquist/seq.lsp index 5e8c9fba9..90c6e935a 100644 --- a/nyquist/seq.lsp +++ b/nyquist/seq.lsp @@ -24,141 +24,172 @@ ; 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 serveral 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) +(defun seq-expr-expand (expr source) (if *sal-call-stack* - (list 'prog2 (list 'sal-trace-enter (list 'quote (list "Expression in SEQ:" expr))) - expr - '(sal-trace-exit)) + `(prog2 (sal-trace-enter '(,(strcat "Expression in " source ":") ,expr)) + ,expr ;; here is where the seq behavior is evaluated + (sal-trace-exit)) expr)) -(defmacro seq (&rest list) - (cond ((null list) - (snd-zero (warp-time *WARP*) *sound-srate*)) - ((null (cdr list)) - (car list)) - ((null (cddr list)) - ;; SEQ with 2 behaviors - `(let* ((first%sound ,(seq-expr-expand (car list))) - (s%rate (get-srates first%sound))) - (cond ((arrayp first%sound) - (snd-multiseq (prog1 first%sound (setf first%sound nil)) - #'(lambda (t0) - (with%environment ',(nyq:the-environment) - (at-abs t0 - (force-srates s%rate ,(seq-expr-expand (cadr list)))))))) - (t - ; allow gc of first%sound: - (snd-seq (prog1 first%sound (setf first%sound nil)) - #'(lambda (t0) - (with%environment ',(nyq:the-environment) - (at-abs t0 - (force-srate s%rate ,(seq-expr-expand (cadr list))))))))))) +(defun with%environment (env expr) + ;; (progv (var1 ...) (val1 ...) expression-list) + `(progv ',*environment-variables* ,env ,expr)) +;(trace with%environment seq-expr-expand) - (t ;; SEQ with more than 2 behaviors - `(let* ((nyq%environment (nyq:the-environment)) - (first%sound ,(car list)) +(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)) - (seq%environment (getenv))) - (cond ((arrayp first%sound) - (snd-multiseq (prog1 first%sound (setf first%sound nil)) - #'(lambda (t0) - (multiseq-iterate ,(cdr list))))) - (t - ; allow gc of first%sound: - (snd-seq (prog1 first%sound (setf first%sound nil)) - #'(lambda (t0) - (seq-iterate ,(cdr list)))))))))) - -(defun envdepth (e) (length (car e))) - -(defmacro myosd (pitch) - `(let () (format t "myosc env depth is ~A~%" - (envdepth (getenv))) (osc ,pitch))) - -(defmacro seq-iterate (behavior-list) - (cond ((null (cdr behavior-list)) - ;; last expression in list - `(eval-seq-behavior ,(seq-expr-expand (car behavior-list)))) - (t ;; more expressions after this one - `(snd-seq (eval-seq-behavior ,(seq-expr-expand (car behavior-list))) - (evalhook '#'(lambda (t0) - ; (format t "lambda depth ~A~%" (envdepth (getenv))) - (seq-iterate ,(cdr behavior-list))) - nil nil seq%environment))))) - -(defmacro multiseq-iterate (behavior-list) - (cond ((null (cdr behavior-list)) - `(eval-multiseq-behavior ,(seq-expr-expand (car behavior-list)))) - (t - `(snd-multiseq (eval-multiseq-behavior ,(seq-expr-expand (car behavior-list))) - (evalhook '#'(lambda (t0) - (multiseq-iterate ,(cdr behavior-list))) - nil nil seq%environment))))) - -(defmacro eval-seq-behavior (beh) - `(with%environment nyq%environment - (at-abs t0 - (force-srate s%rate ,beh)))) - -(defmacro eval-multiseq-behavior (beh) - `(with%environment nyq%environment - (at-abs t0 - (force-srates s%rate ,beh)))) - -(defmacro with%environment (env &rest expr) - `(progv ',*environment-variables* ,env ,@expr)) + (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)) -(defmacro seqrep (pair sound) - `(let ((,(car pair) 0) - (loop%count ,(cadr pair)) + +#| +;; 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)) - seqrep%closure first%sound s%rate) + 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)) - (t - (setf seqrep%closure #'(lambda (t0) -; (display "SEQREP" loop%count ,(car pair)) - (cond ((< ,(car pair) loop%count) - (setf first%sound - (with%environment nyq%environment - (at-abs t0 ,sound))) - ; (display "seqrep" s%rate nyq%environment ,(car pair) - ; loop%count) - (if s%rate - (setf first%sound (force-srates s%rate first%sound)) - (setf s%rate (get-srates first%sound))) - (setf ,(car pair) (1+ ,(car pair))) - ; note the following test is AFTER the counter increment - (cond ((= ,(car pair) loop%count) -; (display "seqrep: computed the last sound at" -; ,(car pair) loop%count -; (local-to-global 0)) - first%sound) ;last sound - ((arrayp s%rate) -; (display "seqrep: calling snd-multiseq at" -; ,(car pair) loop%count (local-to-global 0) -; (snd-t0 (aref first%sound 0))) - (snd-multiseq (prog1 first%sound - (setf first%sound nil)) - seqrep%closure)) - (t -; (display "seqrep: calling snd-seq at" -; ,(car pair) loop%count (local-to-global 0) -; (snd-t0 first%sound)) - (snd-seq (prog1 first%sound - (setf first%sound nil)) - seqrep%closure)))) - (t (snd-zero (warp-time *WARP*) *sound-srate*))))) - (funcall seqrep%closure (local-to-global 0)))))) + ((< 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)))) (defmacro trigger (input beh) diff --git a/nyquist/seqfnint.lsp b/nyquist/seqfnint.lsp index 269fbb77d..1f7b01bde 100644 --- a/nyquist/seqfnint.lsp +++ b/nyquist/seqfnint.lsp @@ -1,19 +1,19 @@ - (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)) - + (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) diff --git a/nyquist/sndfnint.lsp b/nyquist/sndfnint.lsp index 383b055a1..015191b24 100644 --- a/nyquist/sndfnint.lsp +++ b/nyquist/sndfnint.lsp @@ -1,3 +1,9 @@ + (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) @@ -39,9 +45,11 @@ (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) @@ -79,12 +87,6 @@ (setf snd-mode-DPCM 10) (setf snd-mode-msadpcm 11) - - (setf snd-mode-vorbis 12) - (SETF MAX-STOP-TIME 10E20) - - (SETF MIN-START-TIME -10E20) - - (setf OP-AVERAGE 1) (setf OP-PEAK 2) + (setf snd-mode-vorbis 11) diff --git a/nyquist/system.lsp b/nyquist/system.lsp index ca93229e9..3923bc821 100644 --- a/nyquist/system.lsp +++ b/nyquist/system.lsp @@ -71,9 +71,6 @@ (defmacro play (expr) `(s-save-autonorm ,expr NY:ALL *default-sound-file* :play *soundenable*)) -(setf *runtime-path* (current-path)) -(display "system.lsp" *runtime-path*) - ;; for Linux, modify s-plot (defined in nyquist.lsp) by saving s-plot ;; in standard-s-plot, then call gnuplot to display the points. ;; diff --git a/nyquist/xlinit.lsp b/nyquist/xlinit.lsp index 42991e20b..ae2cfda22 100644 --- a/nyquist/xlinit.lsp +++ b/nyquist/xlinit.lsp @@ -51,7 +51,7 @@ (load "profile.lsp" :verbose NIL) -(setq *breakenable* t) +; (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)