Browse Source

Update Nyquist to SVN r331

au-ny-api
Leland Lucius 12 months ago
parent
commit
586b86a77f
  1. 57
      nyquist/dspprims.lsp
  2. 162
      nyquist/fileio.lsp
  3. 83
      nyquist/init.lsp
  4. 7
      nyquist/nyinit.lsp
  5. 156
      nyquist/nyquist.lsp
  6. 56
      nyquist/sal-parse.lsp
  7. 261
      nyquist/seq.lsp
  8. 30
      nyquist/seqfnint.lsp
  9. 18
      nyquist/sndfnint.lsp
  10. 3
      nyquist/system.lsp
  11. 2
      nyquist/xlinit.lsp

57
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

162
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))

83
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)

7
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)

156
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)

56
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)

261
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)))))))))))
(t ;; SEQ with more than 2 behaviors
`(let* ((nyq%environment (nyq:the-environment))
(first%sound ,(car list))
(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))
(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)))))
(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 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))))
#|
;; 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))
(defmacro with%environment (env &rest expr)
`(progv ',*environment-variables* ,env ,@expr))
;; 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)))))
(defmacro seqrep (pair sound)
`(let ((,(car pair) 0)
(loop%count ,(cadr pair))
; 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)

30
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)

18
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)

3
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.
;;

2
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)

Loading…
Cancel
Save