view tools/gsharp-output.lisp @ 164:27e29dd5978b

Add gsharp-output. *Warning: amuse-gsharp has moved*

darcs-hash:20071221114845-40ec0-c296d15b1bb242c36febcb33f4e6266680999818.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")

(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))
        (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 (car layers) (reverse events) time-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 (layer events time-signatures)
  "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?)
         (bar-starts (bar-starts time-signatures :crotchet crotchet-beats))
         (cluster) (bar (gsharp::make-melody-bar)) (cluster-time) (bar-no 0)
         (body (gsharp::body layer)))
    (gsharp::add-bar bar body bar-no)
    (do* ((events events (cdr events))
          (event (car events) (car events)))
         ((null events) layer)
      (when (and (cdr bar-starts)
                 (>= (timepoint event) (second bar-starts)))
        ;; new bar - and add 0 or more empty bars
        (dotimes (i (- (or (position-if #'(lambda (x) (> x (timepoint event)))
                                         bar-starts)
                            2)
                       2))
          ;; This only runs if one or more whole-bar rests is needed
          ;; in a layer.
          (incf bar-no)
          (setf bar (gsharp::make-melody-bar))
          (gsharp::add-bar bar body bar-no)
          (let* ((new-duration (quick-gs-duration (if (cdr bar-starts)
                                                      (- (second bar-starts)
                                                         (first bar-starts))
                                                      4)))
                 (rest (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))))
            (gsharp-mxml::add-element-at-duration rest bar 0))
          (setf bar-starts (cdr bar-starts)))
        ;; Move on to new bar
        (setf bar (gsharp::make-melody-bar)
              bar-starts (cdr bar-starts))
        (incf bar-no)
        (gsharp::add-bar bar body bar-no))
      (when (or (not cluster-time)
                (not (time= cluster-time (onset event))))
        ;; Not part of a pre-existant chord (this will have more
        ;; complicated logic when I add ties). Create a new cluster.
        (let* ((beat-duration (/ (duration event) crotchet-beats))
               ;; This hideous thing gives a duration that doesn't
               ;; overlap with the next note or barline. Unneccessary
               ;; when I fix ties and start supplying bar info to
               ;; duration function.
               (new-duration (quick-gs-duration (min beat-duration
                                                    (if (or (not (cdr events))
                                                            (time= (second events)
                                                                   event))
                                                        beat-duration
                                                        (/ (- (timepoint (second events))
                                                              (timepoint event))
                                                           crotchet-beats))
                                                    (if (cdr bar-starts)
                                                        (- (second bar-starts)
                                                           (/ (timepoint event)
                                                              crotchet-beats))
                                                        beat-duration)))))
          (setf cluster (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)))
          ;; 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 cluster bar (/ (- (/ (timepoint event)
                                                                     crotchet-beats)
                                                                  (car bar-starts))
                                                               4))
          (setf cluster-time (onset event))))
      (let ((pitch (pitch-for-gsharp event)))
        (gsharp::add-note cluster (make-instance 'gsharp::note
                                                 :pitch (first pitch)
                                                 :accidentals (second pitch)
                                                 :staff (car (gsharp::staves layer))))))))

;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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 quick-gs-duration (crotchets)
  ;; gsharp-durations-from-beats returns a list of durations. Take the
  ;; first (= largest).
  (car (gsharp-durations-from-beats crotchets)))

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