1 (use-modules (ice-9 regex))
5 Todo: this is a quick hack; it makes more sense to define a GOOPS
6 class of a documentnode (similar to how
7 ; the documentation is generated.)
9 That is much cleaner: building the document, and dumping it to output
17 "<?xml version=\"1.0\"?>
26 ;; as computed from input/trip.ly, by
27 ;; http://www.pault.com/pault/dtdgenerator/
29 ;; must recompute with larger, more serious piece, and probably
31 (define preliminary-dtd
33 <!ELEMENT duration EMPTY >
34 <!ATTLIST duration denom ( 1 | 3 | 5 ) #REQUIRED >
35 <!ATTLIST duration dots ( 0 | 1 ) #REQUIRED >
36 <!ATTLIST duration log ( 0 | 1 | 2 | 3 | 4 ) #REQUIRED >
37 <!ATTLIST duration numer ( 1 | 4 ) #REQUIRED >
39 <!ELEMENT music ( duration | music | pitch )* >
40 <!ATTLIST music articulation-type ( lheel | ltoe | marcato | rheel | rtoe | staccato | tenuto ) #IMPLIED >
41 <!ATTLIST music change-to-id NMTOKEN #IMPLIED >
42 <!ATTLIST music change-to-type NMTOKEN #IMPLIED >
43 <!ATTLIST music context-id CDATA #IMPLIED >
44 <!ATTLIST music context-type ( PianoStaff | Score | Staff | Timing | Voice ) #IMPLIED >
45 <!ATTLIST music denominator NMTOKEN #IMPLIED >
46 <!ATTLIST music direction ( 0 | 1 ) #IMPLIED >
47 <!ATTLIST music force-accidental CDATA #IMPLIED >
48 <!ATTLIST music grob-property NMTOKEN #IMPLIED >
49 <!ATTLIST music grob-value CDATA #IMPLIED >
50 <!ATTLIST music iterator-ctor CDATA #IMPLIED >
51 <!ATTLIST music label NMTOKEN #IMPLIED >
52 <!ATTLIST music last-pitch CDATA #IMPLIED >
53 <!ATTLIST music numerator NMTOKEN #IMPLIED >
54 <!ATTLIST music penalty NMTOKEN #IMPLIED >
55 <!ATTLIST music pitch-alist CDATA #IMPLIED >
56 <!ATTLIST music pop-first CDATA #IMPLIED >
57 <!ATTLIST music repeat-count NMTOKEN #IMPLIED >
58 <!ATTLIST music span-direction ( -1 | 1 ) #IMPLIED >
59 <!ATTLIST music span-type NMTOKEN #IMPLIED >
60 <!ATTLIST music symbol NMTOKEN #IMPLIED >
61 <!ATTLIST music text NMTOKEN #IMPLIED >
62 <!ATTLIST music text-type NMTOKEN #IMPLIED >
63 <!ATTLIST music type NMTOKEN #REQUIRED >
64 <!ATTLIST music value CDATA #IMPLIED >
66 <!ELEMENT pitch EMPTY >
67 <!ATTLIST pitch alteration ( 0 | 1 ) #REQUIRED >
68 <!ATTLIST pitch notename ( 0 | 1 | 2 | 3 | 4 | 5 | 6 ) #REQUIRED >
69 <!ATTLIST pitch octave ( -1 | -2 | 0 | 1 ) #REQUIRED >")
74 (define (dump-duration d port)
75 (display (open-tag 'duration
76 `((log . ,(duration-log d))
77 (dots . ,(duration-dot-count d))
78 (numer . ,(car (duration-factor d)))
79 (denom . ,(cdr (duration-factor d)))
82 (display (close-tag 'duration) port))
84 (define (dump-pitch p port)
85 (display (open-tag 'pitch
86 `((octave . ,(pitch-octave p))
87 (notename . ,(pitch-notename p))
88 (alteration . ,(pitch-alteration p))
91 (display (close-tag 'pitch) port))
97 (error "assertion failed")))
99 (define (re-sub re to string)
100 (regexp-substitute/global #f re string 'pre to 'post))
102 (define (re-sub-alist string alist)
103 (re-sub (caar alist) (cdar alist)
104 (if (pair? (cdr alist))
105 (re-sub-alist string (cdr alist))
108 (define (open-tag tag attrs exceptions)
109 (define (candidate? x)
110 (not (memq (car x) exceptions)))
112 (define (dump-attr sym-val)
124 (let ((s (call-with-output-string (lambda (port) (display val port)))))
125 (re-sub-alist s '(("\"" . """)
135 "<" (symbol->string tag)
137 (map dump-attr (filter-list candidate? attrs)))
142 (define (close-tag name)
143 (string-append "</" (symbol->string name) ">\n")
146 (define (music-to-xml-helper music port)
149 (name (ly-get-mus-property music 'name))
150 (e (ly-get-mus-property music 'element))
151 (es (ly-get-mus-property music 'elements))
152 (mprops (ly-get-mutable-properties music))
153 (p (ly-get-mus-property music 'pitch))
154 (d (ly-get-mus-property music 'duration))
155 (ignore-props '(origin elements duration pitch element))
158 (display (open-tag 'music (cons `(type . ,name) mprops) ignore-props)
161 (dump-duration d port))
166 (map (lambda (x) (music-to-xml-helper x port)) es)))
169 (music-to-xml-helper e port)))
170 (display (close-tag 'music) port)
174 (define-public (music-to-xml music port)
175 "Dump XML-ish stuff to PORT."
176 (display (dtd-header) port)
177 (display (open-tag 'music '((type . score)) '()) port)
178 (music-to-xml-helper music port)
179 (display (close-tag 'music) port))