diff options
Diffstat (limited to 'runtime')
40 files changed, 8926 insertions, 0 deletions
diff --git a/runtime/dspprims.lsp b/runtime/dspprims.lsp new file mode 100644 index 0000000..57789e7 --- /dev/null +++ b/runtime/dspprims.lsp @@ -0,0 +1,578 @@ +;; dspprims.lsp -- interface to dsp primitives + +;; ARESON - notch filter +;; +(defun areson (s c b &optional (n 0)) + (multichan-expand #'nyq:areson s c b n)) + +(setf areson-implementations + (vector #'snd-areson #'snd-aresonvc #'snd-aresoncv #'snd-aresonvv)) + +;; NYQ:ARESON - notch filter, single channel +;; +(defun nyq:areson (signal center bandwidth normalize) + (select-implementation-1-2 areson-implementations + signal center bandwidth normalize)) + + +;; hp - highpass filter +;; +(defun hp (s c) + (multichan-expand #'nyq:hp s c)) + +(setf hp-implementations + (vector #'snd-atone #'snd-atonev)) + +;; NYQ:hp - highpass filter, single channel +;; +(defun nyq:hp (s c) + (select-implementation-1-1 hp-implementations s c)) + + +;; comb-delay-from-hz -- compute the delay argument +;; +(defun comb-delay-from-hz (hz caller) + (recip hz)) + +;; comb-feedback-from-decay -- compute the feedback argument +;; +(defun comb-feedback (decay delay) + (s-exp (mult -6.9087 delay (recip decay)))) + +;; COMB - comb filter +;; +;; this is just a feedback-delay with different arguments +;; +(defun comb (snd decay hz) + (multichan-expand #'nyq:comb 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")) + (setf feedback (comb-feedback decay delay)) + (nyq:feedback-delay snd delay feedback))) + +;; ALPASS - all-pass filter +;; +(defun alpass (snd decay hz &optional min-hz) + (multichan-expand #'nyq:alpass 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 feedback (comb-feedback decay delay)) + (nyq:alpass1 snd delay feedback min-hz))) + + +;; CONST -- a constant at control-srate +;; +(defun const (value &optional (dur 1.0)) + (let ((d (get-duration dur))) + (snd-const value *rslt* *CONTROL-SRATE* d))) + + +;; CONVOLVE - slow convolution +;; +(defun convolve (s r) + (multichan-expand #'snd-convolve s r)) + + +;; FEEDBACK-DELAY -- (delay is quantized to sample period) +;; +(defun feedback-delay (snd delay feedback) + (multichan-expand #'nyq:feedback-delay 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")) + + +;; NYQ::DELAYCV -- coerce sample rates and call snd-delaycv +;; +(defun nyq:delaycv (the-snd delay feedback) + (display "delaycv" the-snd delay feedback) + (let ((the-snd-srate (snd-srate the-snd)) + (feedback-srate (snd-srate feedback))) + (cond ((> the-snd-srate feedback-srate) + (setf feedback (snd-up the-snd-srate feedback))) + ((< the-snd-srate feedback-srate) + (format t "Warning: down-sampling feedback in feedback-delay/comb~%") + (setf feedback (snd-down the-snd-srate feedback)))) + (snd-delaycv the-snd delay feedback))) + +(setf feedback-delay-implementations + (vector #'snd-delay #'snd-delay-error #'nyq:delaycv #'snd-delay-error)) + + +;; NYQ:FEEDBACK-DELAY -- single channel delay +;; +(defun nyq:feedback-delay (snd delay feedback) + (select-implementation-1-2 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")) + + +(if (not (fboundp 'snd-alpasscv)) + (defun snd-alpasscv (snd delay feedback min-hz) + (error "snd-alpasscv (ALPASS with variable decay) is not implemented"))) +(if (not (fboundp 'snd-alpassvv)) + (defun snd-alpassvv (snd delay feedback min-hz) + (error "snd-alpassvv (ALPASS with variable decay and feedback) is not implemented"))) + +(defun snd-alpass-4 (snd delay feedback min-hz) + (snd-alpass snd delay feedback)) + + +(defun snd-alpasscv-4 (the-snd delay feedback min-hz) + (display "snd-alpasscv-4" (snd-srate the-snd) (snd-srate feedback)) + (let ((the-snd-srate (snd-srate the-snd)) + (feedback-srate (snd-srate feedback))) + (cond ((> the-snd-srate feedback-srate) + (setf feedback (snd-up the-snd-srate feedback))) + ((< the-snd-srate feedback-srate) + (format t "Warning: down-sampling feedback in alpass~%") + (setf feedback (snd-down the-snd-srate feedback)))) + ;(display "snd-alpasscv-4 after cond" (snd-srate the-snd) (snd-srate feedback)) + (snd-alpasscv the-snd delay feedback))) + + +(defun snd-alpassvv-4 (the-snd delay feedback min-hz) + ;(display "snd-alpassvv-4" (snd-srate the-snd) (snd-srate feedback)) + (let ((the-snd-srate (snd-srate the-snd)) + (delay-srate (snd-srate delay)) + (feedback-srate (snd-srate feedback)) + 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)) + ; 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)) + (* max-delay 0.5)) + (* max-delay 0.5))) + ; now delay is between 0 and max-delay, so we won't crash nyquist when + ; we call snd-alpassvv, which doesn't test for out-of-range data + (cond ((> the-snd-srate feedback-srate) + (setf feedback (snd-up the-snd-srate feedback))) + ((< the-snd-srate feedback-srate) + (format t "Warning: down-sampling feedback in alpass~%") + (setf feedback (snd-down the-snd-srate feedback)))) + (cond ((> the-snd-srate delay-srate) + (setf delay (snd-up the-snd-srate delay))) + ((< the-snd-srate delay-srate) + (format t "Warning: down-sampling delay in alpass~%") + (setf delay (snd-down the-snd-srate delay)))) + (display "snd-alpassvv-4 after cond" (snd-srate the-snd) (snd-srate feedback)) + (snd-alpassvv the-snd delay feedback max-delay))) + +(setf alpass-implementations + (vector #'snd-alpass-4 #'snd-alpass-error + #'snd-alpasscv-4 #'snd-alpassvv-4)) + + + +;; NYQ:ALPASS1 -- single channel alpass +;; +(defun nyq:alpass1 (snd delay feedback min-hz) + (select-implementation-1-2 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)) + + +;; S-EXP -- exponentiate a sound +;; +(defun s-exp (s) (multichan-expand #'nyq:exp s)) + + +;; NYQ:EXP -- exponentiate number or sound +;; +(defun nyq:exp (s) (if (soundp s) (snd-exp s) (exp s))) + +;; S-ABS -- absolute value of a sound +;; +(defun s-abs (s) (multichan-expand #'nyq:abs s)) + +;; NYQ:ABS -- absolute value of number or sound +;; +(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)) + +;; NYQ:SQRT -- square root of a number or sound +;; +(defun nyq:sqrt (s) (if (soundp s) (snd-sqrt s) (sqrt s))) + + +;; INTEGRATE -- integration +;; +(defun integrate (s) (multichan-expand #'snd-integrate s)) + + +;; S-LOG -- natural log of a sound +;; +(defun s-log (s) (multichan-expand #'nyq:log s)) + + +;; NYQ:LOG -- log of a number or sound +;; +(defun nyq:log (s) (if (soundp s) (snd-log s) (log s))) + + +;; NOISE -- white noise +;; +(defun noise (&optional (dur 1.0)) + (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)) + (let ((rms (lp (mult snd snd) (/ *control-srate* 10.0)))) + (setf threshold (* threshold threshold)) + (mult snd (gate rms floor risetime falltime lookahead threshold)))) + + +;; QUANTIZE -- quantize a sound +;; +(defun quantize (s f) (multichan-expand #'snd-quantize s f)) + + +;; RECIP -- reciprocal of a sound +;; +(defun recip (s) (multichan-expand #'nyq:recip s)) + + +;; NYQ:RECIP -- reciprocal of a number or sound +;; +(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"))) + (setf step-size (round (/ (snd-srate s) rate))) + (cond ((null window-size) + (setf window-size step-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))))) + + +;; RESON - bandpass filter +;; +(defun reson (s c b &optional (n 0)) + (multichan-expand #'nyq:reson s c b n)) + +(setf reson-implementations + (vector #'snd-reson #'snd-resonvc #'snd-resoncv #'snd-resonvv)) + +;; NYQ:RESON - bandpass filter, single channel +;; +(defun nyq:reson (signal center bandwidth normalize) + (select-implementation-1-2 reson-implementations + signal center bandwidth normalize)) + + +;; SHAPE -- waveshaper +;; +(defun shape (snd shape origin) + (multichan-expand #'snd-shape snd shape origin)) + + +;; SLOPE -- calculate the first derivative of a signal +;; +(defun slope (s) (multichan-expand #'nyq:slope s)) + + +;; NYQ:SLOPE -- first derivative of single channel +;; +(defun nyq:slope (s) + (let* ((sr (snd-srate s)) + (sr-inverse (/ sr))) + (snd-xform (snd-slope s) sr 0 sr-inverse MAX-STOP-TIME 1.0))) + + +;; lp - lowpass filter +;; +(defun lp (s c) + (multichan-expand #'nyq:lp s c)) + +(setf lp-implementations + (vector #'snd-tone #'snd-tonev)) + +;; NYQ:lp - lowpass filter, single channel +;; +(defun nyq:lp (s c) + (select-implementation-1-1 lp-implementations s c)) + + + +;;; fixed-parameter filters based on snd-biquad +;;; note: snd-biquad is implemented in biquadfilt.[ch], +;;; while BiQuad.{cpp,h} is part of STK + +(setf Pi 3.14159265358979) + +(defun square (x) (* x x)) +(defun sinh (x) (* 0.5 (- (exp x) (exp (- x))))) + + +; remember that snd-biquad uses the opposite sign convention for a_i's +; than Matlab does. + +; convenient biquad: normalize a0, and use zero initial conditions. +(defun nyq:biquad (x b0 b1 b2 a0 a1 a2) + (let ((a0r (/ 1.0 a0))) + (snd-biquad x (* a0r b0) (* a0r b1) (* a0r b2) + (* a0r a1) (* a0r a2) 0 0))) + + +(defun biquad (x b0 b1 b2 a0 a1 a2) + (multichan-expand #'nyq:biquad 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)) + +(defun nyq:biquad-m (x b0 b1 b2 a0 a1 a2) + (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)) + +;; NYQ:LOWPASS2 -- operates on single channel +(defun nyq:lowpass2 (x hz q) + (let* ((w (* 2.0 Pi (/ hz (snd-srate x)))) + (cw (cos w)) + (sw (sin w)) + (alpha (* sw (sinh (/ 0.5 q)))) + (a0 (+ 1.0 alpha)) + (a1 (* -2.0 cw)) + (a2 (- 1.0 alpha)) + (b1 (- 1.0 cw)) + (b0 (* 0.5 b1)) + (b2 b0)) + (nyq:biquad-m x b0 b1 b2 a0 a1 a2))) + +; two-pole highpass +(defun highpass2 (x hz &optional (q 0.7071)) + (multichan-expand #'nyq:highpass2 x hz q)) + +(defun nyq:highpass2 (x hz q) + (let* ((w (* 2.0 Pi (/ hz (snd-srate x)))) + (cw (cos w)) + (sw (sin w)) + (alpha (* sw (sinh (/ 0.5 q)))) + (a0 (+ 1.0 alpha)) + (a1 (* -2.0 cw)) + (a2 (- 1.0 alpha)) + (b1 (- -1.0 cw)) + (b0 (* -0.5 b1)) + (b2 b0)) + (nyq:biquad-m x b0 b1 b2 a0 a1 a2))) + +; two-pole bandpass. max gain is unity. +(defun bandpass2 (x hz q) + (multichan-expand #'nyq:bandpass2 x hz q)) + +(defun nyq:bandpass2 (x hz q) + (let* ((w (* 2.0 Pi (/ hz (snd-srate x)))) + (cw (cos w)) + (sw (sin w)) + (alpha (* sw (sinh (/ 0.5 q)))) + (a0 (+ 1.0 alpha)) + (a1 (* -2.0 cw)) + (a2 (- 1.0 alpha)) + (b0 alpha) + (b1 0.0) + (b2 (- alpha))) + (nyq:biquad-m x b0 b1 b2 a0 a1 a2))) + +; two-pole notch. +(defun notch2 (x hz q) + (multichan-expand #'nyq:notch2 x hz q)) + +(defun nyq:notch2 (x hz q) + (let* ((w (* 2.0 Pi (/ hz (snd-srate x)))) + (cw (cos w)) + (sw (sin w)) + (alpha (* sw (sinh (/ 0.5 q)))) + (a0 (+ 1.0 alpha)) + (a1 (* -2.0 cw)) + (a2 (- 1.0 alpha)) + (b0 1.0) + (b1 (* -2.0 cw)) + (b2 1.0)) + (nyq:biquad-m x b0 b1 b2 a0 a1 a2))) + + +; two-pole allpass. +(defun allpass2 (x hz q) + (multichan-expand #'nyq:allpass 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)))) + (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))) + + +; 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)) + +(defun nyq:eq-lowshelf (x hz gain slope) + (let* ((w (* 2.0 Pi (/ hz (snd-srate x)))) + (sw (sin w)) + (cw (cos w)) + (A (expt 10.0 (/ gain (* 2.0 20.0)))) + (b (sqrt (- (/ (+ 1.0 (square A)) slope) (square (- A 1.0))))) + (apc (* cw (+ A 1.0))) + (amc (* cw (- A 1.0))) + (bs (* b sw)) + + (b0 (* A (+ A 1.0 (- amc) bs ))) + (b1 (* 2.0 A (+ A -1.0 (- apc) ))) + (b2 (* A (+ A 1.0 (- amc) (- bs) ))) + (a0 (+ A 1.0 amc bs )) + (a1 (* -2.0 (+ A -1.0 apc ))) + (a2 (+ A 1.0 amc (- bs) ))) + (nyq:biquad-m x b0 b1 b2 a0 a1 a2))) + + +; 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)) + +(defun nyq:eq-highshelf (x hz gain slope) + (let* ((w (* 2.0 Pi (/ hz (snd-srate x)))) + (sw (sin w)) + (cw (cos w)) + (A (expt 10.0 (/ gain (* 2.0 20.0)))) + (b (sqrt (- (/ (+ 1.0 (square A)) slope) (square (- A 1.0))))) + (apc (* cw (+ A 1.0))) + (amc (* cw (- A 1.0))) + (bs (* b sw)) + + (b0 (* A (+ A 1.0 amc bs ))) + (b1 (* -2.0 A (+ A -1.0 apc ))) + (b2 (* A (+ A 1.0 amc (- bs) ))) + (a0 (+ A 1.0 (- amc) bs )) + (a1 (* 2.0 (+ A -1.0 (- apc) ))) + (a2 (+ A 1.0 (- amc) (- bs) ))) + (nyq:biquad-m x b0 b1 b2 a0 a1 a2))) + +(defun nyq:eq-band (x hz gain width) + (cond ((and (numberp hz) (numberp gain) (numberp width)) + (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")))) + +; 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)) + + +(defun eq-band-ccc (x hz gain width) + (let* ((w (* 2.0 Pi (/ hz (snd-srate x)))) + (sw (sin w)) + (cw (cos w)) + (J (sqrt (expt 10.0 (/ gain 20.0)))) + ;(dummy (display "eq-band-ccc" gain J)) + (g (* sw (sinh (* 0.5 (log 2.0) width (/ w sw))))) + ;(dummy2 (display "eq-band-ccc" width w sw g)) + (b0 (+ 1.0 (* g J))) + (b1 (* -2.0 cw)) + (b2 (- 1.0 (* g J))) + (a0 (+ 1.0 (/ g J))) + (a1 (- b1)) + (a2 (- (/ g J) 1.0))) + (biquad x b0 b1 b2 a0 a1 a2))) + +; see failed attempt in eub-reject.lsp to do these with higher-order fns: + +; four-pole Butterworth lowpass +(defun lowpass4 (x hz) + (lowpass2 (lowpass2 x hz 0.60492333) hz 1.33722126)) + +; six-pole Butterworth lowpass +(defun lowpass6 (x hz) + (lowpass2 (lowpass2 (lowpass2 x hz 0.58338080) + hz 0.75932572) + hz 1.95302407)) + +; 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)) + +; four-pole Butterworth highpass +(defun highpass4 (x hz) + (highpass2 (highpass2 x hz 0.60492333) hz 1.33722126)) + +; six-pole Butterworth highpass +(defun highpass6 (x hz) + (highpass2 (highpass2 (highpass2 x hz 0.58338080) + hz 0.75932572) + hz 1.95302407)) + +; 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)) + +; YIN +; maybe this should handle multiple channels, etc. +(setfn yin snd-yin) + + +; FOLLOW +(defun follow (sound floor risetime falltime 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))) diff --git a/runtime/envelopes.lsp b/runtime/envelopes.lsp new file mode 100644 index 0000000..6797997 --- /dev/null +++ b/runtime/envelopes.lsp @@ -0,0 +1,163 @@ +;; envelopes.lsp -- support functions for envelope editor in jNyqIDE + +#| In Nyquist, editable envelopes are saved as one entry in the workspace +named *envelopes*. The entry is an association list where each element +looks like this: + +(name type parameters... ) + +where name is a symbol, e.g. MY-ENVELOPE-1, + type is a function name, e.g. PWL, PWLV, PWE, etc., and + parameters are breakpoint data, e.g. 0.1 1 0.2 0.5 1 + +Example of two envelopes named FOO and BAR: + +((FOO PWL 0.1 1 1) (BAR PWE 0.2 1 1)) + +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 +should call (GET-ENV-DATA), which will dump formatted data to Nyquist's +standard output as follows: + +get-env-data: begin +name (type parameters...) newline +name (type parameters...) newline +... +get-env-data: end + +When the IDE wants to save a definition, it should call +(DEFINE-ENV 'NAME 'EXPRESSION) + +To delete a definition, call: +(DELETE-ENV 'NAME) + +Envelope data will be loaded when the editor window is opened and saved +whenever the user issues a "save" command. If the user switches envelopes +without saving, there is a prompt to save or ignore. + +The user will also be prompted to save when the editor window is closed +or when Nyquist is exited. + +Saving the workspace automatically is something that Nyquist should do +(or prompt the user to do) when it exits. + +|# + +;; WORKSPACE -- the workspace is just a set of variables, typically +;; with scores as values. These are stored in the file workspace.lsp +;; so that you can work on some data and then store it for use later. + +(cond ((not (boundp '*workspace*)) + (setf *workspace* nil))) +(cond ((not (boundp '*workspace-actions*)) + (setf *workspace-actions* nil))) +;; one of the variables in the workspace is *envelopes* +(cond ((not (boundp '*envelopes*)) + (setf *envelopes* nil))) + +;; DESCRIBE -- add a description to a global variable +;; +(defun describe (symbol &optional description) + (add-to-workspace symbol) + (cond (description + (putprop symbol description 'description)) + (t + (get symbol 'description)))) + +;; ADD-TO-WORKSPACE -- add a global symbol to workspace +;; +(defun add-to-workspace (symbol) + (cond ((not (symbolp symbol)) + (format t "add-to-workspace expects a (quoted) symbol~%")) + ((not (member symbol *workspace*)) + (push symbol *workspace*)))) + + +;; ADD-ACTION-TO-WORKSPACE -- call function when workspace is loaded +;; +(defun add-action-to-workspace (symbol) + (cond ((not (symbolp symbol)) + (format t "add-action-to-workspace expects a (quoted) symbol~%")) + ((not (member symbol *workspace-actions*)) + (push symbol *workspace-actions*)))) + +;; SAVE-WORKSPACE -- write data to file +;; +(defun save-workspace () + (let (val (outf (open "workspace.lsp" :direction :output))) + (dolist (sym *workspace*) + (format outf "(add-to-workspace '~A)~%" sym) + (cond ((get sym 'description) + (format outf "(putprop '~A \"~A\" 'description)~%" + sym (get sym 'description)))) + (format outf "(setf ~A '" sym) + (setf val (symbol-value sym)) + (cond ((listp val) + (format outf "(~%") + (dolist (elem val) + (format outf " ~A~%" elem)) + (format outf " ))~%~%")) + (t + (format outf "~A)~%~%" val)))) + (dolist (sym *workspace-actions*) ;; call hooks after reading data + (format outf "(add-action-to-workspace '~A)~%" sym) + (format outf "(if (fboundp '~A) (~A))~%" sym sym)) + (format outf "(princ \"workspace loaded\\n\")~%") + (close outf) + (princ "workspace saved\n") + nil)) + + +;; DEFINE-ENV -- save the env data and make corresponding function +;; +(defun define-env (name expression) + (delete-env name) + (push (cons name expression) *envelopes*) + (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") + (add-action-to-workspace 'make-env-functions) + nil) + + +;; DELETE-ENV -- delete an envelope definition from workspace +;; +;; note that this will not undefine the corresponding envelope function +;; +(defun delete-env (name) + (setf *envelopes* + (remove name *envelopes* + :test #'(lambda (key item) (eql key (car item)))))) + + +;; MAKE-ENV-FUNCTION -- convert data to a defined function +;; +(defun make-env-function (name expression) + (setf (symbol-function name) + (eval (list 'lambda '() expression)))) + + +;; MAKE-ENV-FUNCTIONS -- convert data to defined functions +;; +(defun make-env-functions () + (let (name type parameters) + (dolist (env *envelopes*) + (setf name (car env)) + (setf type (cadr env)) + (setf parameters (cddr env)) + (make-env-function name (cons type parameters))))) + + +;; GET-ENV-DATA -- print env data for IDE +;; +(defun get-env-data () + (princ "get-env-data: begin\n") + (dolist (env *envelopes*) + (format t "~A ~A~%" (car env) (cdr env))) + (princ "get-env-data: end\n") + nil) + diff --git a/runtime/equalizer.lsp b/runtime/equalizer.lsp new file mode 100644 index 0000000..12ff487 --- /dev/null +++ b/runtime/equalizer.lsp @@ -0,0 +1,75 @@ +;; equalizer.lsp -- support functions for equalizer editor in jNyqIDE + +#| This is modeled after envelopes.lsp, which details how envelope data is +exchanged between Nyquist and jNyqIDE. + +The jNyqIDE code needs some work to make it look like the envelope +editor (which also needs work, but that's another matter). For consistency, +both should support named envelopes and equalizers. + +However, for now, we have equalizers numbered from 0 to 9. The format for +exchange will be: + +get-eq-data: begin +name parameters newline +name parameters newline +... +get-eq-data: end + +and when the IDE wants to save a definition, it should call +(DEFINE-EQ 'NAME 'PARAMETER-LIST) + +|# + +(cond ((not (boundp '*equalizers*)) + (setf *equalizers* nil))) + +;; DEFINE-EQ -- save the eq data and make corresponding function +;; +(defun define-eq (name expression) + (setf *equalizers* (remove name *equalizers* + :test #'(lambda (key item) (eql key (car item))))) + (push (list name expression) *equalizers*) + (make-eq-function name expression) + ; make sure equalizers are redefined when workspace is loaded + (add-to-workspace '*equalizers*) + (describe '*equalizers* "data for equalizers in jNyqIDE") + (add-action-to-workspace 'make-eq-functions) + nil) + + +;; MAKE-EQ-FUNCTION -- convert data to a defined function +;; +(defun make-eq-function (name parameters) + (cond ((numberp name) + (setf name (intern (format nil "EQ-~A" name))))) + (if (not (boundp '*grapheq-loaded*)) (load "grapheq.lsp")) + (setf (symbol-function name) + (eval `(lambda (s) (nband-range s ',parameters 60 14000))))) + + +;; MAKE-EQ-FUNCTIONS -- convert data to defined functions +;; +(defun make-eq-functions () + (let (name type parameters) + (dolist (eq *equalizers*) + (setf name (car eq)) + (setf parameters (second parameters)) + (make-eq-function name parameters)))) + + +;; GET-EQ-DATA -- print env data for IDE +;; +(defun get-eq-data () + (let (parameters) + (princ "get-eq-data: begin\n") + (dolist (env *equalizers*) + (format t "~A" (car env)) + (setf parameters (second env)) + (dotimes (i (length parameters)) + (format t " ~A" (aref parameters i))) + (format t "~%")) + (princ "get-eq-data: end\n") + nil)) + + diff --git a/runtime/evalenv.lsp b/runtime/evalenv.lsp new file mode 100644 index 0000000..155139f --- /dev/null +++ b/runtime/evalenv.lsp @@ -0,0 +1,36 @@ +;; +;; The EVAL function in the original XLISP evaluated in the current lexical +;; context. This was changed to evaluate in the NIL (global) context to +;; match Common Lisp. But this created a problem: how do you EVAL an +;; expression in the current lexical context? +;; +;; The answer is you can use the evalhook facility. The evalhook function +;; will evaluate an expression using an environment given to it as an +;; argument. But then the problem is "how do you get the current +;; environment?" Well the getenv macro, below obtains the environent by +;; using an *evalhook* form. +;; +;; The following two macros do the job. Insteading of executing (eval <expr>) +;; just execute (eval-env <expr>). If you want, you can dispense with the +;; macros and execute: +;; +;;(evalhook <expr> nil nil (let ((*evalhook* (lambda (x env) env))) +;; (eval nil))) +;; +;; Tom Almy 10/91 +;; + +(defmacro getenv () + '(progv '(*evalhook*) + (list #'(lambda (exp env) env)) + (eval nil))) + +; this didn't work, may be for a later (Almy) version of xlisp? +;(defmacro getenv () +; '(let ((*evalhook* (lambda (x env) env))) +; (eval nil))) ; hook function evaluates by returning + ; environment + +(defmacro eval-env (arg) ; evaluate in current environment + `(evalhook ,arg nil nil (getenv))) + diff --git a/runtime/fileio.lsp b/runtime/fileio.lsp new file mode 100644 index 0000000..82d1aaa --- /dev/null +++ b/runtime/fileio.lsp @@ -0,0 +1,315 @@ +;; fileio.lsp + +;; if *default-sf-dir* undefined, set it to user's tmp directory +;; +(cond ((not (boundp '*default-sf-dir*)) + ;; it would be nice to use get-temp-path, but when running + ;; the Java-based IDE, Nyquist does not get environment + ;; variables to tell TMP or TEMP or USERPROFILE + ;; We want to avoid the current directory because it may + ;; be read-only. Search for some likely paths... + ;; Note that since these paths don't work for Unix or OS X, + ;; they will not be used, so no system-dependent code is + ;; needed + (let ((current (setdir "."))) + (setf *default-sf-dir* + (or (setdir "c:\\tmp\\" nil) + (setdir "c:\\temp\\" nil) + (setdir "d:\\tmp\\" nil) + (setdir "d:\\temp\\" nil) + (setdir "e:\\tmp\\" nil) + (setdir "e:\\temp\\" nil) + (get-temp-path))) + (format t "Set *default-sf-dir* to \"~A\" in fileio.lsp~%" + *default-sf-dir*) + (setdir current)))) + +;; if the steps above fail, then *default-sf-dir* might be "" (especially +;; on windows), and the current directory could be read-only on Vista and +;; Windows 7. Therefore, the Nyquist IDE will subsequently call +;; suggest-default-sf-dir with Java's idea of a valid temp directory. +;; If *default-sf-dir* is the empty string (""), this will set the variable: +(defun suggest-default-sf-dir (path) + (cond ((equal *default-sf-dir* "") (setf *default-sf-dir* path)))) + +;; s-save -- saves a file +(setf NY:ALL 1000000000) ; 1GIG constant for maxlen +(defmacro s-save (expression &optional (maxlen NY:ALL) filename + &key (format '*default-sf-format*) + (mode '*default-sf-mode*) (bits '*default-sf-bits*) + (endian NIL) ; nil, :big, or :little -- specifies file format + (play nil)) + `(let ((ny:fname ,filename) + (ny:maxlen ,maxlen) + (ny:endian ,endian) + (ny:swap 0)) + ; 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))) + +;; MULTICHANNEL-MAX -- find peak over all channels +;; +(defun multichannel-max (snd samples) + (cond ((soundp snd) + (snd-max snd samples)) + ((arrayp snd) ;; assume it is multichannel sound + (let ((peak 0.0) (chans (length snd))) + (dotimes (i chans) + (setf peak (max peak (snd-max (aref snd i) (/ samples chans))))) + peak)) + (t (error "unexpected value in multichannel-max" snd)))) + + +;; AUTONORM -- look ahead to find peak and normalize sound to 80% +;; +(defun autonorm (snd) + (let (peak) + (cond (*autonormflag* + (cond ((and (not (soundp snd)) + (not (eq (type-of snd) 'ARRAY))) + (error "AUTONORM (or PLAY?) got unexpected value" snd)) + ((eq *autonorm-type* 'previous) + (scale *autonorm* snd)) + ((eq *autonorm-type* 'lookahead) + (setf peak (multichannel-max snd *autonorm-max-samples*)) + (setf peak (max 0.001 peak)) + (setf *autonorm* (/ *autonorm-target* peak)) + (scale *autonorm* snd)) + (t + (error "unknown *autonorm-type*")))) + (t snd)))) + + +(defmacro s-save-autonorm (expression &rest arglist) + `(let ((peak (s-save (autonorm ,expression) ,@arglist))) + (autonorm-update peak))) + +;; The "AutoNorm" facility: when you play something, the Nyquist play +;; command will automatically compute what normalization factor you +;; should have used. If you play the same thing again, the normalization +;; factor is automatically applied. +;; +;; Call AUTONORM-OFF to turn off this feature, and AUTONORM-ON to turn +;; it back on. +;; +;; *autonorm-target* is the peak value we're aiming for (it's set below 1 +;; so allow the next signal to get slightly louder without clipping) +;; +(init-global *autonorm-target* 0.9) +;; +;; *autonorm-type* selects the autonorm algorithm to use +;; 'previous means normalize according to the last computed sound +;; 'precompute means precompute *autonorm-max-samples* samples in +;; memory and normalize according to the peak +;; +(init-global *autonorm-type* 'lookahead) +(init-global *autonorm-max-samples* 1000000) ; default is 4MB buffer +;; +(defun autonorm-on () + (setf *autonorm* 1.0) + (setf *autonorm-previous-peak* 1.0) + (setf *autonormflag* t) + (format t "AutoNorm feature is on.~%")) + +(if (not (boundp '*autonormflag*)) (autonorm-on)) + +(defun autonorm-off () + (setf *autonormflag* nil) + (setf *autonorm* 1.0) + (format t "AutoNorm feature is off.~%")) + +;; AUTONORM-UPDATE -- called with true peak to report and prepare +;; +;; after saving/playing a file, we have the true peak. This along +;; with the autonorm state is printed in a summary and the autonorm +;; state is updated for next time. +;; +;; There are currently two types: PREVIOUS and LOOKAHEAD +;; With PREVIOUS: +;; compute the true peak and print the before and after peak +;; along with the scale factor to be used next time +;; With LOOKAHEAD: +;; compute the true peak and print the before and after peak +;; along with the "suggested scale factor" that would achieve +;; the *autonorm-target* +;; +(defun autonorm-update (peak) + (cond ((> peak 1.0) + (format t "*** CLIPPING DETECTED! ***~%"))) + (cond ((and *autonormflag* (> peak 0.0)) + (setf *autonorm-previous-peak* (/ peak *autonorm*)) + (setf *autonorm* (/ *autonorm-target* *autonorm-previous-peak*)) + (format t "AutoNorm: peak was ~A,~%" *autonorm-previous-peak*) + (format t " peak after normalization was ~A,~%" peak) + (format t (if (eq *autonorm-type* 'PREVIOUS) + " new normalization factor is ~A~%" + " suggested normalization factor is ~A~%") + *autonorm*)) + (t + (format t "Peak was ~A,~%" peak) + (format t " suggested normalization factor is ~A~%" + (/ *autonorm-target* peak))) + peak + )) + +;; s-read -- reads a file +(defun s-read (filename &key (time-offset 0) (srate *sound-srate*) + (dur 10000.0) (nchans 1) (format *default-sf-format*) + (mode *default-sf-mode*) (bits *default-sf-bits*) (endian NIL)) + (let ((swap 0)) + (cond ((eq endian :big) + (setf swap (if (bigendianp) 0 1))) + ((eq endian :little) + (setf swap (if (bigendianp) 1 0)))) + (if (minusp dur) (error "s-read :dur is negative" dur)) + (snd-read (soundfilename filename) time-offset + (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*)) + (format t "Format: ~A~%" + (nth format '("none" "AIFF" "IRCAM" "NeXT" "Wave" "PAF" "SVX" + "NIST" "VOC" "W64" "MAT4" "Mat5" "PVF" "XI" "HTK" + "SDS" "AVR" "SD2" "FLAC" "CAF"))) + (cond ((setp (logand flags snd-head-channels)) + (format t "Channels: ~A~%" channels))) + (cond ((setp (logand flags snd-head-mode)) + (format t "Mode: ~A~%" + (nth mode '("ADPCM" "PCM" "uLaw" "aLaw" "Float" "UPCM" + "unknown" "double" "GSM610" "DWVW" "DPCM" + "msadpcm"))))) + (cond ((setp (logand flags snd-head-bits)) + (format t "Bits/Sample: ~A~%" bits))) + (cond ((setp (logand flags snd-head-srate)) + (format t "SampleRate: ~A~%" srate))) + (cond ((setp (logand flags snd-head-dur)) + (format t "Duration: ~A~%" dur))) + )) + +;; SETP -- tests whether a bit is set (non-zero) +; +(defun setp (bits) (not (zerop bits))) + +;; IS-FILE-SEPARATOR -- is this a file path separation character, e.g. "/"? +;; +(defun is-file-separator (c) + (or (eq c *file-separator*) + (and (eq *file-separator* #\\) ;; if this is windows (indicated by "\") + (eq c #\/)))) ;; then "/" is also a file separator + +;; SOUNDFILENAME -- add default directory to name to get filename +;; +(defun soundfilename (filename) + (cond ((= 0 (length filename)) + (break "filename must be at least one character long" filename)) + ((full-name-p filename)) + (t + ; if sf-dir nonempty and does not end with filename separator, + ; append one + (cond ((and (< 0 (length *default-sf-dir*)) + (not (is-file-separator + (char *default-sf-dir* + (1- (length *default-sf-dir*)))))) + (setf *default-sf-dir* (strcat *default-sf-dir* (string *file-separator*))) + (format t "Warning: appending \"~A\" to *default-sf-dir*~%" + *file-separator*))) + (setf filename (strcat *default-sf-dir* (string filename))))) + ;; now we have a file name, but it may be relative to current directory, so + ;; expand it with the current directory + (cond ((relative-path-p filename) + ;; get current working directory and build full name + (let ((path (setdir "."))) + (cond (path + (setf filename (strcat path (string *file-separator*) + (string filename)))))))) + 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)))) + +;; round is tricky because truncate rounds toward zero as does C +;; in other words, rounding is down for positive numbers and up +;; for negative numbers. You can convert rounding up to rounding +;; down by subtracting one, but this fails on the integers, so +;; we need a special test if (- x 0.5) is an integer +(defun round (x) + (cond ((> x 0) (truncate (+ x 0.5))) + ((= (- x 0.5) (truncate (- x 0.5))) (truncate x)) + (t (truncate (- x 0.5))))) + +;; change defaults for PLAY macro: +(init-global *soundenable* t) +(defun sound-on () (setf *soundenable* t)) +(defun sound-off () (setf *soundenable* nil)) + +(defun coterm (snd1 snd2) + (multichan-expand #'snd-coterm snd1 snd2)) + +(defmacro s-add-to (expr maxlen filename &optional (time-offset 0.0)) + `(let ((ny:fname (soundfilename ,filename)) + ny:peak ny:input (ny:offset ,time-offset)) + (format t "Adding sound to ~A at offset ~A~%" + ny:fname ,time-offset) + (setf ny:peak (snd-overwrite '(let ((ny:addend ,expr)) + (sum (coterm + (s-read ny:fname + :time-offset ny:offset) + ny:addend) + ny:addend)) + ,maxlen ny:fname ny:offset SND-HEAD-NONE 0 0 0)) + (format t "Duration written: ~A~%" (car *rslt*)) + ny:peak)) + + +(defmacro s-overwrite (expr maxlen filename &optional (time-offset 0.0)) + `(let ((ny:fname (soundfilename ,filename)) + (ny:peak 0.0) + ny:input ny:rslt ny:offset) + (format t "Overwriting ~A at offset ~A~%" ny:fname ny:offset) + (setf ny:offset (s-read-byte-offset ny:rslt)) + (setf ny:peak (snd-overwrite `,expr ,maxlen ny:fname ,time-offset + 0, 0, 0, 0.0, 0)) + (format t "Duration written: ~A~%" (car *rslt*)) + ny:peak)) + + + + diff --git a/runtime/follow.lsp b/runtime/follow.lsp new file mode 100644 index 0000000..7332fa7 --- /dev/null +++ b/runtime/follow.lsp @@ -0,0 +1,70 @@ +;(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/runtime/init.lsp b/runtime/init.lsp new file mode 100644 index 0000000..e2b905c --- /dev/null +++ b/runtime/init.lsp @@ -0,0 +1,8 @@ +; init.lsp -- default Nyquist startup file +(load "nyinit.lsp" :verbose nil) + +; add your customizations here: +; e.g. (setf *default-sf-dir* "...") + +; (load "test.lsp") + diff --git a/runtime/misc.lsp b/runtime/misc.lsp new file mode 100644 index 0000000..882adfa --- /dev/null +++ b/runtime/misc.lsp @@ -0,0 +1,191 @@ +;## misc.lsp -- a collection of useful support functions + +;; Garbage collection "improvement" -- XLISP will GC without allocation +;; as long as it does not run out of cells. This can make it very slow +;; since GC does work proportional to the heap size. If there were +;; always at least, say, 1/3 of the heap free after GC, then allocating +;; cells would be more-or-less a constant time operation (amortized). +;; +;; So, after GC, we'll expand until we have 1/3 of the heap free. +;; +(defun ny:gc-hook (heap-size free-cells) + (cond ((< (* free-cells 2) heap-size) ;; free cells is < 1/3 heap + ;; expand. Each expansion unit is 2000 cons cells + (let* ((how-many-not-free (- heap-size free-cells)) + (should-be-free (/ how-many-not-free 2)) + (how-many-more (- should-be-free free-cells)) + (expand-amount (/ how-many-more 2000))) + (cond ((> expand-amount 0) + (if *gc-flag* + (format t + "[ny:gc-hook allocating ~A more cells] " + (* expand-amount 2000))) + (expand expand-amount))))))) + +(setf *gc-hook* 'ny:gc-hook) + + +; set global if not already set +; +(defmacro init-global (symb expr) + `(if (boundp ',symb) ,symb (setf ,symb ,expr))) + +; controlling breaks and tracebacks: +; XLISP and SAL behave differently, so there are four(!) flags: +; *sal-traceback* -- print SAL traceback on error in SAL mode +; Typically you want this on always. +; *sal-break* -- allow break (to XLISP prompt) on error when in SAL mode +; (overrides *sal-traceback*) Typically, you do not want +; this unless you need to see exactly where an error happened +; or the bug is in XLISP source code called from SAL. +; *xlisp-break* -- allow break on error when in XLISP mode +; 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. + +(setf *sal-mode* nil) + +(setf *sal-traceback* t + *sal-break* nil + *xlisp-break* t + *xlisp-traceback* nil) + +(defun sal-tracenable (flag) (setf *sal-traceback* flag)) +(defun sal-breakenable (flag) + (setf *sal-break* flag) + (if *sal-mode* (setf *breakenable* flag))) +(defun xlisp-breakenable (flag) + (setf *xlisp-break* flag) + (if (not *sal-mode*) (setf *breakenable* flag))) +(defun xlisp-tracenable (flag) + (setf *xlisp-traceback* flag) + (if flag (setf *xlisp-break* t)) + (cond ((not *sal-mode*) + (if flag (setf *breakenable* t)) + (setf *tracenable* flag)))) + + +; enable or disable breaks +(defun bkon () (xlisp-breakenable t)) +(defun bkoff () (xlisp-breakenable nil)) + + +;; (grindef 'name) - pretty print a function +;; +(defun grindef (e) (pprint (get-lambda-expression (symbol-function e)))) + +;; (args 'name) - print function and its formal arguments +;; +(defun args (e) + (pprint (cons e (second (get-lambda-expression (symbol-function e)))))) + +;; (incf <place>), (decf <place>) - add/sub 1 to/from variable +;; +(defmacro incf (symbol) `(setf ,symbol (1+ ,symbol))) +(defmacro decf (symbol) `(setf ,symbol (1- ,symbol))) + + +;; (push val <place>) - cons val to list +;; +(defmacro push (val lis) `(setf ,lis (cons ,val ,lis))) +(defmacro pop (lis) `(prog1 (car ,lis) (setf ,lis (cdr ,lis)))) + +;; include this to use RBD's XLISP profiling hooks +;;(load "/afs/andrew/usr/rbd/lib/xlisp/profile.lsp") + +;(cond ((boundp 'application-file-name) +; (load application-file-name))) + + +(defun get-input-file-name () + (let (fname) + (format t "Input file name: ") + (setf fname (read-line)) + (cond ((equal fname "") (get-input-file-name)) + (t fname)))) + + +(defun open-output-file () + (let (fname) + (format t "Output file name: ") + (setf fname (read-line)) + (cond ((equal fname "") t) + (t (open fname :direction :output))))) + + +(defmacro while (cond &rest stmts) + `(prog () loop (if ,cond () (return)) ,@stmts (go loop))) + + +; when parens/quotes don't match, try this +; +(defun file-sexprs () + (let ((fin (open (get-input-file-name))) + inp) + (while (setf inp (read fin)) (print inp)))) + +;; get path for currently loading file (if any) +;; +(defun current-path () + (let (fullpath n) + (setf n -1) + (cond (*loadingfiles* + (setf fullpath (car *loadingfiles*)) + (dotimes (i (length fullpath)) + (cond ((equal (char fullpath i) *file-separator*) + (setf n i)))) + (setf fullpath (subseq fullpath 0 (1+ n))) + +;; REMOVED SUPPORT FOR MAC OS-9 AND BELOW -RBD + ;; if this is a Mac, use ':' in place of empty path +;; (cond ((and (equal fullpath "") +;; (equal *file-separator* #\:)) +;; (setf fullpath ":"))) +;; END MAC OS-9 CODE + + ;; Here's an interesting problem: fullpath is now the path + ;; specified to LOAD, but it may be relative to the current + ;; directory. What if we want to load a sound file from the + ;; current directory? It seems that S-READ gives priority to + ;; the *DEFAULT-SF-DIR*, so it will follow fullpath STARTING + ;; FROM *DEFAULT-SF-DIR*. To fix this, we need to make sure + ;; that fullpath is either an absolute path or starts with + ;; and explicit ./ which tells s-read to look in the current + ;; directory. + (cond ((> (length fullpath) 0) + (cond ((full-name-p fullpath)) + (t ; not absolute, make it explicitly relative + (setf fullpath (strcat "./" fullpath))))) + (t (setf fullpath "./"))) ; use current directory + fullpath) + (t nil)))) + +;; real-random -- pick a random real from a range +;; +(defun real-random (from to) + (+ (* (rrandom) (- to from)) from)) + +;; power -- raise a number to some power x^y +;; +(defun power (x y) + (exp (* (log (float x)) y))) + +;; require-from -- load a file if a function is undefined +;; +;; fn-symbol -- the function defined when the file is loaded +;; file-name -- the name of file to load if fn-symbol is undefined +;; path -- if t, load from current-path; if a string, prepend string +;; to file-name; if nil, ignore it +;; +(defmacro require-from (fn-symbol file-name &optional path) + (cond ((eq path t) + (setf file-name `(strcat (current-path) ,file-name))) + (path + (setf file-name `(strcat ,path ,file-name)))) + ; (display "require-from" file-name) + `(if (fboundp (quote ,fn-symbol)) + t + ;; search for either .lsp or .sal file + (sal-load ,file-name))) + diff --git a/runtime/nyinit.lsp b/runtime/nyinit.lsp new file mode 100644 index 0000000..b3d8237 --- /dev/null +++ b/runtime/nyinit.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 "dspprims.lsp" :verbose NIL) +(load "nyquist.lsp" :verbose NIL) +(load "follow.lsp" :verbose NIL) + +(load "system.lsp" :verbose NIL) + +(load "seqmidi.lsp" :verbose NIL) +(load "nyqmisc.lsp" :verbose NIL) +(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-2011 by Roger B. Dannenberg~%") +(format t " Version 3.05~%~%") + +;(setf *gc-flag* t) + + diff --git a/runtime/nyqmisc.lsp b/runtime/nyqmisc.lsp new file mode 100644 index 0000000..3905d33 --- /dev/null +++ b/runtime/nyqmisc.lsp @@ -0,0 +1,27 @@ +;; nyqmisc.lsp -- misc functions for nyquist + +(init-global *snd-display-max-samples* 10000) +(init-global *snd-display-print-samples* 100) + + +; (snd-display sound) -- describe a sound +(defun snd-display (sound) + (let (t0 srate len extent dur samples) + (setf srate (snd-srate sound)) + (setf t0 (snd-t0 sound)) + (setf len (snd-length sound *snd-display-max-samples*)) + (cond ((= len *snd-display-max-samples*) + (setf extent (format nil ">~A" (+ t0 (* srate *snd-display-max-samples*)))) + (setf dur (format nil ">~A" (* srate *snd-display-max-samples*)))) + (t + (setf extent (cadr (snd-extent sound *snd-display-max-samples*))) + (setf dur (/ (snd-length sound *snd-display-max-samples*) srate)))) + (cond ((> len 100) + (setf samples (format nil "1st ~A samples" *snd-display-print-samples*)) + (setf nsamples *snd-display-print-samples*)) + (t + (setf samples (format nil "~A samples" len)) + (setf nsamples len))) + (format t "~A: srate ~A, t0 ~A, extent ~A, dur ~A, ~A: ~A" + sound srate t0 extent dur samples (snd-samples sound nsamples)))) + diff --git a/runtime/nyquist-plot.txt b/runtime/nyquist-plot.txt new file mode 100644 index 0000000..003e6e0 --- /dev/null +++ b/runtime/nyquist-plot.txt @@ -0,0 +1,3 @@ +set nokey +plot "points.dat" with lines + diff --git a/runtime/nyquist.lsp b/runtime/nyquist.lsp new file mode 100644 index 0000000..1e00d4e --- /dev/null +++ b/runtime/nyquist.lsp @@ -0,0 +1,1725 @@ +;;; +;;; ########################################################### +;;; ### NYQUIST-- A Language for Composition and Synthesis. ### +;;; ### ### +;;; ### Copyright (c) 1994-2006 by Roger B. Dannenberg ### +;;; ########################################################### +;;; +(load "fileio.lsp" :verbose NIL) + +(prog () + (setq lppp -12.0) (setq lpp -9.0) (setq lp -6.0) (setq lmp -3.0) + (setq lfff 12.0) (setq lff 9.0) (setq lf 6.0) (setq lmf 3.0) + (setq dB0 1.00) (setq dB1 1.122) (setq dB10 3.1623) + + (setq s 0.25) (setq sd 0.375) (setq st (/ 0.5 3.0)) + (setq i 0.5) (setq id 0.75) (setq it (* st 2.0)) + (setq q 1.0) (setq qd 1.5) (setq qt (* st 4.0)) + (setq h 2.0) (setq hd 3.0) (setq ht (* st 8.0)) + (setq w 4.0) (setq wd 6.0) (setq wt (* st 16.0)) +) + +(init-global *A4-Hertz* 440.0) + +; next pitch, for initializations below +; +(defun np () (incf nyq:next-pitch)) + +(defun set-pitch-names () + (setq no-pitch 116.0) + ; note: 58.0 is A4 - (C0 - 1) = 69 - (12 - 1) + (setf nyq:next-pitch (- (hz-to-step *A4-Hertz*) 58.0)) + + (setf nyq:pitch-names + '(c0 (cs0 df0) d0 (ds0 ef0) e0 f0 (fs0 gf0) g0 (gs0 af0) a0 + (as0 bf0) b0 + c1 (cs1 df1) d1 (ds1 ef1) e1 f1 (fs1 gf1) g1 (gs1 af1) a1 + (as1 bf1) b1 + c2 (cs2 df2) d2 (ds2 ef2) e2 f2 (fs2 gf2) g2 (gs2 af2) a2 + (as2 bf2) b2 + c3 (cs3 df3) d3 (ds3 ef3) e3 f3 (fs3 gf3) g3 (gs3 af3) a3 + (as3 bf3) b3 + c4 (cs4 df4) d4 (ds4 ef4) e4 f4 (fs4 gf4) g4 (gs4 af4) a4 + (as4 bf4) b4 + c5 (cs5 df5) d5 (ds5 ef5) e5 f5 (fs5 gf5) g5 (gs5 af5) a5 + (as5 bf5) b5 + 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)) + + (dolist (p nyq:pitch-names) + (cond ((atom p) (set p (np))) + (t (let ((pitch (np))) + (dolist (s p) (set s pitch))))))) + + +(set-pitch-names) + +(init-global *default-sound-srate* 44100.0) +(init-global *default-control-srate* 2205.0) + +(setf *environment-variables* + '(*WARP* *SUSTAIN* *START* *LOUD* *TRANSPOSE* + *STOP* *CONTROL-SRATE* *SOUND-SRATE*)) + +(setfn environment-time car) +(setfn environment-stretch cadr) + +; ENVIRONMENT-MAP - map virtual time using an environment +; +;(defun environment-map (env tim) +; (+ (environment-time env) +; (* (environment-stretch env) tim))) + + +(defun nyq:the-environment () (mapcar 'eval *environment-variables*)) + + +;; 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 *SOUND-SRATE* *DEFAULT-SOUND-SRATE*) + t) ; return nothing in particular + +(nyq:environment-init) + +(defun get-duration (dur) + (let ((duration + (- (local-to-global (* (get-sustain) dur)) + (setf *rslt* (local-to-global 0))))) + (cond ((minusp duration) + (error +"duration is less than zero: perhaps a warp or stretch +is ill-formed. Nyquist cannot continue because synthesis +functions assume durations are always positive."))) + duration)) + + +(defun get-loud () + (cond ((numberp *loud*) *loud*) + ((soundp *loud*) + (sref *loud* 0)) + (t + (error (format t "*LOUD* should be a number or sound: ~A" *LOUD*))))) + + +(defun get-sustain () + (cond ((numberp *SUSTAIN*) *SUSTAIN*) + ((soundp *SUSTAIN*) + ;(display "get-sustain: lookup " (local-to-global 0) 0)) + (sref *SUSTAIN* 0)) + (t + (error (format t "*SUSTAIN* should be a number or sound: ~A" *SUSTAIN*))))) + + +(defun get-tempo () + (slope (snd-inverse (get-warp) (local-to-global 0) + *control-srate*))) + +(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*))))) + + +(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*))))))) + + +;;;;;;;;;;;;;;;;;;;;;; +;; OSCILATORS +;;;;;;;;;;;;;;;;;;;;;; + +(defun build-harmonic (n table-size) (snd-sine 0 n table-size 1)) + +(setf *SINE-TABLE* (list (build-harmonic 1 2048) + (hz-to-step 1.0) + T)) +(setf *TABLE* *SINE-TABLE*) + + +;; AMOSC +;; +(defun amosc (pitch modulation &optional (sound *table*) (phase 0.0)) + (let ((modulation-srate (snd-srate modulation)) + (hz (step-to-hz (+ pitch (get-transpose))))) + (cond ((> *SOUND-SRATE* modulation-srate) + (setf modulation (snd-up *SOUND-SRATE* modulation))) + ((< *SOUND-SRATE* modulation-srate) + (format t "Warning: down-sampling AM modulation in amosc~%") + (setf modulation (snd-down *SOUND-SRATE* modulation)))) + (cond ((> hz (/ *SOUND-SRATE* 2)) + (format t "Warning: amosc frequency (~A hz) will alias at current sample rate (~A hz).\n" + hz *SOUND-SRATE*))) + (scale-db (get-loud) + (snd-amosc + (car sound) ; samples for table + (cadr sound) ; step represented by table + *SOUND-SRATE* ; output sample rate + hz ; output hz + (local-to-global 0) ; starting time + modulation ; modulation + phase)))) ; phase + + +;; FMOSC +;; +;; modulation rate must be less than or equal to sound-srate, so +;; force resampling and issue a warning if necessary. snd-fmosc can +;; handle upsampling cases internally. +;; +(defun fmosc (pitch modulation &optional (sound *table*) (phase 0.0)) + (let ((modulation-srate (snd-srate modulation)) + (hz (step-to-hz (+ pitch (get-transpose))))) + (cond ((< *SOUND-SRATE* modulation-srate) + (format t "Warning: down-sampling FM modulation in fmosc~%") + (setf modulation (snd-down *SOUND-SRATE* modulation)))) + (cond ((> hz (/ *SOUND-SRATE* 2)) + (format t "Warning: fmosc nominal frequency (~A hz) will alias at current sample rate (~A hz).\n" + hz *SOUND-SRATE*))) + (scale-db (get-loud) + (snd-fmosc + (car sound) ; samples for table + (cadr sound) ; step represented by table + *SOUND-SRATE* ; output sample rate + hz ; output hz + (local-to-global 0) ; starting time + modulation ; modulation + phase)))) ; phase + + +;; FMFB +;; +;; this code is based on FMOSC above +;; +(defun fmfb (pitch index &optional dur) + (let ((hz (step-to-hz (+ pitch (get-transpose))))) + (cond ((> hz (/ *SOUND-SRATE* 2)) + (format "Warning: fmfb nominal frequency (~A hz) will alias at current sample rate (~A hz).~%" + hz *SOUND-SRATE*))) + (setf dur (get-duration dur)) + (cond ((soundp index) (ny:fmfbv hz index)) + (t + (scale-db (get-loud) + (snd-fmfb (local-to-global 0) + hz *SOUND-SRATE* index dur)))))) + +;; private variable index version of fmfb +(defun ny:fmfbv (hz index) + (let ((modulation-srate (snd-srate index))) + (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) + (snd-fmfbv (local-to-global 0) hz *SOUND-SRATE* index)))) + + +;; BUZZ +;; +;; (ARGUMENTS ("long" "n") ("rate_type" "sr") ("double" "hz") +;; ("time_type" "t0") ("sound_type" "s_fm")) +;; +(defun buzz (n pitch modulation) + (let ((modulation-srate (snd-srate modulation)) + (hz (step-to-hz (+ pitch (get-transpose))))) + (cond ((< *SOUND-SRATE* modulation-srate) + (format t "Warning: down-sampling modulation in buzz~%") + (setf modulation (snd-down *SOUND-SRATE* modulation)))) + (cond ((> hz (/ *SOUND-SRATE* 2)) + (format t "Warning: buzz nominal frequency (~A hz) will alias at current sample rate (~A hz).\n" + hz *SOUND-SRATE*))) + (setf n (max n 1)) ; avoid divide by zero problem + (scale-db (get-loud) + (snd-buzz n ; number of harmonics + *SOUND-SRATE* ; output sample rate + hz ; output hz + (local-to-global 0) ; starting time + modulation)))) ; freq. modulation + + +;; (HZOSC hz [table [phase]]) +;; +;; similar to FMOSC, but without "carrier" frequency parameter +;; also, hz may be a scalar or a sound +;; +(defun hzosc (hz &optional (sound *table*) (phase 0.0)) + (let (hz-srate) + (cond ((numberp hz) + (osc (hz-to-step hz) 1.0 sound phase)) + (t + (setf hz-srate (snd-srate hz)) + (cond ((< *SOUND-SRATE* hz-srate) + (format t "Warning: down-sampling hz in hzosc~%") + (setf hz (snd-down *SOUND-SRATE* hz)))) + (scale-db (get-loud) + (snd-fmosc (car sound) ; samples for table + (cadr sound) ; step repr. by table + *SOUND-SRATE* ; output sample rate + 0.0 ; dummy carrier + (local-to-global 0) ; starting time + hz phase)))))) + + +;; (SIOSC-BREAKPOINTS tab0 t1 tab1 ... tn tabn) +;; converts times to sample numbers +;; NOTE: time-warping the spectral envelope seems +;; like the wrong thing to do (wouldn't it be better +;; to warp the parameters that control the spectra, +;; or don't warp at all?). Nominally, a note should +;; have a "score" or local time duration equal to the +;; SUSTAIN environment variable. (When sustain is 1.0 +;; and no time-warping is in effect, the duration is 1). +;; So, scale all times by +;; (local-to-global (get-sustain)) +;; so that if the final time tn = 1.0, we get a nominal +;; length note. + +(defun siosc-breakpoints (breakpoints) + (display "siosc-breakpoints" breakpoints) + (prog (sample-count result (last-count 0) time-factor) + (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"))) +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"))) + (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 +;; force resampling and issue a warning if necessary. snd-fmosc can +;; handle upsampling cases internally. +;; +(defun siosc (pitch modulation breakpoints) + (let ((modulation-srate (snd-srate modulation)) + (hz (step-to-hz (+ pitch (get-transpose))))) + (cond ((< *SOUND-SRATE* modulation-srate) + (format t "Warning: down-sampling FM modulation in siosc~%") + (setf modulation (snd-down *SOUND-SRATE* modulation)))) + (cond ((> hz (/ *SOUND-SRATE* 2)) + (format t "Warning: siosc nominal frequency (~A hz) will alias at current sample rate (~A hz).\n" + hz *SOUND-SRATE*))) + (scale-db (get-loud) + (snd-siosc + (siosc-breakpoints breakpoints) ; tables + *SOUND-SRATE* ; output sample rate + hz ; output hz + (local-to-global 0) ; starting time + modulation)))) ; modulation + + +;; LFO -- freq &optional duration sound phase) +;; +;; Default duration is 1.0 sec, default sound is *TABLE*, +;; default phase is 0.0. +;; +(defun lfo (freq &optional (duration 1.0) + (sound *SINE-TABLE*) (phase 0.0)) + (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 + (snd-osc + (car sound) ; samples for table + (cadr sound) ; step represented by table + *CONTROL-SRATE* ; output sample rate + freq ; output hz + *rslt* ; starting time + d ; duration + phase) ; phase + duration))) + + +;; FMLFO -- like LFO but uses frequency modulation +;; +(defun fmlfo (freq &optional (sound *SINE-TABLE*) (phase 0.0)) + (let () + (cond ((numberp freq) + (lfo freq 1.0 sound phase)) + ((soundp freq) + (cond ((> (snd-srate freq) *CONTROL-SRATE*) + (setf freq (force-srate *CONTROL-SRATE* freq)))) + (snd-fmosc (car sound) (cadr sound) *CONTROL-SRATE* 0.0 + (local-to-global 0) freq phase)) + (t + (error "frequency must be a number or sound"))))) + + +;; OSC - table lookup oscillator +;; +(defun osc (pitch &optional (duration 1.0) + (sound *TABLE*) (phase 0.0)) + (let ((d (get-duration duration)) + (hz (step-to-hz (+ pitch (get-transpose))))) + ;(display "osc" *warp* global-start global-stop actual-dur + ; (get-transpose)) + (cond ((> hz (/ *SOUND-SRATE* 2)) + (format t "Warning: osc frequency (~A hz) will alias at current sample rate (~A hz).\n" + hz *SOUND-SRATE*))) + (set-logical-stop + (scale-db (get-loud) + (snd-osc + (car sound) ; samples for table + (cadr sound) ; step represented by table + *SOUND-SRATE* ; output sample rate + hz ; output hz + *rslt* ; starting time + d ; duration + phase)) ; phase + duration))) + + +;; PARTIAL -- sine osc with built-in envelope scaling +;; +(defun partial (steps env) + (let ((hz (step-to-hz (+ steps (get-transpose))))) + (cond ((> hz (/ *sound-srate* 2)) + (format t "Warning: partial frequency (~A hz) will alias at current sample rate (~A hz).\n" + hz *sound-srate*))) + (scale-db (get-loud) + (snd-partial *sound-srate* hz + (force-srate *sound-srate* env))))) + + +;; SAMPLER -- simple attack + sustain sampler +;; +(defun sampler (pitch modulation + &optional (sample *table*) (npoints 2)) + (let ((samp (car sample)) + (samp-pitch (cadr sample)) + (samp-loop-start (caddr sample)) + (hz (step-to-hz (+ pitch (get-transpose))))) + ; make a waveform table look like a sample with no attack: + (cond ((not (numberp samp-loop-start)) + (setf samp-loop-start 0.0))) + (cond ((> hz (/ *SOUND-SRATE* 2)) + (format t "Warning: sampler nominal frequency (~A hz) will alias at current sample rate (~A hz).\n" + hz *SOUND-SRATE*))) + (scale-db (get-loud) + (snd-sampler + samp ; samples for table + samp-pitch ; step represented by table + samp-loop-start ; time to start loop + *SOUND-SRATE* ; output sample rate + hz ; output hz + (local-to-global 0) ; starting time + modulation ; modulation + npoints)))) ; number of interpolation points + + +;; SINE -- simple sine oscillator +;; +(defun sine (steps &optional (duration 1.0)) + (let ((hz (step-to-hz (+ steps (get-transpose)))) + (d (get-duration duration))) + (cond ((> hz (/ *SOUND-SRATE* 2)) + (format t "Warning: sine frequency (~A hz) will alias at current sample rate (~A hz).\n" + hz *SOUND-SRATE*))) + (set-logical-stop + (scale-db (get-loud) + (snd-sine *rslt* hz *sound-srate* d)) + duration))) + + +;; PLUCK +;; +;; (ARGUMENTS ("double" "sr") ("double" "hz") ("time_type" "t0") +;; ("time_type" "d") ("double" "final_amp")) +;; +(defun pluck (steps &optional (duration 1.0) (final-amp 0.001)) + (let ((hz (step-to-hz (+ steps (get-transpose)))) + (d (get-duration duration))) + (cond ((> hz (/ *SOUND-SRATE* 2)) + (format t "Warning: pluck frequency (~A hz) will alias at current sample rate (~A hz).\n" + hz *SOUND-SRATE*))) + (set-logical-stop + (scale-db (get-loud) + (snd-pluck *SOUND-SRATE* hz *rslt* d final-amp)) + duration))) + + +;; abs-env -- restore the standard environment +;; +(defmacro abs-env (s) + `(progv '(*WARP* *LOUD* *TRANSPOSE* *SUSTAIN* + *START* *STOP* + *CONTROL-SRATE* *SOUND-SRATE*) + (list '(0.0 1.0 NIL) 0.0 0.0 1.0 + MIN-START-TIME MAX-STOP-TIME + *DEFAULT-CONTROL-SRATE* *DEFAULT-SOUND-SRATE*) + ,s)) + + +; nyq:add2 - add two 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) + (sum-of-arrays s1 s2)) + (t + (nyq:add-2-sounds s1 s2)))) + + +; (NYQ:ADD-2-SOUNDS S1 S2) - add two sound (or number) arguments +; +(defun nyq:add-2-sounds (s1 s2) + (cond ((numberp s1) + (cond ((numberp s2) + (+ 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))))))) + + +(defmacro at (x s) + `(progv '(*WARP*) (list (list (+ (warp-time *WARP*) + (* (warp-stretch *WARP*) ,x)) + (warp-stretch *WARP*) + (warp-function *WARP*))) + ,s)) + + +;; (AT-ABS t behavior) evaluate behavior at global time t +;; +;; *WARP* is the triple (d s f) denoting the function f(st+d), +;; a mapping from local to global time. +;; We want (d' s f) such that f(s*0 + d') = t +;; (Note that we keep the same s and f, and only change the offset. +;; To eliminate the warp and stretch use "(abs-env (at t behavior))") +;; Applying the inverse of f, d' = f-1(t), or (sref (snd-inverse f ...) t) +;; Rather than invert the entire function just to evaluate at one point, +;; we use SREF-INVERSE to find d'. +;; +(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))) + ;; 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) + (dotimes (i (length s)) + (setf t0 (snd-t0 (aref s i)))) + (if (< t0 now) (setf flag t0))) + (t + (setf t0 (snd-t0 s)) + (if (< t0 now) (setf flag t0)))) + (if flag + (format t "Warning: cannot go back in time to ~A, sound came from ~A~%" + flag src)) + ; (display "check-t0" t0 now src) + ; return s whether or not warning was reported + s)) + +;; (CLIP S1 VALUE) - clip maximum amplitude to value +; +(defun clip (x 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)))) + + +;; (NYQ:COERCE-TO S1 S2) - expand sound s1 to type of s2 +; +(defun nyq:coerce-to (s1 s2) + (cond ((or (soundp s1) (numberp s1)) + (cond ((arrayp s2) + (nyq:sound-to-array s1 (length s2))) + (t s1))) + (t s1))) + + +(defmacro continuous-control-warp (beh) + `(snd-compose (warp-abs nil ,beh) + (snd-inverse (get-warp) + (local-to-global 0) *control-srate*))) + +(defmacro continuous-sound-warp (beh) + `(snd-compose (warp-abs nil ,beh) + (snd-inverse (get-warp) + (local-to-global 0) *sound-srate*))) + + +(defmacro control-srate-abs (r s) + `(progv '(*CONTROL-SRATE*) (list ,r) + ,s)) + +; db = 20log(ratio) +; db = 20 ln(ratio)/ln(10) +; db/20 = ln(ratio)/ln(10) +; db ln(10)/20 = ln(ratio) +; e^(db ln(10)/20) = ratio +; +(setf ln10over20 (/ (log 10.0) 20)) + +(defun db-to-linear (x) + (cond ((numberp x) + (exp (* ln10over20 x))) + ((arrayp x) + (let* ((len (length x)) + (result (make-array len))) + (dotimes (i len) + (setf (aref result i) + (snd-exp (snd-scale ln10over20 (aref x i))))) + result)) + (t + (snd-exp (snd-scale ln10over20 x))))) + + +(defun linear-to-db (x) + (cond ((numberp x) + (/ (log (float x)) ln10over20)) + ((arrayp x) + (let* ((len (length x)) + (result (make-array len))) + (dotimes (i len) + (setf (aref result i) + (snd-scale (/ 1.0 ln10over20) (snd-log (aref x i))))) + result)) + (t + (snd-scale (/ 1.0 ln10over20) (snd-log x))))) + + +(cond ((not (fboundp 'scalar-step-to-hz)) + (setfn scalar-step-to-hz step-to-hz) + (setfn scalar-hz-to-step hz-to-step))) + + +(defun step-to-hz (x) + (cond ((numberp x) + (scalar-step-to-hz x)) + ((arrayp x) + (let* ((len (length x)) + (result (make-array len))) + (dotimes (i len) + (setf (aref result i) (step-to-hz (aref x i)))) + result)) + (t + (s-exp (snd-offset (snd-scale 0.0577622650466621 x) + 2.1011784386926213))))) + +(defun hz-to-step (x) + (cond ((numberp x) + (scalar-hz-to-step x)) + ((arrayp x) + (let* ((len (length x)) + (result (make-array len))) + (dotimes (i len) + (setf (aref result i) (hz-to-step (aref x i)))) + result)) + (t + (snd-scale 17.312340490667565 + (snd-offset (s-log x) -2.1011784386926213))))) + + +; sref - access a sound at a given time point +; note that the time is transformed to global +(defun sref (sound 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) + (snd-xform sound (snd-srate sound) (local-to-global 0) + (local-to-global start) (local-to-global stop) 1.0)) + +(defun extract-abs (start stop sound) + (snd-xform sound (snd-srate sound) 0 start stop 1.0)) + + +(defun local-to-global (local-time) + (let ((d (warp-time *WARP*)) + (s (warp-stretch *WARP*)) + (w (warp-function *WARP*)) + global-time) + (setf global-time (+ (* s local-time) d)) + (if w (snd-sref w global-time) global-time))) + + +(defmacro loud (x s) + `(progv '(*LOUD*) (list (sum *LOUD* ,x)) + ,s)) + + +(defmacro loud-abs (x s) + `(progv '(*LOUD*) (list ,x) + ,s)) + +(defun must-be-sound (x) + (cond ((soundp x) x) + (t + (error "SOUND type expected" x)))) + +;; SCALE-DB -- same as scale, but argument is in db +;; +(defun scale-db (factor sound) + (scale (db-to-linear factor) sound)) + +(defun set-control-srate (rate) + (setf *default-control-srate* (float rate)) + (nyq:environment-init)) + +(defun set-sound-srate (rate) + (setf *default-sound-srate* (float rate)) + (nyq:environment-init)) + + +; s-plot -- compute and write n data points for plotting +; +; dur is how many seconds of sound to plot. If necessary, cut the +; sample rate to allow plotting dur seconds +; n is the number of points to plot. If there are more than n points, +; cut the sample rate. If there are fewer than n samples, just +; plot the points that exist. +; +(defun s-plot (snd &optional (dur 2.0) (n 1000)) + (prog* ((sr (snd-srate snd)) + (t0 (snd-t0 snd)) + (filename (soundfilename *default-plot-file*)) + (s snd) ;; s is either snd or resampled copy of snd + (outf (open filename :direction :output)) ;; for plot data + (maximum -1000000.0) ;; maximum amplitude + (minimum 1000000.0) ;; minimum amplitude + actual-dur ;; is the actual-duration of snd + sample-count ;; is how many samples to get from s + period ;; is the period of samples to be plotted + truncation-flag ;; true if we didn't get whole sound + points) ;; is array of samples + ;; If we need more than n samples to get dur seconds, resample + (cond ((< n (* dur sr)) + (setf s (force-srate (/ (float n) dur) snd)))) + ;; Get samples from the signal + (setf points (snd-samples s (1+ n))) + ;; If we got fewer than n points, we can at least estimate the + ;; actual duration (we might not know exactly if we use a lowered + ;; 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) + (cond ((< (length points) n) + ;; sound is shorter than dur, estimate actual length + (setf actual-dur (/ (length points) (snd-srate s))) + (setf sample-count (round (min n (* actual-dur sr)))) + (cond ((< n (* actual-dur sr)) + (setf s (force-srate (/ (float n) actual-dur) snd))) + (t ;; we can use original signal + (setf s snd))) + (setf points (snd-samples s sample-count)) + ;; due to rounding, need to recalculate exact count + (setf sample-count (length points))) + ((= (length points) n) + (setf actual-dur dur) + (setf sample-count n)) + (t ;; greater than n points, so we must have truncated sound + (setf actual-dur dur) + (setf sample-count n) + (setf truncation-flag t))) + ;; actual-dur is the duration of the plot + ;; sample-count is how many samples we have + (setf period (/ 1.0 (snd-srate s))) + (cond ((null outf) + (format t "s-plot: could not open ~A!~%" filename) + (return nil))) + (format t "s-plot: writing ~A ... ~%" filename) + (cond (truncation-flag + (format t " !!TRUNCATING SOUND TO ~As\n" actual-dur))) + (cond ((/= (snd-srate s) (snd-srate snd)) + (format t " !!RESAMPLING SOUND FROM ~A to ~Ahz\n" + (snd-srate snd) (snd-srate s)))) + (cond (truncation-flag + (format t " Plotting ~As, actual sound duration is greater\n" + actual-dur)) + (t + (format t " Sound duration is ~As~%" actual-dur))) + (dotimes (i sample-count) + (setf maximum (max maximum (aref points i))) + (setf minimum (min minimum (aref points i))) + (format outf "~A ~A~%" (+ t0 (* i period)) (aref points i))) + (close outf) + (format t " Wrote ~A points from ~As to ~As~%" + sample-count t0 (+ t0 actual-dur)) + (format t " Range of values ~A to ~A\n" minimum maximum) + (cond ((or (< minimum -1) (> maximum 1)) + (format t " !!SIGNAL EXCEEDS +/-1~%"))))) + + +; run something like this to plot the points: +; graph < points.dat | plot -Ttek + + +(defmacro sound-srate-abs (r s) + `(progv '(*SOUND-SRATE*) (list ,r) + ,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)) + + +(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)) + + +(defmacro sustain (x s) + `(progv '(*SUSTAIN*) (list (prod *SUSTAIN* ,x)) + ,s)) + + +(defmacro sustain-abs (x s) + `(progv '(*SUSTAIN*) (list ,x) + ,s)) + + +;; (WARP-FUNCTION *WARP*) - extracts function field of warp triple +;; +(setfn warp-function caddr) + + +;; (WARP-STRETCH *WARP*) - extracts stretch field of warp triple +;; +(setfn warp-stretch cadr) + + +;; (WARP-TIME *WARP*) - extracts time field of warp triple +;; +(setfn warp-time car) + + +(defmacro transpose (x s) + `(progv '(*TRANSPOSE*) (list (sum *TRANSPOSE* ,x)) + ,s)) + + +(defmacro transpose-abs (x s) + `(progv '(*TRANSPOSE*) (list ,x) + ,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 <your id here> +or add this to your init.lsp file: + (setf *default-sound-file* \"<your filename here>\") + (setf *default-sf-dir* \"<full pathname of desired directory here>\") + +Your id please: ") + (setf user (read)))) +|# + ; now compute the extension based on *default-sf-format* + (cond ((= *default-sf-format* snd-head-AIFF) + (setf extension ".aif")) + ((= *default-sf-format* snd-head-Wave) + (setf extension ".wav")) + (t + (setf extension ".snd"))) + (setf *default-sound-file* + (strcat (string-downcase user) "-temp" extension)) + (format t "Default sound file is ~A.~%" *default-sound-file*))) + + +;; CONTROL-WARP -- apply a warp function to a control function +;; +(defun control-warp (warp-fn control &optional wrate) + (cond (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*))))) + + +;; (cue sound) +;; Cues the given sound; that is, it applies the current *WARP*, *LOUD*, +;; *START*, and *STOP* values to the argument. The logical start time is at +;; local time 0. +(defun cue (sound) + (cond ((arrayp sound) + (let* ((len (length sound)) + (result (make-array len))) + (dotimes (i len) + (setf (aref result i) + (cue-sound (aref sound i)))) + result)) + (t + (cue-sound sound)))) + +(defun cue-sound (sound) + (snd-xform sound + (snd-srate sound) + (local-to-global 0) *START* *STOP* (db-to-linear (get-loud)))) + +;; (sound sound) +;; Same as (cue sound), except also warps the sound. +;; Note that the *WARP* can change the pitch of the +;; sound as a result of resampling. +;; Here's the derivation for the warping code: +;; *WARP* is a triple: (d s f) which denotes that the warp from local to +;; global time is: f(st+d) +;; We need to compose sound with the inverse of this to get a function +;; of global time +;; Let f-1 be the inverse of f. Then the inverse of f(st+d) is +;; (f-1(t) - d)/s +;; The composition gives us: (snd-compose sound (f-1(t) - d)/s) +;; Eliminate the 1/s term by changing the sample rate of sound: +;; = (snd-compose (snd-scale-srate sound s) (f-1(t) - d)) +;; Eliminate the -d term by shifting f before taking the inverse: +;; = (snd-compose (scale-srate sound s) ((inverse f) - d)) +;; = (snd-compose (scale-srate sound s) (inverse f(t + d))) +;; = (snd-compose (scale-srate sound s) (inverse (shift f -d))) +;; snd-inverse takes a time and sample rate. For time, use zero. +;; The sample rate of inverse determines the final sample rate of +;; this function, so use *SOUND-SRATE*: +;; = (snd-compose (scale-srate sound s) (snd-inverse (shift-time f (- d)) +;; 0 *SOUND-SRATE*)) +;; +(defun nyq:sound (sound) + (cond ((null (warp-function *WARP*)) + (snd-xform sound (/ (snd-srate sound) (warp-stretch *WARP*)) + (local-to-global 0) + *START* *STOP* (db-to-linear (get-loud)))) + (t + (snd-compose (scale-srate sound (warp-stretch *WARP*)) + (snd-inverse (shift-time (warp-function *WARP*) + (- (warp-time *WARP*))) + 0 *SOUND-SRATE*))))) + +(defun nyq:sound-of-array (sound) + (let* ((n (length sound)) + (s (make-array n))) + (dotimes (i n) + (setf (aref s i) (nyq:sound (aref sound i)))) + s)) + + +(defun sound (sound) + (cond ((arrayp sound) + (nyq:sound-of-array sound)) + (t + (nyq:sound sound)))) + + +;; (SCALE-SRATE SOUND SCALE) +;; multiplies the sample rate by scale +(defun scale-srate (sound scale) + (let ((new-srate (* scale (snd-srate sound)))) + (snd-xform sound new-srate (snd-time sound) + MIN-START-TIME MAX-STOP-TIME 1.0))) + + +;; (SHIFT-TIME SOUND SHIFT) +;; shift the time of a function by SHIFT, i.e. if SOUND is f(t), +;; then (shift-time SOUND SHIFT) is f(t - SHIFT). Note that if +;; you look at plots, the shifted sound will move *right* when SHIFT +;; is positive. +(defun shift-time (sound 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) + + +;; (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) + (cue (force-srate *SOUND-SRATE* (s-read name)))) + + +;; (env t1 t2 t4 l1 l2 l3 &optional duration) +;; Creates a 4-phase envelope. +;; tN is the duration of phase N, and lN is the final level of +;; phase N. t3 is implied by the duration, and l4 is 0.0. +;; If dur is not supplied, then 1.0 is assumed. The envelope +;; duration is the product of dur, *STRETCH*, and *SUSTAIN*. If +;; t1 + t2 + 2ms + t4 > duration, then a two-phase envelope is +;; substituted that has an attack/release time ratio = t1/t4. +;; The sample rate of the returned sound is *CONTROL-SRATE*. +;; +;; Time transformation: the envelope is not warped; the start time and +;; stop times are warped to global time. Then the value of *SUSTAIN* at +;; the begining of the envelope is used to determing absolute duration. +;; Since PWL is ultimately called to create the envelope, we must use +;; ABS-ENV to prevent any further transforms inside PWL. We use +;; (AT global-start ...) inside ABS-ENV so that the final result has +;; the proper starting time. +;; +(defun env (t1 t2 t4 l1 l2 l3 &optional (duration 1.0)) + (let (actual-dur min-dur ratio t3 + (actual-dur (get-duration duration))) + (setf min-dur (+ t1 t2 t4 0.002)) + (cond ((< actual-dur min-dur) + (setf ratio (/ t1 (float (+ t1 t4)))) + (setf t1 (* ratio actual-dur)) + (setf t2 (- actual-dur t1)) + (setf t3 0.0) + (setf t4 0.0) + (setf l2 0.0) + (setf l3 0.0)) + (t + (setf t3 (- actual-dur t1 t2 t4)))) + (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) + (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))))) + + +;; (osc-note step &optional duration env sust volume sound) +;; Creates a note using table-lookup osc, but with an envelope. +;; The ENV parameter may be a parameter list for the env function, +;; or it may be a sound. +;; +(defun osc-note (pitch &optional (duration 1.0) + (env-spec '(0.02 0.1 0.3 1.0 .8 .7)) + (volume 0.0) + (table *TABLE*)) + (set-logical-stop + (mult (loud volume (osc pitch duration table)) + (if (listp env-spec) + (apply 'env env-spec) + env-spec)) + duration)) + + +;; 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"))) + (cond ((arrayp snd) + (let* ((len (length snd)) + (result (make-array len))) + (dotimes (i len) + (setf (aref result i) + (force-srate sr (aref snd i)))) + result)) + (t + (let ((snd-sr (snd-srate snd))) + (cond ((> sr snd-sr) (snd-up sr snd)) + ((< sr snd-sr) (snd-down sr snd)) + (t snd)))))) + + +(defun force-srates (srs snd) + (cond ((and (numberp srs) (soundp snd)) + (force-srate srs snd)) + ((and (arrayp srs) (arrayp snd)) + (let* ((len (length snd)) + (result (make-array len))) + (dotimes (i len) + (setf (aref result i) + (force-srate (aref srs i) (aref snd i)))) + result)) + (t (error "arguments not compatible")))) + + +;; (breakpoints-convert (t1 x1 t2 x2 ... tn) t0) +;; converts times to sample numbers and scales amplitudes +;; t0 is the global (after warping) start time +;; +;; 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) + (prog (sample-count result sust (last-count 0)) + (setf sust (get-sustain)) + loop + (setf sample-count + (truncate (+ 0.5 (* (- (local-to-global (* (car list) sust)) t0) + *control-srate*)))) + ; now we have a new sample count to put into result list + ; make sure result is non-decreasing + (cond ((< sample-count last-count) + (setf sample-count last-count))) + (setf last-count sample-count) + (push sample-count result) + (cond ((cdr list) + (setf list (cdr 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 pwlr (&rest breakpoints) (pwlr-list breakpoints)) + +;; (breakpoints-relative list) +;; 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) + (prog (result (sum 0.0)) + loop + (setf sum (+ sum (car breakpoints))) + (push sum result) + (cond ((cdr breakpoints) + (setf breakpoints (cdr breakpoints)) + (push (car breakpoints) result))) + (setf breakpoints (cdr breakpoints)) + (cond (breakpoints + (go loop))) + (return (reverse result)))) + + +(defun pwlr-list (breakpoints) + (pwl-list (breakpoints-relative breakpoints))) + +(defun pwl-list (breakpoints) + (let ((t0 (local-to-global 0))) + (snd-pwl t0 *control-srate* (breakpoints-convert breakpoints t0)))) + +;; (pwlv l1 t1 l2 t2 ... ln) +;; Creates a piece-wise linear envelope from breakpoint data; +;; the function initial and final values are explicit +;; +(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)) + +(defun pwlv-list (breakpoints) + (pwl-list (cons 0.0 (append breakpoints '(0.0))))) + +(defun pwlvr (&rest breakpoints) (pwlvr-list breakpoints)) + +(defun pwlvr-list (breakpoints) + (pwlr-list (cons 0.0 (append breakpoints '(0.0))))) + +(defun pwe (&rest breakpoints) + (pwe-list breakpoints)) + +(defun pwe-list (breakpoints) + (pwev-list (cons 1.0 (append breakpoints '(1.0))))) + +(defun pwer (&rest breakpoints) (pwer-list breakpoints)) + +(defun pwer-list (breakpoints) + (pwe-list (breakpoints-relative breakpoints))) + +(defun pwev (&rest breakpoints) + (pwev-list breakpoints)) + +(defun pwev-list (breakpoints) + (let ((lis (breakpoints-log breakpoints))) + (s-exp (pwl-list lis)))) + +(defun pwevr (&rest breakpoints) (pwevr-list breakpoints)) + +(defun pwevr-list (breakpoints) + (pwev-list (cdr (breakpoints-relative (cons 0.0 breakpoints))))) + + +(defun breakpoints-log (breakpoints) + (prog ((result '(0.0)) val tim) +loop + (cond (breakpoints + (setf val (float (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"))))) + + +;; SOUND-WARP -- apply warp function to a sound +;; +(defun sound-warp (warp-fn signal &optional wrate) + (cond (wrate + (snd-resamplev signal *sound-srate* + (snd-inverse warp-fn (local-to-global 0) wrate))) + (t + (snd-compose signal + (snd-inverse warp-fn (local-to-global 0) *sound-srate*))))) + +(defun snd-extent (sound maxsamples) + (list (snd-t0 sound) + (+ (snd-t0 sound) (/ (snd-length sound maxsamples) + (snd-srate sound))))) + +(setfn snd-flatten snd-length) + +;; (maketable sound) +;; Creates a table for osc, lfo, etc. by assuming that the samples +;; in sound represent one period. The sound must start at time 0. + +(defun maketable (sound) + (list sound + (hz-to-step + (/ 1.0 + (cadr (snd-extent sound 1000000)))) + 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) + (vector (mult sound (sum 1 (mult -1 where))) + (mult sound where))) + + +(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))) + (t + (nyq:prod2 (car snds) (apply #'prod (cdr snds)))))) + +(setfn mult prod) + + +;; (NYQ:PROD-OF-ARRAYS S1 S2) - form pairwise products +; +(defun nyq:prod-of-arrays (s1 s2) + (let* ((n (length s1)) + (p (make-array n))) + (cond ((/= n (length s2)) + (error "unequal number of channels in prod"))) + (dotimes (i n) + (setf (aref p i) (nyq:prod2 (aref s1 i) (aref s2 i)))) + p)) + + +; nyq:prod2 - multiply two arguments +; +(defun nyq:prod2 (s1 s2) + (setf s1 (nyq:coerce-to s1 s2)) + (setf s2 (nyq:coerce-to s2 s1)) + (cond ((arrayp s1) + (nyq:prod-of-arrays s1 s2)) + (t + (nyq:prod-2-sounds s1 s2)))) + + +; (PROD-2-SOUNDS S1 S2) - multiply two sound arguments +; +(defun nyq:prod-2-sounds (s1 s2) + (cond ((numberp s1) + (cond ((numberp s2) + (* s1 s2)) + (t + (scale s1 s2)))) + ((numberp s2) + (scale s2 s1)) + (t + (let ((s1sr (snd-srate s1)) + (s2sr (snd-srate s2))) +; (display "nyq:prod-2-sounds" s1sr s2sr) + (cond ((> s1sr s2sr) + (snd-prod s1 (snd-up s1sr s2))) + ((< s1sr s2sr) + (snd-prod (snd-up s2sr s1) s2)) + (t + (snd-prod s1 s2))))))) + + +;; RAMP -- linear ramp from 0 to x +;; +(defun ramp (&optional (x 1)) + (let* ((duration (get-duration x))) + (set-logical-stop + (warp-abs nil + (at *rslt* + (sustain-abs 1 + (pwl duration 1 (+ duration (/ *control-srate*)))))) + x))) + + +(defun resample (snd 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)))) + + +(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)))) + + +(setfn s-print-tree snd-print-tree) + +;; (PEAK sound-expression number-of-samples) - find peak amplitude +; +; NOTE: this used to be called s-max +; +(defmacro peak (expression maxlen) + `(snd-max ',expression ,maxlen)) + +;; (S-MAX S1 S2) - return maximum of S1, S2 +; +(defun s-max (s1 s2) + (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)))) + +(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"))) + (dotimes (i n) + (setf (aref p i) (s-max (aref s1 i) (aref s2 i)))) + p)) + +(defun nyq:max-2-sounds (s1 s2) + (cond ((numberp s1) + (cond ((numberp s2) + (max s1 s2)) + (t + (snd-maxv s2 + (snd-const s1 (local-to-global 0.0) + (snd-srate s2) (get-duration 1.0)))))) + ((numberp s2) + (snd-maxv s1 (snd-const s2 (local-to-global 0.0) + (snd-srate s1) (get-duration 1.0)))) + (t + (let ((s1sr (snd-srate s1)) + (s2sr (snd-srate s2))) + (cond ((> s1sr s2sr) + (snd-maxv s1 (snd-up s1sr s2))) + ((< s1sr s2sr) + (snd-maxv (snd-up s2sr s1) s2)) + (t + (snd-maxv s1 s2))))))) + +(defun s-min (s1 s2) + (setf s1 (nyq:coerce-to s1 s2)) + (setf s2 (nyq:coerce-to s2 s1)) + (cond ((arrayp s1) + (nyq:min-of-arrays s1 s2)) + (t + (nyq:min-2-sounds s1 s2)))) + +(defun nyq:min-of-arrays (s1 s2) + (let* ((n (length s1)) + (p (make-array n))) + (cond ((/= n (length s2)) + (error "unequal number of channels in max"))) + (dotimes (i n) + (setf (aref p i) (s-min (aref s1 i) (aref s2 i)))) + p)) + +(defun nyq:min-2-sounds (s1 s2) + (cond ((numberp s1) + (cond ((numberp s2) + (min s1 s2)) + (t + (snd-minv s2 + (snd-const s1 (local-to-global 0.0) + (snd-srate s2) (get-duration 1.0)))))) + ((numberp s2) + (snd-minv s1 (snd-const s2 (local-to-global 0.0) + (snd-srate s1) (get-duration 1.0)))) + (t + (let ((s1sr (snd-srate s1)) + (s2sr (snd-srate s2))) + (cond ((> s1sr s2sr) + (snd-minv s1 (snd-up s1sr s2))) + ((< s1sr s2sr) + (snd-minv (snd-up s2sr s1) s2)) + (t + (snd-minv s1 s2))))))) + +(defun snd-minv (s1 s2) + (scale -1.0 (snd-maxv (scale -1.0 s1) (scale -1.0 s2)))) + +; sequence macros SEQ and SEQREP are now in seq.lsp: +; +(load "seq" :verbose NIL) + + +; set-logical-stop - modify the sound and return it, time is shifted and +; stretched +(defun set-logical-stop (snd tim) + (let ((d (local-to-global tim))) + (multichan-expand #'set-logical-stop-abs snd d))) + + +; set-logical-stop-abs - modify the sound and return it +; +(defun 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))) + +(defun sim (&rest snds) + (sim-list snds)) + +(setfn sum sim) + +(defun sim-list (snds) + (cond ((null snds) + (snd-zero (local-to-global 0) *sound-srate*)) + ((null (cdr snds)) + (car snds)) + ((null (cddr snds)) + (nyq:add2 (car snds) (cadr snds))) + (t + (nyq:add2 (car snds) (sim-list (cdr snds)))))) + + +(defun s-rest (&optional (dur 1.0) (chans 1)) + (let ((d (get-duration dur)) + r) + (cond ((= chans 1) + (snd-const 0.0 *rslt* *SOUND-SRATE* d)) + (t + (setf r (make-array chans)) + (dotimes (i chans) + (setf (aref r i) (snd-const 0.0 *rslt* *SOUND-SRATE* d))) + r)))) + + +(defun tempo (warpfn) + (slope (snd-inverse warpfn (local-to-global 0) *control-srate*))) + + + +;; (SUM-OF-ARRAYS S1 S2) - add multichannel sounds +; +; result has as many channels the largest of s1, s2 +; corresponding channels are added, extras are copied +; +(defun sum-of-arrays (s1 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))) + + (dotimes (i n) + (setf (aref result i) (nyq:add-2-sounds (aref s1 i) (aref s2 i)))) + (dotimes (i (- m n)) + (setf (aref result (+ n i)) (aref big-s (+ n i)))) + result)) + + +;; (WARP fn behavior) - warp behavior according to fn +;; +;; fn is a map from behavior time to local time, and *WARP* expresses +;; a map from local to global time. +;; To produce a new *WARP* for the environment, we want to compose the +;; effect of the current *WARP* with fn. Note that fn is also a behavior. +;; It is evaluated in the current environment first, then it is used to +;; modify the environment seen by behavior. +;; *WARP* is a triple: (d s f) denoting the function f(st+d). +;; Letting g represent the new warp function fn, we want f(st+d) o g, or +;; f(s*g(t) + d) in the form (d' s' f'). +;; Let's do this one step at a time: +;; f(s*g(t) + d) = f(scale(s, g) + d) +;; = (shift f -d)(scale(s, g)) +;; = (snd-compose (shift-time f (- d)) (scale s g)) +;; +;; If f in NIL, it denotes the identity mapping f(t)=t, so we can +;; simplify: +;; f(scale(s, g) + d) = scale(s, g) + d +;; = (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*))))) + ,s)) + + +(defmacro warp-abs (x s) + `(progv '(*WARP*) (list (list 0.0 1.0 ,x)) + ,s)) + + +;; MULTICHAN-EXPAND -- construct and return array according to args +;; +;; arrays are used in Nyquist to represent multiple channels +;; if any argument is an array, make sure all array arguments +;; have the same length. Then, construct a multichannel result +;; by calling fn once for each channel. The arguments passed to +;; 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 + (dolist (a args) + (cond ((arrayp a) + (setf newlen (length a)) + (cond ((and len (/= len newlen)) + (error (format nil "In ~A, two arguments are vectors of differing length." fn)))) + (setf len newlen)))) + (cond (len + (setf result (make-array len)) + ; for each channel, call fn with args + (dotimes (i len) + (setf (aref result i) + (apply fn + (mapcar + #'(lambda (a) + ; take i'th entry or replicate: + (cond ((arrayp a) (aref a i)) + (t a))) + args)))) + result) + (t + (apply fn args))))) + + +;; SELECT-IMPLEMENTATION-? -- apply an implementation according to args +;; +;; There is a different Nyquist primitive for each combination of +;; constant (NUMBERP) and time-variable (SOUNDP) arguments. E.g. +;; a filter with fixed parameters differs from one with varying +;; parameters. In most cases, the user just calls one function, +;; and the arguments are decoded here: + + +;; 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))))) + + +;; SELECT-IMPLEMENTATION-1-2 -- 1 sound arg, 2 selectors +;; +;; choose implemenation according to args 2 and 3 +;; +(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))))))) + +;; some waveforms + +(setf *saw-table* (pwlvr -1 1 1)) ; eh, creepy way to get 2205 samples. +(setf *saw-table* (list *saw-table* (hz-to-step 1) T)) + +(setf *tri-table* (pwlvr -1 0.5 1 0.5 -1)) +(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) + (let* ((target (expt 0.5 (/ length halfdec))) + (expenv (pwev 1 hold 1 length target))) + expenv) +) + +;;; operations on sounds + +(defun diff (x &optional y) + (cond (y (sum x (prod -1 y))) + (t (prod -1 x)))) + +; compare-shape is a shape table -- origin 1. +(defun compare (x y &optional (compare-shape *step-shape*)) + (let ((xydiff (diff x y))) + (shape xydiff compare-shape 1))) + +;;; oscs + +(defun osc-saw (hz) (hzosc hz *saw-table*)) +(defun osc-tri (hz) (hzosc hz *tri-table*)) + +; bias is [-1, 1] pulse width. sound or scalar. +; hz is a sound or scalar +(defun osc-pulse (hz bias &optional (compare-shape *step-shape*)) + (compare bias (osc-tri hz) compare-shape)) + +;;; tapped delays + +;(tapv snd offset vardelay maxdelay) +(setfn tapv snd-tapv) ;; linear interpolation +(setfn tapf snd-tapf) ;; no interpolation diff --git a/runtime/printrec.lsp b/runtime/printrec.lsp new file mode 100644 index 0000000..4ca17bb --- /dev/null +++ b/runtime/printrec.lsp @@ -0,0 +1,30 @@ +; prints recursive list structure + +;(let (seen-list) +(setf seenlist nil) + (defun seenp (l) (member l seenlist :test 'eq)) + (defun make-seen (l) (setf seenlist (cons l seenlist))) + (defun printrec (l) (printrec-any l) (setf seenlist nil)) + (defun printrec-any (l) + (cond ((atom l) (prin1 l) (princ " ")) + ((seenp l) (princ "<...> ")) + (t + (make-seen l) + (princ "(") + (printrec-list l) + (princ ") "))) + nil) + (defun printrec-list (l) + (printrec-any (car l)) + (cond ((cdr l) + (cond ((seenp (cdr l)) + (princ "<...> ")) + ((atom (cdr l)) + (princ ". ") + (prin1 (cdr l)) + (princ " ")) + (t + (make-seen (cdr l)) + (printrec-list (cdr l)))))) + nil) +; ) diff --git a/runtime/profile.lsp b/runtime/profile.lsp new file mode 100644 index 0000000..0f7038b --- /dev/null +++ b/runtime/profile.lsp @@ -0,0 +1,27 @@ + +; profile.lsp -- support for profiling + +;## show-profile -- print profile data +(defun show-profile () + (let ((profile-flag (profile nil)) (total 0)) + (dolist (name *PROFILE*) + (setq total (+ total (get name '*PROFILE*)))) + (dolist (name *PROFILE*) + (format t "~A (~A%): ~A~%" + (get name '*PROFILE*) + (truncate + (+ 0.5 (/ (float (* 100 (get name '*PROFILE*))) + total))) + name)) + (format t "Total: ~A~%" total) + (profile profile-flag))) + + +;## start-profile -- clear old profile data and start profiling +(defun start-profile () + (profile nil) + (dolist (name *PROFILE*) + (remprop name '*PROFILE*)) + (setq *PROFILE* nil) + (profile t)) + diff --git a/runtime/rawwaves/mand1.raw b/runtime/rawwaves/mand1.raw Binary files differnew file mode 100644 index 0000000..bc04a05 --- /dev/null +++ b/runtime/rawwaves/mand1.raw diff --git a/runtime/rawwaves/mand10.raw b/runtime/rawwaves/mand10.raw Binary files differnew file mode 100644 index 0000000..4b35376 --- /dev/null +++ b/runtime/rawwaves/mand10.raw diff --git a/runtime/rawwaves/mand11.raw b/runtime/rawwaves/mand11.raw Binary files differnew file mode 100644 index 0000000..94889be --- /dev/null +++ b/runtime/rawwaves/mand11.raw diff --git a/runtime/rawwaves/mand12.raw b/runtime/rawwaves/mand12.raw Binary files differnew file mode 100644 index 0000000..a128642 --- /dev/null +++ b/runtime/rawwaves/mand12.raw diff --git a/runtime/rawwaves/mand2.raw b/runtime/rawwaves/mand2.raw Binary files differnew file mode 100644 index 0000000..6208008 --- /dev/null +++ b/runtime/rawwaves/mand2.raw diff --git a/runtime/rawwaves/mand3.raw b/runtime/rawwaves/mand3.raw Binary files differnew file mode 100644 index 0000000..8857f86 --- /dev/null +++ b/runtime/rawwaves/mand3.raw diff --git a/runtime/rawwaves/mand4.raw b/runtime/rawwaves/mand4.raw Binary files differnew file mode 100644 index 0000000..6058eb1 --- /dev/null +++ b/runtime/rawwaves/mand4.raw diff --git a/runtime/rawwaves/mand5.raw b/runtime/rawwaves/mand5.raw Binary files differnew file mode 100644 index 0000000..9b308a8 --- /dev/null +++ b/runtime/rawwaves/mand5.raw diff --git a/runtime/rawwaves/mand6.raw b/runtime/rawwaves/mand6.raw Binary files differnew file mode 100644 index 0000000..05f083d --- /dev/null +++ b/runtime/rawwaves/mand6.raw diff --git a/runtime/rawwaves/mand7.raw b/runtime/rawwaves/mand7.raw Binary files differnew file mode 100644 index 0000000..64941e9 --- /dev/null +++ b/runtime/rawwaves/mand7.raw diff --git a/runtime/rawwaves/mand8.raw b/runtime/rawwaves/mand8.raw Binary files differnew file mode 100644 index 0000000..52027bf --- /dev/null +++ b/runtime/rawwaves/mand8.raw diff --git a/runtime/rawwaves/mand9.raw b/runtime/rawwaves/mand9.raw Binary files differnew file mode 100644 index 0000000..9e88a0c --- /dev/null +++ b/runtime/rawwaves/mand9.raw diff --git a/runtime/rawwaves/mandpluk.raw b/runtime/rawwaves/mandpluk.raw Binary files differnew file mode 100644 index 0000000..162a0da --- /dev/null +++ b/runtime/rawwaves/mandpluk.raw diff --git a/runtime/rawwaves/marmstk1.raw b/runtime/rawwaves/marmstk1.raw Binary files differnew file mode 100644 index 0000000..185b445 --- /dev/null +++ b/runtime/rawwaves/marmstk1.raw diff --git a/runtime/rawwaves/sinewave.raw b/runtime/rawwaves/sinewave.raw Binary files differnew file mode 100644 index 0000000..a5cb349 --- /dev/null +++ b/runtime/rawwaves/sinewave.raw diff --git a/runtime/sal-parse.lsp b/runtime/sal-parse.lsp new file mode 100644 index 0000000..756944a --- /dev/null +++ b/runtime/sal-parse.lsp @@ -0,0 +1,1827 @@ +;; SAL parser -- replaces original pattern-directed parser with +;; a recursive descent one +;; +;; Parse functions either parse correctly and return +;; compiled code as a lisp expression (which could be nil) +;; or else they call parse-error, which does not return +;; (instead, parse-error forces a return from parse) +;; In the original SAL parser, triples were returned +;; including the remainder if any of the tokens to be +;; parsed. In this parser, tokens are on the list +;; *sal-tokens*, and whatever remains on the list is +;; the list of unparsed tokens. + +;; scanning delimiters. + +(setfn nreverse reverse) + +(defconstant +quote+ #\") ; "..." string +(defconstant +kwote+ #\') ; '...' kwoted expr +(defconstant +comma+ #\,) ; positional arg delimiter +(defconstant +pound+ #\#) ; for bools etc +(defconstant +semic+ #\;) ; comment char +(defconstant +lbrace+ #\{) ; {} list notation +(defconstant +rbrace+ #\}) +(defconstant +lbrack+ #\[) ; unused for now +(defconstant +rbrack+ #\]) +(defconstant +lparen+ #\() ; () expr and arg grouping +(defconstant +rparen+ #\)) + +;; these are defined so that SAL programs can name these symbols +;; note that quote(>) doesn't work, so you need quote(symbol:greater) + +(setf symbol:greater '>) +(setf symbol:less '<) +(setf symbol:greater-equal '>=) +(setf symbol:less-equal '<=) +(setf symbol:equal '=) +(setf symbol:not '!) +(setf symbol:not-equal '/=) + + +(defparameter +whites+ (list #\space #\tab #\newline (code-char 13))) + +(defparameter +kwstyle+ (list :suffix #\:)) ; let's try dylan + +(defparameter +operators+ + ;; each op is: (<token-class> <sal-name> <lisp-form>) + '((:+ "+" sum) + (:- "-" diff) + (:* "*" mult) + (:/ "/" /) + (:% "%" rem) + (:^ "^" expt) + (:= "=" eql) ; equality and assigment + (:!= "!=" not-eql) + (:< "<" <) + (:> ">" >) + (:<= "<=" <=) ; leq and assignment minimization + (:>= ">=" >=) ; geq and assignment maximization + (:~= "~=" equal) ; general equality + (:+= "+=" +=) ; assignment increment-and-store + (:-= "-=" -=) ; assignment increment-and-store + (:*= "*=" *=) ; assignment multiply-and-store + (:/= "/=" /=) ; assignment multiply-and-store + (:&= "&=" &=) ; assigment list collecting + (:@= "@=" @=) ; assigment list prepending + (:^= "^=" ^=) ; assigment list appending + (:! "!" not) + (:& "&" and) + (:\| "|" or) + (:~ "~" sal-stretch) + (:~~ "~~" sal-stretch-abs) + (:@ "@" sal-at) + (:@@ "@@" sal-at-abs) + )) + +(setf *sal-local-variables* nil) ;; used to avoid warning about variable + ;; names when the variable has been declared as a local + +(defparameter *sal-operators* + '(:+ :- :* :/ :% :^ := :!= :< :> :<= :>= :~= :+= :*= :&= :@= :^= :! :& :\| + :~ :~~ :@ :@@)) + +(defparameter +delimiters+ + '((:lp #\() + (:rp #\)) + (:lc #\{) ; left curly + (:rc #\}) + (:lb #\[) + (:rb #\]) + (:co #\,) + (:kw #\') ; kwote + (nil #\") ; not token + ; (nil #\#) + (nil #\;) + )) + +(setf *reserved-words* '((::+ ":+") (::- ":-") (::* ":*") (::/ ":/") (::= ":=") + (::!= ":!=") (::< ":<") (::> ":>") (::<= ":<=") + (::>= ":>=") (::~= ":~=") (::! ":!") (::& ":&") + (::\| ":|") (:IF "if") (:THEN "then") (:ELSE "else") + (:WHEN "when") (:UNLESS "unless") (:SET "set") + (:= "=") (:+= "+=") (:*= "*=") (:&= "&=") (:@= "@=") + (:^= "^=") (:<= "<=") (:>= ">=") (:PRINT "print") + (:LOOP "loop") + (:RUN "run") (:REPEAT "repeat") (:FOR "for") + (:FROM "from") (:IN "in") (:BELOW "below") (:TO "to") + (:ABOVE "above") (:DOWNTO "downto") (:BY "by") + (:OVER "over") (:WHILE "while") (:UNTIL "until") + (:FINALLY "finally") (:RETURN "return") + (:WAIT "wait") (:BEGIN "begin") (:WITH "with") + (:END "end") (:VARIABLE "variable") + (:FUNCTION "function") (:PROCESS "process") + (:CHDIR "chdir") (:DEFINE "define") (:LOAD "load") + (:PLAY "play") + (:EXEC "exec") (:exit "exit") (:DISPLAY "display") + (:~ "~") (:~~ "~~") (:@ ":@") (:@@ ":@@"))) + + +(setf *sal-fn-name* nil) + +(defun make-sal-error (&key type text (line nil) start) + ; (error 'make-sal-error-was-called-break) + (list 'sal-error type text line start)) +(setfn sal-error-type cadr) +(setfn sal-error-text caddr) +(setfn sal-error-line cadddr) +(defun sal-error-start (x) (cadddr (cdr x))) +(defun is-sal-error (x) (and x (eq (car x) 'sal-error))) +(defun sal-tokens-error-start (start) + (cond (start + start) + (*sal-tokens* + (token-start (car *sal-tokens*))) + (t + (length *sal-input-text*)))) + + +(defmacro errexit (message &optional start) + `(parse-error (make-sal-error :type "parse" + :line *sal-input-text* :text ,message + :start ,(sal-tokens-error-start start)))) + +(defmacro sal-warning (message &optional start) + `(pperror (make-sal-error :type "parse" :line *sal-input-text* + :text ,message + :start ,(sal-tokens-error-start start)) + "warning")) + +(setf *pos-to-line-source* nil) +(setf *pos-to-line-pos* nil) +(setf *pos-to-line-line* nil) + +(defun pos-to-line (pos source) + ;; this is really inefficient to search every line from + ;; the beginning, so cache results and search forward + ;; from there if possible + (let ((i 0) (line-no 1)) ;; assume no cache + ;; see if we can use the cache + (cond ((and (eq source *pos-to-line-source*) + *pos-to-line-pos* *pos-to-line-line* + (>= pos *pos-to-line-pos*)) + (setf i *pos-to-line-pos*) + (setf line-no *pos-to-line-line*))) + ;; count newlines up to pos + (while (< i pos) + (if (char= (char source i) #\newline) + (incf line-no)) + (setf i (1+ i))) + ;; save results in cache + (setf *pos-to-line-source* source + *pos-to-line-pos* pos + *pos-to-line-line* line-no) + ;; return the line number at pos in source + line-no)) + + +;; makes a string of n spaces, empty string if n <= 0 +(defun make-spaces (n) + (cond ((> n 16) + (let* ((half (/ n 2)) + (s (make-spaces half))) + (strcat s s (make-spaces (- n half half))))) + (t + (subseq " " 0 (max n 0))))) + + +(defun pperror (x &optional (msg-type "error")) + (let* ((source (sal-error-line x)) + (llen (length source)) + line-no + beg end) + ; (display "pperror" x (strcat "|" (sal-error-line x) "|")) + ;; isolate line containing error + (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))) + (if (char= (char source i) #\newline) + (setq n (+ i 1)))) + (do ((i (sal-error-start x) (+ i 1)) + (n nil)) + ((or (>= i llen) n) + (setq end (or n llen))) + (if (char= (char source i) #\newline) + (setq n i))) + (setf line-no (pos-to-line beg source)) + ; (display "pperror" beg end (sal-error-start x)) + + ;; print the error. include the specfic line of input containing + ;; 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))) + (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) + x))) + + +;;; +;;; the lexer. right now it assumes input string is complete and ready +;;; to be processed as a valid expression. +;;; + +(defun advance-white (str white start end) + ;; skip "white" chars, where white can be a char, list of chars + ;; or predicate test + (do ((i start ) + (p nil)) + ((or p (if (< start end) + (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)))) + (if (< start end) + (incf i) + (decf i)))) + + +(defun search-delim (str delim start end) + ;; find position of "delim" chars, where delim can be + ;; a char, list of chars or predicate test + (do ((i start (+ i 1)) + (p nil)) + ((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)))))) + + +;; UNBALANCED-INPUT AND TOKENIZE HAVE BEEN REWRITTEN, SEE BELOW. THIS ONE IS +;; OLD AND JUST KEPT HERE FOR REFERENCE +#| +(defun unbalanced-input (errf line toks par bra brk kwo) + ;; search input for the starting position of some unbalanced + ;; delimiter, toks is reversed list of tokens with something + ;; unbalanced + (let (char text targ othr levl pos) + (cond ((> par 0) (setq char #\( targ ':lp othr ':rp levl par)) + ((< par 0) (setq char #\) targ ':rp othr ':lp levl 0)) + ((> bra 0) (setq char #\{ targ ':lc othr ':rc levl bra)) + ((< bra 0) (setq char #\} targ ':rc othr ':lc levl 0)) + ((> brk 0) (setq char #\[ targ ':ls othr ':rs levl brk)) + ((< brk 0) (setq char #\] targ ':rs othr ':ls levl 0)) + ((> kwo 0) (setq char #\' targ ':kw othr ':kw levl kwo))) + (setq text (format nil "Unmatched '~A'" char)) + ;; search for start of error in token list + (do ((n levl) + (tail toks (cdr tail))) + ((or (null tail) pos) + (or pos (error (format nil "Shouldn't! can't find op ~A in ~A." + targ (reverse toks))))) + (if (eql (token-type (car tail)) targ) + (if (= n levl) + (setq pos (token-start (car tail))) + (decf n)) + (if (eql (token-type (car tail)) othr) + (incf n)))) + (errexit text pos))) + + +(defun tokenize (str reserved error-fn) + ;&key (start 0) (end (length str)) + ; (white-space +whites+) (delimiters +delimiters+) + ; (operators +operators+) (null-ok t) + ; (keyword-style +kwstyle+) (reserved nil) + ; (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))))) + (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))) + (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)) + ;; multiple values are returned, so split them here: + (setf pos (second tok)) ; pos is the end of the token (!) + (setf tok (first tok)) + + ;; 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)))) + (cond ((eql tok ':eof) + (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)) + ;(display "classify-token-result" tok) + (setf (cdr tail) (list tok )) + (setf tail (cdr tail)) + (setq beg pos)))))) +|# + + +;; old tokenize (above) counted delimiters to check for balance, +;; but that does not catch constructions like ({)}. I think +;; we could just leave this up to the parser, but this rewrite +;; uses a stack to check balanced parens, braces, quotes, etc. +;; The checking establishes at least some minimal global properties +;; of the input before evaluating anything, which might be good +;; even though it's doing some extra work. In fact, using a +;; stack rather than counts is doing even more work, but the +;; problem with counters is that some very misleading or just +;; plain wrong error messages got generated. +;; +;; these five delimiter- functions do checks on balanced parens, +;; braces, and brackets, leaving delimiter-mismatch set to bad +;; token if there is a mismatch +(defun delimiter-init () + (setf delimiter-stack nil) + (setf delimiter-mismatch nil)) +(defun delimiter-match (tok what) + (cond ((eql (token-string (first delimiter-stack)) what) + (pop delimiter-stack)) + ((null delimiter-mismatch) + ;(display "delimiter-mismatch" tok) + (setf delimiter-mismatch tok)))) +(defun delimiter-check (tok) + (let ((c (token-string tok))) + (cond ((member c '(#\( #\{ #\[)) + (push tok delimiter-stack)) + ((eql c +rbrace+) + (delimiter-match tok +lbrace+)) + ((eql c +rparen+) + (delimiter-match tok +lparen+)) + ((eql c +rbrack+) + (delimiter-match tok +lbrack+))))) +(defun delimiter-error (tok) + (errexit (format nil "Unmatched '~A'" (token-string tok)) + (token-start tok))) +(defun delimiter-finish () + (if delimiter-mismatch + (delimiter-error delimiter-mismatch)) + (if delimiter-stack + (delimiter-error (car delimiter-stack)))) +(defun tokenize (str reserved error-fn) + ;; 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))))) + (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. + (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)) + ;; 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 + ;; 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)) + (delimiter-check tok) + ;(display "classify-token-result" tok) + (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)) + ;; 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 + ;(FORMAT T "~%READ-DELIMITED: ~S :START ~S :END ~S" input start end) + (let ((len (or end (length input)))) + (while t ;; loop over comment lines + (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+) + ;; comment skips to next line and trys again... + (while (and (< start len) + (char/= (char input start) #\newline)) + (incf start)) + (cond ((< start len) ;; advance past comment and iterate + (incf start) + (setf skip-initial-white t)) + (null-ok + (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))))) + ; 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 + (return (list ':eof end)) + (errexit "Unexpected end of input" start)))))) + + +(defparameter hash-readers + '(( #\t sal:read-bool) + ( #\f sal:read-bool) + ( #\? read-iftok) + )) + + +(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)))) + + +(defun read-iftok (str delims pos len errf) + str delims len errf + (list (make-token :type ':? :string "#?" :lisp 'if + :start (- pos 1)) + (+ pos 1))) + +; (sal:read-string str start len) + +(defun sal:read-bool (str delims pos len errf) + delims len errf + (let ((end (search-delim str delims pos len))) + (unless (= end (+ pos 1)) + (errexit "Illegal # expression" (- pos 1))) + (list (let ((t? (char= (char str pos) #\t) )) + (make-token :type ':bool + :string (if t? "#t" "#f") + :lisp t? + :start (- pos 1))) + (+ pos 1)))) + + +(defun sal:read-string (str delims pos len errf) + (let* ((i (1+ pos)) ; i is index into string; start after open quote + c c2; c is the character at str[i] + (string (make-string-output-stream))) + ;; read string, processing escaped characters + ;; write the chars to string until end quote is found + ;; then retrieve the string. quotes are not included in result token + + ;; in the loop, i is the next character location to examine + (while (and (< i len) + (not (char= (setf c (char str i)) +quote+))) + (if (char= c #\\) ;; escape character, does another character follow this? + (cond ((< (1+ i) len) + (incf i) ;; yes, set i so we'll get the escaped char + (setf c2 (char str i)) + (setf c (assoc c2 `((#\n . #\newline) (#\t . #\tab) + (#\r . ,(char "\r" 0)) + (#\f . ,(char "\f" 0))))) + (setf c (if c (cdr c) c2))) ;; use c2 if c wasn't listed + (t ;; no, we've hit the end of input too early + (errexit "Unmatched \"" i)))) + ;; we're good to take this character and move on to the next one + (write-char c string) + (incf i)) + ;; done with loop, so either we're out of string or we found end quote + (if (>= i len) (errexit "Unmatched \"" i)) + ;; must have found the quote + (setf string (get-output-stream-string string)) + (list (make-token :type :string :start pos :string string :lisp string) + (1+ i)))) + +;;; +;;; tokens +;;; + +(defun make-token (&key (type nil) (string "") start (info nil) lisp) + (list :token type string start info lisp)) +(setfn token-type cadr) +(setfn token-string caddr) +(defun token-start (x) (cadddr x)) +(defun token-info (token) (car (cddddr token))) +(defun token-lisp (token) (cadr (cddddr token))) +(defmacro set-token-type (tok val) `(setf (car (cdr ,tok)) ,val)) +(defmacro set-token-lisp (tok val) `(setf (car (cdr (cddddr ,tok))) ,val)) +(defun tokenp (tok) (and (consp tok) (eq (car tok) :token))) + +(defun token=? (tok op) + (if (tokenp tok) + (equal (token-type tok) op) + (eql tok op))) + +(defmethod token-print (obj stream) + (let ((*print-case* ':downcase)) + (format stream "#<~s ~s>" + (token-type obj) + (token-string obj)))) + +(defun parse-token () + (prog1 (car *sal-tokens*) + (setf *sal-tokens* (cdr *sal-tokens*)))) + +;;; +;;; token classification. types not disjoint! +;;; + +(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))) + tok)) + + +(defun delimiter-token? (str pos input errf delims) + (let ((typ (member str delims :test (lambda (a b) (char= a (cadr b)))))) + ;; 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))))) + + +(defun string-to-number (s) + (read (make-string-input-stream s))) + + +(defun number-token? (str pos input errf) + errf input + (do ((i 0 (+ i 1)) + (len (length str)) + (c nil) + (dot 0) + (typ ':int) + (sig 0) + (sla 0) + (dig 0) + (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))) + (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)))) +; 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))))) + +#|| +(number-token? "" 0 "" #'pperror) +(number-token? " " 0 "" #'pperror) +(number-token? "a" 0 "" #'pperror) +(number-token? "1" 0 "" #'pperror) +(number-token? "+" 0 "" #'pperror) +(number-token? "-1/2" 0 "" #'pperror) +(number-token? "1." 0 "" #'pperror) +(number-token? "1.." 0 "" #'pperror) +(number-token? ".1." 0 "" #'pperror) +(number-token? ".1" 0 "" #'pperror) +(number-token? "-0.1" 0 "" #'pperror) +(number-token? "1/2" 0 "" #'pperror) +(number-token? "1//2" 0 "" #'pperror) +(number-token? "/12" 0 "" #'pperror) +(number-token? "12/" 0 "" #'pperror) +(number-token? "12/1" 0 "" #'pperror) +(number-token? "12./1" 0 "" #'pperror) +(number-token? "12/.1" 0 "" #'pperror) +||# + +(defun operator-token? (str pos input errf ops) + ;; tok can be string or char + (let ((typ (member str ops :test (lambda (a b) (equal a (cadr b)))))) + (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))))))) + +(defun str-to-keyword (str) + (intern (strcat ":" (string-upcase str)))) + + +(defun keyword-token? (tok pos input errf style) + (let* ((tlen (length tok)) + (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 + (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 + (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))))))) + + +(setfn alpha-char-p both-case-p) + + +(defun class-token? (str pos input errf res) + 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))) + +; (keyword-token? ":asd" '(:prefix #\:)) +; (keyword-token? "asd" KSTYLE) +; (keyword-token? "asd:" KSTYLE) +; (keyword-token? "123:" KSTYLE) +; (keyword-token? ":foo" '(:prefix #\:)) +; (keyword-token? "foo=" '(:suffix #\=)) +; (keyword-token? "--foo" '(:prefix #\- #\-)) +; (keyword-token? ":123" '(:suffix #\:)) +; (keyword-token? "--asd" '(:prefix #\-)) ; ok since -asd is legal symbol + + +(defun reserved-token? (str pos input errf reserved) + errf input + (let ((typ (member str reserved :test (lambda (a b) (equal a (cadr b)))))) + (if typ + (make-token :type (caar typ) :string str + :start pos) + nil))) + + +(defun sal-string-to-symbol (str) + (let ((sym (intern (string-upcase str))) + sal-sym) + (cond ((and sym ;; (it might be "nil") + (setf sal-sym (get sym :sal-name))) + sal-sym) + (t sym)))) + + +(putprop 'simrep 'sal-simrep :sal-name) +(putprop 'seqrep 'sal-seqrep :sal-name) + +(defun contains-op-char (s) + ;; assume most identifiers are very short, so we search + ;; over identifier letters, not over operator characters + ;; Minus (-) is so common, we don't complain about it. + (dotimes (i (length s)) + (if (string-search (subseq s i (1+ i)) "*/+=<>!%^&|") + (return t)))) + +(defun test-for-suspicious-symbol (token) + ;; assume token is of type :id + (let ((sym (token-lisp token)) + (str (token-string token)) + (pos (token-start token))) + (cond ((and sym ; nil is not suspicious, but it's not "boundp" + (not (fboundp sym)) ; existing functions not suspicious + (not (boundp sym)) ; existing globals not suspicious + (not (member sym *sal-local-variables*)) + (contains-op-char str)) ; suspicious if embedded operators + (sal-warning + (strcat "Identifier contains operator character(s).\n" + " Perhaps you omitted spaces around an operator") + pos))))) + + +(defun symbol-token? (str pos input errf) + ;; if a potential symbol is preceded by #, drop the # + (if (and (> (length str) 1) + (char= (char str 0) #\#)) + ;; there are a couple of special cases: SAL defines #f and #? + (cond ((equal str "#f") + (return-from symbol-token? + (make-token :type ':id :string str :start pos :lisp nil))) + ((equal str "#?") + (return-from symbol-token? + (make-token :type ':id :string str :start pos :lisp 'if))) + (t + (setf str (subseq str 1))))) + ;; let's insist on at least one letter for sanity's sake + ;; exception: allow '-> because it is used in markov pattern specs + (do ((i 0 (+ i 1)) ; i is index into string + (bad "Not an expression or symbol") + (chr nil) + (ltr 0) ; ltr is count of alphabetic letters in string + (dot nil) ; dot is index of "." + (pkg nil) ; pkg is index if package name "xxx:" found + (len (length str)) + (err nil)) + ;; loop ends when i is at end of string or when err is set + ((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)) + ;(display "in symbol-token?" str) + (setf sym (sal-string-to-symbol str)) + (make-token :type ':id :string str + :info info :start pos + :lisp sym)) + 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 #\:) + ; 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))))))) + + +; (let ((i "foo")) (symbol-token? i 0 i #'pperror)) +; (let ((i "foo..bar")) (symbol-token? i 0 i #'pperror)) +; (let ((i ".bar")) (symbol-token? i 0 i #'pperror)) +; (let ((i "bar.")) (symbol-token? i 0 i #'pperror)) +; (let ((i "1...")) (symbol-token? i 0 i #'pperror)) +; (let ((i "a1..." )) (symbol-token? i 0 i #'pperror)) +; (let ((i "a{b")) (symbol-token? i 0 i #'pperror)) +; (let ((i "foo-bar")) (symbol-token? i 0 i #'pperror)) +; (let ((i "123-a")) (symbol-token? i 0 i #'pperror)) +; (let ((i "1a23-a")) (symbol-token? i 0 i #'pperror)) +; (let ((i "*foo*")) (symbol-token? i 0 i #'pperror)) +; (let ((i "+foo+")) (symbol-token? i 0 i #'pperror)) +; (let ((i "foo+bar")) (symbol-token? i 0 i #'pperror)) +; (let ((i "foo/bar")) (symbol-token? i 0 i #'pperror)) + +; (let ((i ":bar")) (symbol-token? i 0 i #'pperror)) +; (let ((i "::bar")) (symbol-token? i 0 i #'pperror)) +; (let ((i "foo:bar")) (symbol-token? i 0 i #'pperror)) +; (let ((i "cl-user:bar")) (symbol-token? i 0 i #'pperror)) +; (let ((i "cl-user::bar")) (symbol-token? i 0 i #'pperror)) +; (tokenize "aaa + bbb \"asdasdd\" aaa(1,2,3)") +; (tokenize "aaa+bbb \"asdasdd\" aaa(1,2,3)") + + +(setf *in-sal-parser* nil) + +;; line number info for debugging +(setf *sal-line-number-info* t) +(setf *sal-line* 0) + +(defun add-line-info-to-expression (expr token) + (let (line-no) + (cond ((and token ;; null token means do not change expr + *sal-line-number-info* ;; is this feature enabled? + (stringp *sal-input-text*)) + ;; first, get line number + (setf line-no (pos-to-line (token-start token) *sal-input-text*)) + `(prog2 (setf *sal-line* ,line-no) ,expr)) + (t expr)))) + +;; single statement is handled just like an expression +(setfn add-line-info-to-stmt add-line-info-to-expression) + +;; list of statements is simple to handle: prepend SETF +(defun add-line-info-to-stmts (stmts token) + (let (line-no) + (cond ((and *sal-line-number-info* ;; is this feature enabled? + (stringp *sal-input-text*)) + (setf line-no (pos-to-line (token-start token) *sal-input-text*)) + (cons `(setf *sal-line* ,line-no) stmts)) + (t stmts)))) + + +;; PARSE-ERROR -- print error message, return from top-level +;; +(defun parse-error (e) + (unless (sal-error-line e) + (setf (sal-error-line e) *sal-input*)) + (pperror e) + (return-from sal-parse (values nil e *sal-tokens*))) + + +;; SAL-PARSE -- parse string or token input, translate to Lisp +;; +;; If input is text, *sal-input-text* is set to the text and +;; 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 +;; *sal-input-text* is set to the corresponding text. +;; +(defun sal-parse (grammar pat input multiple-statements file) + (progv '(*sal-input-file-name*) (list file) + (let (rslt expr rest) + ; ignore grammar and pat (just there for compatibility) + ; parse input and return lisp expression + (cond ((stringp input) + (setf *sal-input-text* input) + (setq input (tokenize input *reserved-words* #'parse-error)))) + (setf *sal-input* input) ;; all input + (setf *sal-tokens* input) ;; current input + (cond ((null input) + (values t nil nil)) ; e.g. comments compile to nil + (t + (setf rslt (or (maybe-parse-command) + (maybe-parse-block) + (maybe-parse-conditional) + (maybe-parse-assignment) + (maybe-parse-loop) + (maybe-parse-exec) + (maybe-parse-exit) + (errexit "Syntax error"))) + ;; note: there is a return-from parse in parse-error that + ;; returns (values nil error <unparsed-tokens>) + (cond ((and *sal-tokens* (not multiple-statements)) + (errexit "leftover tokens"))) + ;((null rslt) + ; (errexit "nothing to compile"))) + (values t rslt *sal-tokens*)))))) + + +;; TOKEN-IS -- test if the type of next token matches expected type(s) +;; +;; type can be a list of possibilities or just a symbol +;; Usually, suspicious-id-warn is true by default, and any symbol +;; with embedded operator symbols, e.g. x+y results in a warning +;; that this is an odd variable name. But if the symbol is declared +;; as a local, a parameter, a function name, or a global variable, +;; then the warning is supressed. +;; +(defun token-is (type &optional (suspicious-id-warn t)) + (let ((token-type + (if *sal-tokens* (token-type (car *sal-tokens*)) nil)) + rslt) + ; input can be list of possible types or just a type: + (setf rslt (or (and (listp type) + (member token-type type)) + (and (symbolp type) (eq token-type type)))) + ; test if symbol has embedded operator characters: + (cond ((and rslt suspicious-id-warn (eq token-type :id)) + (test-for-suspicious-symbol (car *sal-tokens*)))) + rslt)) + + +(defun maybe-parse-command () + (if (token-is '(:define :load :chdir :variable :function + ; :system + :play :print :display)) + (parse-command) + (if (and (token-is '(:return)) *audacity-top-level-return-flag*) + (parse-command)))) + + +(defun parse-command () + (cond ((token-is '(:define :variable :function)) + (parse-declaration)) + ((token-is :load) + (parse-load)) + ((token-is :chdir) + (parse-chdir)) + ((token-is :play) + (parse-play)) +; ((token-is :system) +; (parse-system)) + ((token-is :print) + (parse-print-display :print 'sal-print)) + ((token-is :display) + (parse-print-display :display 'display)) + ((and *audacity-top-level-return-flag* (token-is :return)) + (parse-return)) +; ((token-is :output) +; (parse-output)) + (t + (errexit "Command not found")))) + + +(defun parse-stmt () + (cond ((token-is :begin) + (parse-block)) + ((token-is '(:if :when :unless)) + (parse-conditional)) + ((token-is :set) + (parse-assignment)) + ((token-is :loop) + (parse-loop)) + ((token-is :print) + (parse-print-display :print 'sal-print)) + ((token-is :display) + (parse-print-display :display 'display)) +; ((token-is :output) +; (parse-output)) + ((token-is :exec) + (parse-exec)) + ((token-is :exit) + (parse-exit)) + ((token-is :return) + (parse-return)) + ((token-is :load) + (parse-load)) + ((token-is :chdir) + (parse-chdir)) +; ((token-is :system) +; (parse-system)) + ((token-is :play) + (parse-play)) + (t + (errexit "Command not found")))) + + +;; GET-PARM-NAMES -- given parms like (a b &key (x 1) (y 2)), +;; return list of parameters: (a b x y) +(defun get-parm-names (parms) + (let (rslt) + (dolist (p parms) + (cond ((symbolp p) + (if (eq p '&key) nil (push p rslt))) + (t (push (car p) rslt)))) + (reverse rslt))) + + +;; RETURNIZE -- make a statement (list) end with a sal-return-from +;; +;; SAL returns nil from begin-end statement lists +;; +(defun returnize (stmt) + (let (rev) + (setf rev (reverse stmt)) + (setf expr (car rev)) ; last expression in list + (cond ((and (consp expr) (eq (car expr) 'sal-return-from)) + stmt) ; already ends in sal-return-from + (t + (reverse (cons (list 'sal-return-from *sal-fn-name* nil) + rev)))))) + + +(defun parse-declaration () + (if (token-is :define) (parse-token)) ; SAL extension: "define" is optional + (let (bindings setf-args formals parms stmt locals loc) + (cond ((token-is :variable) + (setf bindings (parse-bindings)) + (setf loc *rslt*) ; the "variable" token + (dolist (b bindings) + (cond ((symbolp b) + (push b setf-args) + (push `(if (boundp ',b) ,b) setf-args)) + (t + (push (first b) setf-args) + (push (second b) setf-args)))) + (add-line-info-to-stmt (cons 'setf (reverse setf-args)) loc)) + ((token-is :function) + (parse-token) + (if (token-is :id nil) + (setf *sal-fn-name* (token-lisp (parse-token))) + (errexit "function name expected here")) + (setf locals *sal-local-variables*) + (setf formals (parse-parms)) + (setf stmt (parse-stmt)) + ;; stmt may contain a return-from, so make this a progn or prog* + (cond ((and (consp stmt) + (not (eq (car stmt) 'progn)) + (not (eq (car stmt) 'prog*))) + (setf stmt (list 'progn stmt)))) + ;; need return to pop traceback stack + (setf stmt (returnize stmt)) + ;; get list of parameter names + (setf parms (get-parm-names formals)) + (setf *sal-local-variables* locals) + ;; build the defun + (prog1 (list 'defun *sal-fn-name* formals + (list 'sal-trace-enter + (list 'quote *sal-fn-name*) + (cons 'list parms) + (list 'quote parms)) + stmt) + (setf *sal-fn-name* nil))) + (t + (errexit "bad syntax"))))) + + +(defun parse-one-parm (kargs) + ;; kargs is a flag indicating previous parameter was a keyword (all + ;; the following parameters must then also be keyword parameters) + ;; returns: (<keyword> <default>) or (nil <identifier>) + ;; where <keyword> is a keyward parameter name (nil if not a keyword parm) + ;; <default> is an expression for the default value + ;; <identifier> is the parameter name (if not a keyword parm) + (let (key default-value id) + (cond ((and kargs (token-is :id)) + (errexit "positional parameter not allowed after keyword parameter")) + ((token-is :id) + ;(display "parse-one-1" (token-is :id) (car *sal-tokens*)) + (setf id (token-lisp (parse-token))) + (push id *sal-local-variables*) + (list nil id)) + ((token-is :key) + (setf key (sal-string-to-symbol (token-string (parse-token)))) + (cond ((or (token-is :co) (token-is :rp))) ; no default value + (t + (setf default-value (parse-sexpr)))) + (list key default-value)) + (kargs + (errexit "expected keyword name")) + (t + (errexit "expected parameter name"))))) + + +(defun parse-parms () + ;(display "parse-parms" *sal-tokens*) + (let (parms parm kargs expecting) + (if (token-is :lp) + (parse-token) ;; eat the left paren + (errexit "expected left parenthesis")) + (setf expecting (not (token-is :rp))) + (while expecting + (setf parm (parse-one-parm kargs)) + ;(display "parm" parm) + ;; returns list of (kargs . parm) + (if (and (car parm) (not kargs)) ; kargs just set + (push '&key parms)) + (setf kargs (car parm)) + ;; normally push the <id>; for keyword parms, push id and default value + (push (if kargs parm (cadr parm)) parms) + (if (token-is :co) + (parse-token) + (setf expecting nil))) + (if (token-is :rp) (parse-token) + (errexit "expected right parenthesis")) + ;(display "parse-parms" (reverse parms)) + (reverse parms))) + + +(defun parse-bindings () + (let (bindings bind) + (setf *rslt* (parse-token)) ; skip "variable" or "with" + ; return token as "extra" return value + (setf bind (parse-bind)) + (push (if (second bind) bind (car bind)) + bindings) + (while (token-is :co) + (parse-token) + (setf bind (parse-bind)) + ;; if non-nil initializer, push (id expr) + (push (if (second bind) bind (car bind)) + bindings)) + (reverse bindings))) + + +(defun parse-bind () + (let (id val) + (if (token-is :id nil) + (setf id (token-lisp (parse-token))) + (errexit "expected a variable name")) + (cond ((token-is :=) + (parse-token) + (setf val (parse-sexpr)))) + (push id *sal-local-variables*) + (list id val))) + + +(defun parse-chdir () + ;; assume next token is :chdir + (or (token-is :chdir) (error "parse-chdir internal error")) + (let (path loc) + (setf loc (parse-token)) + (setf path (parse-path)) + (add-line-info-to-stmt (list 'setdir path) loc))) + + +(defun parse-play () + ;; assume next token is :play + (or (token-is :play) (error "parse-play internal error")) + (let ((loc (parse-token))) + (add-line-info-to-stmt (list 'sal-play (parse-sexpr)) loc))) + + +(defun parse-return () + (or (token-is :return) (error "parse-return internal error")) + (let (loc expr) + ;; this seems to be a redundant test + (if (and (null *sal-fn-name*) + (not *audacity-top-level-return-flag*)) + (errexit "Return must be inside a function body")) + (setf loc (parse-token)) + (setf expr (parse-sexpr)) + (if *sal-fn-name* + (add-line-info-to-stmt (list 'sal-return-from *sal-fn-name* expr) loc) + (list 'defun 'main '() (list 'sal-trace-enter '(quote main) '() '()) + (add-line-info-to-stmt expr loc))))) + + +(defun parse-load () + ;; assume next token is :load + (or (token-is :load) (error "parse-load internal error")) + (let (path args loc) + (setf loc (parse-token)) + (setf path (parse-path)) ; must return path or raise error + (setf args (parse-keyword-args)) + (add-line-info-to-stmt (cons 'sal-load (cons path args)) loc))) + +(defun parse-keyword-args () + (let (args) + (while (token-is :co) + (parse-token) + (cond ((token-is :key) + (push (token-value) args) + (push (parse-sexpr) args)))) + (reverse args))) + + +'(defun parse-system () + ;; assume next token is :system + (or (token-is :system) (error "parse-system internal error")) + (let (path arg args) + (parse-token) + (setf path (parse-sexpr)) + (list 'sal-system path))) + + +(defun parse-path () + (if (token-is '(:id :string)) + (token-lisp (parse-token)) + (errexit "path not found"))) + + +(defun parse-print-display (token function) + ;; assumes next token is :print + (or (token-is token) (error "parse-print-display internal error")) + (let (args arg loc) + (setf loc (parse-token)) + (setf arg (parse-sexpr)) + (setf args (list arg)) + (while (token-is :co) + (parse-token) ; remove and ignore the comma + (setf arg (parse-sexpr)) + (push arg args)) + (add-line-info-to-stmt (cons function (reverse args)) loc))) + + +;(defun parse-output () +; ;; assume next token is :output +; (or (token-is :output) (error "parse-output internal error")) +; (parse-token) +; (list 'sal-output (parse-sexpr))) + + +(defun maybe-parse-block () + (if (token-is :begin) (parse-block))) + + +(defun parse-block () + ;; assumes next token is :block + (or (token-is :begin) (error "parse-block internal error")) + (let (args stmts (locals *sal-local-variables*)) + (parse-token) + (cond ((token-is :with) + (setf args (parse-bindings)))) + (while (not (token-is :end)) + (push (parse-stmt) stmts)) + (parse-token) + (setf stmts (reverse stmts)) + ;(display "parse-block" args stmts) + (setf *sal-local-variables* locals) + (cons 'prog* (cons args stmts)))) + + +;; MAKE-STATEMENT-LIST -- convert stmt to a stmt list +;; +;; if it is a (PROGN ...) then return cdr -- it's already a list +;; otherwise, put single statement into a list +;; +(defun make-statement-list (stmt) + (cond ((atom stmt) + (list stmt)) + ((eq (car stmt) 'progn) + (cdr stmt)) + (t + (list stmt)))) + +(setf *conditional-tokens* '(:if :when :unless)) + + +(defun maybe-parse-conditional () + (if (token-is *conditional-tokens*) + (parse-conditional))) + + +(defun parse-conditional () + ;; assumes next token is :if + (or (token-is *conditional-tokens*) + (error "parse-conditional internal error")) + (let (test then-stmt else-stmt if-token) + (cond ((token-is :if) + (setf if-token (parse-token)) + (setf test (parse-sexpr if-token)) + (if (not (token-is :then)) + (errexit "expected then after if")) + (parse-token) + (if (not (token-is :else)) ;; no then statement + (setf then-stmt (parse-stmt))) + (cond ((token-is :else) + (parse-token) + (setf else-stmt (parse-stmt)))) + ;(display "cond" test then-stmt else-stmt) + (if else-stmt + (list 'if test then-stmt else-stmt) + (list 'if test then-stmt))) + ((token-is :when) + (parse-token) + (setf test (parse-sexpr)) + (setf then-stmt (parse-stmt)) + (cons 'when (cons test (make-statement-list then-stmt)))) + ((token-is :unless) + (parse-token) + (setf test (parse-sexpr)) + (setf else-stmt (parse-stmt)) + (cons 'unless (cons test (make-statement-list else-stmt))))))) + + +(defun maybe-parse-assignment () + (if (token-is :set) (parse-assignment))) + + +(defun parse-assignment () + ;; first token must be set + (or (token-is :set) (error "parse-assignment internal error")) + (let (assignments rslt vref op expr set-token) + (setf set-token (parse-token)) + (push (parse-assign) assignments) ; returns (target op value) + (while (token-is :co) + (parse-token) ; skip the comma + (push (parse-assign) assignments)) + ; now assignments is ((target op value) (target op value)...) + (dolist (assign assignments) + (setf vref (first assign) op (second assign) expr (third assign)) + (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 `(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)))) + (push (list 'setf vref expr) rslt)) + (setf rslt (add-line-info-to-stmts rslt set-token)) + (if (> (length rslt) 1) + (cons 'progn rslt) + (car rslt)))) + + +;; PARSE-ASSIGN -- based on parse-bind, but with different operators +;; +;; allows arbitrary term on left because it could be an array +;; reference. After parsing, we can check that the target of the +;; assignment is either an identifier or an (aref ...) +;; +(defun parse-assign () + (let ((lhs (parse-term) op val)) + (cond ((token-is '(:= :-= :+= :*= :/= :&= :@= :^= :<= :>=)) + (setf op (parse-token)) + (setf op (if (eq (token-type op) ':=) '= (token-lisp op))) + (setf val (parse-sexpr)))) + (cond ((and (consp lhs) (eq (car lhs) 'aref))) ;; aref good + ((symbolp lhs)) ;; id good + (t (errexit "expected a variable name or array reference"))) + (list lhs op val))) + + +(defun maybe-parse-loop () + (if (token-is :loop) (parse-loop))) + + +;; loops are compiled to do* +;; bindings go next as usual, but bindings include for variables +;; and repeat is converted to a for +count+ from 0 to <sexpr> +;; stepping is done after statement +;; termination clauses are combined with OR and +;; finally goes after termination +;; statement goes in do* body +;; +(defun parse-loop () + (or (token-is :loop) (error "parse-loop: internal error")) + (let (bindings termination-tests stmts sexpr rslt finally + loc + (locals *sal-local-variables*)) + (parse-token) ; skip "loop" + (if (token-is :with) + (setf bindings (reverse (parse-bindings)))) + (while (token-is '(:repeat :for)) + (cond ((token-is :repeat) + (setf loc (parse-token)) + (push (list 'sal:loopcount 0 '(1+ sal:loopcount)) bindings) + (setf sexpr (parse-sexpr loc)) ; get final count expression + (push (list 'sal:loopfinal sexpr) bindings) + (push '(>= sal:loopcount sal:loopfinal) termination-tests)) + ((token-is :for) + (setf rslt (parse-for-clause)) + ; there can be multiple bindings, build bindings in reverse + (cond ((first rslt) + (setf bindings (append (reverse (first rslt)) + bindings)))) + (if (second rslt) (push (second rslt) termination-tests))))) + (while (token-is '(:while :until)) + (cond ((token-is :while) + (setf loc (parse-token)) + (push (list 'not (parse-sexpr loc)) termination-tests)) + ((token-is :until) + (setf loc (parse-token)) + (push (parse-sexpr loc) termination-tests)))) + ; (push (parse-stmt) stmts) + (while (not (token-is '(:end :finally))) + (push (parse-stmt) stmts)) + (cond ((token-is :finally) + (parse-token) ; skip "finally" + (setf finally (parse-stmt)))) + (if (token-is :end) + (parse-token) + (errexit "expected end after loop")) + (setf *sal-local-variables* locals) + `(do* ,(reverse bindings) + ,(list (or-ize (reverse termination-tests)) finally) + ,@(reverse stmts)))) + + +;; OR-IZE -- compute the OR of a list of expressions +;; +(defun or-ize (exprs) + (if (> 1 (length exprs)) (cons 'or exprs) + (car exprs))) + + +(defun maybe-parse-exec () + (if (token-is :exec) (parse-exec))) + + +(defun parse-exec () + (or (token-is :exec) (error "parse-exec internal error")) + (let ((loc (parse-token))) ; skip the :exec + (parse-sexpr loc))) + + +(defun maybe-parse-exit () + (if (token-is :exit) (parse-exit))) + + +(defun parse-exit () + (let (tok loc) + (or (token-is :exit) (error "parse-exit internal error")) + (setf loc (parse-token)) ; skip the :exit + (cond ((token-is :id) + (setf tok (parse-token)) + (cond ((eq (token-lisp tok) 'nyquist) + (add-line-info-to-stmt '(exit) loc)) + ((eq (token-lisp tok) 'sal) + (add-line-info-to-stmt '(sal-exit) loc)) + (t + (errexit "expected \"nyquist\" or \"sal\" after \"exit\"")))) + (t + (add-line-info-to-stmt '(sal-exit) loc))))) + + +;; PARSE-FOR-CLAUSE - returns (bindings term-test) +;; +(defun parse-for-clause () + (or (token-is :for) (error "parse-for-clause: internal error")) + (let (id init next rslt binding term-test list-id loc) + (setf loc (parse-token)) ; skip for + (if (token-is :id) + (setf id (token-lisp (parse-token))) + (errexit "expected identifier after for")) + (cond ((token-is :=) + ;; if the clause is just for id = expr, then assume that + ;; expr depends on something that changes each iteration: + ;; recompute and assign expr to id each time around + (parse-token) ; skip "=" + (setf init (parse-sexpr loc)) + (cond ((token-is :then) + (parse-token) ; skip "then" + (setf binding (list id init (parse-sexpr loc)))) + (t + (setf binding (list id init init)))) + (setf binding (list binding))) + ((token-is :in) + (setf loc (parse-token)) ; skip "in" + (setf list-id (intern (format nil "SAL:~A-LIST" id))) + (setf binding + (list (list list-id (parse-sexpr loc) + (list 'cdr list-id)) + (list id (list 'car list-id) (list 'car list-id)))) + (setf term-test (list 'null list-id))) + ((token-is :over) + (setf loc (parse-token)) ; skip "over" + (setf start (parse-sexpr loc)) +#| (cond ((token-is :by) + (parse-token) ; skip "by" + (parse-sexpr))) ;-- I don't know what "by" means - RBD |# + (setf list-id (intern (format nil "SAL:~A-PATTERN" id))) + (setf binding + (list (list list-id start) + (list id (list 'next list-id) (list 'next list-id))))) + ((token-is '(:from :below :to :above :downto :by)) + (cond ((token-is :from) + (setf loc (parse-token)) ; skip "from" + (setf init (parse-sexpr loc))) + (t + (setf init 0))) + (cond ((token-is :below) + (setf loc (parse-token)) ; skip "below" + (setf term-test (list '>= id (parse-sexpr loc)))) + ((token-is :to) + (setf loc (parse-token)) ; skip "to" + (setf term-test (list '> id (parse-sexpr loc)))) + ((token-is :above) + (setf loc (parse-token)) ; skip "above" + (setf term-test (list '<= id (parse-sexpr loc)))) + ((token-is :downto) + (setf loc (parse-token)) ; skip "downto" + (setf term-test (list '< id (parse-sexpr loc))))) + (cond ((token-is :by) + (setf loc (parse-token)) ; skip "by" + (setf binding (list id init (list '+ id (parse-sexpr loc))))) + ((or (null term-test) + (and term-test (member (car term-test) '(>= >)))) + (setf binding (list id init (list '1+ id)))) + (t ; loop goes down because of "above" or "downto" + ; (display "for step" term-test) + (setf binding (list id init (list '1- id))))) + (setf binding (list binding))) + (t + (errexit "for statement syntax error"))) + (list binding term-test))) + + +;; parse-sexpr works by building a list: (term op term op term ...) +;; later, the list is parsed again using operator precedence rules +(defun parse-sexpr (&optional loc) + (let (term rslt) + (push (parse-term) rslt) + (while (token-is *sal-operators*) + (push (token-type (parse-token)) rslt) + (push (parse-term) rslt)) + (setf rslt (reverse rslt)) + ;(display "parse-sexpr before inf->pre" rslt) + (setf rslt (if (consp (cdr rslt)) + (inf->pre rslt) + (car rslt))) + (if loc + (setf rslt (add-line-info-to-expression rslt loc))) + rslt)) + + +(defun get-lisp-op (op) + (third (assoc op +operators+))) + + +;; a term is <unary-op> <term>, or +;; ( <sexpr> ), or +;; ? ( <sexpr> , <sexpr> , <sexpr> ), or +;; <id>, or +;; <id> ( <args> ), or +;; <term> [ <sexpr> ] +;; Since any term can be followed by indexing, handle everything +;; but the indexing here in parse-term-1, then write parse-term +;; to do term-1 followed by indexing operations +;; +(defun parse-term-1 () + (let (sexpr id) + (cond ((token-is '(:- :!)) + (list (token-lisp (parse-token)) (parse-term))) + ((token-is :lp) + (parse-token) ; skip left paren + (setf sexpr (parse-sexpr)) + (if (token-is :rp) + (parse-token) + (errexit "right parenthesis not found")) + sexpr) + ((token-is :?) + (parse-ifexpr)) + ((token-is :lc) + (list 'quote (parse-list))) + ((token-is '(:int :float :bool :list :string)) + ;(display "parse-term int float bool list string" (car *sal-tokens*)) + (token-lisp (parse-token))) + ((token-is :id) ;; aref or funcall + (setf id (token-lisp (parse-token))) + ;; array indexing was here, but that only allows [x] after + ;; identifiers. Move this to expression parsing. + (cond ((token-is :lp) + (parse-token) + (setf sexpr (cons id (parse-pargs t))) + (if (token-is :rp) + (parse-token) + (errexit "right paren not found")) + sexpr) + (t id))) + (t + (errexit "expression not found"))))) + + +(defun parse-term () + (let ((term (parse-term-1))) + ; (display "parse-term" term (token-is :lb)) + (while (token-is :lb) + (parse-token) + (setf term (list 'aref term (parse-sexpr))) + (if (token-is :rb) + (parse-token) + (errexit "right bracket not found"))) + term)) + + +(defun parse-ifexpr () + (or (token-is :?) (error "parse-ifexpr internal error")) + (let (condition then-sexpr else-sexpr) + (parse-token) ; skip the :? + (if (token-is :lp) (parse-token) (errexit "expected left paren")) + (setf condition (parse-sexpr)) + (if (token-is :co) (parse-token) (errexit "expected comma")) + (setf then-sexpr (parse-sexpr)) + (if (token-is :co) (parse-token) (errexit "expected comma")) + (setf else-sexpr (parse-sexpr)) + (if (token-is :rp) (parse-token) (errexit "expected left paren")) + (list 'if condition then-sexpr else-sexpr))) + + +(defun keywordp (s) + (and (symbolp s) (eq (type-of (symbol-name s)) 'string) + (equal (char (symbol-name s) 0) #\:))) + + +(defun functionp (x) (eq (type-of x) 'closure)) + + +(defun parse-pargs (keywords-allowed) + ;; get a list of sexprs. If keywords-allowed, then at any point + ;; the arg syntax can switch from [<co> <sexpr>]* to + ;; [<co> <keyword> <sexpr>]* + ;; also if keywords-allowed, it's a function call and the + ;; list may be empty. Otherwise, it's a list of indices and + ;; the list may not be empty + (let (pargs keyword-expected sexpr keyword) + (if (and keywords-allowed (token-is :rp)) + nil ; return empty parameter list + (loop ; look for one or more [keyword] sexpr + ; optional keyword test + (setf keyword nil) + ;(display "pargs" (car *sal-tokens*)) + (if (token-is :key) + (setf keyword (token-lisp (parse-token)))) + ; (display "parse-pargs" keyword) + ; did we need a keyword? + (if (and keyword-expected (not keyword)) + (errexit "expected keyword")) + ; was a keyword legal + (if (and keyword (not keywords-allowed)) + (errexit "keyword not allowed here")) + (setf keyword-expected keyword) ; once we get a keyword, we need + ; one before each sexpr + ; now find sexpr + (setf sexpr (parse-sexpr)) + (if keyword (push keyword pargs)) + (push sexpr pargs) + ; (display "parse-pargs" keyword sexpr pargs) + (cond ((token-is :co) + (parse-token)) + (t + (return (reverse pargs)))))))) + + +;; PARSE-LIST -- parse list in braces {}, return list not quoted list +;; +(defun parse-list () + (or (token-is :lc) (error "parse-list internal error")) + (let (elts) + (parse-token) + (while (not (token-is :rc)) + (cond ((token-is '(:int :float :id :bool :key :string)) + (push (token-lisp (parse-token)) elts)) + ((token-is :lc) + (push (parse-list) elts)) + (t + (errexit "expected list element or right brace")))) + (parse-token) + (reverse elts))) + + +(defparameter *op-weights* + '( + (:\| 1) + (:& 2) + (:! 3) + (:= 4) + (:!= 4) + (:> 4) + (:>= 4) + (:< 4) + (:<= 4) + (:~= 4) ; general equality + (:+ 5) + (:- 5) + (:% 5) + (:* 6) + (:/ 6) + (:^ 7) + (:~ 8) + (:~~ 8) + (:@ 8) + (:@@ 8))) + + +(defun is-op? (x) + ;; return op weight if x is operator + (let ((o (assoc (if (listp x) (token-type x) x) + *op-weights*))) + (and o (cadr o)))) + + +(defun inf->pre (inf) + ;; this does NOT rewrite subexpressions because parser applies rules + ;; 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 + (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)) + (t + (push (car inf) li) + (pop inf))))) + (t + (setq lh op)))) + inf))) + diff --git a/runtime/sal.lsp b/runtime/sal.lsp new file mode 100644 index 0000000..def7591 --- /dev/null +++ b/runtime/sal.lsp @@ -0,0 +1,584 @@ +;;; ********************************************************************** +;;; Copyright (C) 2006 Rick Taube +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the Lisp Lesser Gnu Public License. +;;; See http://www.cliki.net/LLGPL for the text of this agreement. +;;; ********************************************************************** + +;;; $Revision: 1.2 $ +;;; $Date: 2009-03-05 17:42:25 $ + +;; DATA STRUCTURES AND ALGORITHMS (for sal.lsp and parse.lsp) +;; +;; TOKENIZE converts source language (a string) into a list of tokens +;; each token is represented as follows: +;; (:TOKEN <type> <string> <start> <info> <lisp>) +;; where <type> is one of: +;; :id -- an identifier +;; :lp -- left paren +;; :rp -- right paren +;; :+, etc. -- operators +;; :int -- an integer +;; :float -- a float +;; :print, etc. -- a reserved word +;; <string> is the source string for the token +;; <start> is the column of the string +;; <info> and <lisp> are ?? +;; Tokenize uses a list of reserved words extracted from terminals in +;; the grammar. Each reserved word has an associated token type, but +;; all other identifiers are simply of type :ID. +;; +;; *** WHY REWRITE THE ORIGINAL PARSER? *** +;; Originally, the code interpreted a grammar using a recursive pattern +;; matcher, but XLISP does not have a huge stack and there were +;; stack overflow problems because even relatively small expressions +;; went through a very deep nesting of productions. E.g. +;; "print note(between(30,odds(.5, 60, 90)))" 0 t nil))" was at recursion +;; level 46 when the stack overflowed. The stack depth is 2000 or 4000, +;; but all locals and parameters get pushed here, so since PARSE is the +;; recursive function and it has lots of parameters and locals, it appears +;; to use 80 elements in the stack per call. +;; *** END *** +;; +;; The grammar for the recursive descent parser: +;; note: [ <x> ] means optional <x>, <x>* means 0 or more of <x> +;; +;; <number> = <int> | <float> +;; <atom> = <int> | <float> | <id> | <bool> +;; <list> = { <elt>* } +;; <elt> = <atom> | <list> | <string> +;; <aref> = <id> <lb> <pargs> <rb> +;; <ifexpr> = ? "(" <sexpr> , <sexpr> [ , <sexpr> ] ")" +;; <funcall> = <id> <funargs> +;; <funargs> = "(" [ <args> ] ")" +;; <args> = <arg> [ , <arg> ]* +;; <arg> = <sexpr> | <key> <sexpr> +;; <op> = + | - | "*" | / | % | ^ | = | != | +;; "<" | ">" | "<=" | ">=" | ~= | ! | & | "|" +;; <mexpr> = <term> [ <op> <term> ]* +;; <term> = <-> <term> | <!> <term> | "(" <mexpr> ")" | +;; <ifexpr> | <funcall> | <aref> | <atom> | <list> | <string> +;; <sexpr> = <mexpr> | <object> | class +;; <top> = <command> | <block> | <conditional> | <assignment> | <loop> | <exec> +;; <exec> = exec <sexpr> +;; <command> = <define-cmd> | <file-cmd> | <output> +;; <define-cmd> = define <declaration> +;; <declaration> = <vardecl> | <fundecl> +;; <vardecl> = variable <bindings> +;; <bindings> = <bind> [ , <bind> ]* +;; <bind> = <id> [ <=> <sexpr> ] +;; <fundecl> = <function> <id> "(" [ <parms> ] ")" <statement> +;; <parms> = <parm> [ , <parm> ]* +;; this is new: key: expression for keyword parameter +;; <parm> = <id> | <key> [ <sexpr> ] +;; <statement> = <block> | <conditional> | <assignment> | +;; <output-stmt> <loop-stmt> <return-from> | <exec> +;; <block> = begin [ with <bindings> [ <statement> ]* end +;; <conditional> = if <sexpr> then [ <statement> ] [ else <statement> ] | +;; when <sexpr> <statement> | unless <sexpr> <statement> +;; <assignment> = set <assign> [ , <assign> ]* +;; <assign> = ( <aref> | <id> ) <assigner> <sexpr> +;; <assigner> = = | += | *= | &= | @= | ^= | "<=" | ">=" +;; <file-cmd> = <load-cmd> | chdir <pathref> | +;; system <pathref> | play <sexpr> +;; (note: system was removed) +;; <load-cmd> = load <pathref> [ , <key> <sexpr> ]* +;; <pathref> = <string> | <id> +;; <output-stmt> = print <sexpr> [ , <sexpr> ]* | +;; output <sexpr> +;; <loop-stmt> = loop [ with <bindings> ] [ <stepping> ]* +;; [ <termination> ]* [ <statement> ]+ +;; [ finally <statement> ] end +;; <stepping> = repeat <sexpr> | +;; for <id> = <sexpr> [ then <sexpr> ] | +;; for <id> in <sexpr> | +;; for <id> over <sexpr> [ by <sexpr> ] | +;; for <id> [ from <sexpr> ] +;; [ ( below | to | above | downto ) <sexpr> ] +;; [ by <sexpr> ] | +;; <termination> = while <sexpr> | until <sexpr> +;; <return-from> = return <sexpr> + +;(in-package cm) + +; (progn (cd "/Lisp/sal/") (load "parse.lisp") (load "sal.lisp")) + +(setfn defconstant setf) +(setfn defparameter setf) +(setfn defmethod defun) +(setfn defvar setf) +(setfn values list) +(if (not (boundp '*sal-secondary-prompt*)) + (setf *sal-secondary-prompt* t)) +(if (not (boundp '*sal-xlispbreak*)) + (setf *sal-xlispbreak* nil)) + +(defun sal-trace-enter (fn &optional argvals argnames) + (push (list fn *sal-line* argvals argnames) *sal-call-stack*)) + +(defun sal-trace-exit () + (setf *sal-line* (second (car *sal-call-stack*))) + (pop *sal-call-stack*)) + +;; SAL-RETURN-FROM is generated by Sal compiler and +;; performs a return as well as a sal-trace-exit() +;; +(defmacro sal-return-from (fn val) + `(prog ((sal:return-value ,val)) + (setf *sal-line* (second (car *sal-call-stack*))) + (pop *sal-call-stack*) + (return-from ,fn sal:return-value))) + + +(setf *sal-traceback* t) + + +(defun sal-traceback (&optional (file t) + &aux comma name names line) + (format file "Call traceback:~%") + (setf line *sal-line*) + (dolist (frame *sal-call-stack*) + (setf comma "") + (format file " ~A" (car frame)) + (cond ((symbolp (car frame)) + (format file "(") + (setf names (cadddr frame)) + (dolist (arg (caddr frame)) + (setf name (car names)) + (format file "~A~% ~A = ~A" comma name arg) + (setf names (cdr names)) + (setf comma ",")) + (format file ") at line ~A~%" line) + (setf line (second frame))) + (t + (format file "~%"))))) + + +'(defmacro defgrammer (sym rules &rest args) + `(defparameter ,sym + (make-grammer :rules ',rules ,@args))) + +'(defun make-grammer (&key rules literals) + (let ((g (list 'a-grammer rules literals))) + (grammer-initialize g) + g)) + +'(defmethod grammer-initialize (obj) + (let (xlist) + ;; each literal is (:name "name") + (cond ((grammer-literals obj) + (dolist (x (grammer-literals obj)) + (cond ((consp x) + (push x xlist)) + (t + (push (list (string->keyword (string-upcase (string x))) + (string-downcase (string x))) + xlist))))) + (t + (dolist (x (grammer-rules obj)) + (cond ((terminal-rule? x) + (push (list (car x) + (string-downcase (subseq (string (car x)) 1))) + xlist)))))) + (set-grammer-literals obj (reverse xlist)))) + +'(setfn grammer-rules cadr) +'(setfn grammer-literals caddr) +'(defun set-grammer-literals (obj val) + (setf (car (cddr obj)) val)) +'(defun is-grammer (obj) (and (consp obj) (eq (car obj) 'a-grammer))) + +(defun string->keyword (str) + (intern (strcat ":" (string-upcase str)))) + +(defun terminal-rule? (rule) + (or (null (cdr rule)) (not (cadr rule)))) + +(load "sal-parse.lsp" :verbose nil) + +(defparameter *sal-print-list* t) + +(defun sal-printer (x &key (stream *standard-output*) (add-space t) + (in-list nil)) + (let ((*print-case* ':downcase)) + (cond ((and (consp x) *sal-print-list*) + (write-char #\{ stream) + (do ((items x (cdr items))) + ((null items)) + (sal-printer (car items) :stream stream + :add-space (cdr items) :in-list t) + (cond ((cdr items) + (cond ((not (consp (cdr items))) + (princ "<list not well-formed> " stream) + (sal-printer (cdr items) :stream stream :add-space nil) + (setf items nil)))))) + (write-char #\} stream)) + ((not x) (princ "#f" stream) ) + ((eq x t) (princ "#t" stream)) + (in-list (prin1 x stream)) + (t (princ x stream))) + (if add-space (write-char #\space stream)))) + +(defparameter *sal-printer* #'sal-printer) + +(defun sal-message (string &rest args) + (format t "~&; ") + (apply #'format t string args)) + + +;; sal-print has been modified from the original SAL to print items separated +;; by spaces (no final trailing space) and followed by a newline. +(defun sal-print (&rest args) + (do ((items args (cdr items))) + ((null items)) + ;; add space unless we are at the last element + (funcall *sal-printer* (car items) :add-space (cdr items))) + (terpri) + (values)) + +(defmacro keyword (sym) + `(str-to-keyword (symbol-name ',sym))) + +(defun plus (&rest nums) + (apply #'+ nums)) + +(defun minus (num &rest nums) + (apply #'- num nums)) + +(defun times (&rest nums) + (apply #'* nums)) + +(defun divide (num &rest nums) + (apply #'/ num nums)) + +;; implementation of infix "!=" operator +(defun not-eql (x y) + (not (eql x y))) + +; dir "*.* +; chdir +; load "rts.sys" + +(defun sal-chdir ( dir) + (cd (expand-path-name dir)) + (sal-message "Directory: ~A" (pwd)) + (values)) + +;;; sigh, not all lisps support ~/ directory components. + +(defun expand-path-name (path &optional absolute?) + (let ((dir (pathname-directory path))) + (flet ((curdir () + (truename + (make-pathname :directory + (pathname-directory + *default-pathname-defaults*))))) + (cond ((null dir) + (if (equal path "~") + (namestring (user-homedir-pathname)) + (if absolute? + (namestring (merge-pathnames path (curdir))) + (namestring path)))) + ((eql (car dir) ':absolute) + (namestring path)) + (t + (let* ((tok (second dir)) + (len (length tok))) + (if (char= (char tok 0) #\~) + (let ((uhd (pathname-directory (user-homedir-pathname)))) + (if (= len 1) + (namestring + (make-pathname :directory (append uhd (cddr dir)) + :defaults path)) + (namestring + (make-pathname :directory + (append (butlast uhd) + (list (subseq tok 1)) + (cddr dir)) + :defaults path)))) + (if absolute? + (namestring (merge-pathnames path (curdir))) + (namestring path))))))))) + + +(defun sal-load (filename &key (verbose t) print) + (progv '(*sal-input-file-name*) (list filename) + (prog (file extended-name) + ;; first try to load exact name + (cond ((setf file (open filename)) + (close file) ;; found it: close it and load it + (return (generic-loader filename verbose print)))) + ;; try to load name with ".sal" or ".lsp" + (cond ((string-search "." filename) ; already has extension + nil) ; don't try to add another extension + ((setf file (open (strcat filename ".sal"))) + (close file) + (return (sal-loader (strcat filename ".sal") + :verbose verbose :print print))) + ((setf file (open (strcat filename ".lsp"))) + (close file) + (return (lisp-loader filename :verbose verbose :print print)))) + ;; search for file as is or with ".lsp" on path + (setf fullpath (find-in-xlisp-path filename)) + (cond ((and (not fullpath) ; search for file.sal on path + (not (string-search "." filename))) ; no extension yet + (setf fullpath (find-in-xlisp-path (strcat filename ".sal"))))) + (cond ((null fullpath) + (format t "sal-load: could not find ~A~%" filename)) + (t + (return (generic-loader filename verbose print))))))) + + +;; GENERIC-LOADER -- load a sal or lsp file based on extension +;; +;; assumes that file exists, and if no .sal extension, type is Lisp +;; +(defun generic-loader (fullpath verbose print) + (cond ((has-extension fullpath ".sal") + (sal-loader fullpath :verbose verbose :print print)) + (t + (lisp-loader fullpath :verbose verbose :print print)))) + +#| +(defun sal-load (filename &key (verbose t) print) + (progv '(*sal-input-file-name*) (list filename) + (let (file extended-name) + (cond ((has-extension filename ".sal") + (sal-loader filename :verbose verbose :print print)) + ((has-extension filename ".lsp") + (lisp-load filename :verbose verbose :print print)) + ;; see if we can just open the exact filename and load it + ((setf file (open filename)) + (close file) + (lisp-load filename :verbose verbose :print print)) + ;; if not, then try loading file.sal and file.lsp + ((setf file (open (setf *sal-input-file-name* + (strcat filename ".sal")))) + (close file) + (sal-loader *sal-input-file-name* :verbose verbose :print print)) + ((setf file (open (setf *sal-input-file-name* + (strcat filename ".lsp")))) + (close file) + (lisp-load *sal-input-file-name* :verbose verbose :print print)) + (t + (format t "sal-load: could not find ~A~%" filename)))))) +|# + +(defun lisp-loader (filename &key (verbose t) print) + (if (load filename :verbose verbose :print print) + nil ; be quiet if things work ok + (format t "error loading lisp file ~A~%" filename))) + + +(defun has-extension (filename ext) + (let ((loc (string-search ext filename + :start (max 0 (- (length filename) + (length ext)))))) + (not (null loc)))) ; coerce to t or nil + + +(defmacro sal-at (s x) (list 'at x s)) +(defmacro sal-at-abs (s x) (list 'at-abs x s)) +(defmacro sal-stretch (s x) (list 'stretch x s)) +(defmacro sal-stretch-abs (s x) (list 'stretch-abs x s)) + +;; splice every pair of lines +(defun strcat-pairs (lines) + (let (rslt) + (while lines + (push (strcat (car lines) (cadr lines)) rslt) + (setf lines (cddr lines))) + (reverse rslt))) + + +(defun strcat-list (lines) + ;; like (apply 'strcat lines), but does not use a lot of stack + ;; When there are too many lines, XLISP will overflow the stack + ;; because args go on the stack. + (let (r) + (while (> (setf len (length lines)) 1) + (if (oddp len) (setf lines (cons "" lines))) + (setf lines (strcat-pairs lines))) + ; if an empty list, return "", else list has one string: return it + (if (null lines) "" (car lines)))) + + +(defun sal-loader (filename &key verbose print) + (let ((input "") (file (open filename)) line lines) + (cond (file + (push filename *loadingfiles*) + (while (setf line (read-line file)) + (push line lines) + (push "\n" lines)) + (close file) + (setf input (strcat-list (reverse lines))) + (sal-trace-enter (strcat "Loading " filename)) + (sal-compile input t t filename) + (pop *loadingfiles*) + (sal-trace-exit)) + (t + (format t "error loading SAL file ~A~%" filename))))) + + +; SYSTEM command is not implemented +;(defun sal-system (sys &rest pairs) +; (apply #'use-system sys pairs)) + + +(defun load-sal-file (file) + (with-open-file (f file :direction :input) + (let ((input (make-array '(512) :element-type 'character + :fill-pointer 0 :adjustable t))) + (loop with flag + for char = (read-char f nil ':eof) + until (or flag (eql char ':eof)) + do + (when (char= char #\;) + (loop do (setq char (read-char f nil :eof)) + until (or (eql char :eof) + (char= char #\newline)))) + (unless (eql char ':eof) + (vector-push-extend char input))) + (sal input :pattern :command-sequence)))) + + +(defmacro sal-play (snd) + (if (stringp snd) `(play-file ,snd) + `(play ,snd))) + + +(if (not (boundp '*sal-compiler-debug*)) + (setf *sal-compiler-debug* nil)) + + +(defmacro sal-simrep (variable iterations body) + `(simrep (,variable ,iterations) ,body)) + + +(defmacro sal-seqrep (variable iterations body) + `(seqrep (,variable ,iterations) ,body)) + + +;; function called in sal programs to exit the sal read-compile-run-print loop +(defun sal-exit () (setf *sal-exit* t)) + +(setf *sal-call-stack* nil) + +;; read-eval-print loop for sal commands +(defun sal () + (progv '(*breakenable* *tracenable* *sal-exit* *sal-mode*) + (list *sal-break* nil nil t) + (let (input line) + (setf *sal-call-stack* nil) + (read-line) ; read the newline after the one the user + ; typed to invoke this fn + (princ "Entering SAL mode ...\n"); + (while (not *sal-exit*) + (princ "\nSAL> ") + (sal-trace-enter "SAL top-level command interpreter") + ;; get input terminated by two returns + (setf input "") + (while (> (length (setf line (read-line))) 0) + (if *sal-secondary-prompt* (princ " ... ")) + (setf input (strcat input "\n" line))) + ;; input may have an extra return, remaining from previous read + ;; if so, trim it because it affects line count in error messages + (if (and (> (length input) 0) (char= (char input 0) #\newline)) + (setf input (subseq input 1))) + (sal-compile input t nil "<console>") + (sal-trace-exit)) + (princ "Returning to Lisp ...\n"))) + ;; in case *xlisp-break* or *xlisp-traceback* was set from SAL, impose + ;; them here + (cond ((not *sal-mode*) + (setf *breakenable* *xlisp-break*) + (setf *tracenable* *xlisp-traceback*))) + t) + + + +(defun sal-error-output (stack) + (if *sal-traceback* (sal-traceback)) + (setf *sal-call-stack* stack)) ;; clear the stack + + +;; when true, top-level return statement is legal and compiled into MAIN +(setf *audacity-top-level-return-flag* nil) + +;; SAL-COMPILE-AUDACITY -- special treatment of RETURN +;; +;; This works like SAL-COMPILE, but if there is a top-level +;; return statement (not normally legal), it is compiled into +;; a function named MAIN. This is a shorthand for Audacity plug-ins +;; +(defun sal-compile-audacity (input eval-flag multiple-statements filename) + (progv '(*audacity-top-level-return-flag*) '(t) + (sal-compile input eval-flag multiple-statements filename))) + + +;; SAL-COMPILE -- translate string or token list to lisp and eval +;; +;; input is either a string or a token list +;; eval-flag tells whether to evaluate the program or return the lisp +;; multiple-statements tells whether the input can contain multiple +;; top-level units (e.g. from a file) or just one (from command line) +;; returns: +;; if eval-flag, then nothing is returned +;; otherwise, returns nil if an error is encountered +;; otherwise, returns a list (PROGN p1 p2 p3 ...) where pn are lisp +;; expressions +;; +(defun sal-compile (input eval-flag multiple-statements filename) + ;; save some globals because eval could call back recursively + (progv '(*sal-tokens* *sal-input* *sal-input-text*) '(nil nil nil) + (let (output remainder rslt stack) + (setf stack *sal-call-stack*) + ;; if first input char is "(", then eval as a lisp expression: + ;(display "sal-compile" input)(setf *sal-compiler-debug* t) + (cond ((input-starts-with-open-paren input) + ;(print "input is lisp expression") + (errset + (print (eval (read (make-string-input-stream input)))) t)) + (t ;; compile SAL expression(s): + (loop + (setf output (sal-parse nil nil input multiple-statements + filename)) + (cond ((first output) ; successful parse + (setf remainder *sal-tokens*) + (setf output (second output)) + (when *sal-compiler-debug* + (terpri) + (pprint output)) + (cond (eval-flag ;; evaluate the compiled code + (cond ((null (errset (eval output) t)) + (sal-error-output stack) + (return)))) ;; stop on error + (t + (push output rslt))) + ;(display "sal-compile after eval" + ; remainder *sal-tokens*) + ;; if there are statements left over, maybe compile again + (cond ((and multiple-statements remainder) + ;; move remainder to input and iterate + (setf input remainder)) + ;; see if we've compiled everything + ((and (not eval-flag) (not remainder)) + (return (cons 'progn (reverse rslt)))) + ;; if eval but no more input, return + ((not remainder) + (return)))) + (t ; error encountered + (return))))))))) + +;; SAL just evaluates lisp expression if it starts with open-paren, +;; but sometimes reader reads previous newline(s), so here we +;; trim off initial newlines and check if first non-newline is open-paren +(defun input-starts-with-open-paren (input) + (let ((i 0)) + (while (and (stringp input) + (> (length input) i) + (eq (char input i) #\newline)) + (incf i)) + (and (stringp input) + (> (length input) i) + (eq (char input i) #\()))) diff --git a/runtime/seq.lsp b/runtime/seq.lsp new file mode 100644 index 0000000..947c63e --- /dev/null +++ b/runtime/seq.lsp @@ -0,0 +1,252 @@ +;; seq.lsp -- sequence control constructs for Nyquist + +;; get-srates -- this either returns the sample rate of a sound or a +;; vector of sample rates of a vector of sounds +;; +(defun get-srates (sounds) + (cond ((arrayp sounds) + (let ((result (make-array (length sounds)))) + (dotimes (i (length sounds)) + (setf (aref result i) (snd-srate (aref sounds i)))) + result)) + (t + (snd-srate sounds)))) + +; These are complex macros that implement sequences of various types. +; The complexity is due to the fact that a behavior within a sequence +; can reference the environment, e.g. (let ((p 60)) (seq (osc p) (osc p))) +; is an example where p must be in the environment of each member of +; the sequence. Since the execution of the sequence elements are delayed, +; the environment must be captured and then used later. In XLISP, the +; EVAL function does not execute in the current environment, so a special +; EVAL, EVALHOOK must be used to evaluate with an environment. Another +; feature of XLISP (see evalenv.lsp) is used to capture the environment +; when the seq is first evaluated, so that the environment can be used +; later. Finally, it is also necessary to save the current transformation +; environment until later. + +(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)) + (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))))))) + (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)) + (with%environment ',(nyq:the-environment) + (at-abs t0 + (force-srate s%rate ,(cadr list)))))))))) + + (t + `(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) + (seq-iterate ,(cdr list)))))))))) + +(defun envdepth (e) (length (car e))) + +(defmacro myosd (pitch) + `(let () (format t "myosc env depth is ~A~%" + (envdepth (getenv))) (osc ,pitch))) + +(defmacro seq-iterate (behavior-list) + (cond ((null (cdr behavior-list)) + `(eval-seq-behavior ,(car behavior-list))) + (t + `(snd-seq (eval-seq-behavior ,(car behavior-list)) + (evalhook '#'(lambda (t0) + ; (format t "lambda depth ~A~%" (envdepth (getenv))) + (seq-iterate ,(cdr behavior-list))) + nil nil seq%environment))))) + +(defmacro multiseq-iterate (behavior-list) + (cond ((null (cdr behavior-list)) + `(eval-multiseq-behavior ,(car behavior-list))) + (t + `(snd-multiseq (eval-multiseq-behavior ,(car behavior-list)) + (evalhook '#'(lambda (t0) + ; (format t "lambda depth ~A~%" (envdepth (getenv))) + (multiseq-iterate ,(cdr behavior-list))) + nil nil seq%environment))))) + +(defmacro eval-seq-behavior (beh) + `(with%environment nyq%environment + (at-abs t0 + (force-srate s%rate ,beh)))) + +(defmacro eval-multiseq-behavior (beh) + `(with%environment nyq%environment +; (display "MULTISEQ 2" t0) + (at-abs t0 + (force-srates s%rate ,beh)))) + +(defmacro with%environment (env &rest expr) + `(progv ',*environment-variables* ,env ,@expr)) + + + +(defmacro seqrep (pair sound) + `(let ((,(car pair) 0) + (loop%count ,(cadr pair)) + (nyq%environment (nyq:the-environment)) + seqrep%closure first%sound s%rate) + ; note: s%rate will tell whether we want a single or multichannel + ; sound, and what the sample rates should be. + (cond ((not (integerp loop%count)) + (error "bad argument type" loop%count)) + (t + (setf seqrep%closure #'(lambda (t0) +; (display "SEQREP" loop%count ,(car pair)) + (cond ((< ,(car pair) loop%count) + (setf first%sound + (with%environment nyq%environment + (at-abs t0 ,sound))) + ; (display "seqrep" s%rate nyq%environment ,(car pair) + ; loop%count) + (if s%rate + (setf first%sound (force-srates s%rate first%sound)) + (setf s%rate (get-srates first%sound))) + (setf ,(car pair) (1+ ,(car pair))) + ; note the following test is AFTER the counter increment + (cond ((= ,(car pair) loop%count) +; (display "seqrep: computed the last sound at" +; ,(car pair) loop%count +; (local-to-global 0)) + first%sound) ;last sound + ((arrayp s%rate) +; (display "seqrep: calling snd-multiseq at" +; ,(car pair) loop%count (local-to-global 0) +; (snd-t0 (aref first%sound 0))) + (snd-multiseq (prog1 first%sound + (setf first%sound nil)) + seqrep%closure)) + (t +; (display "seqrep: calling snd-seq at" +; ,(car pair) loop%count (local-to-global 0) +; (snd-t0 first%sound)) + (snd-seq (prog1 first%sound + (setf first%sound nil)) + seqrep%closure)))) + (t (snd-zero (warp-time *WARP*) *sound-srate*))))) + (funcall seqrep%closure (local-to-global 0)))))) + + +(defmacro trigger (input beh) + `(let ((nyq%environment (nyq:the-environment))) + (snd-trigger ,input #'(lambda (t0) (with%environment nyq%environment + (at-abs t0 ,beh)))))) + +;; EVENT-EXPRESSION -- the sound of the event +;; +(setfn event-expression caddr) + + +;; EVENT-HAS-ATTR -- test if event has attribute +;; +(defun event-has-attr (note attr) + (expr-has-attr (event-expression note))) + + +;; EXPR-SET-ATTR -- new expression with attribute = value +;; +(defun expr-set-attr (expr attr value) + (cons (car expr) (list-set-attr-value (cdr expr) attr value))) + +(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)))))) + + +;; EXPAND-AND-EVAL-EXPR -- evaluate a note, chord, or rest for timed-seq +;; +(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))))) + + +;; (timed-seq '((time1 stretch1 expr1) (time2 stretch2 expr2) ...)) +;; a timed-seq takes a list of events as shown above +;; it sums the behaviors, similar to +;; (sim (at time1 (stretch stretch1 expr1)) ...) +;; but the implementation avoids starting all expressions at once +;; +;; Notes: (1) the times must be in increasing order +;; (2) EVAL is used on each event, so events cannot refer to parameters +;; or local variables +;; +(defun timed-seq (score) + ; check to insure that times are strictly increasing and >= 0 and stretches are >= 0 + (let ((start-time 0) error-msg) + (dolist (event score) + (cond ((< (car event) start-time) + (error (format nil "Out-of-order time in TIMED-SEQ: ~A" event))) + ((< (cadr event) 0) + (error (format nil "Negative stretch factor in TIMED-SEQ: ~A" event))) + (t + (setf start-time (car event))))) + ;; remove rests (a rest has a :pitch attribute of nil) + (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 + (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))))))))))) + + + diff --git a/runtime/seqfnint.lsp b/runtime/seqfnint.lsp new file mode 100644 index 0000000..269fbb7 --- /dev/null +++ b/runtime/seqfnint.lsp @@ -0,0 +1,31 @@ + + (setfn seq-tag first) + (setfn seq-time second) + (setfn seq-line third) + (setfn seq-channel fourth) + (defun seq-value1 (e) (nth 4 e)) + (setfn seq-pitch seq-value1) ; pitch of a note + (setfn seq-control seq-value1) ; control number of a control change + (setfn seq-program seq-value1) ; program number of a program change + (setfn seq-bend seq-value1) ; pitch bend amount + (setfn seq-touch seq-value1) ; aftertouch amount + (defun seq-value2 (e) (nth 5 e)) + (setfn seq-velocity seq-value2) ; velocity of a note + (setfn seq-value seq-value2) ; value of a control change + (defun seq-duration (e) (nth 6 e)) + + + (setf seq-done-tag 0) + + (setf seq-other-tag 1) + + (setf seq-note-tag 2) + + (setf seq-ctrl-tag 3) + + (setf seq-prgm-tag 4) + + (setf seq-touch-tag 5) + + (setf seq-bend-tag 6) + diff --git a/runtime/seqmidi.lsp b/runtime/seqmidi.lsp new file mode 100644 index 0000000..686f018 --- /dev/null +++ b/runtime/seqmidi.lsp @@ -0,0 +1,159 @@ +;; seqmidi.lsp -- functions to use MIDI files in Nyquist +; +; example call: +; +; (seq-midi my-seq +; (note (chan pitch velocity) (= chan 2) (my-note pitch velocity)) +; (ctrl (chan control value) (...)) +; (bend (chan value) (...)) +; (touch (chan value) (...)) +; (prgm (chan value) (setf (aref my-prgm chan) value)) + +;; seq-midi - a macro to create a sequence of sounds based on midi file +; +; +(defmacro seq-midi (the-seq &rest cases) + (seq-midi-cases-syntax-check cases) + `(let (_the-event _next-time _the-seq _seq-midi-closure _nyq-environment + _the-seq _tag) + (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) + (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 + (setf _the-event (seq-get _the-seq)) + ; (display "seq-midi" _the-event t0) + (setf _tag (seq-tag _the-event)) + (cond ((= _tag seq-ctrl-tag) + ,(make-ctrl-handler cases)) + ((= _tag seq-bend-tag) + ,(make-bend-handler cases)) + ((= _tag seq-touch-tag) + ,(make-touch-handler cases)) + ((= _tag seq-prgm-tag) + ,(make-prgm-handler cases)) + ((= _tag seq-done-tag) + ; (format t "_seq_midi_closure: seq-done") + (cond (_the-sound ; this is the last sound of sequence + ; (format t "returning _the-sound~%") + (return _the-sound)) + (t ; sequence is empty, return silence + ; (format t "returning snd-zero~%") + (return (snd-zero t0 *sound-srate*))))) + ((and (= _tag seq-note-tag) + ,(make-note-test cases)) + (cond (_the-sound ; we now have time of next note + (setf _next-time (/ (seq-time _the-event) 1000.0)) + (go exit-loop)) + (t + (setf _the-sound ,(make-note-handler cases)))))) + (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") + (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)) + (funcall _seq-midi-closure (local-to-global 0)))) + + +(defun seq-midi-cases-syntax-check (cases &aux n) + (cond ((not (listp cases)) + (break "syntax error in" cases))) + (dolist (case cases) + (cond ((or (not (listp case)) + (not (member (car case) '(NOTE CTRL BEND TOUCH PRGM))) + (not (listp (cdr case))) + (not (listp (cadr case))) + (not (listp (cddr case))) + (not (listp (last (cddr case))))) + (break "syntax error in" case)) + ((/= (length (cadr case)) + (setf n (cdr (assoc (car case) + '((NOTE . 3) (CTRL . 3) (BEND . 2) + (TOUCH . 2) (PRGM . 2)))))) + (break (format nil "expecting ~A arguments in" n) case)) + ((and (eq (car case) 'NOTE) + (not (member (length (cddr case)) '(1 2)))) + (break + "note handler syntax is (NOTE (ch pitch vel) [filter] behavior)" + case))))) + + +(defun make-ctrl-handler (cases) + (let ((case (assoc 'ctrl cases))) + (cond (case + `(let ((,(caadr case) (seq-channel _the-event)) + (,(cadadr case) (seq-control _the-event)) + (,(caddar (cdr case)) (seq-value _the-event))) + ,@(cddr case))) + (t nil)))) + +(defun make-bend-handler (cases) + (let ((case (assoc 'bend cases))) + (cond (case + `(let ((,(caadr case) (seq-channel _the-event)) + (,(cadadr case) (seq-value _the-event))) + ,@(cddr case))) + (t nil)))) + +(defun make-touch-handler (cases) + (let ((case (assoc 'touch cases))) + (cond (case + `(let ((,(caadr case) (seq-channel _the-event)) + (,(cadadr case) (seq-value _the-event))) + ,@(cddr case))) + (t nil)))) + +(defun make-prgm-handler (cases) + (let ((case (assoc 'pgrm cases))) + (cond (case + `(let ((,(caadr case) (seq-channel _the-event)) + (,(cadadr case) (seq-value _the-event))) + ,@(cddr case))) + (t nil)))) + +(defun make-note-test (cases) + (let ((case (assoc 'note cases))) + (cond ((and case (cdddr case)) + (caddr case)) + (t t)))) + + +(defun make-note-handler (cases) + (let ((case (assoc 'note cases)) + behavior) + (cond ((and case (cdddr case)) + (setf behavior (cadddr case))) + (t + (setf behavior (caddr case)))) + `(with%environment _nyq-environment + (with-note-args ,(cadr case) _the-event ,behavior)))) + + +(defmacro with-note-args (note-args the-event note-behavior) + ; (display "with-note-args" the-event) + `(let ((,(car note-args) (seq-channel ,the-event)) + (,(cadr note-args) (seq-pitch ,the-event)) + (,(caddr note-args) (seq-velocity ,the-event))) + (at (/ (seq-time ,the-event) 1000.0) + (stretch (/ (seq-duration ,the-event) 1000.0) ,note-behavior)))) + + +;(defun seq-next-note-time (the-seq find-first-flag) +; (prog (event) +; (if find-first-flag nil (seq-next the-seq)) +;loop +; (setf event (seq-get the-seq)) +; (cond ((eq (seq-tag event) seq-done-tag) +; (return (if find-first-flag 0.0 nil))) +; ((eq (seq-tag event) seq-note-tag) +; (return (/ (seq-time event) 1000.0)))) +; (seq-next the-seq) +; (go loop))) +; diff --git a/runtime/sndfnint.lsp b/runtime/sndfnint.lsp new file mode 100644 index 0000000..83c897c --- /dev/null +++ b/runtime/sndfnint.lsp @@ -0,0 +1,86 @@ + (setf snd-head-none 0) + + (setf snd-head-AIFF 1) + + (setf snd-head-IRCAM 2) + + (setf snd-head-NeXT 3) + + (setf snd-head-Wave 4) + + (setf snd-head-PAF 5) + + (setf snd-head-SVX 6) + + (setf snd-head-NIST 7) + + (setf snd-head-VOC 8) + + (setf snd-head-W64 9) + + (setf snd-head-MAT4 10) + + (setf snd-head-MAT5 11) + + (setf snd-head-PVF 12) + + (setf snd-head-XI 13) + + (setf snd-head-HTK 14) + + (setf snd-head-SDS 15) + + (setf snd-head-AVR 16) + + (setf snd-head-SD2 17) + + (setf snd-head-FLAC 18) + + (setf snd-head-CAF 19) + + (setf snd-head-raw 20) + + (setf snd-head-channels 1) + + (setf snd-head-mode 2) + + (setf snd-head-bits 4) + + (setf snd-head-srate 8) + + (setf snd-head-dur 16) + + (setf snd-head-latency 32) + + (setf snd-head-type 64) + + (setf snd-mode-adpcm 0) + + (setf snd-mode-pcm 1) + + (setf snd-mode-ulaw 2) + + (setf snd-mode-alaw 3) + + (setf snd-mode-float 4) + + (setf snd-mode-upcm 5) + + (setf snd-mode-unknown 6) + + (setf snd-mode-double 7) + + (setf snd-mode-GSM610 8) + + (setf snd-mode-DWVW 9) + + (setf snd-mode-DPCM 10) + + (setf snd-mode-msadpcm 11) + + (SETF MAX-STOP-TIME 10E20) + + (SETF MIN-START-TIME -10E20) + + (setf OP-AVERAGE 1) (setf OP-PEAK 2) + diff --git a/runtime/stk.lsp b/runtime/stk.lsp new file mode 100644 index 0000000..6ba7e55 --- /dev/null +++ b/runtime/stk.lsp @@ -0,0 +1,189 @@ +;; stk.lsp -- STK-based instruments +;; +;; currently clarinet and saxophony are implemented + +(defun instr-parameter (parm) + ;; coerce parameter into a *sound-srate* signal + (cond ((numberp parm) + (stretch 30 (control-srate-abs *sound-srate* (const (float parm))))) + (t + (force-srate *sound-srate* parm)))) + + +(defun clarinet (step breath-env) + (snd-clarinet (step-to-hz step) (force-srate *sound-srate* breath-env) *sound-srate*)) + + +(defun clarinet-freq (step breath-env freq-env) + ;; note that the parameters are in a different order -- I defined + ;; clarinet-freq this way so that the first two parameters are always + ;; step and breath. I didn't redo snd-clarinet-freq. + (snd-clarinet_freq (step-to-hz step) + (instr-parameter breath-env) + (instr-parameter freq-env) + *sound-srate*)) + + + +(defun clarinet-all (step breath-env freq-env vibrato-freq vibrato-gain reed-stiffness noise) + ;; note that the parameters are not in the same order as snd-clarinet-all + (setf breath-env (instr-parameter breath-env)) + (setf freq-env (instr-parameter freq-env)) + (setf reed-stiffness (instr-parameter reed-stiffness)) + (setf noise (instr-parameter noise)) + (snd-clarinet_all (step-to-hz step) + breath-env freq-env + ;; STK scales 1.0 to 12Hz. Scale here so vibrato-freq is in Hz + (/ vibrato-freq 12.0) vibrato-gain + reed-stiffness noise + *sound-srate*)) + + +(defun sax (step breath-env) + (snd-sax (step-to-hz step) (force-srate *sound-srate* breath-env) *sound-srate*)) + +(defun sax-freq (step breath-env freq-env) + (snd-sax_freq (step-to-hz step) + (instr-parameter breath-env) + (instr-parameter freq-env) + *sound-srate*)) + +(defun sax-all (step breath-env freq-env vibrato-freq vibrato-gain reed-stiffness noise blow-pos reed-table-offset) + (snd-sax_all (step-to-hz step) + (instr-parameter freq-env) + (instr-parameter breath-env) + (instr-parameter (/ vibrato-freq 12.0)) + (instr-parameter vibrato-gain) + (instr-parameter reed-stiffness) + (instr-parameter noise) + (instr-parameter blow-pos) + (instr-parameter reed-table-offset) + *sound-srate*) +) + +; instr-parameter already defined in stk.lsp + +(defun flute (step breath-env) + (snd-flute (step-to-hz step) (force-srate *sound-srate* breath-env) *sound-srate*)) + +(defun flute-freq (step breath-env freq-env) + (snd-flute_freq (step-to-hz step) + (instr-parameter breath-env) + (instr-parameter freq-env) + *sound-srate*)) + +(defun flute-all (step breath-env freq-env vibrato-freq vibrato-gain jet-delay noise) + ;; note that the parameters are not in the same order as snd-clarinet-all + (setf breath-env (instr-parameter breath-env)) + (setf freq-env (instr-parameter freq-env)) + (setf jet-delay (instr-parameter jet-delay)) + (setf noise (instr-parameter noise)) + (snd-flute_all (step-to-hz step) + breath-env freq-env + ;; STK scales 1.0 to 12Hz. Scale here so vibrato-freq is in Hz + (/ vibrato-freq 12.0) vibrato-gain + jet-delay noise + *sound-srate*)) + + +(defun bowed (step bowpress-env) + (snd-bowed (step-to-hz step) (force-srate *sound-srate* bowpress-env) *sound-srate*)) + +(defun bowed-freq (step bowpress-env freq-env) + (snd-bowed_freq (step-to-hz step) + (instr-parameter bowpress-env) + (instr-parameter freq-env) + *sound-srate*)) + +(defun mandolin (step dur &optional (detune 4.0)) + (let ((d (get-duration dur))) + (snd-mandolin *rslt* (step-to-hz step) d 1.0 detune *sound-srate*))) + +(defun wg-uniform-bar (step bowpress-env) + (snd-bandedwg (step-to-hz step) (force-srate *sound-srate* bowpress-env) 0 *sound-srate*)) + +(defun wg-tuned-bar (step bowpress-env) + (snd-bandedwg (step-to-hz step) (force-srate *sound-srate* bowpress-env) 1 *sound-srate*)) + +(defun wg-glass-harm (step bowpress-env) + (snd-bandedwg (step-to-hz step) (force-srate *sound-srate* bowpress-env) 2 *sound-srate*)) + +(defun wg-tibetan-bowl (step bowpress-env) + (snd-bandedwg (step-to-hz step) (force-srate *sound-srate* bowpress-env) 3 *sound-srate*)) + +(defun modalbar (preset step duration) + (let ((preset (case preset + (MARIMBA 0) + (VIBRAPHONE 1) + (AGOGO 2) + (WOOD1 3) + (RESO 4) + (WOOD2 5) + (BEATS 6) + (TWO-FIXED 7) + (CLUMP 8) + (t (error (format nil "Unknown preset for modalbar %A" preset))))) + (d (get-duration duration))) + (snd-modalbar *rslt* (step-to-hz step) preset d *sound-srate*))) + +(defun sitar (step dur) + (let ((d (get-duration dur))) + (snd-sitar *rslt* (step-to-hz step) d *sound-srate*))) + +(defun nyq:nrev (snd rev-time mix) + (snd-stkrev 0 snd rev-time mix *sound-srate*)) + +(defun nyq:jcrev (snd rev-time mix) + (snd-stkrev 1 snd rev-time mix *sound-srate*)) + +(defun nyq:prcrev (snd rev-time mix) + (snd-stkrev 2 snd rev-time mix *sound-srate*)) + +(defun nrev (snd rev-time mix) + (multichan-expand #'nyq:nrev snd rev-time mix)) + +(defun jcrev (snd rev-time mix) + (multichan-expand #'nyq:jcrev snd rev-time mix)) + +(defun prcrev (snd rev-time mix) + (multichan-expand #'nyq:prcrev snd rev-time mix)) + +(defun nyq:chorus (snd depth freq mix &optional (base-delay 6000)) + (snd-stkchorus snd base-delay depth freq mix *sound-srate*)) + +(defun stkchorus (snd depth freq mix &optional (base-delay 6000)) + (multichan-expand #'nyq:chorus snd depth freq mix base-delay)) + +(defun nyq:pitshift (snd shift mix) + (snd-stkpitshift snd shift mix *sound-srate*)) + +(defun pitshift (snd shift mix) + (multichan-expand #'nyq:pitshift snd shift mix)) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; HELPER FUNCTIONS +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; pass in rates of increase/decrease in begin/end... this is like noteOn and noteOff +; +; STK uses setRate but the actual ramp time is also a function of the sample rate. +; I will assume the clarinet was run at 44100Hz and fix things so that the envelope +; is sample-rate independent. +; +; STK seemed to always give a very fast release, so I changed the numbers so that +; note-off values from 0.01 to 1 give an interesting range of articulations. +; +; IMPORTANT: the returned envelope is 0.1s longer than dur. There is 0.1s of silence +; at the end so that the clarinet can "ring" after the driving force is removed. +; +(defun stk-breath-env (dur note-on note-off) + (let* ((target (+ 0.55 (* 0.3 note-on))) + (on-time (/ (* target 0.0045) note-on)) + (off-time (/ (* target 0.02) note-off))) + ;(display "clarinet-breath-env" target on-time off-time) + (pwl on-time target + (- dur off-time) target + dur 0 (+ dur 0.1)))) + + diff --git a/runtime/test.lsp b/runtime/test.lsp new file mode 100644 index 0000000..3bacbc6 --- /dev/null +++ b/runtime/test.lsp @@ -0,0 +1,43 @@ + +(defun ss () (osc c5)) + +(defun tt () (stretch 2 (snd-tapv (ss) 1.1 (scale *d* (lfo 10)) 2.2))) +(setf *d* .01) + +(defun g () (play (tt))) + +;(set-sound-srate 10) +;(set-control-srate 10) +(defun rr () (stretch 10 (ramp))) +(defun ll () (stretch 10 (lfo .5))) +(defun xx () (snd-tapv (rr) 1.1 (ll) 2.2)) +(defun h () (snd-samples (xx) 150)) + +(defun chorus (sound maxdepth depth rate saturation) + (let ((modulation (prod depth (stretch-abs 10000.0 (general-lfo rate)))) + (offset (/ maxdepth 2.0)) + chor) + (setf chor (snd-tapv sound offset modulation maxdepth)) + (sum (prod chor saturation) (prod (seq (s-rest offset) sound) + (sum 1.0 (prod -1.0 saturation)))))) + + +(set-sound-srate 22050.0) + +(defun f () + (chorus (s-read "runtime\\ah.wav") .1 .1 1 .5)) + +(defun e () + (seq (s-rest .05) (chorus (s-read "rpd.wav") .07 .07 .7 .5))) + +(defun d () (sum (e) (f))) + +(defun rou () (s-read "round.wav" :time-offset 1.18 :dur (- 8.378 1.18))) + +(defun rou4 () (sim (rou) + (at *rd* (rou)) + (at (* *rd* 2) (rou)) + (at (* *rd* 3) (rou)))) + + + diff --git a/runtime/upic.sal b/runtime/upic.sal new file mode 100644 index 0000000..87b433d --- /dev/null +++ b/runtime/upic.sal @@ -0,0 +1,53 @@ +;; upic.sal -- play upic data +;; + +define function upic(data) + begin + if data then + ;; use reverse to make a copy of data since sort is destructive + return upic-curve(sort(reverse(data), quote(upic-compare))) + else + return s-rest() + end + + +define function upic-compare(a, b) + return third(a) < third(b) + + +define function upic-curve(data) + begin + with curve = first(data), + waveform = first(curve), + envelope = second(curve), + points = cddr(curve), + from-time = first(points), + to-time = nth(length(points) - 2, points), + dur = to-time - from-time, + next = rest(data), + next-start, snd + ;; shift curve to start at t = 0 + loop + with relpoints + while points + set relpoints @= first(points) - from-time + set relpoints @= second(points) + set points = cddr(points) + finally set points = cdr(reverse(relpoints)) + end + set snd = hzosc(pwlv-list(points), symbol-value(waveform)) * + (funcall(envelope) ~ dur) + if next then + begin + set next-start = third(first(next)) + ;; display "curve", from-time, dur + set snd = seq(set-logical-stop(snd, next-start - from-time), + upic-curve(next)) + end + return snd + end + + +define function upic-env() + return env(0.01, 0.01, 0.01, 1, 1, 1) + diff --git a/runtime/xlinit.lsp b/runtime/xlinit.lsp new file mode 100644 index 0000000..42991e2 --- /dev/null +++ b/runtime/xlinit.lsp @@ -0,0 +1,67 @@ +;; xlinit.lsp -- standard definitions and setup code for XLisp +;; + + +(defun bt () (baktrace 6)) + +(defmacro setfn (a b) + `(setf (symbol-function ',a) (symbol-function ',b))) + +(setfn co continue) +(setfn top top-level) +(setfn res clean-up) +(setfn up clean-up) + +;## display -- debugging print macro +; +; call like this (display "heading" var1 var2 ...) +; and get printout like this: +; "heading : VAR1 = <value> VAR2 = <value> ...<CR>" +; +; returns: +; (let () +; (format t "~A: " ,label) +; (format t "~A = ~A " ',item1 ,item1) +; (format t "~A = ~A " ',item2 ,item2) +; ...) +; +(defmacro display-macro (label &rest items) + (let ($res$) + (dolist ($item$ items) + (setq $res$ (cons + `(format t "~A = ~A " ',$item$ ,$item$) + $res$))) + (append (list 'let nil `(format t "~A : " ,label)) + (reverse $res$) + '((terpri))))) + + +(defun display-on () (setfn display display-macro) t) +(defun display-off () (setfn display or) nil) +(display-on) + +; (objectp expr) - object predicate +; +;this is built-in: (defun objectp (x) (eq (type-of x) 'OBJ)) + + +; (filep expr) - file predicate +; +(defun filep (x) (eq (type-of x) 'FPTR)) + +(load "profile.lsp" :verbose NIL) + +(setq *breakenable* t) +(setq *tracenable* nil) + +(defmacro defclass (name super locals class-vars) + (if (not (boundp name)) + (if super + `(setq ,name (send class :new ',locals ',class-vars ,super)) + `(setq ,name (send class :new ',locals ',class-vars))))) + +;(cond ((boundp 'application-file-name) +; (load application-file-name))) + +(setq *gc-flag* t) + diff --git a/runtime/xm.lsp b/runtime/xm.lsp new file mode 100644 index 0000000..583a0fc --- /dev/null +++ b/runtime/xm.lsp @@ -0,0 +1,2349 @@ +;; X-Music, inspired by Commmon Music + +#| +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 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. + +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. + +EXPLICIT PATTERN LENGTH + +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. + +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. + +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. + +3) The length can be generated by a pattern. +The pattern is evaluated to generate an explicit +length. + +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. + +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. + +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. + +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. + +The :next method generates the next item or +eop+ from +a pattern. The algorithm in psuedo-code is roughly this: + +next(p) + while true: + if not have-current + pattern-advance() + have-current = true + if is-nested and current = eop: + 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 + else + 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). + +|# + +(setf SCORE-EPSILON 0.000001) + +(setf pattern-class + (send class :new '(current have-current is-nested name count + length-pattern trace))) + +(defun patternp (x) + (and (objectp x) (send x :isa pattern-class))) + +(setf +eop+ '+eop+) +(setf +eonp+ '+eonp+) ;; end of nested period, this indicates you + ;; should advance yourself and call back to get the next element + +(defun check-for-list (lis name) + (if (not (listp lis)) + (error (format nil "~A, requires a list of elements" name)))) + +(defun check-for-list-or-pattern (lis name) + (if (not (or (listp lis) (patternp lis))) + (error (format nil "~A, requires a list of elements or a pattern" name)))) + +(defun list-has-pattern (lis) + (dolist (e lis) + (if (patternp e) (return t)))) + +(defun is-homogeneous (lis) + (let (type) + (dolist (elem lis t) + (cond ((null type) + (setf type (if (patternp elem) 'pattern 'atom))) + ((and (eq type 'pattern) + (not (patternp elem))) + (return nil)) + ((and (eq type 'atom) + (patternp elem)) + (return nil)))))) + +(defun make-homogeneous (lis) + (cond ((is-homogeneous lis) lis) + (t + (mapcar #'(lambda (item) + (if (patternp item) item + (make-cycle (list item) + ;; help debugging by naming the new 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)))) + 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 "<no-name>") + (if (patternp current) + (if (send current :name) + (send current :name) + "<a-pattern>") + 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 +;; +(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 :is-nested '() '(is-nested)) + + +(send pattern-class :answer :name '() '(name)) + + +(send pattern-class :answer :set-current '(c) + '((setf current c) + (let ((value + (if (patternp current) + (send current :name) + current))) + ;(display ":set-current" name value) + ))) + + +;; 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)) + (cond ((and period-flag (patternp pattern)) + (let (rslt elem) + (while (not (eq (setf elem (send pattern :next)) +eop+)) + ;(display "next t" (send pattern :name) elem) + (if (not (eq elem +eonp+)) + (push elem rslt))) + (reverse rslt))) + (period-flag + (display "next" pattern) + (error (format nil "~A, next expected a pattern" + (send pattern :name)))) + ((patternp pattern) + ;(display "next" (send pattern :name) pattern) + (let (rslt) + (dotimes (i 10000 (error + (format nil + "~A, just retrieved 10000 empty periods -- is there a bug?" + (send pattern :name)))) + (if (not (member (setf rslt (send pattern :next)) + '(+eop+ +eonp+))) + (return rslt))))) + (t ;; pattern not a pattern, so just return it: + ;(display "next" pattern) + pattern))) + +;; ---- LENGTH Class ---- + +(setf length-class + (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))) + +;; note that count is used as a flag as well as a counter. +;; If count is nil, then the pattern-length has not been +;; determined. Count is nil intitially and again at the +;; end of each period. Otherwise, count is an integer +;; used to count down the number of items remaining in +;; the period. + +(send length-class :answer :start-period '() + '((setf count (next length-pattern)))) + +(send length-class :answer :advance '() + '((send self :set-current (next pattern)))) + +(defun make-length (pattern length-pattern &key (name "length") trace) + (send length-class :new pattern length-pattern name trace)) + +;; ---- CYCLE Class --------- + +(setf cycle-class (send class :new + '(lis cursor lis-pattern) + '() pattern-class)) + +(send cycle-class :answer :isnew '(l 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))) + + +(send cycle-class :answer :set-list '(l) + '((setf lis l) + (check-for-list lis "cycle-class :set-list") + (setf is-nested (list-has-pattern lis)) + (setf lis (make-homogeneous lis)))) + + +(send cycle-class :answer :start-period '() + '(;(display "cycle-class :start-period" lis-pattern lis count length-pattern) + (cond (lis-pattern + (send self :set-list (next lis-pattern t)) + (setf cursor lis))) + (if (null count) + (setf count (length lis))))) + + +(send cycle-class :answer :advance '() + '((cond ((and (null cursor) lis) + (setf cursor lis)) + ((null cursor) + (error (format nil "~A, :advance - no items" name)))) + (send self :set-current (car cursor)) + (pop cursor))) + + +(defun make-cycle (lis &key for (name "cycle") trace) + (check-for-list-or-pattern lis "make-cycle") + (send cycle-class :new lis 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) + (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))) + +(send line-class :answer :set-list '(l) + '((setf lis l) + (check-for-list lis "line-class :set-list") + (setf is-nested (list-has-pattern lis)) + (setf lis (make-homogeneous l)) + (setf cursor lis))) + + +(send line-class :answer :start-period '() + '((cond (lis-pattern + (send self :set-list (next lis-pattern t)) + (setf cursor lis))) + (if (null count) + (setf count (length lis))))) + + +(send line-class :answer :advance '() + '((cond ((null cursor) + (error (format nil "~A, :advance - no items" name)))) + (send self :set-current (car cursor)) + (if (cdr cursor) (pop cursor)))) + + +(defun make-line (lis &key for (name "line") trace) + (check-for-list-or-pattern lis "make-line") + (send line-class :new lis for name trace)) + + +;; ---- RANDOM class ----- + +(setf random-class (send class :new + '(lis lis-pattern len previous repeats mincnt maxcnt) + '() pattern-class)) + +;; the structure is (value weight weight-pattern max min) +(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 select-random (len lis previous repeats mincnt maxcnt) + (let (sum items r) + (cond ((zerop len) + (break "random-class has no list to choose from") + nil) + (t + (setf sum 0) + (dolist (item lis) + (setf sum (+ sum (rand-item-weight item)))) + (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) + (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))) + ((eq (car lis) :max) + (setf maxcnt (cadr lis))) + (t + (error "(make-random) item syntax error" item))) + (setf lis (cddr lis))) + (list value nil wp maxcnt mincnt))) + + +(defun random-atom-to-list (a) + (if (atom a) + (list a nil 1 nil nil) + (random-convert-spec a))) + + +(send random-class :answer :isnew '(l 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) + (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))) + + +(send random-class :answer :set-list '(l) + '((check-for-list l "random-class :set-list") + (setf lis (mapcar #'random-atom-to-list l)) + (dolist (item lis) + (if (patternp (rand-item-value item)) + (setf is-nested t))) + (if is-nested + (mapcar #'(lambda (item) + (if (not (patternp (rand-item-value item))) + (set-rand-item-value item + (make-cycle (list (rand-item-value item)))))) + lis)) + ;(display "random is-new" lis) + (setf repeats 0) + (setf len (length lis)))) + + +(send random-class :answer :start-period '() + '(;(display "random-class :start-period" count len lis 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)))))) + + +(send random-class :answer :advance '() + '((let (selection (iterations 0)) + ;(display "random-class :advance" mincnt repeats) + (cond ((and mincnt (< repeats mincnt)) + (setf selection previous) + (incf repeats)) + (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 + (>= repeats maxcnt)) ; hit maximum limit, try again + (setf selection + (select-random len lis previous repeats mincnt maxcnt)) + (incf iterations) + (cond ((> iterations 10000) + (error + (format nil + "~A, unable to pick next item after 10000 tries" + name) + lis)))) + (t (return)))) ; break from loop, we found a selection + + ; otherwise, we are ok + (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) + (send self :set-current (rand-item-value selection))))) + + +(defun make-random (lis &key for (name "random") trace) + (check-for-list-or-pattern lis "make-random") + (send random-class :new lis for name trace)) + + +;; ---- PALINDROME class ----- + +#| Palindrome includes elide, which is either t, nil, :first, or :last. +The pattern length is the "natural" length of the pattern, which goes +forward and backward through the list. Thus, if the list is of length N, +the palindrome length depends on elide as follows: + elide length + nil 2N + t 2N - 2 + :first 2N - 1 + :last 2N - 1 +If elide is a pattern, and if length is not specified, then length should +be computed based on elide. +|# + + +(setf palindrome-class (send class :new + '(lis revlis lis-pattern + direction elide-pattern + elide cursor) + '() pattern-class)) + +(send palindrome-class :answer :set-list '(l) + '((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))) + + +(send palindrome-class :answer :isnew '(l e 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 elide-pattern e length-pattern for name nm trace tr))) + + +(send palindrome-class :answer :start-period '() + '((cond (lis-pattern + (send self :set-list (next lis-pattern t)) + (setf cursor lis))) + (setf elide (next elide-pattern)) + (if (and elide (null lis)) + (error (format nil "~A, cannot elide if list is empty" name))) + (if (null count) + (setf count (- (* 2 (length lis)) + (if (member elide '(:first :last)) + 1 + (if elide 2 0))))))) + + +(send palindrome-class :answer :next-item '() + '((send self :set-current (car cursor)) + (pop cursor) + (cond ((and cursor (not (cdr cursor)) + (or (and direction (member elide '(:last t))) + (and (not direction) (member elide '(:first t))))) + (pop cursor))))) + + +(send palindrome-class :answer :advance '() + '( + (cond (cursor + (send self :next-item)) + (direction ;; we're going forward + (setf direction nil) ;; now going backward + (setf cursor revlis) + (send self :next-item)) + (t ;; direction is reverse + (setf direction t) + (setf cursor lis) + (send self :next-item))))) + + +(defun make-palindrome (lis &key elide for (name "palindrome") trace) + (check-for-list-or-pattern lis "make-palindrome") + (send palindrome-class :new lis elide for name trace)) + + +;; ================= HEAP CLASS ====================== + +;; to handle the :max keyword, which tells the object to avoid +;; repeating the last element of the previous period: +;; +;; maxcnt = 1 means "avoid the repetition" +;; check-repeat signals we are at the beginning of the period and must check +;; prev holds the previous value (initially nil) +;; 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) + '() pattern-class)) + +(send heap-class :answer :isnew '(l for mx 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))) + (t + (error (format nil "~A, expected list" nm) l))) + (setf length-pattern for maxcnt mx name nm trace tr))) + + +(send heap-class :answer :set-list '(l) + '((setf lis l) + (check-for-list lis "heap-class :set-list") + (setf is-nested (list-has-pattern lis)) + (setf lis (make-homogeneous lis)) + (setf len (length lis)))) + + +(send heap-class :answer :start-period '() + '(;(display "heap-class :start-period" lis-pattern count lis) + (cond (lis-pattern + (send self :set-list (next lis-pattern t)))) + ; start of period -- may need to avoid repeating previous item + (if (= maxcnt 1) (setf check-repeat t)) + (if (null count) + (setf count len)))) + + +(defun delete-first (elem lis) + (cond ((null lis) nil) + ((eq elem (car lis)) + (cdr lis)) + (t + (cons (car lis) (delete-first elem (cdr lis)))))) + + +;; NO-DISTINCT-ELEM -- check if any element of list is not val +;; +(defun no-distinct-elem (lis val) + (not + (dolist (elem lis) + (if (not (equal elem val)) + ;; there is a distinct element, return t from dolist + (return t))))) + ;; if no distinct element, dolist returns nil, but this is negated + ;; by the NOT so the function will return t + + +(send heap-class :answer :advance '() + '((cond ((null lis) + (setf lis used) + (setf used nil))) + (let (n elem) + (cond ((and check-repeat (no-distinct-elem lis prev)) + (error (format nil "~A, cannot avoid repetition, but :max is 1" + name)))) + (loop + (setf n (random (length lis))) + (setf elem (nth n lis)) + (if (or (not check-repeat) (not (equal prev elem))) + (return))) ;; loop until suitable element is chosen + (setf lis (delete-first elem lis)) + (push elem used) + (setf check-repeat nil) + (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)) + +;;================== COPIER CLASS ==================== + +(setf copier-class (send class :new '(sub-pattern repeat repeat-pattern + merge merge-pattern 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))) + + +#| copier-class makes copies of periods from sub-pattern + +If merge is true, the copies are merged into one big period. +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 +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 '() + '((cond ((null count) + (cond ((or (null repeat) (zerop repeat)) + (send self :really-start-period)) + (t + (setf count (length period)))))))) + + +(send copier-class :answer :really-start-period '() + '(;(display "copier-class :really-start-period" count) + (setf merge (next merge-pattern)) + (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 period (next sub-pattern t)) + (setf cursor nil) + (if (null count) + (setf count (* (if merge repeat 1) + (length period)))))) + + +(send copier-class :answer :advance '() + '((let ((loop-count 0)) + (loop + ;(display "copier loop" repeat cursor period) + (cond (cursor + (send self :set-current (car cursor)) + (pop cursor) + (return)) + ((plusp repeat) + (decf repeat) + (setf cursor period)) + ((> loop-count 10000) + (error (format nil + "~A, copier-class :advance encountered 10000 empty periods" + name))) + (t + (send self :really-start-period))) + (incf loop-count))))) + + +(defun make-copier (sub-pattern &key for (repeat 1) merge (name "copier") trace) + (send copier-class :new sub-pattern repeat merge for name trace)) + +;; ================= ACCUMULATE-CLASS =================== + +(setf accumulate-class (send class :new '(sub-pattern period cursor sum mini maxi) + '() 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) + )) + + +#| +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 '() + '((cond ((null count) + (send self :really-start-period))))) + + +(send accumulate-class :answer :really-start-period '() + '((setf period (next sub-pattern t)) + (setf cursor period) + ;(display "accumulate-class :really-start-period" period cursor count) + (if (null count) + (setf count (length period))))) + + +(send accumulate-class :answer :advance '() + '((let ((loop-count 0) (minimum (next mini)) (maximum (next maxi))) + (loop + (cond (cursor + (setf sum (+ sum (car cursor))) + (cond ((and (numberp minimum) (< sum minimum)) + (setf sum minimum))) + (cond ((and (numberp maximum) (> sum maximum)) + (setf sum maximum))) + (send self :set-current sum) + (pop cursor) + (return)) + ((> loop-count 10000) + (error (format nil + "~A, :advance encountered 10000 empty periods" name))) + (t + (send self :really-start-period))) + (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)) + +;;================== ACCUMULATION CLASS =================== + +;; for each item, generate all items up to and including the item, e.g. +;; (a b c) -> (a a b a b c) + +(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) + (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))) + +(send accumulation-class :answer :set-list '(l) + '((setf lis l) + (check-for-list lis "heap-class :set-list") + (setf lis (make-homogeneous lis)) + (setf inner lis) + (setf outer lis) + (setf len (length lis)))) + +(send accumulation-class :answer :start-period '() + '((cond (lis-pattern + (send self :set-list (next lis-pattern t)))) + ; start of period, length = (n^2 + n) / 2 + (if (null count) (setf count (/ (+ (* len len) len) 2))))) + +(send accumulation-class :answer :advance '() + ;; inner traverses lis from first to outer + ;; outer traverses lis + '((let ((elem (car inner))) + (cond ((eq inner outer) + (setf outer (rest outer)) + (setf outer (if outer outer lis)) + (setf inner lis)) + (t + (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)) + + +;;================== 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 #'+))) + +#| +sum-class creates pair-wise sums of numbers from 2 streams. +The output periods are the same as the input periods of the first +pattern argument (by default). +|# + +(send sum-class :answer :start-period '() + '((cond ((null count) + (send self :really-start-period))))) + +(send sum-class :answer :really-start-period '() + '((setf period (next x t)) + (setf cursor period) + (if (null count) + (setf count (length period))))) + +(send sum-class :answer :advance '() + '((let ((loop-count 0) rslt) + (loop + (cond (cursor + (setf rslt (funcall fn (car cursor) (next y))) + (send self :set-current rslt) + (pop cursor) + (return)) + ((> loop-count 10000) + (error (format nil + "~A, :advance encountered 10000 empty periods" name))) + (t + (send self :really-start-period))) + (incf loop-count))))) + + +(defun make-sum (x y &key for (name "sum") trace) + (send sum-class :new x y 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 #'*))) + +(defun make-product (x y &key for (name "product") trace) + (send product-class :new x y for name trace)) + + +;;================== EVAL CLASS ================= + +(setf eval-class (send class :new '(expr expr-pattern) + '() pattern-class)) + +(send eval-class :answer :isnew '(e for nm tr) + '((cond ((patternp e) + (setf expr-pattern e)) + (t + (setf expr e))) + (setf length-pattern for name nm trace tr))) + + +(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 :advance '() + '((send self :set-current (eval expr)))) + + +(defun make-eval (expr &key (for 1) (name "eval") trace) + (send eval-class :new expr for name trace)) + +;;================== MARKOV CLASS ==================== + +(setf markov-class (send class :new + '(rules order state produces pattern len) + '() pattern-class)) + + +(defun is-produces-homogeneous (produces) + (let (type elem) + (setf *rslt* nil) + (loop + (cond ((or (null produces) (eq produces :eval) (null (cadr produces))) + (return t))) + (setf elem (cadr produces)) + (cond ((null type) + (setf type (if (patternp elem) 'pattern 'atom)) + ;(display "is-produces-homogeneous" type) + (setf *rslt* (eq type 'pattern)) + ;(display "is-produces-homogeneous" *rslt*) + ) + ((and (eq type 'pattern) (not (patternp elem))) + (return nil)) + ((and (eq type 'atom) + (patternp elem)) + (return nil))) + (setf produces (cddr produces))))) + + +(defun make-produces-homogeneous (produces) + (let (result item) + (loop + (if (null produces) (return nil)) + (push (car produces) result) + (setf produces (cdr produces)) + (setf item (car produces)) + (setf produces (cdr produces)) + (if (not (patternp item)) + (setf item (make-cycle (list item)))) + (push item result)) + (reverse result))) + + +(send markov-class :answer :isnew '(r o s p 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) + (setf len (length r)) + ;; input r looks like this: + ;; ((prev1 prev2 -> next1 next2 (next3 weight) ... ) ...) + ;; transition table will look like a list of these: + ;; ((prev1 prev2 ... prevn) (next1 weight weight-pattern) ...) + (dolist (rule r) + (let ((targets (cdr (nthcdr order rule))) + entry pattern) + ;; build entry in reverse order + (dolist (target targets) + (push (if (atom target) + (list target 1 1) + (list (first target) + (next (second target)) + (second target))) + entry)) + ; (display "isnew" entry rule targets order (nthcdr order rule)) + (dotimes (i order) + (push (nth i rule) pattern)) + (push (cons (reverse pattern) entry) rules))) + (setf rules (reverse rules)) ;; keep rules in original order + (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*) + (setf is-nested *rslt*) ;; returned by is-produces-homogeneous + ;(display "markov-class :isnew" is-nested) + )) + + +(defun markov-match (state pattern) + (dolist (p pattern t) ;; return true if no mismatch + ;; compare element-by-element + (cond ((eq p '*)) ; anything matches '* + ((eql p (car state))) + (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) + ;; want to choose a value in the interval [0, sum) + ;; but real-random is not open on the right, so fudge + ;; the range by a small amount: + (r (real-random 0.0 (- sum SCORE-EPSILON)))) + (dolist (target (cdr rule)) + (setf total (+ total (second target))) + (cond ((> total r) (return (car target))))))) + + +(defun markov-update-weights (rule) + (dolist (target (cdr rule)) + (setf (car (cdr target)) (next (caddr target))))) + + +(defun markov-map-target (target produces) + (while (and produces (not (eq target (car produces)))) + (setf produces (cddr produces))) + (cadr produces)) + + +(send markov-class :answer :find-rule '() + '((let (rslt) + ;(display "find-rule" rules) + (dolist (rule rules) + ;(display "find-rule" state rule) + (cond ((markov-match state (car rule)) + (setf rslt rule) + (return rslt)))) + (cond ((null rslt) + (display "Error, no matching rule found" state rules) + (error (format nil "~A, (markov-class)" name)))) + rslt))) + + +(send markov-class :answer :start-period '() + '((if (null count) + (setf count len)))) + +(defun markov-general-rule-p (rule) + (let ((pre (car rule))) + (cond ((< (length pre) 2) nil) ;; 1st-order mm + (t + ;; return false if any member not * + ;; return t if all members are * + (dolist (s pre t) + (if (eq s '*) t (return nil))))))) + +(defun markov-find-state-leading-to (target rules) + (let (candidates) + (dolist (rule rules) + (let ((targets (cdr rule))) + (dolist (targ targets) + (cond ((eql (car targ) target) + (push (car rule) candidates)))))) + (cond (candidates ;; found at least one + (nth (random (length candidates)) candidates)) + (t + nil)))) + +(send markov-class :answer :advance '() + '((let (rule sum target rslt new-state) + ;(display "markov" pattern 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)) + ;; 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 + ;; is a higher-order Markov model, and we may now + ;; wander around in parts of the state space that + ;; never appeared in the training data. To avoid this + ;; we violate the strict interpretation of the rules + ;; and pick a random state sequence from the rule set + ;; that might have let to the current state. We jam + ;; this state sequence into state so that when we + ;; append target, we'll have a history that might + ;; have a corresponding rule next time. + (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) + (setf state new-state))))) + (setf state (append (cdr state) (list target))) + ;(display "markov next" rule sum target 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) + (setf target (markov-map-target target produces)))) + (if (not (eq is-nested (patternp target))) + (error (format nil + "~A :is-nested keyword (~A) not consistent with result (~A)" + name is-nested target))) + (send self :set-current target)))) + + +(defun make-markov (rules &key produces past for (name "markov") trace) + ;; check to make sure past and rules are consistent + (let ((order (length past))) + (dolist (rule rules) + (dotimes (i order) + (if (eq (car rule) '->) + (error (format nil "~A, a rule does not match the length of :past" + name))) + (pop rule)) + (if (eq (car rule) '->) nil + (error (format nil "~A, a rule does not match the length of :past" + name))))) + (cond ((null for) + (setf for (length rules)))) + (send markov-class :new rules (length past) past produces for name trace)) + + +(defun markov-rule-match (rule state) + (cond ((null state) t) + ((eql (car rule) (car state)) + (markov-rule-match (cdr rule) (cdr state))) + (t nil))) + + +(defun markov-find-rule (rules state) + (dolist (rule rules) + ;(display "find-rule" rule) + (cond ((markov-rule-match rule state) + (return rule))))) + +;; ------- functions below are for MARKOV-CREATE-RULES -------- + +;; MARKOV-FIND-CHOICE -- given a next state, find it in rule +;; +;; use state to get the order of the Markov model, e.g. how +;; many previous states to skip in the rule, (add 1 for '->). +;; then use assoc to do a quick search +;; +;; example: +;; (markov-find-choice '(a b -> (c 1) (d 2)) '(a b) 'd) +;; returns (d 2) from the rule +;; +(defun markov-find-choice (rule state next) + (assoc next (nthcdr (1+ (length state)) rule))) + +(defun markov-update-rule (rule state next) + (let ((choice (markov-find-choice rule state next))) + (cond (choice + (setf (car (cdr choice)) (1+ (cadr choice)))) + (t + (nconc rule (list (list next 1))))) + rule)) + + +(defun markov-update-rules (rules state next) + (let ((rule (markov-find-rule rules state))) + (cond (rule + (markov-update-rule rule state next)) + (t + (setf rules + (nconc rules + (list (append state + (cons '-> (list + (list next 1))))))))) + rules)) + + +;; MARKOV-UPDATE-HISTOGRAM -- keep a list of symbols and counts +;; +;; This histogram will become the right-hand part of a rule, so +;; the format is ((symbol count) (symbol count) ...) +;; +(defun markov-update-histogram (histogram next) + (let ((pair (assoc next histogram))) + (cond (pair + (setf (car (cdr pair)) (1+ (cadr pair)))) + (t + (setf histogram (cons (list next 1) histogram)))) + histogram)) + + +(defun markov-create-rules (sequence order &optional generalize) + (let ((seqlen (length sequence)) state rules next histogram rule) + (cond ((<= seqlen order) + (error "markov-create-rules: sequence must be longer than order")) + ((< order 1) + (error "markov-create-rules: order must be 1 or greater"))) + ; build initial state sequence + (dotimes (i order) + (setf state (nconc state (list (car sequence)))) + (setf sequence (cdr sequence))) + ; for each symbol, either update a rule or add a rule + (while sequence + (setf next (car sequence)) + (setf sequence (cdr sequence)) + (setf rules (markov-update-rules rules state next)) + (setf histogram (markov-update-histogram histogram next)) + ; shift next state onto current state list + (setf state (nconc (cdr state) (list next)))) + ; generalize? + (cond (generalize + (setf rule (cons '-> histogram)) + (dotimes (i order) + (setf rule (cons '* rule))) + (setf rules (nconc rules (list rule))))) + rules)) + + +;; ----- WINDOW Class --------- + +(setf window-class (send class :new + '(pattern skip-pattern lis cursor) + '() 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 window-class :answer :start-period '() + '((if (null count) (error (format nil "~A, :start-period -- count is null" + name))) + (cond ((null lis) ;; first time + (dotimes (i count) + (push (next pattern) lis)) + (setf lis (reverse lis))) + (t + (let ((skip (next skip-pattern))) + (dotimes (i skip) + (if lis (pop lis) (next pattern)))) + (setf lis (reverse lis)) + (let ((len (length lis))) + (while (< len count) + (incf len) + (push (next pattern) lis)) + (while (> len count) + (decf len) + (pop lis)) + (setf lis (reverse lis))))) + (setf cursor lis))) + + +(send window-class :answer :advance '() + '((send self :set-current (car cursor)) + (pop cursor))) + +(defun make-window (pattern length-pattern skip-pattern + &key (name "window") trace) + (send window-class :new pattern length-pattern skip-pattern name trace)) + +;; SCORE-SORTED -- test if score is sorted +;; +(defun score-sorted (score) + (let ((result t)) + (while (cdr score) + (cond ((event-before (cadr score) (car score)) + (setf result nil) + (return nil))) + (setf score (cdr score))) + result)) + + +(defmacro score-gen (&rest args) + (let (key val tim dur (name ''note) ioi trace save + score-len score-dur others pre post + next-expr (score-begin 0) score-end) + (while (and args (cdr args)) + (setf key (car args)) + (setf val (cadr args)) + (setf args (cddr args)) + (case key + (:time (setf tim val)) + (:dur (setf dur val)) + (:name (setf name val)) + (:ioi (setf ioi val)) + (:trace (setf trace val)) + (:save (setf save val)) + (:pre (setf pre val)) + (:post (setf post val)) + (:score-len (setf score-len val)) + (:score-dur (setf score-dur val)) + (:begin (setf score-begin val)) + (:end (setf score-end val)) + (t (setf others (cons key (cons val others)))))) + ;; make sure at least one of score-len, score-dur is present + (cond ((and (null score-len) (null score-dur)) + (error + "score-gen needs either :score-len or :score-dur to limit length"))) + ;; compute expression for dur + (cond ((null dur) + (setf dur 'sg:ioi))) + ;; compute expression for ioi + (cond ((null ioi) + (setf ioi 1))) + ;; compute expression for next start time + (setf next-expr '(+ sg:start sg:ioi)) + ; (display "score-gen" others) + `(let (sg:seq (sg:start ,score-begin) sg:ioi + (sg:score-len ,score-len) (sg:score-dur ,score-dur) + (sg:count 0) (sg:save ,save) + (sg:begin ,score-begin) (sg:end ,score-end) sg:det-end) + ;; sg:det-end is a flag that tells us to determine the end time + (cond ((null sg:end) (setf sg:end 0 sg:det-end t))) + ;; make sure at least one of score-len, score-dur is present + (loop + (cond ((or (and sg:score-len (<= sg:score-len sg:count)) + (and sg:score-dur (<= (+ sg:begin sg:score-dur) sg:start))) + (return))) + ,pre + ,(cond (tim (list 'setf 'sg:start tim))) + (setf sg:ioi ,ioi) + (setf sg:dur ,dur) + (push (list sg:start sg:dur (list ,name ,@others)) + sg:seq) + ,post + (cond (,trace + (format t "get-seq trace at ~A stretch ~A: ~A~%" + sg:start sg:dur (car sg:seq)))) + (incf sg:count) + (setf sg:start ,next-expr) + ;; end time of score will be max over start times of the next note + ;; this bases the score duration on ioi's rather than durs. But + ;; if user specified sg:end, sg:det-end is false and we do not + ;; try to compute sg:end. + (cond ((and sg:det-end (> sg:start sg:end)) + (setf sg:end sg:start)))) + (setf sg:seq (reverse sg:seq)) + ;; avoid sorting a sorted list -- XLisp's quicksort can overflow the + ;; stack if the list is sorted because (apparently) the pivot points + ;; are not random. + (cond ((not (score-sorted sg:seq)) + (setf sg:seq (bigsort sg:seq #'event-before)))) + (push (list 0 0 (list 'SCORE-BEGIN-END ,score-begin sg:end)) sg:seq) + (cond (sg:save (set sg:save sg:seq))) + sg:seq))) + +;; ============== score manipulation =========== + +(defun event-before (a b) + (< (car a) (car b))) + +;; EVENT-END -- get the ending time of a score event +;; +(defun event-end (e) (+ (car e) (cadr e))) + +;; EVENT-TIME -- time of an event +;; +(setfn event-time car) + +;; EVENT-DUR -- duration of an event +;; +(setfn event-dur cadr) + +;; EVENT-SET-TIME -- new event with new time +;; +(defun event-set-time (event time) + (cons time (cdr event))) + + +;; EVENT-SET-DUR -- new event with new dur +;; +(defun event-set-dur (event dur) + (list (event-time event) + dur + (event-expression event))) + + +;; EVENT-SET-EXPRESSION -- new event with new expression +;; +(defun event-set-expression (event expression) + (list (event-time event) + (event-dur event) + expression)) + +;; EXPR-HAS-ATTR -- test if expression has attribute +;; +(defun expr-has-attr (expression attr) + (member attr expression)) + + +;; EXPR-GET-ATTR -- get value of attribute from expression +;; +(defun expr-get-attr (expression attr &optional default) + (let ((m (member attr expression))) + (if m (cadr m) default))) + + +;; EXPR-SET-ATTR -- set value of an attribute in expression +;; (returns new expression) +(defun expr-set-attr (expr attr value) + (cons (car expr) (expr-parameters-set-attr (cdr expr) attr value))) + +(defun expr-parameters-set-attr (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) + (expr-parameters-set-attr (cddr lis) attr value)))))) + + +;; EXPR-REMOVE-ATTR -- expression without attribute value pair +(defun expr-remove-attr (event attr) + (cons (car expr) (expr-parameters-remove-attr (cdr expr) attr))) + +(defun expr-parameters-remove-attr (lis attr) + (cond ((null lis) nil) + ((eq (car lis) attr) (cddr lis)) + (t (cons (car lis) + (cons (cadr lis) + (expr-parameters-remove-attr (cddr lis) attr)))))) + + +;; EVENT-GET-ATTR -- get value of attribute from event +;; +(defun event-get-attr (note attr &optional default) + (expr-get-attr (event-expression note) attr default)) + + +;; EVENT-SET-ATTR -- new event with attribute = value +(defun event-set-attr (event attr value) + (event-set-expression + event + (expr-set-attr (event-expression event) attr value))) + + +;; EVENT-REMOVE-ATTR -- new event without atttribute value pair +(defun event-remove-attr (event attr) + (event-set-expression + event + (event-remove-attr (event-expression event) attr))) + + +;; SCORE-GET-BEGIN -- get the begin time of a score +;; +(defun score-get-begin (score) + (setf score (score-must-have-begin-end score)) + (cadr (event-expression (car score)))) + + +;; SCORE-SET-BEGIN -- set the begin time of a score +;; +(defun score-set-begin (score time) + (setf score (score-must-have-begin-end score)) + (cons (list 0 0 (list 'score-begin-end time + (caddr (event-expression (car score))))) + (cdr score))) + + +;; SCORE-GET-END -- get the end time of a score +;; +(defun score-get-end (score) + (setf score (score-must-have-begin-end score)) + (caddr (event-expression (car score)))) + + +;; SCORE-SET-END -- set the end time of a score +;; +(defun score-set-end (score time) + (setf score (score-must-have-begin-end score)) + (cons (list 0 0 (list 'score-begin-end + (cadr (event-expression (car score))) time)) + (cdr score))) + + +;; FIND-FIRST-NOTE -- use keywords to find index of first selected note +;; +(defun find-first-note (score from-index from-time) + (let ((s (cdr score))) + ;; offset by one because we removed element 0 + (setf from-index (if from-index (max 0 (- from-index 1)) 0)) + (setf from-time (if from-time + (- from-time SCORE-EPSILON) + (- SCORE-EPSILON))) + (if s (setf s (nthcdr from-index s))) + + (while (and s (>= from-time (event-time (car s)))) + (setf s (cdr s)) + (incf from-index)) + (1+ from-index))) + + +;; EVENT-BEFORE -- useful function for sorting scores +;; +(defun event-before (a b) + (< (car a) (car b))) + +;; bigsort -- a sort routine that avoids recursion in order +;; to sort large lists without overflowing the evaluation stack +;; +;; Does not modify input list. Does not minimize cons-ing. +;; +;; Algorithm: first accumulate sorted sub-sequences into lists +;; Then merge pairs iteratively until only one big list remains +;; +(defun bigsort (lis cmp) ; sort lis using cmp function + ;; if (funcall cmp a b) then a and b are in order + (prog (rslt sub pairs) + ;; first, convert to sorted sublists stored on rslt + ;; accumulate sublists in sub + get-next-sub + (if (null lis) (go done-1)) + (setf sub (list (car lis))) + (setf lis (cdr lis)) + fill-sub + ;; invariant: sub is non-empty, in reverse order + (cond ((and lis (funcall cmp (car sub) (car lis))) + (setf sub (cons (car lis) sub)) + (setf lis (cdr lis)) + (go fill-sub))) + (setf sub (reverse sub)) ;; put sub in correct order + (setf rslt (cons sub rslt)) ;; build rslt in reverse order + (go get-next-sub) + done-1 + ;; invariant: rslt is list of sorted sublists + (if (cdr rslt) nil (go done-2)) + ;; invariant: rslt has at least one list + (setf pairs rslt) + (setf rslt nil) + merge-pairs ;; merge a pair and save on rslt + (if (car pairs) nil (go end-of-pass)) ;; loop until all pairs merged + ;; invariant: pairs has at least one list + (setf list1 (car pairs)) ;; list1 is non-empty + (setf list2 (cadr pairs)) ;; list2 could be empty + (setf pairs (cddr pairs)) + (cond (list2 + (setf rslt (cons (list-merge list1 list2 cmp) rslt))) + (t + (setf rslt (cons list1 rslt)))) + (go merge-pairs) + end-of-pass + (go done-1) + done-2 + ;; invariant: rslt has one sorted list! + (return (car rslt)))) + +(defun list-merge (list1 list2 cmp) + (prog (rslt) + merge-loop + (cond ((and list1 list2) + (cond ((funcall cmp (car list1) (car list2)) + (setf rslt (cons (car list1) rslt)) + (setf list1 (cdr list1))) + (t + (setf rslt (cons (car list2) rslt)) + (setf list2 (cdr list2))))) + (list1 + (return (nconc (reverse rslt) list1))) + (t + (return (nconc (reverse rslt) list2)))) + (go merge-loop))) + + +;; SCORE-SORT -- sort a score into time order +;; +(defun score-sort (score &optional (copy-flag t)) + (setf score (score-must-have-begin-end score)) + (let ((begin-end (car score))) + (setf score (cdr score)) + (if copy-flag (setf score (append score nil))) + (cons begin-end (bigsort score #'event-before)))) + + +;; PUSH-SORT -- insert an event in (reverse) sorted order +;; +;; Note: Score should NOT have a score-begin-end expression +;; +(defun push-sort (event score) + (let (insert-after) + (cond ((null score) (list event)) + ((event-before (car score) event) + (cons event score)) + (t + (setf insert-after score) + (while (and (cdr insert-after) + (event-before event (cadr insert-after))) + (setf insert-after (cdr insert-after))) + (setf (cdr insert-after) (cons event (cdr insert-after))) + score)))) + + +(setf FOREVER 3600000000.0) ; 1 million hours + +;; FIND-LAST-NOTE -- use keywords to find index beyond last selected note +;; +;; note that the :to-index keyword is the index of the last note (numbered +;; from zero), whereas this function returns the index of the last note +;; plus one, i.e. selected notes have an index *less than* this one +;; +(defun find-last-note (score to-index to-time) + ;; skip past score-begin-end event + (let ((s (cdr score)) + (n 1)) + (setf to-index (if to-index (1+ to-index) (length score))) + (setf to-time (if to-time (- to-time SCORE-EPSILON) FOREVER)) + (while (and s (< n to-index) (< (event-time (car s)) to-time)) + (setf s (cdr s)) + (incf n)) + n)) + + +;; SCORE-MUST-HAVE-BEGIN-END -- add score-begin-end event if necessary +;; +(defun score-must-have-begin-end (score) + (cond ((null score) + (list (list 0 0 (list 'SCORE-BEGIN-END 0 0)))) + ((eq (car (event-expression (car score))) 'SCORE-BEGIN-END) + score) + (t (cons (list 0 0 (list 'SCORE-BEGIN-END (event-time (car score)) + (event-end (car (last score))))) + score)))) + + +;; SCORE-SHIFT -- add offset to times of score events +;; +(defun score-shift (score offset &key from-index to-index from-time to-time) + (setf score (score-must-have-begin-end score)) + (let ((i 1) + (start (find-first-note score from-index from-time)) + (stop (find-last-note score to-index to-time)) + (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 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)) + (reverse result)))) + + +;; TIME-STRETCH -- map a timestamp according to stretch factor +;; +(defun time-stretch (time stretch start-time stop-time) + (cond ((< time start-time) time) + ((< time stop-time) + (+ start-time (* stretch (- time start-time)))) + (t ; beyond stop-time + (+ (- time stop-time) ; how much beyond stop-time + start-time + (* stretch (- stop-time start-time)))))) + + +;; EVENT-STRETCH -- apply time warp to an event +(defun event-stretch (event stretch dur-flag time-flag start-time stop-time) + (let* ((new-time (event-time event)) + (new-dur (event-dur event)) + (end-time (+ new-time new-dur))) + (cond (time-flag + (setf new-time (time-stretch new-time stretch + start-time stop-time)))) + (cond ((and time-flag dur-flag) + ;; both time and dur are stretched, so map the end time just + ;; like the start time, then subtract to get new duration + (setf end-time (time-stretch end-time stretch + start-time stop-time)) + (setf new-dur (- end-time new-time))) + ((and dur-flag (>= new-time start-time) (< new-time stop-time)) + ;; stretch only duration, not time. If note starts in range + ;; scale to get the new duration. + (setf new-dur (* stretch new-dur)))) + (list new-time new-dur (event-expression event)))) + + +;; SCORE-STRETCH -- stretch a region of the score +;; +(defun score-stretch (score factor &key (dur t) (time t) + from-index to-index (from-time 0) (to-time FOREVER)) + (setf score (score-must-have-begin-end score)) + (let ((begin-end (event-expression (car score))) + (i 1)) + (if from-index + (setf from-time (max from-time + (event-time (nth from-index score))))) + (if to-index + (setf to-time (min to-time + (event-end (nth to-index score))))) + ; stretch from start-time to stop-time + (cons (list 0 0 (list 'SCORE-BEGIN-END + (time-stretch (cadr begin-end) factor + from-time to-time) + (time-stretch (caddr begin-end) factor + from-time to-time))) + (mapcar #'(lambda (event) + (event-stretch event factor dur time + from-time to-time)) + (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. +;; +(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 params-transpose (params keyword amount) + (cond ((null params) nil) + ((eq keyword (car params)) + (let ((v (get-numeric-value params))) + (cond ((numberp v) + (setf v (+ v amount)))) + (cons (car params) + (cons v (cddr params))))) + (t (cons (car params) + (cons (cadr params) + (params-transpose (cddr params) keyword amount)))))) + + +(defun score-transpose (score keyword amount &key + from-index to-index from-time to-time) + (score-apply score + #'(lambda (time dur expression) + (list time dur + (cons (car expression) + (params-transpose (cdr expression) + keyword amount)))) + :from-index from-index :to-index to-index + :from-time from-time :to-time to-time)) + + +(defun params-scale (params keyword amount) + (cond ((null params) nil) + ((eq keyword (car params)) + (let ((v (get-numeric-value params))) + (cond ((numberp v) + (setf v (* v amount)))) + (cons (car params) + (cons v (cddr params))))) + (t (cons (car params) + (cons (cadr params) + (params-scale (cddr params) keyword amount)))))) + + +(defun score-scale (score keyword amount &key + from-index to-index from-time to-time) + (score-apply score + #'(lambda (time dur expression) + (list time dur + (cons (car expression) + (params-scale (cdr expression) + keyword amount)))) + :from-index from-index :to-index to-index + :from-time from-time :to-time to-time)) + + +(defun score-sustain (score factor &key + from-index to-index from-time to-time) + (setf score (score-must-have-begin-end score)) + (let ((i 0) + (start (find-first-note score from-index from-time)) + (stop (find-last-note score to-index to-time)) + result) + (dolist (event score) + (cond ((and (<= start i) (< i stop)) + (setf event (event-set-dur + event (* (event-dur event) factor))))) + (push event result) + (incf i)) + (reverse result))) + + +(defun map-voice (expression replacement-list) + (let ((mapping (assoc (car expression) replacement-list))) + (cond (mapping (cons (second mapping) + (cdr expression))) + (t expression)))) + + +(defun score-voice (score replacement-list &key + from-index to-index from-time to-time) + (setf score (score-must-have-begin-end score)) + (let ((i 0) + (start (find-first-note score from-index from-time)) + (stop (find-last-note score to-index to-time)) + result) + (dolist (event score) + (cond ((and (<= start i) (< i stop)) + (setf event (event-set-expression + event (map-voice (event-expression event) + replacement-list))))) + (push event result) + (incf i)) + (reverse result))) + + +(defun score-merge (&rest scores) + ;; scores is a list of scores + (cond ((null scores) nil) + (t + (score-merge-1 (car scores) (cdr scores))))) + + +;; SCORE-MERGE-1 -- merge list of scores into score +;; +(defun score-merge-1 (score scores) + ;; scores is a list of scores to merge + (cond ((null scores) score) + (t (score-merge-1 (score-merge-2 score (car scores)) + (cdr scores))))) + +;; SCORE-MERGE-2 -- merge 2 scores +;; +(defun score-merge-2 (score addin) + ;(display "score-merge-2 before" score addin) + (setf score (score-must-have-begin-end score)) + (setf addin (score-must-have-begin-end addin)) + ;(display "score-merge-2" score addin) + (let (start1 start2 end1 end2) + (setf start1 (score-get-begin score)) + (setf start2 (score-get-begin addin)) + (setf end1 (score-get-end score)) + (setf end2 (score-get-end addin)) + + ;; note: score-sort is destructive, but append copies score + ;; and score-shift copies addin + (score-sort + (cons (list 0 0 (list 'SCORE-BEGIN-END (min start1 start2) + (max end1 end2))) + (append (cdr score) (cdr addin) nil))))) + + + +;; SCORE-APPEND -- append scores together in sequence +;; +(defun score-append (&rest scores) + ;; scores is a list of scores + (cond ((null scores) nil) + (t + (score-append-1 (car scores) (cdr scores))))) + + +;; SCORE-APPEND-1 -- append list of scores into score +;; +(defun score-append-1 (score scores) + ;; scores is a list of scores to append + (cond ((null scores) score) + (t (score-append-1 (score-append-2 score (car scores)) + (cdr scores))))) + + +;; SCORE-APPEND-2 -- append 2 scores +;; +(defun score-append-2 (score addin) + ;(display "score-append-2" score addin) + (setf score (score-must-have-begin-end score)) + (setf addin (score-must-have-begin-end addin)) + (let (end1 start2 begin-end1 begin-end2) + (setf start1 (score-get-begin score)) + (setf end1 (score-get-end score)) + (setf start2 (score-get-begin addin)) + (setf end2 (score-get-end addin)) + (setf begin-end1 (event-expression (car score))) + (setf begin-end2 (event-expression (car addin))) + (setf addin (score-shift addin (- end1 start2))) + ;; note: score-sort is destructive, but append copies score + ;; and score-shift copies addin + (score-sort + (cons (list 0 0 (list 'SCORE-BEGIN-END start1 (+ end1 (- end2 start2)))) + (append (cdr score) (cdr addin) nil))))) + + +(defun score-select (score predicate &key + from-index to-index from-time to-time reject) + (setf score (score-must-have-begin-end score)) + (let ((begin-end (car score)) + (i 1) + (start (find-first-note score from-index from-time)) + (stop (find-last-note score to-index to-time)) + result) + ;; selected if start <= i AND i < stop AND predicate(...) + ;; choose if not reject and selected or reject and not selected + ;; so in other words choose if reject != selected. Use NULL to + ;; coerce into boolean values and then use NOT EQ to compare + (dolist (event (cdr score)) + (cond ((not (eq (null reject) + (null (and (<= start i) (< i stop) + (or (eq predicate t) + (funcall predicate + (event-time event) + (event-dur event) + (event-expression event))))))) + (push event result))) + (incf i)) + (cons begin-end (reverse result)))) + + +;; SCORE-FILTER-LENGTH -- remove notes beyond cutoff time +;; +(defun score-filter-length (score cutoff) + (let (result) + (dolist (event score) + (cond ((<= (event-end event) cutoff) + (push event result)))) + (reverse result))) + + +;; SCORE-REPEAT -- make n copies of score in sequence +;; +(defun score-repeat (score n) + (let (result) + (dotimes (i n) + (setf result (score-append result score))) + result)) + + +;; SCORE-STRETCH-TO-LENGTH -- stretch score to have given length +;; +(defun score-stretch-to-length (score length) + (let ((begin-time (score-get-begin score)) + (end-time (score-get-end score)) + duration stretch) + (setf duration (- end-time begin-time)) + (cond ((< 0 duration) + (setf stretch (/ length (- end-time begin-time))) + (score-stretch score stretch)) + (t score)))) + + +(defun score-filter-overlap (score) + (setf score (score-must-have-begin-end score)) + (prog (event end-time filtered-score + (begin-end (car score))) + (setf score (cdr score)) + (cond ((null score) (return (list begin-end)))) + loop + ;; get event from score + (setf event (car score)) + ;; add a note to filtered-score + (push event filtered-score) + ;; save the end-time of this event: start + duration + (setf end-time (+ (car event) (cadr event))) + ;; now skip everything until end-time in score + loop2 + (pop score) ;; move to next event in score + (cond ((null score) + (return (cons begin-end (reverse filtered-score))))) + (setf event (car score)) ;; examine next event + (setf start-time (car event)) + ;(display "overlap" start-time (- end-time SCORE-EPSILON)) + (cond ((< start-time (- end-time SCORE-EPSILON)) + ;(display "toss" event start-time end-time) + (go loop2))) + (go loop))) + + +(defun score-print (score) + (format t "(") + (dolist (event score) + (format t "~S~%" event)) + (format t ")~%")) + +(defun score-play (score) + (play (timed-seq score))) + + +(defun score-adjacent-events (score function &key + from-index to-index from-time to-time) + (setf score (score-must-have-begin-end score)) + (let ((begin-end (car score)) + (a nil) + (b (second score)) + (c-list (cddr score)) + r newscore + (i 1) + (start (find-first-note score from-index from-time)) + (stop (find-last-note score to-index to-time))) + (dolist (event (cdr score)) + (setf r b) + (cond ((and (<= start i) (< i stop)) + (setf r (funcall function a b (car c-list))))) + (cond (r + (push r newscore) + (setf a r))) + (setf b (car c-list)) + (setf c-list (cdr c-list)) + (incf i)) + (score-sort (cons begin-end newscore)))) + + +(defun score-apply (score fn &key + from-index to-index from-time to-time) + + (setf score (score-must-have-begin-end score)) + (let ((begin-end (car score)) + (i 1) + (start (find-first-note score from-index from-time)) + (stop (find-last-note score to-index to-time)) + result) + (dolist (event (cdr score)) + (push + (cond ((and (<= start i) (< i stop)) + (funcall fn (event-time event) + (event-dur event) (event-expression event))) + (t event)) + result) + (incf i)) + (score-sort (cons begin-end result)))) + + +(defun score-indexof (score fn &key + from-index to-index from-time to-time) + (setf score (score-must-have-begin-end score)) + (let ((i 1) + (start (find-first-note score from-index from-time)) + (stop (find-last-note score to-index to-time)) + result) + (dolist (event (cdr score)) + (cond ((and (<= start i) (< i stop) + (funcall fn (event-time event) + (event-dur event) + (event-expression event))) + (setf result i) + (return))) + (incf i)) + result)) + + +(defun score-last-indexof (score fn &key + from-index to-index from-time to-time) + (setf score (score-must-have-begin-end score)) + (let ((i 1) + (start (find-first-note score from-index from-time)) + (stop (find-last-note score to-index to-time)) + result) + (dolist (event (cdr score)) + (cond ((and (<= start i) (< i stop) + (funcall fn (event-time event) + (event-dur event) + (event-expression event))) + (setf result i))) + (incf i)) + result)) + + +;; SCORE-RANDOMIZE-START -- alter start times with offset +;; keywords: jitter, offset, feel factor +;; +(defun score-randomize-start (score amt &key + from-index to-index from-time to-time) + (score-apply score + (lambda (time dur expr) + (setf time (+ (real-random (- amt) amt) time)) + (setf time (max 0.0 time)) + (list time dur expr)))) + + +;; SCORE-READ-SMF -- read a standard MIDI file to a score +;; +(defun score-read-smf (filename) + (let ((seq (seq-create)) + (file (open-binary filename))) + (cond (file + (seq-read-smf seq file) + (close file) + (score-from-seq seq)) + (t nil)))) + + +;; SET-PROGRAM-TO -- a helper function to set a list value +(defun set-program-to (lis index value default) + ;; if length or lis <= index, extend the lis with default + (while (<= (length lis) index) + (setf lis (nconc lis (list default)))) + ;; set the nth element + (setf (nth index lis) value) + ;; return the list + lis) + + +(defun score-from-seq (seq) + (prog (event tag score programs) + (seq-reset seq) +loop + (setf event (seq-get seq)) + (setf tag (seq-tag event)) + (cond ((= tag seq-done-tag) + (go exit)) + ((= tag seq-prgm-tag) + (let ((chan (seq-channel event)) + (when (seq-time event)) + (program (seq-program event))) + (setf programs (set-program-to programs chan program 0)) + (push (list (* when 0.001) 1 + (list 'NOTE :pitch nil :program program)) + score))) + ((= tag seq-note-tag) + (let ((chan (seq-channel event)) + (pitch (seq-pitch event)) + (vel (seq-velocity event)) + (when (seq-time event)) + (dur (seq-duration event))) + (push (list (* when 0.001) (* dur 0.001) + (list 'NOTE :chan (1- chan) :pitch pitch :vel vel)) + score)))) + (seq-next seq) + (go loop) +exit + (setf *rslt* programs) ;; extra return value + (return (score-sort score)))) + + +(defun score-write-smf (score filename &optional programs) + (let ((file (open-binary filename :direction :output)) + (seq (seq-create)) + (chan 1)) + (cond (file + (dolist (program programs) + ;; 6 = SEQ_PROGRAM + (seq-insert-ctrl seq 0 0 6 chan program) + ;(display "insert ctrl" seq 0 0 6 chan program) + (incf chan)) + + (dolist (event (cdr (score-must-have-begin-end score))) + (let ((time (event-time event)) + (dur (event-dur event)) + (chan (event-get-attr event :chan 0)) + (pitch (event-get-attr event :pitch)) + (program (event-get-attr event :program)) + (vel (event-get-attr event :vel 100))) + (cond (program + ;(display "score-write-smf program" chan program) + (seq-insert-ctrl seq (round (* time 1000)) + 0 6 (1+ chan) + (round program)))) + (cond ((consp pitch) + (dolist (p pitch) + (seq-insert-note seq (round (* time 1000)) + 0 (1+ chan) (round p) + (round (* dur 1000)) (round vel)))) + (pitch + (seq-insert-note seq (round (* time 1000)) + 0 (1+ chan) (round pitch) + (round (* dur 1000)) (round vel)))))) + (seq-write-smf seq file) + (close file))))) + + +;; make a default note function for scores +;; +(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"))) + (piano-note-2 pitch vel)) + +;;================================================================ + +;; WORKSPACE functions have moved to envelopes.lsp + + +;; DESCRIBE -- add a description to a global variable +;; +(defun describe (symbol &optional description) + (add-to-workspace symbol) + (cond (description + (putprop symbol description 'description)) + (t + (get symbol 'description)))) + +;; INTERPOLATE -- linear interpolation function +;; +;; compute y given x by interpolating between points (x1, y1) and (x2, y2) +(defun interpolate (x x1 y1 x2 y2) + (cond ((= x1 x2) x1) + (t (+ y1 (* (- x x1) (/ (- y2 y1) (- x2 (float x1)))))))) + + +;; INTERSECTION -- set intersection +;; +;; compute the intersection of two lists +(defun intersection (a b) + (let (result) + (dolist (elem a) + (if (member elem b) (push elem result))) + result)) + +;; UNION -- set union +;; +;; compute the union of two lists +(defun union (a b) + (let (result) + (dolist (elem a) + (if (not (member elem result)) (push elem result))) + (dolist (elem b) + (if (not (member elem result)) (push elem result))) + result)) + +;; SET-DIFFERENCE -- set difference +;; +;; compute the set difference between two sets +(defun set-difference (a b) + (remove-if (lambda (elem) (member elem b)) a)) + +;; SUBSETP -- test is list is subset +;; +;; test if a is subset of b +(defun subsetp (a b) + (let ((result t)) + (dolist (elem a) + (cond ((not (member elem b)) + (setf result nil) + (return nil)))) + result)) + +;; functions to support score editing in jNyqIDE + +(if (not (boundp '*default-score-file*)) + (setf *default-score-file* "score.dat")) + +;; SCORE-EDIT -- save a score for editing by jNyqIDE +;; +;; file goes to a data file to be read by jNyqIDE +;; 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) +;; +(defmacro score-edit (score-name) + `(score-edit-symbol (quote ,score-name))) + +(defun score-edit-symbol (score-name) + (prog ((f (open *default-score-file* :direction :output)) + score expr) + (cond ((symbolp score-name) + (setf score (eval score-name))) + (t + (error "score-edit expects a symbol naming the score to edit"))) + (cond ((null f) + (format t "score-edit: error in output file ~A!~%" *default-score-file*) + (return nil))) + + (format t "score-edit: writing ~A ...~%" *default-score-file*) + (format f "~A~%" score-name) ; put name on first line + (dolist (event score) ;cdr scor + (format f "~A " (event-time event)) ; print start time + (format f "~A " (event-dur event)) ; print duration + + (setf expr (event-expression event)) + + ; print the pitch and the rest of the attributes + (format f "~A " (expr-get-attr expr :pitch)) + (format f "~A~%" (expr-parameters-remove-attr expr :pitch))) + (close f) + (format t "score-edit: wrote ~A events~%" (length score)))) + + +;; Read in a data file stored in the score-edit format and save +;; it to the global variable it came from +(defun score-restore () + (prog ((inf (open *default-score-file*)) + name start dur pitch expr score) + (cond ((null inf) + (format t "score-restore: could not open ~A~%" *default-score-file*) + (return nil))) + (setf name (read inf)) ;; score name + (loop + (setf start (read inf)) + (cond ((null start) (return))) + (setf dur (read inf)) + (setf pitch (read inf)) + (setf expr (read inf)) + (cond (pitch + (setf expr (expr-set-attr expr :pitch pitch))))) + (close inf) + (setf (symbol-value name) score))) |