Update of /project/gsharp/cvsroot/gsharp/Mxml In directory clnet:/tmp/cvs-serv30948/Mxml
Added Files: commands.lisp mxml.lisp Log Message: Add MusicXML support. Initial work from Brian Gruber (funded by Google's Summer of Code); subsequent development by Christophe Rhodes.
It's far from perfect now, but it needs checking in so that people can play with it. It adds dependencies (puri and cxml) to gsharp; if this is a problem, we could make gsharp-mxml a separate system.
Git logs (from git tree at http://www-jcsu.jesus.cam.ac.uk/~csr21/git/gsharp-mxml/.git) follow:
commit 994cd15ec9f480be41515e699f22e7de1687d0ca Author: Christophe Rhodes csr21@omega.localdomain Date: Mon Sep 24 13:19:41 2007 +0100
Add a restart to the same-duration case. It's not good enough, but it allows interactive fixing key signatures in the middle of the bar.
commit cdc2098fac5399303e9515bc81ea65020ec8f109 Author: Christophe Rhodes csr21@omega.localdomain Date: Wed Sep 19 11:07:28 2007 +0100
Only add durations from rhythmic elements.
commit acc6cb410cd55dfe59eb30fe608b101a62651ae9 Author: Christophe Rhodes csr21@omega.localdomain Date: Wed Sep 19 10:45:12 2007 +0100
Whoops. Fix export of notes with no displayed accidentals (from overzealous alteration of CASE -> ECASE
commit dd8d72cac434a8c5a1932aa46db6447e08d9b6ad Author: Christophe Rhodes csr21@omega.localdomain Date: Wed Sep 19 10:41:09 2007 +0100
Support for longs in MusicXML (import and export)
commit eab440b56b086e766dbd405a3fea44d9976f1a1f Author: Christophe Rhodes csr21@omega.localdomain Date: Wed Sep 19 09:16:07 2007 +0100
Long ("lunga") patch from HEAD
commit 8cb34a4879ebb4dce06d8b99da761dfa6ad24cf9 Author: Christophe Rhodes csr21@omega.localdomain Date: Tue Sep 18 15:43:51 2007 +0100
Support semi- and sesqui- accidentals
commit 6ba8208d1f8475552a95f35a5e896248110b0efd Author: Christophe Rhodes csr21@omega.localdomain Date: Tue Sep 18 15:25:16 2007 +0100
Really support breves (and breve rests) -- on output too.
commit a9c36278de0145c12f34123a29815809030b97c2 Author: Christophe Rhodes csr21@omega.localdomain Date: Tue Sep 18 15:17:09 2007 +0100
Slightly batched commit (several changes).
* support :breve noteheads * better stringcase macro (and use it) * temporarily hack in "full" = "breve" for Goldsmiths use * use ECASE in one or two places to remove compiler warnings.
commit 3a3b980576f0d09ddee4de12f6f7b260932a5552 Author: Christophe Rhodes csr21@omega.localdomain Date: Tue Sep 18 15:14:54 2007 +0100
Slightly friendlier (with friends like this...) Import and Export commands. Sets the filepath and name of the buffer on import; sensible export default pathname.
commit 7d72a2a4a28f9668271189ebaf862518ada34877 Author: Christophe Rhodes csr21@omega.localdomain Date: Tue Sep 18 15:13:31 2007 +0100
Whitespace
commit b497d6f5111f20f5e8ac9a059578d3caaab1b832 Author: Christophe Rhodes csr21@omega.localdomain Date: Mon Sep 17 21:33:29 2007 +0100
space requirements fix from HEAD
commit 65d173efbcfa78e5edaf1adb9bceb0f7d619002d Author: Christophe Rhodes csr21@omega.localdomain Date: Mon Sep 17 12:04:08 2007 +0100
Update to Brian Gruber's version of 17th September
commit 91d98d9e2a8d69418edd264ab6293a2f1dbc5a9f Author: Christophe Rhodes csr21@omega.localdomain Date: Mon Sep 17 11:54:53 2007 +0100
Brian Gruber's patch of August 20th
--- /project/gsharp/cvsroot/gsharp/Mxml/commands.lisp 2007/10/18 15:02:48 NONE +++ /project/gsharp/cvsroot/gsharp/Mxml/commands.lisp 2007/10/18 15:02:48 1.1 (in-package :gsharp)
;;; like print-buffer-filename in gui.lisp (defun export-buffer-filename () (let* ((buffer (current-buffer)) (filepath (filepath buffer)) (name (name buffer)) (defaults (or filepath (merge-pathnames (make-pathname :name name) (user-homedir-pathname))))) (merge-pathnames (make-pathname :type "xml") defaults)))
;;; like directory-of-current-buffer in esa-io.lisp (defun directory-of-current-buffer () "Extract the directory part of the filepath to the file in the current buffer. If the current buffer does not have a filepath, the path to the user's home directory will be returned." (make-pathname :directory (pathname-directory (or (filepath (current-buffer)) (user-homedir-pathname)))))
(define-gsharp-command (com-import-musicxml :name t) ((pathname 'pathname :prompt "Import From: " :prompt-mode :raw :default (directory-of-current-buffer) :default-type 'pathname :insert-default t)) (let* ((buffer (gsharp-mxml::parse-mxml (gsharp-mxml::musicxml-document pathname))) (input-state (make-input-state)) (cursor (make-initial-cursor buffer)) (view (make-instance 'orchestra-view :buffer buffer :cursor cursor))) (setf (view (car (windows *application-frame*))) view (filepath buffer) (merge-pathnames (make-pathname :type "gsh") pathname) (name buffer) (file-namestring (filepath buffer)) (input-state *application-frame*) input-state) (select-layer cursor (car (layers (segment (current-cursor)))))))
(define-gsharp-command (com-export-musicxml :name t) ((pathname 'pathname :prompt "Export To: " :prompt-mode :raw :default (export-buffer-filename) :default-type 'pathname :insert-default t)) (let ((string (gsharp-mxml::write-mxml (current-buffer)))) (with-open-file (s pathname :if-does-not-exist :create :if-exists :supersede :direction :output) (write-string string s)))) --- /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2007/10/18 15:02:48 NONE +++ /project/gsharp/cvsroot/gsharp/Mxml/mxml.lisp 2007/10/18 15:02:48 1.1 (in-package :gsharp-mxml)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Utility functions, macros ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro test-make-xml (obj id) `(cxml:with-xml-output (cxml:make-rod-sink :indentation 2 :canonical nil) (make-xml ,obj ,id))) (defun write-buffer-to-xml-file (buffer filename) (with-open-file (s filename :direction :output) (write-string (write-mxml buffer) s)))
(defun pcdata (thing) (string-trim '(#\Space #\Tab #\Newline) (dom:node-value (dom:first-child thing)))) (defun named-pcdata (node tag-name) (if (has-element-type node tag-name) (pcdata (elt (dom:get-elements-by-tag-name node tag-name) 0)) nil)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun expander-for-stringcase (keyform cases exhaustivep) (let ((nkey (gensym "KEY"))) (flet ((expand-case (case) (destructuring-bind (keys &rest forms) case (cond ((member keys '(t otherwise)) (when exhaustivep (warn "~S found in ~S" keys 'estringcase)) `(t ,@forms)) ((stringp keys) `((string= ,keys ,nkey) ,@forms)) ((and (consp keys) (every #'stringp keys)) `((or ,@(loop for k in keys collect `(string= ,k ,nkey))) ,@forms)) (t (warn "Unrecognized keys: ~S" keys)))))) `(let ((,nkey ,keyform)) (cond ,@(loop for case in cases collect (expand-case case)) ,@(when exhaustivep `((t (error "~S failed to match any key in ~S" ,nkey 'estringcase))))))))))
(defmacro stringcase (keyform &body cases) (expander-for-stringcase keyform cases nil)) (defmacro estringcase (keyform &body cases) (expander-for-stringcase keyform cases t))
(defun has-element-type (node type-name) (> (length (dom:get-elements-by-tag-name node type-name)) 0))
(defmacro for-named-elements ((name varname node) &body body) (let ((elements (gensym))) `(let ((,elements (dom:get-elements-by-tag-name ,node ,name))) (sequence:dosequence (,varname ,elements) ,@body)))) (defmacro for-children ((varname node) &body body) (let ((children (gensym))) `(let ((,children (dom:child-nodes ,node))) (sequence:dosequence (,varname ,children) ,@body))))
(defun map-all-lists-maximally (fn id-base &rest all-lists) (loop with lists = (copy-list all-lists) for i from id-base until (every #'null lists) collecting (apply fn i (mapcar #'car lists)) do (map-into lists #'cdr lists)))
(defun split-if (predicate list) (loop for x in list if (funcall predicate x) collect x into a else collect x into b end finally (return (values a b))))
(defun find-if-nthcdr (predicate n sequence) "Finds the nth element that satisfies the predicate, and returns the cdr with that element as the head" (let ((i 0)) (do ((e sequence (cdr sequence))) ((= i n) e) (when (funcall predicate (car e)) (incf i)))))
;; perhaps these should go in utilities.lisp (defun unicode-to-string (unicode) (map 'string #'gsharp-utilities:unicode-to-char unicode)) (defun string-to-unicode (string) (map 'vector #'gsharp-utilities:char-to-unicode string))
;;;;;;;;;;;;;;; ;; Notes on mapping ;; ;; gsh maps to mxml pretty well: ;; staff == staff ;; voice == layer ;; cluster == chord ;; ;; Gsharp allows staffs to be in more than one layer, which isn't ;; explicit in mxml but is there: a note has to be in one staff, but ;; the notes in a chord can be in different ones while in the same ;; voice. ;; ;; the mapping seems to break down in that while mxml allows notes in ;; the same chord to be in different voices (though i'm not sure what ;; that would mean), a cluster in gsharp belongs to one layer. this ;; isn't a problem though, because the mapping of chord to cluster is ;; not really one-to-one. ;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;; ;; Import ;;;;;;;;;;;;
(defun parse-mxml-note-duration (note-element) "Given a MusicXML note element, return the appropriate Gsharp notehead, dots and beams values." ;; valid types: 256th, 128th, 64th, 32nd, 16th, ;; eighth, quarter, half, whole, breve, and long (let ((notehead (if (has-element-type note-element "type") (estringcase (named-pcdata note-element "type") (("256th" "128th" "64th" "32nd" "16th" "eighth" "quarter") :filled) ("half" :half) ("whole" :whole) (("breve" "full") :breve) ("long" :long)) :filled)) (beams (if (has-element-type note-element "type") (estringcase (named-pcdata note-element "type") ("256th" 6) ("128th" 5) ("64th" 4) ("32nd" 3) ("16th" 2) ("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)))
(defparameter *step-to-basenote* '((#\C . 0) (#\D . 1) (#\E . 2) (#\F . 3) (#\G . 4) (#\A . 5) (#\B . 6)))
(defun xmlnote-to-gsh (step octave) ;; C4 is middle C is 28 (let ((basenum (cdr (assoc (char-upcase (character step)) *step-to-basenote*)))) (+ 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. (let ((alters (dom:get-elements-by-tag-name note "alter"))) (if (= 0 (length alters)) :natural (let ((alter (pcdata (elt alters 0)))) (stringcase alter ("1" :sharp) ("0" :natural) ("-1" :flat) ("2" :double-sharp) ("1.5" :sesquisharp) ("0.5" :semisharp) ("-0.5" :semiflat) ("-1.5" :sesquiflat) ("-2" :double-flat) (t :natural))))))
(defun parse-mxml-note-staff-number (note) (if (has-element-type note "staff") (1- (parse-integer (named-pcdata note "staff"))) 0))
(defun parse-mxml-note-staff (note staves) "Given an xml note element and a list of all the staff objects, return the staff object the note is supposed to be assigned to. If none is specified, returns the first (hopefully default) staff." (let ((melody-staves (remove-if #'(lambda (s) (not (typep s 'fiveline-staff))) staves))) (elt melody-staves (parse-mxml-note-staff-number note))))
(defun parse-mxml-pitched-note (note staves) (let* ((staff (parse-mxml-note-staff note staves)) (step (named-pcdata note "step")) (octave (parse-integer (named-pcdata note "octave"))) (pitch (xmlnote-to-gsh step octave)) (accidentals (parse-mxml-accidental note)) (tie-left nil) (tie-right nil)) (for-named-elements ("tied" tie note) (estringcase (dom:get-attribute tie "type") ("start" (setf tie-right t)) ("stop" (setf tie-left t)))) (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 ;; multiple notes in a chord that have different durations, types, ;; and dots, something which Gsharp does not support in any way. ;; However, this is not something often run into: if 2 notes struck ;; simultaneously have different rhythmic properties, they are ;; almost always to be notated in separate voices. Supporting the ;; rare case here is quite complicated, as it requires the ;; spontaneous creation of another layer to accommodate it, so for ;; now, this code will assume that all notes in a chord have the ;; same type and dots as the first one mentioned in the MusicXML ;; file. Suggested revision: throw a condition asking the user if ;; they want to omit the note or make it the same duration as the ;; others.
;; Also, this breaks if you have a rest in a chord, which you can ;; have in MusicXML, but I'm not really sure what that would be. (let ((bar (elt bars (if (has-element-type xnote "voice") (1- (parse-integer (named-pcdata xnote "voice"))) 0))) (advance 0)) (multiple-value-bind (notehead beams dots) (parse-mxml-note-duration xnote)
(when (has-element-type xnote "lyric") (let* ((xlyric (elt (dom:get-elements-by-tag-name xnote "lyric") 0)) (lyrics-staff (cadr (find-if-nthcdr #'(lambda (s) (not (typep s 'lyrics-staff))) (parse-mxml-note-staff-number xnote) staves))) (lyrics-layer (gethash lyrics-staff lyrics-layer-hash)) (lyrics-bar (car (last (bars (body lyrics-layer))))) (lyrics-element (make-lyrics-element lyrics-staff :notehead notehead :lbeams beams :rbeams beams :dots dots))) ;; TODO there can be multiple lyrics on a given xml-note, ;; presumably for verses or something. Right now this just ;; ignores all but the first one, but this should be addressed. (loop for c across (string-to-unicode (named-pcdata xlyric "text")) do (append-char lyrics-element c)) (add-element-at-duration lyrics-element lyrics-bar *parsing-duration-gmeasure-position*)))
(when (has-element-type xnote "rest") (let ((new-rest (make-rest (parse-mxml-note-staff xnote staves) :notehead notehead :lbeams beams :rbeams beams :dots dots))) (add-element-at-duration new-rest bar *parsing-duration-gmeasure-position*) (setf advance (duration new-rest))))
(when (has-element-type xnote "pitch") (progn (unless (has-element-type xnote "chord") (multiple-value-bind (notehead beams dots) (parse-mxml-note-duration xnote) (setf *parsing-in-cluster* (make-cluster :notehead notehead :lbeams beams :rbeams beams :dots dots))) (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))))
(incf *parsing-duration-gmeasure-position* advance))))
(defun add-element-at-duration (element bar duration-position) ;; go through the bar, adding up the 'duration' value of each element. ;; if the total is less than the desired duration-position, ;; add an empty cluster of the appropriate length, and then add the new element. ;; when the sum is greater than the duration where the element should be placed, look at what the last element was ;; if it's not an empty element ;; throw some kind of error ;; else ;; concatenate empty elements together ;; if there's not enough room, (this is a fairly complicated calculation), error ;; else split up the empty cluster and insert the new element (loop for ecdr = (elements bar) then (cdr ecdr) for e = (car ecdr) for position from 0 until (null ecdr) for edur = (duration e) summing edur into total-duration until (> total-duration duration-position) finally (if (<= total-duration duration-position) ;;(this is going at the end of the bar) (progn (dolist (empty-cluster (generate-empty-clusters (- duration-position total-duration))) (add-element empty-cluster bar position) (incf position)) (add-element element bar position)) (if (is-empty e) (let ((empty-duration (loop for ee in ecdr until (not (is-empty ee)) summing (duration ee)))) ;; make sure there is enough empty space (if (> (duration element) empty-duration) (error "There is not enough empty space to put this element") (progn ;; remove all the empty space (loop for ee in ecdr until (not (is-empty ee)) do (remove-element ee bar))
;; add back the needed empty preceding space (dolist (empty-cluster (generate-empty-clusters (- duration-position (- total-duration edur)))) (add-element empty-cluster bar position) (incf position))
;; add the element (add-element element bar position) (incf position)
;; add the trailing empty space (dolist (empty-cluster (generate-empty-clusters (- empty-duration (- duration-position (- total-duration edur)) (duration element)))) (add-element empty-cluster bar position) (incf position))))) ;; FIXME: this restart isn't actually good enough; it ;; is legitimate to have a new element at the same ;; offset from the start of the bar as a previous ;; element, as long as that previous element had zero ;; duration (e.g. key signature) (restart-case (error "There is already a non-empty element here") (add-anyway () (add-element element bar position) (incf position)))))))
(defgeneric is-empty (element)) (defmethod is-empty ((element element)) nil)
[685 lines skipped]