+(define-class <xml-node> ()
+ (name #:init-value "" #:accessor node-name #:init-keyword #:name)
+ (value #:init-value "" #:accessor node-value #:init-keyword #:value)
+ (attributes #:init-value '()
+ #:accessor node-attributes
+ #:init-keyword #:attributes)
+ (children #:init-value '()
+ #:accessor node-children
+ #:init-keyword #:children))
+
+(define node-names
+ '((NoteEvent . note)
+ (SequentialMusic . measure)
+
+ ;;ugh
+ (pitch . pitch)
+ (duration . duration)
+ (octave . octave)
+ (step . step)))
+
+(define (musicxml-node->string node)
+ (let ((xml-name (assoc-get (node-name node) node-names #f)))
+ (string-append
+ (if xml-name (open-tag xml-name '() '()) "")
+ (if (equal? (node-value node) "")
+ (string-append
+ (if xml-name "\n" "")
+ (string-concatenate (map musicxml-node->string (node-children node))))
+ (node-value node))
+ (if xml-name (close-tag xml-name) "")
+ (if xml-name "\n" ""))))
+
+(define (xml-node->string node)
+ (string-append
+ "\n"
+ (open-tag (node-name node) (node-attributes node) '())
+ (if (equal? (node-value node) "")
+ (string-concatenate (map xml-node->string (node-children node)))
+ (node-value node))
+ "\n"
+ (close-tag (node-name node))))
+
+(define (musicxml-duration->xml-node d)
+ (make <xml-node>
+ #:name 'duration
+ #:value (number->string (ash 1 (ly:duration-log d)))))
+
+(define (duration->xml-node d)
+ (make <xml-node>
+ #:name 'duration
+ ;; #:value (number->string (ash 1 (ly:duration-log d)))))
+ #:attributes `((log . ,(ly:duration-log d))
+ (dots . ,(ly:duration-dot-count d))
+ (numer . ,(car (ly:duration-factor d)))
+ (denom . ,(cdr (ly:duration-factor d))))))
+
+(define (pitch->xml-node p)
+ (make <xml-node>
+ #:name 'pitch
+ #:attributes `((octave . ,(ly:pitch-octave p))
+ (notename . ,(ly:pitch-notename p))
+ (alteration . ,(ly:pitch-alteration p)))))
+
+(define (music->xml-node music)
+ (let* ((name (ly:music-property music 'name))
+ (e (ly:music-property music 'element))
+ (es (ly:music-property music 'elements))
+ (mprops (ly:music-mutable-properties music))
+ (d (ly:music-property music 'duration))
+ (p (ly:music-property music 'pitch))
+ (ignore-props '(origin elements duration pitch element)))
+
+ (make <xml-node>
+ #:name name
+ #:children
+ (apply
+ append
+ (if (ly:pitch? p) (list (pitch->xml-node p)) '())
+ (if (ly:duration? d) (list (duration->xml-node d)) '())
+ (if (pair? es) (map music->xml-node es) '())
+ (if (ly:music? e) (list (music->xml-node e)) '())
+ '()))))
+
+(define (dtd-header)
+ (string-append
+ "<?xml version=\"1.0\"?>
+<!DOCTYPE MUSIC ["
+ preliminary-dtd
+ "
+]>
+
+"))
+
+
+;; as computed from input/trip.ly, by
+;; http://www.pault.com/pault/dtdgenerator/
+
+;; must recompute with larger, more serious piece, and probably
+;; manually add stuff
+(define preliminary-dtd
+ "
+<!ELEMENT duration EMPTY >
+<!ATTLIST duration denom ( 1 | 3 | 5 ) #REQUIRED >
+<!ATTLIST duration dots ( 0 | 1 ) #REQUIRED >
+<!ATTLIST duration log ( 0 | 1 | 2 | 3 | 4 ) #REQUIRED >
+<!ATTLIST duration numer ( 1 | 4 ) #REQUIRED >
+
+<!ELEMENT music ( duration | music | pitch )* >
+<!ATTLIST music articulation-type ( lheel | ltoe | marcato | rheel | rtoe | staccato | tenuto ) #IMPLIED >
+<!ATTLIST music change-to-id NMTOKEN #IMPLIED >
+<!ATTLIST music change-to-type NMTOKEN #IMPLIED >
+<!ATTLIST music context-id CDATA #IMPLIED >
+<!ATTLIST music context-type ( PianoStaff | Score | Staff | Timing | Voice ) #IMPLIED >
+<!ATTLIST music denominator NMTOKEN #IMPLIED >
+<!ATTLIST music direction ( 0 | 1 ) #IMPLIED >
+<!ATTLIST music force-accidental CDATA #IMPLIED >
+<!ATTLIST music grob-property NMTOKEN #IMPLIED >
+<!ATTLIST music grob-value CDATA #IMPLIED >
+<!ATTLIST music iterator-ctor CDATA #IMPLIED >
+<!ATTLIST music label NMTOKEN #IMPLIED >
+<!ATTLIST music last-pitch CDATA #IMPLIED >
+<!ATTLIST music numerator NMTOKEN #IMPLIED >
+<!ATTLIST music penalty NMTOKEN #IMPLIED >
+<!ATTLIST music pitch-alist CDATA #IMPLIED >
+<!ATTLIST music pop-first CDATA #IMPLIED >
+<!ATTLIST music repeat-count NMTOKEN #IMPLIED >
+<!ATTLIST music span-direction ( -1 | 1 ) #IMPLIED >
+<!ATTLIST music span-type NMTOKEN #IMPLIED >
+<!ATTLIST music symbol NMTOKEN #IMPLIED >
+<!ATTLIST music text NMTOKEN #IMPLIED >
+<!ATTLIST music text-type NMTOKEN #IMPLIED >
+<!ATTLIST music type NMTOKEN #REQUIRED >
+<!ATTLIST music value CDATA #IMPLIED >
+
+<!ELEMENT pitch EMPTY >
+<!ATTLIST pitch alteration ( 0 | 1 ) #REQUIRED >
+<!ATTLIST pitch notename ( 0 | 1 | 2 | 3 | 4 | 5 | 6 ) #REQUIRED >
+<!ATTLIST pitch octave ( -1 | -2 | 0 | 1 ) #REQUIRED >")
+