1;; seq.lsp -- sequence control constructs for Nyquist 2 3;; get-srates -- this either returns the sample rate of a sound or a 4;; vector of sample rates of a vector of sounds 5;; 6(defun get-srates (sounds) 7 (cond ((arrayp sounds) 8 (let ((result (make-array (length sounds)))) 9 (dotimes (i (length sounds)) 10 (setf (aref result i) (snd-srate (aref sounds i)))) 11 result)) 12 (t 13 (snd-srate sounds)))) 14 15; These are complex macros that implement sequences of various types. 16; The complexity is due to the fact that a behavior within a sequence 17; can reference the environment, e.g. (let ((p 60)) (seq (osc p) (osc p))) 18; is an example where p must be in the environment of each member of 19; the sequence. Since the execution of the sequence elements are delayed, 20; the environment must be captured and then used later. In XLISP, the 21; EVAL function does not execute in the current environment, so a special 22; EVAL, EVALHOOK must be used to evaluate with an environment. Another 23; feature of XLISP (see evalenv.lsp) is used to capture the environment 24; when the seq is first evaluated, so that the environment can be used 25; later. Finally, it is also necessary to save the current transformation 26; environment until later. 27; 28; The SEQ implementation passes an environment through closures that 29; are constructed to evaluate expressions. SEQREP is similar, but 30; the loop variable must be incremented and tested. 31; 32; Other considerations are that SEQ can handle multi-channel sounds, but 33; we don't know to call the snd_multiseq primitive until the first 34; SEQ expression is evaluated. Also, there's no real "NIL" for the end 35; of a sequence, so we need serveral special cases: (1) The sequences 36; is empty at the top level, so return silence, (2) There is one 37; expression, so just evaluate it, (3) there are 2 expressions, so 38; return the first followed by the second, (4) there are more than 39; 2 expressions, so return the first followed by what is effectively 40; a SEQ consisting of the remaining expressions. 41 42 43;; SEQ-EXPR-EXPAND - helper function, expands expression to push/pop entry 44;; on *sal-call-stack* to help debug calls into SAL from lazy evaluation 45;; of SAL code by SEQ 46(defun seq-expr-expand (expr source) 47 (if *sal-call-stack* 48 `(prog2 (sal-trace-enter '(,(strcat "Expression in " source ":") ,expr)) 49 ,expr ;; here is where the seq behavior is evaluated 50 (sal-trace-exit)) 51 expr)) 52 53 54(defun with%environment (env expr) 55 ;; (progv (var1 ...) (val1 ...) expression-list) 56 `(progv ',*environment-variables* ,env ,expr)) 57;(trace with%environment seq-expr-expand) 58 59(defmacro eval-seq-behavior (beh source) 60 ;(tracemacro 'eval-seq-behavior (list beh source) 61 (seq-expr-expand (with%environment 'nyq%environment 62 `(at-abs t0 63 (force-srates s%rate ,beh))) source));) 64 65;; Previous implementations grabbed the environment and passed it from 66;; closure to closure so that each behavior in the sequence could be 67;; evaluated in the saved environment using an evalhook trick. This 68;; version precomputes closures, which avoids using evalhook to get or 69;; use the environment. It's still tricky, because each behavior has 70;; to pass to snd-seq a closure that computes the remaining behavior 71;; sequence. To do this, I use a recursive macro to run down the 72;; behavior sequence, then as the recursion unwinds, construct nested 73;; closures that all capture the current environment. We end up with a 74;; closure we can apply to the current time to get a sound to return. 75;; 76(defmacro seq (&rest behlist) 77 ;; if we have no behaviors, return zero 78 (cond ((null behlist) 79 '(snd-zero (local-to-global 0) *sound-srate*)) 80 (t ; we have behaviors. Must evaluate one to see if it is multichan: 81 `(let* ((first%sound ,(seq-expr-expand (car behlist) "SEQ")) 82 (s%rate (get-srates first%sound)) 83 (nyq%environment (nyq:the-environment))) 84 ; if there's just one behavior, we have it and we're done: 85 ,(progn (setf behlist (cdr behlist)) 86 (if (null behlist) 'first%sound 87 ; otherwise, start the recursive construction: 88 `(if (arrayp first%sound) 89 (seq2-deferred snd-multiseq ,behlist) 90 (seq2-deferred snd-seq ,behlist)))))))) 91 92 93;; seq2-deferred uses seq2 and seq3 to construct nested closures for 94;; snd-seq. It is deferred so that we can first (in seq) determine whether 95;; this is a single- or multi-channel sound before recursively constructing 96;; the closures, since we only want to do it for either snd-seq or 97;; snd-multiseq, but not both. It simply calls seq2 to begin the expansion. 98;; 99(defmacro seq2-deferred (seq-prim behlist) 100 (seq2 seq-prim behlist)) 101 102 103#| 104;; for debugging, you can replace references to snd-seq with this 105(defun snd-seq-trace (asound aclosure) 106 (princ "Evaluating SND-SEQ-TRACE instead of SND-SEQ...\n") 107 (format t " Sound argument is ~A\n" asound) 108 (princ " Closure argument is:\n") 109 (pprint (get-lambda-expression aclosure)) 110 (princ " Calling SND-SEQ ...\n") 111 (let ((s (snd-seq asound aclosure))) 112 (format t " SND-SEQ returned ~A\n" s) 113 s)) 114 115;; also for debugging, you can uncomment some tracemacro wrappers from 116;; macro definitions. This function prints what the macro expands to 117;; along with name and args (which you add by hand to the call): 118(defun tracemacro (name args expr) 119 (format t "Entered ~A with args:\n" name) 120 (pprint args) 121 (format t "Returned from ~A with expression:\n" name) 122 (pprint expr) 123 expr) 124|# 125 126 127;; we have at least 2 behaviors so we need the top level call to be 128;; a call to snd-multiseq or snd-seq. This macro constructs the call 129;; and uses recursion with seq3 to construct the remaining closures. 130;; 131(defun seq2 (seq-prim behlist) 132 `(,seq-prim first%sound 133 (prog1 ,(seq3 seq-prim behlist) ; <- passed to seq-prim 134 ;; we need to remove first%sound from the closure 135 ;; to avoid accumulating samples due to an unnecessary 136 ;; reference: 137 (setf first%sound nil)))) 138 139;; construct a closure that evaluates to a sequence of behaviors. 140;; behlist has at least one behavior in it. 141;; 142(defun seq3 (seq-prim behlist) 143 `(lambda (t0) 144 (setf first%sound (eval-seq-behavior ,(car behlist) "SEQ")) 145 ,(progn (setf behlist (cdr behlist)) 146 (if (null behlist) 'first%sound 147 (seq2 seq-prim behlist))))) 148 149 150; we have to use the real loop variable name since it could be 151; referred to by the sound expression, so we avoid name collisions 152; by using % in all the macro variable names 153; 154(defmacro seqrep (loop-control snd-expr) 155 ;(tracemacro "SEQREP" (list loop-control snd-expr) 156 `(let ((,(car loop-control) 0) 157 (loop%count ,(cadr loop-control)) 158 (nyq%environment (nyq:the-environment)) 159 s%rate seqrep%closure) 160 ; note: s%rate will tell whether we want a single or multichannel 161 ; sound, and what the sample rates should be. 162 (cond ((not (integerp loop%count)) 163 (error "bad argument type" loop%count)) 164 ((< loop%count 1) 165 (snd-zero (local-to-global 0) *sound-srate*)) 166 ((= loop%count 1) 167 ,snd-expr) 168 (t ; more than 1 iterations 169 (setf loop%count (1- loop%count)) 170 (setf first%sound ,snd-expr) 171 (setf s%rate (get-srates first%sound)) 172 (setf nyq%environment (nyq:the-environment)) 173 (if (arrayp first%sound) 174 (seqrep2 snd-multiseq ,loop-control ,snd-expr) 175 (seqrep2 snd-seq ,loop-control ,snd-expr))))));) 176 177 178(defmacro seqrep2 (seq-prim loop-control snd-expr) 179 ;(tracemacro "SEQREP2" (list seq-prim loop-control snd-expr) 180 `(progn (setf seqrep%closure 181 (lambda (t0) ,(seqrep-iterate seq-prim loop-control snd-expr))) 182 (,seq-prim (prog1 first%sound (setf first%sound nil)) 183 seqrep%closure)));) 184 185 186(defun seqrep-iterate (seq-prim loop-control snd-expr) 187 (setf snd-expr `(eval-seq-behavior ,snd-expr "SEQREP")) 188 `(progn 189 (setf ,(car loop-control) (1+ ,(car loop-control))) ; incr. loop counter 190 (if (>= ,(car loop-control) loop%count) ; last iteration 191 ,snd-expr 192 (,seq-prim ,snd-expr seqrep%closure)))) 193 194 195;; TRIGGER - sums instances of beh which are launched when input becomes 196;; positive (> 0). New in 2021: input is resampled to *sound-srate*. 197;; As before, beh sample rates must match, so now they must also be 198;; *sound-srate*. This implementation uses eval-seq-behavior to create 199;; a more helpful stack trace for SAL. 200(defmacro trigger (input beh) 201 `(let* ((nyq%environment (nyq:the-environment)) 202 (s%rate *sound-srate*)) 203 (snd-trigger (force-srate *sound-srate* ,input) 204 #'(lambda (t0) (eval-seq-behavior ,beh "TRIGGER"))))) 205 206 207;; EVENT-EXPRESSION -- the sound of the event 208;; 209(setfn event-expression caddr) 210 211 212;; EVENT-HAS-ATTR -- test if event has attribute 213;; 214(defun event-has-attr (note attr) 215 (expr-has-attr (event-expression note))) 216 217 218;; EXPR-SET-ATTR -- new expression with attribute = value 219;; 220(defun expr-set-attr (expr attr value) 221 (cons (car expr) (list-set-attr-value (cdr expr) attr value))) 222 223(defun list-set-attr-value (lis attr value) 224 (cond ((null lis) (list attr value)) 225 ((eq (car lis) attr) 226 (cons attr (cons value (cddr lis)))) 227 (t 228 (cons (car lis) 229 (cons (cadr lis) 230 (list-set-attr-value (cddr lis) attr value)))))) 231 232 233;; EXPAND-AND-EVAL-EXPR -- evaluate a note, chord, or rest for timed-seq 234;; 235(defun expand-and-eval-expr (expr) 236 (let ((pitch (member :pitch expr))) 237 (cond ((and pitch (cdr pitch) (listp (cadr pitch))) 238 (setf pitch (cadr pitch)) 239 (simrep (i (length pitch)) 240 (eval (expr-set-attr expr :pitch (nth i pitch))))) 241 (t 242 (eval expr))))) 243 244 245;; (timed-seq '((time1 stretch1 expr1) (time2 stretch2 expr2) ...)) 246;; a timed-seq takes a list of events as shown above 247;; it sums the behaviors, similar to 248;; (sim (at time1 (stretch stretch1 expr1)) ...) 249;; but the implementation avoids starting all expressions at once 250;; 251;; Notes: (1) the times must be in increasing order 252;; (2) EVAL is used on each event, so events cannot refer to parameters 253;; or local variables 254;; 255;; If score events are very closely spaced (< 1020 samples), the block 256;; overlap can cause a ripple effect where to complete one block of the 257;; output, you have to compute part of the next score event, but then 258;; it in turn computes part of the next score event, and so on, until 259;; the stack overflows (if you have 1000's of events). 260;; 261;; This is really a fundamental problem in Nyquist because blocks are 262;; not aligned. To work around the problem (but not totally solve it) 263;; scores are evaluated up to a length of 100. If there are more than 264;; 100 score events, we form a balanced tree of adders so that maybe 265;; we will end up with a lot of sound in memory, but at least the 266;; stack will not overflow. Generally, we should not end up with more 267;; than 100 times as many blocks as we would like, but since the 268;; normal space required is O(1), we're still using constant space + 269;; a small constant * log(score-length). 270;; 271(setf MAX-LINEAR-SCORE-LEN 100) 272(defun timed-seq (score) 273 (must-be-valid-score "TIMED-SEQ" score) 274 (let ((len (length score)) 275 pair) 276 (cond ((< len MAX-LINEAR-SCORE-LEN) 277 (timed-seq-linear score)) 278 (t ;; split the score -- divide and conquer 279 (setf pair (score-split score (/ len 2))) 280 (sum (timed-seq (car pair)) (timed-seq (cdr pair))))))) 281 282;; score-split -- helper function: split score into two, with n elements 283;; in the first part; returns a dotted pair 284(defun score-split (score n) 285 ;; do the split without recursion to avoid stack overflow 286 ;; algorithm: modify the list destructively to get the first 287 ;; half. Copy it. Reassemble the list. 288 (let (pair last front back) 289 (setf last (nthcdr (1- n) score)) 290 (setf back (cdr last)) 291 (rplacd last nil) 292 (setf front (append score nil)) ; shallow copy 293 (rplacd last back) 294 (cons front back))) 295 296 297;; TIMED-SEQ-LINEAR - check to insure that times are strictly increasing 298;; and >= 0 and stretches are >= 0 299(defun timed-seq-linear (score) 300 (let ((start-time 0) error-msg rslt) 301 (dolist (event score) 302 (cond ((< (car event) start-time) 303 (error (format nil 304 "Out-of-order time in TIMED-SEQ: ~A, consider using SCORE-SORT" 305 event))) 306 ((< (cadr event) 0) 307 (error (format nil "Negative stretch factor in TIMED-SEQ: ~A" event))) 308 (t 309 (setf start-time (car event))))) 310 ;; remove rests (a rest has a :pitch attribute of nil) 311 (setf score (score-select score #'(lambda (tim dur evt) 312 (expr-get-attr evt :pitch t)))) 313 (cond ((and score (car score) 314 (eq (car (event-expression (car score))) 'score-begin-end)) 315 (setf score (cdr score)))) ; skip score-begin-end data 316 (cond ((null score) (s-rest 0)) 317 (t 318 (at (caar score) 319 (seqrep (i (length score)) 320 (progn 321 (cond (*sal-call-stack* 322 (sal-trace-enter (list "Score event:" (car score)) nil nil) 323 (setf *sal-line* 0))) 324 (setf rslt 325 (cond ((cdr score) 326 (prog1 327 (set-logical-stop 328 (stretch (cadar score) 329 (expand-and-eval-expr (caddar score))) 330 (- (caadr score) (caar score))) 331 (setf score (cdr score)))) 332 (t 333 (stretch (cadar score) (expand-and-eval-expr 334 (caddar score)))))) 335 (if *sal-call-stack* (sal-trace-exit)) 336 rslt))))))) 337