From e6c1a891231e712b781bd9f94d91d0513856b2b3 Mon Sep 17 00:00:00 2001 From: Leland Lucius Date: Mon, 13 Jan 2020 12:43:39 -0600 Subject: [PATCH] Update Nyquist runtime to r288 Totally forgot about these when upgrading Nyquist to r288. --- nyquist/dspprims.lsp | 370 ++++++--- nyquist/envelopes.lsp | 6 +- nyquist/fileio.lsp | 102 ++- nyquist/follow.lsp | 70 -- nyquist/init.lsp | 78 -- nyquist/misc.lsp | 43 +- nyquist/nyinit-dbg.lsp | 38 + nyquist/nyinit.lsp | 18 +- nyquist/nyquist.lsp | 1478 ++++++++++++++++++++++++--------- nyquist/sal-parse.lsp | 576 +++++++------ nyquist/sal.lsp | 39 +- nyquist/seq.lsp | 119 +-- nyquist/seqmidi.lsp | 20 +- nyquist/sliders.lsp | 196 +++++ nyquist/spec-plot.lsp | 47 ++ nyquist/spectral-analysis.lsp | 289 +++++++ nyquist/stk.lsp | 21 +- nyquist/xm.lsp | 1187 +++++++++++++++++--------- 18 files changed, 3263 insertions(+), 1434 deletions(-) delete mode 100644 nyquist/follow.lsp create mode 100644 nyquist/nyinit-dbg.lsp create mode 100644 nyquist/sliders.lsp create mode 100644 nyquist/spec-plot.lsp create mode 100644 nyquist/spectral-analysis.lsp diff --git a/nyquist/dspprims.lsp b/nyquist/dspprims.lsp index c6750ee5a..42ad02fda 100644 --- a/nyquist/dspprims.lsp +++ b/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))) + diff --git a/nyquist/envelopes.lsp b/nyquist/envelopes.lsp index 67979972f..18e6a6f65 100644 --- a/nyquist/envelopes.lsp +++ b/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) diff --git a/nyquist/fileio.lsp b/nyquist/fileio.lsp index 6408d6059..fb2b79f03 100644 --- a/nyquist/fileio.lsp +++ b/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)) diff --git a/nyquist/follow.lsp b/nyquist/follow.lsp deleted file mode 100644 index 7332fa79a..000000000 --- a/nyquist/follow.lsp +++ /dev/null @@ -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))) - diff --git a/nyquist/init.lsp b/nyquist/init.lsp index 5fc5cbc3c..e2b905c6c 100644 --- a/nyquist/init.lsp +++ b/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") diff --git a/nyquist/misc.lsp b/nyquist/misc.lsp index 6ac521612..c81726ca8 100644 --- a/nyquist/misc.lsp +++ b/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 +or add this to your init.lsp file: + (setf *default-sound-file* \"\") + (setf *default-sf-dir* \"\") + +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*))) + + diff --git a/nyquist/nyinit-dbg.lsp b/nyquist/nyinit-dbg.lsp new file mode 100644 index 000000000..352844575 --- /dev/null +++ b/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) + + diff --git a/nyquist/nyinit.lsp b/nyquist/nyinit.lsp index 6560334d5..9846fb65d 100644 --- a/nyquist/nyinit.lsp +++ b/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 "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) diff --git a/nyquist/nyquist.lsp b/nyquist/nyquist.lsp index c4f4eb689..2d2e4312a 100644 --- a/nyquist/nyquist.lsp +++ b/nyquist/nyquist.lsp @@ -5,7 +5,112 @@ ;;; ### Copyright (c) 1994-2006 by Roger B. Dannenberg ### ;;; ########################################################### ;;; -(load "fileio.lsp" :verbose NIL) +(princ "LOADING NYQUIST RUNTIME DEBUG VERSION\n") + +;; #### Error checking and reporting functions #### + +(setf *SAL-CALL-STACK* nil) ; because SEQ looks at this + +;; MULTICHANNEL-SOUNDP - test for vector of sounds +(defun multichannel-soundp (v) + (prog ((rslt t)) + (if (not (arrayp v)) (return nil)) + (dotimes (i (length v)) + (cond ((not (soundp (aref v i))) + (setf rslt nil) + (return nil)))) + (return rslt))) + +;; MULTICHANNELP - test for vector of sounds or numbers +(defun multichannelp (v) + (prog ((rslt t)) + (if (not (arrayp v)) (return nil)) + (dotimes (i (length v)) + (cond ((not (or (numberp (aref v i)) (soundp (aref v i)))) + (setf rslt nil) + (return nil)))) + (return rslt))) + +;; NUMBERSP - test for vector of numbers +(defun numbersp (v) + (prog ((rslt t)) + (if (not (arrayp v)) (return nil)) + (dotimes (i (length v)) + (cond ((not (numberp (aref v i))) + (setf rslt nil) + (return nil)))) + (return rslt))) + + +;; PARAM-TO-STRING - make printable parameter for error message +(defun param-to-string (param) + (cond ((null param) (format nil "NIL")) + ((soundp param) (format nil "a SOUND")) + ((multichannel-soundp param) + (format nil "a ~A-channel SOUND" (length param))) + ((eq (type-of param) 'ARRAY) ;; avoid saying "#(1 2), a ARRAY" + (format nil "~A, an ARRAY" param)) + ((stringp param) (format nil "~s, a STRING" param)) ;; add quotes + (t + (format nil "~A, a ~A" param (symbol-name (type-of param)))))) + + +;; NY:TYPECHECK -- syntactic sugar for "if", used for all nyquist typechecks +(setfn ny:typecheck if) + +(defun index-to-string (index) + (nth index '("" " 1st" " 2nd" " 3rd" " 4th" " 5th" " 6th" " 7th"))) + +(setf number-anon '((NUMBER) nil)) +(setf number-sound-anon '((NUMBER SOUND) nil)) + +;; NY:TYPE-LIST-AS-STRING - convert permissible type list into +;; description. E.g. typs = '(NUMBER SOUND) and multi = t returns: +;; "number, sound or array thereof" +(defun ny:type-list-as-string (typs multi) + (let (lis last penultimate (string "") multi-clause) + (if (member 'NUMBER typs) (push "number" lis)) + (if (member 'POSITIVE typs) (push "positive number" lis)) + (if (member 'NONNEGATIVE typs) (push "non-negative number" lis)) + (if (member 'INTEGER typs) (push "integer" lis)) + (if (member 'STEP typs) (push "step number" lis)) + (if (member 'STRING typs) (push "string" lis)) + (if (member 'SOUND typs) (push "sound" lis)) + (if (member 'NULL typs) (push "NIL" lis)) + ;; this should be handled with two entries: INTEGER and NULL, but + ;; this complicates multichan-expand, where lists of arbitrary types + ;; are not handled and we need INT-OR-NULL for PV-TIME-PITCH's + ;; hopsize parameter. + (cond ((member 'INT-OR-NULL typs) + (push "integer" lis) + (push "NIL" lis))) + (cond ((member 'POSITIVE-OR-NULL typs) + (push "positive number" lis) + (push "NIL" lis))) + (cond (multi + (setf multi-clause + (cond ((> (length lis) 1) "array thereof") + ((equal (car lis) "sound") "multichannel sound") + (t (strcat "array of " (car lis) "s")))) + (push multi-clause lis))) + (setf last (first lis)) + (setf penultimate (second lis)) + (setf lis (cddr lis)) + (dolist (item lis) + (setf string (strcat item ", " string))) + (strcat string (if penultimate (strcat penultimate " or ") "") last))) + + +;; NY:ERROR -- construct an error message and raise an error +(defun ny:error (src index typ val &optional multi (val2 nil second-val)) + (let ((types-string (ny:type-list-as-string (first typ) multi))) + (error (strcat "In " src "," (index-to-string index) " argument" + (if (second typ) (strcat " (" (second typ) ")") "") + (if (eq (char types-string 0) #\i) " must be an " " must be a ") + types-string + ", got " (param-to-string val) + (if second-val (strcat ", and" (param-to-string val2)) ""))))) + (prog () (setq lppp -12.0) (setq lpp -9.0) (setq lp -6.0) (setq lmp -3.0) @@ -46,7 +151,9 @@ c6 (cs6 df6) d6 (ds6 ef6) e6 f6 (fs6 gf6) g6 (gs6 af6) a6 (as6 bf6) b6 c7 (cs7 df7) d7 (ds7 ef7) e7 f7 (fs7 gf7) g7 (gs7 af7) a7 - (as7 bf7) b7)) + (as7 bf7) b7 + c8 (cs8 df8) d8 (ds8 ef8) e8 f8 (fs8 gf8) g8 (gs8 af8) a8 + (as8 bf8) b8)) (dolist (p nyq:pitch-names) (cond ((atom p) (set p (np))) @@ -78,19 +185,21 @@ ;; GLOBAL ENVIRONMENT VARIABLES and their startup values: (defun nyq:environment-init () - (setq *WARP* '(0.0 1.0 nil)) - (setq *LOUD* 0.0) ; now in dB - (setq *TRANSPOSE* 0.0) - (setq *SUSTAIN* 1.0) - (setq *START* MIN-START-TIME) - (setq *STOP* MAX-STOP-TIME) - (setq *CONTROL-SRATE* *DEFAULT-CONTROL-SRATE*) + (setq *WARP* '(0.0 1.0 nil)) + (setq *LOUD* 0.0) ; now in dB + (setq *TRANSPOSE* 0.0) + (setq *SUSTAIN* 1.0) + (setq *START* MIN-START-TIME) + (setq *STOP* MAX-STOP-TIME) + (setq *CONTROL-SRATE* *DEFAULT-CONTROL-SRATE*) (setq *SOUND-SRATE* *DEFAULT-SOUND-SRATE*) t) ; return nothing in particular (nyq:environment-init) (defun get-duration (dur) + (ny:typecheck (not (numberp dur)) + (ny:error "GET-DURATION" 0 number-anon dur)) (let ((duration (- (local-to-global (* (get-sustain) dur)) (setf *rslt* (local-to-global 0))))) @@ -120,14 +229,14 @@ functions assume durations are always positive."))) (defun get-tempo () - (slope (snd-inverse (get-warp) (local-to-global 0) - *control-srate*))) + (if (warp-function *WARP*) + (slope (snd-inverse (get-warp) (local-to-global 0) + *control-srate*)) + (/ 1.0 (warp-stretch *WARP*)))) (defun get-transpose () (cond ((numberp *TRANSPOSE*) *TRANSPOSE*) ((soundp *TRANSPOSE*) - ; (display "get-transpose: lookup " 0) - ; (format t "samples: ~A~%" (snd-samples *TRANSPOSE* 100)) (sref *TRANSPOSE* 0)) (t (error (format t "*TRANSPOSE* should be a number or sound: ~A" *TRANSPOSE*))))) @@ -135,17 +244,28 @@ functions assume durations are always positive."))) (defun get-warp () (let ((f (warp-function *WARP*))) - (cond ((null f) (error "Null warp function")) - (t - (shift-time (scale-srate f (/ (warp-stretch *WARP*))) - (- (warp-time *WARP*))))))) + (ny:typecheck (null f) + (error "In GET-WARP, there is no warp function, probably because you are not within WARP or WARP-ABS")) + (shift-time (scale-srate f (/ (warp-stretch *WARP*))) + (- (warp-time *WARP*))))) +(load "dspprims.lsp" :verbose NIL) +(load "fileio.lsp" :verbose NIL) + ;;;;;;;;;;;;;;;;;;;;;; ;; OSCILATORS ;;;;;;;;;;;;;;;;;;;;;; -(defun build-harmonic (n table-size) (snd-sine 0 n table-size 1)) +(defun build-harmonic (n table-size) + (ny:typecheck (not (integerp n)) + (ny:error "BUILD-HARMONIC" 1 '((INTEGER) "n") n)) + (ny:typecheck (not (integerp table-size)) + (ny:error "BUILD-HARMONIC" 2 '((INTEGER) "table-size") table-size)) + (ny:typecheck (>= n (/ table-size 2)) + (error "In BUILD-HARMONIC, harmonic number should be less than half the table size" + (list n table-size))) + (snd-sine 0 n table-size 1)) (setf *SINE-TABLE* (list (build-harmonic 1 2048) (hz-to-step 1.0) @@ -153,27 +273,96 @@ functions assume durations are always positive."))) (setf *TABLE* *SINE-TABLE*) -(defun calculate-hz (pitch what) +(defun calculate-hz (pitch what &optional (max-fraction 0.5) maxlength) (let ((hz (step-to-hz (+ pitch (get-transpose)))) - (octaves 0)) - (cond ((> hz (/ *SOUND-SRATE* 2)) - (format t "Warning: ~A frequency (~A hz) will alias at current sample rate (~A hz).\n" - what hz *SOUND-SRATE*) - (while (> hz *SOUND-SRATE*) - (setf octaves (1+ octaves) - hz (* hz 0.5))) - (cond ((> octaves 0) - (format t "Warning: ~A frequency reduced by ~A octaves to ~A hz (which will still alias).\n" - what octaves hz))))) + (octaves 0) original) + (setf original hz) + (while (>= hz (* *SOUND-SRATE* max-fraction)) + (setf octaves (1+ octaves) + hz (* hz 0.5))) + (cond ((> octaves 0) + (format t + "Warning: ~A frequency reduced by ~A octaves from ~A to ~A hz to avoid aliasing.\n" + what octaves original hz) + (setf octaves 0))) + (while (and maxlength (<= hz (/ *SOUND-SRATE* maxlength))) + (setf octaves (1+ octaves) + hz (* hz 2.0))) + (cond ((> octaves 0) + (format t + "Warning: ~A frequency increased by ~A octaves from ~A to ~A hz due to restriction on maximum table length.\n" + what octaves original hz))) hz)) +(defun ny:assert-env-spec (env-spec message) + (if (not (ny:env-spec-p env-spec)) + (error message env-spec))) + + +(defun ny:assert-table (fun-name index formal actual) + (if (not (and (listp actual) (= 3 (length actual)))) + (error (format nil + "In ~A,~A argument (~A) should be a list of 3 elements, got ~A" + fun-name (index-to-string index) formal actual))) + (if (not (soundp (car actual))) + (error (format nil + "In ~A,~A argument (~A) should be a list beginning with a sound, got ~A" + fun-name (index-to-string index) formal actual))) + (if (not (numberp (second actual))) + (error (format nil + "In ~A,~A argument (~A) should be a list whose 2nd element is a step number (pitch), got ~A" + fun-name (index-to-string index) formal actual))) + (if (not (third actual)) + (error (format nil + "In ~A,~A argument (~A) should be a list whose 3rd element is true, got ~A" + fun-name (index-to-string index) formal actual)))) + + +(defun ny:assert-sample (fun-name index formal actual) + (if (not (and (listp actual) (= 3 (length actual)))) + (error (format nil + "In ~A,~A argument (~A) should be a list of 3 elements, got ~A" + fun-name (index-to-string index) formal actual))) + (if (not (soundp (car actual))) + (error (format nil + "In ~A,~A argument (~A) should be a list beginning with a sound, got ~A" + fun-name (index-to-string index) formal actual))) + (if (not (numberp (second actual))) + (error (format nil + "In ~A,~A argument (~A) should be a list whose 2nd element is a step number (pitch), got ~A" + fun-name (index-to-string index) formal actual))) + (if (not (numberp (third actual))) + (error (format nil + "In ~A,~A argument (~A) should be a list whose 3rd element is the sample start time, got ~A" + fun-name (index-to-string index) formal actual)))) + +(defun ny:env-spec-p (env-spec) + (prog (len (rslt t)) + (if (not (listp env-spec)) (return nil)) + (setf len (length env-spec)) + (if (< len 6) (return nil)) + (if (> len 7) (return nil)) + (dolist (x env-spec) + (cond ((not (numberp x)) + (setf rslt nil) + (return nil)))) + (return rslt))) + + ;; AMOSC ;; (defun amosc (pitch modulation &optional (sound *table*) (phase 0.0)) + (ny:typecheck (not (numberp pitch)) + (ny:error "AMOSC" 1 '((STEP) "pitch") pitch)) + (ny:typecheck (not (soundp modulation)) + (ny:error "AMOSC" 2 '((SOUND) "modulation") modulation)) + (ny:assert-table "AMOSC" 3 "table" sound) + (ny:typecheck (not (numberp phase)) + (ny:error "AMOSC" 4 '((NUMBER) "phase") phase)) (let ((modulation-srate (snd-srate modulation)) (hz (calculate-hz pitch "amosc"))) - (scale-db (get-loud) + (ny:scale-db (get-loud) (snd-amosc (car sound) ; samples for table (cadr sound) ; step represented by table @@ -191,9 +380,16 @@ functions assume durations are always positive."))) ;; handle upsampling cases internally. ;; (defun fmosc (pitch modulation &optional (sound *table*) (phase 0.0)) + (ny:typecheck (not (numberp pitch)) + (ny:error "FMOSC" 1 '((STEP) "pitch") pitch)) + (ny:typecheck (not (soundp modulation)) + (ny:error "FMOSC" 2 '((SOUND) "modulation") modulation)) + (ny:assert-table "FMOSC" 3 "table" sound) + (ny:typecheck (not (numberp phase)) + (ny:error "FMOSC" 4 '((NUMBER) "phase") phase)) (let ((modulation-srate (snd-srate modulation)) (hz (calculate-hz pitch "fmosc"))) - (scale-db (get-loud) + (ny:scale-db (get-loud) (snd-fmosc (car sound) ; samples for table (cadr sound) ; step represented by table @@ -208,12 +404,18 @@ functions assume durations are always positive."))) ;; ;; this code is based on FMOSC above ;; -(defun fmfb (pitch index &optional dur) +(defun fmfb (pitch index &optional (dur 1.0)) + (ny:typecheck (not (numberp pitch)) + (ny:error "FMFB" 1 '((STEP) "pitch") pitch)) + (ny:typecheck (not (or (numberp index) (soundp index))) + (ny:error "FMFB" 2 '((NUMBER SOUND) "index") index)) + (ny:typecheck (not (numberp dur)) + (ny:error "FMFB" 3 '((NUMBER) "dur") dur)) (let ((hz (calculate-hz pitch "fmfb"))) (setf dur (get-duration dur)) (cond ((soundp index) (ny:fmfbv hz index)) (t - (scale-db (get-loud) + (ny:scale-db (get-loud) (snd-fmfb (local-to-global 0) hz *SOUND-SRATE* index dur)))))) @@ -223,7 +425,7 @@ functions assume durations are always positive."))) (cond ((< *SOUND-SRATE* modulation-srate) (format t "Warning: down-sampling FM modulation in fmfb~%") (setf index (snd-down *SOUND-SRATE* index)))) - (scale-db (get-loud) + (ny:scale-db (get-loud) (snd-fmfbv (local-to-global 0) hz *SOUND-SRATE* index)))) @@ -233,13 +435,19 @@ functions assume durations are always positive."))) ;; ("time_type" "t0") ("sound_type" "s_fm")) ;; (defun buzz (n pitch modulation) + (ny:typecheck (not (integerp n)) + (ny:error "BUZZ" 1 '((INTEGER) "number of harmonics") n)) + (ny:typecheck (not (numberp pitch)) + (ny:error "BUZZ" 2 '((STEP) "pitch") pitch)) + (ny:typecheck (not (soundp modulation)) + (ny:error "BUZZ" 3 '((SOUND) "modulation") modulation)) (let ((modulation-srate (snd-srate modulation)) (hz (calculate-hz pitch "buzz nominal"))) (cond ((< *SOUND-SRATE* modulation-srate) (format t "Warning: down-sampling modulation in buzz~%") (setf modulation (snd-down *SOUND-SRATE* modulation)))) (setf n (max n 1)) ; avoid divide by zero problem - (scale-db (get-loud) + (ny:scale-db (get-loud) (snd-buzz n ; number of harmonics *SOUND-SRATE* ; output sample rate hz ; output hz @@ -253,6 +461,11 @@ functions assume durations are always positive."))) ;; also, hz may be a scalar or a sound ;; (defun hzosc (hz &optional (sound *table*) (phase 0.0)) + (ny:typecheck (not (or (numberp hz) (soundp hz))) + (ny:error "HZOSC" 1 '((NUMBER SOUND) "hz") hz)) + (ny:assert-table "HZOSC" 2 "table" sound) + (ny:typecheck (not (numberp phase)) + (ny:error "HZOSC" 3 '((NUMBER) "phase") phase)) (let (hz-srate) (cond ((numberp hz) (osc (hz-to-step hz) 1.0 sound phase)) @@ -261,7 +474,7 @@ functions assume durations are always positive."))) (cond ((< *SOUND-SRATE* hz-srate) (format t "Warning: down-sampling hz in hzosc~%") (setf hz (snd-down *SOUND-SRATE* hz)))) - (scale-db (get-loud) + (ny:scale-db (get-loud) (snd-fmosc (car sound) ; samples for table (cadr sound) ; step repr. by table *SOUND-SRATE* ; output sample rate @@ -285,41 +498,47 @@ functions assume durations are always positive."))) ;; length note. (defun siosc-breakpoints (breakpoints) - (display "siosc-breakpoints" breakpoints) - (prog (sample-count result (last-count 0) time-factor) + (prog (sample-count result (last-count 0) time-factor (index 0)) (setf time-factor (- (local-to-global (get-sustain)) (local-to-global 0.0))) (setf time-factor (* time-factor *SOUND-SRATE*)) - (cond ((and (listp breakpoints) - (cdr breakpoints) - (cddr breakpoints))) - (t (error "SIOSC table list must have at least 3 elements"))) + (ny:typecheck (not (and (listp breakpoints) + (cdr breakpoints) + (cddr breakpoints))) + (error "In SIOSC, 3rd argument (breakpoints) must be a list with at least 3 elements" + breakpoints)) loop - (cond ((and (listp breakpoints) - (soundp (car breakpoints))) - (push (car breakpoints) result) - (setf breakpoints (cdr breakpoints))) - (t - (error "SIOSC expecting SOUND in table list"))) - (cond ((and breakpoints - (listp breakpoints) - (numberp (car breakpoints))) - (setf sample-count (truncate - (+ 0.5 (* time-factor (car breakpoints))))) - (cond ((< sample-count last-count) - (setf sample-count (1+ last-count)))) - (push sample-count result) - (setf last-count sample-count) - (setf breakpoints (cdr breakpoints)) - (cond (breakpoints - (go loop)))) - (breakpoints - (error "SIOSC expecting number (time) in table list"))) + (ny:typecheck (not (and (listp breakpoints) + (soundp (car breakpoints)))) + (error (format nil + "In SIOSC, expected a sound in breakpoints list at index ~A" + index) + (car breakpoints))) + (push (car breakpoints) result) + (setf breakpoints (cdr breakpoints)) + (setf index (1+ index)) + (cond (breakpoints + (ny:typecheck (not (and (listp breakpoints) + (numberp (car breakpoints)))) + (error (format nil + "In SIOSC, expected a number (time) in breakpoints list at index ~A" + index) + (car breakpoints))) + (setf sample-count (truncate + (+ 0.5 (* time-factor (car breakpoints))))) + (cond ((< sample-count last-count) + (setf sample-count (1+ last-count)))) + (push sample-count result) + (setf last-count sample-count) + (setf breakpoints (cdr breakpoints)) + (setf index (1+ index)) + (cond (breakpoints + (go loop))))) (setf result (reverse result)) - (display "siosc-breakpoints" result) (return result))) + ;; SIOSC -- spectral interpolation oscillator ;; ;; modulation rate must be less than or equal to sound-srate, so @@ -327,12 +546,16 @@ loop ;; handle upsampling cases internally. ;; (defun siosc (pitch modulation breakpoints) + (ny:typecheck (not (numberp pitch)) + (ny:error "SIOSC" 1 '((STEP) "pitch") pitch)) + (ny:typecheck (not (soundp modulation)) + (ny:error "SIOSC" 2 '((SOUND) "modulation") modulation)) (let ((modulation-srate (snd-srate modulation)) (hz (calculate-hz pitch "siosc nominal"))) (cond ((< *SOUND-SRATE* modulation-srate) (format t "Warning: down-sampling FM modulation in siosc~%") (setf modulation (snd-down *SOUND-SRATE* modulation)))) - (scale-db (get-loud) + (ny:scale-db (get-loud) (snd-siosc (siosc-breakpoints breakpoints) ; tables *SOUND-SRATE* ; output sample rate hz ; output hz @@ -347,12 +570,19 @@ loop ;; (defun lfo (freq &optional (duration 1.0) (sound *SINE-TABLE*) (phase 0.0)) + (ny:typecheck (not (numberp freq)) + (ny:error "LFO" 1 '((NUMBER) "freq") freq)) + (ny:typecheck (not (numberp duration)) + (ny:error "LFO" 2 '((NUMBER) "duration") duration)) + (ny:assert-table "LFO" 3 "table" sound) + (ny:typecheck (not (numberp phase)) + (ny:error "LFO" 4 '((NUMBER) "phase") phase)) (let ((d (get-duration duration))) (if (minusp d) (setf d 0)) (cond ((> freq (/ *CONTROL-SRATE* 2)) (format t "Warning: lfo frequency (~A hz) will alias at current control rate (~A hz).\n" freq *CONTROL-SRATE*))) - (set-logical-stop + (ny:set-logical-stop (snd-osc (car sound) ; samples for table (cadr sound) ; step represented by table @@ -367,6 +597,11 @@ loop ;; FMLFO -- like LFO but uses frequency modulation ;; (defun fmlfo (freq &optional (sound *SINE-TABLE*) (phase 0.0)) + (ny:typecheck (not (soundp freq)) + (ny:error "FMLFO" 1 '((SOUND) "freq") freq)) + (ny:assert-table "FMLFO" 2 "table" sound) + (ny:typecheck (not (numberp phase)) + (ny:error "FMLFO" 3 '((NUMBER) "phase") phase)) (let () (cond ((numberp freq) (lfo freq 1.0 sound phase)) @@ -383,10 +618,17 @@ loop ;; (defun osc (pitch &optional (duration 1.0) (sound *TABLE*) (phase 0.0)) + (ny:typecheck (not (numberp pitch)) + (ny:error "OSC" 1 '((STEP) "pitch") pitch)) + (ny:typecheck (not (numberp duration)) + (ny:error "OSC" 2 '((NUMBER) "duration") duration)) + (ny:assert-table "OSC" 3 "table" sound) + (ny:typecheck (not (numberp phase)) + (ny:error "OSC" 4 '((NUMBER) "phase") phase)) (let ((d (get-duration duration)) - (hz (calculate-hz pitch "osc"))) - (set-logical-stop - (scale-db (get-loud) + (hz (calculate-hz pitch "osc"))) + (ny:set-logical-stop + (snd-scale (db-to-linear (get-loud)) (snd-osc (car sound) ; samples for table (cadr sound) ; step represented by table @@ -401,16 +643,30 @@ loop ;; PARTIAL -- sine osc with built-in envelope scaling ;; (defun partial (steps env) + (ny:typecheck (not (numberp steps)) + (ny:error "PARTIAL" 1 '((STEP) "steps") steps)) + (ny:typecheck (not (soundp env)) + (ny:error "PARTIAL" 2 '((SOUND) "env") env)) (let ((hz (calculate-hz steps "partial"))) - (scale-db (get-loud) + (ny:scale-db (get-loud) (snd-partial *sound-srate* hz (force-srate *sound-srate* env))))) +(setf *SINE-SAMPLE* (list (first *TABLE*) (second *TABLE*) 0.0)) + + ;; SAMPLER -- simple attack + sustain sampler ;; (defun sampler (pitch modulation - &optional (sample *table*) (npoints 2)) + &optional (sample *SINE-SAMPLE*) (npoints 2)) + (ny:typecheck (not (numberp pitch)) + (ny:error "SAMPLER" 1 '((STEP) "pitch") pitch)) + (ny:typecheck (not (soundp modulation)) + (ny:error "SAMPLER" 2 '((SOUND) "modulation") modulation)) + (ny:assert-sample "SAMPLER" 3 "table" sample) + (ny:typecheck (not (integerp npoints)) + (ny:error "BUZZ" 3 '((INTEGER) "npoints") npoints)) (let ((samp (car sample)) (samp-pitch (cadr sample)) (samp-loop-start (caddr sample)) @@ -418,7 +674,7 @@ loop ; make a waveform table look like a sample with no attack: (cond ((not (numberp samp-loop-start)) (setf samp-loop-start 0.0))) - (scale-db (get-loud) + (ny:scale-db (get-loud) (snd-sampler samp ; samples for table samp-pitch ; step represented by table @@ -433,10 +689,14 @@ loop ;; SINE -- simple sine oscillator ;; (defun sine (steps &optional (duration 1.0)) + (ny:typecheck (not (numberp steps)) + (ny:error "SINE" 1 '((STEP) "steps") steps)) + (ny:typecheck (not (numberp duration)) + (ny:error "SINE" 2 '((NUMBER) "duration") duration)) (let ((hz (calculate-hz steps "sine")) (d (get-duration duration))) - (set-logical-stop - (scale-db (get-loud) + (ny:set-logical-stop + (ny:scale-db (get-loud) (snd-sine *rslt* hz *sound-srate* d)) duration))) @@ -447,10 +707,17 @@ loop ;; ("time_type" "d") ("double" "final_amp")) ;; (defun pluck (steps &optional (duration 1.0) (final-amp 0.001)) - (let ((hz (calculate-hz steps "pluck")) + (ny:typecheck (not (numberp steps)) + (ny:error "PLUCK" 1 '((NUMBER) "steps") steps)) + (ny:typecheck (not (numberp duration)) + (ny:error "PLUCK" 2 '((NUMBER) "duration") duration)) + (ny:typecheck (not (numberp final-amp)) + (ny:error "PLUCK" 3 '((NUMBER) "final-amp") final-amp)) + ;; 200000 is MAXLENGTH in nyquist/tran/pluck.alg - the max table length + (let ((hz (calculate-hz steps "pluck" (/ 1.0 3) 200000)) (d (get-duration duration))) - (set-logical-stop - (scale-db (get-loud) + (ny:set-logical-stop + (ny:scale-db (get-loud) (snd-pluck *SOUND-SRATE* hz *rslt* d final-amp)) duration))) @@ -467,46 +734,82 @@ loop ,s)) -; nyq:add2 - add two arguments +;; (NYQ:TO-ARRAY SOUND N) - duplicate SOUND to N channels +; +(defun nyq:to-array (value len) + (let ((a (make-array len))) + (dotimes (i len) + (setf (aref a i) value)) + a)) + + +; nyq:add2 - add two arguments. +; +; Assumes s1 and s2 are numbers, sounds, or multichannel sounds or numbers +; +; Semantics: numbers and sounds can be freely mixed and +; add as expected. Arrays (multichannel) arguments are +; added channel-by-channel, and if one array is larger, +; the "extra" channels are simply copied to the result. +; Therefore the result has the channel count of the +; maximum channel count in s1 or s2. When adding a +; multichannel sound to a (non-multichannel) sound, the +; sound is coerced to a 1-channel multi-channel sound, +; and therefore adds to channel 1 of the multi-channel +; sound. However, when adding a multichannel sound to a +; number, the number is added to *every* channel. +; Semantics differ from the normal multichan-expand processing +; in that sounds are considered to be a multichannel sound +; with 1 channel, and channel counts do not have to match +; when processing array arguments. ; (defun nyq:add2 (s1 s2) - (cond ((and (arrayp s1) (not (arrayp s2))) - (setf s2 (vector s2))) - ((and (arrayp s2) (not (arrayp s1))) - (setf s1 (vector s1)))) - (cond ((arrayp s1) + ; make number + number as fast as possible: + (cond ((and (numberp s1) (numberp s2)) (+ s1 s2)) + ; if not 2 numbers, the overhead here is amortized by + ; computing samples of at least one sound + ((and (arrayp s1) (numberp s2)) + (sum-of-arrays s1 (nyq:to-array s2 (length s1)))) + ((and (arrayp s2) (numberp s1)) + (sum-of-arrays (nyq:to-array s1 (length s2)) s2)) + ((and (arrayp s1) (soundp s2)) + (sum-of-arrays s1 (vector s2))) + ((and (arrayp s2) (soundp s1)) + (sum-of-arrays (vector s1) s2)) + ((and (arrayp s1) (arrayp s2)) (sum-of-arrays s1 s2)) + ((numberp s1) + (snd-offset s2 s1)) + ((numberp s2) + (snd-offset s1 s2)) (t (nyq:add-2-sounds s1 s2)))) -; (NYQ:ADD-2-SOUNDS S1 S2) - add two sound (or number) arguments +; (NYQ:ADD-2-SOUNDS S1 S2) - add two sound arguments ; +; assumes s1 and s2 are sounds +; (defun nyq:add-2-sounds (s1 s2) - (cond ((numberp s1) - (cond ((numberp s2) - (+ s1 s2)) + (let ((s1sr (snd-srate s1)) + (s2sr (snd-srate s2))) + (cond ((> s1sr s2sr) + (snd-add s1 (snd-up s1sr s2))) + ((< s1sr s2sr) + (snd-add (snd-up s2sr s1) s2)) (t - (snd-offset s2 s1)))) - ((numberp s2) - (snd-offset s1 s2)) - (t - (let ((s1sr (snd-srate s1)) - (s2sr (snd-srate s2))) -; (display "nyq:add-2-sounds" s1sr s2sr) - (cond ((> s1sr s2sr) - (snd-add s1 (snd-up s1sr s2))) - ((< s1sr s2sr) - (snd-add (snd-up s2sr s1) s2)) - (t - (snd-add s1 s2))))))) + (snd-add s1 s2))))) (defmacro at (x s) - `(progv '(*WARP*) (list (list (+ (warp-time *WARP*) - (* (warp-stretch *WARP*) ,x)) - (warp-stretch *WARP*) - (warp-function *WARP*))) + `(progv '(*WARP*) + (let ((shift ,x)) + (ny:typecheck (not (numberp shift)) + (error "1st argument of AT (or 2nd argument of SAL's @ operator) should be a time offset number" shift)) + (list (list (+ (warp-time *WARP*) + (* (warp-stretch *WARP*) shift)) + (warp-stretch *WARP*) + (warp-function *WARP*)))) ,s)) @@ -523,14 +826,18 @@ loop ;; (defmacro at-abs (x s) `(progv '(*WARP*) - (if (warp-function *WARP*) - (list (list (sref-inverse (warp-function *WARP*) ,x) - (warp-stretch *WARP*) - (warp-function *WARP*))) - (list (list ,x (warp-stretch *WARP*) NIL))) + (let ((tim ,x)) + (ny:typecheck (not (numberp tim)) + (error "1st argument of AT-ABS (or 2nd argument of SAL's @@ operator) should be a number (start time)" tim)) + (if (warp-function *WARP*) + (list (list (sref-inverse (warp-function *WARP*) tim) + (warp-stretch *WARP*) + (warp-function *WARP*))) + (list (list tim (warp-stretch *WARP*) NIL)))) ;; issue warning if sound starts in the past (check-t0 ,s ',s))) + (defun check-t0 (s src) (let (flag t0 (now (local-to-global 0))) (cond ((arrayp s) @@ -550,17 +857,21 @@ loop ;; (CLIP S1 VALUE) - clip maximum amplitude to value ; (defun clip (x v) + (ny:typecheck (not (or (numberp x) (soundp x) (multichannelp x))) + (ny:error "CLIP" 1 number-sound-anon x t)) + (ny:typecheck (not (numberp v)) + (ny:error "CLIP" 2 number-anon v)) (cond ((numberp x) - (max (min x v) (- v))) - ((arrayp x) - (let* ((len (length x)) - (result (make-array len))) - (dotimes (i len) - (setf (aref result i) - (snd-clip (aref x i) v))) - result)) - (t - (snd-clip x v)))) + (max (min x v) (- v))) + ((arrayp x) + (let* ((len (length x)) + (result (make-array len))) + (dotimes (i len) + (setf (aref result i) + (snd-clip (aref x i) v))) + result)) + (t ;; x is a sound + (snd-clip x v)))) ;; (NYQ:COERCE-TO S1 S2) - expand sound s1 to type of s2 @@ -568,7 +879,7 @@ loop (defun nyq:coerce-to (s1 s2) (cond ((or (soundp s1) (numberp s1)) (cond ((arrayp s2) - (nyq:sound-to-array s1 (length s2))) + (nyq:to-array s1 (length s2))) (t s1))) (t s1))) @@ -585,8 +896,12 @@ loop (defmacro control-srate-abs (r s) - `(progv '(*CONTROL-SRATE*) (list ,r) - ,s)) + `(let ((rate ,r)) + (progv '(*CONTROL-SRATE*) + (progn (ny:typecheck (not (numberp rate)) + (ny:error "CONTROL-SRATE-ABS" 1 '((NUMBER) "sample rate") rate)) + (list rate)) + ,s))) ; db = 20log(ratio) ; db = 20 ln(ratio)/ln(10) @@ -597,6 +912,8 @@ loop (setf ln10over20 (/ (log 10.0) 20)) (defun db-to-linear (x) + (ny:typecheck (not (or (numberp x) (soundp x) (multichannelp x))) + (ny:error "DB-TO-LINEAR" 0 number-sound-anon x t)) (cond ((numberp x) (exp (* ln10over20 x))) ((arrayp x) @@ -611,6 +928,8 @@ loop (defun linear-to-db (x) + (ny:typecheck (not (or (numberp x) (soundp x) (multichannelp x))) + (ny:error "LINEAR-TO-DB" 0 number-sound-anon x t)) (cond ((numberp x) (/ (log (float x)) ln10over20)) ((arrayp x) @@ -630,6 +949,8 @@ loop (defun step-to-hz (x) + (ny:typecheck (not (or (numberp x) (soundp x) (multichannelp x))) + (ny:error "STEP-TO-HZ" 0 number-sound-anon x t)) (cond ((numberp x) (scalar-step-to-hz x)) ((arrayp x) @@ -643,6 +964,8 @@ loop 2.1011784386926213))))) (defun hz-to-step (x) + (ny:typecheck (not (or (numberp x) (soundp x) (multichannelp x))) + (ny:error "HZ-TO-STEP" 0 number-sound-anon x t)) (cond ((numberp x) (scalar-hz-to-step x)) ((arrayp x) @@ -659,12 +982,26 @@ loop ; sref - access a sound at a given time point ; note that the time is transformed to global (defun sref (sound point) + (ny:typecheck (not (soundp sound)) + (ny:error "SREF" 1 '((SOUND) "sound") sound)) + (ny:typecheck (not (numberp point)) + (ny:error "SREF" 2 '((NUMBER) "time") point)) (snd-sref sound (local-to-global point))) ; extract - start is stretched and shifted as is stop ; result is shifted to start at local time zero (defun extract (start stop sound) + (ny:typecheck (not (numberp start)) + (ny:error "EXTRACT" 1 '((NUMBER) "start") start)) + (ny:typecheck (not (numberp stop)) + (ny:error "EXTRACT" 2 '((NUMBER) "stop") stop)) + (ny:typecheck (< stop start) + (error + (format nil "In EXTRACT, stop (~A) must be greater or equal to start (~A)" + stop start))) + (ny:typecheck (not (soundp sound)) + (ny:error "EXTRACT" 3 '((SOUND) "sound") sound)) (extract-abs (local-to-global start) (local-to-global stop) sound (local-to-global 0))) @@ -678,6 +1015,19 @@ loop ; The solution is that if t0 > start_time, subtract the difference ; from start and stop to shift them appropriately. (defun extract-abs (start stop sound &optional (start-time 0)) + (ny:typecheck (not (numberp start)) + (ny:error "EXTRACT-ABS" 1 '((NUMBER) "start") start)) + (ny:typecheck (not (numberp stop)) + (ny:error "EXTRACT-ABS" 2 '((NUMBER) "stop") stop)) + (ny:typecheck (< stop start) + (error + (format nil + "In EXTRACT-ABS, stop (~A) must be greater or equal to start (~A)" + stop start))) + (ny:typecheck (not (soundp sound)) + (ny:error "EXTRACT-ABS" 3 '((SOUND) "sound") sound)) + (ny:typecheck (not (numberp start-time)) + (ny:error "EXTRACT-ABS" 4 '((NUMBER) "start-time") start-time)) (let ((t0 (snd-t0 sound)) offset) (cond ((/= t0 start-time) (setf offset (- t0 start-time)) @@ -687,6 +1037,8 @@ loop (defun local-to-global (local-time) + (ny:typecheck (not (numberp local-time)) + (ny:error "LOCAL-TO-GLOBAL" 0 '((NUMBER) "local-time") local-time)) (let ((d (warp-time *WARP*)) (s (warp-stretch *WARP*)) (w (warp-function *WARP*)) @@ -696,29 +1048,55 @@ loop (defmacro loud (x s) - `(progv '(*LOUD*) (list (sum *LOUD* ,x)) + `(progv '(*LOUD*) + (let ((ld ,x)) + (ny:typecheck (not (or (numberp ld) (soundp ld))) + (ny:error "LOUD" 1 number-sound-anon ld)) + (list (sum *LOUD* ld))) ,s)) (defmacro loud-abs (x s) - `(progv '(*LOUD*) (list ,x) + `(progv '(*LOUD*) + (let ((ld ,x)) + (ny:typecheck (not (or (numberp ld) (soundp ld))) + (ny:error "LOUD-ABS" 1 number-anon ld)) + (list ld)) ,s)) -(defun must-be-sound (x) - (cond ((soundp x) x) - (t - (error "SOUND type expected" x)))) +;(defun must-be-sound (x) +; (cond ((soundp x) x) +; (t +; (error "SOUND type expected" x)))) + + +;; NY:SCALE-DB -- a "fast" scale-db: no typechecks and +;; no multichannel expansion +(defun ny:scale-db (factor sound) + (snd-scale (db-to-linear factor) sound)) + ;; SCALE-DB -- same as scale, but argument is in db ;; (defun scale-db (factor sound) - (scale (db-to-linear factor) sound)) +; (ny:typecheck (not (or (numberp factor) (numbersp factor))) +; (ny:error "SCALE-DB" 1 '((NUMBER) "dB") factor t)) +; (ny:typecheck (not (or (soundp sound) (multichannel-soundp sound))) +; (ny:error "SCALE-DB" 2 '((SOUND) "sound") sound t)) + (multichan-expand "SCALE-DB" #'ny:scale-db + '(((NUMBER) "factor") ((SOUND) "sound")) factor sound)) + + (defun set-control-srate (rate) + (ny:typecheck (not (numberp rate)) + (ny:error "SET-CONTROL-SRATE" 0 '((NUMBER) "rate") rate)) (setf *default-control-srate* (float rate)) (nyq:environment-init)) (defun set-sound-srate (rate) + (ny:typecheck (not (numberp rate)) + (ny:error "SET-SOUND-SRATE" 0 '((NUMBER) "rate") rate)) (setf *default-sound-srate* (float rate)) (nyq:environment-init)) @@ -732,6 +1110,13 @@ loop ; plot the points that exist. ; (defun s-plot (snd &optional (dur 2.0) (n 1000)) + (ny:typecheck (not (soundp snd)) + (ny:error "S-PLOT (or PLOT command)" 1 '((SOUND) nil) snd)) + (ny:typecheck (not (numberp dur)) + (ny:error "S-PLOT (or PLOT command)" 2 '((NUMBER) "dur") dur)) + (ny:typecheck (not (integerp n)) + (ny:error "S-PLOT (or PLOT command)" 3 '((INTEGER) nil) n)) + (prog* ((sr (snd-srate snd)) (t0 (snd-t0 snd)) (filename (soundfilename *default-plot-file*)) @@ -754,7 +1139,7 @@ loop ;; sample rate). If the actual sample rate was lowered to avoid ;; getting more than n samples, we can now raise the sample rate ;; based on our estimate of the actual sample duration. - (display "test" (length points) n) + ;(display "test" (length points) n) (cond ((< (length points) n) ;; sound is shorter than dur, estimate actual length (setf actual-dur (/ (length points) (snd-srate s))) @@ -805,37 +1190,56 @@ loop ; run something like this to plot the points: ; graph < points.dat | plot -Ttek - (defmacro sound-srate-abs (r s) - `(progv '(*SOUND-SRATE*) (list ,r) + `(progv '(*SOUND-SRATE*) + (let ((rate ,r)) + (ny:typecheck (not (numberp rate)) + (ny:error "SOUND-SRATE-ABS" 1 '((NUMBER) "sample rate") rate)) + (list rate)) ,s)) (defmacro stretch (x s) - `(progv '(*WARP*) (list (list (warp-time *WARP*) - (* (warp-stretch *WARP*) ,x) - (warp-function *WARP*))) - (if (minusp (warp-stretch *WARP*)) - (break "Negative stretch factor is not allowed")) - ,s)) + `(progv '(*WARP*) + (let ((str ,x)) + (ny:typecheck (not (numberp str)) + (error "1st argument of STRETCH (or 2nd argument of SAL's ~ operator) should be a number (stretch factor)" str)) + (list (list (warp-time *WARP*) + (* (warp-stretch *WARP*) str) + (warp-function *WARP*)))) + (ny:typecheck (minusp (warp-stretch *WARP*)) + (error "In STRETCH (or SAL's ~ operator), negative stretch factor is not allowed" + (warp-stretch *WARP*))) + ,s)) (defmacro stretch-abs (x s) - `(progv '(*WARP*) (list (list (local-to-global 0) - ,x - nil)) - (if (minusp (warp-stretch *WARP*)) - (break "Negative stretch factor is not allowed")) - ,s)) + `(progv '(*WARP*) + (let ((str ,x)) + (ny:typecheck (not (numberp str)) + (error "1st argument of STRETCH-ABS (or 2nd argument of SAL's ~~ operator) should be a number (stretch factor)" str)) + (list (list (local-to-global 0) str nil))) + (ny:typecheck (minusp (warp-stretch *WARP*)) + (error "In STRETCH-ABS (or SAL's ~~ operator), negative stretch factor is not allowed" + (warp-stretch *WARP*))) + ,s)) (defmacro sustain (x s) - `(progv '(*SUSTAIN*) (list (prod *SUSTAIN* ,x)) + `(progv '(*SUSTAIN*) + (let ((sus ,x)) + (ny:typecheck (not (or (numberp sus) (soundp sus))) + (ny:error "SUSTAIN" 1 number-sound-anon sus)) + (list (prod *SUSTAIN* sus))) ,s)) (defmacro sustain-abs (x s) - `(progv '(*SUSTAIN*) (list ,x) + `(progv '(*SUSTAIN*) + (let ((sus ,x)) + (ny:typecheck (not (or (numberp sus) (soundp sus))) + (ny:error "SUSTAIN-ABS" 1 number-sound-anon sus)) + (list sus)) ,s)) @@ -855,64 +1259,38 @@ loop (defmacro transpose (x s) - `(progv '(*TRANSPOSE*) (list (sum *TRANSPOSE* ,x)) + `(progv '(*TRANSPOSE*) + (let ((amt ,x)) + (ny:typecheck (not (or (numberp amt) (soundp amt))) + (ny:error "TRANSPOSE" 1 number-sound-anon amt)) + (list (sum *TRANSPOSE* amt))) ,s)) (defmacro transpose-abs (x s) - `(progv '(*TRANSPOSE*) (list ,x) + `(progv '(*TRANSPOSE*) + (let ((amt ,x)) + (ny:typecheck (not (or (numberp amt) (soundp amt))) + (ny:error "TRANSPOSE-ABS" 1 number-anon amt)) + (list amt)) ,s)) -;; 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 -or add this to your init.lsp file: - (setf *default-sound-file* \"\") - (setf *default-sf-dir* \"\") - -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*))) - - ;; CONTROL-WARP -- apply a warp function to a control function ;; (defun control-warp (warp-fn control &optional wrate) + (ny:typecheck (not (soundp warp-fn)) + (ny:error "CONTROL-WARP" 1 '((SOUND) "warp-fn") warp-fn)) + (ny:typecheck (not (soundp control)) + (ny:error "CONTROL-WARP" 2 '((SOUND) "control") control)) (cond (wrate + (ny:typecheck (not (numberp wrate)) + (ny:error "CONTROL-WARP" 3 '((NUMBER) "wrate") wrate)) (snd-resamplev control *control-srate* (snd-inverse warp-fn (local-to-global 0) wrate))) (t (snd-compose control - (snd-inverse warp-fn (local-to-global 0) *control-srate*))))) + (snd-inverse warp-fn (local-to-global 0) *control-srate*))))) ;; (cue sound) @@ -920,6 +1298,8 @@ Your id please: ") ;; *START*, and *STOP* values to the argument. The logical start time is at ;; local time 0. (defun cue (sound) + (ny:typecheck (not (or (soundp sound) (multichannel-soundp sound))) + (ny:error "CUE" 0 '((SOUND) nil) sound t)) (cond ((arrayp sound) (let* ((len (length sound)) (result (make-array len))) @@ -979,6 +1359,8 @@ Your id please: ") (defun sound (sound) + (ny:typecheck (not (or (soundp sound) (multichannel-soundp sound))) + (ny:error "SOUND" 0 '((SOUND) nil) sound t)) (cond ((arrayp sound) (nyq:sound-of-array sound)) (t @@ -988,6 +1370,10 @@ Your id please: ") ;; (SCALE-SRATE SOUND SCALE) ;; multiplies the sample rate by scale (defun scale-srate (sound scale) + (ny:typecheck (not (soundp sound)) + (ny:error "SCALE-SRATE" 1 '((SOUND) "sound") sound)) + (ny:typecheck (not (numberp scale)) + (ny:error "SCALE-SRATE" 2 '((NUMBER) "scale") scale)) (let ((new-srate (* scale (snd-srate sound)))) (snd-xform sound new-srate (snd-time sound) MIN-START-TIME MAX-STOP-TIME 1.0))) @@ -999,29 +1385,32 @@ Your id please: ") ;; you look at plots, the shifted sound will move *right* when SHIFT ;; is positive. (defun shift-time (sound shift) + (ny:typecheck (not (soundp sound)) + (ny:error "SHIFT-TIME" 1 '((SOUND) "sound") sound)) + (ny:typecheck (not (numberp shift)) + (ny:error "SHIFT-TIME" 2 '((NUMBER) "shift") shift)) (snd-xform sound (snd-srate sound) (+ (snd-t0 sound) shift) MIN-START-TIME MAX-STOP-TIME 1.0)) -;; (NYQ:SOUND-TO-ARRAY SOUND N) - duplicate SOUND to N channels -;; -(defun nyq:sound-to-array (sound n) - (let ((result (make-array n))) - (dotimes (i n) - (setf (aref result i) sound)) - result)) - - ;; (control sound) ;; Same as (sound sound), except this is used for control signals. ;; This code is identical to sound. -(setfn control sound) +(defun control (sound) + (ny:typecheck (not (or (soundp sound) (multichannel-soundp sound))) + (ny:error "CONTROL" 0 '((SOUND) nil) sound t)) + (cond ((arrayp sound) + (nyq:sound-of-array sound)) + (t + (nyq:sound sound)))) ;; (cue-file string) ;; Loads a sound file with the given name, returning a sound which is ;; transformed to the current environment. (defun cue-file (name) + (ny:typecheck (not (stringp name)) + (ny:error "CUE-FILE" 0 '((STRING) "name") name)) (cue (force-srate *SOUND-SRATE* (s-read name)))) @@ -1044,6 +1433,12 @@ Your id please: ") ;; the proper starting time. ;; (defun env (t1 t2 t4 l1 l2 l3 &optional (duration 1.0)) + (ny:typecheck (not (and (numberp t1) (numberp t2) (numberp t4) + (numberp l1) (numberp l2) (numberp l3))) + (error "In ENV, expected 6 numbers (t1, t2, t4, l1, l2, l3)" + (list t1 t2 t4 l1 l2 l3))) + (ny:typecheck (not (numberp duration)) + (ny:error "ENV" 7 '((NUMBER) "duration") duration)) (let (actual-dur min-dur ratio t3 (actual-dur (get-duration duration))) (setf min-dur (+ t1 t2 t4 0.002)) @@ -1057,23 +1452,42 @@ Your id please: ") (setf l3 0.0)) (t (setf t3 (- actual-dur t1 t2 t4)))) - (set-logical-stop + (ny:set-logical-stop (abs-env (at *rslt* (pwl t1 l1 (+ t1 t2) l2 (- actual-dur t4) l3 actual-dur))) duration))) -(defun gate (sound lookahead risetime falltime floor threshold) +(defun gate (sound lookahead risetime falltime floor threshold + &optional (source "GATE")) + (ny:typecheck (not (soundp sound)) + (ny:error "GATE" 1 '((SOUND) "sound") sound)) + (ny:typecheck (not (numberp lookahead)) + (ny:error "GATE" 2 '((NUMBER) "lookahead") lookahead)) + (ny:typecheck (not (numberp risetime)) + (ny:error "GATE" 3 '((NUMBER) "risetime") risetime)) + (ny:typecheck (not (numberp falltime)) + (ny:error "GATE" 4 '((NUMBER) "falltime") falltime)) + (ny:typecheck (not (numberp floor)) + (ny:error "GATE" 5 '((NUMBER) "floor") floor)) + (ny:typecheck (not (numberp threshold)) + (ny:error "GATE" 6 '((NUMBER) "threshold") threshold)) (cond ((< lookahead risetime) - (break "lookahead must be greater than risetime in GATE function")) - ((or (< risetime 0) (< falltime 0) (< floor 0)) - (break "risetime, falltime, and floor must all be positive in GATE function")) - (t - (let ((s - (snd-gate (seq (cue sound) (abs-env (s-rest lookahead))) - lookahead risetime falltime floor threshold))) - (snd-xform s (snd-srate s) (snd-t0 sound) - (+ (snd-t0 sound) lookahead) MAX-STOP-TIME 1.0))))) + (format t "WARNING: lookahead must be greater than risetime in ~A function; setting lookahead to ~A.\n" source risetime) + (setf lookahead risetime))) + (cond ((< risetime 0) + (format t "WARNING: risetime must be greater than zero in ~A function; setting risetime to 0.0.\n" source) + (setf risetime 0.0))) + (cond ((< falltime 0) + (format t "WARNING: falltime must be greater than zero in ~A function; setting falltime to 0.0.\n" source) + (setf falltime 0.0))) + (cond ((< floor 0) + (format t "WARNING: floor must be greater than zero in ~A function; setting floor to 0.0.\n" source) + (setf floor 0.0))) + (let ((s (snd-gate (seq (cue sound) (abs-env (s-rest lookahead))) + lookahead risetime falltime floor threshold))) + (snd-xform s (snd-srate s) (snd-t0 sound) + (+ (snd-t0 sound) lookahead) MAX-STOP-TIME 1.0))) ;; (osc-note step &optional duration env sust volume sound) @@ -1085,7 +1499,17 @@ Your id please: ") (env-spec '(0.02 0.1 0.3 1.0 .8 .7)) (volume 0.0) (table *TABLE*)) - (set-logical-stop + (ny:typecheck (not (numberp pitch)) + (ny:error "OSC-NOTE" 1 '((STEP) "pitch") pitch)) + (ny:typecheck (not (numberp duration)) + (ny:error "OSC-NOTE" 2 '((NUMBER) "duration") duration)) + (ny:assert-env-spec env-spec + "In OSCNOTE, 3rd argument (env-spec) must be a list of 6 or 7 numbers to pass as arguments to ENV") + (ny:typecheck (not (numberp volume)) + (ny:error "OSC-NOTE" 4 '((NUMBER) "volume") volume)) + (ny:assert-table "OSC-NOTE" 5 "table" table) + + (ny:set-logical-stop (mult (loud volume (osc pitch duration table)) (if (listp env-spec) (apply 'env env-spec) @@ -1096,8 +1520,10 @@ Your id please: ") ;; force-srate -- resample snd if necessary to get sample rate ; (defun force-srate (sr snd) - (cond ((not (numberp sr)) - (error "force-srate: SR should be a number"))) + (ny:typecheck (not (numberp sr)) + (ny:error "FORCE-SRATE" 1 '((NUMBER) "sr") sr)) + (ny:typecheck (not (or (soundp snd) (multichannel-soundp snd))) + (ny:error "FORCE-SRATE" 2 '((SOUND) "snd") snd t)) (cond ((arrayp snd) (let* ((len (length snd)) (result (make-array len))) @@ -1122,21 +1548,32 @@ Your id please: ") (setf (aref result i) (force-srate (aref srs i) (aref snd i)))) result)) - (t (error "arguments not compatible")))) + (t (error (format nil "In force-srates: arguments not compatible. srs is ~A, snd is ~A. Perhaps you are constructing a sequence using both mono and multi-channel sounds." + (type-of srs) (type-of snd)))))) ;; (breakpoints-convert (t1 x1 t2 x2 ... tn) t0) ;; converts times to sample numbers and scales amplitudes ;; t0 is the global (after warping) start time ;; +;; input list is one or more numbers +;; result is abs-sample-count, val, abs-sample-count, val, ... +;; if the list length is odd, the result length is odd, and +;; snd-pwl treats it as if a final value of zero was appended +;; ;; NOTE: there were some stack overflow problems with the original ;; recursive version (in comments now), so it was rewritten as an ;; iteration. ;; -(defun breakpoints-convert (list t0) +(defun breakpoints-convert (list t0 source) (prog (sample-count result sust (last-count 0)) (setf sust (get-sustain)) + (ny:typecheck (not (consp list)) + (error (format nil "In ~A, expected a list of numbers" source) list)) loop + (ny:typecheck (not (numberp (car list))) + (error (format nil "In ~A, expected only numbers in breakpoint list, got ~A" + source (car list)))) (setf sample-count (truncate (+ 0.5 (* (- (local-to-global (* (car list) sust)) t0) *control-srate*)))) @@ -1148,47 +1585,46 @@ Your id please: ") (push sample-count result) (cond ((cdr list) (setf list (cdr list)) + (ny:typecheck (not (numberp (car list))) + (error (format nil "In ~A, expected only numbers in breakpoint list" source) + (car list))) (push (float (car list)) result))) (setf list (cdr list)) (cond (list (go loop))) (return (reverse result)))) - ;; (pwl t1 l1 t2 l2 ... tn) ;; Creates a piece-wise linear envelope from breakpoint data. ;; -(defun pwl (&rest breakpoints) (pwl-list breakpoints)) +(defun pwl (&rest breakpoints) (pwl-list breakpoints "PWL")) -(defun pwlr (&rest breakpoints) (pwlr-list breakpoints)) +(defun pwlr (&rest breakpoints) (pwlr-list breakpoints "PWLR")) -;; (breakpoints-relative list) +;; BREAKPOINTS-RELATIVE list source ;; converts list, which has the form (value dur value dur value ...) ;; into the form (value time value time value ...) ;; the list may have an even or odd length ;; -(defun breakpoints-relative (breakpoints) - (prog (result (sum 0.0)) - loop - (cond (breakpoints - (push (car breakpoints) result) - (setf breakpoints (cdr breakpoints)) - (cond (breakpoints - (setf sum (+ sum (car breakpoints))) - (push sum result) - (setf breakpoints (cdr breakpoints)) - (go loop))))) - (return (reverse result)))) - - -(defun breakpoints-relative (breakpoints) +(defun breakpoints-relative (breakpoints source) (prog (result (sum 0.0)) + (ny:typecheck (not (consp breakpoints)) + (error (format nil "In ~A, expected list of numbers, got ~A" + source breakpoints))) loop + (ny:typecheck (not (numberp (car breakpoints))) + (error (format nil + "In ~A, expected only numbers in breakpoints list, got ~A" + source (car breakpoints)))) (setf sum (+ sum (car breakpoints))) (push sum result) (cond ((cdr breakpoints) (setf breakpoints (cdr breakpoints)) + (ny:typecheck (not (numberp (car breakpoints))) + (error (format nil + "In ~A, expected only numbers in breakpoints list, got ~A" + source (car breakpoints)))) (push (car breakpoints) result))) (setf breakpoints (cdr breakpoints)) (cond (breakpoints @@ -1196,12 +1632,12 @@ Your id please: ") (return (reverse result)))) -(defun pwlr-list (breakpoints) - (pwl-list (breakpoints-relative breakpoints))) +(defun pwlr-list (breakpoints &optional (source "PWLR-LIST")) + (pwl-list (breakpoints-relative breakpoints source) source)) -(defun pwl-list (breakpoints) +(defun pwl-list (breakpoints &optional (source "PWL-LIST")) (let ((t0 (local-to-global 0))) - (snd-pwl t0 *control-srate* (breakpoints-convert breakpoints t0)))) + (snd-pwl t0 *control-srate* (breakpoints-convert breakpoints t0 source)))) ;; (pwlv l1 t1 l2 t2 ... ln) ;; Creates a piece-wise linear envelope from breakpoint data; @@ -1210,61 +1646,97 @@ Your id please: ") (defun pwlv (&rest breakpoints) ;use pwl, modify breakpoints with initial and final changes ;need to put initial time of 0, and final time of 0 - (pwlv-list breakpoints)) + (pwlv-list breakpoints "PWLV")) -(defun pwlv-list (breakpoints) - (pwl-list (cons 0.0 (append breakpoints '(0.0))))) +(defun pwlv-list (breakpoints &optional (source "PWLV-LIST")) + (ny:typecheck (not (consp breakpoints)) + (error (format nil "In ~A, expected list of numbers, got ~A" + source breakpoints))) + (pwl-list (cons 0.0 breakpoints) source)) -(defun pwlvr (&rest breakpoints) (pwlvr-list breakpoints)) +(defun pwlvr (&rest breakpoints) (pwlvr-list breakpoints "PWLVR")) -(defun pwlvr-list (breakpoints) - (pwlr-list (cons 0.0 (append breakpoints '(0.0))))) +(defun pwlvr-list (breakpoints &optional (source "PWLVR-LIST")) + (ny:typecheck (not (consp breakpoints)) + (error (format nil "In ~A, expected list of numbers, got ~A" + source breakpoints))) + (pwlr-list (cons 0.0 breakpoints) source)) (defun pwe (&rest breakpoints) - (pwe-list breakpoints)) + (pwe-list breakpoints "PWE")) -(defun pwe-list (breakpoints) - (pwev-list (cons 1.0 (append breakpoints '(1.0))))) +(defun pwe-list (breakpoints &optional (source "PWE-LIST")) + (ny:typecheck (not (consp breakpoints)) + (error (format nil "In ~A, expected list of numbers, got ~A" + source breakpoints))) + (pwev-list (cons 1.0 breakpoints) source)) -(defun pwer (&rest breakpoints) (pwer-list breakpoints)) +(defun pwer (&rest breakpoints) + (pwer-list breakpoints "PWER")) -(defun pwer-list (breakpoints) - (pwe-list (breakpoints-relative breakpoints))) +(defun pwer-list (breakpoints &optional (source "PWER-LIST")) + (pwe-list (breakpoints-relative breakpoints source) source)) (defun pwev (&rest breakpoints) - (pwev-list breakpoints)) + (pwev-list breakpoints "PWEV")) -(defun pwev-list (breakpoints) - (let ((lis (breakpoints-log breakpoints))) +(defun pwev-list (breakpoints &optional (source "PWEV-LIST")) + (let ((lis (breakpoints-log breakpoints source))) (s-exp (pwl-list lis)))) -(defun pwevr (&rest breakpoints) (pwevr-list breakpoints)) +(defun pwevr (&rest breakpoints) (pwevr-list breakpoints "PWEVR")) -(defun pwevr-list (breakpoints) - (pwev-list (cdr (breakpoints-relative (cons 0.0 breakpoints))))) +(defun pwevr-list (breakpoints &optional (source "PWEVR-LIST")) + (ny:typecheck (not (consp breakpoints)) + (error (format nil "In ~A, expected list of numbers, got ~A" + source breakpoints))) + (pwev-list (cdr (breakpoints-relative (cons 0.0 breakpoints) source)) source)) -(defun breakpoints-log (breakpoints) +;; input is 2 or more numbers representing val, time, val, time, ... +;; output is odd number of 1 or more numbers representing +;; time, val, time, val, ..., time +;; +;; +(defun breakpoints-log (breakpoints source) (prog ((result '(0.0)) val tim) loop + (ny:typecheck (not (consp breakpoints)) + (error (format nil "In ~A, expected list of numbers, got ~A" + source breakpoints))) + (ny:typecheck (not (numberp (car breakpoints))) + (error (format nil "In ~A, expected number in breakpoint list, got ~A" + source (car breakpoints)))) + + (setf val (float (car breakpoints))) + (setf breakpoints (cdr breakpoints)) + (cond (breakpoints - (setf val (float (car breakpoints))) + (ny:typecheck (not (consp breakpoints)) + (error (format nil "In ~A, expected list of numbers, got ~A" + source (car breakpoints)))) + (setf tim (car breakpoints)) (setf breakpoints (cdr breakpoints)) - (cond (breakpoints - (setf tim (car breakpoints)) - (setf breakpoints (cdr breakpoints)))) - (setf result (cons tim (cons (log val) result))) - (cond ((null breakpoints) - (return (reverse result)))) - (go loop)) - (t - (error "Expected odd number of elements in breakpoint list"))))) + (ny:typecheck (not (numberp tim)) + (error (format nil "In ~A, expected number in breakpoint list, got ~A" + source tim))))) + + (setf result (cons tim (cons (log val) result))) + (cond ((null breakpoints) + (return (reverse result)))) + (go loop))) ;; SOUND-WARP -- apply warp function to a sound ;; (defun sound-warp (warp-fn signal &optional wrate) + (ny:typecheck (not (soundp warp-fn)) + (ny:error "SOUND-WARP" 1 '((SOUND) "warp-fn") warp-fn)) + (ny:typecheck (not (soundp signal)) + (ny:error "SOUND-WARP" 2 '((SOUND) "signal") signal)) (cond (wrate + (ny:typecheck (not (numberp wrate)) + (ny:error "SOUND-WARP" 3 '((NUMBER) "wrate") wrate)) (snd-resamplev signal *sound-srate* (snd-inverse warp-fn (local-to-global 0) wrate))) (t @@ -1272,6 +1744,10 @@ loop (snd-inverse warp-fn (local-to-global 0) *sound-srate*))))) (defun snd-extent (sound maxsamples) + (ny:typecheck (not (soundp sound)) + (ny:error "SND-EXTENT" 1 '((SOUND) "sound") sound)) + (ny:typecheck (not (integerp maxsamples)) + (ny:error "SND-EXTENT" 2 '((INTEGER) "maxsamples") maxsamples)) (list (snd-t0 sound) (+ (snd-t0 sound) (/ (snd-length sound maxsamples) (snd-srate sound))))) @@ -1283,6 +1759,8 @@ loop ;; in sound represent one period. The sound must start at time 0. (defun maketable (sound) + (ny:typecheck (not (soundp sound)) + (ny:error "MAKETABLE" 0 '((SOUND) nil) sound)) (list sound (hz-to-step (/ 1.0 @@ -1290,77 +1768,86 @@ loop T)) -;(defmacro endTime (sound) -; `(get-logical-stop ,sound)) - - -;(defmacro beginTime (sound) -; `(car (snd-extent ,sound))) - - ; simple stereo pan: as where goes from 0 to 1, sound ; is linearly panned from left to right ; (defun pan (sound where) + (ny:typecheck (not (soundp sound)) + (ny:error "PAN" 1 '((SOUND) "sound") sound)) + (ny:typecheck (not (or (soundp where) (numberp where))) + (ny:error "PAN" 2 '((NUMBER SOUND) "where") where)) (vector (mult sound (sum 1 (mult -1 where))) - (mult sound where))) + (mult sound where))) +(setf prod-source "PROD (or * in SAL)") + (defun prod (&rest snds) (cond ((null snds) (snd-zero (local-to-global 0) *sound-srate*)) ((null (cdr snds)) (car snds)) ((null (cddr snds)) - (nyq:prod2 (car snds) (cadr snds))) + (nyq:prod2 (car snds) (cadr snds) prod-source)) (t - (nyq:prod2 (car snds) (apply #'prod (cdr snds)))))) + (nyq:prod2 (car snds) (apply #'prod (cdr snds)) prod-source)))) (setfn mult prod) ;; (NYQ:PROD-OF-ARRAYS S1 S2) - form pairwise products ; -(defun nyq:prod-of-arrays (s1 s2) +(defun nyq:prod-of-arrays (s1 s2 source) (let* ((n (length s1)) (p (make-array n))) - (cond ((/= n (length s2)) - (error "unequal number of channels in prod"))) + (ny:typecheck (/= n (length s2)) + (error (strcat "In " source ", unequal number of channels, got " + (param-to-string s1) " and " (param-to-string s2)))) (dotimes (i n) - (setf (aref p i) (nyq:prod2 (aref s1 i) (aref s2 i)))) + (setf (aref p i) (nyq:prod2 (aref s1 i) (aref s2 i) source))) p)) ; nyq:prod2 - multiply two arguments ; -(defun nyq:prod2 (s1 s2) +(defun nyq:prod2 (s1 s2 source) (setf s1 (nyq:coerce-to s1 s2)) (setf s2 (nyq:coerce-to s2 s1)) (cond ((arrayp s1) - (nyq:prod-of-arrays s1 s2)) + (nyq:prod-of-arrays s1 s2 source)) (t - (nyq:prod-2-sounds s1 s2)))) + (nyq:prod-2-sounds s1 s2 source)))) ; (PROD-2-SOUNDS S1 S2) - multiply two sound arguments ; -(defun nyq:prod-2-sounds (s1 s2) +(defun nyq:prod-2-sounds (s1 s2 source) (cond ((numberp s1) (cond ((numberp s2) (* s1 s2)) + ((soundp s2) + (snd-scale s1 s2)) (t - (scale s1 s2)))) + (ny:error source 0 number-sound-anon s2 t)))) ((numberp s2) - (scale s2 s1)) + (ny:typecheck (not (soundp s1)) + (ny:error source 0 number-sound-anon s1 t)) + (snd-scale s2 s1)) + ((and (soundp s1) (soundp s2)) + (snd-prod s1 s2)) + ((soundp s1) + (ny:error source 0 number-sound-anon s2 t)) (t - (snd-prod s1 s2)))) + (ny:error source 0 number-sound-anon s1 t)))) ;; RAMP -- linear ramp from 0 to x ;; (defun ramp (&optional (x 1)) + (ny:typecheck (not (numberp x)) + (ny:error "RAMP" 0 number-anon x)) (let* ((duration (get-duration x))) - (set-logical-stop + (ny:set-logical-stop (warp-abs nil (at *rslt* (sustain-abs 1 @@ -1369,36 +1856,41 @@ loop (defun resample (snd rate) + (ny:typecheck (not (or (soundp snd) (multichannel-soundp snd))) + (ny:error "RESAMPLE" 1 '((SOUND) nil) snd t)) + (ny:typecheck (not (numberp rate)) + (ny:error "RESAMPLE" 2 '((NUMBER) "rate") rate)) (cond ((arrayp snd) - (let* ((len (length snd)) - (result (make-array len))) - (dotimes (i len) - (setf (aref result i) - (snd-resample (aref snd i) rate))) - result)) - (t - (snd-resample snd rate)))) + (let* ((len (length snd)) + (result (make-array len))) + (dotimes (i len) + (setf (aref result i) + (snd-resample (aref snd i) rate))) + result)) + (t + (snd-resample snd rate)))) (defun scale (amt snd) - (cond ((arrayp snd) - (let* ((len (length snd)) - (result (make-array len))) - (dotimes (i len) - (setf (aref result i) (snd-scale amt (aref snd i)))) - result)) - (t - (snd-scale amt snd)))) + (multichan-expand "SCALE" #'snd-scale + '(((NUMBER) "amt") ((SOUND) "snd")) amt snd)) (setfn s-print-tree snd-print-tree) + ;; (PEAK sound-expression number-of-samples) - find peak amplitude ; ; NOTE: this used to be called s-max +; It is tempting to try using multichan-expand here to get peaks +; from multichannel sounds, but at this point the argument is just +; an expression, so we cannot tell if it is multichannel. We could +; evaluate the expression, but then we'd have a local binding and +; would retain samples in memory if we called snd-max on each channel. ; (defmacro peak (expression maxlen) `(snd-max ',expression ,maxlen)) + ;; (S-MAX S1 S2) - return maximum of S1, S2 ; @@ -1406,15 +1898,16 @@ loop (setf s1 (nyq:coerce-to s1 s2)) (setf s2 (nyq:coerce-to s2 s1)) (cond ((arrayp s1) - (nyq:max-of-arrays s1 s2)) - (t - (nyq:max-2-sounds s1 s2)))) + (nyq:max-of-arrays s1 s2)) + (t + (nyq:max-2-sounds s1 s2)))) (defun nyq:max-of-arrays (s1 s2) (let* ((n (length s1)) - (p (make-array n))) - (cond ((/= n (length s2)) - (error "unequal number of channels in max"))) + (p (make-array n))) + (ny:typecheck (/= n (length s2)) + (error (strcat "In S-MAX, unequal number of channels, got " + (param-to-string s1) " and " (param-to-string s2)))) (dotimes (i n) (setf (aref p i) (s-max (aref s1 i) (aref s2 i)))) p)) @@ -1423,15 +1916,23 @@ loop (cond ((numberp s1) (cond ((numberp s2) (max s1 s2)) - (t + ((soundp s2) (snd-maxv s2 (snd-const s1 (local-to-global 0.0) - (snd-srate s2) (get-duration 1.0)))))) + (snd-srate s2) (get-duration 1.0)))) + (t + (ny:error "S-MAX" 2 number-sound-anon s2 t)))) ((numberp s2) + (ny:typecheck (not (soundp s1)) + (ny:error "S-MAX" 2 number-sound-anon s2 t)) (snd-maxv s1 (snd-const s2 (local-to-global 0.0) - (snd-srate s1) (get-duration 1.0)))) + (snd-srate s1) (get-duration 1.0)))) + ((and (soundp s1) (soundp s2)) + (snd-maxv s1 s2)) + ((soundp s1) + (ny:error "S-MAX" 2 number-sound-anon s2 t)) (t - (snd-maxv s1 s2)))) + (ny:error "S-MAX" 1 number-sound-anon s1 t)))) (defun s-min (s1 s2) @@ -1444,7 +1945,10 @@ loop (defun nyq:min-of-arrays (s1 s2) (let* ((n (length s1)) - (p (make-array n))) + (p (make-array n))) + (ny:typecheck (/= n (length s2)) + (error (strcat "In S-MIN, unequal number of channels, got " + (param-to-string s1) (param-to-string s2)))) (cond ((/= n (length s2)) (error "unequal number of channels in max"))) (dotimes (i n) @@ -1455,19 +1959,27 @@ loop (cond ((numberp s1) (cond ((numberp s2) (min s1 s2)) - (t + ((soundp s2) (snd-minv s2 (snd-const s1 (local-to-global 0.0) - (snd-srate s2) (get-duration 1.0)))))) + (snd-srate s2) (get-duration 1.0)))) + (t + (ny:error "S-MIN" 2 number-sound-anon s2 t)))) ((numberp s2) + (ny:typecheck (not (soundp s1)) + (ny:error "S-MIN" 2 number-sound-anon s2 t)) (snd-minv s1 (snd-const s2 (local-to-global 0.0) (snd-srate s1) (get-duration 1.0)))) - (t - (snd-minv s1 s2)))) + ((and (soundp s1) (soundp s2)) + (snd-minv s1 s2)) + ((soundp s1) + (ny:error "S-MIN" 2 number-sound-anon s2 t)) + (t + (ny:error "S-MIN" 1 number-sound-anon s1 t)))) (defun snd-minv (s1 s2) - (scale -1.0 (snd-maxv (scale -1.0 s1) (scale -1.0 s2)))) + (snd-scale -1.0 (snd-maxv (snd-scale -1.0 s1) (snd-scale -1.0 s2)))) ; sequence macros SEQ and SEQREP are now in seq.lsp: ; @@ -1477,37 +1989,72 @@ loop ; set-logical-stop - modify the sound and return it, time is shifted and ; stretched (defun set-logical-stop (snd tim) + (ny:typecheck (not (numberp tim)) + (ny:error "SET-LOGICAL-STOP" 2 '((NUMBER) "logical stop time") tim)) + (ny:typecheck (not (or (soundp snd) (multichannel-soundp snd))) + (ny:error "SET-LOGICAL-STOP" 1 '((SOUND) "snd") snd t)) + (multichan-expand "SET-LOGICAL-STOP" #'ny:set-logical-stop + '(((SOUND) "snd") ((NUMBER) "logical stop time")) snd tim)) + + +;; NY:SET-LOGICAL-STOP - "fast" set-logical-stop: no typechecks and no +;; multichannel expansion +(defun ny:set-logical-stop (snd tim) (let ((d (local-to-global tim))) - (multichan-expand #'set-logical-stop-abs snd d))) + (snd-set-logical-stop snd d) + snd)) + - -; set-logical-stop-abs - modify the sound and return it +; SET-LOGICAL-STOP-ABS - modify the sound and return it ; -(defun set-logical-stop-abs (snd tim) (snd-set-logical-stop snd tim) snd) +(defun set-logical-stop-abs (snd tim) + (ny:typecheck (not (numberp tim)) + (ny:error "SET-LOGICAL-STOP-ABS" 2 '((NUMBER) "logical stop time") tim)) + (ny:typecheck (not (or (soundp snd) (multichannel-soundp snd))) + (ny:error "SET-LOGICAL-STOP-ABS" 1 '((SOUND) "snd") snd t)) + (multichan-expand "SET-LOGICAL-STOP-ABS" #'ny:set-logical-stop-abs + '(((SOUND) "snd") ((NUMBER) "logical stop time")) snd tim)) +(defun ny:set-logical-stop-abs (snd tim) + (snd-set-logical-stop snd tim) + snd) + + (defmacro simrep (pair sound) `(let (_snds) (dotimes ,pair (push ,sound _snds)) - (sim-list _snds))) + (sim-list _snds "SIMREP"))) (defun sim (&rest snds) - (sim-list snds)) + (sim-list snds "SIM or SUM (or + in SAL)")) (setfn sum sim) -(defun sim-list (snds) +(defun sim-list (snds source) + (let (a b) (cond ((null snds) (snd-zero (local-to-global 0) *sound-srate*)) ((null (cdr snds)) - (car snds)) + (setf a (car snds)) + (ny:typecheck (not (or (numberp a) (soundp a) (multichannel-soundp a))) + (ny:error source 0 number-sound-anon a t)) + a) ((null (cddr snds)) - (nyq:add2 (car snds) (cadr snds))) + ;; sal-plus does typechecking, then calls nyq:add2 + (sal-plus (car snds) (cadr snds))) (t - (nyq:add2 (car snds) (sim-list (cdr snds)))))) + (setf a (car snds)) + (ny:typecheck (not (or (numberp a) (soundp a) (multichannel-soundp a))) + (ny:error source 0 number-sound-anon a t)) + (nyq:add2 a (sim-list (cdr snds) source)))))) (defun s-rest (&optional (dur 1.0) (chans 1)) + (ny:typecheck (not (numberp dur)) + (ny:error "S-REST" 1 '((NUMBER) "dur") dur)) + (ny:typecheck (not (integerp chans)) + (ny:error "S-REST" 2 '((INTEGER) "chans") chans)) (let ((d (get-duration dur)) r) (cond ((= chans 1) @@ -1520,25 +2067,40 @@ loop (defun tempo (warpfn) + (ny:typecheck (not (soundp warpfn)) + (ny:error "TEMPO" 0 '((SOUND) "warpfn") warpfn)) (slope (snd-inverse warpfn (local-to-global 0) *control-srate*))) - ;; (SUM-OF-ARRAYS S1 S2) - add multichannel sounds ; +; assumes s1 & s2 are arrays of numbers and sounds +; ; result has as many channels the largest of s1, s2 ; corresponding channels are added, extras are copied ; (defun sum-of-arrays (s1 s2) +; (ny:typecheck (not (multichannel-soundp s1)) +; (error (strcat "In SUM or SIM (or + in SAL), at least one channel in the array contains a non-sound, got " (param-to-string s1)))) +; (ny:typecheck (not (multichannel-soundp s2)) +; (error (strcat "In SUM or SIM (or + in SAL), at least one channel in the array contains a non-sound, got " (param-to-string s2)))) (let* ((n1 (length s1)) (n2 (length s2)) (n (min n1 n2)) (m (max n1 n2)) (result (make-array m)) - (big-s (if (> n1 n2) s1 s2))) + (big-s (if (> n1 n2) s1 s2)) + v1 v2) (dotimes (i n) - (setf (aref result i) (nyq:add-2-sounds (aref s1 i) (aref s2 i)))) + (setf v1 (aref s1 i) v2 (aref s2 i)) + (setf (aref result i) + (cond ((numberp v1) + (if (numberp v2) (+ v1 v2) (snd-offset v2 v1))) + ((numberp v2) + (if (numberp v1) (+ v1 v2) (snd-offset v1 v2))) + (t + (nyq:add-2-sounds v1 v2))))) (dotimes (i (- m n)) (setf (aref result (+ n i)) (aref big-s (+ n i)))) result)) @@ -1566,21 +2128,29 @@ loop ;; = (snd-offset (scale s g) d) (defmacro warp (x s) - `(progv '(*WARP*) (list - (list 0.0 1.0 - (if (warp-function *WARP*) - (snd-compose (shift-time (warp-function *WARP*) - (- (warp-time *WARP*))) - (scale (warp-stretch *WARP*) - (must-be-sound ,x))) - (snd-offset (scale (warp-stretch *WARP*) - (must-be-sound ,x)) - (warp-time *WARP*))))) + `(progv '(*WARP*) + (let ((wp ,x)) + (list (list 0.0 1.0 + (cond ((warp-function *WARP*) + (ny:typecheck (not (soundp wp)) + (ny:error "WARP" 1 '((SOUND) "warp function") wp)) + (snd-compose (shift-time (warp-function *WARP*) + (- (warp-time *WARP*))) + (snd-scale (warp-stretch *WARP*) wp))) + (t + (ny:typecheck (not (soundp wp)) + (ny:error "WARP" 1 '((SOUND) "warp function") wp)) + (snd-offset (snd-scale (warp-stretch *WARP*) wp) + (warp-time *WARP*))))))) ,s)) (defmacro warp-abs (x s) - `(progv '(*WARP*) (list (list 0.0 1.0 ,x)) + `(progv '(*WARP*) + (let ((wp ,x)) + (ny:typecheck (and wp (not (soundp wp))) + (ny:error "WARP-ABS" 1 '((NULL SOUND) NIL) wp)) + (list (list 0.0 1.0 wp))) ,s)) @@ -1593,29 +2163,82 @@ loop ;; fn for the i'th channel are either the i'th element of an array ;; argument, or just a copy of a non-array argument. ;; -(defun multichan-expand (fn &rest args) - (let (len newlen result) ; len is a flag as well as a count +;; types should be a list of type info for each arg, where type info is: +;; (arg1-info arg2-info ...), where each arg-info is +;; (valid-type-list name-or-nil), where valid-type-list is a list +;; of valid types from among NUMBER, SOUND, POSITIVE (number > 0), +;; NONNEGATIVE (number >= 0), INTEGER, STEP, STRING, +;; POSITIVE-OR_NULL (a positive number or nil), +;; INT-OR-NULL (integer or nil), or NULL (the value can be nil). +;; It is implied that arrays of these are valid too. name-or-nil +;; is the parameter name as a string if the parameter name should +;; be printed, or NIL if the parameter name should not be printed. +;; There can be at most 2 elements in valid-type-list, and if +;; there are 2 elements, the 2nd one must be SOUND. For example, +;; arg-info '((NUMBER SOUND) "cutoff") might generate the error +;; In LOPASS8, 2nd argument (cutoff) must be a number, sound +;; or array thereof, got "bad-value" +;; +(defun multichan-expand (src fn types &rest args) + (let (len newlen result prev typ (index 0) nonsnd) ; len is a flag as well as a count (dolist (a args) - (cond ((arrayp a) - (setf newlen (length a)) - (cond ((and len (/= len newlen)) - (error (format nil "In ~A, two arguments are vectors of differing length." fn)))) - (setf len newlen)))) + (setf typ (car types) types (cdr types)) + ;; we only report argument position when there is more than one. + ;; index tracks argument position, where 0 means no position to report + (if (> (length args) 1) (setf index (1+ index))) + (setf nonsnd (caar typ)) ;; if non-sound type allowed, what is it? + ;; compute the length of any array argument, and typecheck all of them + (cond ((arrayp a) + (setf newlen (length a)) + (ny:typecheck (and len (/= len newlen)) + (error (strcat "In " src + ", two arguments are multichannels of differing length, got " + (param-to-string prev) ", and " (param-to-string a)))) + (dotimes (i newlen) + (setf chan (aref a i)) + (cond ((and (eq nonsnd 'NUMBER) (numberp chan))) + ((and (member 'SOUND (car typ)) (soundp chan))) + ((and (eq nonsnd 'STEP) (numberp chan))) + ((and (eq nonsnd 'POSITIVE) (numberp chan) (> chan 0))) + ((and (eq nonsnd 'POSITIVE-OR-NULL) + (or (and (numberp chan) (> chan 0)) (null chan)))) + ((and (eq nonsnd 'NONNEGATIVE) (numberp chan) (>= chan 0))) + ((and (eq nonsnd 'INTEGER) (integerp chan))) + ((and (eq nonsnd 'STRING) (stringp chan))) + ((and (eq nonsnd 'NULL) (null chan))) + ((and (eq nonsnd 'INT-OR-NULL) + (or (integerp chan) (null chan)))) + (t (ny:error src index typ a t)))) + (setf prev a) + (setf len newlen)) + ((and (eq nonsnd 'NUMBER) (numberp a))) + ((and (member 'SOUND (car typ)) (soundp a))) + ((and (eq nonsnd 'STEP) (numberp a))) + ((and (eq nonsnd 'POSITIVE) (numberp a) (>= a 0))) + ((and (eq nonsnd 'POSITIVE-OR-NULL) + (or (and (numberp a) (> a 0)) (null a)))) + ((and (eq nonsnd 'NONNEGATIVE) (numberp a) (>= a 0))) + ((and (eq nonsnd 'INTEGER) (integerp a))) + ((and (eq nonsnd 'STRING) (stringp a))) + ((and (eq nonsnd 'NULL) (null a))) + ((and (eq nonsnd 'INT-OR-NULL) + (or (integerp a) (null a)))) + (t + (ny:error src index typ a t)))) (cond (len - (setf result (make-array len)) - ; for each channel, call fn with args - (dotimes (i len) - (setf (aref result i) - (apply fn - (mapcar - #'(lambda (a) - ; take i'th entry or replicate: - (cond ((arrayp a) (aref a i)) - (t a))) - args)))) - result) - (t - (apply fn args))))) + (setf result (make-array len)) + ; for each channel, call fn with args + (dotimes (i len) + (setf (aref result i) + (apply fn + (mapcar + #'(lambda (a) ; take i'th entry or replicate: + (cond ((arrayp a) (aref a i)) + (t a))) + args)))) + result) + (t + (apply fn args))))) ;; SELECT-IMPLEMENTATION-? -- apply an implementation according to args @@ -1629,24 +2252,46 @@ loop ;; SELECT-IMPLEMENTATION-1-1 -- 1 sound arg, 1 selector ;; -(defun select-implementation-1-1 (fns snd sel1 &rest others) - (if (numberp sel1) - (apply (aref fns 0) (cons snd (cons sel1 others))) - (apply (aref fns 1) (cons snd (cons sel1 others))))) +(defun select-implementation-1-1 (source fns snd sel1 &rest others) + (ny:typecheck (not (soundp snd)) + (ny:error source 1 '((SOUND) nil) snd t)) + (cond ((numberp sel1) + (apply (aref fns 0) (cons snd (cons sel1 others)))) + ((soundp sel1) + (apply (aref fns 1) (cons snd (cons sel1 others)))) + (t + (ny:error source 2 number-sound-anon sel1 t)))) ;; SELECT-IMPLEMENTATION-1-2 -- 1 sound arg, 2 selectors ;; -;; choose implemenation according to args 2 and 3 +;; choose implemenation according to args 2 and 3. In this implementation, +;; since we have two arguments to test for types, we return from prog +;; if we find good types. That way, we can fall through the decision tree +;; and all paths lead to one call to ERROR if good types are not found. ;; -(defun select-implementation-1-2 (fns snd sel1 sel2 &rest others) - (if (numberp sel2) - (if (numberp sel1) - (apply (aref fns 0) (cons snd (cons sel1 (cons sel2 others)))) - (apply (aref fns 1) (cons snd (cons sel1 (cons sel2 others))))) - (if (numberp sel1) - (apply (aref fns 2) (cons snd (cons sel1 (cons sel2 others)))) - (apply (aref fns 3) (cons snd (cons sel1 (cons sel2 others))))))) +(defun select-implementation-1-2 (source fns snd sel1 sel2 &rest others) + (prog () + (ny:typecheck (not (soundp snd)) + (ny:error source 1 '((SOUND) nil) snd t)) + (cond ((numberp sel2) + (cond ((numberp sel1) + (return (apply (aref fns 0) + (cons snd (cons sel1 (cons sel2 others)))))) + ((soundp sel1) + (return (apply (aref fns 1) + (cons snd (cons sel1 (cons sel2 others)))))))) + ((soundp sel2) + (cond ((numberp sel1) + (return (apply (aref fns 2) + (cons snd (cons sel1 (cons sel2 others)))))) + ((soundp sel1) + (return (apply (aref fns 3) + (cons snd (cons sel1 (cons sel2 others))))))))) + (ny:typecheck (not (or (numberp sel1) (soundp sel1))) + (ny:error src 2 number-sound-anon sel1 t) + (ny:error src 3 number-sound-anon sel2 t)))) + ;; some waveforms @@ -1657,9 +2302,16 @@ loop (setf *tri-table* (list *tri-table* (hz-to-step 1) T)) (setf *id-shape* (pwlvr -1 2 1 .01 1)) ; identity + (setf *step-shape* (seq (const -1) (const 1 1.01))) ; hard step at zero (defun exp-dec (hold halfdec length) + (ny:typecheck (not (numberp hold)) + (ny:error "EXP-DEC" 1 '((NUMBER) "hold") hold)) + (ny:typecheck (not (numberp halfdec)) + (ny:error "EXP-DEC" 2 '((NUMBER) "halfdec") halfdec)) + (ny:typecheck (not (numberp length)) + (ny:error "EXP-DEC" 3 '((NUMBER) "length") length)) (let* ((target (expt 0.5 (/ length halfdec))) (expenv (pwev 1 hold 1 length target))) expenv) @@ -1667,13 +2319,26 @@ loop ;;; operations on sounds -(defun diff (x &rest y) - (cond (y (sum x (prod -1 (car y)))) - (t (prod -1 x)))) +(defun diff (x &rest y) (diff-list x y "DIFF (or - in SAL)")) + +(defun diff-list (x y source) + (cond ((and (numberp x) (numberp (car y)) (null (cdr y))) + (- x (car y))) ;; this is a fast path for the common case + (y (sal-plus x (nyq:prod2 -1 (car y) source) source)) + (t (nyq:prod2 -1 x source)))) + ; compare-shape is a shape table -- origin 1. (defun compare (x y &optional (compare-shape *step-shape*)) - (let ((xydiff (diff x y))) + (ny:typecheck (not (or (soundp x) (soundp y))) + (error "In COMPARE, either first or second argument must be a sound")) + (ny:typecheck (not (soundp compare-shape)) + (ny:error "COMPARE" 3 '((SOUND) "compare-shape") compare-shape)) + (ny:typecheck (not (or (soundp x) (numberp x))) + (ny:error "COMPARE" 1 '((SOUND NUMBER) nil) x)) + (ny:typecheck (not (or (soundp y) (numberp y))) + (ny:error "COMPARE" 2 '((SOUND NUMBER) nil) y)) + (let ((xydiff (diff-list x (list y) "COMPARE"))) (shape xydiff compare-shape 1))) ;;; oscs @@ -1689,5 +2354,48 @@ loop ;;; tapped delays ;(tapv snd offset vardelay maxdelay) -(setfn tapv snd-tapv) ;; linear interpolation -(setfn tapf snd-tapf) ;; no interpolation +(defun tapv (snd offset vardelay maxdelay) + (multichan-expand "TAPV" #'snd-tapv + '(((SOUND) "snd") ((NUMBER) "offset") + ((SOUND) "vardelay") ((NUMBER) "maxdelay")) + snd offset vardelay maxdelay)) + +(defun tapf (snd offset vardelay maxdelay) + (multichan-expand "TAPF" #'snd-tapf + '(((SOUND) "snd") ((NUMBER) "offset") + ((SOUND) "vardelay") ((NUMBER) "maxdelay")) + snd offset vardelay maxdelay)) + + +;; autoload functions -- SELF-MODIFYING CODE! +;; generate functions that replace themselves by loading more files +;; and then re-calling themselves as if they were already loaded +;; +(defun autoload (filename &rest fns) + ;; filename is the file to load (a string) from the current path + ;; fns are symbols to be defined as function that will load filename + ;; the first time any one is called, and it is assumed that + ;; filename will define each function in fns, so the called + ;; function can be called again to execute the real implementation + (let ((cp (current-path))) + (cond ((string-equal cp "./") ;; this is the typical case + (setf cp (setdir ".")))) + ;; make sure cp ends in file separator + (cond ((not (equal (char cp (1- (length cp))) *file-separator*)) + (setf cp (strcat cp (string *file-separator*))))) + (setf cp (strcat cp filename)) + (dolist (fn fns) + (eval `(defun ,fn (&rest args) + (autoload-helper ,cp ',fn args)))))) + + +(defun autoload-helper (path fn args) + (if (abs-env (sal-load path)) + (apply fn args) + (error (strcat "Could not load " path)))) + + +(autoload "spec-plot.lsp" 'spec-plot) + +(autoload "spectral-analysis.lsp" 'sa-init) + diff --git a/nyquist/sal-parse.lsp b/nyquist/sal-parse.lsp index 326c94ec1..34817b6f3 100644 --- a/nyquist/sal-parse.lsp +++ b/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: ( ) - '((:+ "+" 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))) diff --git a/nyquist/sal.lsp b/nyquist/sal.lsp index 47781024d..cbb451b1f 100644 --- a/nyquist/sal.lsp +++ b/nyquist/sal.lsp @@ -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))) diff --git a/nyquist/seq.lsp b/nyquist/seq.lsp index 4d6000960..5e8c9fba9 100644 --- a/nyquist/seq.lsp +++ b/nyquist/seq.lsp @@ -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))))))) diff --git a/nyquist/seqmidi.lsp b/nyquist/seqmidi.lsp index 686f018b3..bea71145d 100644 --- a/nyquist/seqmidi.lsp +++ b/nyquist/seqmidi.lsp @@ -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))))) diff --git a/nyquist/sliders.lsp b/nyquist/sliders.lsp new file mode 100644 index 000000000..702bb0db4 --- /dev/null +++ b/nyquist/sliders.lsp @@ -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 "*********************************************") diff --git a/nyquist/spec-plot.lsp b/nyquist/spec-plot.lsp new file mode 100644 index 000000000..20343cc4b --- /dev/null +++ b/nyquist/spec-plot.lsp @@ -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))))) + diff --git a/nyquist/spectral-analysis.lsp b/nyquist/spectral-analysis.lsp new file mode 100644 index 000000000..56b2340b6 --- /dev/null +++ b/nyquist/spectral-analysis.lsp @@ -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: , +;; fft-dur: , +;; skip-period: , +;; window: , +;; input: ) +;; +;; 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)))) + diff --git a/nyquist/stk.lsp b/nyquist/stk.lsp index 10c84d6a2..3eae13908 100644 --- a/nyquist/stk.lsp +++ b/nyquist/stk.lsp @@ -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)) diff --git a/nyquist/xm.lsp b/nyquist/xm.lsp index 725bb87f7..5a47426ba 100644 --- a/nyquist/xm.lsp +++ b/nyquist/xm.lsp @@ -3,156 +3,294 @@ #| PATTERN SEMANTICS -Patterns are objects that are generally accessed by calling -(next pattern). Each call returns the next item in an -infinite sequence generated by the pattern. Items are -organized into periods. You can access all (remaining) -items in the current period using (next pattern t). +Patterns are objects that are generally accessed by calling (next +pattern). Each call returns the next item in an infinite sequence +generated by the pattern. Items are organized into periods. You can +access all (remaining) items in the current period using (next pattern +t). -Patterns mark the end-of-period with +eop+, a distinguished -atom. The +eop+ markers are filtered out by the next function -but returned by the :next method. +Patterns mark the end-of-period with +eop+, a distinguished atom. The ++eop+ markers are filtered out by the next() function but returned by +the :next method. -Pattern items may be patterns. This is called a nested -pattern. When patterns are nested, you return a period -from the innermost pattern, i.e. traversal is depth-first. -This means when you are using something like random, you -have to remember the last thing returned and keep getting -the next element from that thing until you see +eop+; -then you move on. It's a bit more complicated because -a pattern advances when its immediate child pattern -finishes a cycle, but +eop+ is only returned from the -"leaf" patterns. +Pattern items may be patterns. This is called a nested pattern. When +patterns are nested, you return a period from the innermost pattern, +i.e. traversal is depth-first. This means when you are using something +like random, you select a random pattern and get an item from it. The +next time you handle :next, you get another item from the same pattern +until the pattern returns +eonp+, which you can read as "end of nested +pattern". Random would then advance to the next random pattern and get +an item from it. -With nested patterns, i.e. patterns with items that -are patterns, the implementation requires that -*all* items must be patterns. The application does -*not* have to make every item a pattern, so the -implementation "cleans up" the item list: Any item -that is not a pattern is be replaced with a cycle -pattern whose list contains just the one item. +While generating from a nested pattern, you might return many periods +including +eop+, but you do not advance to the next pattern at any +given level until that level receives +eonp+ from the next level down. -EXPLICIT PATTERN LENGTH +With nested patterns, i.e. patterns with items that are patterns, the +implementation requires that *all* items must be patterns. The +application does *not* have to make every item a pattern, so the +implementation "cleans up" the item list: Any item that is not a +pattern is be replaced with a cycle pattern whose list contains just +the one item. -Pattern length may be given explicitly by a number or -a pattern that generates numbers. Generally this is -specified as the optional :for keyword parameter when -the pattern is created. If the explicit pattern -length is a number, this will be the period length, -overriding all implicit lengths. If the pattern length -is itself a pattern, the pattern is evaluated every -period to determine the length of the next period, -overriding any implicit length. +PATTERN LENGTH + +There are two sorts of cycles and lengths. The nominal pattern +behavior, illustrated by cycle patterns, is to cycle through a +list. There is a "natural" length computed by :start-period and stored +in count that keeps track of this. + +The second cycle and length is established by the :for parameter, +which is optional. If a number or pattern is provided, it controls the +period length and overrides any default periods. When :for is given, +count is set and used as a counter to count the items remaining in +a period. + +To summarize, there are 3 ways to determine lengths: + +1) The length is implicit. The length can be computed by :start-period +and turned into an explicit length stored in count. + +2) The length is explicitly set with :for. This overrides the implicit +length. The explicit length is stored as count that tells how many +more items to generate in the current period. + +3) The length can be generated by a pattern. The pattern is evaluated +in :start-period to generate an explicit length. + +In case (1), a pattern object does not return +eonp+ to the next level +up unless it receives an +eonp+ from one level down *and* is at the +end of its period. E.g. in the random pattern, if there are three +nested patterns, random must see +eonp+ three times and make three +random pattern selections before returning +eonp+ to the next level +up. This is the basic mechanism for achieving a "depth-first" +expansion of patterns. + +However, there is still the question of periods. When a nested pattern +returns a period, do the containing pattern return that period or +merge the period with other periods from other nested patterns? The +default is to return periods as they are generated by sub-patterns. In +other words, when a nested pattern returns +eop+ (end of period), that +token is returned by the :next message. Thus, in one "natural" cycle +of a pattern of patterns, there can be many periods (+eop+'s) before ++eonp+ is returned, marking the end of the "natural" pattern at this +level. + +The alternative strategy, which is to filter out all the +eop+'s and +form one giant pattern that runs up to the natural length (+eonp+) for +this level, can be selected by setting the :merge parameter to true. +Note that :merge is ignored if :for is specified because :for says +exactly how many items are in each period. + +The Copier pattern is an interesting case. It's :start-pattern should +get the next period from its sub-pattern, a repeat count from the +:repeat pattern, and a boolean from the :merge pattern. Then, it +should make that many copies, returning them as multiple periods or as +one merged one, depending on :merge, followed by +eonp+, after which +:start-pattern is called and the process repeats. But if :for 10 is +provided, this means we need to return a single period of 10 items. We +call :start-pattern, then repeat the sub-pattern's period until we +have 10 items. Thus, we ignore the :merge flag and :repeat count. +This makes Copier with a :for parameter equivalent to Cycle with a +single sub-pattern in a list. If you think :for should not override +these parameters (:repeat and :merge), you can probably get what you +want by using a Length pattern to regroup the output of a Copier. IMPLEMENTATION -There are 3 ways to determine lengths: -1) The length is implicit. The length can be -computed (at some point) and turned into an -explicit length. +Most pattern behavior is implemented in a few inherited methods. -2) The length is explicit. This overrides the -implicit length. The explicit length is stored as -a counter that tells how many more items to generate -in the current period. +:next gets the next item or period. If there is a length-pattern +(from :for), :next groups items into periods, filtering out +eop+ and ++eonp+. If there is no length-pattern, :next passes +eop+ through and +watches for +eonp+ to cause the pattern to re-evaluate pattern +parameters. -3) The length can be generated by a pattern. -The pattern is evaluated to generate an explicit -length. +Several methods are implemented by subclasses of pattern-class: -So ultimately, we just need a mechanism to handle -explicit lengths. This is incorporated into the -pattern-class. The pattern-class sends :start-period -before calling :advance when the first item in a -period is about to be generated. Also, :next returns -+eop+ automatically at the end of a period. +:START-PERIOD is called before the first advance and before the first +item of a period controlled by :for. It sets count to the "natural" +length of the period. HAVE-CURRENT will be set to false. -Because evaluation is "depth first," i.e. we -advance to the next top-level item only after a period -is generated from a lower-level pattern, every pattern -has a "current" field that holds the current item. the -"have-current" field is a flag to tell when the "current" -field is valid. It is initialized to nil. +:ADVANCE advances to the next item in the pattern. If there are nested +patterns, advance is called to select the first nested pattern, then +items are returned until +eonp+ is seen, then we advance to the next +pattern, etc. After :ADVANCE, HAVE-CURRENT is true. -To generate an element, you need to follow the nested -patterns all the way to the leaf pattern for every -generated item. This is perhaps less efficient than -storing the current leaf pattern at the top level, but -patterns can be shared, i.e. a pattern can be a -sub-pattern of multiple patterns, so current position -in the tree structure of patterns can change at -any time. +CURRENT is set by advance to the current item. If this has nested +patterns, current is set to a pattern, and the pattern stays there in +current until advance is called, either at the end of period or when ++eonp+ is seen. -The evaluation of nested patterns is depth-first -and the next shallower level advances when its current -child pattern completes a cycle. To facilitate this -step, the :advance method, which advances a pattern -and computes "current", returns +eonp+, which is a -marker that a nested pattern has completed a cycle. +HAVE-CURRENT is a boolean to tell when CURRENT is valid. -The :next method generates the next item or +eop+ from -a pattern. The algorithm in psuedo-code is roughly this: +IS-NESTED - set when there are nested patterns. If there are, make all +items of any nested pattern be patterns (no mix of patterns and +non-patterns is allowed; use + (MAKE-CYCLE (LIST item)) +to convert a non-pattern to a pattern). -next(p) - while true: - if not have-current - pattern-advance() - have-current = true - if is-nested and current = eop: +Patterns may be shared, so the state machines may be advanced by more +than one less-deeply nested pattern. Thus, patterns are really DAGs +and not trees. Since patterns are hard enough to understand, the +precise order of evaluation and therefore the behavior of shared +patterns in DAGs may not be well-defined. In this implementation +though, we only call on state machines to advance as needed (we try +not to read out whole periods). + +The next() function gets an item or period by calling :next. + +The :next method is shared by all pattern sub-classes and behaves +differently with :for vs. no :for parameter. With the :for parameter, +we just get items until the count is reached, but getting items is +a bit tricky, because the normal behavior (without :for) might reach +the end of the "natural" period (+eonp+) before count is +reached. So somehow, we need to override count. We could just set +count the count, but count is going to count items and due to +empty periods, count could go to zero before count does. We could +set count = 1000 * count with the idea that we're probably in an +infinite loop generating empty periods forever if count ever reaches +zero. + +But then what about the Heap pattern? If count is greater than the +heap size, what happens when the heap is empty? Or should Heap not +allow :for? There are other "problem" patterns, and not all Vers. 1 +patterns allowed :for, so let's make list of patterns that could use +:for: + +:for is OK :for is not OK +---------- -------------- +cycle heap +line accumulation +random copier +palindrome length +accumulate window +sum +product +eval +markov + +It seems that we could use :for for all patterns and just extend the +behavior a bit, e.g. when the heap runs out, replenish it (without +getting another period from a sub-pattern, if any; accumulation could +just start over; copier could cycle as described earlier; length +really should not allow :for, and window could just generate :for +items before reevaluating :skip and :pattern-length parameters. + +To implement this, the subclass patterns need :advance to do the right +next thing even if we are beyond the "natural" period. :advance should +go to the next sub-pattern or item without returning +eop+ or getting +the next item from any sub-pattern. + +state transitions are based on count and something like this: +count +nil -> actions: :start-period, don't return, set count +N -> N-1, actions: :advance if not have-current, return next item +0 -> -1, actions: return +eop+ +-1 -> nil, actions: return +eonp+ + + +def :next() + if length-pattern: // the :for parameter value + if null(count): // initial state before every period + var forcount = next(length-pattern) // must be a number + // compute forcount first and pass to start-period in case there + // is no "natural" period length. If there is a "natural" period, + // the forcount parameter is ignored (the usual case) + self.:start-period(forcount) + have-current = false + // :start-period() sets count, but we replace it with :for parameter + count = forcount + if count == 0: + count = -1 + return +eop+ + if count == -1: + count = nil + return +eonp+ + while true + // otherwise, here is where we return N items + if not have-current + self.:advance() + if not is-nested + // now current is updated + have-current = false + count = count - 1 + return current + // nested, so get item from sub-pattern + rslt = current.:next + if rslt == +eonp+ + // time to advance because sub-pattern has played out have-current = false - return eonp - if is-nested: - rslt = next(current) - if rslt == eonp - have-current = false - elif rslt == eop and not current.is-nested - have-current = false - return rslt + elif rslt == +eop+ + nil // skip ends of periods, we're merging them + // we got a real item to return else + count = count - 1 return rslt - else - have-current = nil - return current - -pattern-advance - // length-pattern is either a pattern or a constant - if null(count) and length-pattern: - count = next(length-pattern) - start-period() // subclass-specific computation - if null(count) - error - if count == 0 - current = eop - count = nil - else - advance() // subclass-specific computation - count-- - - -SUBCLASS RESPONSIBILITIES - -Note that :advance is the method to override in the -various subclasses of pattern-class. The :advance() -method computes the next element in the infinite -sequence of items and puts the item in the "current" -field. - -The :start-period method is called before calling -advance to get the first item of a new period. - -Finally, set the is-nested flag if there are nested patterns, -and make all items of any nested pattern be patterns (no -mix of patterns and non-patterns is allowed; use - (MAKE-CYCLE (LIST item)) -to convert a non-pattern to a pattern). - + // here, we have no length-pattern, so use "natural" periods + // count is null, and we use count + while true + if null(count): + have-current = false + self.:start-period() + if is-nested: + if count == 0: + if merge-flag: // we filtered out +eop+ so return one here + count == -1 + return +eop+ + else + count = nil + return +eonp+ + if count == -1 + count = nil + return +eonp+ + else + if count = 0: + count = -1 + return +eop+ + if count == -1: + count = nil + return +eonp+ + // count is a number > 0 + if not have-current: + self.:advance + have-current = true + if not is-nested + have-current = false + count = count - 1 + return current + // nested, so get sub-pattern's next item or +eonp+ or +eop+ + rslt = current.:next + if rslt == +eonp+ + have-current = false // force advance next time, don't + // return +eonp+ until count == 0 + else if rslt == +eop+ and merge-flag: + nil // iterate, skipping this +eop+ to merge periods + else + return rslt // either +eop+ or a real item + + +If the input is a list of patterns, then the pattern selects patterns +from the list, and the internal state advances as each selected +pattern completes a period. In this case, there is no way to control +the number of elements drawn from each selected pattern -- the number +is always the length of the period returned by the selected +pattern. If :for is specified, this controls the length of the period +delivered to the next less deeply nested pattern, but the delivered +period may be a mix of elements from the more deeply nested patterns. |# (setf SCORE-EPSILON 0.000001) (setf pattern-class - (send class :new '(current have-current is-nested name count - length-pattern trace))) + (send class :new '(current have-current is-nested name count merge-flag + merge-pattern length-pattern trace))) + +;; sub-classes should all call (send-super :isnew length-pattern name trace) +;; +(send pattern-class :answer :isnew '(mp lp nm tr) + '((setf merge-pattern mp length-pattern lp name nm trace tr) + (xm-traceif "pattern-class :isnew nm" nm "name" name))) (defun patternp (x) (and (objectp x) (send x :isa pattern-class))) @@ -185,7 +323,7 @@ to convert a non-pattern to a pattern). (patternp elem)) (return nil)))))) -(defun make-homogeneous (lis) +(defun make-homogeneous (lis traceflag) (cond ((is-homogeneous lis) lis) (t (mapcar #'(lambda (item) @@ -195,69 +333,127 @@ to convert a non-pattern to a pattern). ;; probably, the name could be item, but ;; here we coerce item to a string to avoid ;; surprises in code that assumes string names. - :name (format nil "~A" item)))) + :name (format nil "~A" item) :trace traceflag))) lis)))) -(send pattern-class :answer :next '() - '(;(display ":next" name is-nested) - (loop - (cond ((not have-current) - (send self :pattern-advance) - (setf have-current t) - (cond (trace - (format t "pattern ~A advanced to ~A~%" - (if name name "") - (if (patternp current) - (if (send current :name) - (send current :name) - "") - current)))) - (cond ((and is-nested (eq current +eop+)) - ;(display ":next returning eonp" name) - (setf have-current nil) - (return +eonp+))))) - (cond (is-nested - (let ((rslt (send current :next))) - (cond ((eq rslt +eonp+) - (setf have-current nil)) - ;; advance next-to-leaf level at end of leaf's period - ((and (eq rslt +eop+) (not (send current :is-nested))) - (setf have-current nil) - ;; return +eof+ because it's the end of leaf's period - (return rslt)) - (t - (return rslt))))) - (t - (setf have-current nil) - (return current)))))) - - -;; :PATTERN-ADVANCE -- advance to the next item in a pattern -;; -;; this code is used by every class. class-specific behavior -;; is implemented by :advance, which this method calls +;; used for both "advanced to" and ":next returns" messages ;; -(send pattern-class :answer :pattern-advance '() - '(;(display "enter :pattern-advance" self name count current is-nested) - (cond ((null count) - ;(display "in :pattern-advance" name count length-pattern) - (if length-pattern - (setf count (next length-pattern))) - ;; if count is still null, :start-period must set count - (send self :start-period))) - (cond ((null count) - (error - (format nil - "~A, pattern-class :pattern-advance has null count" name)))) - (cond ((zerop count) - (setf current +eop+) - (setf count nil)) - (t - (send self :advance) - (decf count))) - ;(display "exit :pattern-advance" name count current) - )) +(send pattern-class :answer :write-trace '(verb value) + '((format t "pattern ~A ~A ~A~%" + (if name name "") + verb + (if (patternp value) + (if (send value :name) + (send value :name) + "") + value)))) + + +;; :next returns the next value, including +eop+ and +eonp+ markers +;; +(send pattern-class :answer :next '() + '((xm-traceif ":next of" name "is-nested" is-nested "length-pattern" length-pattern) + (incf xm-next-nesting) + (let ((rslt + (cond (length-pattern (send self :next-for)) + (t (send self :next-natural))))) + (if trace (send self :write-trace ":next returns" rslt)) + (xm-traceif-return ":next" self rslt)))) + + +;; :next-for returns the next value, including +eop+ and +eonp+ markers +;; this code handles the cases where :for is specified, so the length +;; of each period is explicitly given, non intrinsic to the pattern +;; +(send pattern-class :answer :next-for '() + '((block pattern:next-for-block ;; so we can return from inside while loop + (cond ((null count) + (let ((forcount (next length-pattern))) + ;; in the case of window-class, there is no "natural" length + ;; so for that case, we pass in forcount + (send self :start-period forcount) ;; :start-period sets count, + (setf count forcount) ;; but it is replaced here by a number + (setf have-current nil)))) + ;; note that merge-flag is ignored if length-pattern + (cond ((zerop count) + (setf count -1) + (return-from pattern:next-for-block +eop+)) + ((eql count -1) + (setf count nil) + (return-from pattern:next-for-block +eonp+))) + (while t ;; after rejecting special cases, here is where we return N items + (cond ((not have-current) + (send self :advance) + (setf have-current t) + (if trace (send self :write-trace "advanced to" current)))) + (cond ((not is-nested) ;; now current is updated + (setf have-current nil) + (decf count) + (return-from pattern:next-for-block current))) + ;; is-nested, so get item from sub-pattern + (let ((rslt (send current :next))) + (cond ((eq rslt +eonp+) + ;; time to advance because sub-pattern has played out + (setf have-current nil)) + ((eq rslt +eop+)) ;; skip ends of periods; we merge them + (t + (decf count) + (return-from pattern:next-for-block rslt)))))))) + +;; :next-natural returns the next value, including +eop+ and +eonp+ markers +;; this code handles the cases where :for is not specified, so the length +;; of each period is implicitly determined from the pattern +;; +(send pattern-class :answer :next-natural '() + '((block pattern:next-natural-block ;; so we can return from inside while loop + (xm-traceif ":next-natural current" current) + (while t + (cond ((null count) + (setf have-current nil) + ;; :merge parameter is not used by every pattern, but it does not + ;; hurt to evaluate it here + (setf merge-flag (if merge-pattern (next merge-pattern))) + (send self :start-period nil))) ;; sets count + (xm-traceif "count" count "is-nested" is-nested) + (cond (is-nested + (cond ((zerop count) + (cond (merge-flag ;; we filtered out +eop+; return one here + (setf count -1) + (return-from pattern:next-natural-block +eop+)) + (t + (setf count nil) + (return-from pattern:next-natural-block +eonp+)))) + ((eql count -1) + (setf count nil) + (return-from pattern:next-natural-block +eonp+)))) + (t + (cond ((zerop count) + (setf count -1) + (return-from pattern:next-natural-block +eop+)) + ((eql count -1) + (setf count nil) + (return-from pattern:next-natural-block +eonp+))))) + (cond ((not have-current) + (send self :advance) + (setf have-current t) + (if trace (send self :write-trace "advanced to" current)) + (xm-traceif ":advance current" current))) + (cond ((not is-nested) + (setf have-current nil) + (decf count) + (return-from pattern:next-natural-block current))) + ;; nested, so get sub-pattern's next item or +eonp+ or +eop+ + (let ((rslt (send current :next))) + (xm-traceif "in :next-natural got from sub-pattern " rslt) + (cond ((eq rslt +eonp+) + (setf have-current nil) ;; force advance next time, don't + ;; return +eonp+ until count == 0 + (decf count)) + ((and (eq rslt +eop+) merge-flag)) ;; iterate, skip +eop+ + (t + (return-from pattern:next-natural-block rslt)))))))) + (send pattern-class :answer :is-nested '() '(is-nested)) @@ -272,40 +468,78 @@ to convert a non-pattern to a pattern). (if (patternp current) (send current :name) current))) - ;(display ":set-current" name value) + (xm-traceif ":set-current" name "value" value) ))) +;; get-pattern-name - used for debugging, handles non-patterns safely +;; +(defun get-pattern-name (pattern) + (cond ((patternp pattern) (send pattern :name)) + (t pattern))) + + +;; more debugging support +(setf xm-next-nesting -1) +(setf *xm-trace* nil) + +;; use xm-traceif for verbose printing. It only prints if *xm-trace* +;; +(defun xm-traceif (&rest items) + (if *xm-trace* (apply #'xm-trace items))) + +;; use xm-traceif-return for verbose printing of return values. +;; It only prints if *xm-trace*. Includes decrement of xm-next-nesting. +;; +(defun xm-traceif-return (method pattern val) + (xm-traceif method (get-pattern-name pattern) "returning" val) + (decf xm-next-nesting) + val) + +;; use xm-trace for normal tracing enabled by the trace flag in patterns +;; +(defun xm-trace (&rest items) + (princ "|") + (dotimes (i xm-next-nesting) (princ " |")) + (dolist (item items) (princ item) (princ " ")) + (terpri)) + + ;; next -- get the next element in a pattern ;; ;; any non-pattern value is simply returned ;; (defun next (pattern &optional period-flag) - ;(display "next" pattern period-flag (patternp pattern)) + (incf xm-next-nesting) + (xm-traceif "next" (get-pattern-name pattern) period-flag) (cond ((and period-flag (patternp pattern)) (let (rslt elem) + (incf xm-next-nesting) + (xm-traceif "next sending :next to" (get-pattern-name pattern)) (while (not (eq (setf elem (send pattern :next)) +eop+)) - ;(display "next t" (send pattern :name) elem) + (xm-traceif "next got" elem "from" (get-pattern-name pattern)) (if (not (eq elem +eonp+)) - (push elem rslt))) - (reverse rslt))) + (push elem rslt)) + (if (null elem) (error "got null elem"))) ;;;;;;;; DEBUG ;;;;;;;;;;; + (decf xm-next-nesting) + (xm-traceif-return "next" pattern (reverse rslt)))) (period-flag - (display "next" pattern) + (xm-traceif "next with period-flag" (get-pattern-name pattern)) (error (format nil "~A, next expected a pattern" - (send pattern :name)))) + (get-pattern-name pattern)))) ((patternp pattern) - ;(display "next" (send pattern :name) pattern) + (xm-traceif "next with pattern" (get-pattern-name pattern) pattern) (let (rslt) (dotimes (i 10000 (error (format nil "~A, just retrieved 10000 empty periods -- is there a bug?" - (send pattern :name)))) + (get-pattern-name pattern)))) (if (not (member (setf rslt (send pattern :next)) '(+eop+ +eonp+))) - (return rslt))))) + (return (xm-traceif-return "next" pattern rslt)))))) (t ;; pattern not a pattern, so just return it: - ;(display "next" pattern) - pattern))) + (xm-traceif "next not pattern" pattern) + (xm-traceif-return "next" pattern pattern)))) ;; ---- LENGTH Class ---- @@ -313,7 +547,8 @@ to convert a non-pattern to a pattern). (send class :new '(pattern length-pattern) '() pattern-class)) (send length-class :answer :isnew '(p l nm tr) - '((setf pattern p length-pattern l name nm trace tr))) + '((send-super :isnew nil l nm tr) ;; note: no merge pattern is applicable + (setf pattern p))) ;; note that count is used as a flag as well as a counter. ;; If count is nil, then the pattern-length has not been @@ -322,7 +557,7 @@ to convert a non-pattern to a pattern). ;; used to count down the number of items remaining in ;; the period. -(send length-class :answer :start-period '() +(send length-class :answer :start-period '(forcount) '((setf count (next length-pattern)))) (send length-class :answer :advance '() @@ -337,28 +572,31 @@ to convert a non-pattern to a pattern). '(lis cursor lis-pattern) '() pattern-class)) -(send cycle-class :answer :isnew '(l for nm tr) - '((cond ((patternp l) +(send cycle-class :answer :isnew '(l mp for nm tr) + '((send-super :isnew mp for nm tr) + (cond ((patternp l) (setf lis-pattern l)) ((listp l) - (send self :set-list l)) + (send self :set-list l tr)) (t - (error (format nil "~A, expected list" nm) l))) - (setf length-pattern for name nm trace tr))) + (error (format nil "~A, expected list" nm) l))))) -(send cycle-class :answer :set-list '(l) +(send cycle-class :answer :set-list '(l tr) '((setf lis l) (check-for-list lis "cycle-class :set-list") (setf is-nested (list-has-pattern lis)) - (setf lis (make-homogeneous lis)))) + (setf lis (make-homogeneous lis tr)))) -(send cycle-class :answer :start-period '() - '(;(display "cycle-class :start-period" lis-pattern lis count length-pattern) +(send cycle-class :answer :start-period '(forcount) + '((xm-traceif "cycle-class :start-period" "lis-pattern" + (get-pattern-name lis-pattern) "lis" lis "count" count + "length-pattern" (get-pattern-name length-pattern)) (cond (lis-pattern - (send self :set-list (next lis-pattern t)) - (setf cursor lis))) + (send self :set-list (next lis-pattern t) trace))) + ;; notice that list gets reset at the start of the period + (setf cursor lis) (if (null count) (setf count (length lis))))) @@ -372,35 +610,36 @@ to convert a non-pattern to a pattern). (pop cursor))) -(defun make-cycle (lis &key for (name "cycle") trace) +(defun make-cycle (lis &key merge for (name "cycle") trace) (check-for-list-or-pattern lis "make-cycle") - (send cycle-class :new lis for name trace)) + (send cycle-class :new lis merge for name trace)) ;; ---- LINE class ---- (setf line-class (send class :new '(lis cursor lis-pattern) '() pattern-class)) -(send line-class :answer :isnew '(l for nm tr) - '((cond ((patternp l) +(send line-class :answer :isnew '(l mp for nm tr) + '((send-super :isnew mp for nm tr) + (cond ((patternp l) (setf lis-pattern l)) ((listp l) - (send self :set-list l)) + (send self :set-list l tr)) (t - (error (format nil "~A, expected list" nm) l))) - (setf length-pattern for name nm trace tr))) + (error (format nil "~A, expected list" nm) l))))) -(send line-class :answer :set-list '(l) + +(send line-class :answer :set-list '(l tr) '((setf lis l) (check-for-list lis "line-class :set-list") (setf is-nested (list-has-pattern lis)) - (setf lis (make-homogeneous l)) + (setf lis (make-homogeneous l tr)) (setf cursor lis))) -(send line-class :answer :start-period '() +(send line-class :answer :start-period '(forcount) '((cond (lis-pattern - (send self :set-list (next lis-pattern t)) + (send self :set-list (next lis-pattern t) trace) (setf cursor lis))) (if (null count) (setf count (length lis))))) @@ -413,9 +652,9 @@ to convert a non-pattern to a pattern). (if (cdr cursor) (pop cursor)))) -(defun make-line (lis &key for (name "line") trace) +(defun make-line (lis &key merge for (name "line") trace) (check-for-list-or-pattern lis "make-line") - (send line-class :new lis for name trace)) + (send line-class :new lis merge for name trace)) ;; ---- RANDOM class ----- @@ -424,14 +663,21 @@ to convert a non-pattern to a pattern). '(lis lis-pattern len previous repeats mincnt maxcnt) '() pattern-class)) -;; the structure is (value weight weight-pattern max min) +;; the structure is (value weight weight-pattern max max-pattern min min-pattern) (setfn rand-item-value car) (defun set-rand-item-value (item value) (setf (car item) value)) + (setfn rand-item-weight cadr) (defun set-rand-item-weight (item weight) (setf (car (cdr item)) weight)) (setfn rand-item-weight-pattern caddr) + (setfn rand-item-max cadddr) -(defun rand-item-min (lis) (car (cddddr lis))) +(defun set-rand-item-max (item max) (setf (car (cdddr item)) max)) +(defun rand-item-max-pattern(item) (car (cddddr item))) + +(defun rand-item-min (lis) (cadr (cddddr lis))) +(defun set-rand-item-min (item min) (setf (car (cdr (cddddr item))) min)) +(defun rand-item-min-pattern(item) (car (cddr (cddddr item)))) (defun select-random (len lis previous repeats mincnt maxcnt) @@ -446,55 +692,54 @@ to convert a non-pattern to a pattern). (setf items lis) (setf r (rrandom)) (setf sum (* sum r)) - (setf rbd-count-all (incf rbd-count-all)) (loop (setf sum (- sum (rand-item-weight (car items)))) (if (<= sum 0) (return (car items))) - (setf rbd-count-two (incf rbd-count-two)) (setf items (cdr items))))))) (defun random-convert-spec (item) ;; convert (value :weight wp :min min :max max) to (value nil wp max min) - (let (value (wp 1) mincnt maxcnt lis) + (let (value (wp 1) minpat maxpat lis) (setf value (car item)) (setf lis (cdr item)) (while lis (cond ((eq (car lis) :weight) (setf wp (cadr lis))) ((eq (car lis) :min) - (setf mincnt (cadr lis))) + (setf minpat (cadr lis))) ((eq (car lis) :max) - (setf maxcnt (cadr lis))) + (setf maxpat (cadr lis))) (t (error "(make-random) item syntax error" item))) (setf lis (cddr lis))) - (list value nil wp maxcnt mincnt))) + (list value nil wp nil maxpat nil minpat))) (defun random-atom-to-list (a) (if (atom a) - (list a nil 1 nil nil) + (list a nil 1 nil nil nil nil) (random-convert-spec a))) -(send random-class :answer :isnew '(l for nm tr) +(send random-class :answer :isnew '(l mp for nm tr) ;; there are two things we have to normalize: ;; (1) make all items lists ;; (2) if any item is a pattern, make all items patterns - '((cond ((patternp l) + '((xm-traceif "random :isnew list" l "merge" mp "for" for "name" nm "trace" tr) + (send-super :isnew mp for nm tr) + (cond ((patternp l) (setf lis-pattern l)) ((listp l) (send self :set-list l)) (t - (error (format nil "~A, expected list") l))) - (setf rbd-count-all 0 rbd-count-two 0) - (setf length-pattern for name nm trace tr))) + (error (format nil "~A, expected list") l))))) (send random-class :answer :set-list '(l) '((check-for-list l "random-class :set-list") (setf lis (mapcar #'random-atom-to-list l)) + ; (display "random set-list" lis) (dolist (item lis) (if (patternp (rand-item-value item)) (setf is-nested t))) @@ -504,33 +749,38 @@ to convert a non-pattern to a pattern). (set-rand-item-value item (make-cycle (list (rand-item-value item)))))) lis)) - ;(display "random is-new" lis) + (xm-traceif "random is-new" name lis) (setf repeats 0) (setf len (length lis)))) -(send random-class :answer :start-period '() - '(;(display "random-class :start-period" count len lis lis-pattern) +(send random-class :answer :start-period '(forcount) + '((xm-traceif "random-class :start-period" name "count" count "len" len + "lis" lis "lis-pattern" (get-pattern-name lis-pattern)) (cond (lis-pattern (send self :set-list (next lis-pattern t)))) (if (null count) (setf count len)) (dolist (item lis) - (set-rand-item-weight item (next (rand-item-weight-pattern item)))))) + (set-rand-item-weight item (next (rand-item-weight-pattern item))) + (set-rand-item-max item (next (rand-item-max-pattern item))) + (set-rand-item-min item (next (rand-item-min-pattern item)))) + ; (display "random start-period" lis-pattern lis) + )) (send random-class :answer :advance '() '((let (selection (iterations 0)) - ;(display "random-class :advance" mincnt repeats) + (xm-traceif "random-class :advance" name "mincnt" mincnt + "repeats" repeats) (cond ((and mincnt (< repeats mincnt)) - (setf selection previous) - (incf repeats)) + (setf selection previous)) (t (setf selection (select-random len lis previous repeats mincnt maxcnt)))) (loop ; make sure selection is ok, otherwise try again (cond ((and (eq selection previous) - maxcnt + maxcnt (>= repeats maxcnt)) ; hit maximum limit, try again (setf selection (select-random len lis previous repeats mincnt maxcnt)) @@ -544,19 +794,24 @@ to convert a non-pattern to a pattern). (t (return)))) ; break from loop, we found a selection ; otherwise, we are ok + ; notice that we could have selected based on an older maxcnt and + ; maxcnt may now be smaller. This is allowed. Perhaps another + ; rule would be better, e.g. update maxcnt and check against it + ; with each selection. (if (not (eq selection previous)) (setf repeats 1) (incf repeats)) (setf mincnt (rand-item-min selection)) (setf maxcnt (rand-item-max selection)) (setf previous selection) - ;(display "new selection" repeats mincnt maxcnt selection) + (xm-traceif "new selection" name "repeats" repeats "mincnt" mincnt + "maxcnt" maxcnt "selection" selection) (send self :set-current (rand-item-value selection))))) -(defun make-random (lis &key for (name "random") trace) +(defun make-random (lis &key merge for (name "random") trace) (check-for-list-or-pattern lis "make-random") - (send random-class :new lis for name trace)) + (send random-class :new lis merge for name trace)) ;; ---- PALINDROME class ----- @@ -581,30 +836,35 @@ be computed based on elide. elide cursor) '() pattern-class)) -(send palindrome-class :answer :set-list '(l) +(send palindrome-class :answer :set-list '(l tr) '((setf lis l) (check-for-list lis "palindrome-class :start-period") (setf is-nested (list-has-pattern lis)) - (setf lis (make-homogeneous l)) - (setf revlis (reverse lis) - direction t - cursor lis))) + (setf lis (make-homogeneous l tr)) + (send self :set-cursor))) + +(send palindrome-class :answer :set-cursor '() + '((setf revlis (reverse lis) + direction t + cursor lis))) -(send palindrome-class :answer :isnew '(l e for nm tr) - '((cond ((patternp l) +(send palindrome-class :answer :isnew '(l e mp for nm tr) + '((send-super :isnew mp for nm tr) + (cond ((patternp l) (setf lis-pattern l)) ((listp l) - (send self :set-list l)) + (send self :set-list l tr)) (t (error (format nil "~A, expected list" nm) l))) - (setf elide-pattern e length-pattern for name nm trace tr))) + (setf elide-pattern e))) -(send palindrome-class :answer :start-period '() +(send palindrome-class :answer :start-period '(forcount) '((cond (lis-pattern - (send self :set-list (next lis-pattern t)) - (setf cursor lis))) + (send self :set-list (next lis-pattern t) trace))) + ;; like cycle, list is reset at the start of the period + (send self :set-cursor) (setf elide (next elide-pattern)) (if (and elide (null lis)) (error (format nil "~A, cannot elide if list is empty" name))) @@ -612,7 +872,10 @@ be computed based on elide. (setf count (- (* 2 (length lis)) (if (member elide '(:first :last)) 1 - (if elide 2 0))))))) + (if elide 2 0))))) + (if (<= count 0) + (error (format nil "palindrome ~A period is <= 0" + (get-pattern-name self)))))) (send palindrome-class :answer :next-item '() @@ -631,6 +894,8 @@ be computed based on elide. (direction ;; we're going forward (setf direction nil) ;; now going backward (setf cursor revlis) + (xm-traceif "palindrome at end" (get-pattern-name self) + "current" (get-pattern-name (car cursor))) (send self :next-item)) (t ;; direction is reverse (setf direction t) @@ -638,9 +903,9 @@ be computed based on elide. (send self :next-item))))) -(defun make-palindrome (lis &key elide for (name "palindrome") trace) +(defun make-palindrome (lis &key elide merge for (name "palindrome") trace) (check-for-list-or-pattern lis "make-palindrome") - (send palindrome-class :new lis elide for name trace)) + (send palindrome-class :new lis elide merge for name trace)) ;; ================= HEAP CLASS ====================== @@ -654,33 +919,42 @@ be computed based on elide. ;; after each item is generated, check-repeat is cleared. It is ;; recalculated when a new period is started. -(setf heap-class (send class :new '(lis used maxcnt prev check-repeat - lis-pattern len) +(setf heap-class (send class :new '(lis used maxcnt maxcnt-pattern prev + check-repeat lis-pattern len) '() pattern-class)) -(send heap-class :answer :isnew '(l for mx nm tr) - '((cond ((patternp l) +(send heap-class :answer :isnew '(l mp for mx nm tr) + '((send-super :isnew mp for nm tr) + (cond ((patternp l) (setf lis-pattern l)) ((listp l) ; make a copy of l to avoid side effects - (send self :set-list (append l nil))) + (send self :set-list (append l nil) tr)) (t (error (format nil "~A, expected list" nm) l))) - (setf length-pattern for maxcnt mx name nm trace tr))) + (cond ((patternp mx) + (setf maxcnt-pattern mx)) + ((not (numberp mx)) + (error (format nil "~A, expected number" nm) mx)) + (t + (setf maxcnt mx))))) -(send heap-class :answer :set-list '(l) +(send heap-class :answer :set-list '(l tr) '((setf lis l) (check-for-list lis "heap-class :set-list") (setf is-nested (list-has-pattern lis)) - (setf lis (make-homogeneous lis)) + (setf lis (make-homogeneous lis tr)) (setf len (length lis)))) -(send heap-class :answer :start-period '() - '(;(display "heap-class :start-period" lis-pattern count lis) +(send heap-class :answer :start-period '(forcount) + '((xm-traceif "heap-class :start-period" name "lis-pattern" + (get-pattern-name lis-pattern) "count" count "lis" lis) (cond (lis-pattern - (send self :set-list (next lis-pattern t)))) + (send self :set-list (next lis-pattern t) trace))) + (cond (maxcnt-pattern + (setf maxcnt (next maxcnt-pattern)))) ; start of period -- may need to avoid repeating previous item (if (= maxcnt 1) (setf check-repeat t)) (if (null count) @@ -726,18 +1000,18 @@ be computed based on elide. (setf prev elem) (send self :set-current elem)))) -(defun make-heap (lis &key for (max 2) (name "heap") trace) - (send heap-class :new lis for max name trace)) +(defun make-heap (lis &key merge for (max 2) (name "heap") trace) + (send heap-class :new lis merge for max name trace)) ;;================== COPIER CLASS ==================== (setf copier-class (send class :new '(sub-pattern repeat repeat-pattern - merge merge-pattern period cursor) + period cursor) '() pattern-class)) (send copier-class :answer :isnew '(p r m for nm tr) - '((setf sub-pattern p repeat-pattern r merge-pattern m) - (setf length-pattern for name nm trace tr))) + '((send-super :isnew m for nm tr) + (setf sub-pattern p repeat-pattern r))) #| copier-class makes copies of periods from sub-pattern @@ -747,14 +1021,14 @@ If merge is false, then repeat separate periods are returned. If repeat is negative, then -repeat periods of sub-pattern are skipped. -merge and repeat are computed from merge-pattern and +merge-flag and repeat are computed from merge-pattern and repeat-pattern initially and after making repeat copies To repeat individual items, set the :for keyword parameter of the sub-pattern to 1. |# -(send copier-class :answer :start-period '() +(send copier-class :answer :start-period '(forcount) '((cond ((null count) (cond ((or (null repeat) (zerop repeat)) (send self :really-start-period)) @@ -763,25 +1037,32 @@ the sub-pattern to 1. (send copier-class :answer :really-start-period '() - '(;(display "copier-class :really-start-period" count) - (setf merge (next merge-pattern)) + '((xm-traceif "copier-class :really-start-period" name "count" count) (setf repeat (next repeat-pattern)) (while (minusp repeat) (dotimes (i (- repeat)) (setf period (next sub-pattern t))) (setf repeat (next repeat-pattern)) - (setf merge (next merge-pattern))) + (setf merge-flag (next merge-pattern))) + +; (print "** STARTING NEXT PATTERN IN COPIER-CLASS") + (setf period (next sub-pattern t)) + +; (display "copier-class really-start-period got" period) +; (print "** ENDING NEXT PATTERN IN COPIER-CLASS") + (setf cursor nil) (if (null count) - (setf count (* (if merge repeat 1) + (setf count (* (if merge-flag repeat 1) (length period)))))) (send copier-class :answer :advance '() '((let ((loop-count 0)) (loop - ;(display "copier loop" repeat cursor period) + (xm-traceif "copier loop" name "repeat" repeat "cursor" cursor + "period" period) (cond (cursor (send self :set-current (car cursor)) (pop cursor) @@ -803,36 +1084,43 @@ the sub-pattern to 1. ;; ================= ACCUMULATE-CLASS =================== -(setf accumulate-class (send class :new '(sub-pattern period cursor sum mini maxi) +(setf accumulate-class (send class :new '(sub-pattern period cursor sum + mini maxi minimum maximum) '() pattern-class)) -(send accumulate-class :answer :isnew '(p for nm tr mn mx) - '((setf sub-pattern p length-pattern for name nm trace tr sum 0 mini mn maxi mx) - ; (display "accumulate isnew" self nm) +(send accumulate-class :answer :isnew '(p mp for nm tr mn mx) + '((send-super :isnew mp for nm tr) + (setf sub-pattern p sum 0 mini mn maxi mx) + ;(xm-trace "accumulate isnew" self nm) )) #| accumulate-class creates sums of numbers from another pattern The output periods are the same as the input periods (by default). -|# -(send accumulate-class :answer :start-period '() +(send accumulate-class :answer :start-period '(forcount) '((cond ((null count) (send self :really-start-period))))) - (send accumulate-class :answer :really-start-period '() +|# + + +(send accumulate-class :answer :start-period '(forcount) '((setf period (next sub-pattern t)) (setf cursor period) - ;(display "accumulate-class :really-start-period" period cursor count) + (xm-traceif "accumulate-class :start-period" name "period" period + "cursor" cursor "count" count) + (if maxi (setf maximum (next maxi))) + (if mini (setf minimum (next mini))) (if (null count) (setf count (length period))))) (send accumulate-class :answer :advance '() - '((let ((loop-count 0) (minimum (next mini)) (maximum (next maxi))) + '((let ((loop-count 0)) (loop (cond (cursor (setf sum (+ sum (car cursor))) @@ -847,12 +1135,12 @@ The output periods are the same as the input periods (by default). (error (format nil "~A, :advance encountered 10000 empty periods" name))) (t - (send self :really-start-period))) + (send self :start-period nil))) (incf loop-count))))) -(defun make-accumulate (sub-pattern &key for min max (name "accumulate") trace) - (send accumulate-class :new sub-pattern for name trace min max)) +(defun make-accumulate (sub-pattern &key merge for min max (name "accumulate") trace) + (send accumulate-class :new sub-pattern merge for name trace min max)) ;;================== ACCUMULATION CLASS =================== @@ -862,24 +1150,25 @@ The output periods are the same as the input periods (by default). (setf accumulation-class (send class :new '(lis lis-pattern outer inner len) '() pattern-class)) -(send accumulation-class :answer :isnew '(l for nm tr) - '((cond ((patternp l) +(send accumulation-class :answer :isnew '(l mp for nm tr) + '((send-super :isnew mp for nm tr) + (cond ((patternp l) (setf lis-pattern l)) ((listp l) (send self :set-list l)) (t - (error (format nil "~A, expected list" nm) l))) - (setf length-pattern for name nm trace tr))) + (error (format nil "~A, expected list" nm) l))))) + (send accumulation-class :answer :set-list '(l) '((setf lis l) (check-for-list lis "heap-class :set-list") - (setf lis (make-homogeneous lis)) + (setf lis (make-homogeneous lis trace)) (setf inner lis) (setf outer lis) (setf len (length lis)))) -(send accumulation-class :answer :start-period '() +(send accumulation-class :answer :start-period '(forcount) '((cond (lis-pattern (send self :set-list (next lis-pattern t)))) ; start of period, length = (n^2 + n) / 2 @@ -897,16 +1186,17 @@ The output periods are the same as the input periods (by default). (setf inner (rest inner)))) (send self :set-current elem)))) -(defun make-accumulation (lis &key for (name "accumulation") trace) - (send accumulation-class :new lis for name trace)) +(defun make-accumulation (lis &key merge for (name "accumulation") trace) + (send accumulation-class :new lis merge for name trace)) ;;================== SUM CLASS ================= (setf sum-class (send class :new '(x y period cursor fn) '() pattern-class)) -(send sum-class :answer :isnew '(xx yy for nm tr) - '((setf x xx y yy length-pattern for name nm trace tr fn #'+))) +(send sum-class :answer :isnew '(xx yy mp for nm tr) + '((send-super :isnew mp for nm tr) + (setf x xx y yy fn #'+))) #| sum-class creates pair-wise sums of numbers from 2 streams. @@ -914,7 +1204,7 @@ The output periods are the same as the input periods of the first pattern argument (by default). |# -(send sum-class :answer :start-period '() +(send sum-class :answer :start-period '(forcount) '((cond ((null count) (send self :really-start-period))))) @@ -940,46 +1230,71 @@ pattern argument (by default). (incf loop-count))))) -(defun make-sum (x y &key for (name "sum") trace) - (send sum-class :new x y for name trace)) +(defun make-sum (x y &key merge for (name "sum") trace) + (send sum-class :new x y merge for name trace)) ;;================== PRODUCT CLASS ================= (setf product-class (send class :new '() '() sum-class)) -(send product-class :answer :isnew '(xx yy for nm tr) - '((setf x xx y yy length-pattern for name nm trace tr fn #'*))) +(send product-class :answer :isnew '(xx yy mp for nm tr) + '((send-super :isnew xx yy mp for nm tr) + (setf x xx y yy fn #'*))) -(defun make-product (x y &key for (name "product") trace) - (send product-class :new x y for name trace)) +(defun make-product (x y &key merge for (name "product") trace) + (send product-class :new x y merge for name trace)) ;;================== EVAL CLASS ================= +;; +;; (1) if :for, then period is determined by :for and we should +;; just fetch the next item from expr-pattern or use expr +;; (this case is length-pattern) +;; (2) if expr-pattern and not :for, then we should fetch a whole +;; period from expr-pattern and use it to determine period len +;; (this case is (and expr-pattern (not length-pattern))) +;; (3) if not expr-pattern and not :for, then the pattern len is 1 +;; (this case is (and (not expr-pattern) (not length-pattern))) (setf eval-class (send class :new '(expr expr-pattern) '() pattern-class)) -(send eval-class :answer :isnew '(e for nm tr) - '((cond ((patternp e) +(send eval-class :answer :isnew '(e mp for nm tr) + '((send-super :isnew mp for nm tr) + (cond ((patternp e) (setf expr-pattern e)) (t - (setf expr e))) - (setf length-pattern for name nm trace tr))) + (setf expr e))))) -(send eval-class :answer :start-period '() - '(;(display "cycle-class :start-period" lis-pattern lis count length-pattern) - (cond (expr-pattern - (setf expr (next expr-pattern)))))) - +(send eval-class :answer :start-period '(forcount) + '((xm-traceif "eval-class :start-period" name "lis-pattern" + (get-pattern-name expr-pattern) "expr" expr "count" count + "length-pattern" (get-pattern-name expr-pattern)) + (cond (length-pattern t) ;; case 1 + (expr-pattern ;; case 2 + (setf expr (next expr-pattern t)) + (setf count (length expr))) + (t ;; case 3 + (setf count 1))))) + (send eval-class :answer :advance '() - '((send self :set-current (eval expr)))) + '((send self :set-current + (cond ((and length-pattern expr-pattern) + (eval (next expr-pattern))) + (length-pattern + (eval expr)) + (expr-pattern + (let ((item (car expr))) + (setf expr (cdr expr)) + item)) + (t (eval expr)))))) -(defun make-eval (expr &key (for 1) (name "eval") trace) - (send eval-class :new expr for name trace)) +(defun make-eval (expr &key merge (for 1) (name "eval") trace) + (send eval-class :new expr merge for name trace)) ;;================== MARKOV CLASS ==================== @@ -997,9 +1312,9 @@ pattern argument (by default). (setf elem (cadr produces)) (cond ((null type) (setf type (if (patternp elem) 'pattern 'atom)) - ;(display "is-produces-homogeneous" type) + (xm-traceif "is-produces-homogeneous type" type) (setf *rslt* (eq type 'pattern)) - ;(display "is-produces-homogeneous" *rslt*) + (xm-traceif "is-produces-homogeneous *rslt*" *rslt*) ) ((and (eq type 'pattern) (not (patternp elem))) (return nil)) @@ -1023,9 +1338,10 @@ pattern argument (by default). (reverse result))) -(send markov-class :answer :isnew '(r o s p for nm tr) +(send markov-class :answer :isnew '(r o s p mp for nm tr) ;; input parameters are rules, order, state, produces, for, name, trace - '((setf order o state s produces p length-pattern for name nm trace tr) + '((send-super :isnew mp for nm tr) + (setf order o state s produces p) (setf len (length r)) ;; input r looks like this: ;; ((prev1 prev2 -> next1 next2 (next3 weight) ... ) ...) @@ -1042,7 +1358,8 @@ pattern argument (by default). (next (second target)) (second target))) entry)) - ; (display "isnew" entry rule targets order (nthcdr order rule)) + (xm-traceif "markov-class isnew" name "entry" entry "rule" rule + "targets" targets "order" order (nthcdr order rule)) (dotimes (i order) (push (nth i rule) pattern)) (push (cons (reverse pattern) entry) rules))) @@ -1050,9 +1367,8 @@ pattern argument (by default). (setf *rslt* nil) ;; in case produces is nil (cond ((and produces (not (is-produces-homogeneous produces))) (setf produces (make-produces-homogeneous produces)))) - ;(display "markov-class :isnew" *rslt*) + (xm-traceif "markov-class :isnew" name "is-nested" *rslt*) (setf is-nested *rslt*) ;; returned by is-produces-homogeneous - ;(display "markov-class :isnew" is-nested) )) @@ -1064,14 +1380,6 @@ pattern argument (by default). (t (return nil))) ; a mismatch: return false (setf state (cdr state)))) -(defun markov-sum-of-weights (rule) - ;(display "sum-of-weights" rule) - (let ((sum 0.0)) - (dolist (target (cdr rule)) - ;(display "markov-sum-of-weights" target) - (setf sum (+ sum (second target)))) - sum)) - (defun markov-pick-target (sum rule) (let ((total 0.0) @@ -1092,14 +1400,25 @@ pattern argument (by default). (defun markov-map-target (target produces) (while (and produces (not (eq target (car produces)))) (setf produces (cddr produces))) - (cadr produces)) + (let ((rslt (cadr produces))) + (if (not rslt) (setf rslt target)) ;; if lookup fails return target + (if (patternp rslt) (setf rslt (next rslt))) + rslt)) + + +(send markov-class :answer :sum-of-weights '(rule) + '((let ((sum 0.0)) + (dolist (target (cdr rule)) + (xm-traceif "markov-sum-of-weights" name "target" target) + (setf sum (+ sum (second target)))) + sum))) (send markov-class :answer :find-rule '() '((let (rslt) - ;(display "find-rule" rules) + (xm-traceif "markov-class find-rule" name "rules" rules) (dolist (rule rules) - ;(display "find-rule" state rule) + (xm-traceif "markov find-rule" name "state" state "rule" rule) (cond ((markov-match state (car rule)) (setf rslt rule) (return rslt)))) @@ -1109,7 +1428,7 @@ pattern argument (by default). rslt))) -(send markov-class :answer :start-period '() +(send markov-class :answer :start-period '(forcount) '((if (null count) (setf count len)))) @@ -1136,12 +1455,11 @@ pattern argument (by default). (send markov-class :answer :advance '() '((let (rule sum target rslt new-state) - ;(display "markov" pattern rules) + (xm-traceif "markov :advance" name "pattern" pattern "rules" rules) (setf rule (send self :find-rule)) - ;(display "advance 1" rule) (markov-update-weights rule) - ;(display "advance 2" rule) - (setf sum (markov-sum-of-weights rule)) + (xm-traceif "markov sum-of-weights" name "rule" rule) + (setf sum (send self :sum-of-weights rule)) ;; the target can be a pattern, so apply NEXT to it (setf target (next (markov-pick-target sum rule))) ;; if the matching rule is multiple *'s, then this @@ -1157,17 +1475,20 @@ pattern argument (by default). (cond ((markov-general-rule-p rule) (setf new-state (markov-find-state-leading-to target rules)) (cond (new-state - ;(display "state replacement" new-state target) + (xm-trace "markov state replacement" name + "new-state" new-state "target" target) (setf state new-state))))) (setf state (append (cdr state) (list target))) - ;(display "markov next" rule sum target state) + (xm-traceif "markov next" name "rule" rule "sum" sum "target" target + "state" state) ;; target is the symbol for the current state. We can ;; return target (default), the value of target, or a ;; mapped value: (cond ((eq produces :eval) (setf target (eval target))) ((and produces (listp produces)) - ;(display "markov-produce" target produces) + (xm-traceif "markov-produce" name "target" target + "produces" produces) (setf target (markov-map-target target produces)))) (if (not (eq is-nested (patternp target))) (error (format nil @@ -1176,7 +1497,7 @@ pattern argument (by default). (send self :set-current target)))) -(defun make-markov (rules &key produces past for (name "markov") trace) +(defun make-markov (rules &key produces past merge for (name "markov") trace) ;; check to make sure past and rules are consistent (let ((order (length past))) (dolist (rule rules) @@ -1190,7 +1511,7 @@ pattern argument (by default). name))))) (cond ((null for) (setf for (length rules)))) - (send markov-class :new rules (length past) past produces for name trace)) + (send markov-class :new rules (length past) past produces merge for name trace)) (defun markov-rule-match (rule state) @@ -1202,7 +1523,7 @@ pattern argument (by default). (defun markov-find-rule (rules state) (dolist (rule rules) - ;(display "find-rule" rule) + (xm-traceif "markov find-rule" name "rule" rule) (cond ((markov-rule-match rule state) (return rule))))) @@ -1291,30 +1612,38 @@ pattern argument (by default). '() pattern-class)) (send window-class :answer :isnew '(p for sk nm tr) - '((setf pattern p length-pattern for skip-pattern sk name nm trace tr))) + '((send-super :isnew nil for nm tr) + (setf pattern p skip-pattern sk))) -(send window-class :answer :start-period '() - '((if (null count) (error (format nil "~A, :start-period -- count is null" - name))) +(send window-class :answer :start-period '(forcount) + '((if (null length-pattern) + (error (format nil "~A, :start-period -- length-pattern is null" + name))) + (setf count forcount) (cond ((null lis) ;; first time (dotimes (i count) (push (next pattern) lis)) - (setf lis (reverse lis))) + (setf lis (reverse lis)) + (setf cursor lis)) (t (let ((skip (next skip-pattern))) (dotimes (i skip) (if lis (pop lis) (next pattern)))) (setf lis (reverse lis)) - (let ((len (length lis))) + ;; now lis is in reverse order; if not long enough, push + (let ((len (length lis)) rslt) (while (< len count) (incf len) (push (next pattern) lis)) + (setf lis (reverse lis)) + ;; lis is in order, copy it to rstl and take what we need + (setf rslt (reverse (append lis nil))) ;; copy lis (while (> len count) (decf len) - (pop lis)) - (setf lis (reverse lis))))) - (setf cursor lis))) + (pop rslt)) + (setf cursor (reverse rslt))))) + (xm-traceif "window start-period cursor" cursor "lis" lis))) (send window-class :answer :advance '() @@ -1413,6 +1742,24 @@ pattern argument (by default). ;; ============== score manipulation =========== +(defun must-be-valid-score (caller score) + (if (not (score-validp score)) + (error (strcat "In " caller ", not a valid score") score))) + +(defun invalid-score () (return-from validp nil)) +(defun score-validp (score) + (block validp + (if (listp score) nil (invalid-score)) ;; tricky: return nil if NOT condition + (dolist (event score) + (if (listp event) nil (invalid-score)) + (if (and (event-time event) (numberp (event-time event))) nil + (invalid-score)) + (if (and (event-dur event) (numberp (event-dur event))) nil + (invalid-score)) + (if (and (event-expression event) (consp (event-expression event))) nil + (invalid-score))) + t)) + (defun event-before (a b) (< (car a) (car b))) @@ -1705,18 +2052,18 @@ pattern argument (by default). (let ((i 1) (start (find-first-note score from-index from-time)) (stop (find-last-note score to-index to-time)) + (begin (cadr (event-expression (car score)))) (end (caddr (event-expression (car score)))) result) (dolist (event (cdr score)) (cond ((and (<= start i) (< i stop)) (setf event (event-set-time event (+ (event-time event) offset))) + (setf begin (min begin (event-time event))) (setf end (max end (event-end event))))) (setf result (push-sort event result)) (incf i)) - (cons (list 0 0 (list 'SCORE-BEGIN-END - (cadr (event-expression (car score))) - end)) + (cons (list 0 0 (list 'SCORE-BEGIN-END begin end)) (reverse result)))) @@ -1757,6 +2104,7 @@ pattern argument (by default). ;; (defun score-stretch (score factor &key (dur t) (time t) from-index to-index (from-time 0) (to-time FOREVER)) + (if (zerop factor) (print "WARNING: score-stretch called with zero stretch factor.")) (setf score (score-must-have-begin-end score)) (let ((begin-end (event-expression (car score))) (i 1)) @@ -1778,23 +2126,25 @@ pattern argument (by default). (cdr score))))) -;; Get the second element of params (the value field) and turn it -;; into a numeric value if possible (by looking up a global variable -;; binding). This allows scores to say C4 instead of 60. +;; Turn a value field into a numeric value if possible +;; (by looking up a global variable binding). This +;; allows scores to say C4 instead of 60. ;; -(defun get-numeric-value (params) - (let ((v (cadr params))) - (cond ((and (symbolp v) (boundp v) (numberp (symbol-value v))) - (setf v (symbol-value v)))) - v)) +(defun get-numeric-value (v) + (cond ((and v (symbolp v) (boundp v) (numberp (symbol-value v))) + (symbol-value v)) + (t v))) (defun params-transpose (params keyword amount) (cond ((null params) nil) ((eq keyword (car params)) - (let ((v (get-numeric-value params))) + (let ((v (get-numeric-value (cadr params)))) (cond ((numberp v) - (setf v (+ v amount)))) + (setf v (+ v amount))) + ((and (eq keyword :pitch) (listp v)) + (setf v (mapcar #'(lambda (x) (setf x (get-numeric-value x)) + (+ x amount)) v)))) (cons (car params) (cons v (cddr params))))) (t (cons (car params) @@ -1817,7 +2167,7 @@ pattern argument (by default). (defun params-scale (params keyword amount) (cond ((null params) nil) ((eq keyword (car params)) - (let ((v (get-numeric-value params))) + (let ((v (get-numeric-value (cadr params)))) (cond ((numberp v) (setf v (* v amount)))) (cons (car params) @@ -1855,15 +2205,38 @@ pattern argument (by default). (reverse result))) +;; MAP-VOICE - helper function for SCORE-VOICE +;; input: a score expression, e.g. '(note :pitch 60 :vel 100) +;; a replacement list, e.g. '((note foo) (* bar)) +;; output: the score expression with substitutions, e.g. +;; '(foo :pitch 60 :vel 100) +;; (defun map-voice (expression replacement-list) - (let ((mapping (assoc (car expression) replacement-list))) - (cond (mapping (cons (second mapping) - (cdr expression))) - (t expression)))) + (cond (replacement-list + (cond ((or (eq (car expression) (caar replacement-list)) + (eq (caar replacement-list) '*)) + (cons (cadar replacement-list) (cdr expression))) + (t (map-voice expression (cdr replacement-list))))) + (t expression))) + + +(defun ny:assert-replacement-list (fun-name index formal actual) + (let ((lis actual) r) + (while lis + (if (not (consp actual)) + (error (format nil "In ~A,~A argument (~A) should be a list, got ~A" + fun-name (index-to-string index) formal actual))) + (setf r (car lis)) + (if (not (and (listp r) (= 2 (length r)) (symbolp (car r)) (symbolp (cadr r)))) + (error (format nil + "In ~A,~A argument (~A) should be a list of lists of two symbols, got ~A" + fun-name (index-to-string index) formal actual))) + (setf lis (cdr lis)) ))) (defun score-voice (score replacement-list &key from-index to-index from-time to-time) + (ny:assert-replacement-list 'SCORE-VOICE 2 "replacement-list" replacement-list) (setf score (score-must-have-begin-end score)) (let ((i 0) (start (find-first-note score from-index from-time)) @@ -2039,11 +2412,25 @@ pattern argument (by default). (go loop))) -(defun score-print (score) - (format t "(") - (dolist (event score) - (format t "~S~%" event)) - (format t ")~%")) +(defun score-print (score &optional lines) + (let ((len (length score))) ;; len will be how many events left + (format t "(") + (cond (lines + (setf lines (max lines 3))) ;; always allow up to 3 lines + (t ;; no limit on lines, pick a conservatively large number + (setf lines (+ 100 len)))) + (dolist (event score) + (cond ((or (> lines 2) (= 1 len)) + ;; print if we have more than 2 lines left to print or + ;; if we are at the last line (always printed) + (format t "~S~%" event) + (setf lines (1- lines))) + ((and (= lines 2) (> len 2)) ;; need ellipsis + (format t "... skipping ~A events ...~%" (- len lines)) + (setf lines (1- lines))) + (t nil)) ;; print nothing until end if lines is 1 + (setf len (1- len))) + (format t ")~%"))) (defun score-play (score) (play (timed-seq score))) @@ -2207,10 +2594,10 @@ exit (return (score-sort score)))) -(defun score-write (score filename &optional programs) - (score-write-smf score filename programs t)) +(defun score-write (score filename &optional programs absolute) + (score-write-smf score filename programs t absolute)) -(defun score-write-smf (score filename &optional programs as-adagio) +(defun score-write-smf (score filename &optional programs as-adagio absolute) (let ((file (if as-adagio (open filename :direction :output) (open-binary filename :direction :output))) (seq (seq-create)) @@ -2243,8 +2630,12 @@ exit (seq-insert-note seq (round (* time 1000)) 0 (1+ chan) (round pitch) (round (* dur 1000)) (round vel)))))) - (if as-adagio (seq-write seq file) (seq-write-smf seq file)) - (close file))))) + (cond (as-adagio + (seq-write seq file absolute) + (close file)) ;; seq-write does not close file, so do it here + (t + (seq-write-smf seq file))))))) ; seq-write-smf closes file + ;; make a default note function for scores @@ -2252,7 +2643,7 @@ exit (defun note (&key (pitch 60) (vel 100)) ;; load the piano if it is not loaded already (if (not (boundp '*piano-srate*)) - (abs-env (load "pianosyn"))) + (abs-env (load "piano/pianosyn"))) (piano-note-2 pitch vel)) ;;================================================================ @@ -2314,14 +2705,14 @@ exit (return nil)))) result)) -;; functions to support score editing in jNyqIDE +;; functions to support score editing in NyquistIDE (if (not (boundp '*default-score-file*)) (setf *default-score-file* "score.dat")) -;; SCORE-EDIT -- save a score for editing by jNyqIDE +;; SCORE-EDIT -- save a score for editing by NyquistIDE ;; -;; file goes to a data file to be read by jNyqIDE +;; file goes to a data file to be read by NyquistIDE ;; Note that the parameter is a global variable name, not a score, ;; but you do not quote the global variable name, e.g. call ;; (score-edit my-score)