;; xmseq.lsp -- implements score-from-seq()
;;
;; Roger B. Dannenberg
;; April 2021
;;
;; This file is a supplement to xm.lsp, the "xmusic" library of Nyquist
;; that supports scores and pattern generators. This function converts
;; sequences (SEQ structures) to scores. SEQ structures read/write from/to
;; allegro and MIDI files.
;;
;; (score-from-seq seq rate: rate channels: chans :prog pflag
;;    :bend btype :cpress cptype :ctrl ctype
;;    :synths synths)
;;
;; converts a SEQ into a score and control functions.
;; The return value of score-from-seq is the score, and *rslt* is, as a
;; side effect, set to an array of 16 entries which may be nil or
;; control-functions objects.
;;
;; seq is a SEQ.
;; rate is the sample rate for any generated control signals. It
;;     defaults to 441 Hz, which means if the rate is upsampled
;;     to control audio, there is a 2.2 ms ramp between adjacent samples.
;; chans is a list of FIXNUMS from 0 to 15 representing what channels
;;     should be incorporated into the score.
;; pflag tells whether to incorporate program changes into score events.
;;     If true, every event includes the attribute :prog, with
;;     the MIDI program number (0 based) as parameter. Default is nil.
;; btype and cptype indicate interest in bend and pressure messages.
;;     Either of these attributes may be nil (default), :contin (interested
;;     in data as continuous messages sampled at rate), or :onset 
;;     (interested only in the value at note onset). In the case of :onset,
;;     every note will have a :bend or :cpress attribute with the latest
;;     value from a MIDI message on the relevant channel.
;; ctype indicates interest in control change messages. It must be nil
;;     (default) for no interest, :contin as with btype and cptype, or
;;     the list (:onset c1 c2 ... cn) where c1 through cn are FIXNUMs
;;     indicating the controllers of interest. In this case, each score
;;     event will have a :ctrl attribute whose value is a list of the
;;     form ((c1 v1) (c2 v2) ... (cn vn)) giving the current values
;;     (normalized to the FLONUM range 0 to 127/128) at event onset
;;     time of controllers c1 ... cn.
;;     As a special case for LSB controllers, controllers 0 through 31
;;     contain the FLONUM sum of ((value_of_controller_N +
;;     value_of_controller_N_plus_32 / 128) / 128, and if there is no
;;     value for controller_N_plus_32, it defaults to zero.
;;     
;; synths is a mapping from channels to functions as a list in the form
;;     ((ch0 sy0) (ch1 sy1) ... (chn syn) (* default)) where chi are
;;     channel numbers and syi are function names (symbols) used for
;;     score events. If no specific mapping exists for a channel, and
;;     (* default) is present, then default is used. If there is no
;;     default, then NOTE is used.
;;
;; Control functions are constructed and stored in objects of class
;; control-functions and returned as array elements of *rslt*, which
;; has 16 elements for 16 channels.  The control functions
;; are SOUNDs derived from MIDI pitch bend, channel aftertouch and
;; control change messages. When any of these is present and requested,
;; an object is constructed and accessed through a functional interface.
;; If ctrls is the object, then
;;     (ctrlfn-bend? ctrl) is non-null if there is a pitch bend function
;;     (ctrlfn-cpress? ctrl) is non-null if there is a channel pressure function
;;     (ctrlfn-ctrl? ctrl number) is non-null if there is a control change for
;;          the controller number (0 to 122)
;;     (ctrlfn-bend ctrl) gives pitch bend function.
;;     (ctrlfn-cpress ctrl) gives channel pressure
;;     (ctrlfn-ctrl ctrl number) gives the control change function
;;          for the controller with the given number (0 to 122, except 32-63)
;;          Controllers 32-63 are considered LSB for controllers 0-31 so
;;          numbers 32-63 are always missing. If there are no controls,
;;          CONST is used to construct a control function with the duration
;;          determined by the environment and a value of zero except for
;;          controller 7 (volume pedal) with value 1.
;; Note that key-pressure (polyphonic aftertouch) is not represented in
;; the SEQ data structure. These MIDI messages are ignored.
;;
;; For each note, if there is any control function on the same channel
;; as the note, then the score event for the note will contain the
;; attribute/value pair :contin control-functions, where control-functions
;; is the control functions object for the channel. Note that the :contin
;; attribute/value pair will not print as a readable value and cannot be
;; written to a file. (You can filter out the :contin attributes and
;; write everything else if you wish.)
;;

;; class for continuous functions for a channel
;; basically, this is just
;;   struct { float bend; float cpress; float ctrls[122] } ctrlfns[16];
;; that is, a collection of control parameters for each channel.
;; Details:
;;   If there is no MIDI message, the channel or ctrls[i] could be nil
;;   This object is used 3 ways:
;;   - for discrete parameters, it stored FLONUMS. When you fetch a control
;;      from 0 to 31, you get the sum of MSB and LSB controls, and you get
;;      nil for controls 32-64.
;;   - for contin (parameters as SOUNDs) parameters, PWL lists are prepared
;;   - after reading the whole MIDI file, contin parameters are converted
;;      to sounds, with ctrls[0-31] being the sum of MSB (0-31) and
;;      LSB (32-63) parameters, and controls 32-63 replaced with nil.
;;
;; SEE BELOW FOR "PUBLIC" FUNCTIONS THAT YOU SHOULD USE
;;
;; INTERNAL FUNCTIONS HERE: DO NOT CALL THE FUNCTIONS:
;;
(defun must-be-control-function (x &optional (default 0.0))
  (if x x (const default)))
(defun must-be-value (x &optional (default 0.0)) (if x x default))

(setf control-functions (send class :new '(bend cpress ctrls)))
(send control-functions :answer :bend '() '(bend))
(send control-functions :answer :set-bend '(b) '((setf bend b)))
(defun ctrlfn-bendval (cf) (must-be-value (send cf :bend)))

(send control-functions :answer :cpress '() '(cpress))
(send control-functions :answer :set-cpress '(p) '((setf cpress p)))
(defun ctrlfn-cpressval (cf) (must-be-value (send cf :cpress)))

(send control-functions :answer :ctrls? '() '(ctrls))
(send control-functions :answer :ctrls '()
      '((if ctrls ctrls (setf ctrls (make-array 122)))))
(send control-functions :answer :ctrl '(num) '((if ctrls (aref ctrls num) nil)))
(send control-functions :answer :set-ctrl '(num x)
      '((setf (aref (send self :ctrls) num) x)))
;; get the value for given controller number. Controllers 0-31 can have
;; an LSB control at num+32, and this is automatically scaled and added in.
;; If you retrieve controller 32-63, you get a value from 0 to 1 as if it
;; is not a LSB (so in this case there is no scaling).
(defun ctrlfn-ctrlval (cf num)
  (if cf
      (let ((val1 (must-be-value (ctrlfn-ctrl? cf num)         ;; default volume
                                 (if (= num 7) (/ 127 128.0) 0.0))) ; is 127/128
            (val2 0.0))
        (if (< num 32)
            (setf val2 (must-be-value (ctrlfn-ctrl? cf (+ num 32)))))
        (+ val1 (/ val2 128.0)))
      nil))


;; PUBLIC API FUNCTIONS FOR ACCESSING THE VALUE OF contin: ATTRIBUTES IN SCORES
;;
(defun ctrlfn-bend? (cf) (if cf (send cf :bend) nil))
(defun ctrlfn-bend (cf) (must-be-control-function (ctrlfn-bend? cf)))
(defun ctrlfn-cpress? (cf) (if cf (send cf :cpress) nil))
(defun ctrlfn-cpress (cf) (must-be-control-function (ctrlfn-cpress? cf)))
(defun ctrlfn-ctrl? (cf num) (if cf (send cf :ctrl num) cf))
(defun ctrlfn-ctrl (cf num)
  (must-be-control-function (ctrlfn-ctrl? cf num)       ;; default for volume
                            (if (= num 7) (/ 127 128.0) 0.0))) ;;  is 127/128


;; print-control-functions -- debugging print
(defun print-control-functions (desc vals)
  (let (ctrl val)
    (format t "print-control-functions - ~A:~%" desc)
    (cond (vals
           (dotimes (chan 16)
             (setf ctrl (aref vals chan))
             (cond (ctrl
                    (format t "    chan ~A: bend ~A cpress ~A"
                            chan (send ctrl :bend) (send ctrl :cpress))
                    (cond ((send ctrl :ctrls?) ;; are there any controls at all?
                           (format t " ctrls")
                           (dotimes (i 122)
                             (if (ctrlfn-ctrl? ctrl i) ;; control i exists?
                                 (format t " (~A ~A)"
                                         i (ctrlfn-ctrl? ctrl i))))))
                    (format t "~%"))))))))
      


(defun score-from-seq (seq &key rate channels synths
                           prog bend cpress ctrl)
  (prog ((the-seq (seq-copy seq))
         (last-time 0) ; last time of any event; score's stop time in ms
         event     ; each seq event, not a score event
         tag       ; the event's tag (type code)
         ctrl-fns  ; array of all control changes. Initially created as
                   ;   a reversed argument list for pwl-list
         contin    ; list of tags we need ctrl-fns for
         discrete  ; list of tags we need lastest value for
         controls  ; list of controllers to be provided as :ctrl value
         programs  ; array of current programs
         ctrl-vals ; similar to ctrl-fns but only has latest value
         score     ; the score in reverse
         new-last-time  ; used in the loop to update last-time
         )
    (setf channels (if channels channels
                       '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)))
    (setf programs (vector 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
    (cond ((eq bend :contin)
           (setf contin (cons seq-bend-tag contin)))
          ((eq bend :onset)
           (setf discrete (cons seq-bend-tag discrete))))
    (cond ((eq cpress :contin)
           (setf contin (cons seq-cpress-tag contin)))
          ((eq cpress :onset)
           (setf discrete (cons seq-cpress-tag discrete))))
    (cond ((eq ctrl :contin)
           (setf contin (cons seq-ctrl-tag contin)))
          ((eq (first ctrl) :onset)
           (setf discrete (cons seq-ctrl-tag discrete))
           (setf controls (rest ctrl))))
    loop
    (setf new-last-time last-time)
    (setf event (seq-get the-seq))
    ; (display "score-from-seq seq-get" event)
    (setf tag (seq-tag event))
    (cond ((= tag seq-note-tag)
           (setf score (score-add-note score event channels synths
                                       (if prog programs nil)
                                       discrete controls ctrl-vals))
           ;; get new end time if new note is computed:
           (if *rslt* (setf new-last-time *rslt*)))
          ((= tag seq-prgm-tag)
           ; (display "score-from-seq program change" (seq-program event))
           (setf (aref programs (seq-channel event))
                 (seq-program event))
           (setf new-last-time (seq-time event)))
          ((= tag seq-done-tag)
           (go exit-loop))
          ((member tag contin)
           (setf ctrl-fns (ctrl-fns-add-change ctrl-fns event))
           (setf new-last-time (seq-time event)))
          ((member tag discrete)
           (setf ctrl-vals (ctrl-vals-add-change ctrl-vals event))
           ; (print-control-functions "ctrl-vals in score-from-seq" ctrl-vals)
           (setf new-last-time (seq-time event))))
    ;; always compute the max because the final last time could
    ;; be the end time of the first note, even if it's not the
    ;; last seq event we looked at:
    (setf last-time (max last-time new-last-time))
    (seq-next the-seq)
    (go loop)
    exit-loop
    (setf *rslt* (generate-ctrl-fns ctrl-fns last-time))
    (setf score (reverse score))
    (if *rslt*
      (setf score (score-apply score #'(lambda (time dur expr)
                    (let* ((chan (expr-get-attr expr :chan))
                           (contin (aref *rslt* chan)))
                      (list time dur
                            (if contin
                                (expr-set-attr expr :contin contin)
                                expr)))))))
    ;; last-time is in units of ms, so convert to seconds
    (setf score (score-set-begin (score-set-end score last-time) 0))
    (return score)))


(defun generate-ctrl-fns (ctrl-fns last-time)
  (cond ((null ctrl-fns) nil)
        (t
         ;(print-control-functions "ctrl-fns before generating sounds" ctrl-fns)
         (dotimes (i 16)
           (generate-ctrl-fns-channel (aref ctrl-fns i) last-time))))
  ctrl-fns)

(setf CTRL-SCALE-FACTOR (/ 128.0))

(defun generate-ctrl-fns-channel (chan-ctrls last-time)
  ;; skip all processing if there are no control changes on this channel
  (cond (chan-ctrls
         (if (ctrlfn-bend? chan-ctrls)  ;; convert bends to SOUND if bends exist
             (send chan-ctrls :set-bend
                   (generate-ctrl-fn (send chan-ctrls :bend) last-time)))
         (if (ctrlfn-cpress? chan-ctrls) ;; convert cpress to SOUND if exist
             (send chan-ctrls :set-cpress
                   (generate-ctrl-fn (send chan-ctrls :cpress) last-time)))
         (let ((ctrls (send chan-ctrls :ctrls?)) lsb)
           (cond (ctrls
                  (dotimes (i 122)
                    (setf (aref ctrls i)
                          (generate-ctrl-fn (aref ctrls i) last-time)))
                  ;; controls are tricky: 32 to 63 are LSB to 0 to 31
                  (dotimes (i 32)
                    (setf lsb (aref ctrls (+ i 32)))
                    (if lsb (setf lsb (scale CTRL-SCALE-FACTOR lsb)))
                    (cond ((and (aref ctrls i) lsb)
                           ;; add MSB and LSB. MSB goes 0 to 1
                           (setf (aref ctrls i) (sum (aref ctrls i) lsb)))
                          (lsb
                           (setf (aref ctrls i) lsb)))
                    (setf (aref ctrls (+ i 32)) nil))))))))

(defun generate-ctrl-fn (lis last-time)
  (cond (lis
         ;; if lis ends in ... val, it should be extended to
         ;;     ... val last-time val last-time 0
         ;; enter those values in reverse at the front of the reversed list:
         (setf lis (reverse (cons 0         (cons last-time
                            (cons (car lis) (cons last-time lis))))))
         ;; remove extra (0, 0) from beginning if any
         (if (and (zerop (first lis)) (zerop (second lis)) (zerop (third lis)))
             (setf lis (cddr lis)))
         (pwl-list lis))
        (t nil)))

;; get event time in seconds rather than ms
(defun seq-seconds (event) (* (seq-time event) 0.001))

;; get normalized bend from event
(defun seq-bend-norm (event) (/ (- (seq-bend event) 8192) 8191.0))

;; get normalized cpress from event
(defun seq-cpress-norm (event) (* (seq-touch event) CTRL-SCALE-FACTOR))

;; get normalized control change value from event
(defun seq-ctrl-norm (event) (* (seq-value event) CTRL-SCALE-FACTOR))

;(setf BEND-INDEX 0 CPRESS-INDEX 2 CTRL-INDEX 1)
;(setf tag-to-index (list (cons seq-bend-tag BEND-INDEX)
;                         (cons seq-cpress-tag CPRESS-INDEX)
;                         (cons seq-ctrl-tag CTRL-INDEX)))

;; ctrl-fns-add-change - a control change was found that we need to
;; record. Initially, we build reversed parameter lists for pwl-list,
;; so reverse of t1 0 t1 v1 t2 v1 t2 v2 ...
;; so cons of list is prev, and we append time prev time new, which
;; backwards is: new time prev time.
;; First point is a special case with prev = 0.
(defun ctrl-fns-add-change (ctrl-fns event)
  (let ((tag (seq-tag event)) chan-ctrls index i ctrls points)
    ;; make sure ctrl-fns exists
    (if (not ctrl-fns) (setf ctrl-fns (make-array 16)))
    ;; make sure bend-ctrl-cpress slots exist for this channel:
    (setf chan-ctrls (aref ctrl-fns (seq-channel event)))
    (cond ((not chan-ctrls)
           (setf chan-ctrls (send control-functions :new))
           (setf (aref ctrl-fns (seq-channel event)) chan-ctrls)))
    ;; test for extra level of array nesting
    (cond ((= tag seq-bend-tag)
           (setf points (send chan-ctrls :bend))
           (send chan-ctrls :set-bend
                 (extend-control-breakpoints points
                   (seq-seconds event) (seq-bend-norm event))))
          ((= tag seq-cpress-tag)
           (setf points (send chan-ctrls :cpress))
           (send chan-ctrls :set-cpress
                 (extend-control-breakpoints points
                   (seq-seconds event) (seq-cpress-norm event))))
          ((= tag seq-ctrl-tag)
           ;; :ctrls method makes sure array of 122 ctrls exists:
           (setf points (send chan-ctrls :ctrls))
           (setf i (seq-control event))
           ; (display "control add" i (seq-ctrl-norm event))
           (send chan-ctrls :set-ctrl i
                 (extend-control-breakpoints (aref points i)
                   (seq-seconds event) (seq-ctrl-norm event)))))
    ctrl-fns))


;; helper function to append to the reversed pwl list
(defun extend-control-breakpoints (points time val) 
  (let ((prev (if points (car points) 0)))
    (cons val (cons time (cons prev (cons time points))))))
                    

(defun ctrl-vals-add-change (ctrl-vals event)
  (let ((tag (seq-tag event)) chan-vals ctrls)
    ;; make sure ctrl-vals exists
    (if (not ctrl-vals) (setf ctrl-vals (make-array 16)))
    (setf chan-vals (aref ctrl-vals (seq-channel event)))
    ;; make sure bend/cpress/ctrl slots exist for this channel:
    (cond ((not chan-vals)
           (setf chan-vals (send control-functions :new))
           (setf (aref ctrl-vals (seq-channel event)) chan-vals)))
    ;; test for extra level of array nesting
    (cond ((= tag seq-bend-tag) ;; bend and cpress are per-channel values
           (send chan-vals :set-bend (seq-bend-norm event)))
          ((= tag seq-cpress-tag)
           (send chan-vals :set-cpress (seq-cpress-norm event)))
          ((= tag seq-ctrl-tag)
           (send chan-vals :set-ctrl (seq-control event)
                 (seq-ctrl-norm event))))
    ctrl-vals))
                    

;; score-add-note - insert a new note at the front of score
;; returns (new) score
;; sets *rslt* to end time of note if a new note is created, but if
;; note is not in the requested channels, score is not changed and
;; *rslt* is set to nil.
;;
;; channels is list of channels to put in the score
;; synths is mapping from channel to synthesis function
;; programs is array of current program for each channel
;; tags is a list with control tags for controls to be added to score events:
;;     list elements can be seq-bend-tag, seq-cpress-tag, seq-ctrl-tag
;; controls is a list of control numbers to be added to ctrl: parameters
;;     (only if seq-ctrl-tag is in tags)
;; vals is the current state of discrete controls: bend, cpress and ctrl
;;
;; helper function:
(defun get-ctrl-val (ctrlvals control)
  (let ((val (aref ctrlvals control)) lsb)
    (cond ((< control 32)
           (setf lsb (aref ctrlvals (+ control 32)))
           (cond (lsb
                  (setf val (if val val 0))
                  (setf val (+ val (/ lsb 128.0)))))))
    val)) ;; returns nil if no control MSB or LSB
           

(defun add-control-vals (chvals controls expr)
  (let (ctrls)
    (dolist (control controls)
      (cond ((ctrlfn-ctrl? chvals control)
             (setf ctrls
                   (cons (list control (ctrlfn-ctrlval chvals control))
                         ctrls)))))
    (if ctrls ;; quote ctrls because they get evaluated
        (expr-set-attr expr :ctrl (list 'quote ctrls))
        expr)))


(defun score-add-note (score event channels synths programs tags controls vals)
  (prog ((chan (seq-channel event))
         (pitch (seq-pitch event))
         (vel (seq-velocity event))
         (when (seq-time event))
         (dur (seq-duration event))
         expr event synth
         chvals) ; array of bend, cpress, ctrl for current channel
    (cond ((not (member chan channels))
           (setf *rslt* nil)
           (return score)))
    (setf synth (assoc chan synths))
    (cond (synth
           (setf synth (second synth)))
          (t
           (setf synth (assoc '* synths))
           (setf synth (if synth (second synth) 'NOTE))))
    (setf expr (list synth :chan chan :pitch pitch :vel vel))
    (if programs
        (setf expr (expr-set-attr expr :prog (aref programs chan))))
    ;; add onset controls if any
    (if vals (setf chvals (aref vals chan)))
    (cond (chvals
           (dolist (tag tags)
             (cond ((= tag seq-bend-tag)
                    (if (ctrlfn-bend? chvals)
                        (setf expr (expr-set-attr expr :bend
                                                  (ctrlfn-bend chvals)))))
                   ((= tag seq-cpress-tag)
                    (if (ctrlfn-cpress? chvals)
                        (setf expr (expr-set-attr expr :cpress
                                                  (ctrlfn-cpress chvals)))))
                   ((= tag seq-ctrl-tag)
                    (cond ((send chvals :ctrls?)
                           (setf expr (add-control-vals
                                       chvals controls expr)))))))))
    ;; add event
    (setf event (list (* when 0.001) (* dur 0.001) expr))
    (setf *rslt* (event-end event))
    ; (display "score-add-note" event *rslt*)
    (return (cons event score))))


;; midi-ctrl-get -- gets the SOUND corresponding to type and number
'(defun midi-ctrl-get (ctrls type &optional number)
  (if ctrls
      (cond ((eq type :bend) (aref ctrls BEND-INDEX))
            ((eq type :cpress) (aref ctrls CPRESS-INDEX))
            ((and (eq type :ctrl) (aref ctrls CTRL-INDEX))
             (aref (aref ctrls CTRL-INDEX) number))
            (t nil))
      nil))

;; midi-ctrl-get-snd -- gets the SOUND corresponding to type and number
'(defun midi-ctrl-get-snd (ctrls type &optional number)
  (let ((snd (midi-ctrl-get ctrls type number)))
    (if snd snd (const 0))))