audacia
/
audacia
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Update Nyquist runtime to r288 

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
;;
(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
(vector #'snd-areson #'snd-aresonvc #'snd-aresoncv #'snd-aresonvv))
@ -11,14 +14,15 @@
;; NYQ:ARESON - notch filter, single channel
;;
(defun nyq:areson (signal center bandwidth normalize)
(select-implementation-1-2 areson-implementations
(select-implementation-1-2 "ARESON" areson-implementations
signal center bandwidth normalize))
;; hp - highpass filter
;;
(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
(vector #'snd-atone #'snd-atonev))
@ -26,15 +30,15 @@
;; NYQ:hp - highpass filter, single channel
;;
(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
;;
(defun comb-delay-from-hz (hz caller)
(defun comb-delay-from-hz (hz)
(recip hz))
;; comb-feedback-from-decay -- compute the feedback argument
;; comb-feedback -- compute the feedback argument
;;
(defun comb-feedback (decay delay)
(s-exp (mult -6.9087 delay (recip decay))))
@ -44,26 +48,30 @@
;; this is just a feedback-delay with different arguments
;;
(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)
(let (delay feedback len d)
; convert decay to feedback, iterate over array if necessary
(setf delay (comb-delay-from-hz hz "comb"))
; convert decay to feedback
(setf delay (/ (float hz)))
(setf feedback (comb-feedback decay delay))
(nyq:feedback-delay snd delay feedback)))
(nyq:feedback-delay snd delay feedback "COMB")))
;; ALPASS - all-pass filter
;;
(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)
(let (delay feedback len d)
; 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))
(nyq:alpass1 snd delay feedback min-hz)))
@ -71,26 +79,36 @@
;; CONST -- a constant at control-srate
;;
(defun const (value &optional (dur 1.0))
(ny:typecheck (not (numberp value))
(ny:error "CONST" 1 '((NUMBER) "value") value))
(ny:typecheck (not (numberp dur))
(ny:error "CONST" 2 '((NUMBER) "dur") dur))
(let ((d (get-duration dur)))
(snd-const value *rslt* *CONTROL-SRATE* d)))
;; CONVOLVE - slow convolution
;; CONVOLVE - fast convolution
;;
(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)
;;
(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
;;
(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
@ -99,15 +117,15 @@
;; NYQ:FEEDBACK-DELAY -- single channel delay
;;
(defun nyq:feedback-delay (snd delay feedback)
(select-implementation-1-2 feedback-delay-implementations
(defun nyq:feedback-delay (snd delay feedback &optional (src "FEEDBACK-DELAY"))
(select-implementation-1-2 src feedback-delay-implementations
snd delay feedback))
;; SND-ALPASS-ERROR -- report type error
;;
(defun snd-alpass-error (snd delay feedback)
(error "alpass with constant decay and variable hz is not implemented"))
(error "ALPASS with constant decay and variable hz is not implemented"))
(if (not (fboundp 'snd-alpasscv))
@ -120,10 +138,9 @@
(defun nyq:alpassvv (the-snd delay feedback min-hz)
(let (max-delay)
(cond ((or (not (numberp min-hz))
(<= min-hz 0))
(error "alpass needs numeric (>0) 4th parameter (min-hz) when delay is variable")))
(setf max-delay (/ 1.0 min-hz))
(ny:typecheck (or (not (numberp min-hz)) (<= min-hz 0))
(ny:error "ALPASS" 4 '((POSITIVE) "min-hz") min-hz))
(setf max-delay (/ (float min-hz)))
; make sure delay is between 0 and max-delay
; use clip function, which is symetric, with an offset
(setf delay (snd-offset (clip (snd-offset delay (* max-delay -0.5))
@ -152,17 +169,22 @@
;; NYQ:ALPASS1 -- single channel alpass
;;
(defun nyq:alpass1 (snd delay feedback min-hz)
(select-implementation-1-2 alpass-implementations
snd delay feedback min-hz))
(select-implementation-1-2 "ALPASS" alpass-implementations
snd delay feedback min-hz))
;; CONGEN -- contour generator, patterned after gated analog env gen
;;
(defun congen (gate rise fall) (multichan-expand #'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
;;
(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
@ -171,83 +193,125 @@
;; 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
;;
(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
;;
(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
;;
(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
;;
(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
;;
(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
;;
(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
;;
(defun noise (&optional (dur 1.0))
(ny:typecheck (not (numberp dur))
(ny:error "NOISE" 1 number-anon dur))
(let ((d (get-duration dur)))
(snd-white *rslt* *SOUND-SRATE* d)))
(defun noise-gate (snd &optional (lookahead 0.5) (risetime 0.02) (falltime 0.5)
(floor 0.01) (threshold 0.01))
(ny:typecheck (not (soundp snd))
(ny:error "NOISE-GATE" 1 '((SOUND) "snd") snd))
(ny:typecheck (not (numberp lookahead))
(ny:error "NOISE-GATE" 2 '((NUMBER) "lookahead") lookahead))
(ny:typecheck (not (numberp risetime))
(ny:error "NOISE-GATE" 3 '((NUMBER) "risetime") risetime))
(ny:typecheck (not (numberp falltime))
(ny:error "NOISE-GATE" 4 '((NUMBER) "falltime") falltime))
(ny:typecheck (not (numberp floor))
(ny:error "NOISE-GATE" 5 '((NUMBER) "floor") floor))
(ny:typecheck (not (numberp threshold))
(ny:error "NOISE-GATE" 6 '((NUMBER) "threshold") threshold))
(let ((rms (lp (mult snd snd) (/ *control-srate* 10.0))))
(setf threshold (* threshold threshold))
(mult snd (gate rms floor risetime falltime lookahead threshold))))
(mult snd (gate rms floor risetime falltime lookahead threshold "NOISE-GATE"))))
;; 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
;;
(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
;;
(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
;;
(defun rms (s &optional (rate 100.0) window-size)
(let (rslt step-size)
(cond ((not (eq (type-of s) 'SOUND))
(break "in RMS, first parameter must be a monophonic SOUND")))
(ny:typecheck (not (soundp s))
(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)))
(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 result (snd-avg s window-size step-size OP-AVERAGE))
;; compute square root of average
(s-exp (scale 0.5 (s-log result)))))
;; compute square root of average
(s-exp (scale 0.5 (s-log result)))))
;; RESON - bandpass filter
;;
(defun reson (s c b &optional (n 0))
(multichan-expand #'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
(vector #'snd-reson #'snd-resonvc #'snd-resoncv #'snd-resonvv))
@ -255,19 +319,23 @@
;; NYQ:RESON - bandpass filter, single channel
;;
(defun nyq:reson (signal center bandwidth normalize)
(select-implementation-1-2 reson-implementations
(select-implementation-1-2 "RESON" reson-implementations
signal center bandwidth normalize))
;; SHAPE -- waveshaper
;;
(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
;;
(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
@ -281,7 +349,8 @@
;; lp - lowpass filter
;;
(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
(vector #'snd-tone #'snd-tonev))
@ -289,7 +358,7 @@
;; NYQ:lp - lowpass filter, single channel
;;
(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
; 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.
(defun nyq:biquad (x b0 b1 b2 a0 a1 a2)
(if (<= a0 0.0)
(error (format nil "a0 < 0 (unstable parameter a0 = ~A) in biquad~%" a0)))
(let ((a0r (/ 1.0 a0)))
(setf a1 (* a0r a1)
(ny:typecheck (<= a0 0.0)
(error (format nil "In BIQUAD, a0 < 0 (unstable parameter a0 = ~A)" a0)))
(let ((a0r (/ (float a0))))
(setf a1 (* a0r a1)
a2 (* a0r a2))
(if (or (<= a2 -1.0) (<= (- 1.0 a2) (abs a1)))
(error (format nil
"(a2 <= -1) or (1 - a2 <= |a1|) (~A a1 = ~A, a2 = ~A) in biquad~%"
(ny:typecheck (or (<= a2 -1.0) (<= (- 1.0 a2) (abs a1)))
(error (format nil
"In BIQUAD, (a2 <= -1) or (1 - a2 <= |a1|) (~A a1 = ~A, a2 = ~A)"
"unstable parameters" a1 a2)))
(snd-biquad x (* a0r b0) (* a0r b1) (* a0r b2)
(snd-biquad x (* a0r b0) (* a0r b1) (* a0r b2)
a1 a2 0 0)))
(defun biquad (x b0 b1 b2 a0 a1 a2)
(multichan-expand #'nyq:biquad x b0 b1 b2 a0 a1 a2))
(defun biquad (x b0 b1 b2 a0 a1 a2 &optional (source "BIQUAD"))
(multichan-expand "BIQUAD" #'nyq:biquad
'(((SOUND) "snd") ((NUMBER) "b0") ((NUMBER) "b1")
((NUMBER) "b2") ((NUMBER) "a0") ((NUMBER) "a1")
((NUMBER) "a2"))
x b0 b1 b2 a0 a1 a2))
; biquad with Matlab sign conventions for a_i's.
(defun biquad-m (x b0 b1 b2 a0 a1 a2)
(multichan-expand #'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)))
; two-pole lowpass
(defun lowpass2 (x hz &optional (q 0.7071))
(multichan-expand #'nyq:lowpass2 x hz q))
(defun lowpass2 (x hz &optional (q 0.7071) (source "LOWPASS2"))
(multichan-expand source #'nyq:lowpass2
'(((SOUND) "snd") ((POSITIVE) "hz") ((POSITIVE) "q") ((STRING) "source"))
x hz q source))
;; NYQ:LOWPASS2 -- operates on single channel
(defun nyq:lowpass2 (x hz q)
(defun nyq:lowpass2 (x hz q source)
(if (or (> hz (* 0.5 (snd-srate x)))
(< hz 0))
(error "cutoff frequency out of range" hz))
@ -352,13 +441,15 @@
(b1 (- 1.0 cw))
(b0 (* 0.5 b1))
(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
(defun highpass2 (x hz &optional (q 0.7071))
(multichan-expand #'nyq:highpass2 x hz q))
(defun highpass2 (x hz &optional (q 0.7071) (source "HIGHPASS2"))
(multichan-expand source #'nyq:highpass2
'(((SOUND) "snd") ((POSITIVE) "hz") ((POSITIVE) "q") ((STRING) "source"))
x hz q source))
(defun nyq:highpass2 (x hz q)
(defun nyq:highpass2 (x hz q source)
(if (or (> hz (* 0.5 (snd-srate x)))
(< hz 0))
(error "cutoff frequency out of range" hz))
@ -372,11 +463,13 @@
(b1 (- -1.0 cw))
(b0 (* -0.5 b1))
(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.
(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)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
@ -389,11 +482,13 @@
(b0 alpha)
(b1 0.0)
(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.
(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)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
@ -406,31 +501,36 @@
(b0 1.0)
(b1 (* -2.0 cw))
(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.
(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)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
(cw (cos w))
(sw (sin w))
(k (exp (* -0.5 w (/ 1.0 q))))
(k (exp (* -0.5 w (/ (float q)))))
(a0 1.0)
(a1 (* -2.0 cw k))
(a2 (* k k))
(b0 a2)
(b1 a1)
(b2 1.0))
(nyq:biquad-m x b0 b1 b2 a0 a1 a2)))
(nyq:biquad-m x b0 b1 b2 a0 a1 a2 "ALLPASS2")))
; bass shelving EQ. gain in dB; Fc is halfway point.
; response becomes peaky at slope > 1.
(defun eq-lowshelf (x hz gain &optional (slope 1.0))
(multichan-expand #'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)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
@ -454,7 +554,9 @@
; treble shelving EQ. gain in dB; Fc is halfway point.
; response becomes peaky at slope > 1.
(defun eq-highshelf (x hz gain &optional (slope 1.0))
(multichan-expand #'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)
(let* ((w (* 2.0 Pi (/ hz (snd-srate x))))
@ -479,12 +581,20 @@
(eq-band-ccc x hz gain width))
((and (soundp hz) (soundp gain) (soundp width))
(snd-eqbandvvv x hz (db-to-linear gain) width))
(t
(error "eq-band hz, gain, and width must be all numbers or all sounds"))))
(t (error
(strcat
"In EQ-BAND, hz, gain, and width must be all numbers"
" or all sounds (if any parameter is an array, there"
" is a problem with at least one channel), hz is "
(param-to-string hz) ", gain is " (param-to-string gain)
", width is " (param-to-string width)) )) ))
; midrange EQ. gain in dB, width in octaves (half-gain width).
(defun eq-band (x hz gain width)
(multichan-expand #'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)
@ -507,53 +617,99 @@
; four-pole Butterworth lowpass
(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
(defun lowpass6 (x hz)
(lowpass2 (lowpass2 (lowpass2 x hz 0.58338080)
hz 0.75932572)
hz 1.95302407))
(lowpass2 (lowpass2 (lowpass2 x hz 0.58338080 "LOWPASS6")
hz 0.75932572 "LOWPASS6")
hz 1.95302407 "LOWPASS6"))
; eight-pole Butterworth lowpass
(defun lowpass8 (x hz)
(lowpass2 (lowpass2 (lowpass2 (lowpass2 x hz 0.57622191)
hz 0.66045510)
hz 0.94276399)
hz 2.57900101))
(lowpass2 (lowpass2 (lowpass2 (lowpass2 x hz 0.57622191 "LOWPASS8")
hz 0.66045510 "LOWPASS8")
hz 0.94276399 "LOWPASS8")
hz 2.57900101 "LOWPASS8"))
; four-pole Butterworth highpass
(defun highpass4 (x hz)
(highpass2 (highpass2 x hz 0.60492333) hz 1.33722126))
(highpass2 (highpass2 x hz 0.60492333 "HIGHPASS4")
hz 1.33722126 "HIGHPASS4"))
; six-pole Butterworth highpass
(defun highpass6 (x hz)
(highpass2 (highpass2 (highpass2 x hz 0.58338080)
hz 0.75932572)
hz 1.95302407))
(highpass2 (highpass2 (highpass2 x hz 0.58338080 "HIGHPASS6")
hz 0.75932572 "HIGHPASS6")
hz 1.95302407 "HIGHPASS6"))
; eight-pole Butterworth highpass
(defun highpass8 (x hz)
(highpass2 (highpass2 (highpass2 (highpass2 x hz 0.57622191)
hz 0.66045510)
hz 0.94276399)
hz 2.57900101))
(highpass2 (highpass2 (highpass2 (highpass2 x hz 0.57622191 "HIGHPASS8")
hz 0.66045510 "HIGHPASS8")
hz 0.94276399 "HIGHPASS8")
hz 2.57900101 "HIGHPASS8"))
; YIN
; maybe this should handle multiple channels, etc.
(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
(defun follow (sound floor risetime falltime lookahead)
(ny:typecheck (not (soundp sound))
(ny:error "FOLLOW" 1 '((SOUND) "sound") sound))
(ny:typecheck (not (numberp floor))
(ny:error "FOLLOW" 2 '((NUMBER) "floor") floor))
(ny:typecheck (not (numberp risetime))
(ny:error "FOLLOW" 3 '((NUMBER) "risetime") risetime))
(ny:typecheck (not (numberp falltime))
(ny:error "FOLLOW" 4 '((NUMBER) "stepsize") falltime))
(ny:typecheck (not (numberp lookahead))
(ny:error "FOLLOW" 5 '((NUMBER) "lookahead") lookahead))
;; use 10000s as "infinite" -- that's about 2^30 samples at 96K
(setf lookahead (round (* lookahead (snd-srate sound))))
(extract (/ lookahead (snd-srate sound)) 10000
(snd-follow sound floor risetime falltime lookahead)))
; Note: gate implementation moved to nyquist.lsp
;(defun gate (sound floor risetime falltime lookahead threshold)
; (setf lookahead (round (* lookahead (snd-srate sound))))
; (setf lookahead (/ lookahead (snd-srate sound)))
; (extract lookahead 10000
; (snd-gate sound lookahead risetime falltime floor threshold)))
;; PHASE VOCODER
(defun phasevocoder (s map &optional (fftsize -1) (hopsize -1) (mode 0))
(multichan-expand "PHASEVOCODER" #'snd-phasevocoder
'(((SOUND) nil) ((SOUND) "map") ((INTEGER) "fftsize")
((INTEGER) "hopsize") ((INTEGER) "mode"))
s map fftsize hopsize mode))
;; PV-TIME-PITCH
;; PV-TIME-PITCH -- control time stretch and transposition
;;
;; stretchfn maps from input time to output time
;; pitchfn maps from input time to transposition factor (2 means octave up)
(defun pv-time-pitch (input stretchfn pitchfn dur &optional
(fftsize 2048) (hopsize nil) (mode 0))
(multichan-expand "PV-TIME-PITCH" #'nyq:pv-time-pitch
'(((SOUND) "input") ((SOUND) "stretchfn") ((SOUND) "pitchfn")
((NUMBER) "dur") ((INTEGER) "fftsize") ((INT-OR-NULL) "hopsize")
((INTEGER) "mode"))
input stretchfn pitchfn dur fftsize hopsize mode))
(defun nyq:pv-time-pitch (input stretchfn pitchfn dur fftsize hopsize mode)
(let (wrate u v w vinv)
(if (null hopsize) (setf hopsize (/ fftsize 8)))
(setf wrate (/ 3000 dur))
(setf vinv (integrate (prod stretchfn pitchfn)))
(setf v (snd-inverse vinv (local-to-global 0) wrate))
(setf w (integrate (snd-recip (snd-compose pitchfn v))))
(sound-warp w (phasevocoder input v fftsize hopsize mode) wrate)))

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
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.
(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
standard output as follows:
@ -119,7 +119,7 @@ Saving the workspace automatically is something that Nyquist should do
(make-env-function name expression)
; make sure envelopes are redefined when workspace is loaded
(add-to-workspace '*envelopes*) ; so *envelopes* will be saved
(describe '*envelopes* "data for envelope editor in jNyqIDE")
(describe '*envelopes* "data for envelope editor in NyquistIDE")
(add-action-to-workspace 'make-env-functions)
nil)

102
nyquist/fileio.lsp
View File

@ -33,6 +33,7 @@
(cond ((equal *default-sf-dir* "") (setf *default-sf-dir* path))))
;; s-save -- saves a file
(setf *in-s-save* nil)
(setf NY:ALL 1000000000) ; 1GIG constant for maxlen
(defmacro s-save (expression &optional (maxlen NY:ALL) filename
&key (format '*default-sf-format*)
@ -42,27 +43,47 @@
`(let ((ny:fname ,filename)
(ny:maxlen ,maxlen)
(ny:endian ,endian)
(ny:swap 0))
; allow caller to omit maxlen, in which case the filename will
; be a string in the maxlen parameter position and filename will be null
(cond ((null ny:fname)
(cond ((stringp ny:maxlen)
(setf ny:fname ny:maxlen)
(setf ny:maxlen NY:ALL))
(t
(setf ny:fname *default-sound-file*)))))
(ny:swap 0)
max-sample) ; return value
(cond (*in-s-save*
(error "Recursive call to s-save (maybe play?) detected!")))
(progv '(*in-s-save*) '(t)
; allow caller to omit maxlen, in which case the filename will
; be a string in the maxlen parameter position and filename will be null
(cond ((null ny:fname)
(cond ((stringp ny:maxlen)
(setf ny:fname ny:maxlen)
(setf ny:maxlen NY:ALL))
(t
(setf ny:fname *default-sound-file*)))))
(cond ((equal ny:fname "")
(cond ((not ,play)
(format t "s-save: no file to write! play option is off!\n"))))
(t
(setf ny:fname (soundfilename ny:fname))
(format t "Saving sound file to ~A~%" ny:fname)))
(cond ((eq ny:endian :big)
(setf ny:swap (if (bigendianp) 0 1)))
((eq ny:endian :little)
(setf ny:swap (if (bigendianp) 1 0))))
(snd-save ',expression ny:maxlen ny:fname ,format ,mode ,bits ny:swap ,play)))
(cond ((equal ny:fname "")
(cond ((not ,play)
(format t "s-save: no file to write! play option is off!\n"))))
(t
(setf ny:fname (soundfilename ny:fname))
(format t "Saving sound file to ~A~%" ny:fname)))
(cond ((eq ny:endian :big)
(setf ny:swap (if (bigendianp) 0 1)))
((eq ny:endian :little)
(setf ny:swap (if (bigendianp) 1 0))))
; print device info the first time sound is played
(cond (,play
(cond ((not (boundp '*snd-list-devices*))
(setf *snd-list-devices* t))))) ; one-time show
(setf max-sample
(snd-save ',expression ny:maxlen ny:fname ,format
,mode ,bits ny:swap ,play))
; more information if *snd-list-devices* was unbound:
(cond (,play
(cond (*snd-list-devices*
(format t "\nSet *snd-list-devices* = t\n~A\n~A\n~A\n~A\n\n"
" and call play to see device list again."
"Set *snd-device* to a fixnum to select an output device"
" or set *snd-device* to a substring of a device name"
" to select the first device containing the substring.")))
(setf *snd-list-devices* nil))) ; normally nil
max-sample)))
;; MULTICHANNEL-MAX -- find peak over all channels
;;
@ -217,21 +238,21 @@
(local-to-global 0) format nchans mode bits swap srate
dur)))
;; SF-INFO -- print sound file info
;;
(defun sf-info (filename)
(let (s format channels mode bits swap srate dur flags)
(format t "~A:~%" (soundfilename filename))
(setf s (s-read filename))
(setf format (car *rslt*))
(setf channels (cadr *rslt*))
(setf mode (caddr *rslt*))
(setf bits (cadddr *rslt*))
(setf *rslt* (cddddr *rslt*))
(setf swap (car *rslt*))
(setf srate (cadr *rslt*))
(setf dur (caddr *rslt*))
(setf flags (cadddr *rslt*))
(setf format (snd-read-format *rslt*))
(setf channels (snd-read-channels *rslt*))
(setf mode (snd-read-mode *rslt*))
(setf bits (snd-read-bits *rslt*))
; (setf swap (snd-read-swap *rslt*))
(setf srate (snd-read-srate *rslt*))
(setf dur (snd-read-dur *rslt*))
(setf flags (snd-read-flags *rslt*))
(format t "Format: ~A~%"
(nth format '("none" "AIFF" "IRCAM" "NeXT" "Wave" "PAF" "SVX"
"NIST" "VOC" "W64" "MAT4" "Mat5" "PVF" "XI" "HTK"
@ -290,14 +311,15 @@
filename)
(setfn s-read-format car)
(setfn s-read-channels cadr)
(setfn s-read-mode caddr)
(setfn s-read-bits cadddr)
(defun s-read-swap (rslt) (car (cddddr rslt)))
(defun s-read-srate (rslt) (cadr (cddddr rslt)))
(defun s-read-dur (rslt) (caddr (cddddr rslt)))
(defun s-read-byte-offset (rslt) (car (cddddr (cddddr rslt))))
(setfn snd-read-format car)
(setfn snd-read-channels cadr)
(setfn snd-read-mode caddr)
(setfn snd-read-bits cadddr)
(defun snd-read-swap (rslt) (car (cddddr rslt)))
(defun snd-read-srate (rslt) (cadr (cddddr rslt)))
(defun snd-read-dur (rslt) (caddr (cddddr rslt)))
(defun snd-read-flags (rslt) (cadddr (cddddr rslt)))
(defun snd-read-byte-offset (rslt) (cadr (cddddr (cddddr rslt))))
;; round is tricky because truncate rounds toward zero as does C
;; in other words, rounding is down for positive numbers and up
@ -328,7 +350,7 @@
:time-offset ny:offset)
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*))
ny:peak))
@ -338,9 +360,9 @@
(ny:peak 0.0)
ny:input ny:rslt (ny:offset ,time-offset))
(format t "Overwriting ~A at offset ~A~%" ny:fname ny:offset)
(setf ny:offset (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
SND-HEAD-NONE 0 0 0 0.0))
SND-HEAD-NONE 0 0 0))
(format t "Duration written: ~A~%" (car *rslt*))
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")
;; "_" (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.
; *xlisp-traceback* -- print XLISP traceback on error in XLISP mode
; Typically, you do not want this because the full
; stack can be long and tedious.
; stack can be long and tedious. Also allow XLISP
; traceback in SAL mode if *sal-break* is true.
(setf *sal-mode* nil)
@ -192,3 +193,43 @@
;; search for either .lsp or .sal file
(sal-load ,file-name)))
;; COMPUTE-DEFAULT-SOUND-FILE -- construct and set *default-sound-file*
;;
;; (this is harder than it might seem because the default place for
;; sound files is in /tmp, which is shared by users, so we'd like to
;; use a user-specific name to avoid collisions)
;;
(defun compute-default-sound-file ()
(let (inf user extension)
; the reason for the user name is that if UserA creates a temp file,
; then UserB will not be able to overwrite it. The user name is a
; way to give each user a unique temp file name. Note that we don't
; want each session to generate a unique name because Nyquist doesn't
; delete the sound file at the end of the session.
(setf user (get-user))
#|
(cond ((null user)
(format t
"Please type your user-id so that I can construct a default
sound-file name. To avoid this message in the future, add
this to your .login file:
setenv USER <your id here>
or add this to your init.lsp file:
(setf *default-sound-file* \"<your filename here>\")
(setf *default-sf-dir* \"<full pathname of desired directory here>\")
Your id please: ")
(setf user (read))))
|#
; now compute the extension based on *default-sf-format*
(cond ((= *default-sf-format* snd-head-AIFF)
(setf extension ".aif"))
((= *default-sf-format* snd-head-Wave)
(setf extension ".wav"))
(t
(setf extension ".snd")))
(setf *default-sound-file*
(strcat (string-downcase user) "-temp" extension))
(format t "Default sound file is ~A.~%" *default-sound-file*)))

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

39
nyquist/sal.lsp
View File

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

119
nyquist/seq.lsp
View File

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

20
nyquist/seqmidi.lsp
View File

@ -19,7 +19,7 @@
(setf _the-seq (seq-copy ,the-seq))
(setf _nyq-environment (nyq:the-environment))
(setf _seq-midi-closure #'(lambda (t0)
; (format t "_seq_midi_closure: t0 = ~A~%" t0)
(format t "_seq_midi_closure: t0 = ~A~%" t0) ;DEBUG
(prog (_the-sound)
loop ; go forward until we find note to play (we may be there)
; then go forward to find time of next note
@ -45,6 +45,7 @@ loop ; go forward until we find note to play (we may be there)
((and (= _tag seq-note-tag)
,(make-note-test cases))
(cond (_the-sound ; we now have time of next note
; (display "note" (seq-time _the-event))
(setf _next-time (/ (seq-time _the-event) 1000.0))
(go exit-loop))
(t
@ -52,13 +53,13 @@ loop ; go forward until we find note to play (we may be there)
(seq-next _the-seq)
(go loop)
exit-loop ; here, we know time of next note
; (display "seq-midi" _next-time)
; (format t "seq-midi calling snd-seq\n")
(display "seq-midi" _next-time) ;DEBUG
(format t "seq-midi calling snd-seq\n") ;DEBUG
(return (snd-seq
(set-logical-stop-abs _the-sound
(local-to-global _next-time))
_seq-midi-closure)))))
; (display "calling closure" (get-lambda-expression _seq-midi-closure))
(display "calling closure" (get-lambda-expression _seq-midi-closure)) ; DEBUG
(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)
; (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))
(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)
(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)
(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))
(snd-stkchorus snd base-delay depth freq mix))
(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)
(snd-stkpitshift 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