Update of /project/gsharp/cvsroot/gsharp/Mxml In directory clnet:/tmp/cvs-serv12920/Mxml
Modified Files: mxml.lisp Log Message: Support for layers/staves in MusicXML parts
--- /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2008/02/08 16:47:55 1.2 +++ /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2008/02/08 16:48:54 1.3 @@ -454,13 +454,10 @@ (defun gduration-from-xduration (xduration) (/ xduration (* 4 *mxml-divisions*)))
-(defun parse-mxml-part (part) +(defun parse-mxml-part (part part-name) (let ((staves nil) (layers nil) - (lyrics-layer-hash (make-hash-table)) - ;; TODO this could pull the part-name from the partlist at the - ;; top of the file - (part-name (dom:get-attribute part "id"))) + (lyrics-layer-hash (make-hash-table)))
;; Create all of the staves, along with their initial ;; keysignatures and clefs. @@ -522,10 +519,14 @@ ;; in when added to the buffer. (setf staves (loop for i below number-of-staves - for melody-staff = (make-fiveline-staff :name (format nil "~A staff ~D" part-name (1+ i)) + for melody-staff = (make-fiveline-staff :name (if (= number-of-staves 1) + part-name + (format nil "~A staff ~D" part-name (1+ i))) :clef (elt clefs i)) for lyric-staff = (if (xmlstaff-has-lyrics part (1+ i)) - (list (make-lyrics-staff :name (format nil "~A lyricstaff ~D" part-name (1+ i)))) + (list (make-lyrics-staff :name (if (= number-of-staves 1) + part-name + (format nil "~A lyricstaff ~D" part-name (1+ i))))) nil) nconc (cons melody-staff lyric-staff)))
@@ -554,18 +555,22 @@ (pushnew (nth staff-number fiveline-staves) (elt staves-for-layers voice-number))))
(setf layers (nconc - (loop for staves across staves-for-layers - for i from 1 - collect (make-layer staves - :body (make-slice :bars nil) - :name (format nil "~A layer ~D" part-name i))) - (loop for lyrics-staff in lyrics-staves - for i from 1 - for new-layer = (make-layer (list lyrics-staff) - :body (make-slice :bars nil) - :name (format nil "~A lyrics-layer ~D" part-name i)) - do (setf (gethash lyrics-staff lyrics-layer-hash) new-layer) - collecting new-layer))))) + (loop for staves across staves-for-layers + for i from 1 + collect (make-layer staves + :body (make-slice :bars nil) + :name (if (= (length staves-for-layers) 1) + part-name + (format nil "~A layer ~D" part-name i)))) + (loop for lyrics-staff in lyrics-staves + for i from 1 + for new-layer = (make-layer (list lyrics-staff) + :body (make-slice :bars nil) + :name (if (= (length staves-for-layers) 1) + part-name + (format nil "~A lyrics-layer ~D" part-name i))) + do (setf (gethash lyrics-staff lyrics-layer-hash) new-layer) + collecting new-layer)))))
;; return the layers and the staves (values layers @@ -622,11 +627,23 @@ (let ((layerss nil) (lyrics-layer-hashes nil) (stavess nil) - (parts (dom:get-elements-by-tag-name document "part"))) - + (parts (dom:get-elements-by-tag-name document "part")) + (parts-alist nil)) + (sequence:dosequence (part (dom:child-nodes + (aref (dom:get-elements-by-tag-name document "part-list") + 0))) + (setf parts-alist + (if (has-element-type part "part-name") + (acons (dom:get-attribute part "id") + (named-pcdata part "part-name") + parts-alist) + (acons (dom:get-attribute part "id") + (dom:get-attribute part "id") + parts-alist)))) (sequence:dosequence (part parts) - (multiple-value-bind (layers staves lyrics-layer-hash) - (parse-mxml-part part) + (multiple-value-bind (layers staves lyrics-layer-hash) + (parse-mxml-part part (cdr (assoc (dom:get-attribute part "id") + parts-alist :test #'string=))) (setf layerss (append layerss (list layers))) (setf lyrics-layer-hashes @@ -634,8 +651,10 @@ (setf stavess (append stavess (list staves)))))
;; And finally make the buffer and start parsing notes. + ;; Previous operations result in staves and layers in opposite + ;; orders (don't know why) - hence the reverse for segment layers (let* ((segment (make-instance 'segment - :layers (apply #'concatenate 'list layerss))) + :layers (reverse (apply #'concatenate 'list layerss)))) (buffer (make-instance 'buffer :segments (list segment) :staves (apply #'concatenate 'list stavess)))) @@ -681,8 +700,48 @@ ;;;;;;;;;;; (defvar *staff-hash*)
+(defun guess-parts (layers) + ;; Looks for the way of dividing layers into as many mxml-parts as + ;; possible without ending up with a single staff in two + ;; parts. Returns two parallel lists - one of lists of layers, the + ;; other of staves. + (let ((parts)) + (dolist (layer layers (values (mapcar #'second parts) + (mapcar #'first parts))) + (dolist (part parts (setf parts (cons (list (staves layer) + (list layer)) + parts))) + (when (not (every #'(lambda (x) (not (member x (first part)))) + (staves layer))) + (setf (first part) (union (staves layer) + (first part)) + (second part) (cons layer (second part))) + (return)))))) + +(defun ordered-parts (segment buffer) + ;; sort parts that can have multiple layers and staves. Sort by + ;; stave order and then by layers order. + (multiple-value-bind (part-layers part-staves) + (guess-parts (layers segment)) + (let* ((s-positions (mapcar #'(lambda (x) + (loop for stave in x + minimize (position stave (staves buffer)))) + part-staves)) + (l-positions (mapcar #'(lambda (x) + (loop for layer in x + minimize (position layer (layers segment)))) + part-layers)) + (parts (mapcar #'list part-layers s-positions l-positions))) + (mapcar #'car + (sort parts #'(lambda (x y) (or (< (second x) (second y)) + (and (= (second x) (second y)) + (< (third x) (third y)))))))))) + (defun write-mxml (buffer) - (let ((sink (cxml:make-rod-sink :indentation 2 :canonical nil))) + ;; Create mxml for buffer. Previously took part = segment, now takes + ;; part = layer. + (let ((sink (cxml:make-rod-sink :indentation 2 :canonical nil)) + (ordered-parts)) (cxml:with-xml-output sink (sax:start-dtd sink "score-partwise" @@ -691,24 +750,33 @@ (sax:end-dtd sink) (cxml:with-element "score-partwise" (cxml:attribute "version" "1.1") - (make-xml-partlist) - (cxml:with-element "part" - (cxml:attribute "id" "P1") - (loop for segment in (segments buffer) + (loop for segment in (segments buffer) with measure-number = 1 - do - (make-xml-segment segment measure-number) - (setf measure-number - (+ measure-number - (loop for layer in (layers segment) - maximizing (length (bars (body layer)))))))))))) - -(defun make-xml-partlist () + do + (setf ordered-parts (ordered-parts segment buffer)) + (make-xml-partlist ordered-parts) + (make-xml-segment segment measure-number ordered-parts) + (setf measure-number + (+ measure-number + (loop for layer in (layers segment) + maximizing (length (bars (body layer))))))))))) + +(defun make-xml-partlist (part-list) + ;; Generates the part-list element based on sublists of layers. Part ID's are + ;; numbered P1, P2, etc., part names are taken from the layer names. (cxml:with-element "part-list" - (let ((partid "P1")) + (do ((part-list part-list (cdr part-list)) + (i 1 (1+ i))) + ((null part-list)) (cxml:with-element "score-part" - (cxml:attribute "id" partid) - (cxml:with-element "part-name" (cxml:text partid)))))) + (cxml:attribute "id" (format nil "P~D" i)) + (cxml:with-element "part-name" + (cxml:text (name-for-part (car part-list)))))))) + +(defun name-for-part (layers) + (apply #'concatenate 'string (name (car layers)) + (loop for layer in (cdr layers) + collect (format nil ", ~A" (name layer)))))
;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Dealing with durations @@ -759,7 +827,7 @@ ;; Back to exporting ;;;;;;;;;;;;;;;;;;;;;;
-(defun make-xml-segment (segment first-bar-number) +(defun make-xml-segment (segment first-bar-number ordered-parts)
;; Evaluate the appropriate mxml divisions. ;; i think the beginning of a segment is a good place to do this. i @@ -767,16 +835,23 @@ ;; right. (let ((*mxml-divisions* (loop for element in (extract-all-elements segment) - maximizing (calculate-required-divisions element))) - (*staff-hash* - (make-staff-hash - (remove-duplicates (apply #'concatenate 'list - (mapcar #'staves (layers segment))))))) - - (let ((lists-of-bars (mapcar #'(lambda (l) (bars (body l))) - (layers segment)))) - (apply #'map-all-lists-maximally - #'make-xml-bars first-bar-number lists-of-bars)))) + maximizing (calculate-required-divisions element)))) + (do* ((parts ordered-parts (cdr parts)) + (part (car parts) (car parts)) + (i 1 (1+ i))) + ((null parts)) + (let ((*staff-hash* + (make-staff-hash (remove-duplicates + (apply #'concatenate 'list + (mapcar #'staves part)))))) + (cxml:with-element "part" + (cxml:attribute "id" (format nil "P~D" i)) + (do ((part-bars (mapcar #'(lambda (x) (bars (body x))) + part) + (mapcar #'cdr part-bars)) + (bar-no first-bar-number (1+ bar-no))) + ((null (car part-bars))) + (apply #'make-xml-bars bar-no part (mapcar #'car part-bars))))))))
;;(defun make-xml-layer (layer) ;; (let ((body (body layer))) @@ -795,7 +870,7 @@ (setf (gethash staff new-staff-hash) i)))) new-staff-hash))
-(defun make-xml-bars (id &rest bars) +(defun make-xml-bars (id layers &rest bars) (cxml:with-element "measure" (cxml:attribute "number" (write-to-string id))
@@ -820,12 +895,7 @@ (cxml:with-element "divisions" (cxml:text (write-to-string *mxml-divisions*)))
- (let* ((layers - (remove-duplicates - (mapcar #'(lambda (bar) (layer (slice bar))) bars))) - (staves - (remove-duplicates - (apply #'concatenate 'list (mapcar #'staves layers)))) + (let* ((staves (reduce #'union (mapcar #'staves layers))) (melody-staves (remove-if #'(lambda (staff) (typep staff 'lyrics-staff)) staves)) @@ -837,6 +907,9 @@ ;; is fixed in MusicXML 2.0. ;; TODO: put a bunch more attribute elements after this ;; one if the other staves have different key signatures. + ;; N.B. These comments are largely based on the + ;; parts/segments/layers issue. Should be a very rare issue + ;; with the new code. (let ((staff (car melody-staves))) (cxml:with-element "key" (alterations-to-fifths