Update Nyquist to SVN r331
This commit is contained in:
Leland Lucius
parent
29d35e46e9
commit
586b86a77f
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
265
nyquist/seq.lsp
265
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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -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…
Reference in New Issue