annotate tools/gsharp-output.lisp @ 167:4cb3ec07831f

Finish moving get-applicable from amuse-geerdes

darcs-hash:20080101132215-40ec0-ce1cb48a47fc7a5a7e2e51ebf0d74d572771c7fb.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)

(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

(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
      (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
                                                   :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)))
    (sequence:dosequence (event composition (values layer-events layer-scores))
      (when (pitchedp event)
        (cond
          ((gethash (gsharp-layer-string event) layer-events)
           (push event (gethash (gsharp-layer-string event) layer-events))
           (when (< (midi-pitch-number event) 60)
             (incf (gethash (gsharp-layer-string event) layer-scores))))
          (t (setf (gethash (gsharp-layer-string event) layer-events)
                   (list event)
                   (gethash (gsharp-layer-string event) layer-scores)
                   (if (< (midi-pitch-number event) 60)
                       1 0))))))))

(defun add-bars-and-events-to-layer (layer events time-signatures &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))
         (ons)
         (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))
    ;; Now create the bars and the gsharp clusters
    (do ((old-ons nil ons)
         (ons ons (cdr ons)))
        ((null (cdr ons)))
      (when (member (caar ons) bar-starts)
        (setf bar (gsharp::make-melody-bar))
        (gsharp::add-bar bar body bar-no)
        (incf bar-no))
      ;; 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 (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 (cdr (car 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))
        (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-mxml::add-element-at-duration (car clusters)
                                                bar
                                                (/ (- now (car bar-starts))
                                                   4))
          (dolist (note (cdr (car ons)))
            (when note
              (let ((pitch (pitch-for-gsharp note)))
                (gsharp::add-note (car clusters)
                                  (make-instance 'gsharp::note
                                                 :pitch (first pitch)
                                                 :accidentals (second pitch)
                                                 :staff (car (gsharp::staves layer))
                                                 :tie-right (if (cdr clusters)
                                                                t
                                                                (member note (second ons)))
                                                 :tie-left (if first-p
                                                               (member note (first old-ons))
                                                               t))))))
          (incf now (* (gsharp::duration (car clusters)) 4))
          (setf first-p nil)))
      (when (and (cdr bar-starts)
                 (= (car (second ons))
                    (second bar-starts)))
        (setf bar-starts (cdr bar-starts)
              beat-starts (cdr beat-starts))))
    (dolist (key-signature key-signatures)
      ;; code half-inched from mxml.lisp (maybe there's a useful
      ;; function to be abstracted here?), but I don't really
      ;; understand how key changes work...?
      (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)))
        (setf (gsharp::keysig (car (gsharp::staves layer)))
              (gsharp-buffer::make-key-signature (car (gsharp::staves layer))
                                                 :alteration alterations))))))

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

;; Pitch

(defgeneric pitch-for-gsharp (pitch)
  (:documentation "Given a pitch object, return a list of gsharp's
  pitch number and accidental keyword"))
(defmethod pitch-for-gsharp ((pitch diatonic-pitch))
  ;; 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))
  ;; Just go for line-of-fifths proximity spelling. Could always try
  ;; to spell it, 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))))

;; 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))
  (:documentation "Return a string that uniquely identifies the layer
  to which event belongs"))

(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))
  (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)))))

;;;;;;;;;;;;;;;;;;
;;
;; 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)
  "looks for small rests such as might be created by midi performance
of tenuto lines"
  (let ((new-ons))
    (do ((ons ons (cdr ons)))
        ((null (cdr ons))
         (reverse (cons (car ons) new-ons)))
      (unless (and (<= (- (car (second ons))
                          (car (first ons)))
                       *rounding-factor*)
                   (null (cdr (first ons))))
        (push (car ons) new-ons)))))

(defun guess-rounding-factor (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))))