From dlewis at common-lisp.net Fri Feb 8 16:47:58 2008 From: dlewis at common-lisp.net (dlewis) Date: Fri, 8 Feb 2008 11:47:58 -0500 (EST) Subject: [gsharp-cvs] CVS gsharp/Mxml Message-ID: <20080208164758.E8B4481003@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp/Mxml In directory clnet:/tmp/cvs-serv12683/Mxml Modified Files: mxml.lisp Log Message: Added octave treble support in musicxml import/export --- /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2007/10/18 15:02:47 1.1 +++ /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2008/02/08 16:47:55 1.2 @@ -494,7 +494,10 @@ ;; clefs (for-named-elements ("clef" clef attributes) (let ((name (stringcase (named-pcdata clef "sign") - ("G" :treble) + ("G" (if (string= (named-pcdata clef "clef-octave-change") + "-1") + :treble8 + :treble)) ("F" :bass) ("C" :c) ("percussion" :percussion) @@ -861,7 +864,10 @@ (cxml:with-element "sign" (cxml:text clef-sign)) (cxml:with-element "line" - (cxml:text (write-to-string clef-line)))))))) + (cxml:text (write-to-string clef-line))) + (when (eq (name clef) :treble8) + (cxml:with-element "clef-octave-change" + (cxml:text "-1")))))))) ;; process each bar, backing up only if there's a "next" bar (loop for voice from 1 From dlewis at common-lisp.net Fri Feb 8 16:48:54 2008 From: dlewis at common-lisp.net (dlewis) Date: Fri, 8 Feb 2008 11:48:54 -0500 (EST) Subject: [gsharp-cvs] CVS gsharp/Mxml Message-ID: <20080208164854.AAF086209D@common-lisp.net> 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 From dlewis at common-lisp.net Fri Feb 8 16:50:57 2008 From: dlewis at common-lisp.net (dlewis) Date: Fri, 8 Feb 2008 11:50:57 -0500 (EST) Subject: [gsharp-cvs] CVS gsharp/Mxml Message-ID: <20080208165057.77B076A004@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp/Mxml In directory clnet:/tmp/cvs-serv13047/Mxml Modified Files: mxml.lisp Log Message: Preserve some stem direction decisions in MusicXML --- /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2008/02/08 16:48:54 1.3 +++ /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2008/02/08 16:50:57 1.4 @@ -143,8 +143,14 @@ ("eighth" 1) (("quarter" "half" "whole" "breve" "full" "long") 0)) 0)) - (dots (length (dom:get-elements-by-tag-name note-element "dot")))) - (values notehead beams dots))) + (dots (length (dom:get-elements-by-tag-name note-element "dot"))) + (stem (if (has-element-type note-element "stem") + (cond + ((string= (named-pcdata note-element "stem") "up") :up) + ((string= (named-pcdata note-element "stem") "down"):down) + (t :auto)) + :auto))) + (values notehead beams dots stem))) (defparameter *step-to-basenote* '((#\C . 0) (#\D . 1) @@ -271,12 +277,14 @@ (when (has-element-type xnote "pitch") (progn (unless (has-element-type xnote "chord") - (multiple-value-bind (notehead beams dots) + (multiple-value-bind (notehead beams dots stem) (parse-mxml-note-duration xnote) (setf *parsing-in-cluster* (make-cluster :notehead notehead :lbeams beams :rbeams beams - :dots dots))) + :dots dots + :stem-direction stem))) + (add-element-at-duration *parsing-in-cluster* bar *parsing-duration-gmeasure-position*) (setf advance (duration *parsing-in-cluster*))) (add-note *parsing-in-cluster* (parse-mxml-pitched-note xnote staves)))) @@ -1105,6 +1113,10 @@ do (cxml:with-element "dot")) (if accidental (cxml:with-element "accidental" (cxml:text accidental))) + (unless (eq (final-stem-direction (cluster note)) :auto) + (cxml:with-element "stem" + (cxml:text (string-downcase + (string (final-stem-direction (cluster note))))))) (if (> (hash-table-count *staff-hash*) 1) (cxml:with-element "staff" (cxml:text (write-to-string (gethash (staff note) *staff-hash*))))) From crhodes at common-lisp.net Sat Feb 9 16:54:33 2008 From: crhodes at common-lisp.net (crhodes) Date: Sat, 9 Feb 2008 11:54:33 -0500 (EST) Subject: [gsharp-cvs] CVS gsharp/Mxml Message-ID: <20080209165433.2B847691A5@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp/Mxml In directory clnet:/tmp/cvs-serv26533/Mxml Modified Files: mxml.lisp Log Message: Comment fixes in MusicXML code. --- /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2008/02/08 16:50:57 1.4 +++ /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2008/02/09 16:54:33 1.5 @@ -129,6 +129,9 @@ :filled) ("half" :half) ("whole" :whole) + ;; KLUDGE: "full" here (and for beams) I think is a + ;; feature of catering for Nightingale's MusicXML + ;; export, which is wrong in this respect. (("breve" "full") :breve) ("long" :long)) :filled)) @@ -166,9 +169,8 @@ (+ basenum (* 7 octave)))) (defun parse-mxml-accidental (note) - ;; TODO this should support microtones. also, i wrote it fairly - ;; early on and it doesn't use things like has-element which it - ;; should. + ;; I (presumably Brian Gruber -- CSR) wrote it fairly early on and + ;; it doesn't use things like has-element which it should. (let ((alters (dom:get-elements-by-tag-name note "alter"))) (if (= 0 (length alters)) :natural From crhodes at common-lisp.net Sat Feb 9 16:58:35 2008 From: crhodes at common-lisp.net (crhodes) Date: Sat, 9 Feb 2008 11:58:35 -0500 (EST) Subject: [gsharp-cvs] CVS gsharp Message-ID: <20080209165835.E352BD003@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv26736 Modified Files: buffer.lisp drawing.lisp gui.lisp measure.lisp modes.lisp packages.lisp Log Message: Work-in-progress hooks for drawing routines, used for now for tenuto and staccato articulation marks. The quality of the graphical rendering of the marks is not really up to scratch; horizontal placement seems to be off by somewhere between half and one pixel, and of course a note with both marks on at once gets an ugly graphical clash. As I say, "work in progress". --- /project/gsharp/cvsroot/gsharp/buffer.lisp 2007/12/02 05:52:53 1.58 +++ /project/gsharp/cvsroot/gsharp/buffer.lisp 2008/02/09 16:58:35 1.59 @@ -61,10 +61,11 @@ (defclass element (gsharp-object) ((bar :initform nil :initarg :bar :accessor bar) - (xoffset :initform 0 :initarg :xoffset :accessor xoffset))) + (xoffset :initform 0 :initarg :xoffset :accessor xoffset) + (annotations :initform nil :initarg :annotations :accessor annotations))) (defmethod slots-to-be-saved append ((e element)) - '(xoffset)) + '(xoffset annotations)) (defmethod duration ((element element)) 0) (defmethod rbeams ((element element)) 0) --- /project/gsharp/cvsroot/gsharp/drawing.lisp 2007/09/18 21:19:03 1.84 +++ /project/gsharp/cvsroot/gsharp/drawing.lisp 2008/02/09 16:58:35 1.85 @@ -909,6 +909,60 @@ (defgeneric draw-element (pane element &optional flags)) +(defmethod draw-element :around (pane element &optional flags) + (call-next-method) + (dolist (annotation (annotations element)) + (draw-element-annotation pane element annotation))) + +(defgeneric draw-element-annotation (pane element annotation) + (:method (pane element annotation) + (warn "unknown annotation ~S for ~S" annotation element))) + +;;; FIXME: these methods work and have the right vertical behaviour; +;;; the horizontal centering of the dot and the tenuto mark are all +;;; wrong, sadly. +(defmethod draw-element-annotation + (pane (element cluster) (annotation (eql :staccato))) + (let ((direction (final-stem-direction element)) + (x (final-absolute-element-xoffset element))) + (if (eq direction :up) + (score-pane:with-vertical-score-position (pane (bot-note-staff-yoffset element)) + (score-pane:with-notehead-right-offsets (dx dy) + (score-pane:with-notehead-left-offsets (ddx ddy) + (let ((pos (- (bot-note-pos element) 2))) + (when (and (<= 0 pos) (evenp pos)) + (setq pos (1- pos))) + (score-pane:draw-dot pane (+ x (/ (+ dx ddx) 2)) pos))))) + (score-pane:with-vertical-score-position (pane (top-note-staff-yoffset element)) + (score-pane:with-notehead-right-offsets (dx dy) + (score-pane:with-notehead-left-offsets (ddx ddy) + (let ((pos (+ (top-note-pos element) 2))) + (when (and (<= pos 8) (evenp pos)) + (setq pos (1+ pos))) + (score-pane:draw-dot pane (+ x (/ (+ dx ddx) 2)) pos)))))))) + +(defmethod draw-element-annotation + (pane (element cluster) (annotation (eql :tenuto))) + (let ((direction (final-stem-direction element)) + (x (final-absolute-element-xoffset element))) + (if (eq direction :up) + (score-pane:with-vertical-score-position (pane (bot-note-staff-yoffset element)) + (score-pane:with-notehead-right-offsets (dx dy) + (score-pane:with-notehead-left-offsets (ddx ddy) + (let ((pos (- (bot-note-pos element) 2))) + (when (and (<= 0 pos) (evenp pos)) + (setq pos (1- pos))) + (draw-rectangle* pane (+ x ddx) (1- (score-pane:staff-step (- pos))) + (+ x dx) (1+ (score-pane:staff-step (- pos)))))))) + (score-pane:with-vertical-score-position (pane (top-note-staff-yoffset element)) + (score-pane:with-notehead-right-offsets (dx dy) + (score-pane:with-notehead-left-offsets (ddx ddy) + (let ((pos (+ (bot-note-pos element) 2))) + (when (and (<= pos 8) (evenp pos)) + (setq pos (1+ pos))) + (draw-rectangle* pane (+ x ddx) (1- (score-pane:staff-step (- pos))) + (+ x dx) (1+ (score-pane:staff-step (- pos))))))))))) + (defmethod note-difference ((note1 note) (note2 note)) (- (pitch note1) (pitch note2))) --- /project/gsharp/cvsroot/gsharp/gui.lisp 2008/01/30 09:59:25 1.93 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2008/02/09 16:58:35 1.94 @@ -754,6 +754,18 @@ (:up :down) (:down :auto)))) +(define-gsharp-command com-toggle-staccato () + (let ((cluster (cur-cluster))) + (if (member :staccato (annotations cluster)) + (setf (annotations cluster) (remove :staccato (annotations cluster))) + (push :staccato (annotations cluster))))) + +(define-gsharp-command com-toggle-tenuto () + (let ((cluster (cur-cluster))) + (if (member :tenuto (annotations cluster)) + (setf (annotations cluster) (remove :tenuto (annotations cluster))) + (push :tenuto (annotations cluster))))) + (define-gsharp-command com-down () (let ((element (cur-element))) (if (typep element 'cluster) --- /project/gsharp/cvsroot/gsharp/measure.lisp 2007/08/30 03:04:56 1.38 +++ /project/gsharp/cvsroot/gsharp/measure.lisp 2008/02/09 16:58:35 1.39 @@ -117,6 +117,10 @@ (declare (ignore direction)) (mark-modified element)) +(defmethod (setf annotations) :after (annotations (element relement)) + (declare (ignore annotations)) + (mark-modified element)) + (defmethod append-char :after ((element lyrics-element) char) (declare (ignore char)) (mark-modified element)) --- /project/gsharp/cvsroot/gsharp/modes.lisp 2007/07/06 14:16:20 1.27 +++ /project/gsharp/cvsroot/gsharp/modes.lisp 2008/02/09 16:58:35 1.28 @@ -103,6 +103,8 @@ (set-key 'com-untie-note-left 'cluster-table '((#\x) (#\{))) (set-key 'com-untie-note-right 'cluster-table '((#\x) (#\}))) (set-key 'com-rotate-stem-direction 'cluster-table '((#\s :meta))) +(set-key 'com-toggle-staccato 'cluster-table '(#\s)) +(set-key 'com-toggle-tenuto 'cluster-table '(#\t)) (set-key 'com-current-increment 'cluster-table '((#\p))) (set-key 'com-current-decrement 'cluster-table '((#\n))) (set-key 'com-octave-up 'cluster-table '((#\U :shift :meta))) --- /project/gsharp/cvsroot/gsharp/packages.lisp 2008/01/15 15:43:52 1.65 +++ /project/gsharp/cvsroot/gsharp/packages.lisp 2008/02/09 16:58:35 1.66 @@ -59,7 +59,7 @@ #:gsharp-condition #:pitch #:accidentals #:dots #:note #:make-note #:note-less #:note-equal #:bar - #:notehead #:rbeams #:lbeams #:dots #:element + #:notehead #:rbeams #:lbeams #:dots #:element #:annotations #:melody-element #:rhythmic-element #:notes #:add-note #:find-note #:remove-note #:cluster-upper-bound #:cluster-lower-bound From crhodes at common-lisp.net Sat Feb 9 18:17:21 2008 From: crhodes at common-lisp.net (crhodes) Date: Sat, 9 Feb 2008 13:17:21 -0500 (EST) Subject: [gsharp-cvs] CVS gsharp/Mxml Message-ID: <20080209181721.0E39A610BE@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp/Mxml In directory clnet:/tmp/cvs-serv13743 Modified Files: mxml.lisp Log Message: Minor MusicXML edits. --- /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2008/02/09 16:54:33 1.5 +++ /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2008/02/09 18:17:20 1.6 @@ -753,10 +753,10 @@ (let ((sink (cxml:make-rod-sink :indentation 2 :canonical nil)) (ordered-parts)) (cxml:with-xml-output sink - (sax:start-dtd sink - "score-partwise" - "-//Recordare//DTD MusicXML 1.1 Partwise//EN" - "http://www.musicxml.org/dtds/partwise.dtd") + (sax:start-dtd sink + "score-partwise" + "-//Recordare//DTD MusicXML 1.1 Partwise//EN" + "http://www.musicxml.org/dtds/partwise.dtd") (sax:end-dtd sink) (cxml:with-element "score-partwise" (cxml:attribute "version" "1.1") @@ -976,22 +976,25 @@ (defgeneric make-xml-element (gharp-element voice)) +(defun rhythmic-element-type (element) + (ecase (notehead element) + (:long "long") + (:breve "breve") + (:whole "whole") + (:half "half") + (:filled + (ecase (max (rbeams element) (lbeams element)) + (0 "quarter") + (1 "eighth") + (2 "16th") + (3 "32nd") + (4 "64th") + (5 "128th") + (6 "256th"))))) + (defmethod make-xml-element ((rest rest) voice) (let ((duration (calculate-duration rest)) - (type (ecase (notehead rest) - (:long "long") - (:breve "breve") - (:whole "whole") - (:half "half") - (:filled - (ecase (max (rbeams rest) (lbeams rest)) - (0 "quarter") - (1 "eighth") - (2 "16th") - (3 "32nd") - (4 "64th") - (5 "128th") - (6 "256th"))))) + (type (rhythmic-element-type rest)) (dots (dots rest))) (cxml:with-element "note" (cxml:with-element "rest") @@ -1009,20 +1012,7 @@ ;; this maybe should get called earlier. or later. i don't know. (gsharp-measure::compute-final-accidentals (notes cluster)) (let ((duration (calculate-duration cluster)) - (type (ecase (notehead cluster) - (:long "long") - (:breve "breve") - (:whole "whole") - (:half "half") - (:filled - (ecase (max (rbeams cluster) (lbeams cluster)) - (0 "quarter") - (1 "eighth") - (2 "16th") - (3 "32nd") - (4 "64th") - (5 "128th") - (6 "256th"))))) + (type (rhythmic-element-type cluster)) (dots (dots cluster))) (loop for note in (notes cluster) @@ -1077,7 +1067,7 @@ (let ((step (mod pitch 7))) (list (car (rassoc step *step-to-basenote*)) (/ (- pitch step) 7)))) -(defun make-xml-note (note in-chord type dots duration &optional voice) +(defun make-xml-note (note in-chord type dots duration voice) (let ((pitch (gshnote-to-xml (pitch note))) (accidental (ecase (final-accidental note) ((nil)) @@ -1101,11 +1091,12 @@ (:sesquiflat "-1.5") (:double-flat "-2")))) (cxml:with-element "note" - (if in-chord - (cxml:with-element "chord")) + (when in-chord + (cxml:with-element "chord")) (cxml:with-element "pitch" (cxml:with-element "step" (cxml:text (car pitch))) - (if alter (cxml:with-element "alter" (cxml:text alter))) + (when alter + (cxml:with-element "alter" (cxml:text alter))) (cxml:with-element "octave" (cxml:text (write-to-string (cadr pitch))))) (cxml:with-element "duration" (cxml:text (write-to-string duration))) (unless (null voice) @@ -1113,15 +1104,15 @@ (cxml:with-element "type" (cxml:text type)) (loop repeat dots do (cxml:with-element "dot")) - (if accidental (cxml:with-element "accidental" - (cxml:text accidental))) + (when accidental + (cxml:with-element "accidental" (cxml:text accidental))) (unless (eq (final-stem-direction (cluster note)) :auto) (cxml:with-element "stem" (cxml:text (string-downcase (string (final-stem-direction (cluster note))))))) - (if (> (hash-table-count *staff-hash*) 1) - (cxml:with-element "staff" - (cxml:text (write-to-string (gethash (staff note) *staff-hash*))))) + (when (> (hash-table-count *staff-hash*) 1) + (cxml:with-element "staff" + (cxml:text (write-to-string (gethash (staff note) *staff-hash*))))) ;; Small temptation here to put the if clause on the attribute, ;; but remember that a note can have ties in both directions. From crhodes at common-lisp.net Sat Feb 9 18:21:00 2008 From: crhodes at common-lisp.net (crhodes) Date: Sat, 9 Feb 2008 13:21:00 -0500 (EST) Subject: [gsharp-cvs] CVS gsharp/Mxml Message-ID: <20080209182100.502DE691A8@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp/Mxml In directory clnet:/tmp/cvs-serv15850 Modified Files: mxml.lisp Log Message: One or two more stylistic changes. --- /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2008/02/09 18:17:20 1.6 +++ /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2008/02/09 18:21:00 1.7 @@ -1004,9 +1004,9 @@ (cxml:with-element "type" (cxml:text type)) (loop repeat dots do (cxml:with-element "dot")) - (if (> (hash-table-count *staff-hash*) 1) - (cxml:with-element "staff" - (cxml:text (write-to-string (gethash (staff rest) *staff-hash*)))))))) + (when (> (hash-table-count *staff-hash*) 1) + (cxml:with-element "staff" + (cxml:text (write-to-string (gethash (staff rest) *staff-hash*)))))))) (defmethod make-xml-element ((cluster cluster) voice) ;; this maybe should get called earlier. or later. i don't know. @@ -1034,9 +1034,9 @@ (unless (null voice) (cxml:with-element "voice" (cxml:text (write-to-string voice)))) ;; TODO: make this use the first melody staff above the lyrics staff - (if (> (hash-table-count *staff-hash*) 1) - (cxml:with-element "staff" - (cxml:text (write-to-string (gethash (staff lyric) *staff-hash*))))) + (when (> (hash-table-count *staff-hash*) 1) + (cxml:with-element "staff" + (cxml:text (write-to-string (gethash (staff lyric) *staff-hash*))))) (cxml:with-element "lyric" (cxml:with-element "syllabic" (cxml:text syllabic)) (cxml:with-element "text" (cxml:text text)))))) From crhodes at common-lisp.net Sat Feb 9 18:43:13 2008 From: crhodes at common-lisp.net (crhodes) Date: Sat, 9 Feb 2008 13:43:13 -0500 (EST) Subject: [gsharp-cvs] CVS gsharp/Mxml Message-ID: <20080209184313.B7BAC691A4@common-lisp.net> Update of /project/gsharp/cvsroot/gsharp/Mxml In directory clnet:/tmp/cvs-serv21297 Modified Files: mxml.lisp Log Message: MusicXML support for staccato and tenuto import and export. --- /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2008/02/09 18:21:00 1.7 +++ /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2008/02/09 18:43:13 1.8 @@ -201,6 +201,8 @@ (remove-if #'(lambda (s) (not (typep s 'fiveline-staff))) staves))) (elt melody-staves (parse-mxml-note-staff-number note)))) +(defvar *parsing-in-cluster*) + (defun parse-mxml-pitched-note (note staves) (let* ((staff (parse-mxml-note-staff note staves)) (step (named-pcdata note "step")) @@ -213,11 +215,16 @@ (estringcase (dom:get-attribute tie "type") ("start" (setf tie-right t)) ("stop" (setf tie-left t)))) + (for-named-elements ("staccato" stacc note) + (declare (ignore stacc)) + (pushnew :staccato (annotations *parsing-in-cluster*))) + (for-named-elements ("tenuto" ten note) + (declare (ignore ten)) + (pushnew :tenuto (annotations *parsing-in-cluster*))) (make-instance 'note :pitch pitch :staff staff :accidentals accidentals :tie-left tie-left :tie-right tie-right))) (defvar *parsing-duration-gmeasure-position*) -(defvar *parsing-in-cluster*) (defvar *mxml-divisions*) (defun parse-mxml-note (xnote bars staves lyrics-layer-hash) ;; TODO: There is nothing in MusicXML that stops you from having @@ -1011,18 +1018,14 @@ (defmethod make-xml-element ((cluster cluster) voice) ;; this maybe should get called earlier. or later. i don't know. (gsharp-measure::compute-final-accidentals (notes cluster)) - (let ((duration (calculate-duration cluster)) - (type (rhythmic-element-type cluster)) - (dots (dots cluster))) - + (let ((duration (calculate-duration cluster))) (loop for note in (notes cluster) - for x from 0 - do (make-xml-note note (> x 0) type dots duration voice)) - + for x from 0 + do (make-xml-note note (> x 0) duration voice cluster)) (when (null (notes cluster)) - ;; it's an empty cluster, a "space" + ;; it's an empty cluster, a "space" (cxml:with-element "forward" - (cxml:text (write-to-string duration)))))) + (cxml:text (write-to-string duration)))))) (defmethod make-xml-element ((lyric lyrics-element) voice) (let ((duration (calculate-duration lyric)) @@ -1067,29 +1070,47 @@ (let ((step (mod pitch 7))) (list (car (rassoc step *step-to-basenote*)) (/ (- pitch step) 7)))) -(defun make-xml-note (note in-chord type dots duration voice) - (let ((pitch (gshnote-to-xml (pitch note))) - (accidental (ecase (final-accidental note) - ((nil)) - (:sharp "sharp") - (:natural "natural") - (:flat "flat") - (:double-sharp "double-sharp") - (:sesquisharp "three-quarters-sharp") - (:semisharp "quarter-sharp") - (:semiflat "quarter-flat") - (:sesquiflat "three-quarters-flat") - (:double-flat "flat-flat"))) - (alter (ecase (accidentals note) - (:sharp "1") - (:natural nil) - (:flat "-1") - (:double-sharp "2") - (:sesquisharp "1.5") - (:semisharp "0.5") - (:semiflat "-0.5") - (:sesquiflat "-1.5") - (:double-flat "-2")))) +(defun note-accidental (note) + (ecase (final-accidental note) + ((nil)) + (:sharp "sharp") + (:natural "natural") + (:flat "flat") + (:double-sharp "double-sharp") + (:sesquisharp "three-quarters-sharp") + (:semisharp "quarter-sharp") + (:semiflat "quarter-flat") + (:sesquiflat "three-quarters-flat") + (:double-flat "flat-flat"))) + +(defun note-alter (note) + (ecase (accidentals note) + (:sharp "1") + (:natural nil) + (:flat "-1") + (:double-sharp "2") + (:sesquisharp "1.5") + (:semisharp "0.5") + (:semiflat "-0.5") + (:sesquiflat "-1.5") + (:double-flat "-2"))) + +(defun note-notations-p (note cluster) + (or (tie-left note) + (tie-right note) + (note-articulations-p note cluster))) + +(defun note-articulations-p (note cluster) + (let ((annotations (annotations cluster))) + (or (member :staccato annotations) + (member :tenuto annotations)))) + +(defun make-xml-note (note in-chord duration voice cluster) + (let ((type (rhythmic-element-type cluster)) + (dots (dots cluster)) + (pitch (gshnote-to-xml (pitch note))) + (accidental (note-accidental note)) + (alter (note-alter note))) (cxml:with-element "note" (when in-chord (cxml:with-element "chord")) @@ -1113,12 +1134,15 @@ (when (> (hash-table-count *staff-hash*) 1) (cxml:with-element "staff" (cxml:text (write-to-string (gethash (staff note) *staff-hash*))))) - - ;; Small temptation here to put the if clause on the attribute, - ;; but remember that a note can have ties in both directions. - (when (or (tie-left note) (tie-right note)) + (when (note-notations-p note cluster) (cxml:with-element "notations" (when (tie-left note) (cxml:with-element "tied" (cxml:attribute "type" "stop"))) (when (tie-right note) - (cxml:with-element "tied" (cxml:attribute "type" "start")))))))) + (cxml:with-element "tied" (cxml:attribute "type" "start"))) + (when (note-articulations-p note cluster) + (cxml:with-element "articulations" + (when (member :staccato (annotations cluster)) + (cxml:with-element "staccato")) + (when (member :tenuto (annotations cluster)) + (cxml:with-element "tenuto")))))))))