Autres/audacity
1
0
Fork 0
mirror of https://github.com/cookiengineer/audacity synced 2025-06-15 15:49:36 +02:00
Code Issues Releases Wiki Activity

Update Nyquist runtime to r288

Browse Source 
Totally forgot about these when upgrading Nyquist to r288.
This commit is contained in:
Leland Lucius 2020-01-13 12:43:39 -06:00
parent 69ee0a8963
commit e6c1a89123
18 changed files with 3263 additions and 1434 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

370
nyquist/dspprims.lsp
View File

@ -3,7 +3,10 @@
;; ARESON - notch filter ;; ARESON - notch filter
;; ;;
(defun areson (s c b &optional (n 0)) (defun areson (s c b &optional (n 0))
(multichan-expand #'nyq:areson s c b n)) (multichan-expand "ARESON" #'nyq:areson
'(((SOUND) nil) ((NUMBER SOUND) "center")
((NUMBER SOUND) "bandwidth") ((INTEGER) nil))
s c b n))
(setf areson-implementations (setf areson-implementations
(vector #'snd-areson #'snd-aresonvc #'snd-aresoncv #'snd-aresonvv)) (vector #'snd-areson #'snd-aresonvc #'snd-aresoncv #'snd-aresonvv))
@ -11,14 +14,15 @@
;; NYQ:ARESON - notch filter, single channel ;; NYQ:ARESON - notch filter, single channel
;; ;;
(defun nyq:areson (signal center bandwidth normalize) (defun nyq:areson (signal center bandwidth normalize)
(select-implementation-1-2 areson-implementations (select-implementation-1-2 "ARESON" areson-implementations
signal center bandwidth normalize)) signal center bandwidth normalize))
;; hp - highpass filter ;; hp - highpass filter
;; ;;
(defun hp (s c) (defun hp (s c)
(multichan-expand #'nyq:hp s c)) (multichan-expand "HP" #'nyq:hp
'(((SOUND) "snd") ((NUMBER SOUND) "cutoff")) s c))
(setf hp-implementations (setf hp-implementations
(vector #'snd-atone #'snd-atonev)) (vector #'snd-atone #'snd-atonev))
@ -26,15 +30,15 @@
;; NYQ:hp - highpass filter, single channel ;; NYQ:hp - highpass filter, single channel
;; ;;
(defun nyq:hp (s c) (defun nyq:hp (s c)
(select-implementation-1-1 hp-implementations s c)) (select-implementation-1-1 "HP" hp-implementations s c))
;; comb-delay-from-hz -- compute the delay argument ;; comb-delay-from-hz -- compute the delay argument
;; ;;
(defun comb-delay-from-hz (hz caller) (defun comb-delay-from-hz (hz)
(recip hz)) (recip hz))
;; comb-feedback-from-decay -- compute the feedback argument ;; comb-feedback -- compute the feedback argument
;; ;;
(defun comb-feedback (decay delay) (defun comb-feedback (decay delay)
(s-exp (mult -6.9087 delay (recip decay)))) (s-exp (mult -6.9087 delay (recip decay))))
@ -44,26 +48,30 @@
;; this is just a feedback-delay with different arguments ;; this is just a feedback-delay with different arguments
;; ;;
(defun comb (snd decay hz) (defun comb (snd decay hz)
(multichan-expand #'nyq:comb snd decay hz)) (multichan-expand "COMB" #'nyq:comb
'(((SOUND) "snd") ((NUMBER SOUND) "decay") ((POSITIVE) "hz"))
snd decay hz))
(defun nyq:comb (snd decay hz) (defun nyq:comb (snd decay hz)
(let (delay feedback len d) (let (delay feedback len d)
; convert decay to feedback, iterate over array if necessary ; convert decay to feedback
(setf delay (comb-delay-from-hz hz "comb")) (setf delay (/ (float hz)))
(setf feedback (comb-feedback decay delay)) (setf feedback (comb-feedback decay delay))
(nyq:feedback-delay snd delay feedback))) (nyq:feedback-delay snd delay feedback "COMB")))
;; ALPASS - all-pass filter ;; ALPASS - all-pass filter
;; ;;
(defun alpass (snd decay hz &optional min-hz) (defun alpass (snd decay hz &optional min-hz)
(multichan-expand #'nyq:alpass snd decay hz min-hz)) (multichan-expand "ALPASS" #'nyq:alpass
'(((SOUND) "snd") ((NUMBER SOUND) "decay")
((POSITIVE SOUND) "hz") ((POSITIVE-OR-NULL) "min-hz"))
snd decay hz min-hz))
(defun nyq:alpass (snd decay hz min-hz) (defun nyq:alpass (snd decay hz min-hz)
(let (delay feedback len d) (let (delay feedback len d)
; convert decay to feedback, iterate over array if necessary ; convert decay to feedback, iterate over array if necessary
(setf delay (comb-delay-from-hz hz "alpass")) (setf delay (comb-delay-from-hz hz))
(setf feedback (comb-feedback decay delay)) (setf feedback (comb-feedback decay delay))
(nyq:alpass1 snd delay feedback min-hz))) (nyq:alpass1 snd delay feedback min-hz)))
@ -71,26 +79,36 @@
;; CONST -- a constant at control-srate ;; CONST -- a constant at control-srate
;; ;;
(defun const (value &optional (dur 1.0)) (defun const (value &optional (dur 1.0))
(ny:typecheck (not (numberp value))
(ny:error "CONST" 1 '((NUMBER) "value") value))
(ny:typecheck (not (numberp dur))
(ny:error "CONST" 2 '((NUMBER) "dur") dur))
(let ((d (get-duration dur))) (let ((d (get-duration dur)))
(snd-const value *rslt* *CONTROL-SRATE* d))) (snd-const value *rslt* *CONTROL-SRATE* d)))
;; CONVOLVE - slow convolution ;; CONVOLVE - fast convolution
;; ;;
(defun convolve (s r) (defun convolve (s r)
(multichan-expand #'snd-convolve s r)) (multichan-expand "CONVOLVE" #'nyq:convolve
'(((SOUND) nil) ((SOUND) nil)) s r))
(defun nyq:convolve (s r)
(snd-convolve s (force-srate (snd-srate s) r)))
;; FEEDBACK-DELAY -- (delay is quantized to sample period) ;; FEEDBACK-DELAY -- (delay is quantized to sample period)
;; ;;
(defun feedback-delay (snd delay feedback) (defun feedback-delay (snd delay feedback)
(multichan-expand #'nyq:feedback-delay snd delay feedback)) (multichan-expand "FEEDBACK-DELAY" #'nyq:feedback-delay
'(((SOUND) "snd") ((NUMBER) "delay") ((NUMBER SOUND) "feedback"))
snd delay feedback))
;; SND-DELAY-ERROR -- report type error ;; SND-DELAY-ERROR -- report type error
;; ;;
(defun snd-delay-error (snd delay feedback) (defun snd-delay-error (snd delay feedback)
(error "feedback-delay with variable delay is not implemented")) (error "FEEDBACK-DELAY with variable delay is not implemented"))
(setf feedback-delay-implementations (setf feedback-delay-implementations
@ -99,15 +117,15 @@
;; NYQ:FEEDBACK-DELAY -- single channel delay ;; NYQ:FEEDBACK-DELAY -- single channel delay
;; ;;
(defun nyq:feedback-delay (snd delay feedback) (defun nyq:feedback-delay (snd delay feedback &optional (src "FEEDBACK-DELAY"))
(select-implementation-1-2 feedback-delay-implementations (select-implementation-1-2 src feedback-delay-implementations
snd delay feedback)) snd delay feedback))
;; SND-ALPASS-ERROR -- report type error ;; SND-ALPASS-ERROR -- report type error
;; ;;
(defun snd-alpass-error (snd delay feedback) (defun snd-alpass-error (snd delay feedback)
(error "alpass with constant decay and variable hz is not implemented")) (error "ALPASS with constant decay and variable hz is not implemented"))
(if (not (fboundp 'snd-alpasscv)) (if (not (fboundp 'snd-alpasscv))
@ -120,10 +138,9 @@
(defun nyq:alpassvv (the-snd delay feedback min-hz) (defun nyq:alpassvv (the-snd delay feedback min-hz)
(let (max-delay) (let (max-delay)
(cond ((or (not (numberp min-hz)) (ny:typecheck (or (not (numberp min-hz)) (<= min-hz 0))
(<= min-hz 0)) (ny:error "ALPASS" 4 '((POSITIVE) "min-hz") min-hz))
(error "alpass needs numeric (>0) 4th parameter (min-hz) when delay is variable"))) (setf max-delay (/ (float min-hz)))
(setf max-delay (/ 1.0 min-hz))
; make sure delay is between 0 and max-delay ; make sure delay is between 0 and max-delay
; use clip function, which is symetric, with an offset ; use clip function, which is symetric, with an offset
(setf delay (snd-offset (clip (snd-offset delay (* max-delay -0.5)) (setf delay (snd-offset (clip (snd-offset delay (* max-delay -0.5))
@ -152,17 +169,22 @@
;; NYQ:ALPASS1 -- single channel alpass ;; NYQ:ALPASS1 -- single channel alpass
;; ;;
(defun nyq:alpass1 (snd delay feedback min-hz) (defun nyq:alpass1 (snd delay feedback min-hz)
(select-implementation-1-2 alpass-implementations (select-implementation-1-2 "ALPASS" alpass-implementations
snd delay feedback min-hz)) snd delay feedback min-hz))
;; CONGEN -- contour generator, patterned after gated analog env gen ;; CONGEN -- contour generator, patterned after gated analog env gen
;; ;;
(defun congen (gate rise fall) (multichan-expand #'snd-congen gate rise fall)) (defun congen (gate rise fall)
(multichan-expand "CONGEN" #'snd-congen
'(((SOUND) "gate") ((NONNEGATIVE) "rise") ((NONNEGATIVE) "fall"))
gate rise fall))
;; S-EXP -- exponentiate a sound ;; S-EXP -- exponentiate a sound
;; ;;
(defun s-exp (s) (multichan-expand #'nyq:exp s)) (defun s-exp (s)
(multichan-expand "S-EXP" #'nyq:exp
'(((NUMBER SOUND) nil)) s))
;; NYQ:EXP -- exponentiate number or sound ;; NYQ:EXP -- exponentiate number or sound
@ -171,83 +193,125 @@
;; S-ABS -- absolute value of a sound ;; S-ABS -- absolute value of a sound
;; ;;
(defun s-abs (s) (multichan-expand #'nyq:abs s)) (defun s-abs (s)
(multichan-expand "S-ABS" #'nyq:abs
'(((NUMBER SOUND) nil)) s))
;; NYQ:ABS -- absolute value of number or sound ;; NYQ:ABS -- absolute value of number or sound
;; ;;
(defun nyq:abs (s) (if (soundp s) (snd-abs s) (abs s))) (defun nyq:abs (s)
(if (soundp s) (snd-abs s) (abs s)))
;; S-SQRT -- square root of a sound ;; S-SQRT -- square root of a sound
;; ;;
(defun s-sqrt (s) (multichan-expand #'nyq:sqrt s)) (defun s-sqrt (s)
(multichan-expand "S-SQRT" #'nyq:sqrt
'(((NUMBER SOUND) nil)) s))
;; NYQ:SQRT -- square root of a number or sound ;; NYQ:SQRT -- square root of a number or sound
;; ;;
(defun nyq:sqrt (s) (if (soundp s) (snd-sqrt s) (sqrt s))) (defun nyq:sqrt (s)
(if (soundp s) (snd-sqrt s) (sqrt s)))
;; INTEGRATE -- integration ;; INTEGRATE -- integration
;; ;;
(defun integrate (s) (multichan-expand #'snd-integrate s)) (defun integrate (s)
(multichan-expand "INTEGRATE" #'snd-integrate
'(((SOUND) nil)) s))
;; S-LOG -- natural log of a sound ;; S-LOG -- natural log of a sound
;; ;;
(defun s-log (s) (multichan-expand #'nyq:log s)) (defun s-log (s)
(multichan-expand "S-LOG" #'nyq:log
'(((NUMBER SOUND) nil)) s))
;; NYQ:LOG -- log of a number or sound ;; NYQ:LOG -- log of a number or sound
;; ;;
(defun nyq:log (s) (if (soundp s) (snd-log s) (log s))) (defun nyq:log (s)
(if (soundp s) (snd-log s) (log s)))
;; NOISE -- white noise ;; NOISE -- white noise
;; ;;
(defun noise (&optional (dur 1.0)) (defun noise (&optional (dur 1.0))
(ny:typecheck (not (numberp dur))
(ny:error "NOISE" 1 number-anon dur))
(let ((d (get-duration dur))) (let ((d (get-duration dur)))
(snd-white *rslt* *SOUND-SRATE* d))) (snd-white *rslt* *SOUND-SRATE* d)))
(defun noise-gate (snd &optional (lookahead 0.5) (risetime 0.02) (falltime 0.5) (defun noise-gate (snd &optional (lookahead 0.5) (risetime 0.02) (falltime 0.5)
(floor 0.01) (threshold 0.01)) (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)))) (let ((rms (lp (mult snd snd) (/ *control-srate* 10.0))))
(setf threshold (* threshold threshold)) (setf threshold (* threshold threshold))
(mult snd (gate rms floor risetime falltime lookahead threshold)))) (mult snd (gate rms floor risetime falltime lookahead threshold "NOISE-GATE"))))
;; QUANTIZE -- quantize a sound ;; QUANTIZE -- quantize a sound
;; ;;
(defun quantize (s f) (multichan-expand #'snd-quantize s f)) (defun quantize (s f)
(multichan-expand "QUANTIZE" #'snd-quantize
'(((SOUND) nil) ((POSITIVE) nil)) s f))
;; RECIP -- reciprocal of a sound ;; RECIP -- reciprocal of a sound
;; ;;
(defun recip (s) (multichan-expand #'nyq:recip s)) (defun recip (s)
(multichan-expand "RECIP" #'nyq:recip
'(((NUMBER SOUND) nil)) s))
;; NYQ:RECIP -- reciprocal of a number or sound ;; NYQ:RECIP -- reciprocal of a number or sound
;; ;;
(defun nyq:recip (s) (if (soundp s) (snd-recip s) (/ (float s)))) (defun nyq:recip (s)
(if (soundp s) (snd-recip s) (/ (float s))))
;; RMS -- compute the RMS of a sound ;; 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)
(let (rslt step-size) (let (rslt step-size)
(cond ((not (eq (type-of s) 'SOUND)) (ny:typecheck (not (soundp s))
(break "in RMS, first parameter must be a monophonic SOUND"))) (ny:error "RMS" 1 number-anon s))
(ny:typecheck (not (numberp rate))
(ny:error "RMS" 2 '((NUMBER) "rate") rate))
(setf step-size (round (/ (snd-srate s) rate))) (setf step-size (round (/ (snd-srate s) rate)))
(cond ((null window-size) (cond ((null window-size)
(setf window-size step-size))) (setf window-size step-size))
((not (integerp window-size))
(error "In RMS, 2nd argument (window-size) must be an integer"
window-size)))
(setf s (prod s s)) (setf s (prod s s))
(setf result (snd-avg s window-size step-size OP-AVERAGE)) (setf result (snd-avg s window-size step-size OP-AVERAGE))
;; compute square root of average ;; compute square root of average
(s-exp (scale 0.5 (s-log result))))) (s-exp (scale 0.5 (s-log result)))))
;; RESON - bandpass filter ;; RESON - bandpass filter
;; ;;
(defun reson (s c b &optional (n 0)) (defun reson (s c b &optional (n 0))
(multichan-expand #'nyq:reson s c b n)) (multichan-expand "RESON" #'nyq:reson
'(((SOUND) "snd") ((NUMBER SOUND) "center")
((NUMBER SOUND) "bandwidth") ((INTEGER) "n"))
s c b n))
(setf reson-implementations (setf reson-implementations
(vector #'snd-reson #'snd-resonvc #'snd-resoncv #'snd-resonvv)) (vector #'snd-reson #'snd-resonvc #'snd-resoncv #'snd-resonvv))
@ -255,19 +319,23 @@
;; NYQ:RESON - bandpass filter, single channel ;; NYQ:RESON - bandpass filter, single channel
;; ;;
(defun nyq:reson (signal center bandwidth normalize) (defun nyq:reson (signal center bandwidth normalize)
(select-implementation-1-2 reson-implementations (select-implementation-1-2 "RESON" reson-implementations
signal center bandwidth normalize)) signal center bandwidth normalize))
;; SHAPE -- waveshaper ;; SHAPE -- waveshaper
;; ;;
(defun shape (snd shape origin) (defun shape (snd shape origin)
(multichan-expand #'snd-shape snd shape origin)) (multichan-expand "SHAPE" #'snd-shape
'(((SOUND) "snd") ((SOUND) "shape") ((NUMBER) "origin"))
snd shape origin))
;; SLOPE -- calculate the first derivative of a signal ;; SLOPE -- calculate the first derivative of a signal
;; ;;
(defun slope (s) (multichan-expand #'nyq:slope s)) (defun slope (s)
(multichan-expand "SLOPE" #'nyq:slope
'(((SOUND) nil)) s))
;; NYQ:SLOPE -- first derivative of single channel ;; NYQ:SLOPE -- first derivative of single channel
@ -281,7 +349,8 @@
;; lp - lowpass filter ;; lp - lowpass filter
;; ;;
(defun lp (s c) (defun lp (s c)
(multichan-expand #'nyq:lp s c)) (multichan-expand "LP" #'nyq:lp
'(((SOUND) "snd") ((NUMBER SOUND) "cutoff")) s c))
(setf lp-implementations (setf lp-implementations
(vector #'snd-tone #'snd-tonev)) (vector #'snd-tone #'snd-tonev))
@ -289,7 +358,7 @@
;; NYQ:lp - lowpass filter, single channel ;; NYQ:lp - lowpass filter, single channel
;; ;;
(defun nyq:lp (s c) (defun nyq:lp (s c)
(select-implementation-1-1 lp-implementations s c)) (select-implementation-1-1 "LP" lp-implementations s c))
@ -305,40 +374,60 @@
; remember that snd-biquad uses the opposite sign convention for a_i's ; remember that snd-biquad uses the opposite sign convention for a_i's
; than Matlab does. ; than Matlab does.
;
; Stability: Based on courses.cs.washington.edu/courses/cse490s/11au/
; Readings/Digital_Sound_Generation_2.pdf, the stable region is
; (a2 < 1) and ((a2 + 1) > |a1|)
; It doesn't look to me like our a0, a1, a2 match the paper's a0, a1, a2,
; and I'm not convinced the paper's derivation is correct, but at least
; the predicted region of stability is correct if we swap signs on a1 and
; a2 (but due to the |a1| term, only the sign of a2 matters). This was
; tested manually at a number of points inside and outside the stable
; triangle. Previously, the stability test was (>= a0 1.0) which seems
; generally wrong. The old test has been removed.
; convenient biquad: normalize a0, and use zero initial conditions.
; convenient biquad: normalize a0, and use zero initial conditions. ; convenient biquad: normalize a0, and use zero initial conditions.
(defun nyq:biquad (x b0 b1 b2 a0 a1 a2) (defun nyq:biquad (x b0 b1 b2 a0 a1 a2)
(if (<= a0 0.0) (ny:typecheck (<= a0 0.0)
(error (format nil "a0 < 0 (unstable parameter a0 = ~A) in biquad~%" a0))) (error (format nil "In BIQUAD, a0 < 0 (unstable parameter a0 = ~A)" a0)))
(let ((a0r (/ 1.0 a0))) (let ((a0r (/ (float a0))))
(setf a1 (* a0r a1) (setf a1 (* a0r a1)
a2 (* a0r a2)) a2 (* a0r a2))
(if (or (<= a2 -1.0) (<= (- 1.0 a2) (abs a1))) (ny:typecheck (or (<= a2 -1.0) (<= (- 1.0 a2) (abs a1)))
(error (format nil (error (format nil
"(a2 <= -1) or (1 - a2 <= |a1|) (~A a1 = ~A, a2 = ~A) in biquad~%" "In BIQUAD, (a2 <= -1) or (1 - a2 <= |a1|) (~A a1 = ~A, a2 = ~A)"
"unstable parameters" a1 a2))) "unstable parameters" a1 a2)))
(snd-biquad x (* a0r b0) (* a0r b1) (* a0r b2) (snd-biquad x (* a0r b0) (* a0r b1) (* a0r b2)
a1 a2 0 0))) a1 a2 0 0)))
(defun biquad (x b0 b1 b2 a0 a1 a2) (defun biquad (x b0 b1 b2 a0 a1 a2 &optional (source "BIQUAD"))
(multichan-expand #'nyq:biquad x b0 b1 b2 a0 a1 a2)) (multichan-expand "BIQUAD" #'nyq:biquad
'(((SOUND) "snd") ((NUMBER) "b0") ((NUMBER) "b1")
((NUMBER) "b2") ((NUMBER) "a0") ((NUMBER) "a1")
((NUMBER) "a2"))
x b0 b1 b2 a0 a1 a2))
; biquad with Matlab sign conventions for a_i's. ; biquad with Matlab sign conventions for a_i's.
(defun biquad-m (x b0 b1 b2 a0 a1 a2) (defun biquad-m (x b0 b1 b2 a0 a1 a2)
(multichan-expand #'nyq:biquad-m x b0 b1 b2 a0 a1 a2)) (multichan-expand "BIQUAD-M" #'nyq:biquad-m
'(((SOUND) "snd") ((NUMBER) "b0") ((NUMBER) "b1")
((NUMBER) "b2") ((NUMBER) "a0") ((NUMBER) "a1")
((NUMBER) "a2"))
x b0 b1 b2 a0 a1 a2))
(defun nyq:biquad-m (x b0 b1 b2 a0 a1 a2) (defun nyq:biquad-m (x b0 b1 b2 a0 a1 a2 &optional (source "BIQUAD-M"))
(nyq:biquad x b0 b1 b2 a0 (- a1) (- a2))) (nyq:biquad x b0 b1 b2 a0 (- a1) (- a2)))
; two-pole lowpass ; two-pole lowpass
(defun lowpass2 (x hz &optional (q 0.7071)) (defun lowpass2 (x hz &optional (q 0.7071) (source "LOWPASS2"))
(multichan-expand #'nyq:lowpass2 x hz q)) (multichan-expand source #'nyq:lowpass2
'(((SOUND) "snd") ((POSITIVE) "hz") ((POSITIVE) "q") ((STRING) "source"))
x hz q source))
;; NYQ:LOWPASS2 -- operates on single channel ;; NYQ:LOWPASS2 -- operates on single channel
(defun nyq:lowpass2 (x hz q) (defun nyq:lowpass2 (x hz q source)
(if (or (> hz (* 0.5 (snd-srate x))) (if (or (> hz (* 0.5 (snd-srate x)))
(< hz 0)) (< hz 0))
(error "cutoff frequency out of range" hz)) (error "cutoff frequency out of range" hz))
@ -352,13 +441,15 @@
(b1 (- 1.0 cw)) (b1 (- 1.0 cw))
(b0 (* 0.5 b1)) (b0 (* 0.5 b1))
(b2 b0)) (b2 b0))
(nyq:biquad-m x b0 b1 b2 a0 a1 a2))) (nyq:biquad-m x b0 b1 b2 a0 a1 a2 source)))
; two-pole highpass ; two-pole highpass
(defun highpass2 (x hz &optional (q 0.7071)) (defun highpass2 (x hz &optional (q 0.7071) (source "HIGHPASS2"))
(multichan-expand #'nyq:highpass2 x hz q)) (multichan-expand source #'nyq:highpass2
'(((SOUND) "snd") ((POSITIVE) "hz") ((POSITIVE) "q") ((STRING) "source"))
x hz q source))
(defun nyq:highpass2 (x hz q) (defun nyq:highpass2 (x hz q source)
(if (or (> hz (* 0.5 (snd-srate x))) (if (or (> hz (* 0.5 (snd-srate x)))
(< hz 0)) (< hz 0))
(error "cutoff frequency out of range" hz)) (error "cutoff frequency out of range" hz))
@ -372,11 +463,13 @@
(b1 (- -1.0 cw)) (b1 (- -1.0 cw))
(b0 (* -0.5 b1)) (b0 (* -0.5 b1))
(b2 b0)) (b2 b0))
(nyq:biquad-m x b0 b1 b2 a0 a1 a2))) (nyq:biquad-m x b0 b1 b2 a0 a1 a2 source)))
; two-pole bandpass. max gain is unity. ; two-pole bandpass. max gain is unity.
(defun bandpass2 (x hz q) (defun bandpass2 (x hz q)
(multichan-expand #'nyq:bandpass2 x hz q)) (multichan-expand "BANDPASS2" #'nyq:bandpass2
'(((SOUND) "snd") ((POSITIVE) "hz") ((POSITIVE) "q"))
x hz q))
(defun nyq:bandpass2 (x hz q) (defun nyq:bandpass2 (x hz q)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x)))) (let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
@ -389,11 +482,13 @@
(b0 alpha) (b0 alpha)
(b1 0.0) (b1 0.0)
(b2 (- alpha))) (b2 (- alpha)))
(nyq:biquad-m x b0 b1 b2 a0 a1 a2))) (nyq:biquad-m x b0 b1 b2 a0 a1 a2 "BANDPASS2")))
; two-pole notch. ; two-pole notch.
(defun notch2 (x hz q) (defun notch2 (x hz q)
(multichan-expand #'nyq:notch2 x hz q)) (multichan-expand "NOTCH2" #'nyq:notch2
'(((SOUND) "snd") ((POSITIVE) "hz") ((POSITIVE) "q"))
x hz q))
(defun nyq:notch2 (x hz q) (defun nyq:notch2 (x hz q)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x)))) (let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
@ -406,31 +501,36 @@
(b0 1.0) (b0 1.0)
(b1 (* -2.0 cw)) (b1 (* -2.0 cw))
(b2 1.0)) (b2 1.0))
(nyq:biquad-m x b0 b1 b2 a0 a1 a2))) (nyq:biquad-m x b0 b1 b2 a0 a1 a2 "NOTCH2")))
; two-pole allpass. ; two-pole allpass.
(defun allpass2 (x hz q) (defun allpass2 (x hz q)
(multichan-expand #'nyq:allpass x hz q)) (multichan-expand "ALLPASS2" #'nyq:allpass
'(((SOUND) "snd") ((POSITIVE) "hz") ((POSITIVE) "q"))
x hz q))
(defun nyq:allpass (x hz q) (defun nyq:allpass (x hz q)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x)))) (let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
(cw (cos w)) (cw (cos w))
(sw (sin w)) (sw (sin w))
(k (exp (* -0.5 w (/ 1.0 q)))) (k (exp (* -0.5 w (/ (float q)))))
(a0 1.0) (a0 1.0)
(a1 (* -2.0 cw k)) (a1 (* -2.0 cw k))
(a2 (* k k)) (a2 (* k k))
(b0 a2) (b0 a2)
(b1 a1) (b1 a1)
(b2 1.0)) (b2 1.0))
(nyq:biquad-m x b0 b1 b2 a0 a1 a2))) (nyq:biquad-m x b0 b1 b2 a0 a1 a2 "ALLPASS2")))
; bass shelving EQ. gain in dB; Fc is halfway point. ; bass shelving EQ. gain in dB; Fc is halfway point.
; response becomes peaky at slope > 1. ; response becomes peaky at slope > 1.
(defun eq-lowshelf (x hz gain &optional (slope 1.0)) (defun eq-lowshelf (x hz gain &optional (slope 1.0))
(multichan-expand #'nyq:eq-lowshelf x hz gain slope)) (multichan-expand "EQ-LOWSHELF" #'nyq:eq-lowshelf
'(((SOUND) "snd") ((POSITIVE) "hz") ((NUMBER) "gain") ((NUMBER) "slope"))
x hz gain slope))
(defun nyq:eq-lowshelf (x hz gain slope) (defun nyq:eq-lowshelf (x hz gain slope)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x)))) (let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
@ -454,7 +554,9 @@
; treble shelving EQ. gain in dB; Fc is halfway point. ; treble shelving EQ. gain in dB; Fc is halfway point.
; response becomes peaky at slope > 1. ; response becomes peaky at slope > 1.
(defun eq-highshelf (x hz gain &optional (slope 1.0)) (defun eq-highshelf (x hz gain &optional (slope 1.0))
(multichan-expand #'nyq:eq-highshelf x hz gain slope)) (multichan-expand "EQ-HIGHSHELF" #'nyq:eq-highshelf
'(((SOUND) "snd") ((POSITIVE) "hz") ((NUMBER) "gain") ((NUMBER) "slope"))
x hz gain slope))
(defun nyq:eq-highshelf (x hz gain slope) (defun nyq:eq-highshelf (x hz gain slope)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x)))) (let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
@ -479,12 +581,20 @@
(eq-band-ccc x hz gain width)) (eq-band-ccc x hz gain width))
((and (soundp hz) (soundp gain) (soundp width)) ((and (soundp hz) (soundp gain) (soundp width))
(snd-eqbandvvv x hz (db-to-linear gain) width)) (snd-eqbandvvv x hz (db-to-linear gain) width))
(t (t (error
(error "eq-band hz, gain, and width must be all numbers or all sounds")))) (strcat
"In EQ-BAND, hz, gain, and width must be all numbers"
" or all sounds (if any parameter is an array, there"
" is a problem with at least one channel), hz is "
(param-to-string hz) ", gain is " (param-to-string gain)
", width is " (param-to-string width)) )) ))
; midrange EQ. gain in dB, width in octaves (half-gain width). ; midrange EQ. gain in dB, width in octaves (half-gain width).
(defun eq-band (x hz gain width) (defun eq-band (x hz gain width)
(multichan-expand #'nyq:eq-band x hz gain width)) (multichan-expand "EQ-BAND" #'nyq:eq-band
'(((SOUND) "snd") ((POSITIVE SOUND) "hz")
((NUMBER SOUND) "gain") ((POSITIVE SOUND) "width"))
x hz gain width))
(defun eq-band-ccc (x hz gain width) (defun eq-band-ccc (x hz gain width)
@ -507,53 +617,99 @@
; four-pole Butterworth lowpass ; four-pole Butterworth lowpass
(defun lowpass4 (x hz) (defun lowpass4 (x hz)
(lowpass2 (lowpass2 x hz 0.60492333) hz 1.33722126)) (lowpass2 (lowpass2 x hz 0.60492333 "LOWPASS4")
hz 1.33722126 "LOWPASS4"))
; six-pole Butterworth lowpass ; six-pole Butterworth lowpass
(defun lowpass6 (x hz) (defun lowpass6 (x hz)
(lowpass2 (lowpass2 (lowpass2 x hz 0.58338080) (lowpass2 (lowpass2 (lowpass2 x hz 0.58338080 "LOWPASS6")
hz 0.75932572) hz 0.75932572 "LOWPASS6")
hz 1.95302407)) hz 1.95302407 "LOWPASS6"))
; eight-pole Butterworth lowpass ; eight-pole Butterworth lowpass
(defun lowpass8 (x hz) (defun lowpass8 (x hz)
(lowpass2 (lowpass2 (lowpass2 (lowpass2 x hz 0.57622191) (lowpass2 (lowpass2 (lowpass2 (lowpass2 x hz 0.57622191 "LOWPASS8")
hz 0.66045510) hz 0.66045510 "LOWPASS8")
hz 0.94276399) hz 0.94276399 "LOWPASS8")
hz 2.57900101)) hz 2.57900101 "LOWPASS8"))
; four-pole Butterworth highpass ; four-pole Butterworth highpass
(defun highpass4 (x hz) (defun highpass4 (x hz)
(highpass2 (highpass2 x hz 0.60492333) hz 1.33722126)) (highpass2 (highpass2 x hz 0.60492333 "HIGHPASS4")
hz 1.33722126 "HIGHPASS4"))
; six-pole Butterworth highpass ; six-pole Butterworth highpass
(defun highpass6 (x hz) (defun highpass6 (x hz)
(highpass2 (highpass2 (highpass2 x hz 0.58338080) (highpass2 (highpass2 (highpass2 x hz 0.58338080 "HIGHPASS6")
hz 0.75932572) hz 0.75932572 "HIGHPASS6")
hz 1.95302407)) hz 1.95302407 "HIGHPASS6"))
; eight-pole Butterworth highpass ; eight-pole Butterworth highpass
(defun highpass8 (x hz) (defun highpass8 (x hz)
(highpass2 (highpass2 (highpass2 (highpass2 x hz 0.57622191) (highpass2 (highpass2 (highpass2 (highpass2 x hz 0.57622191 "HIGHPASS8")
hz 0.66045510) hz 0.66045510 "HIGHPASS8")
hz 0.94276399) hz 0.94276399 "HIGHPASS8")
hz 2.57900101)) hz 2.57900101 "HIGHPASS8"))
; YIN ; YIN
; maybe this should handle multiple channels, etc. ; maybe this should handle multiple channels, etc.
(setfn yin snd-yin) (defun yin (sound minstep maxstep stepsize)
(ny:typecheck (not (soundp sound))
(ny:error "YIN" 1 '((SOUND) "sound") sound))
(ny:typecheck (not (numberp minstep))
(ny:error "YIN" 2 '((NUMBER) "minstep") minstep))
(ny:typecheck (not (numberp maxstep))
(ny:error "YIN" 3 '((NUMBER) "maxstep") maxstep))
(ny:typecheck (not (integerp stepsize))
(ny:error "YIN" 4 '((INTEGER) "stepsize") stepsize))
(snd-yin sound minstep maxstep stepsize))
; FOLLOW ; FOLLOW
(defun follow (sound floor risetime falltime lookahead) (defun follow (sound floor risetime falltime lookahead)
(ny:typecheck (not (soundp sound))
(ny:error "FOLLOW" 1 '((SOUND) "sound") sound))
(ny:typecheck (not (numberp floor))
(ny:error "FOLLOW" 2 '((NUMBER) "floor") floor))
(ny:typecheck (not (numberp risetime))
(ny:error "FOLLOW" 3 '((NUMBER) "risetime") risetime))
(ny:typecheck (not (numberp falltime))
(ny:error "FOLLOW" 4 '((NUMBER) "stepsize") falltime))
(ny:typecheck (not (numberp lookahead))
(ny:error "FOLLOW" 5 '((NUMBER) "lookahead") lookahead))
;; use 10000s as "infinite" -- that's about 2^30 samples at 96K ;; use 10000s as "infinite" -- that's about 2^30 samples at 96K
(setf lookahead (round (* lookahead (snd-srate sound)))) (setf lookahead (round (* lookahead (snd-srate sound))))
(extract (/ lookahead (snd-srate sound)) 10000 (extract (/ lookahead (snd-srate sound)) 10000
(snd-follow sound floor risetime falltime lookahead))) (snd-follow sound floor risetime falltime lookahead)))
; Note: gate implementation moved to nyquist.lsp
;(defun gate (sound floor risetime falltime lookahead threshold) ;; PHASE VOCODER
; (setf lookahead (round (* lookahead (snd-srate sound)))) (defun phasevocoder (s map &optional (fftsize -1) (hopsize -1) (mode 0))
; (setf lookahead (/ lookahead (snd-srate sound))) (multichan-expand "PHASEVOCODER" #'snd-phasevocoder
; (extract lookahead 10000 '(((SOUND) nil) ((SOUND) "map") ((INTEGER) "fftsize")
; (snd-gate sound lookahead risetime falltime floor threshold))) ((INTEGER) "hopsize") ((INTEGER) "mode"))
s map fftsize hopsize mode))
;; PV-TIME-PITCH
;; PV-TIME-PITCH -- control time stretch and transposition
;;
;; stretchfn maps from input time to output time
;; pitchfn maps from input time to transposition factor (2 means octave up)
(defun pv-time-pitch (input stretchfn pitchfn dur &optional
(fftsize 2048) (hopsize nil) (mode 0))
(multichan-expand "PV-TIME-PITCH" #'nyq:pv-time-pitch
'(((SOUND) "input") ((SOUND) "stretchfn") ((SOUND) "pitchfn")
((NUMBER) "dur") ((INTEGER) "fftsize") ((INT-OR-NULL) "hopsize")
((INTEGER) "mode"))
input stretchfn pitchfn dur fftsize hopsize mode))
(defun nyq:pv-time-pitch (input stretchfn pitchfn dur fftsize hopsize mode)
(let (wrate u v w vinv)
(if (null hopsize) (setf hopsize (/ fftsize 8)))
(setf wrate (/ 3000 dur))
(setf vinv (integrate (prod stretchfn pitchfn)))
(setf v (snd-inverse vinv (local-to-global 0) wrate))
(setf w (integrate (snd-recip (snd-compose pitchfn v))))
(sound-warp w (phasevocoder input v fftsize hopsize mode) wrate)))

6
nyquist/envelopes.lsp
View File

@ -1,4 +1,4 @@
;; envelopes.lsp -- support functions for envelope editor in jNyqIDE ;; envelopes.lsp -- support functions for envelope editor in NyquistIDE
#| In Nyquist, editable envelopes are saved as one entry in the workspace #| In Nyquist, editable envelopes are saved as one entry in the workspace
named *envelopes*. The entry is an association list where each element named *envelopes*. The entry is an association list where each element
@ -18,7 +18,7 @@ To convert envelope data into functions, call (MAKE-ENV-FUNCTIONS).
This function should be on the workspace's list of functions to call. This function should be on the workspace's list of functions to call.
(See ADD-ACTION-TO-WORKSPACE in Nyquist Manual.) (See ADD-ACTION-TO-WORKSPACE in Nyquist Manual.)
When the jNyqIDE wants to get the envelope data from the workspace, it When the NyquistIDE wants to get the envelope data from the workspace, it
should call (GET-ENV-DATA), which will dump formatted data to Nyquist's should call (GET-ENV-DATA), which will dump formatted data to Nyquist's
standard output as follows: standard output as follows:
@ -119,7 +119,7 @@ Saving the workspace automatically is something that Nyquist should do
(make-env-function name expression) (make-env-function name expression)
; make sure envelopes are redefined when workspace is loaded ; make sure envelopes are redefined when workspace is loaded
(add-to-workspace '*envelopes*) ; so *envelopes* will be saved (add-to-workspace '*envelopes*) ; so *envelopes* will be saved
(describe '*envelopes* "data for envelope editor in jNyqIDE") (describe '*envelopes* "data for envelope editor in NyquistIDE")
(add-action-to-workspace 'make-env-functions) (add-action-to-workspace 'make-env-functions)
nil) nil)

102
nyquist/fileio.lsp
View File

@ -33,6 +33,7 @@
(cond ((equal *default-sf-dir* "") (setf *default-sf-dir* path)))) (cond ((equal *default-sf-dir* "") (setf *default-sf-dir* path))))
;; s-save -- saves a file ;; s-save -- saves a file
(setf *in-s-save* nil)
(setf NY:ALL 1000000000) ; 1GIG constant for maxlen (setf NY:ALL 1000000000) ; 1GIG constant for maxlen
(defmacro s-save (expression &optional (maxlen NY:ALL) filename (defmacro s-save (expression &optional (maxlen NY:ALL) filename
&key (format '*default-sf-format*) &key (format '*default-sf-format*)
@ -42,27 +43,47 @@
`(let ((ny:fname ,filename) `(let ((ny:fname ,filename)
(ny:maxlen ,maxlen) (ny:maxlen ,maxlen)
(ny:endian ,endian) (ny:endian ,endian)
(ny:swap 0)) (ny:swap 0)
; allow caller to omit maxlen, in which case the filename will max-sample) ; return value
; be a string in the maxlen parameter position and filename will be null (cond (*in-s-save*
(cond ((null ny:fname) (error "Recursive call to s-save (maybe play?) detected!")))
(cond ((stringp ny:maxlen) (progv '(*in-s-save*) '(t)
(setf ny:fname ny:maxlen) ; allow caller to omit maxlen, in which case the filename will
(setf ny:maxlen NY:ALL)) ; be a string in the maxlen parameter position and filename will be null
(t (cond ((null ny:fname)
(setf ny:fname *default-sound-file*))))) (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 ((equal ny:fname "")
(cond ((not ,play) (cond ((not ,play)
(format t "s-save: no file to write! play option is off!\n")))) (format t "s-save: no file to write! play option is off!\n"))))
(t (t
(setf ny:fname (soundfilename ny:fname)) (setf ny:fname (soundfilename ny:fname))
(format t "Saving sound file to ~A~%" ny:fname))) (format t "Saving sound file to ~A~%" ny:fname)))
(cond ((eq ny:endian :big) (cond ((eq ny:endian :big)
(setf ny:swap (if (bigendianp) 0 1))) (setf ny:swap (if (bigendianp) 0 1)))
((eq ny:endian :little) ((eq ny:endian :little)
(setf ny:swap (if (bigendianp) 1 0)))) (setf ny:swap (if (bigendianp) 1 0))))
(snd-save ',expression ny:maxlen ny:fname ,format ,mode ,bits ny:swap ,play))) ; 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)))
;; MULTICHANNEL-MAX -- find peak over all channels ;; MULTICHANNEL-MAX -- find peak over all channels
;; ;;
@ -217,21 +238,21 @@
(local-to-global 0) format nchans mode bits swap srate (local-to-global 0) format nchans mode bits swap srate
dur))) dur)))
;; SF-INFO -- print sound file info ;; SF-INFO -- print sound file info
;; ;;
(defun sf-info (filename) (defun sf-info (filename)
(let (s format channels mode bits swap srate dur flags) (let (s format channels mode bits swap srate dur flags)
(format t "~A:~%" (soundfilename filename)) (format t "~A:~%" (soundfilename filename))
(setf s (s-read filename)) (setf s (s-read filename))
(setf format (car *rslt*)) (setf format (snd-read-format *rslt*))
(setf channels (cadr *rslt*)) (setf channels (snd-read-channels *rslt*))
(setf mode (caddr *rslt*)) (setf mode (snd-read-mode *rslt*))
(setf bits (cadddr *rslt*)) (setf bits (snd-read-bits *rslt*))
(setf *rslt* (cddddr *rslt*)) ; (setf swap (snd-read-swap *rslt*))
(setf swap (car *rslt*)) (setf srate (snd-read-srate *rslt*))
(setf srate (cadr *rslt*)) (setf dur (snd-read-dur *rslt*))
(setf dur (caddr *rslt*)) (setf flags (snd-read-flags *rslt*))
(setf flags (cadddr *rslt*))
(format t "Format: ~A~%" (format t "Format: ~A~%"
(nth format '("none" "AIFF" "IRCAM" "NeXT" "Wave" "PAF" "SVX" (nth format '("none" "AIFF" "IRCAM" "NeXT" "Wave" "PAF" "SVX"
"NIST" "VOC" "W64" "MAT4" "Mat5" "PVF" "XI" "HTK" "NIST" "VOC" "W64" "MAT4" "Mat5" "PVF" "XI" "HTK"
@ -290,14 +311,15 @@
filename) filename)
(setfn s-read-format car) (setfn snd-read-format car)
(setfn s-read-channels cadr) (setfn snd-read-channels cadr)
(setfn s-read-mode caddr) (setfn snd-read-mode caddr)
(setfn s-read-bits cadddr) (setfn snd-read-bits cadddr)
(defun s-read-swap (rslt) (car (cddddr rslt))) (defun snd-read-swap (rslt) (car (cddddr rslt)))
(defun s-read-srate (rslt) (cadr (cddddr rslt))) (defun snd-read-srate (rslt) (cadr (cddddr rslt)))
(defun s-read-dur (rslt) (caddr (cddddr rslt))) (defun snd-read-dur (rslt) (caddr (cddddr rslt)))
(defun s-read-byte-offset (rslt) (car (cddddr (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 ;; round is tricky because truncate rounds toward zero as does C
;; in other words, rounding is down for positive numbers and up ;; in other words, rounding is down for positive numbers and up
@ -328,7 +350,7 @@
:time-offset ny:offset) :time-offset ny:offset)
ny:addend) ny:addend)
ny:addend)) ny:addend))
,maxlen ny:fname ny:offset SND-HEAD-NONE 0 0 0 0.0)) ,maxlen ny:fname ny:offset SND-HEAD-NONE 0 0 0))
(format t "Duration written: ~A~%" (car *rslt*)) (format t "Duration written: ~A~%" (car *rslt*))
ny:peak)) ny:peak))
@ -338,9 +360,9 @@
(ny:peak 0.0) (ny:peak 0.0)
ny:input ny:rslt (ny:offset ,time-offset)) ny:input ny:rslt (ny:offset ,time-offset))
(format t "Overwriting ~A at offset ~A~%" ny:fname ny:offset) (format t "Overwriting ~A at offset ~A~%" ny:fname ny:offset)
(setf ny:offset (s-read-byte-offset ny:rslt)) (setf ny:offset (snd-read-byte-offset ny:rslt))
(setf ny:peak (snd-overwrite `,expr ,maxlen ny:fname ny:offset (setf ny:peak (snd-overwrite `,expr ,maxlen ny:fname ny:offset
SND-HEAD-NONE 0 0 0 0.0)) SND-HEAD-NONE 0 0 0))
(format t "Duration written: ~A~%" (car *rslt*)) (format t "Duration written: ~A~%" (car *rslt*))
ny:peak)) ny:peak))

70
nyquist/follow.lsp
View File

@ -1,70 +0,0 @@
;(set-control-srate 100)
;(set-sound-srate 100)
;(setf xx (pwl 0 1 1 0 1.1 1 1.8 0 2 1 3 0 5))
;(setf xx (pwl 0 1 1 .2 1.1 1 1.8 .2 2 1 3 0 5))
;(setf yy (snd-follow xx 0.1 0.25 1.0 30))
;(setf db-factor (/ 1.0 (log 0.00001)))
; COMPRESS-MAP -- constructs a map for the compress function
;
; The map consists of two parts: a compression part and an expansion part.
; The intended use is to compress everything above compress-threshold by
; compress-ratio, and to downward expand everything below expand-ratio
; by expand-ratio. Thresholds are in dB and ratios are dB-per-dB.
; 0dB corresponds to an amplitude of 1.0
; If the input goes above 0dB, the output can optionally be limited
; by seting limit-flag to T. This effectively changes the compression
; ratio to infinity at 0dB. If limit-flag is NIL, then the compression-ratio
; continues to apply above 0dB.
; It is assumed that expand-threshold <= compress-threshold <= 0
; The gain is unity at 0dB so if compression-ratio > 1, then gain
; will be greater than unity below 0dB
;(defun compress-map (compress-ratio compress-threshold expand-ratio
; expand-threshold limit-flag)
; (let ()
; (
;; I'm not sure if the rest of this function was lost due to version
;; problems, or it never existed. Email to rbd@cs.cmu.edu if you would
;; like some help with dynamics compression.
;;
;; Also, I had a really great 2-stage compressor for speech -- it did
;; something like a noise gate with a short time constant, and an automatic
;; gain control with a long time constant. Each one varied the gain by
;; about 12 dB -- any more would cause really ugly noise pumping, but
;; without the combined actions of both, there was not enough control.
;; Again, email me if you are interested. Lately, I've been using
;; more sophisticated multiple band noise reduction in Cool Edit. They
;; obviously put a lot of work into that, and I don't plan to redo the
;; work for Nyquist. -RBD
(defun compress (input map rise-time fall-time)
; take the square of the input to get power
(let ((in-squared (mult input input)))
; compute the time-average (sort of a low-pass) of the square
(setf avg (snd-avg in-squared 1000 500 OP-AVERAGE))
; use follower to anticipate rise and trail off smoothly
(setf env (snd-follow avg 0.001 0.2 1.0 20))
; take logarithm to get dB instead of linear
(setf logenv (snd-log env))
; tricky part: map converts dB of input to desired gain in dB
; this defines the character of the compressor
(setf shaped-env (shape logenv map 1.0))
; go back to linear
(setf gain (snd-exp shaped-env))
; return the scaled input sound,
; another trick: avg signal will be delayed. Also, snd-follow
; has a delayed response because it's looking ahead in sound
; 20 = the number of samples of lookahead from snd-follow
; 88.2 = 44,100 (sample rate) / 500 (the step-size in avg)
; in other words, 44100/500 is the sample rate of the control
; signal looked at by follow
; "44100" should be replace by the signal's sample rate
; = (snd-srate input)
(mult (seq (s-rest (/ 20.0 88.2)) (cue input)) gain)))

78
nyquist/init.lsp
View File

@ -6,81 +6,3 @@
; (load "test.lsp") ; (load "test.lsp")
;; "_" (UNDERSCORE) - translation function
;;
;; Third party plug-ins are not translated by gettext in Audacity, but may include a
;; list of translations named *locale*. The format of *locale* must be:
;; (LIST (language-list) [(language-list) ...])
;; Each language-list is an a-list in the form:
;; ("cc" ((list "string" "translated-string") [(list "string" "translated-string") ...]))
;; where "cc" is the quoted country code.
;;
(setfn underscore _)
;;
(defun _(txt &aux newtxt)
(when (boundp '*locale*)
(when (not (listp *locale*))
(error "bad argument type" *locale*))
(let* ((cc (get '*audacity* 'language))
(translations (second (assoc cc *locale* :test 'string-equal))))
(if translations
(let ((translation (second (assoc txt translations :test 'string=))))
(if translation
(if (stringp translation)
(setf newtxt translation)
(error "bad argument type" translation))
(format t "No ~s translation of ~s.~%" cc txt)))
(progn
(setf *locale* '*unbound*)
(format t "No ~s translations.~%" cc)))))
(if newtxt newtxt (underscore txt)))
;;; Some helpers for parsing strings returned by (aud-do "GetInfo: ...
(defun eval-string (string)
;;; Evaluate a string as a LISP expression.
;;; If 'string' is not a valid LISP expression, the behaviour is undefined.
(eval (read (make-string-input-stream string))))
(defmacro quote-string (string)
;;; Prepend a single quote to a string
`(setf ,string (format nil "\'~a" ,string)))
(defun aud-get-info (str)
;;; Return "GetInfo: type=type" as Lisp list, or throw error
;;; Audacity 2.3.0 does not fail if type is not recognised, it
;;; falls back to a default, so test for valid types.
;;; 'Commands+' is not supported in Audacity 2.3.0
(let (type
info
(types '("Commands" "Menus" "Preferences"
"Tracks" "Clips" "Envelopes" "Labels" "Boxes")))
;Case insensitive search, then set 'type' with correct case string, or NIL.
(setf type (first (member str types :test 'string-equal)))
(if (not type)
(error (format nil "bad argument '~a' in (aud-get-info ~a)" str str)))
(setf info (aud-do (format nil "GetInfo: type=~a format=LISP" type)))
(if (not (last info))
(error (format nil "(aud-get-info ~a) failed.~%" str)))
(let* ((info-string (first info))
(sanitized ""))
;; Escape backslashes
(dotimes (i (length info-string))
(setf ch (subseq info-string i (1+ i)))
(if (string= ch "\\")
(string-append sanitized "\\\\")
(string-append sanitized ch)))
(eval-string (quote-string sanitized)))))
;;; *NYQ-PATH* is not required as path to Nyquist .lsp files
;;; is already defined (but not previously documented) as *runtime-path*
;;(setf *NYQ-PATH* (current-path))
;;; Load wrapper functions for aud-do commands.
;;; If commented out, "aud-do-support.lsp" may be loaded by a plug-in.
;;; Example: (lisp-loader (strcat *runtime-path* "aud-do-support.lsp"))
(load "aud-do-support.lsp")

43
nyquist/misc.lsp
View File

@ -42,7 +42,8 @@
; Typically, you want this on. ; Typically, you want this on.
; *xlisp-traceback* -- print XLISP traceback on error in XLISP mode ; *xlisp-traceback* -- print XLISP traceback on error in XLISP mode
; Typically, you do not want this because the full ; Typically, you do not want this because the full
; stack can be long and tedious. ; stack can be long and tedious. Also allow XLISP
; traceback in SAL mode if *sal-break* is true.
(setf *sal-mode* nil) (setf *sal-mode* nil)
@ -192,3 +193,43 @@
;; search for either .lsp or .sal file ;; search for either .lsp or .sal file
(sal-load ,file-name))) (sal-load ,file-name)))
;; COMPUTE-DEFAULT-SOUND-FILE -- construct and set *default-sound-file*
;;
;; (this is harder than it might seem because the default place for
;; sound files is in /tmp, which is shared by users, so we'd like to
;; use a user-specific name to avoid collisions)
;;
(defun compute-default-sound-file ()
(let (inf user extension)
; the reason for the user name is that if UserA creates a temp file,
; then UserB will not be able to overwrite it. The user name is a
; way to give each user a unique temp file name. Note that we don't
; want each session to generate a unique name because Nyquist doesn't
; delete the sound file at the end of the session.
(setf user (get-user))
#|
(cond ((null user)
(format t
"Please type your user-id so that I can construct a default
sound-file name. To avoid this message in the future, add
this to your .login file:
setenv USER <your id here>
or add this to your init.lsp file:
(setf *default-sound-file* \"<your filename here>\")
(setf *default-sf-dir* \"<full pathname of desired directory here>\")
Your id please: ")
(setf user (read))))
|#
; now compute the extension based on *default-sf-format*
(cond ((= *default-sf-format* snd-head-AIFF)
(setf extension ".aif"))
((= *default-sf-format* snd-head-Wave)
(setf extension ".wav"))
(t
(setf extension ".snd")))
(setf *default-sound-file*
(strcat (string-downcase user) "-temp" extension))
(format t "Default sound file is ~A.~%" *default-sound-file*)))

38
nyquist/nyinit-dbg.lsp Normal file
View File

@ -0,0 +1,38 @@
(expand 5)
(load "xlinit.lsp" :verbose NIL)
(setf *gc-flag* nil)
(load "misc.lsp" :verbose NIL)
(load "evalenv.lsp" :verbose NIL)
(load "printrec.lsp" :verbose NIL)
(load "sndfnint.lsp" :verbose NIL)
(load "seqfnint.lsp" :verbose NIL)
(load "velocity.lsp" :verbose NIL) ; linear-to-vel etc
(load "nyquist-dbg.lsp" :verbose NIL)
(load "compress.lsp" :verbose NIL)
(load "system.lsp" :verbose NIL)
(load "seqmidi.lsp" :verbose NIL)
(load "nyqmisc.lsp" :verbose NIL)
(load "stk.lsp" :verbose NIL)
(load "envelopes.lsp" :verbose NIL)
(load "equalizer.lsp" :verbose NIL)
(load "xm.lsp" :verbose NIL)
(load "sal.lsp" :verbose NIL)
;; set to T to get ANSI headers and NIL to get antique headers
(setf *ANSI* NIL)
;; set to T to generate tracing code, NIL to disable tracing code
(setf *WATCH* NIL)
(format t "~%Nyquist -- A Language for Sound Synthesis and Composition~%")
(format t " Copyright (c) 1991,1992,1995,2007-2012 by Roger B. Dannenberg~%")
(format t " Version 3.10~%~%")
;(setf *gc-flag* t)

18
nyquist/nyinit.lsp
View File

@ -3,18 +3,18 @@
(load "xlinit.lsp" :verbose NIL) (load "xlinit.lsp" :verbose NIL)
(setf *gc-flag* nil) (setf *gc-flag* nil)
(load "misc.lsp" :verbose NIL) (load "misc.lsp" :verbose NIL)
;; now compute-default-sound-file is defined; needed by system.lsp ...
(load "evalenv.lsp" :verbose NIL) (load "evalenv.lsp" :verbose NIL)
(load "printrec.lsp" :verbose NIL) (load "printrec.lsp" :verbose NIL)
(load "sndfnint.lsp" :verbose NIL) (load "sndfnint.lsp" :verbose NIL)
(load "seqfnint.lsp" :verbose NIL) (load "seqfnint.lsp" :verbose NIL)
(load "dspprims.lsp" :verbose NIL)
(load "velocity.lsp" :verbose NIL) ; linear-to-vel etc (load "velocity.lsp" :verbose NIL) ; linear-to-vel etc
(load "nyquist.lsp" :verbose NIL)
(load "follow.lsp" :verbose NIL)
(load "system.lsp" :verbose NIL) (load "system.lsp" :verbose NIL)
;; now *file-separator* is defined, used by nyquist.lsp...
(load "nyquist.lsp" :verbose NIL)
(load "seqmidi.lsp" :verbose NIL) (load "seqmidi.lsp" :verbose NIL)
(load "nyqmisc.lsp" :verbose NIL) (load "nyqmisc.lsp" :verbose NIL)
@ -24,15 +24,11 @@
(load "xm.lsp" :verbose NIL) (load "xm.lsp" :verbose NIL)
(load "sal.lsp" :verbose NIL) (load "sal.lsp" :verbose NIL)
;; set to T to get ANSI headers and NIL to get antique headers
(setf *ANSI* NIL)
;; set to T to generate tracing code, NIL to disable tracing code
(setf *WATCH* NIL)
(format t "~%Nyquist -- A Language for Sound Synthesis and Composition~%") (format t "~%Nyquist -- A Language for Sound Synthesis and Composition~%")
(format t " Copyright (c) 1991,1992,1995,2007-2012 by Roger B. Dannenberg~%") (format t " Copyright (c) 1991,1992,1995,2007-2018 by Roger B. Dannenberg~%")
(format t " Version 3.09~%~%") (format t " Version 3.15~%~%")
(load "extensions.lsp" :verbose NIL)
;(setf *gc-flag* t) ;(setf *gc-flag* t)

1478
nyquist/nyquist.lsp
View File

File diff suppressed because it is too large Load Diff

576
nyquist/sal-parse.lsp
View File

@ -15,11 +15,11 @@
(setfn nreverse reverse) (setfn nreverse reverse)
(defconstant +quote+ #\") ; "..." string (defconstant +quote+ #\") ; "..." string
(defconstant +kwote+ #\') ; '...' kwoted expr (defconstant +kwote+ #\') ; '...' kwoted expr
(defconstant +comma+ #\,) ; positional arg delimiter (defconstant +comma+ #\,) ; positional arg delimiter
(defconstant +pound+ #\#) ; for bools etc (defconstant +pound+ #\#) ; for bools etc
(defconstant +semic+ #\;) ; comment char (defconstant +semic+ #\;) ; comment char
(defconstant +lbrace+ #\{) ; {} list notation (defconstant +lbrace+ #\{) ; {} list notation
(defconstant +rbrace+ #\}) (defconstant +rbrace+ #\})
(defconstant +lbrack+ #\[) ; unused for now (defconstant +lbrack+ #\[) ; unused for now
@ -45,7 +45,7 @@
(defparameter +operators+ (defparameter +operators+
;; each op is: (<token-class> <sal-name> <lisp-form>) ;; each op is: (<token-class> <sal-name> <lisp-form>)
'((:+ "+" sum) '((:+ "+" sal-plus)
(:- "-" diff) (:- "-" diff)
(:* "*" mult) (:* "*" mult)
(:/ "/" /) (:/ "/" /)
@ -57,7 +57,7 @@
(:> ">" >) (:> ">" >)
(:<= "<=" <=) ; leq and assignment minimization (:<= "<=" <=) ; leq and assignment minimization
(:>= ">=" >=) ; geq and assignment maximization (:>= ">=" >=) ; geq and assignment maximization
(:~= "~=" equal) ; general equality (:~= "~=" sal-about-equal) ; general equality
(:+= "+=" +=) ; assignment increment-and-store (:+= "+=" +=) ; assignment increment-and-store
(:-= "-=" -=) ; assignment increment-and-store (:-= "-=" -=) ; assignment increment-and-store
(:*= "*=" *=) ; assignment multiply-and-store (:*= "*=" *=) ; assignment multiply-and-store
@ -84,13 +84,13 @@
(defparameter +delimiters+ (defparameter +delimiters+
'((:lp #\() '((:lp #\()
(:rp #\)) (:rp #\))
(:lc #\{) ; left curly (:lc #\{) ; left curly
(:rc #\}) (:rc #\})
(:lb #\[) (:lb #\[)
(:rb #\]) (:rb #\])
(:co #\,) (:co #\,)
(:kw #\') ; kwote (:kw #\') ; kwote
(nil #\") ; not token (nil #\") ; not token
; (nil #\#) ; (nil #\#)
(nil #\;) (nil #\;)
)) ))
@ -112,7 +112,7 @@
(:END "end") (:VARIABLE "variable") (:END "end") (:VARIABLE "variable")
(:FUNCTION "function") (:PROCESS "process") (:FUNCTION "function") (:PROCESS "process")
(:CHDIR "chdir") (:DEFINE "define") (:LOAD "load") (:CHDIR "chdir") (:DEFINE "define") (:LOAD "load")
(:PLAY "play") (:PLAY "play") (:PLOT "plot")
(:EXEC "exec") (:exit "exit") (:DISPLAY "display") (:EXEC "exec") (:exit "exit") (:DISPLAY "display")
(:~ "~") (:~~ "~~") (:@ ":@") (:@@ ":@@"))) (:~ "~") (:~~ "~~") (:@ ":@") (:@@ ":@@")))
@ -138,7 +138,7 @@
(defmacro errexit (message &optional start) (defmacro errexit (message &optional start)
`(parse-error (make-sal-error :type "parse" `(parse-error (make-sal-error :type "parse"
:line *sal-input-text* :text ,message :line *sal-input-text* :text ,message
:start ,(sal-tokens-error-start start)))) :start ,(sal-tokens-error-start start))))
(defmacro sal-warning (message &optional start) (defmacro sal-warning (message &optional start)
@ -187,7 +187,7 @@
(defun pperror (x &optional (msg-type "error")) (defun pperror (x &optional (msg-type "error"))
(let* ((source (sal-error-line x)) (let* ((source (sal-error-line x))
(llen (length source)) (llen (length source))
line-no line-no
beg end) beg end)
; (display "pperror" x (strcat "|" (sal-error-line x) "|")) ; (display "pperror" x (strcat "|" (sal-error-line x) "|"))
@ -195,17 +195,17 @@
(setf beg (sal-error-start x)) (setf beg (sal-error-start x))
(setf beg (min beg (1- llen))) (setf beg (min beg (1- llen)))
(do ((i beg (- i 1)) (do ((i beg (- i 1))
(n nil)) ; n gets set when we find a newline (n nil)) ; n gets set when we find a newline
((or (< i 0) n) ((or (< i 0) n)
(setq beg (or n 0))) (setq beg (or n 0)))
(if (char= (char source i) #\newline) (if (char= (char source i) #\newline)
(setq n (+ i 1)))) (setq n (+ i 1))))
(do ((i (sal-error-start x) (+ i 1)) (do ((i (sal-error-start x) (+ i 1))
(n nil)) (n nil))
((or (>= i llen) n) ((or (>= i llen) n)
(setq end (or n llen))) (setq end (or n llen)))
(if (char= (char source i) #\newline) (if (char= (char source i) #\newline)
(setq n i))) (setq n i)))
(setf line-no (pos-to-line beg source)) (setf line-no (pos-to-line beg source))
; (display "pperror" beg end (sal-error-start x)) ; (display "pperror" beg end (sal-error-start x))
@ -213,17 +213,17 @@
;; the error as well as a line below it marking the error position ;; the error as well as a line below it marking the error position
;; with an arrow: ^ ;; with an arrow: ^
(let* ((pos (- (sal-error-start x) beg)) (let* ((pos (- (sal-error-start x) beg))
(line (if (and (= beg 0) (= end llen)) (line (if (and (= beg 0) (= end llen))
source source
(subseq source beg end))) (subseq source beg end)))
(mark (make-spaces pos))) (mark (make-spaces pos)))
(format t "~%>>> ~A ~A: ~A.~%>>> in ~A, line ~A, col ~A.~%~%~A~%~A^~%" (format t "~%>>> ~A ~A: ~A.~%>>> in ~A, line ~A, col ~A.~%~%~A~%~A^~%"
(sal-error-type x) msg-type (sal-error-text x) (sal-error-type x) msg-type (sal-error-text x)
*sal-input-file-name* line-no (1+ pos) *sal-input-file-name* line-no (1+ pos)
line mark) line mark)
; (format t "~%>>> ~A error in \"~A\", line ~A, col ~A: ~A.~%~%~A~%~A^~%" ; (format t "~%>>> ~A error in \"~A\", line ~A, col ~A: ~A.~%~%~A~%~A^~%"
; (sal-error-type x) *sal-input-file-name* line-no pos ; (sal-error-type x) *sal-input-file-name* line-no pos
; (sal-error-text x) line mark) ; (sal-error-text x) line mark)
x))) x)))
@ -238,21 +238,21 @@
(do ((i start ) (do ((i start )
(p nil)) (p nil))
((or p (if (< start end) ((or p (if (< start end)
(not (< -1 i end)) (not (< -1 i end))
(not (> i end -1)))) (not (> i end -1))))
(or p end)) (or p end))
(cond ((consp white) (cond ((consp white)
(unless (member (char str i) white :test #'char=) (unless (member (char str i) white :test #'char=)
(setq p i))) (setq p i)))
((characterp white) ((characterp white)
(unless (char= (char str i) white) (unless (char= (char str i) white)
(setq p i))) (setq p i)))
((functionp white) ((functionp white)
(unless (funcall white (char str i)) (unless (funcall white (char str i))
(setq p i)))) (setq p i))))
(if (< start end) (if (< start end)
(incf i) (incf i)
(decf i)))) (decf i))))
(defun search-delim (str delim start end) (defun search-delim (str delim start end)
@ -263,14 +263,14 @@
((or (not (< i end)) p) ((or (not (< i end)) p)
(or p end)) (or p end))
(cond ((consp delim) (cond ((consp delim)
(if (member (char str i) delim :test #'char=) (if (member (char str i) delim :test #'char=)
(setq p i))) (setq p i)))
((characterp delim) ((characterp delim)
(if (char= (char str i) delim) (if (char= (char str i) delim)
(setq p i))) (setq p i)))
((functionp delim) ((functionp delim)
(if (funcall delim (char str i)) (if (funcall delim (char str i))
(setq p i)))))) (setq p i))))))
;; UNBALANCED-INPUT AND TOKENIZE HAVE BEEN REWRITTEN, SEE BELOW. THIS ONE IS ;; UNBALANCED-INPUT AND TOKENIZE HAVE BEEN REWRITTEN, SEE BELOW. THIS ONE IS
@ -303,45 +303,45 @@
(incf n)))) (incf n))))
(errexit text pos))) (errexit text pos)))
;; REMINDER: THIS IS PART OF A BIG BLOCK COMMENT
(defun tokenize (str reserved error-fn) (defun tokenize (str reserved error-fn)
;&key (start 0) (end (length str)) ;&key (start 0) (end (length str))
; (white-space +whites+) (delimiters +delimiters+) ; (white-space +whites+) (delimiters +delimiters+)
; (operators +operators+) (null-ok t) ; (operators +operators+) (null-ok t)
; (keyword-style +kwstyle+) (reserved nil) ; (keyword-style +kwstyle+) (reserved nil)
; (error-fn nil) ; (error-fn nil)
; &allow-other-keys) ; &allow-other-keys)
;; return zero or more tokens or a sal-error ;; return zero or more tokens or a sal-error
(let ((toks (list t)) (let ((toks (list t))
(start 0) (start 0)
(end (length str)) (end (length str))
(all-delimiters +whites+) (all-delimiters +whites+)
(errf (or error-fn (errf (or error-fn
(lambda (x) (pperror x) (return-from tokenize x))))) (lambda (x) (pperror x) (return-from tokenize x)))))
(dolist (x +delimiters+) (dolist (x +delimiters+)
(push (cadr x) all-delimiters)) (push (cadr x) all-delimiters))
(do ((beg start) (do ((beg start)
(pos nil) (pos nil)
(all all-delimiters) (all all-delimiters)
(par 0) (par 0)
(bra 0) (bra 0)
(brk 0) (brk 0)
(kwo 0) (kwo 0)
(tok nil) (tok nil)
(tail toks)) (tail toks))
((not (< beg end)) ((not (< beg end))
;; since input is complete check parens levels. ;; since input is complete check parens levels.
(if (= 0 par bra brk kwo) (if (= 0 par bra brk kwo)
(if (null (cdr toks)) (if (null (cdr toks))
(list) (list)
(cdr toks)) (cdr toks))
(unbalanced-input errf str (reverse (cdr toks)) (unbalanced-input errf str (reverse (cdr toks))
par bra brk kwo))) par bra brk kwo)))
(setq beg (advance-white str +whites+ beg end)) (setq beg (advance-white str +whites+ beg end))
(setf tok (setf tok
(read-delimited str :start beg :end end (read-delimited str :start beg :end end
:white +whites+ :delimit all :white +whites+ :delimit all
:skip-initial-white nil :errorf errf)) :skip-initial-white nil :errorf errf))
;; multiple values are returned, so split them here: ;; multiple values are returned, so split them here:
(setf pos (second tok)) ; pos is the end of the token (!) (setf pos (second tok)) ; pos is the end of the token (!)
(setf tok (first tok)) (setf tok (first tok))
@ -349,29 +349,29 @@
;; tok now string, char (delimiter), :eof or token since input ;; tok now string, char (delimiter), :eof or token since input
;; is complete keep track of balancing delims ;; is complete keep track of balancing delims
(cond ((eql tok +lbrace+) (incf bra)) (cond ((eql tok +lbrace+) (incf bra))
((eql tok +rbrace+) (decf bra)) ((eql tok +rbrace+) (decf bra))
((eql tok +lparen+) (incf par)) ((eql tok +lparen+) (incf par))
((eql tok +rparen+) (decf par)) ((eql tok +rparen+) (decf par))
((eql tok +lbrack+) (incf brk)) ((eql tok +lbrack+) (incf brk))
((eql tok +rbrack+) (decf brk)) ((eql tok +rbrack+) (decf brk))
((eql tok +kwote+) (setq kwo (mod (+ kwo 1) 2)))) ((eql tok +kwote+) (setq kwo (mod (+ kwo 1) 2))))
(cond ((eql tok ':eof) (cond ((eql tok ':eof)
(setq beg end)) (setq beg end))
(t (t
;; may have to skip over comments to reach token, so ;; may have to skip over comments to reach token, so
;; token beginning is computed by backing up from current ;; token beginning is computed by backing up from current
;; position (returned by read-delimited) by string length ;; position (returned by read-delimited) by string length
(setf beg (if (stringp tok) (setf beg (if (stringp tok)
(- pos (length tok)) (- pos (length tok))
(1- pos))) (1- pos)))
(setq tok (classify-token tok beg str errf (setq tok (classify-token tok beg str errf
+delimiters+ +operators+ +delimiters+ +operators+
+kwstyle+ reserved)) +kwstyle+ reserved))
;(display "classify-token-result" tok) ;(display "classify-token-result" tok)
(setf (cdr tail) (list tok )) (setf (cdr tail) (list tok ))
(setf tail (cdr tail)) (setf tail (cdr tail))
(setq beg pos)))))) (setq beg pos))))))
|# |#
@ -422,53 +422,53 @@
(start 0) (start 0)
(end (length str)) (end (length str))
(all-delimiters +whites+) (all-delimiters +whites+)
(errf (or error-fn (errf (or error-fn
(lambda (x) (pperror x) (return-from tokenize x))))) (lambda (x) (pperror x) (return-from tokenize x)))))
(dolist (x +delimiters+) (dolist (x +delimiters+)
(push (cadr x) all-delimiters)) (push (cadr x) all-delimiters))
(delimiter-init) (delimiter-init)
(do ((beg start) (do ((beg start)
(pos nil) (pos nil)
(all all-delimiters) (all all-delimiters)
(tok nil) (tok nil)
(tail toks)) (tail toks))
((not (< beg end)) ((not (< beg end))
;; since input is complete check parens levels. ;; since input is complete check parens levels.
(delimiter-finish) (delimiter-finish)
(if (null (cdr toks)) nil (cdr toks))) (if (null (cdr toks)) nil (cdr toks)))
(setq beg (advance-white str +whites+ beg end)) (setq beg (advance-white str +whites+ beg end))
(setf tok (setf tok
(read-delimited str :start beg :end end (read-delimited str :start beg :end end
:white +whites+ :delimit all :white +whites+ :delimit all
:skip-initial-white nil :errorf errf)) :skip-initial-white nil :errorf errf))
;; multiple values are returned, so split them here: ;; multiple values are returned, so split them here:
(setf pos (second tok)) ; pos is the end of the token (!) (setf pos (second tok)) ; pos is the end of the token (!)
(setf tok (first tok)) (setf tok (first tok))
(cond ((eql tok ':eof) (cond ((eql tok ':eof)
(setq beg end)) (setq beg end))
(t (t
;; may have to skip over comments to reach token, so ;; may have to skip over comments to reach token, so
;; token beginning is computed by backing up from current ;; token beginning is computed by backing up from current
;; position (returned by read-delimited) by string length ;; position (returned by read-delimited) by string length
(setf beg (if (stringp tok) (setf beg (if (stringp tok)
(- pos (length tok)) (- pos (length tok))
(1- pos))) (1- pos)))
(setq tok (classify-token tok beg str errf (setq tok (classify-token tok beg str errf
+delimiters+ +operators+ +delimiters+ +operators+
+kwstyle+ reserved)) +kwstyle+ reserved))
(delimiter-check tok) (delimiter-check tok)
;(display "classify-token-result" tok) ;(display "classify-token-result" tok)
(setf (cdr tail) (list tok )) (setf (cdr tail) (list tok ))
(setf tail (cdr tail)) (setf tail (cdr tail))
(setq beg pos)))))) (setq beg pos))))))
(defun read-delimited (input &key (start 0) end (null-ok t) (defun read-delimited (input &key (start 0) end (null-ok t)
(delimit +delims+) ; includes whites... (delimit +delims+) ; includes whites...
(white +whites+) (white +whites+)
(skip-initial-white t) (skip-initial-white t)
(errorf #'pperror)) (errorf #'pperror))
;; read a substring from input, optionally skipping any white chars ;; read a substring from input, optionally skipping any white chars
;; first. reading a comment delim equals end-of-line, input delim ;; first. reading a comment delim equals end-of-line, input delim
;; reads whole input, pound reads next token. call errf if error ;; reads whole input, pound reads next token. call errf if error
@ -478,10 +478,10 @@
(when skip-initial-white (when skip-initial-white
(setq start (advance-white input white start len))) (setq start (advance-white input white start len)))
(if (< start len) (if (< start len)
(let ((char (char input start))) (let ((char (char input start)))
(setq end (search-delim input delimit start len)) (setq end (search-delim input delimit start len))
(if (equal start end) ; have a delimiter (if (equal start end) ; have a delimiter
(cond ((char= char +semic+) (cond ((char= char +semic+)
;; comment skips to next line and trys again... ;; comment skips to next line and trys again...
(while (and (< start len) (while (and (< start len)
(char/= (char input start) #\newline)) (char/= (char input start) #\newline))
@ -493,22 +493,22 @@
(return (list ':eof end))) (return (list ':eof end)))
(t (t
(errexit "Unexpected end of input")))) (errexit "Unexpected end of input"))))
; ((char= char +pound+) ; ((char= char +pound+)
; ;; read # dispatch ; ;; read # dispatch
; (read-hash input delimit start len errorf)) ; (read-hash input delimit start len errorf))
((char= char +quote+) ((char= char +quote+)
;; input delim reads whole input ;; input delim reads whole input
(return (sal:read-string input delimit start len errorf))) (return (sal:read-string input delimit start len errorf)))
((char= char +kwote+) ((char= char +kwote+)
(errexit "Illegal delimiter" start)) (errexit "Illegal delimiter" start))
(t ;; all other delimiters are tokens in and of themselves (t ;; all other delimiters are tokens in and of themselves
(return (list char (+ start 1))))) (return (list char (+ start 1)))))
; else part of (equal start end), so we have token before delimiter ; else part of (equal start end), so we have token before delimiter
(return (list (subseq input start end) end)))) (return (list (subseq input start end) end))))
; else part of (< start len)... ; else part of (< start len)...
(if null-ok (if null-ok
(return (list ':eof end)) (return (list ':eof end))
(errexit "Unexpected end of input" start)))))) (errexit "Unexpected end of input" start))))))
(defparameter hash-readers (defparameter hash-readers
@ -521,18 +521,18 @@
(defun read-hash (str delims pos len errf) (defun read-hash (str delims pos len errf)
(let ((e (+ pos 1))) (let ((e (+ pos 1)))
(if (< e len) (if (< e len)
(let ((a (assoc (char str e) hash-readers))) (let ((a (assoc (char str e) hash-readers)))
(if (not a) (if (not a)
(errexit "Illegal # character" e) (errexit "Illegal # character" e)
(funcall (cadr a) str delims e len errf))) (funcall (cadr a) str delims e len errf)))
(errexit "Missing # character" pos)))) (errexit "Missing # character" pos))))
(defun read-iftok (str delims pos len errf) (defun read-iftok (str delims pos len errf)
str delims len errf str delims len errf
(list (make-token :type ':? :string "#?" :lisp 'if (list (make-token :type ':? :string "#?" :lisp 'if
:start (- pos 1)) :start (- pos 1))
(+ pos 1))) (+ pos 1)))
; (sal:read-string str start len) ; (sal:read-string str start len)
@ -544,8 +544,8 @@
(list (let ((t? (char= (char str pos) #\t) )) (list (let ((t? (char= (char str pos) #\t) ))
(make-token :type ':bool (make-token :type ':bool
:string (if t? "#t" "#f") :string (if t? "#t" "#f")
:lisp t? :lisp t?
:start (- pos 1))) :start (- pos 1)))
(+ pos 1)))) (+ pos 1))))
@ -603,8 +603,8 @@
(defmethod token-print (obj stream) (defmethod token-print (obj stream)
(let ((*print-case* ':downcase)) (let ((*print-case* ':downcase))
(format stream "#<~s ~s>" (format stream "#<~s ~s>"
(token-type obj) (token-type obj)
(token-string obj)))) (token-string obj))))
(defun parse-token () (defun parse-token ()
(prog1 (car *sal-tokens*) (prog1 (car *sal-tokens*)
@ -617,19 +617,19 @@
(defun classify-token (str pos input errf delims ops kstyle res) (defun classify-token (str pos input errf delims ops kstyle res)
(let ((tok nil)) (let ((tok nil))
(cond ((characterp str) (cond ((characterp str)
;; normalize char delimiter tokens ;; normalize char delimiter tokens
(setq tok (delimiter-token? str pos input errf delims))) (setq tok (delimiter-token? str pos input errf delims)))
((stringp str) ((stringp str)
(setq tok (or (number-token? str pos input errf) (setq tok (or (number-token? str pos input errf)
(operator-token? str pos input errf ops) (operator-token? str pos input errf ops)
(keyword-token? str pos input errf kstyle) (keyword-token? str pos input errf kstyle)
(class-token? str pos input errf res) (class-token? str pos input errf res)
(reserved-token? str pos input errf res) (reserved-token? str pos input errf res)
(symbol-token? str pos input errf) (symbol-token? str pos input errf)
)) ))
(unless tok (unless tok
(errexit "Not an expression or symbol" pos))) (errexit "Not an expression or symbol" pos)))
(t (setq tok str))) (t (setq tok str)))
tok)) tok))
@ -638,9 +638,9 @@
;; member returns remainder of the list ;; member returns remainder of the list
;(display "delimiter-token?" str delims typ) ;(display "delimiter-token?" str delims typ)
(if (and typ (car typ) (caar typ)) (if (and typ (car typ) (caar typ))
(make-token :type (caar typ) :string str (make-token :type (caar typ) :string str
:start pos) :start pos)
(+ (break) (errexit "Shouldn't: non-token delimiter" pos))))) (+ (break) (errexit "Shouldn't: non-token delimiter" pos)))))
(defun string-to-number (s) (defun string-to-number (s)
@ -660,30 +660,30 @@
(non nil)) (non nil))
((or (not (< i len)) non) ((or (not (< i len)) non)
(if non nil (if non nil
(if (> dig 0) (if (> dig 0)
(make-token :type typ :string str (make-token :type typ :string str
:start pos :lisp (string-to-number str)) :start pos :lisp (string-to-number str))
nil))) nil)))
(setq c (char str i)) (setq c (char str i))
(cond ((member c '(#\+ #\-)) (cond ((member c '(#\+ #\-))
(if (> i 0) (setq non t) (if (> i 0) (setq non t)
(incf sig))) (incf sig)))
((char= c #\.) ((char= c #\.)
(if (> dot 0) (setq non t) (if (> dot 0) (setq non t)
(if (> sla 0) (setq non t) (if (> sla 0) (setq non t)
(incf dot)))) (incf dot))))
; xlisp does not have ratios ; xlisp does not have ratios
; ((char= c #\/) ; ((char= c #\/)
; (setq typ ':ratio) ; (setq typ ':ratio)
; (if (> sla 0) (setq non t) ; (if (> sla 0) (setq non t)
; (if (= dig 0) (setq non t) ; (if (= dig 0) (setq non t)
; (if (> dot 0) (setq non t) ; (if (> dot 0) (setq non t)
; (if (= i (1- len)) (setq non t) ; (if (= i (1- len)) (setq non t)
; (incf sla)))))) ; (incf sla))))))
((digit-char-p c) ((digit-char-p c)
(incf dig) (incf dig)
(if (> dot 0) (setq typ ':float))) (if (> dot 0) (setq typ ':float)))
(t (setq non t))))) (t (setq non t)))))
#|| #||
(number-token? "" 0 "" #'pperror) (number-token? "" 0 "" #'pperror)
@ -712,8 +712,8 @@
(cond (typ (cond (typ
(setf typ (car typ)) ;; member returns remainder of list (setf typ (car typ)) ;; member returns remainder of list
(make-token :type (car typ) :string str (make-token :type (car typ) :string str
:start pos :lisp (or (third typ) :start pos :lisp (or (third typ)
(read-from-string str))))))) (read-from-string str)))))))
(defun str-to-keyword (str) (defun str-to-keyword (str)
(intern (strcat ":" (string-upcase str)))) (intern (strcat ":" (string-upcase str))))
@ -721,40 +721,40 @@
(defun keyword-token? (tok pos input errf style) (defun keyword-token? (tok pos input errf style)
(let* ((tlen (length tok)) (let* ((tlen (length tok))
(keys (cdr style)) (keys (cdr style))
(klen (length keys))) (klen (length keys)))
(cond ((not (< klen tlen)) nil) (cond ((not (< klen tlen)) nil)
((eql (car style) ':prefix) ((eql (car style) ':prefix)
(do ((i 0 (+ i 1)) (do ((i 0 (+ i 1))
(x nil)) (x nil))
((or (not (< i klen)) x) ((or (not (< i klen)) x)
(if (not x) (if (not x)
(let ((sym (symbol-token? (subseq tok i) (let ((sym (symbol-token? (subseq tok i)
pos input errf ))) pos input errf )))
(cond (sym (cond (sym
(set-token-type sym ':key) (set-token-type sym ':key)
(set-token-lisp sym (set-token-lisp sym
(str-to-keyword (token-string sym))) (str-to-keyword (token-string sym)))
sym))) sym)))
nil)) nil))
(unless (char= (char tok i) (nth i keys)) (unless (char= (char tok i) (nth i keys))
(setq x t)))) (setq x t))))
((eql (car style) ':suffix) ((eql (car style) ':suffix)
(do ((j (- tlen klen) (+ j 1)) (do ((j (- tlen klen) (+ j 1))
(i 0 (+ i 1)) (i 0 (+ i 1))
(x nil)) (x nil))
((or (not (< i klen)) x) ((or (not (< i klen)) x)
(if (not x) (if (not x)
(let ((sym (symbol-token? (subseq tok 0 (- tlen klen)) (let ((sym (symbol-token? (subseq tok 0 (- tlen klen))
pos input errf ))) pos input errf )))
(cond (sym (cond (sym
(set-token-type sym ':key) (set-token-type sym ':key)
(set-token-lisp sym (set-token-lisp sym
(str-to-keyword (token-string sym))) (str-to-keyword (token-string sym)))
sym))) sym)))
nil)) nil))
(unless (char= (char tok j) (nth i keys)) (unless (char= (char tok j) (nth i keys))
(setq x t))))))) (setq x t)))))))
(setfn alpha-char-p both-case-p) (setfn alpha-char-p both-case-p)
@ -764,17 +764,17 @@
res res
(let ((a (char str 0))) (let ((a (char str 0)))
(if (char= a #\<) (if (char= a #\<)
(let* ((l (length str)) (let* ((l (length str))
(b (char str (- l 1)))) (b (char str (- l 1))))
(if (char= b #\>) (if (char= b #\>)
(let ((tok (symbol-token? (subseq str 1 (- l 1)) (let ((tok (symbol-token? (subseq str 1 (- l 1))
pos input errf))) pos input errf)))
;; class token has <> removed! ;; class token has <> removed!
(if tok (progn (set-token-type tok ':class) (if tok (progn (set-token-type tok ':class)
tok) tok)
(errexit "Not a class identifer" pos))) (errexit "Not a class identifer" pos)))
(errexit "Not a class identifer" pos))) (errexit "Not a class identifer" pos)))
nil))) nil)))
; (keyword-token? ":asd" '(:prefix #\:)) ; (keyword-token? ":asd" '(:prefix #\:))
; (keyword-token? "asd" KSTYLE) ; (keyword-token? "asd" KSTYLE)
@ -787,13 +787,18 @@
; (keyword-token? "--asd" '(:prefix #\-)) ; ok since -asd is legal symbol ; (keyword-token? "--asd" '(:prefix #\-)) ; ok since -asd is legal symbol
;; determine if str is a reserved word using reserved as the list of
;; reserved words, of the form ((id string) (id string) ...) where
;; id identifies the token, e.g. :to and string is the token, e.g. "to"
;;
(defun reserved-token? (str pos input errf reserved) (defun reserved-token? (str pos input errf reserved)
errf input errf input
(let ((typ (member str reserved :test (lambda (a b) (equal a (cadr b)))))) (let ((typ (member str reserved :test
(lambda (a b) (string-equal a (cadr b))))))
(if typ (if typ
(make-token :type (caar typ) :string str (make-token :type (caar typ) :string str
:start pos) :start pos)
nil))) nil)))
(defun sal-string-to-symbol (str) (defun sal-string-to-symbol (str)
@ -825,6 +830,7 @@
(not (fboundp sym)) ; existing functions not suspicious (not (fboundp sym)) ; existing functions not suspicious
(not (boundp sym)) ; existing globals not suspicious (not (boundp sym)) ; existing globals not suspicious
(not (member sym *sal-local-variables*)) (not (member sym *sal-local-variables*))
(not (eq sym '->)) ; used by make-markov, so let it pass
(contains-op-char str)) ; suspicious if embedded operators (contains-op-char str)) ; suspicious if embedded operators
(sal-warning (sal-warning
(strcat "Identifier contains operator character(s).\n" (strcat "Identifier contains operator character(s).\n"
@ -859,43 +865,44 @@
((or (not (< i len)) err) ((or (not (< i len)) err)
(if (or (> ltr 0) ; must be at least one letter, or (if (or (> ltr 0) ; must be at least one letter, or
(equal str "->")) ; symbol can be "->" (equal str "->")) ; symbol can be "->"
(let ((info ()) sym) (let ((info ()) sym)
(if pkg (push (cons ':pkg pkg) info)) (if pkg (push (cons ':pkg pkg) info))
(if dot (push (cons ':slot dot) info)) (if dot (push (cons ':slot dot) info))
;(display "in symbol-token?" str) ;(display "in symbol-token?" str)
(setf sym (sal-string-to-symbol str)) (setf sym (sal-string-to-symbol str))
(make-token :type ':id :string str (make-token :type ':id :string str
:info info :start pos :info info :start pos
:lisp sym)) :lisp sym))
nil)) nil))
(setq chr (char str i)) (setq chr (char str i))
(cond ((alpha-char-p chr) (incf ltr)) (cond ((alpha-char-p chr) (incf ltr))
; need to allow arbitrary lisp symbols ; need to allow arbitrary lisp symbols
; ((member chr '(#\* #\+)) ;; special variable names can start/end ; ((member chr '(#\* #\+)) ;; special variable names can start/end
; (if (< 0 i (- len 2)) ;; with + or * ; (if (< 0 i (- len 2)) ;; with + or *
; (errexit bad pos))) ; (errexit bad pos)))
((char= chr #\/) ;; embedded / is not allowed ((char= chr #\/) ;; embedded / is not allowed
(errexit bad pos)) (errexit bad pos))
;((char= chr #\-) ;; hyphens are allowed anywhere in symbol ;((char= chr #\-) ;; hyphens are allowed anywhere in symbol
; (if (= ltr 0) ; (if (= ltr 0)
; (errexit errf input bad pos ) ; (errexit errf input bad pos )
; (setq ltr 0) ; (setq ltr 0)
; )) ; ))
((char= chr #\:) ((char= chr #\$) (incf ltr)) ;; "$" is treated as a letter
((char= chr #\:)
; allowable forms are :foo, foo:bar, :foo:bar ; allowable forms are :foo, foo:bar, :foo:bar
(if (> i 0) ;; lisp keyword symbols ok (if (> i 0) ;; lisp keyword symbols ok
(cond ((= ltr 0) (cond ((= ltr 0)
(errexit bad pos)) (errexit bad pos))
((not pkg) ((not pkg)
(setq pkg i)) (setq pkg i))
(t (errexit errf input (t (errexit errf input
(format nil "Too many colons in ~s" str) (format nil "Too many colons in ~s" str)
pos)))) pos))))
(setq ltr 0)) (setq ltr 0))
((char= chr #\.) ((char= chr #\.)
(if (or dot (= i 0) (= i (- len 1))) (if (or dot (= i 0) (= i (- len 1)))
(errexit bad pos) (errexit bad pos)
(progn (setq dot i) (setq ltr 0))))))) (progn (setq dot i) (setq ltr 0)))))))
; (let ((i "foo")) (symbol-token? i 0 i #'pperror)) ; (let ((i "foo")) (symbol-token? i 0 i #'pperror))
@ -966,7 +973,7 @@
;; read later (maybe) by ERREXIT. ;; read later (maybe) by ERREXIT.
;; If input is a token list, it is assumed these are leftovers ;; If input is a token list, it is assumed these are leftovers
;; from tokenized text, so *sal-input-text* is already valid. ;; from tokenized text, so *sal-input-text* is already valid.
;; *Therfore*, do not call sal-parse with tokens unless ;; *Therefore*, do not call sal-parse with tokens unless
;; *sal-input-text* is set to the corresponding text. ;; *sal-input-text* is set to the corresponding text.
;; ;;
(defun sal-parse (grammar pat input multiple-statements file) (defun sal-parse (grammar pat input multiple-statements file)
@ -1025,7 +1032,7 @@
(defun maybe-parse-command () (defun maybe-parse-command ()
(if (token-is '(:define :load :chdir :variable :function (if (token-is '(:define :load :chdir :variable :function
; :system ; :system
:play :print :display)) :play :print :display :plot))
(parse-command) (parse-command)
(if (and (token-is '(:return)) *audacity-top-level-return-flag*) (if (and (token-is '(:return)) *audacity-top-level-return-flag*)
(parse-command)))) (parse-command))))
@ -1046,6 +1053,8 @@
(parse-print-display :print 'sal-print)) (parse-print-display :print 'sal-print))
((token-is :display) ((token-is :display)
(parse-print-display :display 'display)) (parse-print-display :display 'display))
((token-is :plot)
(parse-plot))
((and *audacity-top-level-return-flag* (token-is :return)) ((and *audacity-top-level-return-flag* (token-is :return))
(parse-return)) (parse-return))
; ((token-is :output) ; ((token-is :output)
@ -1067,6 +1076,8 @@
(parse-print-display :print 'sal-print)) (parse-print-display :print 'sal-print))
((token-is :display) ((token-is :display)
(parse-print-display :display 'display)) (parse-print-display :display 'display))
((token-is :plot)
(parse-plot))
; ((token-is :output) ; ((token-is :output)
; (parse-output)) ; (parse-output))
((token-is :exec) ((token-is :exec)
@ -1315,6 +1326,21 @@
(push arg args)) (push arg args))
(add-line-info-to-stmt (cons function (reverse args)) loc))) (add-line-info-to-stmt (cons function (reverse args)) loc)))
(defun parse-plot ()
;; assumes next token is :plot
(or (token-is :plot) (error "parse-plot internal error"))
(let (arg args loc)
(setf loc (parse-token))
(setf arg (parse-sexpr))
(setf args (list arg))
(cond ((token-is :co) ; get duration parameter
(parse-token) ; remove and ignore the comma
(setf arg (parse-sexpr))
(push arg args)
(cond ((token-is :co) ; get n points parameter
(parse-token) ; remove and ignore the comma
(setf arg (parse-sexpr))))))
(add-line-info-to-stmt (cons 's-plot (reverse args)) loc)))
;(defun parse-output () ;(defun parse-output ()
; ;; assume next token is :output ; ;; assume next token is :output
@ -1415,14 +1441,14 @@
(cond ((eq op '=)) (cond ((eq op '=))
((eq op '-=) (setf expr `(diff ,vref ,expr))) ((eq op '-=) (setf expr `(diff ,vref ,expr)))
((eq op '+=) (setf expr `(sum ,vref ,expr))) ((eq op '+=) (setf expr `(sum ,vref ,expr)))
((eq op '*=) (setq expr `(mult ,vref ,expr))) ((eq op '*=) (setq expr `(mult ,vref ,expr)))
((eq op '/=) (setq expr `(/ ,vref ,expr))) ((eq op '/=) (setq expr `(/ ,vref ,expr)))
((eq op '&=) (setq expr `(nconc ,vref (list ,expr)))) ((eq op '&=) (setq expr `(nconc ,vref (list ,expr))))
((eq op '@=) (setq expr `(cons ,expr ,vref))) ((eq op '@=) (setq expr `(cons ,expr ,vref)))
((eq op '^=) (setq expr `(nconc ,vref (append ,expr nil)))) ((eq op '^=) (setq expr `(nconc ,vref (append ,expr nil))))
((eq op '<=) (setq expr `(min ,vref ,expr))) ((eq op '<=) (setq expr `(min ,vref ,expr)))
((eq op '>=) (setq expr `(max ,vref ,expr))) ((eq op '>=) (setq expr `(max ,vref ,expr)))
(t (errexit (format nil "unknown assigment operator ~A" op)))) (t (errexit (format nil "unknown assigment operator ~A" op))))
(push (list 'setf vref expr) rslt)) (push (list 'setf vref expr) rslt))
(setf rslt (add-line-info-to-stmts rslt set-token)) (setf rslt (add-line-info-to-stmts rslt set-token))
(if (> (length rslt) 1) (if (> (length rslt) 1)
@ -1507,7 +1533,7 @@
;; OR-IZE -- compute the OR of a list of expressions ;; OR-IZE -- compute the OR of a list of expressions
;; ;;
(defun or-ize (exprs) (defun or-ize (exprs)
(if (> 1 (length exprs)) (cons 'or exprs) (if (> (length exprs) 1) (cons 'or exprs)
(car exprs))) (car exprs)))
@ -1758,8 +1784,12 @@
(while (not (token-is :rc)) (while (not (token-is :rc))
(cond ((token-is '(:int :float :id :bool :key :string)) (cond ((token-is '(:int :float :id :bool :key :string))
(push (token-lisp (parse-token)) elts)) (push (token-lisp (parse-token)) elts))
((token-is *sal-operators*)
(push (intern (token-string (parse-token))) elts))
((token-is :lc) ((token-is :lc)
(push (parse-list) elts)) (push (parse-list) elts))
((token-is :co)
(errexit "expected list element or right brace; do not use commas inside braces {}"))
(t (t
(errexit "expected list element or right brace")))) (errexit "expected list element or right brace"))))
(parse-token) (parse-token)
@ -1793,7 +1823,7 @@
(defun is-op? (x) (defun is-op? (x)
;; return op weight if x is operator ;; return op weight if x is operator
(let ((o (assoc (if (listp x) (token-type x) x) (let ((o (assoc (if (listp x) (token-type x) x)
*op-weights*))) *op-weights*)))
(and o (cadr o)))) (and o (cadr o))))
@ -1802,26 +1832,26 @@
;; depth-first so subexprs are already processed ;; depth-first so subexprs are already processed
(let (op lh rh w1) (let (op lh rh w1)
(if (consp inf) (if (consp inf)
(do () (do ()
((null inf) lh) ((null inf) lh)
(setq op (car inf)) ; look at each element of in (setq op (car inf)) ; look at each element of in
(pop inf) (pop inf)
(setq w1 (is-op? op)) (setq w1 (is-op? op))
(cond ((numberp w1) ; found op (w1 is precedence) (cond ((numberp w1) ; found op (w1 is precedence)
(do ((w2 nil) (do ((w2 nil)
(ok t) (ok t)
(li (list))) (li (list)))
((or (not inf) (not ok)) ((or (not inf) (not ok))
(setq rh (inf->pre (nreverse li))) (setq rh (inf->pre (nreverse li)))
(setq lh (if lh (list (get-lisp-op op) lh rh) (setq lh (if lh (list (get-lisp-op op) lh rh)
(list (get-lisp-op op) rh nil)))) (list (get-lisp-op op) rh nil))))
(setq w2 (is-op? (first inf))) (setq w2 (is-op? (first inf)))
(cond ((and w2 (<= w2 w1)) (cond ((and w2 (<= w2 w1))
(setq ok nil)) (setq ok nil))
(t (t
(push (car inf) li) (push (car inf) li)
(pop inf))))) (pop inf)))))
(t (t
(setq lh op)))) (setq lh op))))
inf))) inf)))

39
nyquist/sal.lsp
View File

@ -366,7 +366,7 @@
(defun lisp-loader (filename &key (verbose t) print) (defun lisp-loader (filename &key (verbose t) print)
(if (load filename :verbose verbose :print print) (if (load filename :verbose verbose :print print)
nil ; be quiet if things work ok t ; be quiet if things work ok
(format t "error loading lisp file ~A~%" filename))) (format t "error loading lisp file ~A~%" filename)))
@ -467,7 +467,7 @@
;; read-eval-print loop for sal commands ;; read-eval-print loop for sal commands
(defun sal () (defun sal ()
(progv '(*breakenable* *tracenable* *sal-exit* *sal-mode*) (progv '(*breakenable* *tracenable* *sal-exit* *sal-mode*)
(list *sal-break* nil nil t) (list *sal-break* *xlisp-traceback* nil t)
(let (input line) (let (input line)
(setf *sal-call-stack* nil) (setf *sal-call-stack* nil)
(read-line) ; read the newline after the one the user (read-line) ; read the newline after the one the user
@ -587,9 +587,44 @@
(> (length input) i) (> (length input) i)
(eq (char input i) #\()))) (eq (char input i) #\())))
(defun sal-list-equal (a b)
(let ((rslt t)) ;; set to false if any element not equal
(dolist (x a)
(if (sal-equal x (car b))
t ;; continue comparing
(return (setf rslt nil))) ;; break out of loop
(setf b (cdr b)))
(and rslt (null b)))) ;; make sure no leftovers in b
(defun sal-plus(a b &optional (source "+ operation in SAL"))
(ny:typecheck (not (or (numberp a) (soundp a) (multichannel-soundp a)))
(ny:error source 0 number-sound-anon a t))
(ny:typecheck (not (or (numberp b) (soundp b) (multichannel-soundp b)))
(ny:error source 0 number-sound-anon b t))
(nyq:add2 a b))
(defun sal-equal (a b) (defun sal-equal (a b)
(or (and (numberp a) (numberp b) (= a b)) (or (and (numberp a) (numberp b) (= a b))
(and (consp a) (consp b) (sal-list-equal a b))
(equal a b))) (equal a b)))
(defun not-sal-equal (a b) (defun not-sal-equal (a b)
(not (sal-equal a b))) (not (sal-equal a b)))
(defun sal-list-about-equal (a b)
(let ((rslt t)) ;; set to false if any element not equal
(dolist (x a)
(if (sal-about-equal x (car b))
t ;; continue comparing
(return (setf rslt nil))) ;; break out of loop
(setf b (cdr b)))
(and rslt (null b)))) ;; make sure no leftovers in b
(setf *~=tolerance* 0.000001)
(defun sal-about-equal (a b)
(or (and (numberp a) (numberp b) (< (abs (- a b)) *~=tolerance*))
(and (consp a) (consp b) (sal-list-about-equal a b))
(equal a b)))

119
nyquist/seq.lsp
View File

@ -25,44 +25,50 @@
; later. Finally, it is also necessary to save the current transformation ; later. Finally, it is also necessary to save the current transformation
; environment until later. ; environment until later.
;; 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)
(if *sal-call-stack*
(list 'prog2 (list 'sal-trace-enter (list 'quote (list "Expression in SEQ:" expr)))
expr
'(sal-trace-exit))
expr))
(defmacro seq (&rest list) (defmacro seq (&rest list)
(cond ((null list) (cond ((null list)
(snd-zero (warp-time *WARP*) *sound-srate*)) (snd-zero (warp-time *WARP*) *sound-srate*))
((null (cdr list)) ((null (cdr list))
(car list)) (car list))
((null (cddr list)) ((null (cddr list))
; (format t "SEQ with 2 behaviors: ~A~%" list) ;; SEQ with 2 behaviors
`(let* ((first%sound ,(car list)) `(let* ((first%sound ,(seq-expr-expand (car list)))
(s%rate (get-srates first%sound))) (s%rate (get-srates first%sound)))
(cond ((arrayp first%sound) (cond ((arrayp first%sound)
(snd-multiseq (prog1 first%sound (setf first%sound nil)) (snd-multiseq (prog1 first%sound (setf first%sound nil))
#'(lambda (t0) #'(lambda (t0)
(format t "MULTISEQ's 2nd behavior: ~A~%" ',(cadr list))
(with%environment ',(nyq:the-environment) (with%environment ',(nyq:the-environment)
; (display "MULTISEQ 1" t0)
(at-abs t0 (at-abs t0
(force-srates s%rate ,(cadr list))))))) (force-srates s%rate ,(seq-expr-expand (cadr list))))))))
(t (t
; allow gc of first%sound: ; allow gc of first%sound:
(snd-seq (prog1 first%sound (setf first%sound nil)) (snd-seq (prog1 first%sound (setf first%sound nil))
#'(lambda (t0) #'(lambda (t0)
; (format t "SEQ's 2nd behavior: ~A~%" ',(cadr list))
(with%environment ',(nyq:the-environment) (with%environment ',(nyq:the-environment)
(at-abs t0 (at-abs t0
(force-srate s%rate ,(cadr list)))))))))) (force-srate s%rate ,(seq-expr-expand (cadr list)))))))))))
(t (t ;; SEQ with more than 2 behaviors
`(let* ((nyq%environment (nyq:the-environment)) `(let* ((nyq%environment (nyq:the-environment))
(first%sound ,(car list)) (first%sound ,(car list))
(s%rate (get-srates first%sound)) (s%rate (get-srates first%sound))
(seq%environment (getenv))) (seq%environment (getenv)))
(cond ((arrayp first%sound) (cond ((arrayp first%sound)
; (print "calling snd-multiseq")
(snd-multiseq (prog1 first%sound (setf first%sound nil)) (snd-multiseq (prog1 first%sound (setf first%sound nil))
#'(lambda (t0) #'(lambda (t0)
(multiseq-iterate ,(cdr list))))) (multiseq-iterate ,(cdr list)))))
(t (t
; (print "calling snd-seq")
; allow gc of first%sound: ; allow gc of first%sound:
(snd-seq (prog1 first%sound (setf first%sound nil)) (snd-seq (prog1 first%sound (setf first%sound nil))
#'(lambda (t0) #'(lambda (t0)
@ -76,9 +82,10 @@
(defmacro seq-iterate (behavior-list) (defmacro seq-iterate (behavior-list)
(cond ((null (cdr behavior-list)) (cond ((null (cdr behavior-list))
`(eval-seq-behavior ,(car behavior-list))) ;; last expression in list
(t `(eval-seq-behavior ,(seq-expr-expand (car behavior-list))))
`(snd-seq (eval-seq-behavior ,(car behavior-list)) (t ;; more expressions after this one
`(snd-seq (eval-seq-behavior ,(seq-expr-expand (car behavior-list)))
(evalhook '#'(lambda (t0) (evalhook '#'(lambda (t0)
; (format t "lambda depth ~A~%" (envdepth (getenv))) ; (format t "lambda depth ~A~%" (envdepth (getenv)))
(seq-iterate ,(cdr behavior-list))) (seq-iterate ,(cdr behavior-list)))
@ -86,11 +93,10 @@
(defmacro multiseq-iterate (behavior-list) (defmacro multiseq-iterate (behavior-list)
(cond ((null (cdr behavior-list)) (cond ((null (cdr behavior-list))
`(eval-multiseq-behavior ,(car behavior-list))) `(eval-multiseq-behavior ,(seq-expr-expand (car behavior-list))))
(t (t
`(snd-multiseq (eval-multiseq-behavior ,(car behavior-list)) `(snd-multiseq (eval-multiseq-behavior ,(seq-expr-expand (car behavior-list)))
(evalhook '#'(lambda (t0) (evalhook '#'(lambda (t0)
; (format t "lambda depth ~A~%" (envdepth (getenv)))
(multiseq-iterate ,(cdr behavior-list))) (multiseq-iterate ,(cdr behavior-list)))
nil nil seq%environment))))) nil nil seq%environment)))))
@ -101,7 +107,6 @@
(defmacro eval-multiseq-behavior (beh) (defmacro eval-multiseq-behavior (beh)
`(with%environment nyq%environment `(with%environment nyq%environment
; (display "MULTISEQ 2" t0)
(at-abs t0 (at-abs t0
(force-srates s%rate ,beh)))) (force-srates s%rate ,beh))))
@ -121,7 +126,7 @@
(error "bad argument type" loop%count)) (error "bad argument type" loop%count))
(t (t
(setf seqrep%closure #'(lambda (t0) (setf seqrep%closure #'(lambda (t0)
; (display "SEQREP" loop%count ,(car pair)) ; (display "SEQREP" loop%count ,(car pair))
(cond ((< ,(car pair) loop%count) (cond ((< ,(car pair) loop%count)
(setf first%sound (setf first%sound
(with%environment nyq%environment (with%environment nyq%environment
@ -159,7 +164,7 @@
(defmacro trigger (input beh) (defmacro trigger (input beh)
`(let ((nyq%environment (nyq:the-environment))) `(let ((nyq%environment (nyq:the-environment)))
(snd-trigger ,input #'(lambda (t0) (with%environment nyq%environment (snd-trigger ,input #'(lambda (t0) (with%environment nyq%environment
(at-abs t0 ,beh)))))) (at-abs t0 ,beh))))))
;; EVENT-EXPRESSION -- the sound of the event ;; EVENT-EXPRESSION -- the sound of the event
;; ;;
@ -179,12 +184,12 @@
(defun list-set-attr-value (lis attr value) (defun list-set-attr-value (lis attr value)
(cond ((null lis) (list attr value)) (cond ((null lis) (list attr value))
((eq (car lis) attr) ((eq (car lis) attr)
(cons attr (cons value (cddr lis)))) (cons attr (cons value (cddr lis))))
(t (t
(cons (car lis) (cons (car lis)
(cons (cadr lis) (cons (cadr lis)
(list-set-attr-value (cddr lis) attr value)))))) (list-set-attr-value (cddr lis) attr value))))))
;; EXPAND-AND-EVAL-EXPR -- evaluate a note, chord, or rest for timed-seq ;; EXPAND-AND-EVAL-EXPR -- evaluate a note, chord, or rest for timed-seq
@ -192,11 +197,11 @@
(defun expand-and-eval-expr (expr) (defun expand-and-eval-expr (expr)
(let ((pitch (member :pitch expr))) (let ((pitch (member :pitch expr)))
(cond ((and pitch (cdr pitch) (listp (cadr pitch))) (cond ((and pitch (cdr pitch) (listp (cadr pitch)))
(setf pitch (cadr pitch)) (setf pitch (cadr pitch))
(simrep (i (length pitch)) (simrep (i (length pitch))
(eval (expr-set-attr expr :pitch (nth i pitch))))) (eval (expr-set-attr expr :pitch (nth i pitch)))))
(t (t
(eval expr))))) (eval expr)))))
;; (timed-seq '((time1 stretch1 expr1) (time2 stretch2 expr2) ...)) ;; (timed-seq '((time1 stretch1 expr1) (time2 stretch2 expr2) ...))
@ -227,6 +232,7 @@
;; ;;
(setf MAX-LINEAR-SCORE-LEN 100) (setf MAX-LINEAR-SCORE-LEN 100)
(defun timed-seq (score) (defun timed-seq (score)
(must-be-valid-score "TIMED-SEQ" score)
(let ((len (length score)) (let ((len (length score))
pair) pair)
(cond ((< len MAX-LINEAR-SCORE-LEN) (cond ((< len MAX-LINEAR-SCORE-LEN)
@ -250,12 +256,15 @@
(cons front back))) (cons front back)))
;; TIMED-SEQ-LINEAR - check to insure that times are strictly increasing
;; and >= 0 and stretches are >= 0
(defun timed-seq-linear (score) (defun timed-seq-linear (score)
; check to insure that times are strictly increasing and >= 0 and stretches are >= 0 (let ((start-time 0) error-msg rslt)
(let ((start-time 0) error-msg)
(dolist (event score) (dolist (event score)
(cond ((< (car event) start-time) (cond ((< (car event) start-time)
(error (format nil "Out-of-order time in TIMED-SEQ: ~A" event))) (error (format nil
"Out-of-order time in TIMED-SEQ: ~A, consider using SCORE-SORT"
event)))
((< (cadr event) 0) ((< (cadr event) 0)
(error (format nil "Negative stretch factor in TIMED-SEQ: ~A" event))) (error (format nil "Negative stretch factor in TIMED-SEQ: ~A" event)))
(t (t
@ -264,30 +273,26 @@
(setf score (score-select score #'(lambda (tim dur evt) (setf score (score-select score #'(lambda (tim dur evt)
(expr-get-attr evt :pitch t)))) (expr-get-attr evt :pitch t))))
(cond ((and score (car score) (cond ((and score (car score)
(eq (car (event-expression (car score))) 'score-begin-end)) (eq (car (event-expression (car score))) 'score-begin-end))
(setf score (cdr score)))) ; skip score-begin-end data (setf score (cdr score)))) ; skip score-begin-end data
; (score-print score) ;; debugging
(cond ((null score) (s-rest 0)) (cond ((null score) (s-rest 0))
(t (t
(at (caar score) (at (caar score)
(seqrep (i (length score)) (seqrep (i (length score))
(cond ((cdr score) (progn
(let (event) (cond (*sal-call-stack*
(prog1 (sal-trace-enter (list "Score event:" (car score)) nil nil)
(set-logical-stop (setf *sal-line* 0)))
(stretch (cadar score) (setf rslt
(setf event (expand-and-eval-expr (cond ((cdr score)
(caddar score)))) (prog1
(- (caadr score) (caar score))) (set-logical-stop
;(display "timed-seq" (caddar score) (stretch (cadar score)
; (local-to-global 0) (expand-and-eval-expr (caddar score)))
; (snd-t0 event) (- (caadr score) (caar score)))
; (- (caadr score) (setf score (cdr score))))
; (caar score))) (t
(setf score (cdr score))))) (stretch (cadar score) (expand-and-eval-expr
(t (caddar score))))))
(stretch (cadar score) (expand-and-eval-expr (if *sal-call-stack* (sal-trace-exit))
(caddar score))))))))))) rslt)))))))

20
nyquist/seqmidi.lsp
View File

@ -19,7 +19,7 @@
(setf _the-seq (seq-copy ,the-seq)) (setf _the-seq (seq-copy ,the-seq))
(setf _nyq-environment (nyq:the-environment)) (setf _nyq-environment (nyq:the-environment))
(setf _seq-midi-closure #'(lambda (t0) (setf _seq-midi-closure #'(lambda (t0)
; (format t "_seq_midi_closure: t0 = ~A~%" t0) (format t "_seq_midi_closure: t0 = ~A~%" t0) ;DEBUG
(prog (_the-sound) (prog (_the-sound)
loop ; go forward until we find note to play (we may be there) loop ; go forward until we find note to play (we may be there)
; then go forward to find time of next note ; then go forward to find time of next note
@ -45,6 +45,7 @@ loop ; go forward until we find note to play (we may be there)
((and (= _tag seq-note-tag) ((and (= _tag seq-note-tag)
,(make-note-test cases)) ,(make-note-test cases))
(cond (_the-sound ; we now have time of next note (cond (_the-sound ; we now have time of next note
; (display "note" (seq-time _the-event))
(setf _next-time (/ (seq-time _the-event) 1000.0)) (setf _next-time (/ (seq-time _the-event) 1000.0))
(go exit-loop)) (go exit-loop))
(t (t
@ -52,13 +53,13 @@ loop ; go forward until we find note to play (we may be there)
(seq-next _the-seq) (seq-next _the-seq)
(go loop) (go loop)
exit-loop ; here, we know time of next note exit-loop ; here, we know time of next note
; (display "seq-midi" _next-time) (display "seq-midi" _next-time) ;DEBUG
; (format t "seq-midi calling snd-seq\n") (format t "seq-midi calling snd-seq\n") ;DEBUG
(return (snd-seq (return (snd-seq
(set-logical-stop-abs _the-sound (set-logical-stop-abs _the-sound
(local-to-global _next-time)) (local-to-global _next-time))
_seq-midi-closure))))) _seq-midi-closure)))))
; (display "calling closure" (get-lambda-expression _seq-midi-closure)) (display "calling closure" (get-lambda-expression _seq-midi-closure)) ; DEBUG
(funcall _seq-midi-closure (local-to-global 0)))) (funcall _seq-midi-closure (local-to-global 0))))
@ -157,3 +158,14 @@ exit-loop ; here, we know time of next note
; (seq-next the-seq) ; (seq-next the-seq)
; (go loop))) ; (go loop)))
; ;
;; for SAL we can't pass in lisp expressions as arguments, so
;; we pass in functions instead, using keyword parameters for
;; ctrl, bend, touch, and prgm. The note parameter is required.
;;
(defun seq-midi-sal (seq note &optional ctrl bend touch prgm)
(seq-midi seq (note (chan pitch vel) (funcall note chan pitch vel))
(ctrl (chan num val) (if ctrl (funcall ctrl chan num val)))
(bend (chan val) (if bend (funcall bend chan val)))
(touch (chan val) (if touch (funcall touch chan val)))
(prgm (chan val) (if prgm (funcall prgm chan val)))))

196
nyquist/sliders.lsp Normal file
View File

@ -0,0 +1,196 @@
;; sliders.lsp -- communicate with NyquistIDE to implement control panels
;; Roger B. Dannenberg
;; April 2015
;; (stop-on-zero s) -- a sound that returns 1 until s goes to zero, then
;; the sound terminates. If s comes from a slider and you multiply
;; a sound by (stop-on-zero s), you can interactively stop it
;; (make-slider-panel "name" color) -- sets panel name for the following
;; sliders
;; (make-slider "param" [initial [low high]]) -- create slider named
;; "param" with optional range and initial value. Also returns
;; a sound.
;; (make-button "param" normal) -- create a button named "param" with
;; a starting value of normal (either 0 or 1). While the button
;; in the panel is pressed, the value changes to 1 or 0.
;; (get-slider-value "param") -- when called with a string, this looks up
;; the slider value by name
;; (slider-panel-close "name") -- close the panel window. Values of any
;; existing sliders become undefined.
;; (slider "panel" "name" [dur]) -- make a signal from slider value
;; (slider "name" [dur]) -- make a signal from slider in current panel
;; (get-slider-value "panel" "name") -- get a float value
;; (get-slider-value "name") -- get a float in current panel
;; *active-slider-panel* is the current panel to which sliders are added
;;
(if (not (boundp '*active-slider-panel*))
(setf *active-slider-panel* nil))
;; *panels-in-use* is an assoc list of panels, where each panel
;; is a list of allocated sliders stored as (name number)
;;
(if (not (boundp '*panels-in-use*))
(setf *panels-in-use* nil))
;; allocate-slider-num -- find an unused slider number
;; linear search is used to avoid maintaining a parallel structure
;; for faster searching. We search starting at slider #10, leaving
;; sliders 0-9 unused; for example, you might want to control them
;; via open sound control, so this gives you 10 sliders that are
;; off limits to allocation by the SLIDER function.
;;
;; This code takes advantage of the fact that dotimes and dolist
;; return nil when they end normally, so we signal that we found
;; or did not find i by explictly returning. Note that RETURN
;; returns from the innermost dotimes or dolist -- they do not
;; return from allocate-slider-num.
;;
(defun allocate-slider-num ()
(dotimes (n 990)
(let ((i (+ n 10)))
(cond ((not (dolist (panel *panels-in-use*)
(cond ((dolist (pair (cdr panel))
(cond ((eql (second pair) i) (return t))))
(return t)))))
(return i))))))
;; remove panel from list of panels
(defun slider-panel-free (panel)
(setf *panels-in-use* (remove panel *panels-in-use* :test #'equal)))
(setfn stop-on-zero snd-stoponzero)
(defun make-slider-panel (name &optional (color 0))
(let ((panel (assoc name *panels-in-use* :test #'equal)))
;; first find if panel already exists. If so, free the resources
(cond (panel
(slider-panel-free panel)))
(setf *active-slider-panel* (list name))
(setf *panels-in-use* (cons *active-slider-panel* *panels-in-use*))
(format t "slider-panel-create: \"~A\" ~A~%" name color)))
(defun make-slider (name &optional (init 0) (low 0) (high 1))
(let ((num (allocate-slider-num)))
(cond ((null num)
(format t "WARNING: MAKE-SLIDER is out of slider numbers. ~A~%"
"No slider created."))
((not (and (stringp name) (numberp init)
(numberp low) (numberp high)))
(display
"WARNING: MAKE-SLIDER called with bad arguments. No slider created"
name init low high)))
;; make sure we have an active panel
(cond ((null *active-slider-panel*)
(make-slider-panel "Controls")))
;; insert new slider into list of sliders in active panel. This
;; is aliased with an element in the assoc list *panels-in-use*.
(rplacd *active-slider-panel* (cons (list name num)
(cdr *active-slider-panel*)))
(format t "slider-create: \"~A\" ~A ~A ~A ~A~%" name num init low high)
num))
(defun make-button (name &optional (normal 0))
(let ((num (allocate-slider-num)))
(cond ((null num)
(format t "WARNING: MAKE-BUTTON is out of slider numbers. ~A~%"
"No button created."))
((not (and (stringp name) (numberp normal)))
(display
"WARNING: MAKE-BUTTON called with bad arguments. No button created"
name normal)))
;; make sure we have an active panel
(cond ((null *active-slider-panel*)
(slider-panel "Controls")))
;; insert new button into list of controls in active panel. This
;; is aliased with an element in the assoc list *panels-in-use*.
(rplacd *active-slider-panel* (cons (list name num)
(cdr *active-slider-panel*)))
(format t "button-create: \"~A\" ~A ~A~%" name num normal)
num))
(defun close-slider-panel (name)
(let ((panel (assoc name *panels-in-use* :test #'equal)))
(cond ((not (stringp name))
(display "WARNING: SLIDER-PANEL-CLOSED called with bad argument."
name)))
(cond (panel
(slider-panel-free panel)
(format t "slider-panel-close: \"~A\"~%" name))
(t
(format t "WARNING: slider panel ~A not found.~%" name)))))
;; SLIDER-LOOKUP - find the slider by name
;;
(defun slider-lookup (name slider)
(let ((panel (assoc name *panels-in-use* :test #'equal)) s)
(cond ((null panel)
(error "Could not find slider panel named" name)))
(setf s (assoc slider (cdr panel) :test #'equal))
(cond ((null s)
(error "Could not find slider named" s)))
(second s)))
;; SLIDER - creates a signal from real-time slider input
;;
;; options are:
;; (SLIDER number [dur])
;; (SLIDER "name" [dur]) -- look up slider in current slider panel
;; (SLIDER "panel" "name" [dur]) -- look up panel, then look up slider
;;
(defun slider (id &optional slider-name dur)
(cond ((and (numberp id) (null slider-name))
(setf dur 1.0))
((and (numberp id) (numberp slider-name) (null dur))
(setf dur slider-name))
((and (stringp id) (null slider-name))
(setf dur 1.0)
(setf id (slider-lookup (car *active-slider-panel*) id)))
((and (stringp id) (numberp slider-name) (null dur))
(setf dur slider-name)
(setf id (slider-lookup (car *active-slider-panel*) id)))
((and (stringp id) (stringp slider-name) (null dur))
(setf dur 1.0)
(setf id (slider-lookup id slider-name)))
((and (stringp id) (stringp slider-name) (numberp dur))
(setf id (slider-lookup id slider-name)))
(t
(error "SLIDER called with invalid arguments")))
(setf dur (get-duration dur))
(setf id (round id)) ;; just to make sure it's an integer
(cond ((or (< id 0) (>= id 1000))
(error "SLIDER index out of bounds" id)))
(display "slider" id slider-name dur)
(snd-slider id *rslt* *sound-srate* dur))
(if (not (boundp '*lpslider-cutoff*))
(setf *lpslider-cutoff* 20.0))
(defun lpslider (id &optional slider-name dur)
(lp (slider id slider-name dur) 20.0))
;; save built-in get-slider-value so we can redefine it
(if (not (fboundp 'prim-get-slider-value))
(setfn prim-get-slider-value get-slider-value))
(defun get-slider-value (id &optional slider-name)
(cond ((and (numberp id) (null slider-name)) nil)
((and (stringp id) (null slider-name))
(setf id (slider-lookup (car *active-slider-pael*) id)))
((and (stringp id) (stringp slider-name))
(setf id (slider-lookup id slider-name)))
(t
(error "GET-SLIDER-VALUE called with invalid arguments")))
;; further parameter checking is done in get-slider-value:
(prim-get-slider-value id))
(autonorm-off)
(snd-set-latency 0.02)
(print "**********sliders.lsp************************")
(print "WARNING: AUTONORM IS NOW TURNED OFF")
(print "WARNING: AUDIO LATENCY SET TO 20MS")
(print "To restore settings, execute (autonorm-on) and")
(print " (set-audio-latency 0.3)")
(print "*********************************************")

47
nyquist/spec-plot.lsp Normal file
View File

@ -0,0 +1,47 @@
;; spec-plot.lsp -- spectral plot function
;;
;; Roger B. Dannenberg, May 2016
;;
(setf *spec-plot-bw* 8000.0) ;; higest frequency to plot (default)
(setf *spec-plot-res* 20.0) ;; bin size (default)
(setf *spec-plot-db* nil) ;; plot dB? (default)
;; We want to allow round-number bin-sizes so plot will be more readable
;; Assuming 20Hz as an example, the FFT size would have to be
;; 44100/20 = 2205, but that's not a power of 2, so we should resample
;; the signal down so that the FFT size is 2048 (or up to 4096). This
;; would result in sample rates of 2048*20 = 40960 or 81120. We should
;; pick the smaller one if it is at least 2x *spec-plot-bw*.
(defun spec-plot (sound &optional offset &key (res *spec-plot-res*)
(bw *spec-plot-bw*)
(db *spec-plot-db*))
(ny:typecheck (not (soundp sound))
(ny:error "SPEC-PLOT" 1 '((SOUND) nil) sound))
(ny:typecheck (not (or (null offset) (numberp offset)))
(ny:error "SPEC-PLOT" 2 '((NUMBER NULL) nil) offset))
(let (newsr sa fft-size power2)
(setf fft-size (/ (snd-srate sound) res))
(setf power2 8) ;; find integer size for FFT
(while (< power2 fft-size)
(setf power2 (* 2 power2)))
;; now power2 >= fft-size
(cond ((> power2 fft-size) ;; not equal, must resample
;; if half power2 * res is above 2 * bw,
;; use half power2 as fft size
(cond ((> (* power2 res) (* 4 bw))
(setf power2 (/ power2 2))))
(setf sound (snd-resample sound (* power2 res)))
(setf fft-size power2)))
;; we only need fft-dur samples, but allow an extra second just to
;; avoid any rounding errors
(if offset
(setf sound (extract offset (+ 1.0 offset (/ (snd-srate sound)
fft-size)) sound)))
(setf sa (sa-init :resolution res :input sound))
(setf mag (sa-magnitude (sa-next sa)))
(setf mag (snd-from-array 0 (/ 1.0 res) mag))
(if db (setf mag (linear-to-db mag)))
(s-plot mag bw (round (/ (float bw) res)))))

289
nyquist/spectral-analysis.lsp Normal file
View File

@ -0,0 +1,289 @@
;; spectral-analysis.lsp -- functions to simplify computing
;; spectrogram data
;;
;; Roger B. Dannenberg and Gus Xia
;; Jan 2013, modified Oct 2017
;; API:
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set sa-obj = sa-init(resolution: <nil or Hz>,
;; fft-dur: <nil or seconds>,
;; skip-period: <seconds>,
;; window: <window type>,
;; input: <filename or sound>)
;;
;; sa-init() creates a spectral-analysis object that can be used
;; to obtain spectral data from a sound.
;;
;; resolution is the width of each spectral bin in Hz. If nil of
;; not specified, the resolution is computed from fft-dur.
;; The actual resolution will be finer than the specified
;; resolution because fft sizes are rounded to a power of 2.
;; fft-dur is the width of the FFT window in seconds. The actual
;; FFT size will be rounded up to the nearest power of two
;; in samples. If nil, fft-dur will be calculated from
;; resolution. If both fft-size and resolution are nil
;; or not specified, the default value of 1024 samples,
;; corresponding to a duration of 1024 / signal-sample-rate,
;; will be used. If both resolution and fft-dur are
;; specified, the resolution parameter will be ignored.
;; Note that fft-dur and resolution are reciprocals.
;; skip-period specifies the time interval in seconds between
;; successive spectra (FFT windows). Overlapping FFTs are
;; possible. The default value overlaps windows by 50%.
;; Non-overlapped and widely spaced windows that ignore
;; samples by skipping over them entirely are also acceptable.
;; window specifies the type of window. The default is raised
;; cosine (Hann or "Hanning") window. Options include
;; :hann, :hanning, :hamming, :none, nil, where :none and
;; nil mean a rectangular window.
;; input can be a string (which specifies a sound file to read)
;; or a Nyquist SOUND to be analyzed.
;; Return value is an XLISP object that can be called to obtain
;; parameters as well as a sequence of spectral frames.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set sa-frame = sa-next(sa-obj)
;;
;; sa-next() fetches the next spectrum from sa-obj.
;;
;; sa-obj is a spectral-analysis object returned by sa-init().
;; Return value is an array of FLONUMS representing the discrete
;; spectrum.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; exec sa-info(sa-obj)
;;
;; sa-info prints information about the spectral computation.
;;
;; sa-obj is a spectral-analysis object returned by sa-init().
;; Return value is nil, but information is printed.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set mag = sa-magnitude(frame)
;;
;; sa-magnitude computes the magnitude (amplitude) spectrum
;; from a frame returned by sa-frame.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; exec sa-plot(sa-obj, sa-frame)
;;
;; sa-plot plots the amplitude (magnitude) spectrum of sa-frame.
;;
;; sa-obj is used to determine the bin width of data in sa-frame.
;;
;; sa-frame is a spectral frame (array) returned by sa-next()
;;
;; Return value is nil, but a plot is generated and displayed.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set hz = sa-get-bin-width(sa-obj)
;; set n = sa-get-fft-size(sa-obj)
;; set secs = sa-get-fft-dur(sa-obj)
;; set window = sa-get-fft-window(sa-obj)
;; set skip-period = sa-get-skip-period(sa-obj)
;; set m = sa-get-fft-skip-size(sa-obj)
;; set sr = sa-get-sample-rate(sa-obj)
;;
;; These functions retrieve data from the sa-obj created by
;; sa-init. The return values are:
;; hz - the width of a frequency bin (also the separation
;; of bin center frequencies). The center frequency of
;; the i'th bin is i * hz.
;; n - the size of the FFT, an integer, a power of two. The
;; size of a spectral frame (an array returned by sa-next)
;; is (n / 2) + 1.
;; secs - the duration of an FFT window.
;; window - the type of window used (:hann, :hamming, :none)
;; skip-period - the time in seconds of the skip (the time
;; difference between successive frames
;; m - the size of the skip in samples.
;; sr - the sample rate of the sound being analyzed (in Hz, a flonum)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; define the class of spectral analysis objects
(setf sa-class (send class :new '(sound length skip window window-type)))
(send sa-class :answer :next '() '(
(snd-fft sound length skip window)))
(defun sa-raised-cosine (alpha beta)
(sum (const alpha)
(scale beta (lfo 1.0 1.0 *sine-table* 270))))
(defun sa-fft-window (frame-size alpha beta)
(abs-env (control-srate-abs frame-size
(sa-raised-cosine alpha beta))))
(defun hann-window (frame-size) (sa-fft-window frame-size 0.5 0.5))
(defun hamming-window (frame-size) (sa-fft-window frame-size 0.54 0.46))
(defun sa-get-window-type (win-type)
(case win-type
((:hann :hanning) :hann)
((nil :none) :none)
(:hamming :hamming)
(t (print "Warning: invalid window-type parameter: ~A~%" win-type)
(print " Using :HAMMING instead.~%")
:hamming)))
(defun sa-compute-window (len win-type)
(case win-type
(:hann (hann-window len))
(:none nil)
(:hamming (hamming-window len))
(t (print "Warning: invalid window-type paramter: ~A~%" win-type)
(print " Using :HAMMING instead.~%")
(hamming-window len))))
(send sa-class :answer :isnew '(snd len skp win-type) '(
(setf sound snd)
(setf length len)
(setf skip skp)
(setf window-type (sa-get-window-type win-type))
(setf window (sa-compute-window length window-type))))
;; sa-to-mono -- sum up the channels in an array
;;
(defun sa-to-mono (s)
(let ((mono (aref s 0)))
(dotimes (i (1- (length s)))
(setf mono (sum mono (aref s (1+ i)))))
mono))
(defun sa-init (&key resolution fft-dur skip-period window input)
(let (len sr n skip)
(cond ((stringp input)
(setf input (s-read input))))
(cond ((arrayp input)
(format t "Warning: sa-init is converting stereo sound to mono~%")
(setf input (sa-to-mono input)))
((soundp input) ;; so that variables are not "consumed" by snd-fft
(setf input (snd-copy input))))
(cond ((not (soundp input))
(error
(format nil
"Error: sa-init did not get a valid :input parameter~%"))))
(setf sr (snd-srate input))
(setf len 1024)
(cond (fft-dur
(setf len (* fft-dur sr)))
(resolution
(setf len (/ sr resolution))))
;; limit fft size to between 4 and 2^16
(cond ((> len 65536)
(format t "Warning: fft-size reduced from ~A to 65536~%" len)
(setf len 65536))
((< len 4)
(format t "Warning: fft-size increased from ~A to 4~%" len)
(setf len 4)))
;; round up len to a power of two
(setf n 4)
(while (< n len)
(setf n (* n 2)))
(setf length n) ;; len is now an integer power of 2
;(display "sa-init" length)
;; compute skip length - default is len/2
(setf skip (if skip-period (round (* skip-period sr))
(/ length 2)))
(send sa-class :new input length skip window)))
(defun sa-next (sa-obj)
(send sa-obj :next))
(defun sa-info (sa-obj)
(send sa-obj :info))
(send sa-class :answer :info '() '(
(format t "Spectral Analysis object (instance of sa-class):~%")
(format t " resolution (bin width): ~A Hz~%" (/ (snd-srate sound) length))
(format t " fft-dur: ~A s (~A samples)~%" (/ length (snd-srate sound)) length)
(format t " skip-period: ~A s (~A samples)~%" (/ skip (snd-srate sound)) skip)
(format t " window: ~A~%" window-type)
nil))
(defun sa-plot (sa-obj frame)
(send sa-obj :plot frame))
(defun sa-magnitude(frame)
(let* ((flen (length frame))
(n (/ (length frame) 2)) ; size of amplitude spectrum - 1
(as (make-array (1+ n)))) ; amplitude spectrum
;; first compute an amplitude spectrum
(setf (aref as 0) (abs (aref frame 0))) ;; DC
;; half_n is actually length/2 - 1, the number of complex pairs
;; in addition there is the DC and Nyquist terms, which are
;; real and in the first and last slots of frame
(setf half_n (1- n))
(dotimes (i half_n)
(let* ((i2 (+ i i 2)) ; index of the imag part
(i2m1 (1- i2)) ; index of the real part
(amp (sqrt (+ (* (aref frame i2m1) (aref frame i2m1))
(* (aref frame i2) (aref frame i2))))))
(setf (aref as (1+ i)) amp)))
(setf (aref as n) (aref frame (1- flen)))
as)) ;; return the amplitude spectrum
(send sa-class :answer :plot '(frame) '(
(let* ((as (sa-magnitude frame))
(sr (snd-srate sound)))
(s-plot (snd-from-array 0 (/ length sr) as)
sr (length as)))))
(defun sa-get-bin-width (sa-obj)
(send sa-obj :get-bin-width))
(send sa-class :answer :get-bin-width '()
'((/ (snd-srate sound) length)))
(defun sa-get-fft-size (sa-obj)
(send sa-obj :get-fft-size))
(send sa-class :answer :get-fft-size '() '(length))
(defun sa-get-fft-dur (sa-obj)
(send sa-obj :get-fft-dur))
(send sa-class :answer :get-fft-dur '() '(/ length (snd-srate sound)))
(defun sa-get-fft-window (sa-obj)
(send sa-obj :get-fft-window))
(send sa-class :answer :get-fft-window '() '(window-type))
(defun sa-get-fft-skip-period (sa-obj)
(send sa-obj :get-skip-period))
(send sa-class :answer :get-skip-period '() '((/ skip (snd-srate sound))))
(defun sa-get-fft-skip-size (sa-obj)
(send sa-obj :get-skip-size))
(send sa-class :answer :get-fft-skip-size '() '(skip))
(defun sa-get-sample-rate (sa-obj)
(send sa-obj :get-sample-rate))
(send sa-class :answer :get-sample-rate '() '((snd-srate sound)))
;;;;;;; TESTS ;;;;;;;;;;
(defun plot-test ()
(let (frame)
(setf sa (sa-init :input "./rpd-cello.wav"))
(while t
(setf frame (sa-next sa))
(if (null sa) (return nil))
(sa-plot sa frame))))

21
nyquist/stk.lsp
View File

@ -140,25 +140,36 @@
(snd-stkrev 2 snd rev-time mix)) (snd-stkrev 2 snd rev-time mix))
(defun nrev (snd rev-time mix) (defun nrev (snd rev-time mix)
(multichan-expand #'nyq:nrev snd rev-time mix)) (multichan-expand "NREV" #'nyq:nrev
'(((SOUND) "snd") ((NUMBER) "rev-time") ((NUMBER) "mix"))
snd rev-time mix))
(defun jcrev (snd rev-time mix) (defun jcrev (snd rev-time mix)
(multichan-expand #'nyq:jcrev snd rev-time mix)) (multichan-expand "JCREV" #'nyq:jcrev
'(((SOUND) "snd") ((NUMBER) "rev-time") ((NUMBER) "mix"))
snd rev-time mix))
(defun prcrev (snd rev-time mix) (defun prcrev (snd rev-time mix)
(multichan-expand #'nyq:prcrev snd rev-time mix)) (multichan-expand "PRCREV" #'nyq:prcrev
'(((SOUND) "snd") ((NUMBER) "rev-time") ((NUMBER) "mix"))
snd rev-time mix))
(defun nyq:chorus (snd depth freq mix &optional (base-delay 6000)) (defun nyq:chorus (snd depth freq mix &optional (base-delay 6000))
(snd-stkchorus snd base-delay depth freq mix)) (snd-stkchorus snd base-delay depth freq mix))
(defun stkchorus (snd depth freq mix &optional (base-delay 6000)) (defun stkchorus (snd depth freq mix &optional (base-delay 6000))
(multichan-expand #'nyq:chorus snd depth freq mix base-delay)) (multichan-expand "STKCHORUS" #'nyq:chorus
'(((SOUND) "snd") ((NUMBER) "depth") ((NUMBER) "freq") ((NUMBER) "mix")
((INTEGER) "base-delay"))
snd depth freq mix base-delay))
(defun nyq:pitshift (snd shift mix) (defun nyq:pitshift (snd shift mix)
(snd-stkpitshift snd shift mix)) (snd-stkpitshift snd shift mix))
(defun pitshift (snd shift mix) (defun pitshift (snd shift mix)
(multichan-expand #'nyq:pitshift snd shift mix)) (multichan-expand "PITSHIFT" #'nyq:pitshift
'(((SOUND) "snd") ((NUMBER) "shift") ((NUMBER) "mix"))
snd shift mix))

1187
nyquist/xm.lsp
View File

File diff suppressed because it is too large Load Diff