Mxml/mxml.lisp

   1 (in-package :gsharp-mxml)
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;; Utility functions, macros
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 (defmacro test-make-xml (obj id)
   8   `(cxml:with-xml-output (cxml:make-rod-sink :indentation 2 :canonical nil)
   9     (make-xml ,obj ,id)))
  10 (defun write-buffer-to-xml-file (buffer filename)
  11   (with-open-file (s filename :direction :output)
  12     (write-string (write-mxml buffer) s)))
  13
  14 (defun pcdata (thing)
  15   (let ((content (dom:first-child thing)))
  16     ;; Could be empty
  17     (if content
  18         (string-trim '(#\Space #\Tab #\Newline)
  19                      (dom:node-value content))
  20         "")))
  21 (defun named-pcdata (node tag-name)
  22   (if (has-element-type node tag-name)
  23       (pcdata (elt (dom:get-elements-by-tag-name node tag-name) 0))
  24       nil))
  25 (eval-when (:compile-toplevel :load-toplevel :execute)
  26   (defun expander-for-stringcase (keyform cases exhaustivep)
  27     (let ((nkey (gensym "KEY")))
  28       (flet ((expand-case (case)
  29                (destructuring-bind (keys &rest forms) case
  30                  (cond
  31                    ((member keys '(t otherwise))
  32                     (when exhaustivep
  33                       (warn "~S found in ~S" keys 'estringcase))
  34                     `(t ,@forms))
  35                    ((stringp keys)
  36                     `((string= ,keys ,nkey) ,@forms))
  37                    ((and (consp keys) (every #'stringp keys))
  38                     `((or ,@(loop for k in keys collect `(string= ,k ,nkey)))
  39                       ,@forms))
  40                    (t
  41                     (warn "Unrecognized keys: ~S" keys))))))
  42         `(let ((,nkey ,keyform))
  43           (cond
  44             ,@(loop for case in cases collect (expand-case case))
  45             ,@(when exhaustivep
  46                 `((t (error "~S failed to match any key in ~S"
  47                       ,nkey 'estringcase))))))))))
  48
  49 (defmacro stringcase (keyform &body cases)
  50   (expander-for-stringcase keyform cases nil))
  51 (defmacro estringcase (keyform &body cases)
  52   (expander-for-stringcase keyform cases t))
  53
  54 (defun has-element-type (node type-name)
  55   (> (length (dom:get-elements-by-tag-name node type-name)) 0))
  56
  57 (defmacro for-named-elements ((name varname node) &body body)
  58   (let ((elements (gensym)))
  59     `(let ((,elements (dom:get-elements-by-tag-name ,node ,name)))
  60       (sequence:dosequence (,varname ,elements)
  61         ,@body))))
  62 (defmacro for-children ((varname node) &body body)
  63   (let ((children (gensym)))
  64     `(let ((,children (dom:child-nodes ,node)))
  65       (sequence:dosequence (,varname ,children)
  66         ,@body))))
  67
  68 (defun map-all-lists-maximally (fn id-base &rest all-lists)
  69   (loop with lists = (copy-list all-lists)
  70      for i from id-base
  71      until (every #'null lists)
  72      collecting (apply fn i (mapcar #'car lists))
  73      do (map-into lists #'cdr lists)))
  74
  75 (defun split-if (predicate list)
  76   (loop for x in list
  77      if (funcall predicate x)
  78        collect x into a
  79      else
  80        collect x into b
  81      end
  82      finally (return (values a b))))
  83
  84 (defun find-if-nthcdr (predicate n sequence)
  85   "Finds the nth element that satisfies the predicate, and returns the
  86 cdr with that element as the head"
  87   (let ((i 0))
  88     (do ((e sequence (cdr sequence)))
  89         ((= i n) e)
  90       (when (funcall predicate (car e))
  91         (incf i)))))
  92
  93 ;; perhaps these should go in utilities.lisp
  94 (defun unicode-to-string (unicode)
  95     (map 'string #'gsharp-utilities:unicode-to-char unicode))
  96 (defun string-to-unicode (string)
  97     (map 'vector #'gsharp-utilities:char-to-unicode string))
  98
  99
 100 ;;;;;;;;;;;;;;;
 101 ;; Notes on mapping
 102 ;;
 103 ;; gsh maps to mxml pretty well:
 104 ;; staff == staff
 105 ;; voice == layer
 106 ;; cluster == chord
 107 ;;
 108 ;; Gsharp allows staffs to be in more than one layer, which isn't
 109 ;; explicit in mxml but is there: a note has to be in one staff, but
 110 ;; the notes in a chord can be in different ones while in the same
 111 ;; voice.
 112 ;;
 113 ;; the mapping seems to break down in that while mxml allows notes in
 114 ;; the same chord to be in different voices (though i'm not sure what
 115 ;; that would mean), a cluster in gsharp belongs to one layer. this
 116 ;; isn't a problem though, because the mapping of chord to cluster is
 117 ;; not really one-to-one.
 118 ;;;;;;;;;;;;;;;;;;
 119
 120 ;;;;;;;;;;;;
 121 ;; Import
 122 ;;;;;;;;;;;;
 123
 124 (defun parse-mxml-note-duration (note-element)
 125   "Given a MusicXML note element, return the appropriate Gsharp
 126 notehead, dots and beams values."
 127   ;; valid types: 256th, 128th, 64th, 32nd, 16th,
 128   ;; eighth, quarter, half, whole, breve, and long
 129   (let ((notehead
 130          (if (has-element-type note-element "type")
 131              (estringcase (named-pcdata note-element "type")
 132                (("256th" "128th" "64th" "32nd" "16th" "eighth" "quarter")
 133                 :filled)
 134                ("half" :half)
 135                ("whole" :whole)
 136                ;; KLUDGE: "full" here (and for beams) I think is a
 137                ;; feature of catering for Nightingale's MusicXML
 138                ;; export, which is wrong in this respect.
 139                (("breve" "full") :breve)
 140                ("long" :long))
 141              :filled))
 142         (beams
 143          (if (has-element-type note-element "type")
 144              (estringcase (named-pcdata note-element "type")
 145                ("256th" 6)
 146                ("128th" 5)
 147                ("64th" 4)
 148                ("32nd" 3)
 149                ("16th" 2)
 150                ("eighth" 1)
 151                (("quarter" "half" "whole" "breve" "full" "long") 0))
 152              0))
 153         (dots (length (dom:get-elements-by-tag-name note-element "dot")))
 154         (stem (if (has-element-type note-element "stem")
 155                   (cond
 156                     ((string= (named-pcdata note-element "stem") "up") :up)
 157                     ((string= (named-pcdata note-element "stem") "down"):down)
 158                     (t :auto))
 159                   :auto)))
 160     (values notehead beams dots stem)))
 161
 162 (defparameter *step-to-basenote* '((#\C . 0)
 163                                    (#\D . 1)
 164                                    (#\E . 2)
 165                                    (#\F . 3)
 166                                    (#\G . 4)
 167                                    (#\A . 5)
 168                                    (#\B . 6)))
 169
 170 (defun xmlnote-to-gsh (step octave)
 171   ;; C4 is middle C is 28
 172   (let ((basenum (cdr (assoc (char-upcase (character step)) *step-to-basenote*))))
 173     (+ basenum (* 7 octave))))
 174
 175 (defun parse-mxml-accidental (note)
 176   ;; I (presumably Brian Gruber -- CSR) wrote it fairly early on and
 177   ;; it doesn't use things like has-element which it should.
 178   (let ((alters (dom:get-elements-by-tag-name note "alter")))
 179     (if (= 0 (length alters))
 180         :natural
 181         (let ((alter (pcdata (elt alters 0))))
 182           (stringcase alter
 183             ("1" :sharp)
 184             ("0" :natural)
 185             ("-1" :flat)
 186             ("2" :double-sharp)
 187             ("1.5" :sesquisharp)
 188             ("0.5" :semisharp)
 189             ("-0.5" :semiflat)
 190             ("-1.5" :sesquiflat)
 191             ("-2" :double-flat)
 192             (t :natural))))))
 193
 194 (defun parse-mxml-note-staff-number (note)
 195   (if (has-element-type note "staff")
 196       (1- (parse-integer
 197            (named-pcdata note "staff")))
 198       0))
 199
 200 (defun parse-mxml-note-staff (note staves)
 201 "Given an xml note element and a list of all the staff objects, return
 202 the staff object the note is supposed to be assigned to. If none is
 203 specified, returns the first (hopefully default) staff."
 204 (let ((melody-staves
 205        (remove-if #'(lambda (s) (not (typep s 'fiveline-staff))) staves)))
 206   (elt melody-staves (parse-mxml-note-staff-number note))))
 207
 208 (defvar *parsing-in-cluster*)
 209
 210 (defun parse-mxml-pitched-note (note staves)
 211   (let* ((staff (parse-mxml-note-staff note staves))
 212          (step (named-pcdata note "step"))
 213          (octave (parse-integer (named-pcdata note "octave")))
 214          (pitch (xmlnote-to-gsh step octave))
 215          (accidentals (parse-mxml-accidental note))
 216          (tie-left nil)
 217          (tie-right nil))
 218     (for-named-elements ("tied" tie note)
 219       (estringcase (dom:get-attribute tie "type")
 220         ("start" (setf tie-right t))
 221         ("stop" (setf tie-left t))))
 222     (for-named-elements ("staccato" stacc note)
 223       (declare (ignore stacc))
 224       (pushnew :staccato (annotations *parsing-in-cluster*)))
 225     (for-named-elements ("tenuto" ten note)
 226       (declare (ignore ten))
 227       (pushnew :tenuto (annotations *parsing-in-cluster*)))
 228     (make-instance 'note :pitch pitch :staff staff :accidentals accidentals
 229                    :tie-left tie-left :tie-right tie-right)))
 230
 231 (defvar *parsing-duration-gmeasure-position*)
 232 (defvar *mxml-divisions*)
 233 (defun parse-mxml-note (xnote bars staves lyrics-layer-hash)
 234   ;; TODO: There is nothing in MusicXML that stops you from having
 235   ;; multiple notes in a chord that have different durations, types,
 236   ;; and dots, something which Gsharp does not support in any way.
 237   ;; However, this is not something often run into: if 2 notes struck
 238   ;; simultaneously have different rhythmic properties, they are
 239   ;; almost always to be notated in separate voices. Supporting the
 240   ;; rare case here is quite complicated, as it requires the
 241   ;; spontaneous creation of another layer to accommodate it, so for
 242   ;; now, this code will assume that all notes in a chord have the
 243   ;; same type and dots as the first one mentioned in the MusicXML
 244   ;; file. Suggested revision: throw a condition asking the user if
 245   ;; they want to omit the note or make it the same duration as the
 246   ;; others.
 247
 248   ;; Also, this breaks if you have a rest in a chord, which you can
 249   ;; have in MusicXML, but I'm not really sure what that would be.
 250   (let ((bar (elt bars (if (has-element-type xnote "voice")
 251                            (1- (parse-integer (named-pcdata xnote "voice")))
 252                            0)))
 253         (advance 0))
 254     (multiple-value-bind (notehead beams dots)
 255         (parse-mxml-note-duration xnote)
 256
 257       (when (has-element-type xnote "lyric")
 258         (let* ((xlyric (elt (dom:get-elements-by-tag-name xnote "lyric") 0))
 259                (lyrics-staff
 260                 (cadr (find-if-nthcdr #'(lambda (s) (not (typep s 'lyrics-staff)))
 261                                       (parse-mxml-note-staff-number xnote)
 262                                       staves)))
 263                (lyrics-layer (gethash lyrics-staff lyrics-layer-hash))
 264                (lyrics-bar (car (last (bars (body lyrics-layer)))))
 265                (lyrics-element (make-lyrics-element lyrics-staff
 266                                                     :notehead notehead
 267                                                     :lbeams beams
 268                                                     :rbeams beams
 269                                                     :dots dots)))
 270           ;; TODO there can be multiple lyrics on a given xml-note,
 271           ;; presumably for verses or something. Right now this just
 272           ;; ignores all but the first one, but this should be addressed.
 273           (loop for c across (string-to-unicode (named-pcdata xlyric "text"))
 274              do (append-char lyrics-element c))
 275           (add-element-at-duration lyrics-element
 276                                    lyrics-bar
 277                                    *parsing-duration-gmeasure-position*)))
 278
 279       (when (has-element-type xnote "rest")
 280         (let ((new-rest (make-rest (parse-mxml-note-staff xnote staves)
 281                                    :notehead notehead
 282                                    :lbeams beams
 283                                    :rbeams beams
 284                                    :dots dots)))
 285           (add-element-at-duration new-rest
 286                                    bar
 287                                    *parsing-duration-gmeasure-position*)
 288           (setf advance (duration new-rest))))
 289
 290       (when (has-element-type xnote "pitch")
 291         (progn
 292           (unless (has-element-type xnote "chord")
 293             (multiple-value-bind (notehead beams dots stem)
 294                 (parse-mxml-note-duration xnote)
 295               (setf *parsing-in-cluster* (make-cluster :notehead notehead
 296                                                        :lbeams beams
 297                                                        :rbeams beams
 298                                                        :dots dots
 299                                                        :stem-direction stem)))
 300
 301             (add-element-at-duration *parsing-in-cluster* bar *parsing-duration-gmeasure-position*)
 302             (setf advance (duration *parsing-in-cluster*)))
 303           (add-note *parsing-in-cluster* (parse-mxml-pitched-note xnote staves))))
 304
 305       (incf *parsing-duration-gmeasure-position* advance))))
 306
 307 (defun add-element-at-duration (element bar duration-position)
 308   ;; go through the bar, adding up the 'duration' value of each element.
 309   ;; if the total is less than the desired duration-position,
 310   ;;   add an empty cluster of the appropriate length, and then add the new element.
 311   ;; when the sum is greater than the duration where the element should be placed, look at what the last element was
 312   ;; if it's not an empty element
 313   ;;   throw some kind of error
 314   ;; else
 315   ;;   concatenate empty elements together
 316   ;;   if there's not enough room, (this is a fairly complicated calculation), error
 317   ;;   else split up the empty cluster and insert the new element
 318   (loop for ecdr = (elements bar) then (cdr ecdr)
 319      for e = (car ecdr)
 320      for position from 0
 321      until (null ecdr)
 322      for edur = (duration e)
 323      summing edur into total-duration
 324      until (> total-duration duration-position)
 325      finally
 326        (if (<= total-duration duration-position) ;;(this is going at the end of the bar)
 327            (progn
 328              (dolist (empty-cluster
 329                        (generate-empty-clusters (- duration-position total-duration)))
 330                (add-element empty-cluster bar position)
 331                (incf position))
 332              (add-element element bar position))
 333            (if (is-empty e)
 334                (let ((empty-duration
 335                       (loop for ee in ecdr
 336                          until (not (is-empty ee))
 337                          summing (duration ee))))
 338                  ;; make sure there is enough empty space
 339                  (if (> (duration element) empty-duration)
 340                      (error "There is not enough empty space to put this element")
 341                      (progn
 342                        ;; remove all the empty space
 343                        (loop for ee in ecdr
 344                           until (not (is-empty ee))
 345                           do (remove-element ee bar))
 346
 347                        ;; add back the needed empty preceding space
 348                        (dolist (empty-cluster
 349                                  (generate-empty-clusters (- duration-position (- total-duration edur))))
 350                          (add-element empty-cluster bar position)
 351                          (incf position))
 352
 353                        ;; add the element
 354                        (add-element element bar position)
 355                        (incf position)
 356
 357                        ;; add the trailing empty space
 358                        (dolist (empty-cluster
 359                                  (generate-empty-clusters
 360                                   (- empty-duration (- duration-position (- total-duration edur)) (duration element))))
 361                          (add-element empty-cluster bar position)
 362                          (incf position)))))
 363                ;; FIXME: this restart isn't actually good enough; it
 364                ;; is legitimate to have a new element at the same
 365                ;; offset from the start of the bar as a previous
 366                ;; element, as long as that previous element had zero
 367                ;; duration (e.g. key signature)
 368                (restart-case
 369                    (error "There is already a non-empty element here")
 370                  (add-anyway ()
 371                    (add-element element bar position)
 372                    (incf position)))))))
 373
 374 (defgeneric is-empty (element))
 375 (defmethod is-empty ((element cons))
 376   t)
 377 (defmethod is-empty ((element element))
 378   nil)
 379 (defmethod is-empty ((lyrics-element lyrics-element))
 380   (= 0 (length (text lyrics-element))))
 381 (defmethod is-empty ((cluster cluster))
 382   (null (notes cluster)))
 383
 384
 385 (defun generate-empty-clusters (duration)
 386   (let ((whole-divisions 1)
 387         (half-divisions 1/2)
 388         (quarter-divisions 1/4))
 389     (nconc
 390      (loop until (> whole-divisions duration)
 391         do (decf duration whole-divisions)
 392         collect (make-cluster :notehead :whole))
 393      (loop until (> half-divisions duration)
 394         do (decf duration half-divisions)
 395         collect (make-cluster :notehead :half))
 396      (loop until (> quarter-divisions duration)
 397         do (decf duration quarter-divisions)
 398         collect (make-cluster :notehead :filled))
 399      (loop for beams from 1
 400         for divisions = (/ quarter-divisions 2) then (/ divisions 2)
 401         nconc
 402         (loop until (> divisions duration)
 403            do (decf duration divisions)
 404            collect (make-cluster :notehead :filled :lbeams beams :rbeams beams))
 405         until (= duration 0)))))
 406
 407 (defun parse-mxml-clef (clef)
 408   "Takes dom element for clef and returns a clef object"
 409   (let ((name (stringcase (named-pcdata clef "sign")
 410                           ("G" (if (string= (named-pcdata clef "clef-octave-change")
 411                                             "-1")
 412                                    :treble8
 413                                    :treble))
 414                           ("F" :bass)
 415                           ("C" :c)
 416                           ("percussion" :percussion)
 417                           ;; "TAB" and "none" are the other, unsupported choices,
 418                           ;; along with other octave shifts.
 419                           (t  :c)))
 420         (lineno (if (has-element-type clef "line")
 421                     (* 2 (1- (parse-integer (named-pcdata clef "line"))))
 422                     nil))
 423         (staff-number (if (dom:has-attribute clef "number")
 424                           (1- (parse-integer (dom:get-attribute clef "number")))
 425                           0)))
 426     (values (make-clef name :lineno lineno) staff-number)))
 427
 428 (defun parse-mxml-key (key staves)
 429   "Takes a dom element 'key' and returns a key-signature object"
 430
 431   (let ((alterations (fill (make-array 7) :natural))
 432         (fifths-element (dom:get-elements-by-tag-name key "fifths"))
 433
 434         (staff (nth (if (dom:has-attribute key "number")
 435                         (1- (parse-integer (dom:get-attribute key "number")))
 436                         ;; TODO: this next line is wrong... it's
 437                         ;; supposed to apply to all staves if the
 438                         ;; staff isn't specified
 439                         0)
 440                     (remove-if #'(lambda (s) (typep s 'lyrics-staff)) staves))))
 441     (if (eql 1 (length fifths-element))
 442         (let ((fifths (parse-integer (pcdata (elt fifths-element 0))))
 443               (order-of-sharps #(3 0 4 1 5 2 6))
 444               (order-of-flats #(6 2 5 1 4 0 3))
 445               (key-signature (gsharp-buffer::make-key-signature staff)))
 446           ;; deal with the basic fifths
 447           (if (< fifths 0)
 448               ;; well, this would have been a nice way to do it, but
 449               ;; it doesn't work:
 450               ;; (more-flats key-signature (abs fifths))
 451               ;; (more-sharps key-signature fifths))
 452
 453               (dotimes (index (abs fifths))
 454                 (setf (elt alterations (elt order-of-flats index)) :flat))
 455               (dotimes (index fifths)
 456                 (setf (elt alterations (elt order-of-sharps index)) :sharp)))
 457           key-signature)
 458
 459         ;; Deal with weird key signatures
 460         ;; The DTD specifies that it goes step, alter, step, alter. If
 461         ;; it doesn't, the parser should have barfed when the file was
 462         ;; loaded, so I'm not checking it here.
 463         (let ((steps (dom:get-elements-by-tag-name key "key-step"))
 464               (alters (dom:get-elements-by-tag-name key "key-alter")))
 465           (loop for step across steps
 466                 for alter across (map 'vector #'pcdata alters)
 467                 do
 468                 (let ((index
 469                        (cdr (assoc
 470                              (char-upcase (character (pcdata step)))
 471                              *step-to-basenote*))))
 472                   (setf (elt alterations index)
 473                         (stringcase alter
 474                           ("1" :sharp)
 475                           ("0" :natural)
 476                           ("-1" :flat)
 477                           ("2" :double-sharp)
 478                           ("-2" :double-flat)
 479                           (t :natural)))))))
 480     (gsharp-buffer::make-key-signature staff :alterations alterations)))
 481
 482 (defun xmlstaff-has-lyrics (part staff-number)
 483   "Given a MusicXML part and a staff number, determine if any of the
 484 note elements in that staff have associated lyrics."
 485   (for-named-elements ("note" note part)
 486     (let ((staff (if (has-element-type note "staff")
 487                      (parse-integer (named-pcdata note "staff"))
 488                      1)))
 489       (when (eql staff staff-number)
 490         (when (has-element-type note "lyric")
 491           (return-from xmlstaff-has-lyrics t)))))
 492   nil)
 493
 494 (defun copy-keysignature (ks)
 495   (gsharp-buffer::make-key-signature
 496    (staff ks) :alterations (copy-seq (alterations ks))))
 497 (defun copy-clef (clef)
 498   (make-clef (name clef) :lineno (lineno clef)))
 499
 500 (defun gduration-from-xduration (xduration)
 501   (/ xduration (* 4 *mxml-divisions*)))
 502
 503 (defun parse-mxml-part (part part-name)
 504   (let ((staves nil)
 505         (layers nil)
 506         (lyrics-layer-hash (make-hash-table)))
 507     ;; Create all of the staves, along with their initial
 508     ;; keysignatures and clefs.
 509     ;; TODO change this to do look in the current part, not the
 510     ;; current doc
 511
 512     ;; handling lyric staves: for every new stave i make, look to see
 513     ;; if any of the note elements assigned to this staff have a
 514     ;; lyrics element. if such a beast exists, create a new lyric
 515     ;; staff and a new layer, which should come immediately after the
 516     ;; melody staff in question in the staves list.
 517
 518     (let* ((number-of-staves
 519             (max 1
 520                  (loop for x across
 521                       (dom:get-elements-by-tag-name part "staves")
 522                       maximizing (parse-integer (pcdata x)))))
 523            (clefs (make-array number-of-staves))
 524            (measures (dom:get-elements-by-tag-name part "measure"))
 525            (attributes))
 526       ;; The attributes don't appear to need to be the first things in
 527       ;; a bar (see the Dichterliebe example on recordare
 528       ;; website---it's a v2.0 example, but I can't see where what it
 529       ;; does would be illegal in v1). I don't know what can precede
 530       ;; it in the wild, but the dtd is very permissive. This approach
 531       ;; allows the element to occur anywhere---not even limiting it
 532       ;; to the first bar. This may be stupid, but I can't tell.
 533       (do ((i 0 (1+ i)))
 534           ((= i (length measures)))
 535         (do ((thing (dom:first-child (elt measures i))
 536                     (dom:next-sibling thing)))
 537             ((not thing))
 538           (when (string= (dom:tag-name thing) "attributes")
 539             (setf attributes thing)
 540             (return)))
 541         (when attributes
 542           (return)))
 543       (when attributes
 544
 545         ;; clefs need to be made before i make the staves, keysigs
 546         ;; after. don't ask.
 547         ;; clefs
 548         (for-named-elements ("clef" clef attributes)
 549           (multiple-value-bind (new-clef staff-number)
 550               (parse-mxml-clef clef)
 551             (setf (elt clefs staff-number) new-clef)))
 552         ;; every fiveline staff must have a clef, even if the xml file did not specify one
 553         (loop for clef across clefs
 554            for i from 0
 555            do (when (eql 0 clef)
 556                 (setf (elt clefs i) (make-clef :treble))))
 557         ;; staves
 558         ;; remember that the order of the staves matters, and the
 559         ;; order that they are put in here is the order they will be
 560         ;; in when added to the buffer.
 561         (setf staves
 562               (loop for i below number-of-staves
 563                  for melody-staff = (make-fiveline-staff :name (if (= number-of-staves 1)
 564                                                                    part-name
 565                                                                    (format nil "~A staff ~D" part-name (1+ i)))
 566                                                          :clef (elt clefs i))
 567                  for lyric-staff = (if (xmlstaff-has-lyrics part (1+ i))
 568                                        (list (make-lyrics-staff :name (if (= number-of-staves 1)
 569                                                                           part-name
 570                                                                           (format nil "~A lyricstaff ~D" part-name (1+ i)))))
 571                                        nil)
 572                  nconc (cons melody-staff lyric-staff)))
 573         ;; keysignatures
 574         (for-named-elements ("key" key attributes)
 575           (let ((keysig (parse-mxml-key key staves)))
 576             (setf (keysig (staff keysig)) keysig)))))
 577
 578     ;; make the layers
 579     (multiple-value-bind (lyrics-staves fiveline-staves)
 580         (split-if #'(lambda (s) (typep s 'lyrics-staff)) staves)
 581       ;; first figure out which staves go in each layer
 582       (let ((staves-for-layers (make-array
 583                                 (max 1
 584                                      (loop for x across
 585                                           (dom:get-elements-by-tag-name part "voice")
 586                                           maximizing (parse-integer (pcdata x))))
 587                                 :initial-element nil)))
 588         (for-named-elements ("note" note part)
 589           (let ((staff-number (if (has-element-type note "staff")
 590                                   (1- (parse-integer (named-pcdata note "staff")))
 591                                   0))
 592                 (voice-number (if (has-element-type note "voice")
 593                                   (1- (parse-integer (named-pcdata note "voice")))
 594                                   0)))
 595             (pushnew (nth staff-number fiveline-staves) (elt staves-for-layers voice-number))))
 596         (setf layers (nconc
 597                        (loop for staves across staves-for-layers
 598                           for i from 1
 599                           collect (make-layer staves
 600                                               :body (make-slice :bars nil)
 601                                               :name (if (= (length staves-for-layers) 1)
 602                                                         part-name
 603                                                         (format nil "~A layer ~D" part-name i))))
 604                        (loop for lyrics-staff in lyrics-staves
 605                           for i from 1
 606                           for new-layer = (make-layer (list lyrics-staff)
 607                                                       :body (make-slice :bars nil)
 608                                                       :name (if (= (length staves-for-layers) 1)
 609                                                                 part-name
 610                                                                 (format nil "~A lyrics-layer ~D" part-name i)))
 611                           do (setf (gethash lyrics-staff lyrics-layer-hash) new-layer)
 612                           collecting new-layer)))))
 613
 614     ;; return the layers and the staves
 615     (values layers
 616             staves
 617             lyrics-layer-hash)))
 618
 619 (defun parse-make-segment (part layers staves lyrics-layer-hash)
 620   ;;look at each element
 621   (loop for measure across (dom:get-elements-by-tag-name part "measure")
 622      for measure-position from 0
 623      do
 624      (let ((bars (loop for layer in layers
 625                     for new-bar = (if (typep layer 'melody-layer)
 626                                       (make-melody-bar)
 627                                       (make-lyrics-bar))
 628                     do (add-bar new-bar (body layer) measure-position)
 629                     collect new-bar))
 630            (*parsing-duration-gmeasure-position* 0)
 631            (*parsing-in-cluster* nil))
 632
 633        (for-children (child measure)
 634          (let ((element-type (dom:tag-name child)))
 635            (stringcase element-type
 636              ("note"
 637               (parse-mxml-note child bars staves lyrics-layer-hash))
 638
 639              ("attributes"
 640               ;; Divisions:
 641               (when (has-element-type child "divisions")
 642                 (setf *mxml-divisions* (parse-integer (named-pcdata child "divisions"))))
 643
 644               ;; Keysigs:
 645
 646               ;; if we haven't written anything yet, this
 647               ;; keysignature got added to the staff itself
 648               (unless (= 0 measure-position *parsing-duration-gmeasure-position*)
 649                 (when (has-element-type child "key")
 650                   (let ((new-keysignature (parse-mxml-key
 651                                            (elt (dom:get-elements-by-tag-name child "key") 0)
 652                                            staves)))
 653                     (loop for bar in bars
 654                        do (when (find (staff new-keysignature) (staves (layer (slice bar))))
 655                             (add-element-at-duration
 656                              (copy-keysignature new-keysignature)
 657                              bar *parsing-duration-gmeasure-position*)))))
 658                 (when (has-element-type child "clef")
 659                   ;; spacer till this is available in gsharp
 660                   #+nil (multiple-value-bind (new-clef staff-number)
 661                       (parse-mxml-clef (elt (dom:get-elements-by-tag-name child "clef") 0))
 662                     (loop for bar in bars
 663                        do (when (find (nth staff-number staves) (staves (layer (slice bar))))
 664                             (add-element-at-duration
 665                              (copy-clef new-clef) bar
 666                              *parsing-duration-gmeasure-position*)))))))
 667
 668              ("backup" (setf *parsing-duration-gmeasure-position*
 669                          (max (- *parsing-duration-gmeasure-position*
 670                                  (gduration-from-xduration
 671                                   (parse-integer (named-pcdata child "duration"))))
 672                               0)))
 673          ("forward" (incf *parsing-duration-gmeasure-position*
 674                           (gduration-from-xduration
 675                            (parse-integer (named-pcdata child "duration")))))))))))
 676
 677 (defun parse-mxml (document)
 678   (let ((layerss nil)
 679         (lyrics-layer-hashes nil)
 680         (stavess nil)
 681         (parts (dom:get-elements-by-tag-name document "part"))
 682         (parts-alist nil))
 683     (sequence:dosequence (part (dom:child-nodes
 684                                 (aref (dom:get-elements-by-tag-name document "part-list")
 685                                       0)))
 686       (setf parts-alist
 687             (if (has-element-type part "part-name")
 688                 (acons (dom:get-attribute part "id")
 689                        (named-pcdata part "part-name")
 690                        parts-alist)
 691                 (acons (dom:get-attribute part "id")
 692                        (dom:get-attribute part "id")
 693                        parts-alist))))
 694     (sequence:dosequence (part parts)
 695        (multiple-value-bind (layers staves lyrics-layer-hash)
 696           (parse-mxml-part part (cdr (assoc (dom:get-attribute part "id")
 697                                             parts-alist :test #'string=)))
 698         (setf layerss
 699               (append layerss (list layers)))
 700         (setf lyrics-layer-hashes
 701               (append lyrics-layer-hashes (list lyrics-layer-hash)))
 702         (setf stavess (append stavess (list staves)))))
 703
 704     ;; And finally make the buffer and start parsing notes.
 705     ;; Previous operations result in staves and layers in opposite
 706     ;; orders (don't know why) - hence the reverse for segment layers
 707     (let* ((segment (make-instance 'segment
 708                                    :layers (reverse (apply #'concatenate 'list layerss))))
 709            (buffer (make-instance 'buffer
 710                                   :segments (list segment)
 711                                   :staves (apply #'concatenate 'list stavess))))
 712       (loop for part across parts
 713          for lyrics-layer-hash in lyrics-layer-hashes
 714          for layers in layerss
 715          for staves in stavess
 716          with *mxml-divisions* = nil
 717          do (parse-make-segment part layers staves lyrics-layer-hash))
 718       buffer)))
 719
 720 (defvar *mxml-dtds-dir*
 721   (merge-pathnames "mxml-dtds/"
 722                    (make-pathname
 723                     :directory (pathname-directory
 724                                 (load-time-value *load-pathname*)))))
 725 (defun musicxml-document (pathname)
 726   (flet ((resolver (pubid sysid)
 727            (declare (ignore pubid))
 728            (when (equal (puri:uri-host sysid) "www.musicxml.org")
 729              (open (merge-pathnames
 730                     (get-dtd-path (puri:uri-parsed-path sysid))
 731                     *mxml-dtds-dir*)
 732                    :element-type '(unsigned-byte 8)))))
 733     (cxml:parse-file pathname (cxml:make-whitespace-normalizer
 734                                (cxml-dom:make-dom-builder))
 735                      :entity-resolver #'resolver :validate t)))
 736 (defun get-dtd-path (uri-path)
 737   (let* ((parsed-path uri-path)
 738          (parent-dir (nth (- (list-length parsed-path) 2)
 739                           parsed-path))
 740          (filename (car (last parsed-path))))
 741     (cond
 742       ((member parent-dir '("1.0" "1.1" "2.0") :test #'string=)
 743        (format nil "~D/~D" parent-dir filename))
 744       (t (format nil "2.0/~D" filename)))))
 745
 746
 747
 748 (defun musicxml-document-from-string (string)
 749   (flet ((resolver (pubid sysid)
 750            (declare (ignore pubid))
 751            (when (equal (puri:uri-host sysid) "www.musicxml.org")
 752              (open (merge-pathnames
 753                     (file-namestring (puri:uri-path sysid))
 754                     *mxml-dtds-dir*)
 755                    :element-type '(unsigned-byte 8)))))
 756     (cxml:parse-rod string (cxml:make-whitespace-normalizer
 757                                (cxml-dom:make-dom-builder))
 758                      :entity-resolver #'resolver :validate t)))
 759
 760 ;;;;;;;;;;;
 761 ;; Export
 762 ;;;;;;;;;;;
 763 (defvar *staff-hash*)
 764
 765 (defun guess-parts (layers)
 766   ;; Looks for the way of dividing layers into as many mxml-parts as
 767   ;; possible without ending up with a single staff in two
 768   ;; parts. Returns two parallel lists - one of lists of layers, the
 769   ;; other of staves.
 770   (let ((parts))
 771     (dolist (layer layers (values (mapcar #'second parts)
 772                                   (mapcar #'first parts)))
 773       (dolist (part parts (setf parts (cons (list (staves layer)
 774                                                   (list layer))
 775                                             parts)))
 776         (when (not (every #'(lambda (x) (not (member x (first part))))
 777                           (staves layer)))
 778           (setf (first part) (union (staves layer)
 779                                     (first part))
 780                 (second part) (cons layer (second part)))
 781           (return))))))
 782
 783 (defun ordered-parts (segment buffer)
 784   ;; sort parts that can have multiple layers and staves. Sort by
 785   ;; stave order and then by layers order.
 786   (multiple-value-bind (part-layers part-staves)
 787       (guess-parts (layers segment))
 788     (let* ((s-positions (mapcar #'(lambda (x)
 789                                     (loop for stave in x
 790                                        minimize (position stave (staves buffer))))
 791                                 part-staves))
 792            (l-positions (mapcar #'(lambda (x)
 793                                     (loop for layer in x
 794                                        minimize (position layer (layers segment))))
 795                                 part-layers))
 796            (parts (mapcar #'list part-layers s-positions l-positions)))
 797       (mapcar #'car
 798               (sort parts #'(lambda (x y) (or (< (second x) (second y))
 799                                               (and (= (second x) (second y))
 800                                                    (< (third x) (third y))))))))))
 801
 802 (defun write-mxml (buffer)
 803   ;; Create mxml for buffer. Previously took part = segment, now takes
 804   ;; part = layer.
 805   (let ((sink (cxml:make-rod-sink :indentation 2 :canonical nil))
 806         (ordered-parts))
 807     (cxml:with-xml-output sink
 808       (sax:start-dtd sink
 809                      "score-partwise"
 810                      "-//Recordare//DTD MusicXML 1.1 Partwise//EN"
 811                      "http://www.musicxml.org/dtds/partwise.dtd")
 812       (sax:end-dtd sink)
 813       (cxml:with-element "score-partwise"
 814         (cxml:attribute "version" "1.1")
 815         (loop for segment in (segments buffer)
 816              with measure-number = 1
 817              do
 818              (setf ordered-parts (ordered-parts segment buffer))
 819              (make-xml-partlist ordered-parts)
 820              (make-xml-segment segment measure-number ordered-parts)
 821              (setf measure-number
 822                    (+ measure-number
 823                       (loop for layer in (layers segment)
 824                          maximizing (length (bars (body layer)))))))))))
 825
 826 (defun make-xml-partlist (part-list)
 827   ;; Generates the part-list element based on sublists of layers. Part ID's are
 828   ;; numbered P1, P2, etc., part names are taken from the layer names.
 829   (cxml:with-element "part-list"
 830     (do ((part-list part-list (cdr part-list))
 831          (i 1 (1+ i)))
 832         ((null part-list))
 833       (cxml:with-element "score-part"
 834         (cxml:attribute "id" (format nil "P~D" i))
 835         (cxml:with-element "part-name"
 836           (cxml:text (name-for-part (car part-list))))))))
 837
 838 (defun name-for-part (layers)
 839   (apply #'concatenate 'string (name (car layers))
 840          (loop for layer in (cdr layers)
 841             collect (format nil ", ~A" (name layer)))))
 842
 843 ;;;;;;;;;;;;;;;;;;;;;;;;;;
 844 ;; Dealing with durations
 845 ;;;;;;;;;;;;;;;;;;;;;;;;;;
 846 (defun extract-all-elements (segment)
 847   (loop for layer in (layers segment)
 848      append (loop for bar in (bars (body layer))
 849                 appending (elements bar))))
 850
 851 (defun calculate-required-divisions (element)
 852   "Determines what fraction of a quarter note is required to represent
 853 the duration of this note. For example, passing a quarter-note will
 854 return 1. Passing a double-dotted half-note will return 2. Passing a
 855 dotted 16th note will return 8."
 856   (when (not (typep element 'rhythmic-element))
 857     (return-from calculate-required-divisions 1))
 858   ;; so gsharp allows you to have half- and whole- notes w/
 859   ;; flags/beams. i'm just gonna pretend that said flags/beams make
 860   ;; any note half of it's normal value.
 861   (let ((base-value
 862          (ecase (notehead element)
 863            (:filled 1)
 864            (:whole 1/4)
 865            (:half 1/2)
 866            (:breve 1/8)
 867            (:long 1/16)))
 868         (dots (dots element))
 869         (beams (max (rbeams element) (lbeams element))))
 870     (ceiling (* base-value (expt 2 (+ beams dots))))))
 871
 872 (defun calculate-duration (element)
 873   ;; If not all of these calculations result in integers, then
 874   ;; calculate-required-divisions did not work properly.
 875   (let ((base-value
 876          (ecase (notehead element)
 877            (:filled 1)
 878            (:long 16)
 879            (:breve 8)
 880            (:whole 4)
 881            (:half 2)))
 882         (dots (dots element))
 883         (beams (max (rbeams element) (lbeams element))))
 884     (let ((b (* *mxml-divisions* base-value (expt 2 (* -1 beams)))))
 885       (loop for i upto dots
 886            summing (* b (expt 2 (* -1 i)))))))
 887
 888 ;;;;;;;;;;;;;;;;;;;;;;
 889 ;; Back to exporting
 890 ;;;;;;;;;;;;;;;;;;;;;;
 891
 892 (defun make-xml-segment (segment first-bar-number ordered-parts)
 893
 894   ;; Evaluate the appropriate mxml divisions.
 895   ;; i think the beginning of a segment is a good place to do this. i
 896   ;; have no real reason for doing it at this level, it just seems
 897   ;; right.
 898   (let ((*mxml-divisions*
 899          (loop for element in (extract-all-elements segment)
 900             maximizing (calculate-required-divisions element))))
 901     (do* ((parts ordered-parts (cdr parts))
 902           (part (car parts) (car parts))
 903           (i 1 (1+ i)))
 904          ((null parts))
 905       (let ((*staff-hash*
 906              (make-staff-hash (remove-duplicates
 907                                (apply #'concatenate 'list
 908                                       (mapcar #'staves part))))))
 909         (cxml:with-element "part"
 910           (cxml:attribute "id" (format nil "P~D" i))
 911           (do ((part-bars (mapcar #'(lambda (x) (bars (body x)))
 912                                   part)
 913                           (mapcar #'cdr part-bars))
 914                (bar-no first-bar-number (1+ bar-no)))
 915               ((null (car part-bars)))
 916             (apply #'make-xml-bars bar-no part (mapcar #'car part-bars))))))))
 917
 918 ;;(defun make-xml-layer (layer)
 919 ;;  (let ((body (body layer)))
 920 ;;    (loop for bar in (bars body)
 921 ;;          for measurenum from 1
 922 ;;          do (make-xml-bar bar measurenum))))
 923
 924 (defun make-staff-hash (staves)
 925   (let ((new-staff-hash (make-hash-table :size (length staves))))
 926     (loop for staff in staves
 927        and i from 1
 928        do
 929          (multiple-value-bind (v p) (gethash staff new-staff-hash)
 930            (declare (ignore v))
 931            (unless p
 932              (setf (gethash staff new-staff-hash) i))))
 933     new-staff-hash))
 934
 935 (defun make-xml-bars (id layers &rest bars)
 936   (cxml:with-element "measure"
 937     (cxml:attribute "number" (write-to-string id))
 938
 939     ;; There are some things that can change mid-measure, mid-segment,
 940     ;; whatever, in mxml that can't change in gsharp (number of
 941     ;; staves, clef). Other things don't really have any meaning in
 942     ;; gsharp and so can't change: notably "divisions" and
 943     ;; "beats". These things will get written in the first measure of
 944     ;; the layer. Keysignatures CAN change in gsharp, but each staff
 945     ;; also has a keysignature assigned to it, so that will also go
 946     ;; into the first measure.
 947     ;;
 948     ;; This is sort of an abuse of the measure number, since it is
 949     ;; really intended for printed measure numbers that would get
 950     ;; printed on a score, and are intended to be arbitrary rather
 951     ;; than purely sequential, starting with 1. But since gsharp
 952     ;; doesn't really have measure numbers of this sort, the numbers
 953     ;; resulting from an export operation will always be sequential
 954     ;; and start from one.
 955     (if (eql 1 id)
 956         (cxml:with-element "attributes"
 957           (cxml:with-element "divisions"
 958             (cxml:text (write-to-string *mxml-divisions*)))
 959
 960           (let* ((staves (reduce #'union (mapcar #'staves layers)))
 961                  (melody-staves
 962                   (remove-if
 963                    #'(lambda (staff) (typep staff 'lyrics-staff)) staves))
 964                  (staves-length (length staves)))
 965
 966             ;; what i would consider a bug in musicxml 1.1: only one
 967             ;; key allowed per attribute element, despite the fact
 968             ;; that you can specify which staff the key goes on. This
 969             ;; is fixed in MusicXML 2.0.
 970             ;; TODO: put a bunch more attribute elements after this
 971             ;; one if the other staves have different key signatures.
 972             ;; N.B. These comments are largely based on the
 973             ;; parts/segments/layers issue. Should be a very rare issue
 974             ;; with the new code.
 975             (let ((staff (car melody-staves)))
 976               (cxml:with-element "key"
 977                 (alterations-to-fifths
 978                  (alterations (keysig staff)))))
 979
 980             (when (> staves-length 1)
 981               (cxml:with-element "staves"
 982                 (cxml:text (write-to-string staves-length))))
 983             (loop for staff in melody-staves
 984                for clef = (clef staff)
 985                ;; possibilities for MusicXML:
 986                ;; G, F, C, percussion, TAB, and none
 987                for clef-sign = (case (name clef)
 988                                  (:treble "G")
 989                                  (:treble8 "G")
 990                                  (:bass "F")
 991                                  (:c "C")
 992                                  (:percussion "percussion"))
 993                for clef-line = (1+ (/ (lineno clef) 2))
 994                for staff-num = (gethash staff *staff-hash*)
 995                do
 996                  (cxml:with-element "clef"
 997                    (when (> staves-length 1)
 998                      (cxml:attribute "number" (write-to-string staff-num)))
 999                    (cxml:with-element "sign"
1000                      (cxml:text clef-sign))
1001                    (cxml:with-element "line"
1002                      (cxml:text (write-to-string clef-line)))
1003                    (when (eq (name clef) :treble8)
1004                      (cxml:with-element "clef-octave-change"
1005                        (cxml:text "-1"))))))))
1006
1007     ;; process each bar, backing up only if there's a "next" bar
1008     (loop for voice from 1
1009        and bar in bars
1010        do (unless (null bar)
1011             (make-xml-bar bar (unless (= voice 1) voice))
1012          (unless (= voice (length bars))
1013            ;; TODO: if spaces are the first thing in the next bar,
1014            ;; don't output backwards followed by a forwards.
1015            (cxml:with-element "backup"
1016              (cxml:with-element "duration"
1017                   (cxml:text (write-to-string (bar-duration bar))))))))))
1018
1019 (defun bar-duration (bar)
1020   (loop for element in (elements bar)
1021         when (typep element 'rhythmic-element)
1022         sum (calculate-duration element)))
1023
1024 (defun make-xml-bar (bar voice)
1025   ;; and now do whatever elements are in there
1026   (loop for element in (elements bar)
1027      do (make-xml-element element voice)))
1028
1029 (defgeneric make-xml-element (gharp-element voice))
1030
1031 (defun rhythmic-element-type (element)
1032   (ecase (notehead element)
1033     (:long "long")
1034     (:breve "breve")
1035     (:whole "whole")
1036     (:half "half")
1037     (:filled
1038      (ecase (max (rbeams element) (lbeams element))
1039        (0 "quarter")
1040        (1 "eighth")
1041        (2 "16th")
1042        (3 "32nd")
1043        (4 "64th")
1044        (5 "128th")
1045        (6 "256th")))))
1046
1047 (defmethod make-xml-element ((rest rest) voice)
1048   (let ((duration (calculate-duration rest))
1049         (type (rhythmic-element-type rest))
1050         (dots (dots rest)))
1051     (cxml:with-element "note"
1052       (cxml:with-element "rest")
1053       (cxml:with-element "duration" (cxml:text (write-to-string duration)))
1054       (unless (null voice)
1055         (cxml:with-element "voice" (cxml:text (write-to-string voice))))
1056       (cxml:with-element "type" (cxml:text type))
1057       (loop repeat dots
1058          do (cxml:with-element "dot"))
1059       (when (> (hash-table-count *staff-hash*) 1)
1060         (cxml:with-element "staff"
1061           (cxml:text (write-to-string (gethash (staff rest) *staff-hash*))))))))
1062
1063 (defmethod make-xml-element ((cluster cluster) voice)
1064   ;; this maybe should get called earlier. or later. i don't know.
1065   (gsharp-measure::compute-final-accidentals (notes cluster))
1066   (let ((duration (calculate-duration cluster)))
1067     (loop for note in (notes cluster)
1068           for x from 0
1069           do (make-xml-note note (> x 0) duration voice cluster))
1070     (when (null (notes cluster))
1071       ;; it's an empty cluster, a "space"
1072       (cxml:with-element "forward"
1073         (cxml:text (write-to-string duration))))))
1074
1075 (defmethod make-xml-element ((lyric lyrics-element) voice)
1076   (let ((duration (calculate-duration lyric))
1077         (syllabic "single")
1078         (text (unicode-to-string (text lyric))))
1079     (cxml:with-element "note"
1080       (cxml:with-element "unpitched")
1081       (cxml:with-element "duration" (cxml:text (write-to-string duration)))
1082       (unless (null voice)
1083         (cxml:with-element "voice" (cxml:text (write-to-string voice))))
1084       ;; TODO: make this use the first melody staff above the lyrics staff
1085       (when (> (hash-table-count *staff-hash*) 1)
1086         (cxml:with-element "staff"
1087           (cxml:text (write-to-string (gethash (staff lyric) *staff-hash*)))))
1088       (cxml:with-element "lyric"
1089         (cxml:with-element "syllabic" (cxml:text syllabic))
1090         (cxml:with-element "text" (cxml:text text))))))
1091
1092
1093 (defmethod make-xml-element ((key-signature key-signature) voice)
1094   ;; TODO: right now this only does "normal" keysignatures, which is
1095   ;; fine because that's the only kind a user can create in gsharp.
1096   ;; also, i'm not sure how to deal w/ canceling.
1097   (declare (ignore voice))
1098   (cxml:with-element "attributes"
1099     (cxml:with-element "key"
1100       (alterations-to-fifths (alterations key-signature)))))
1101
1102 (defun alterations-to-fifths (alterations)
1103   (cxml:with-element "fifths"
1104     (let ((fifths 0))
1105       ;; the magic list on the next line is the order of fifths,
1106       ;; where C is 0, D is 1, etc.
1107       (dolist (index '(3 0 4 1 5 2 6))
1108         (let ((fifth (elt alterations index)))
1109           (case fifth
1110             (:sharp (incf fifths))
1111             (:flat (decf fifths)))))
1112       (cxml:text (write-to-string fifths)))))
1113
1114 (defun gshnote-to-xml (pitch)
1115   (let ((step (mod pitch 7)))
1116     (list (car (rassoc step *step-to-basenote*)) (/ (- pitch step) 7))))
1117
1118 (defun note-accidental (note)
1119   (ecase (final-accidental note)
1120     ((nil))
1121     (:sharp "sharp")
1122     (:natural "natural")
1123     (:flat "flat")
1124     (:double-sharp "double-sharp")
1125     (:sesquisharp "three-quarters-sharp")
1126     (:semisharp "quarter-sharp")
1127     (:semiflat "quarter-flat")
1128     (:sesquiflat "three-quarters-flat")
1129     (:double-flat "flat-flat")))
1130
1131 (defun note-alter (note)
1132   (ecase (accidentals note)
1133     (:sharp "1")
1134     (:natural nil)
1135     (:flat "-1")
1136     (:double-sharp "2")
1137     (:sesquisharp "1.5")
1138     (:semisharp "0.5")
1139     (:semiflat "-0.5")
1140     (:sesquiflat "-1.5")
1141     (:double-flat "-2")))
1142
1143 (defun note-notations-p (note cluster)
1144   (or (tie-left note)
1145       (tie-right note)
1146       (note-articulations-p note cluster)))
1147
1148 (defun note-articulations-p (note cluster)
1149   (let ((annotations (annotations cluster)))
1150     (or (member :staccato annotations)
1151         (member :tenuto annotations))))
1152
1153 (defun make-xml-note (note in-chord duration voice cluster)
1154   (let ((type (rhythmic-element-type cluster))
1155         (dots (dots cluster))
1156         (pitch (gshnote-to-xml (pitch note)))
1157         (accidental (note-accidental note))
1158         (alter (note-alter note)))
1159     (cxml:with-element "note"
1160       (when in-chord
1161         (cxml:with-element "chord"))
1162       (cxml:with-element "pitch"
1163         (cxml:with-element "step" (cxml:text (car pitch)))
1164         (when alter
1165           (cxml:with-element "alter" (cxml:text alter)))
1166         (cxml:with-element "octave" (cxml:text (write-to-string (cadr pitch)))))
1167       (cxml:with-element "duration" (cxml:text (write-to-string duration)))
1168       (unless (null voice)
1169         (cxml:with-element "voice" (cxml:text (write-to-string voice))))
1170       (cxml:with-element "type" (cxml:text type))
1171       (loop repeat dots
1172            do (cxml:with-element "dot"))
1173       (when accidental
1174         (cxml:with-element "accidental" (cxml:text accidental)))
1175       (unless (eq (final-stem-direction (cluster note)) :auto)
1176         (cxml:with-element "stem"
1177           (cxml:text (string-downcase
1178                       (string (final-stem-direction (cluster note)))))))
1179       (when (> (hash-table-count *staff-hash*) 1)
1180         (cxml:with-element "staff"
1181           (cxml:text (write-to-string (gethash (staff note) *staff-hash*)))))
1182       (when (note-notations-p note cluster)
1183         (cxml:with-element "notations"
1184           (when (tie-left note)
1185             (cxml:with-element "tied" (cxml:attribute "type" "stop")))
1186           (when (tie-right note)
1187             (cxml:with-element "tied" (cxml:attribute "type" "start")))
1188           (when (note-articulations-p note cluster)
1189             (cxml:with-element "articulations"
1190               (when (member :staccato (annotations cluster))
1191                 (cxml:with-element "staccato"))
1192               (when (member :tenuto (annotations cluster))
1193                 (cxml:with-element "tenuto")))))))))