Browse Source

Update Nyquist runtime to r288

Totally forgot about these when upgrading Nyquist to r288.
au-ny-api
Leland Lucius 2 years ago
parent
commit
e6c1a89123
  1. 370
      nyquist/dspprims.lsp
  2. 6
      nyquist/envelopes.lsp
  3. 102
      nyquist/fileio.lsp
  4. 70
      nyquist/follow.lsp
  5. 78
      nyquist/init.lsp
  6. 43
      nyquist/misc.lsp
  7. 38
      nyquist/nyinit-dbg.lsp
  8. 16
      nyquist/nyinit.lsp
  9. 1480
      nyquist/nyquist.lsp
  10. 576
      nyquist/sal-parse.lsp
  11. 39
      nyquist/sal.lsp
  12. 119
      nyquist/seq.lsp
  13. 20
      nyquist/seqmidi.lsp
  14. 196
      nyquist/sliders.lsp
  15. 47
      nyquist/spec-plot.lsp
  16. 289
      nyquist/spectral-analysis.lsp
  17. 21
      nyquist/stk.lsp
  18. 1213
      nyquist/xm.lsp

370
nyquist/dspprims.lsp

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

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

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

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

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

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

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

16
nyquist/nyinit.lsp

@ -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 "system.lsp" :verbose NIL)
;; now *file-separator* is defined, used by nyquist.lsp...
(load "nyquist.lsp" :verbose NIL)
(load "follow.lsp" :verbose NIL)
(load "system.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)

1480
nyquist/nyquist.lsp
File diff suppressed because it is too large
View File

576
nyquist/sal-parse.lsp

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