annotate tools/gsharp-output.lisp @ 180:1a2b876b5587

ECOLM functionality for tabcode implementation

darcs-hash:20080708152414-40ec0-be5878c3d42affaf70ad7d08e987ba2223f5fa59.gz

;; This file is for methods creating and using gsharp score buffers
;; for output. This would generally involve rendering to screen, file,
;; printer or browser.
;;
;; The interface doesn't obviously align perfectly with the gsharp
;; data structure, so some notes on the key elements are included
;; here:
;;
;; amuse:events have no direct analogue, with their attributes divided
;; between notes and clusters:
;;
;; * notes have a pitch with a number that is 1- the diatonic
;; component of mips pitch and an accidental that is one of a list of
;; keyword options, most relevant being :sharp :natural :flat
;; :double-sharp and :double-flat
;;
;; * clusters are the rhythmic and positional aspect of one or more
;; notes. Duration is stored in terms of notehead (:long :breve :whole
;; :half :filled) and, for :filled, lbeams and rbeams for the number
;; of beams in each direction, supplemented by a dots slot. To render
;; this to a number for standard time within amuse, there is a method,
;; gsharp:duration, for which a crotchet is 1/4
;;
;; Parts and staffs are viewed notationally, so we have largely
;; independant structures called layers (roughly = voices) and staves
;; (as they appear on the page). These have names and, at the moment,
;; are being identified by a string-getting method below. Within a
;; layer, clusters are to be found in bar objects and listed in the
;; bars slot.
;;
;; The musical entity into which these slot is a segment, and there
;; can be multiple segments in a buffer, though what this means and
;; how they relate is as yet a mystery to me.
;;
;;; IMPLEMENTATION
;; 
;; We're creating a buffer. Lots of this code is adapted from
;; gsharp/mxml/mxml.lisp, but wouldn't now be recognised
;;
;; * Clef is guessed at - we need amuse:get-applicable-clef (and
;; amuse:clef)
;;
;; * Anacruses are ignored unless they have their own time-signatures!
;;
;; The stages used are:
;;  1 - find layers (1:1 with staves at the moment)
;;  2 - for each layer, get events and their timings (includes
;;  rounding/quantization)
;;  3 - Find all ties needed for graphical/courtesy reasons (includes
;;  removal of extraneous rests and other artefacts)
;;  4 - Generate gsharp clusters
;;  5 - Get gsharp pitch for events and add notes to clusters
;;  


(in-package "AMUSE-TOOLS")

(defparameter *rounding-factor* 1/4)

(defstruct gsharp-duration 
  "Structure for specifying duration-related parameters for g-sharp"
  notehead (beams 0) (dots 0) (tied-p nil))

;;;;;;;;;;;;;;;;;;;;;
;; Top-level methods

(defparameter *foo* nil)

(defun write-gsharp-eps (composition pathname)
  ;; write a score eps from a composition. Most of this can be copied
  ;; straight (this is copied already from CSR's code)
  ;; Boilerplate stuff:
  (let* ((frame (clim:make-application-frame 'gsharp:gsharp))
         (clim:*application-frame* frame)
         (esa:*esa-instance* frame))
      (clim:adopt-frame (clim:find-frame-manager :server-path '(:null)) frame)
      (clim:execute-frame-command frame '(gsharp::com-new-buffer))
      ;; Now generate the buffer
      (fill-gsharp-buffer-with-constituent (car (esa:buffers frame)) composition)
      ;; Refresh and process
      (setf (gsharp::modified-p (car (esa:buffers frame))) t)
      (gsharp::recompute-measures (car (esa:buffers frame)))
      ;; Print
      (setf *foo* (car (esa:buffers frame)))
      (clim:execute-frame-command
       frame `(gsharp::com-print-buffer-to-file ,pathname))))

;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Big `walking through data structures' type functions

(defgeneric fill-gsharp-buffer-with-constituent (buffer constituent)
  (:documentation "Takes an empty gsharp buffer and a constituent and
  fills the buffer based on the contents of constituent. Buffer is
  returned, but this is not necessary, since it is modified in
  place."))
(defmethod fill-gsharp-buffer-with-constituent (buffer (composition composition))
  ;; FIXME: Throughout this, I assume that
  ;; get-applicable-time-signatures isn't '()
  (let ((time-signatures (get-applicable-time-signatures composition composition))
        (key-signatures (get-applicable-key-signatures composition composition))
        (layers))
    (multiple-value-bind (layer-events layer-scores)
        ;; Get hash-tables of events by layer and counts of events
        ;; below middle C for guessing clef.
        (identify-gsharp-layers composition)
      ;; For each layer make clef, and one staff per layer
      ;; FIXME: this is cheating
      (maphash #'(lambda (name events)
                   (let* ((clef (if (> (gethash name layer-scores)
                                       (/ (length events) 2))
                                    (gsharp::make-clef :bass)
                                    (gsharp::make-clef :treble)))
                          (staff (gsharp::make-fiveline-staff :name name
                                                              :clef clef)))
                     ;; Make the layers
                     (push (gsharp::make-layer (list staff)
                                               :body (gsharp::make-slice :bars nil)
                                               :name name)
                           layers)
                     ;; Add the notes and bars
                     (add-bars-and-events-to-layer (car layers) (reverse events)
                                                   time-signatures composition
                                                   :key-signatures key-signatures)))
               layer-events)
      ;; Attach layers to a segment and place segment into buffer
      (let* ((segment (make-instance 'gsharp::segment :layers layers :buffer buffer)))
        (setf (gsharp::segments buffer) (list segment)
              (gsharp::staves buffer) (mapcar #'(lambda (x) (car (gsharp::staves x)))
                                              layers))
        buffer))))

(defgeneric identify-gsharp-layers (constituent)
  (:documentation "Takes a composition, returns two hash tables, one
  of events grouped by layer name and the other of counts of notes
  below middle C by layer (for choosing clef). N.B. On two counts this
  is a dodgy way of tying clef, staff and layer. Separate later."))

(defmethod identify-gsharp-layers ((composition composition))
  (let ((layer-events (make-hash-table :test #'equal))
        (layer-scores (make-hash-table :test #'equal))
        (layer-clefs (make-hash-table :test #'equal))
        (layer-name))
    (sequence:dosequence (event composition (values layer-events layer-scores))
      (when (pitchedp event)
        (setf layer-name (gsharp-layer-string event))
        (cond
          ((gethash layer-name layer-events)
           (push event (gethash layer-name layer-events))
           (when (< (midi-pitch-number event) 60)
             (incf (gethash layer-name layer-scores))))
          (t (setf (gethash layer-name layer-events)
                   (list event)
                   (gethash layer-name layer-scores)
                   (if (< (midi-pitch-number event) 60)
                       1 0))))))))

(defun add-bars-and-events-to-layer (layer events time-signatures composition
                                     &key (key-signatures nil))
  "Given list of events to be attached to a layer, along with
  applicable time signatures, clumsily waddle through them all and
  slap an approximation to the events into place. Improve this."
  (let* (
;;         (crotchet-beats (duration (crotchet (car events)))) ;; (or make into semibreves?)
;;         (beat-starts (beat-starts time-signatures 
;;                                   :crotchet crotchet-beats))
;;         (bar-starts (mapcar #'car beat-starts))
         (bar-starts (let ((starts))
                       (do ((bar-period (amuse::current-bar (make-standard-moment 0) composition)
                                        (amuse::current-bar (cut-off bar-period) composition)))
                           ((time>= (cut-off bar-period) (cut-off composition))
                            (reverse (cons (timepoint bar-period) starts)))
                         (push (timepoint bar-period) starts))))
         (beat-starts (if time-signatures
                          (let ((starts) (current))
                            (do* ((bars bar-starts)
                                  (beat-period (amuse::current-beat (make-standard-moment 0) composition)
                                               (amuse::current-beat (cut-off beat-period) composition))
                                  (beat-time (timepoint beat-period) (timepoint beat-period)))
                                 ((time>= (onset beat-period) (cut-off composition))
                                  (reverse (if current
                                               (cons (reverse current) starts)
                                               starts)))
                              (when (and (cdr bars)
                                         (>= beat-time (second bars)))
                                (push (reverse current) starts)
                                (setf current nil
                                      bars (cdr bars)))
                              (push beat-time current)))
                          (mapcar #'list bar-starts)))
         (ons) (position)
         (clusters) (bar) (bar-no 0)
         (body (gsharp::body layer)))
    ;; this is a cheat to guess timing rounding (quantisation) based
    ;; on onset times - only affects midi-like data where onsets are
    ;; already rounded, but durations are not (as in TC's fantasia
    ;; midi files....)
    (setf *rounding-factor* (max (guess-rounding-factor events)
                                 1/8))
    ;; First create a list of change-points for when events are
    ;; sounding, of the format (time event event event) (time event))
    (dolist (event events)
      (setf ons (add-on-off-pair event ons)))
    ;; These durations may span bars, which is an absolute ban for
    ;; most music (Mensurstrich aside), so insert bar starts if not
    ;; present. Note that, since the events themselves are recorded in
    ;; the list, the existence of ties shuold be detected.
    (when bar-starts
      (setf ons (add-bar-starts-if-not-present bar-starts ons)))
    ;; Finally, one problem here is that, in midi, there is often a
    ;; gap or overlap between consecutive notes or chords. Since
    ;; rounding happens, but there is no check for bar length here or
    ;; within g-sharp, this should verify that everything makes
    ;; sense. At the moment, it just removes short rests...
    (setf ons (check-ons ons bar-starts))
    ;; Now create the bars and the gsharp clusters
    (when key-signatures
      (setf (gsharp::keysig (car (gsharp::staves layer)))
            (make-gsharp-key-signature (car key-signatures) layer)))
    (do ((old-ons nil ons)
         (ons ons (cdr ons)))
        ((null (cdr ons)))
      (when (member (caar ons) bar-starts)
        ;; We're at the beginning of a bar.
        (when bar (check-beams bar))
        (setf bar (gsharp::make-melody-bar))
        (gsharp::add-bar bar body bar-no)
        (incf bar-no)
        (setf position 0))
      (when (and key-signatures
                 (<= (timepoint (car key-signatures))
                     (caar ons)))
        (gsharp::add-element (make-gsharp-key-signature (car key-signatures) layer)
                             bar
                             position)
        (incf position)
        (setf key-signatures (cdr key-signatures)))
      ;; A quick check for notes which span beats and don't start at
      ;; the beginning of their beats. IMO, this makes them more
      ;; likely to require a tie.
      (when (and (cdr ons)
		 (not (member (caar ons)
                              (car beat-starts)))
                 (find-if #'(lambda (x) (> x (caar ons)))
			  (car beat-starts))
                 (< (find-if #'(lambda (x) (> x (caar ons)))
			     (car beat-starts))
                    (car (second ons))))
        (setf (cdr ons)
              (cons (cons (find-if #'(lambda (x) (> x (caar ons)))
                                   (car beat-starts))
                          (cdar ons))
                    (cdr ons))))
      ;; Making clusters just from duration removes the ability to
      ;; divide notes into easy-to-read tied components based on the
      ;; time signature (for example, a note of a tactus beat + a
      ;; quaver in 6/8 will be rendered as a minim this way) - that's
      ;; why I've taken as much of the metrical logic out and put it
      ;; above if there are other straightforward rules, they should,
      ;; I think go there.
      (if (cdar ons)
          (setf clusters (make-gsharp-clusters-with-duration (- (car (second ons))
								(car (car ons)))))
          (setf clusters (make-gsharp-rests-with-duration (- (car (second ons))
							     (car (car ons)))
							  layer)))
      (let ((now (caar ons)) (first-p t) (pitches))
        (do ((clusters clusters (cdr clusters)))
            ((null clusters))
          (when (member now (car beat-starts))
            (setf (gsharp::lbeams (car clusters)) 0))
          ;; This function adds cluster at a specific point in the
          ;; bar. It does a lot of other things that are probably a)
          ;; not necessary or b) should be within the duration logic
          ;; above. Would be good not to rely on it (which is not to
          ;; say that it isn't reliable)
          (gsharp::add-element (car clusters) bar position)
          ;; FIXME: Deleting notes that fall on the same note
          ;; name. Stupid thing to do.
          (setf pitches (remove-duplicates (mapcar #'(lambda (x)
                                                       (cons x (pitch-for-gsharp x composition)))
                                                   (cdar ons))
                                           :key #'second :test #'=))
          (dolist (pitch pitches)
            (with-simple-restart (ignore "Ignore note")
              (gsharp::add-note (car clusters)
                                (make-instance 'gsharp::note
                                               :pitch (second pitch)
                                               :accidentals (third pitch)
                                               :staff (car (gsharp::staves layer))
                                               :tie-right (if (or (cdr clusters)
                                                                  (member (car pitch) (second ons)))
                                                              t
                                                              nil)
                                               :tie-left (if first-p
                                                             (member (car pitch) (first old-ons))
                                                             t)))))
          (incf now (* (gsharp::duration (car clusters)) 4))
          (setf first-p nil)
          (incf position)))
      (when (and (cdr bar-starts)
                 (= (car (second ons))
                    (second bar-starts)))
        (setf bar-starts (cdr bar-starts)
              beat-starts (cdr beat-starts))))))

(defun check-beams (bar)
  (do* ((clusters (gsharp::elements bar) (cdr clusters))
        (left) (mid) (right))
       ((null (cddr clusters)))
    (setf left (first clusters)
          mid (second clusters)
          right (third clusters))
    (unless (or (typep mid 'gsharp::rest)
                (= (max (gsharp::rbeams mid)
                        (gsharp::lbeams mid))
                   0))
      (cond
        ((or (typep left 'gsharp::rest)
             (= (gsharp::rbeams left) 0))
         (setf (gsharp::lbeams mid) 0))
        ((or (typep right 'gsharp::rest)
             (= (gsharp::lbeams right) 0))
         (setf (gsharp::rbeams mid) 0))
        ((< (gsharp::rbeams left)
            (gsharp::lbeams right))
         (setf (gsharp::lbeams mid) (gsharp::rbeams left)))
        (t (setf (gsharp::rbeams mid) (gsharp::lbeams right)))))))

(defgeneric make-gsharp-key-signature (key-signature layer))
(defmethod make-gsharp-key-signature ((key-signature standard-key-signature) layer)
  (let ((alterations (make-array 7))
        (order-of-sharps #(3 0 4 1 5 2 6))
        (order-of-flats #(6 2 5 1 4 0 3)))
    (if (< (key-signature-sharps key-signature) 0)
        (dotimes (index (abs (key-signature-sharps key-signature)))
          (setf (elt alterations (elt order-of-flats index)) :flat))
        (dotimes (index (key-signature-sharps key-signature))
          (setf (elt alterations (elt order-of-sharps index)) :sharp)))
    (gsharp-buffer::make-key-signature (car (gsharp::staves layer))
                                       :alterations alterations)))

;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Information conversion functions

;; Pitch

(defgeneric pitch-for-gsharp (pitch composition)
  (:documentation "Given a pitch object, return a list of gsharp's
  pitch number and accidental keyword"))
(defmethod pitch-for-gsharp ((pitch diatonic-pitch) composition)
  (declare (ignore composition))
  ;; Easy for diatonic pitch, although behaviour for extreme or
  ;; fractional alterations is unclear.
  (list (1+ (diatonic-pitch-mp pitch))
        (case (diatonic-pitch-accidental pitch)
            (1 :sharp)
            (-1 :flat)
            (2 :double-sharp)
            (-2 :double-flat)
            (0 :natural)
            (otherwise (error "gsharp can't handle this pitch")))))
(defmethod pitch-for-gsharp ((pitch chromatic-pitch) composition)
  ;; Just go for line-of-fifths proximity spelling, but based on
  ;; keysig if present. Could always try to spell it with ps13, but..
  (let* ((octave (octave pitch))
         (pitch-class (pitch-class pitch))
         (diatonic-pitch-number (aref #(0 0 1 2 2 3 3 4 4 5 6 6) pitch-class)))
    (list (+ (* 7 octave) diatonic-pitch-number)
          (aref #(:natural :sharp ;; C  C#
                  :natural        ;; D
                  :flat :natural  ;; Eb E
                  :natural :sharp ;; F  F#
                  :natural :sharp ;; G  G#
                  :natural        ;; A
                  :flat :natural) ;; Bb B
                pitch-class))))
(defmethod pitch-for-gsharp ((event standard-chromatic-pitched-event) composition)
  ;; Should probably go for line-of-fifths proximity spelling, 
  ;; if keysig present, but ps13ing for now.
  (let* ((octave (octave event))
         (event-pos (position event (ocp-list composition) :key #'car))
         (note-sequence (get-spelling-list composition))
         (spelling (elt note-sequence event-pos))
         (note-name (cdr (assoc (aref (second spelling) 0)
                                '(("C" . 0) ("D" . 1) ("E" . 2) ("F" . 3)
                                  ("G" . 4) ("A" . 5) ("B" . 6))
                                :test #'string=)))
         (accidental (cdr (assoc (aref (second spelling) 1)
                                 '(("ss" . :double-sharp) ("s" . :sharp) ("n" . :natural)
                                   ("f" . :flat) ("ff" . :double-flat))
                                 :test #'string=))))
    (list (+ (* 7 octave) note-name) accidental)))
         
    
(defparameter *spelling-cache* (make-hash-table))
(defparameter *ocp-cache* (make-hash-table))

(defun get-spelling-list (composition)
  (unless (gethash composition *spelling-cache*)
    (setf (gethash composition *spelling-cache*) 
          (ps13:ps13-new-imp (map 'list #'cdr (get-ocp-list composition))
                             10 42 nil nil nil)))
  (gethash composition *spelling-cache*))

(defun get-ocp-list (composition)
  (unless (gethash composition *ocp-cache*)
    (setf (gethash composition *ocp-cache*) (ocp-list composition)))
  (gethash composition *ocp-cache*))

(defun ocp-list (composition)
  (flet ((sorter (x y)
           (or (amuse:time< x y)
               (and (amuse:time= x y)
                    (amuse:pitch< x y)))))
    (loop for e being each element of composition
          if (typep e 'amuse:pitched-event)
          collect (cons e (make-array 2 :initial-contents 
                                      (list (slot-value e 'amuse::time)
                                            (- (slot-value e 'amuse::number) 21)))) into result
          finally (return (sort result #'sorter :key #'car)))))




;; Time 

(defun make-gsharp-clusters-with-duration (duration)
  "Returns a list of cluster(s) whose total duration is equal to
  duration (which is given in crotchets)"
  (let ((new-durations (gsharp-durations-from-beats duration)))
    (loop for new-duration in new-durations
         collect (gsharp::make-cluster :notehead (gsharp-duration-notehead new-duration)
                                       :lbeams (gsharp-duration-beams new-duration)
                                       :rbeams (gsharp-duration-beams new-duration)
                                       :dots  (gsharp-duration-dots new-duration)))))

(defun make-gsharp-rests-with-duration (duration layer)
  "Returns a list of rest(s) whose total duration is equal to
  duration (which is given in crotchets)"
  (let ((new-durations (gsharp-durations-from-beats duration)))
    (loop for new-duration in new-durations
       collect(gsharp::make-rest (car (gsharp::staves layer))
                                 :notehead (gsharp-duration-notehead new-duration)
                                 :lbeams (gsharp-duration-beams new-duration)
                                 :rbeams (gsharp-duration-beams new-duration)
                                 :dots  (gsharp-duration-dots new-duration)))))

(defun gsharp-durations-from-beats (beats &optional (durations nil))
  ;; Takes a count of crotchets and returns a list of
  ;; <gsharp-duration>s that most simply defines the attached.  This
  ;; is a recursive function that finds the longest simple duration
  ;; that fits into beats and, if that leaves a remainder, runs again
  ;; on the remainder (until hemi-demi-semi-quavers are reached). It
  ;; avoids double dots and is ignorant of time-signature. It will be
  ;; replaced. Soon.
  ;;; FIXME: Handles quantisation fairly
  ;; stupidly. Could be made slightly smarter with simple rounding
  ;; (erring on the side of longer durations?)
  (assert (>= beats 0))
  (push (make-gsharp-duration) durations)
  ;; First find the longest simple duration that fits in beats
  ;; First with notes > 1 crotchet
  (loop for option in '((16 :long) (8 :breve) (4 :whole) (2 :half) (1 :filled))
     do (cond
          ((= beats (* (car option) 7/4))
           (setf (gsharp-duration-notehead (car durations))
                 (cadr option)
                 (gsharp-duration-dots (car durations))
                 2)
           (return-from gsharp-durations-from-beats (reverse durations)))
          ((= beats (* (car option) 3/2))
           (setf (gsharp-duration-notehead (car durations))
                 (cadr option)
                 (gsharp-duration-dots (car durations))
                 1)
           (return-from gsharp-durations-from-beats (reverse durations)))
          ((> beats (car option))
           (setf (gsharp-duration-notehead (car durations))
                 (cadr option))
           (return-from gsharp-durations-from-beats
             (gsharp-durations-from-beats (- beats (car option)) durations)))
          ((= beats (car option))
           (setf (gsharp-duration-notehead (car durations))
                 (cadr option))
           (return-from gsharp-durations-from-beats (reverse durations)))))
  (setf (gsharp-duration-notehead (car durations))
        :filled)
  ;; then with short notes (beams rather than noteheads)
  (do ((i 1 (1+ i)))
      ((= i 4) ;; means either tuplet, very short note or unquantised data
       (reverse durations))
    (cond
      ((= beats (* (/ 1 (expt 2 i)) 3/2))
       (setf (gsharp-duration-beams (car durations))
             i
             (gsharp-duration-dots (car durations))
             1)
       (return-from gsharp-durations-from-beats (reverse durations)))
      ((> beats (/ 1 (expt 2 i)))
       (setf (gsharp-duration-beams (car durations))
             i)
       (return-from gsharp-durations-from-beats
         (gsharp-durations-from-beats (- beats (/ 1 (expt 2 i))) durations)))
      ((= beats (/ 1 (expt 2 i)))
       (setf (gsharp-duration-beams (car durations))
             i)
       (return-from gsharp-durations-from-beats (reverse durations))))))

;;;;;;;;;;;;;;;;;;;;;
;; 
;; Other utility functions

(defgeneric gsharp-layer-string (event)
  (:method (e) (name-from-channel-and-patch e))
  (:method ((e amuse-gsharp::gsharp-object))
    (name-from-layer e))
  (:documentation "Return a string that uniquely identifies the layer
  to which event belongs"))

(defun name-from-layer (event)
  ;; Uses gsharp layer names. Numbers layers in cases of duplication
  (let* ((layers (gsharp::layers
                  (car
                   (gsharp::segments
                    (gsharp::buffer
                     (gsharp::staff
                      (amuse-gsharp::note event)))))))
         (layer (gsharp::layer
                 (gsharp::slice
                  (gsharp::bar
                   (gsharp::cluster
                    (amuse-gsharp::note event))))))
         (name (gsharp::name layer))
         (count))
    (dolist (cand-layer layers)
      (if (eq cand-layer layer)
          (if count
              (return-from name-from-layer (concatenate 'string
                                                        name
                                                        (princ-to-string count)))
              (return-from name-from-layer name))
          (when (string= name (gsharp::name cand-layer))
            (setf count (if count (+ count 1) 2)))))))

(defun name-from-channel-and-patch (event)
  "Generate layer-identifying string from the patch and channel that
would be used for midi export. For MIDI, this is guaranteed to
separate or over-separate. Tracks would possibly be better, but ?don't
exist in MIDI type 0?"
  (format nil "~D/~D"
          (get-patch-for-midi event)
          (get-channel-for-midi event)))

(defun bar-starts (time-signature-list &key (crotchet 1))
  (loop for time-signature in time-signature-list
     nconc (loop for i from (timepoint (onset time-signature))
                to (1- (timepoint (cut-off time-signature)))
                by (* (crotchets-in-a-bar time-signature) crotchet)
                collect i)))

(defun beat-starts (time-signature-list &key (crotchet 1))
  ;; provides a list of bars, each a list of beats. If no timesig,
  ;; guesses at 4/4
  ;; FIXME: This is stupid and should disappear if and when proper
  ;; beat methods are implemented.
  (if time-signature-list
      (loop for time-signature in time-signature-list
         nconc (loop for i from (timepoint (onset time-signature))
                  to (1- (timepoint (cut-off time-signature)))
                  by (* (crotchets-in-a-bar time-signature) crotchet)
                  collect (loop for j from 0
                             to (* (crotchets-in-a-bar time-signature)
                                   crotchet)
                             by (* (tactus-duration time-signature)
                                   crotchet)
                             collect (+ j i))))
      ;; FIXME: fudge
      (loop for i from 0 to 1000 by 4
         collect (loop for j from i to (+ i 3) 
                    collect j))))

;;;;;;;;;;;;;;;;;;
;;
;; Sequence and data structure functions


(defun add-bar-starts-if-not-present (bar-starts changes)
  "Takes a list of bar-start times and one of sounding notes at
times. If a bar has no change of sounding notes at its start, it would
not appear in the latter list, but since we will want notes tied over
barlines, we must add it and return the modified list"
  (let ((new-changes))
    (dolist (event changes (reverse new-changes))
      (do ()
          ((not (and bar-starts
                     (< (car bar-starts)
                        (car event)))))
        (setf new-changes
              (cons (if (cadr new-changes)
                        (cons (car bar-starts)
                              (cdar new-changes))
                        (list (car bar-starts)))
                    new-changes)
              bar-starts (cdr bar-starts)))
      (setf new-changes (cons event new-changes))
      (when (and bar-starts (= (car event) (car bar-starts)))
        (setf bar-starts (cdr bar-starts))))))

(defun add-on-off-pair (event data)
  "For walking through an ordered event sequence and building up a
list of changes to sounding pitches, this function takes an event and
adds the time for which it sounds to the structure."
  (let ((copied-data)
        (on (* (round
                (* (timepoint event)
                   (duration (crotchet event)))
                *rounding-factor*) *rounding-factor*))
        (off (* (round
                 (* (timepoint (cut-off event))
                    (duration (crotchet event)))
                 *rounding-factor*) *rounding-factor*)))
    (do ((data data (cdr data)))
        ((null data) (reverse (cons (list off)
                                    (cons (list on event)
                                          copied-data))))
      (cond
        ((<= on (caar data))
         (when (< on (caar data))
           (push (cons on (cons event (cdr (car copied-data))))
                 copied-data))
         (do ((data data (cdr data)))
             ((null data)
              (return-from add-on-off-pair
                (reverse (cons (cons off (cddr (car copied-data)))
                               copied-data))))
           (cond
             ((= (caar data) off)
              (return-from add-on-off-pair
                (nconc (reverse copied-data) data)))
             ((> (caar data) off)
              (push (cons off (cddr (car copied-data)))
                    copied-data)
              (return-from add-on-off-pair
                (nconc (reverse copied-data) data)))
             ((< (caar data) off)
              (push (cons (caar data) 
                          (cons event (cdr (car data))))
                    copied-data)))))
        (t
         (push (car data) copied-data))))))

(defun check-ons (ons bar-starts)
  "looks for small rests such as might be created by midi performance
of tenuto lines"
  (let ((time (caar ons)) (notes (cdar ons))(new-ons))
    (do ((ons (cdr ons) (cdr ons)))
        ((null ons) (reverse new-ons))
      (if (or (member (caar ons) bar-starts)
              (> (- (caar ons) time)
                 *rounding-factor*))
          (setf new-ons (cons (cons time notes) new-ons)
                time (caar ons)
                notes (cdar ons))
          (dolist (note (cdar ons))
            (unless (member note notes)
              (push note notes)))))))

#+nil

(defun check-ons (ons)
  "looks for small rests such as might be created by midi performance
of tenuto lines"
  (let ((new-ons) (skip))
    (do ((ons ons (cdr ons)))
        ((null (cdr ons))
         (if skip (reverse new-ons) (reverse (cons (car ons) new-ons))))
      (cond
	(skip (setf skip nil))
	((not (and (<= (- (car (second ons))
			  (car (first ons)))
		       *rounding-factor*)
		   (null (cdr (first ons)))))
	 (if (<= (- (car (second ons))
		    (car (first ons)))
		 *rounding-factor*)
	     (progn
	       (push (cons (caar ons) (remove-duplicates (nconc (cdr (first ons))
								(cdr (second ons)))))
		     new-ons)
	       (setf skip t))
	     (push (car ons) new-ons)))))))


(defun guess-rounding-factor (events)
  "Assuming that only durations need quantising, look at the lcd for
onsets"
  (let ((rounding-factor (/ 1 *rounding-factor*)))
    (when events
	(let ((crotchet (duration (crotchet (car events)))))
	  (do ((events events (cdr events)))
	      ((null (cdr events)))
	    (do ((divisor rounding-factor (* 2 divisor)))
		((<= (rem (* (timepoint (car events)) crotchet)
			  divisor)
		     (/ divisor 3))
		 (setf rounding-factor divisor))))))
    (/ 1 rounding-factor)))

(defun guess-rounding-factor-smart (events)
  "Assuming that only durations need quantising, look at the lcd for
onsets"
  (let ((times (map 'list #'(lambda (x)
                              (denominator (* (timepoint x)
                                              (duration (crotchet x)))))
                    events)))
    (/ 1 (apply #'lcm times))))