Mercurial > hg > amuse
changeset 164:27e29dd5978b
Add gsharp-output. *Warning: amuse-gsharp has moved*
darcs-hash:20071221114845-40ec0-c296d15b1bb242c36febcb33f4e6266680999818.gz
| author | d.lewis <d.lewis@gold.ac.uk> |
|---|---|
| date | Fri, 21 Dec 2007 11:48:45 +0000 |
| parents | 83023a2668d2 |
| children | f59787f1101e |
| files | amuse-gsharp.asd implementations/gsharp/amuse-gsharp.asd tools/gsharp-output.lisp |
| diffstat | 3 files changed, 351 insertions(+), 7 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/amuse-gsharp.asd Fri Dec 21 11:48:45 2007 +0000 @@ -0,0 +1,14 @@ +(asdf:defsystem amuse-gsharp + :depends-on (amuse gsharp) + :components + ((:module implementations + :components + ((:module gsharp + :components + ((:file "package") + (:file "classes" :depends-on ("package")) + (:file "methods" :depends-on ("package" "classes")) + (:file "gsharp-import" :depends-on ("package" "classes")))))) + (:module tools + :components + ((:file "gsharp-output")))))
--- a/implementations/gsharp/amuse-gsharp.asd Tue Dec 18 12:02:03 2007 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -(asdf:defsystem amuse-gsharp - :depends-on (amuse gsharp) - :components - ((:file "package") - (:file "classes" :depends-on ("package")) - (:file "methods" :depends-on ("package" "classes")) - (:file "gsharp-import" :depends-on ("package" "classes"))))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tools/gsharp-output.lisp Fri Dec 21 11:48:45 2007 +0000 @@ -0,0 +1,337 @@ +;; 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)))