[gsharp-cvs] CVS gsharp/Mxml
crhodes
crhodes at common-lisp.net
Thu Oct 18 15:02:48 UTC 2007
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 at 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 at omega.localdomain>
Date: Wed Sep 19 11:07:28 2007 +0100
Only add durations from rhythmic elements.
commit acc6cb410cd55dfe59eb30fe608b101a62651ae9
Author: Christophe Rhodes <csr21 at 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 at 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 at omega.localdomain>
Date: Wed Sep 19 09:16:07 2007 +0100
Long ("lunga") patch from HEAD
commit 8cb34a4879ebb4dce06d8b99da761dfa6ad24cf9
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date: Tue Sep 18 15:43:51 2007 +0100
Support semi- and sesqui- accidentals
commit 6ba8208d1f8475552a95f35a5e896248110b0efd
Author: Christophe Rhodes <csr21 at 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 at 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 at 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 at omega.localdomain>
Date: Tue Sep 18 15:13:31 2007 +0100
Whitespace
commit b497d6f5111f20f5e8ac9a059578d3caaab1b832
Author: Christophe Rhodes <csr21 at omega.localdomain>
Date: Mon Sep 17 21:33:29 2007 +0100
space requirements fix from HEAD
commit 65d173efbcfa78e5edaf1adb9bceb0f7d619002d
Author: Christophe Rhodes <csr21 at 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 at 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 , at forms))
((stringp keys)
`((string= ,keys ,nkey) , at forms))
((and (consp keys) (every #'stringp keys))
`((or ,@(loop for k in keys collect `(string= ,k ,nkey)))
, at 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)
, at body))))
(defmacro for-children ((varname node) &body body)
(let ((children (gensym)))
`(let ((,children (dom:child-nodes ,node)))
(sequence:dosequence (,varname ,children)
, at 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]
More information about the Gsharp-cvs
mailing list