Mercurial > hg > amuse
changeset 185:1d3cdca12aeb
Fixes for gsharp output to allow n:n staves:layers
darcs-hash:20080722112038-40ec0-da363f762724456890dd90c1ec362e184a726320.gz
| author | d.lewis <d.lewis@gold.ac.uk> |
|---|---|
| date | Tue, 22 Jul 2008 12:20:38 +0100 |
| parents | 94803c723ccd |
| children | 03be243f9003 |
| files | amuse-ecolm.asd amuse-tabcode.asd implementations/tabcode/amuse-ecolm.asd implementations/tabcode/amuse-tabcode.asd implementations/tabcode/methods.lisp tools/gsharp-output.lisp |
| diffstat | 6 files changed, 221 insertions(+), 164 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/amuse-ecolm.asd Tue Jul 22 12:20:38 2008 +0100 @@ -0,0 +1,9 @@ +(asdf:defsystem amuse-ecolm + :depends-on (amuse-tabcode clsql) + :components + ((:module implementations + :components + ((:module tabcode + :components + ((:file "package-ecolm") + (:file "ecolm" :depends-on ("package-ecolm")))))))) \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/amuse-tabcode.asd Tue Jul 22 12:20:38 2008 +0100 @@ -0,0 +1,12 @@ +(asdf:defsystem amuse-tabcode + :name "amuse-tabcode" + :depends-on (amuse tabcode amuse-harmony) + :components + ((:module implementations + :components + ((:module tabcode + :components + ((:file "package") + (:file "classes" :depends-on ("package")) + (:file "methods" :depends-on ("package" "classes")) + (:file "tabcode-import" :depends-on ("package" "classes")))))))) \ No newline at end of file
--- a/implementations/tabcode/amuse-ecolm.asd Mon Jul 21 14:08:17 2008 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,5 +0,0 @@ -(asdf:defsystem amuse-ecolm - :depends-on (amuse-tabcode clsql) - :components - ((:file "package-ecolm") - (:file "ecolm" :depends-on ("package-ecolm")))) \ No newline at end of file
--- a/implementations/tabcode/amuse-tabcode.asd Mon Jul 21 14:08:17 2008 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -(asdf:defsystem amuse-tabcode - :depends-on (amuse tabcode amuse-harmony) - :components - ((:file "package") - (:file "classes" :depends-on ("package")) - (:file "methods" :depends-on ("package" "classes")) - (:file "tabcode-import" :depends-on ("package" "classes")))) \ No newline at end of file
--- a/implementations/tabcode/methods.lisp Mon Jul 21 14:08:17 2008 +0100 +++ b/implementations/tabcode/methods.lisp Tue Jul 22 12:20:38 2008 +0100 @@ -108,4 +108,9 @@ (do () ((time> (cut-off beat-period) current-moment) beat-period) (setf (timepoint beat-period) - (timepoint (cut-off beat-period)))))) \ No newline at end of file + (timepoint (cut-off beat-period)))))) + +(defmethod amuse-tools::gsharp-staff-string ((event tabcode-pitched-event)) + (if (< (midi-pitch-number event) 60) + "bass" + "treble")) \ No newline at end of file
--- a/tools/gsharp-output.lisp Mon Jul 21 14:08:17 2008 +0100 +++ b/tools/gsharp-output.lisp Tue Jul 22 12:20:38 2008 +0100 @@ -40,10 +40,11 @@ ;; * Clef is guessed at - we need amuse:get-applicable-clef (and ;; amuse:clef) ;; -;; * Anacruses are ignored unless they have their own time-signatures! +;; [* Anacruses are ignored unless they have their own time-signatures! +;; - not strictly true now. This depends on the implementation of current bar] ;; ;; The stages used are: -;; 1 - find layers (1:1 with staves at the moment) +;; 1 - find layers and stave (was 1:1 with staves. Not anymore) ;; 2 - for each layer, get events and their timings (includes ;; rounding/quantization) ;; 3 - Find all ties needed for graphical/courtesy reasons (includes @@ -76,136 +77,167 @@ (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) + (make-objects-for-gsharp-buffer composition (car (esa:buffers frame))) + ;; (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))) + (setf *foo* (car (esa:buffers frame))) ;; Print - (setf *foo* (car (esa:buffers frame))) (clim:execute-frame-command - frame `(gsharp::com-print-buffer-to-file ,pathname)))) + frame `(gsharp::com-print-buffer-to-file ,pathname)) + (car (esa:buffers frame)))) ;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; 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)) - (key-signatures (handler-bind ((insufficient-information - #'(lambda (c) - (declare (ignore c)) - (invoke-restart 'guess)))) - (get-applicable-key-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-to-layer (car layers) (reverse events) - time-signatures composition - :key-signatures key-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)))) +(defun make-objects-for-gsharp-buffer (composition buffer) + "This replacement for fill-gsharp-buffer-with-constituent generates + staves and layers itself and attaches them to a segment in the + supplied buffer. Clefs are guessed rather than being read. Each + event is asked for its staff and layer using gsharp-staff-string + gsharp-layer-string, and from this, the connections are + made. gsharp-staff-string defaults to calling gsharp-layer-string, + so in most cases there will be a single staff for each layer. Events + are added, and then staves are sorted using staff<. A proper layout + object would be another way of doing this." + (let ((layer-names (make-hash-table :test #'equal)) + (layer-events (make-hash-table)) + (layer-staves (make-hash-table)) + (staff-names (make-hash-table :test #'equal)) + (staff-name)(staff)(layer-name)(layer) + (segment)) + (sequence::dosequence (event composition) + ;; can't do percussion parts yet: + (when (pitchedp event) + (setf layer-name (gsharp-layer-string event) + layer (gethash layer-name layer-names) + staff-name (gsharp-staff-string event) + staff (gethash staff-name staff-names)) + (if staff + ;; this looks a little cryptic, but we're keeping note of + ;; whether the mean pitch is above C for clef guessing. + (setf (third staff) (+ (third staff) 1) + (second staff) (+ (second staff) (min (floor (midi-pitch-number event) 60) 1))) + (setf staff (list (gsharp::make-fiveline-staff :name staff-name) + (min (floor (midi-pitch-number event) 60) + 1) + 1) + (gsharp::buffer (car staff)) buffer + (gethash staff-name staff-names) staff)) + (if layer + (progn + (unless (find (first staff) (gethash layer layer-staves)) + (push (first staff) (gethash layer layer-staves))) + (push event (gethash layer layer-events))) + (if segment + (setf layer (gsharp::make-layer (list (first staff)) + :body (gsharp::make-slice :bars nil) + :name layer-name + :segment segment) + (gsharp::layers segment) (cons layer (gsharp::layers segment)) + (gethash layer-name layer-names) layer + (gethash layer layer-staves) (list staff) + (gethash layer layer-events) (list event)) + (setf layer (gsharp::make-layer (list (first staff)) + :body (gsharp::make-slice :bars nil) + :name layer-name) + segment (make-instance 'gsharp::segment + :buffer buffer + :layers (list layer)) + (gsharp-buffer:segment layer) segment + (gethash layer-name layer-names) layer + (gethash layer layer-staves) (list (first staff)) + (gethash layer layer-events) (list event)))))) + (maphash #'(lambda (key val) + (declare (ignore key)) + (unless (>= (second val) (/ (third val) 2)) + (setf *foo* (first val)) + (setf (gsharp::clef (first val)) (gsharp::make-clef :bass)))) + staff-names) + (maphash #'(lambda (key events) + (add-music-to-layer key + (reverse events) + (gethash key layer-staves) + composition + (handler-bind ((insufficient-information + #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'guess)))) + (get-applicable-key-signatures composition composition)))) + layer-events) + (setf (gsharp::segments buffer) (list segment) + (gsharp::staves buffer) nil) + (let ((staves)) + (maphash #'(lambda (key val) + (declare (ignore key)) + (push (car val) staves)) + staff-names) + (setf staves (sort staves #'stave<)) + (setf (gsharp::staves buffer) staves) + buffer))) +(defgeneric stave< (staff1 staff2) + (:method (s1 s2) + (let* ((clefs '(:treble :bass)) + (c1 (gsharp::clef s1)) + (c2 (gsharp::clef s2)) + (pos1 (position (gsharp::name c1) clefs)) + (pos2 (position (gsharp::name c2) clefs))) + (or (< pos1 pos2) + (and (= pos1 pos2) + (< (gsharp::lineno c1) + (gsharp::lineno c2))) + (and (= pos1 pos2) + (= (gsharp::lineno c1) + (gsharp::lineno c2)) + (string< (gsharp::name s1) + (gsharp::name s2))))))) -(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)) - (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 layer-name layer-events) - (push event (gethash layer-name layer-events)) - (when (< (midi-pitch-number event) 60) - (incf (gethash layer-name layer-scores)))) - (t (setf (gethash layer-name layer-events) - (list event) - (gethash layer-name layer-scores) - (if (< (midi-pitch-number event) 60) - 1 0)))))))) - -(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." - (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 (current-bar (make-standard-moment 0) composition) - (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 - (handler-bind - ((insufficient-information - #'(lambda (c) - (declare (ignore c)) - (invoke-restart 'use-whole-bar)))) - (let ((starts) (current)) - (do* ((bars bar-starts) - (beat-period (current-beat (make-standard-moment 0) composition) - (current-beat (cut-off beat-period) composition)) - (beat-time (timepoint beat-period) (timepoint beat-period))) - ((time>= (cut-off beat-period) (cut-off composition)) - (progn - (when (and (cdr bars) - (>= beat-time (second bars))) - (push (reverse current) starts) - (setf current nil - bars (cdr bars))) - (push beat-time current) - (reverse (cons (reverse current) 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))) +(defun bar-starts-2 (composition) + (let ((starts)) + (do ((bar-period (current-bar (make-standard-moment 0) composition) + (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)))) +(defun beat-starts-2 (bar-starts composition) + ;; FIXME: improve this + (when (get-applicable-time-signatures composition composition) + (handler-bind + ((insufficient-information + #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'use-whole-bar)))) + (let ((starts) (current)) + (do* ((bars bar-starts) + (beat-period (current-beat (make-standard-moment 0) composition) + (current-beat (cut-off beat-period) composition)) + (beat-time (timepoint beat-period) (timepoint beat-period))) + ((time>= (cut-off beat-period) (cut-off composition)) + (progn + (when (and (cdr bars) + (>= beat-time (second bars))) + (push (reverse current) starts) + (setf current nil + bars (cdr bars))) + (push beat-time current) + (reverse (cons (reverse current) starts)))) + (when (and (cdr bars) + (>= beat-time (second bars))) + (push (reverse current) starts) + (setf current nil + bars (cdr bars))) + (push beat-time current)))))) +(defun add-music-to-layer (layer events staves composition key-sigs) + "Creating all the musical objects for the gsharp staves in the +provided layer" + (let* ((bar-moments (bar-starts-2 composition)) + (beat-moments (or (beat-starts-2 bar-moments composition) + bar-moments)) + (body (gsharp::body layer)) + (bar-no 0) + (ons) (position) (clusters) (bar)) ;; this is a cheat to guess timing rounding (quantisation) based ;; on onset times - only affects midi-like data where onsets are ;; already rounded, but durations are not (as in TC's fantasia @@ -220,50 +252,43 @@ ;; most music (Mensurstrich aside), so insert bar starts if not ;; present. Note that, since the events themselves are recorded in ;; the list, the existence of ties shuold be detected. - (when bar-starts - (setf ons (add-bar-starts-if-not-present bar-starts ons))) + (when bar-moments + (setf ons (add-bar-starts-if-not-present bar-moments ons))) ;; Finally, one problem here is that, in midi, there is often a ;; gap or overlap between consecutive notes or chords. Since ;; 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 bar-starts)) + (setf ons (check-ons ons bar-moments)) ;; 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))) + (when key-sigs + (dolist (staff staves) + (setf (gsharp::keysig staff) + (make-gsharp-key-signature (car key-sigs) staff)))) (do ((old-ons nil ons) (ons ons (cdr ons))) ((null (cdr ons))) - (when (member (caar ons) bar-starts) + (when (member (caar ons) bar-moments) ;; 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) (setf position 0)) -#+nil (when (and key-signatures - (<= (timepoint (car key-signatures)) - (caar ons))) - (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 (cdr ons) (not (member (caar ons) - (car beat-starts))) + (car beat-moments))) (find-if #'(lambda (x) (> x (caar ons))) - (car beat-starts)) + (car beat-moments)) (< (find-if #'(lambda (x) (> x (caar ons))) - (car beat-starts)) + (car beat-moments)) (car (second ons)))) (setf (cdr ons) (cons (cons (find-if #'(lambda (x) (> x (caar ons))) - (car beat-starts)) + (car beat-moments)) (cdar ons)) (cdr ons)))) ;; Making clusters just from duration removes the ability to @@ -282,7 +307,7 @@ (let ((now (caar ons)) (first-p t) (pitches)) (do ((clusters clusters (cdr clusters))) ((null clusters)) - (when (member now (car beat-starts)) + (when (member now (car beat-moments)) (setf (gsharp::lbeams (car clusters)) 0)) ;; This function adds cluster at a specific point in the ;; bar. It does a lot of other things that are probably a) @@ -302,7 +327,7 @@ (make-instance 'gsharp::note :pitch (second pitch) :accidentals (third pitch) - :staff (car (gsharp::staves layer)) + :staff (staff-for-note (car pitch) staves) :tie-right (if (or (cdr clusters) (member (car pitch) (second ons))) t @@ -313,11 +338,15 @@ (incf now (* (gsharp::duration (car clusters)) 4)) (setf first-p nil) (incf position))) - (when (and (cdr bar-starts) + (when (and (cdr bar-moments) (= (car (second ons)) - (second bar-starts))) - (setf bar-starts (cdr bar-starts) - beat-starts (cdr beat-starts)))))) + (second bar-moments))) + (setf bar-moments (cdr bar-moments) + beat-moments (cdr beat-moments)))))) + +(defun staff-for-note (event staves) + (find-if #'(lambda (x) (string= (gsharp::name x) (gsharp-staff-string event))) + staves)) (defun check-beams (bar) (do* ((clusters (gsharp::elements bar) (cdr clusters)) @@ -342,8 +371,8 @@ (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) +(defgeneric make-gsharp-key-signature (key-signature object)) +(defmethod make-gsharp-key-signature ((key-signature standard-key-signature) (layer gsharp-buffer::layer)) (let ((alterations (make-array 7 :initial-element :natural)) (order-of-sharps #(3 0 4 1 5 2 6)) (order-of-flats #(6 2 5 1 4 0 3))) @@ -354,6 +383,18 @@ (setf (elt alterations (elt order-of-sharps index)) :sharp))) (gsharp-buffer::make-key-signature (car (gsharp::staves layer)) :alterations alterations))) +(defmethod make-gsharp-key-signature ((key-signature standard-key-signature) + (staff gsharp::staff)) + (let ((alterations (make-array 7 :initial-element :natural)) + (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 staff + :alterations alterations))) ;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -436,9 +477,6 @@ (- (slot-value e 'amuse::number) 21)))) into result finally (return (sort result #'sorter :key #'car))))) - - - ;; Time (defun make-gsharp-clusters-with-duration (duration) @@ -534,6 +572,11 @@ (:documentation "Return a string that uniquely identifies the layer to which event belongs")) +(defgeneric gsharp-staff-string (event) + (:method (e) (gsharp-layer-string e)) + (:documentation "Return a string that uniquely identifies the staff + to which event belongs")) + (defun name-from-layer (event) ;; Uses gsharp layer names. Numbers layers in cases of duplication (let* ((layers (gsharp::layers