;; 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.
;
; The SEQ implementation passes an environment through closures that
; are constructed to evaluate expressions. SEQREP is similar, but
; the loop variable must be incremented and tested.
;
; Other considerations are that SEQ can handle multi-channel sounds, but
; we don't know to call the snd_multiseq primitive until the first
; SEQ expression is evaluated. Also, there's no real "NIL" for the end
; of a sequence, so we need serveral special cases: (1) The sequences
; is empty at the top level, so return silence, (2) There is one
; expression, so just evaluate it, (3) there are 2 expressions, so 
; return the first followed by the second, (4) there are more than
; 2 expressions, so return the first followed by what is effectively
; a SEQ consisting of the remaining expressions.


;; SEQ-EXPR-EXPAND - helper function, expands expression to push/pop entry 
;;    on *sal-call-stack* to help debug calls into SAL from lazy evaluation
;;    of SAL code by SEQ
(defun seq-expr-expand (expr source)
  (if *sal-call-stack*
    `(prog2 (sal-trace-enter '(,(strcat "Expression in " source ":") ,expr))
            ,expr ;; here is where the seq behavior is evaluated
            (sal-trace-exit))
    expr))


(defun with%environment (env expr)
  ;; (progv (var1 ...) (val1 ...) expression-list)
  `(progv ',*environment-variables* ,env ,expr))
;(trace with%environment seq-expr-expand)

(defmacro eval-seq-behavior (beh source)
  ;(tracemacro 'eval-seq-behavior (list beh source)
  (seq-expr-expand (with%environment 'nyq%environment
                      `(at-abs t0
                               (force-srates s%rate ,beh))) source));)

;; Previous implementations grabbed the environment and passed it from
;; closure to closure so that each behavior in the sequence could be
;; evaluated in the saved environment using an evalhook trick. This
;; version precomputes closures, which avoids using evalhook to get or
;; use the environment. It's still tricky, because each behavior has
;; to pass to snd-seq a closure that computes the remaining behavior
;; sequence. To do this, I use a recursive macro to run down the
;; behavior sequence, then as the recursion unwinds, construct nested
;; closures that all capture the current environment. We end up with a
;; closure we can apply to the current time to get a sound to return.
;;
(defmacro seq (&rest behlist)
  ;; if we have no behaviors, return zero
  (cond ((null behlist)
         '(snd-zero (local-to-global 0) *sound-srate*))
        (t  ; we have behaviors. Must evaluate one to see if it is multichan:
         `(let* ((first%sound ,(seq-expr-expand (car behlist) "SEQ"))
                 (s%rate (get-srates first%sound))
                 (nyq%environment (nyq:the-environment)))
            ; if there's just one behavior, we have it and we're done:
            ,(progn (setf behlist (cdr behlist))
                    (if (null behlist) 'first%sound
                        ; otherwise, start the recursive construction:
                        `(if (arrayp first%sound)
                             (seq2-deferred snd-multiseq ,behlist)
                             (seq2-deferred snd-seq ,behlist))))))))


;; seq2-deferred uses seq2 and seq3 to construct nested closures for
;; snd-seq. It is deferred so that we can first (in seq) determine whether
;; this is a single- or multi-channel sound before recursively constructing
;; the closures, since we only want to do it for either snd-seq or
;; snd-multiseq, but not both. It simply calls seq2 to begin the expansion.
;;
(defmacro seq2-deferred (seq-prim behlist)
  (seq2 seq-prim behlist))


#|
;; for debugging, you can replace references to snd-seq with this
(defun snd-seq-trace (asound aclosure)
  (princ "Evaluating SND-SEQ-TRACE instead of SND-SEQ...\n")
  (format t "  Sound argument is ~A\n" asound)
  (princ "  Closure argument is:\n")
  (pprint (get-lambda-expression aclosure))
  (princ "  Calling SND-SEQ ...\n")
  (let ((s (snd-seq asound aclosure)))
    (format t "  SND-SEQ returned ~A\n" s)
    s))

;; also for debugging, you can uncomment some tracemacro wrappers from
;; macro definitions. This function prints what the macro expands to
;; along with name and args (which you add by hand to the call):
(defun tracemacro (name args expr)
  (format t "Entered ~A with args:\n" name)
  (pprint args)
  (format t "Returned from ~A with expression:\n" name)
  (pprint expr)
  expr)
|#

  
;; we have at least 2 behaviors so we need the top level call to be
;; a call to snd-multiseq or snd-seq. This macro constructs the call
;; and uses recursion with seq3 to construct the remaining closures.
;;
(defun seq2 (seq-prim behlist)
  `(,seq-prim first%sound
              (prog1 ,(seq3 seq-prim behlist)  ; <- passed to seq-prim
                     ;; we need to remove first%sound from the closure
                     ;; to avoid accumulating samples due to an unnecessary
                     ;; reference:
                     (setf first%sound nil))))

;; construct a closure that evaluates to a sequence of behaviors.
;; behlist has at least one behavior in it.
;;
(defun seq3 (seq-prim behlist)
  `(lambda (t0)
     (setf first%sound (eval-seq-behavior ,(car behlist) "SEQ"))
     ,(progn (setf behlist (cdr behlist))
             (if (null behlist) 'first%sound
                 (seq2 seq-prim behlist)))))


; we have to use the real loop variable name since it could be
; referred to by the sound expression, so we avoid name collisions
; by using % in all the macro variable names
;
(defmacro seqrep (loop-control snd-expr)
  ;(tracemacro "SEQREP" (list loop-control snd-expr)
  `(let ((,(car loop-control) 0)
         (loop%count ,(cadr loop-control))
         (nyq%environment (nyq:the-environment))
         s%rate seqrep%closure)
     ; 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))
           ((< loop%count 1)
            (snd-zero (local-to-global 0) *sound-srate*))
           ((= loop%count 1)
            ,snd-expr)
           (t ; more than 1 iterations
            (setf loop%count (1- loop%count))
            (setf first%sound ,snd-expr)
            (setf s%rate (get-srates first%sound))
            (setf nyq%environment (nyq:the-environment))
            (if (arrayp first%sound)
                (seqrep2 snd-multiseq ,loop-control ,snd-expr)
                (seqrep2 snd-seq ,loop-control ,snd-expr))))));)


(defmacro seqrep2 (seq-prim loop-control snd-expr)
  ;(tracemacro "SEQREP2" (list seq-prim loop-control snd-expr)
  `(progn (setf seqrep%closure
                (lambda (t0) ,(seqrep-iterate seq-prim loop-control snd-expr)))
          (,seq-prim (prog1 first%sound (setf first%sound nil))
                     seqrep%closure)));)


(defun seqrep-iterate (seq-prim loop-control snd-expr)
  (setf snd-expr `(eval-seq-behavior ,snd-expr "SEQREP"))
  `(progn
     (setf ,(car loop-control) (1+ ,(car loop-control))) ; incr. loop counter
     (if (>= ,(car loop-control) loop%count) ; last iteration 
         ,snd-expr
         (,seq-prim ,snd-expr seqrep%closure))))


;; TRIGGER - sums instances of beh which are launched when input becomes
;;     positive (> 0). New in 2021: input is resampled to *sound-srate*.
;;     As before, beh sample rates must match, so now they must also be
;;     *sound-srate*. This implementation uses eval-seq-behavior to create
;;     a more helpful stack trace for SAL.
(defmacro trigger (input beh)
  `(let* ((nyq%environment (nyq:the-environment))
          (s%rate *sound-srate*))
     (snd-trigger (force-srate *sound-srate* ,input)
                  #'(lambda (t0) (eval-seq-behavior ,beh "TRIGGER")))))


;; 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
;;
;; If score events are very closely spaced (< 1020 samples), the block
;; overlap can cause a ripple effect where to complete one block of the
;; output, you have to compute part of the next score event, but then
;; it in turn computes part of the next score event, and so on, until
;; the stack overflows (if you have 1000's of events).
;;
;; This is really a fundamental problem in Nyquist because blocks are
;; not aligned. To work around the problem (but not totally solve it)
;; scores are evaluated up to a length of 100. If there are more than
;; 100 score events, we form a balanced tree of adders so that maybe
;; we will end up with a lot of sound in memory, but at least the
;; stack will not overflow. Generally, we should not end up with more
;; than 100 times as many blocks as we would like, but since the
;; normal space required is O(1), we're still using constant space +
;; a small constant * log(score-length).
;;
(setf MAX-LINEAR-SCORE-LEN 100)
(defun timed-seq (score)
  (must-be-valid-score "TIMED-SEQ" score)
  (let ((len (length score))
        pair)
    (cond ((< len MAX-LINEAR-SCORE-LEN)
           (timed-seq-linear score))
          (t ;; split the score -- divide and conquer
           (setf pair (score-split score (/ len 2)))
           (sum (timed-seq (car pair)) (timed-seq (cdr pair)))))))

;; score-split -- helper function: split score into two, with n elements
;;                in the first part; returns a dotted pair
(defun score-split (score n)
  ;; do the split without recursion to avoid stack overflow
  ;; algorithm: modify the list destructively to get the first
  ;; half. Copy it. Reassemble the list.
  (let (pair last front back)
    (setf last (nthcdr (1- n) score))
    (setf back (cdr last))
    (rplacd last nil)
    (setf front (append score nil)) ; shallow copy
    (rplacd last back)
    (cons front back)))

 
;; TIMED-SEQ-LINEAR - check to insure that times are strictly increasing
;;                    and >= 0 and stretches are >= 0
(defun timed-seq-linear (score)
  (let ((start-time 0) error-msg rslt)
    (dolist (event score)
      (cond ((< (car event) start-time)
             (error (format nil
                     "Out-of-order time in TIMED-SEQ: ~A, consider using SCORE-SORT"
                     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
    (cond ((null score) (s-rest 0))
          (t
           (at (caar score)
               (seqrep (i (length score))
                 (progn
                   (cond (*sal-call-stack*
                          (sal-trace-enter (list "Score event:" (car score)) nil nil)
                          (setf *sal-line* 0)))
                   (setf rslt
                     (cond ((cdr score)
                            (prog1
                              (set-logical-stop
                                (stretch (cadar score)
                                  (expand-and-eval-expr (caddar score)))
                                (- (caadr score) (caar score)))
                              (setf score (cdr score))))
                           (t
                            (stretch (cadar score) (expand-and-eval-expr
                                                    (caddar score))))))
                   (if *sal-call-stack* (sal-trace-exit))
                   rslt)))))))