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