diff options
Diffstat (limited to 'runtime/seq.lsp')
| -rw-r--r-- | runtime/seq.lsp | 252 |
1 files changed, 252 insertions, 0 deletions
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))))))))))) + + + |