Mercurial > hg > amuse
changeset 168:f1d0ea63581c
Improved spelling for score output. amuse-gsharp now depends on ps13
darcs-hash:20080103134532-40ec0-e36c64cecc14ce9f821da7381d546c9e87bc7f63.gz
| author | d.lewis <d.lewis@gold.ac.uk> |
|---|---|
| date | Thu, 03 Jan 2008 13:45:32 +0000 |
| parents | 4cb3ec07831f |
| children | 4a0e15e2829a |
| files | amuse-gsharp.asd implementations/gsharp/classes.lisp implementations/gsharp/methods.lisp tools/gsharp-output.lisp |
| diffstat | 4 files changed, 165 insertions(+), 51 deletions(-) [+] |
line wrap: on
line diff
--- a/amuse-gsharp.asd Tue Jan 01 13:22:15 2008 +0000 +++ b/amuse-gsharp.asd Thu Jan 03 13:45:32 2008 +0000 @@ -1,5 +1,5 @@ (asdf:defsystem amuse-gsharp - :depends-on (amuse gsharp) + :depends-on (amuse gsharp ps13) :components ((:module implementations :components
--- a/implementations/gsharp/classes.lisp Tue Jan 01 13:22:15 2008 +0000 +++ b/implementations/gsharp/classes.lisp Thu Jan 03 13:45:32 2008 +0000 @@ -1,14 +1,16 @@ (cl:in-package "AMUSE-GSHARP") -(defclass gsharp-composition (amuse:standard-composition) +(defclass gsharp-object ()()) + +(defclass gsharp-composition (amuse:standard-composition gsharp-object) ((buffer :initarg :buffer :reader buffer) (tempi :initarg :tempi :reader tempi))) -(defclass gsharp-pitched-event (standard-chromatic-pitched-event) +(defclass gsharp-pitched-event (standard-chromatic-pitched-event gsharp-object) ((note :initarg :note :reader note) (slice-index :initarg :slice-index))) -(defclass gsharp-identifier (identifier) +(defclass gsharp-identifier (identifier gsharp-object) ((pathname :initarg :path :reader %gsharp-identifier-pathname :initform 'nil))
--- a/implementations/gsharp/methods.lisp Tue Jan 01 13:22:15 2008 +0000 +++ b/implementations/gsharp/methods.lisp Thu Jan 03 13:45:32 2008 +0000 @@ -55,3 +55,16 @@ (gsharp::frame-find-file frame (%gsharp-identifier-pathname id))) (defmethod import-from-identifier (frame (id gsharp-mxml-identifier)) (clim:execute-frame-command frame `(gsharp::com-import-musicxml ,(%gsharp-identifier-pathname id)))) + +(defmethod get-applicable-key-signatures (anchored-period (composition gsharp-composition)) + (let ((keysigs)) + (sequence::dosequence (event composition (reverse keysigs)) + (cond + ((overlaps event anchored-period) + (unless (member (gsharp::keysig event) keysigs) + (push (gsharp::keysig event) keysigs))) + ((not (before event anchored-period)) + (return-from get-applicable-key-signatures (reverse keysigs))))))) + +(defmethod crotchet ((object gsharp-object)) + (make-standard-period 1)) \ No newline at end of file
--- a/tools/gsharp-output.lisp Tue Jan 01 13:22:15 2008 +0000 +++ b/tools/gsharp-output.lisp Thu Jan 03 13:45:32 2008 +0000 @@ -104,7 +104,7 @@ layers) ;; Add the notes and bars (add-bars-and-events-to-layer (car layers) (reverse events) - time-signatures + time-signatures composition :key-signatures key-signatures))) layer-events) ;; Attach layers to a segment and place segment into buffer @@ -136,7 +136,8 @@ (if (< (midi-pitch-number event) 60) 1 0)))))))) -(defun add-bars-and-events-to-layer (layer events time-signatures &key (key-signatures nil)) +(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." @@ -170,6 +171,9 @@ ;; sense. At the moment, it just removes short rests... (setf ons (check-ons ons)) ;; 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))) @@ -177,6 +181,15 @@ (setf bar (gsharp::make-melody-bar)) (gsharp::add-bar bar body bar-no) (incf bar-no)) + (when (and key-signatures + (<= (timepoint (car key-signatures)) + (caar ons))) + (gsharp-mxml::add-element-at-duration (make-gsharp-key-signature (car key-signatures) layer) + bar + (/ (- (timepoint (car key-signatures)) + (caar beat-starts)) + 4)) + (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. @@ -220,41 +233,41 @@ (/ (- 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)))))) + (with-simple-restart (ignore "Ignore note") + (when note + (let ((pitch (pitch-for-gsharp note composition))) + (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)))))) + beat-starts (cdr beat-starts)))))) + + +(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))) ;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -262,10 +275,11 @@ ;; Pitch -(defgeneric pitch-for-gsharp (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)) +(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)) @@ -276,9 +290,9 @@ (-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... +(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))) @@ -291,6 +305,53 @@ :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 composition)) + (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 @@ -382,9 +443,35 @@ (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) + (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 @@ -402,16 +489,21 @@ 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 + (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))))) + 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)))) ;;;;;;;;;;;;;;;;;; ;; @@ -490,11 +582,18 @@ (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))))) + (unless + (and (<= (- (car (second ons)) + (car (first ons))) + *rounding-factor*) + (null (cdr (first ons)))) + (if (= (- (car (second ons)) + (car (first ons))) + 0) + (push (cons (caar ons) (remove-duplicates (nconc (cdr (first ons)) + (cdr (second ons))))) + new-ons) + (push (car ons) new-ons)))))) (defun guess-rounding-factor (events) "Assuming that only durations need quantising, look at the lcd for