Mercurial > hg > amuse
changeset 177:e5de0895d843
Gsharp-output
darcs-hash:20080313112652-40ec0-64241751ae1c0bfc32c3e35deac499132728c5bf.gz
| author | d.lewis <d.lewis@gold.ac.uk> |
|---|---|
| date | Thu, 13 Mar 2008 11:26:52 +0000 |
| parents | cddf83554c08 |
| children | 057e8ab413f9 |
| files | implementations/gsharp/methods.lisp tools/gsharp-output.lisp |
| diffstat | 2 files changed, 213 insertions(+), 65 deletions(-) [+] |
line wrap: on
line diff
--- a/implementations/gsharp/methods.lisp Thu Mar 13 11:25:36 2008 +0000 +++ b/implementations/gsharp/methods.lisp Thu Mar 13 11:26:52 2008 +0000 @@ -58,13 +58,48 @@ (defmethod get-applicable-key-signatures (anchored-period (composition gsharp-composition)) (let ((keysigs)) - (sequence::dosequence (event composition (reverse keysigs)) + (sequence::dosequence (event composition (mapcar #'import-key-signature (reverse keysigs))) (cond ((overlaps event anchored-period) - (unless (member (gsharp::keysig event) keysigs) - (push (gsharp::keysig event) keysigs))) + (unless (member (gsharp::keysig (note event)) keysigs) + (push (gsharp::keysig (note event)) keysigs))) ((not (before event anchored-period)) - (return-from get-applicable-key-signatures (reverse keysigs))))))) + (return-from get-applicable-key-signatures (mapcar #'import-key-signature (reverse keysigs)))))))) + +(defun import-key-signature (gsharp-keysig) + ;; FIXME: This is WRONG - shouldn't be using standard key signature, + ;; since important detail is lost (very rarely) + (make-standard-key-signature-period (- (count :sharp (gsharp::alterations gsharp-keysig)) + (count :flat (gsharp::alterations gsharp-keysig))) + ())) (defmethod crotchet ((object gsharp-object)) - (make-standard-period 1)) \ No newline at end of file + (make-standard-period 1)) + +;;; +;; Experimental + +(defmethod amuse::current-bar ((moment standard-moment) + (composition gsharp-composition)) + ;; No, I don't know how (or if) these work. But it's a hard problem, + ;; so I don't mind cheating. + (let ((bar-lengths (gsharp-play::measure-durations + (mapcar #'gsharp-buffer:body + (gsharp-buffer::layers (car (gsharp::segments + (amuse-gsharp::buffer composition))))))) + (moment-time (timepoint moment)) (now 0)) + (dolist (bar-duration bar-lengths) + (when (> (+ now (* bar-duration 4)) moment-time) + (return-from amuse::current-bar + (make-standard-anchored-period now (* bar-duration 4)))) + (incf now (* bar-duration 4))))) + +(defmethod get-applicable-clefs (anchored-period (composition gsharp-composition)) + (let ((clefs)) + (sequence::dosequence (event composition (mapcar #'import-clef (reverse clefs))) + (cond + ((overlaps event anchored-period) + (unless (member (gsharp::clef (gsharp::staff (note event))) clefs) + (push (gsharp::clef (gsharp::staff (note event))) clefs))) + ((not (before event anchored-period)) + (return-from get-applicable-clefs (mapcar #'import-clef (reverse clefs)))))))) \ No newline at end of file
--- a/tools/gsharp-output.lisp Thu Mar 13 11:25:36 2008 +0000 +++ b/tools/gsharp-output.lisp Thu Mar 13 11:26:52 2008 +0000 @@ -39,6 +39,19 @@ ;; ;; * Clef is guessed at - we need amuse:get-applicable-clef (and ;; amuse:clef) +;; +;; * Anacruses are ignored unless they have their own time-signatures! +;; +;; The stages used are: +;; 1 - find layers (1:1 with staves at the moment) +;; 2 - for each layer, get events and their timings (includes +;; rounding/quantization) +;; 3 - Find all ties needed for graphical/courtesy reasons (includes +;; removal of extraneous rests and other artefacts) +;; 4 - Generate gsharp clusters +;; 5 - Get gsharp pitch for events and add notes to clusters +;; + (in-package "AMUSE-TOOLS") @@ -51,6 +64,8 @@ ;;;;;;;;;;;;;;;;;;;;; ;; Top-level methods +(defparameter *foo* nil) + (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) @@ -66,6 +81,7 @@ (setf (gsharp::modified-p (car (esa:buffers frame))) t) (gsharp::recompute-measures (car (esa:buffers frame))) ;; Print + (setf *foo* (car (esa:buffers frame))) (clim:execute-frame-command frame `(gsharp::com-print-buffer-to-file ,pathname)))) @@ -122,17 +138,20 @@ (defmethod identify-gsharp-layers ((composition composition)) (let ((layer-events (make-hash-table :test #'equal)) - (layer-scores (make-hash-table :test #'equal))) + (layer-scores (make-hash-table :test #'equal)) + (layer-clefs (make-hash-table :test #'equal)) + (layer-name)) (sequence:dosequence (event composition (values layer-events layer-scores)) (when (pitchedp event) + (setf layer-name (gsharp-layer-string event)) (cond - ((gethash (gsharp-layer-string event) layer-events) - (push event (gethash (gsharp-layer-string event) layer-events)) + ((gethash layer-name layer-events) + (push event (gethash layer-name 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) + (incf (gethash layer-name layer-scores)))) + (t (setf (gethash layer-name layer-events) (list event) - (gethash (gsharp-layer-string event) layer-scores) + (gethash layer-name layer-scores) (if (< (midi-pitch-number event) 60) 1 0)))))))) @@ -141,11 +160,35 @@ "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) + (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)) + (bar-starts (let ((starts)) + (do ((bar-period (amuse::current-bar (make-standard-moment 0) composition) + (amuse::current-bar (cut-off bar-period) composition))) + ((time>= (cut-off bar-period) (cut-off composition)) + (reverse (cons (timepoint bar-period) starts))) + (push (timepoint bar-period) starts)))) + (beat-starts (if time-signatures + (let ((starts) (current)) + (do* ((bars bar-starts) + (beat-period (amuse::current-beat (make-standard-moment 0) composition) + (amuse::current-beat (cut-off beat-period) composition)) + (beat-time (timepoint beat-period) (timepoint beat-period))) + ((time>= (onset beat-period) (cut-off composition)) + (reverse (if current + (cons (reverse current) starts) + starts))) + (when (and (cdr bars) + (>= beat-time (second bars))) + (push (reverse current) starts) + (setf current nil + bars (cdr bars))) + (push beat-time current))) + (mapcar #'list bar-starts))) + (ons) (position) (clusters) (bar) (bar-no 0) (body (gsharp::body layer))) ;; this is a cheat to guess timing rounding (quantisation) based @@ -169,7 +212,7 @@ ;; 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)) + (setf ons (check-ons ons bar-starts)) ;; Now create the bars and the gsharp clusters (when key-signatures (setf (gsharp::keysig (car (gsharp::staves layer))) @@ -178,27 +221,30 @@ (ons ons (cdr ons))) ((null (cdr ons))) (when (member (caar ons) bar-starts) + ;; We're at the beginning of a bar. + (when bar (check-beams bar)) (setf bar (gsharp::make-melody-bar)) (gsharp::add-bar bar body bar-no) - (incf bar-no)) + (incf bar-no) + (setf position 0)) (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)) + (gsharp::add-element (make-gsharp-key-signature (car key-signatures) layer) + bar + position) + (incf position) (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. - (when (and (not (member (caar ons) + (when (and (cdr ons) + (not (member (caar ons) (car beat-starts))) (find-if #'(lambda (x) (> x (caar ons))) - (car beat-starts)) + (car beat-starts)) (< (find-if #'(lambda (x) (> x (caar ons))) - (car beat-starts)) + (car beat-starts)) (car (second ons)))) (setf (cdr ons) (cons (cons (find-if #'(lambda (x) (> x (caar ons))) @@ -212,13 +258,13 @@ ;; 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)) + (if (cdar ons) (setf clusters (make-gsharp-clusters-with-duration (- (car (second ons)) - (car (car 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)) + (car (car ons))) + layer))) + (let ((now (caar ons)) (first-p t) (pitches)) (do ((clusters clusters (cdr clusters))) ((null clusters)) (when (member now (car beat-starts)) @@ -228,33 +274,58 @@ ;; 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))) + (gsharp::add-element (car clusters) bar position) + ;; FIXME: Deleting notes that fall on the same note + ;; name. Stupid thing to do. + (setf pitches (remove-duplicates (mapcar #'(lambda (x) + (cons x (pitch-for-gsharp x composition))) + (cdar ons)) + :key #'second :test #'=)) + (dolist (pitch pitches) (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))))))) + (gsharp::add-note (car clusters) + (make-instance 'gsharp::note + :pitch (second pitch) + :accidentals (third pitch) + :staff (car (gsharp::staves layer)) + :tie-right (if (or (cdr clusters) + (member (car pitch) (second ons))) + t + nil) + :tie-left (if first-p + (member (car pitch) (first old-ons)) + t))))) (incf now (* (gsharp::duration (car clusters)) 4)) - (setf first-p nil))) + (setf first-p nil) + (incf position))) (when (and (cdr bar-starts) (= (car (second ons)) (second bar-starts))) (setf bar-starts (cdr bar-starts) beat-starts (cdr beat-starts)))))) +(defun check-beams (bar) + (do* ((clusters (gsharp::elements bar) (cdr clusters)) + (left) (mid) (right)) + ((null (cddr clusters))) + (setf left (first clusters) + mid (second clusters) + right (third clusters)) + (unless (or (typep mid 'gsharp::rest) + (= (max (gsharp::rbeams mid) + (gsharp::lbeams mid)) + 0)) + (cond + ((or (typep left 'gsharp::rest) + (= (gsharp::rbeams left) 0)) + (setf (gsharp::lbeams mid) 0)) + ((or (typep right 'gsharp::rest) + (= (gsharp::lbeams right) 0)) + (setf (gsharp::rbeams mid) 0)) + ((< (gsharp::rbeams left) + (gsharp::lbeams right)) + (setf (gsharp::lbeams mid) (gsharp::rbeams left))) + (t (setf (gsharp::rbeams mid) (gsharp::lbeams right))))))) (defgeneric make-gsharp-key-signature (key-signature layer)) (defmethod make-gsharp-key-signature ((key-signature standard-key-signature) layer) @@ -309,7 +380,7 @@ ;; 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)) + (event-pos (position event (ocp-list composition) :key #'car)) (note-sequence (get-spelling-list composition)) (spelling (elt note-sequence event-pos)) (note-name (cdr (assoc (aref (second spelling) 0) @@ -449,6 +520,7 @@ to which event belongs")) (defun name-from-layer (event) + ;; Uses gsharp layer names. Numbers layers in cases of duplication (let* ((layers (gsharp::layers (car (gsharp::segments @@ -489,6 +561,10 @@ collect i))) (defun beat-starts (time-signature-list &key (crotchet 1)) + ;; provides a list of bars, each a list of beats. If no timesig, + ;; guesses at 4/4 + ;; FIXME: This is stupid and should disappear if and when proper + ;; beat methods are implemented. (if time-signature-list (loop for time-signature in time-signature-list nconc (loop for i from (timepoint (onset time-signature)) @@ -575,29 +651,66 @@ (t (push (car data) copied-data)))))) +(defun check-ons (ons bar-starts) + "looks for small rests such as might be created by midi performance +of tenuto lines" + (let ((time (caar ons)) (notes (cdar ons))(new-ons)) + (do ((ons (cdr ons) (cdr ons))) + ((null ons) (reverse new-ons)) + (if (or (member (caar ons) bar-starts) + (> (- (caar ons) time) + *rounding-factor*)) + (setf new-ons (cons (cons time notes) new-ons) + time (caar ons) + notes (cdar ons)) + (dolist (note (cdar ons)) + (unless (member note notes) + (push note notes))))))) + +#+nil + (defun check-ons (ons) "looks for small rests such as might be created by midi performance of tenuto lines" - (let ((new-ons)) + (let ((new-ons) (skip)) (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)))) - (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)))))) + (if skip (reverse new-ons) (reverse (cons (car ons) new-ons)))) + (cond + (skip (setf skip nil)) + ((not (and (<= (- (car (second ons)) + (car (first ons))) + *rounding-factor*) + (null (cdr (first ons))))) + (if (<= (- (car (second ons)) + (car (first ons))) + *rounding-factor*) + (progn + (push (cons (caar ons) (remove-duplicates (nconc (cdr (first ons)) + (cdr (second ons))))) + new-ons) + (setf skip t)) + (push (car ons) new-ons))))))) + (defun guess-rounding-factor (events) "Assuming that only durations need quantising, look at the lcd for onsets" + (let ((rounding-factor (/ 1 *rounding-factor*))) + (when events + (let ((crotchet (duration (crotchet (car events))))) + (do ((events events (cdr events))) + ((null (cdr events))) + (do ((divisor rounding-factor (* 2 divisor))) + ((<= (rem (* (timepoint (car events)) crotchet) + divisor) + (/ divisor 3)) + (setf rounding-factor divisor)))))) + (/ 1 rounding-factor))) + +(defun guess-rounding-factor-smart (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)))))