| blob | 4133fa6443b7ba95277d591be7ffa88ff65efd47 |
1 ;;; define-music-display-methods.scm -- data for displaying music
2 ;;; expressions using LilyPond notation.
3 ;;;
4 ;;; (c) 2005--2008 Nicolas Sceaux <nicolas.sceaux@free.fr>
5 ;;;
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;;
9 ;;; Display method implementation
10 ;;;
12 (define-module (scm display-lily))
14 ;;;
15 ;;; Scheme forms
16 ;;;
17 (define (scheme-expr->lily-string scm-arg)
18 (cond ((or (number? scm-arg)
19 (string? scm-arg))
20 (format #f "~s" scm-arg))
21 ((or (symbol? scm-arg)
22 (list? scm-arg))
23 (format #f "'~s" scm-arg))
24 ((procedure? scm-arg)
25 (format #f "~a"
26 (or (procedure-name scm-arg)
27 (with-output-to-string
28 (lambda ()
29 (pretty-print (procedure-source scm-arg)))))))
30 (else
31 (format #f "~a"
32 (with-output-to-string
33 (lambda ()
34 (display-scheme-music scm-arg)))))))
35 ;;;
36 ;;; Markups
37 ;;;
39 (define-public (markup->lily-string markup-expr)
40 "Return a string describing, in LilyPond syntax, the given markup expression."
41 (define (proc->command proc)
42 (let ((cmd-markup (symbol->string (procedure-name proc))))
43 (substring cmd-markup 0 (- (string-length cmd-markup)
44 (string-length "-markup")))))
45 (define (arg->string arg)
46 (cond ((string? arg)
47 (format #f "~s" arg))
48 ((markup? arg) ;; a markup
49 (markup->lily-string-aux arg))
50 ((and (pair? arg) (every markup? arg)) ;; a markup list
51 (format #f "{~{ ~a~}}" (map-in-order markup->lily-string-aux arg)))
52 (else ;; a scheme argument
53 (format #f "#~a" (scheme-expr->lily-string arg)))))
54 (define (markup->lily-string-aux expr)
55 (if (string? expr)
56 (format #f "~s" expr)
57 (let ((cmd (car expr))
58 (args (cdr expr)))
59 (if (eqv? cmd simple-markup) ;; a simple markup
60 (format #f "~s" (car args))
61 (format #f "\\~a~{ ~a~}"
62 (proc->command cmd)
63 (map-in-order arg->string args))))))
64 (cond ((string? markup-expr)
65 (format #f "~s" markup-expr))
66 ((eqv? (car markup-expr) simple-markup)
67 (format #f "~s" (second markup-expr)))
68 (else
69 (format #f "\\markup ~a"
70 (markup->lily-string-aux markup-expr)))))
72 ;;;
73 ;;; pitch names
74 ;;;
76 ;; It is a pity that there is no rassoc in Scheme.
77 (define* (rassoc item alist #:optional (test equal?))
78 (do ((alist alist (cdr alist))
79 (result #f result))
80 ((or result (null? alist)) result)
81 (if (and (car alist) (test item (cdar alist)))
82 (set! result (car alist)))))
84 (define (note-name->lily-string ly-pitch parser)
85 ;; here we define a custom pitch= function, since we do not want to
86 ;; test whether octaves are also equal. (otherwise, we would be using equal?)
87 (define (pitch= pitch1 pitch2)
88 (and (= (ly:pitch-notename pitch1) (ly:pitch-notename pitch2))
89 (= (ly:pitch-alteration pitch1) (ly:pitch-alteration pitch2))))
90 (let ((result (rassoc ly-pitch (ly:parser-lookup parser 'pitchnames) pitch=)))
91 (if result
92 (car result)
93 #f)))
95 (define (octave->lily-string pitch)
96 (let ((octave (ly:pitch-octave pitch)))
97 (cond ((>= octave 0)
98 (make-string (1+ octave) #\'))
99 ((< octave -1)
100 (make-string (1- (* -1 octave)) #\,))
101 (else ""))))
103 ;;;
104 ;;; durations
105 ;;;
106 (define* (duration->lily-string ly-duration #:key (prev-duration (*previous-duration*))
107 (force-duration (*force-duration*))
108 (time-factor-numerator (*time-factor-numerator*))
109 (time-factor-denominator (*time-factor-denominator*)))
110 (let ((log2 (ly:duration-log ly-duration))
111 (dots (ly:duration-dot-count ly-duration))
112 (num+den (ly:duration-factor ly-duration)))
113 (if (or force-duration (not prev-duration) (not (equal? ly-duration prev-duration)))
114 (string-append (case log2
115 ((-1) "\\breve")
116 ((-2) "\\longa")
117 ((-3) "\\maxima")
118 (else (number->string (expt 2 log2))))
119 (make-string dots #\.)
120 (let ((num? (not (or (= 1 (car num+den))
121 (and time-factor-numerator
122 (= (car num+den) time-factor-numerator)))))
123 (den? (not (or (= 1 (cdr num+den))
124 (and time-factor-denominator
125 (= (cdr num+den) time-factor-denominator))))))
126 (cond (den?
127 (format #f "*~a/~a" (car num+den) (cdr num+den)))
128 (num?
129 (format #f "*~a" (car num+den)))
130 (else ""))))
131 "")))
133 ;;;
134 ;;; post events
135 ;;;
137 (define post-event? (make-music-type-predicate
138 'StringNumberEvent
139 'ArticulationEvent
140 'FingeringEvent
141 'TextScriptEvent
142 'MultiMeasureTextEvent
143 'HyphenEvent
144 'ExtenderEvent
145 'BeamEvent
146 'SlurEvent
147 'TieEvent
148 'CrescendoEvent
149 'DecrescendoEvent
150 'PhrasingSlurEvent
151 'TremoloEvent
152 'SustainEvent
153 'SostenutoEvent
154 'TextSpanEvent
155 'HarmonicEvent
156 'BeamForbidEvent
157 'AbsoluteDynamicEvent
158 'TupletSpanEvent
159 'TrillSpanEvent
160 'GlissandoEvent
161 'ArpeggioEvent
162 'NoteGroupingEvent
163 'UnaCordaEvent))
165 (define* (event-direction->lily-string event #:optional (required #t))
166 (let ((direction (ly:music-property event 'direction)))
167 (cond ((or (not direction) (null? direction) (= CENTER direction))
168 (if required "-" ""))
169 ((= UP direction) "^")
170 ((= DOWN direction) "_")
171 (else ""))))
173 (define-macro (define-post-event-display-method type vars direction-required str)
174 `(define-display-method ,type ,vars
175 (format #f "~a~a"
176 (event-direction->lily-string ,(car vars) ,direction-required)
177 ,str)))
179 (define-macro (define-span-event-display-method type vars direction-required str-start str-stop)
180 `(define-display-method ,type ,vars
181 (format #f "~a~a"
182 (event-direction->lily-string ,(car vars) ,direction-required)
183 (if (= START (ly:music-property ,(car vars) 'span-direction))
184 ,str-start
185 ,str-stop))))
187 (define-display-method HyphenEvent (event parser)
188 " --")
189 (define-display-method ExtenderEvent (event parser)
190 " __")
191 (define-display-method TieEvent (event parser)
192 " ~")
193 (define-display-method BeamForbidEvent (event parser)
194 "\\noBeam")
195 (define-display-method StringNumberEvent (event parser)
196 (format #f "\\~a" (ly:music-property event 'string-number)))
199 (define-display-method TremoloEvent (event parser)
200 (let ((tremolo-type (ly:music-property event 'tremolo-type)))
201 (format #f ":~a" (if (= 0 tremolo-type)
202 ""
203 tremolo-type))))
205 (define-post-event-display-method ArticulationEvent (event parser) #t
206 (let ((articulation (ly:music-property event 'articulation-type)))
207 (case (string->symbol articulation)
208 ((marcato) "^")
209 ((stopped) "+")
210 ((tenuto) "-")
211 ((staccatissimo) "|")
212 ((accent) ">")
213 ((staccato) ".")
214 ((portato) "_")
215 (else (format #f "\\~a" articulation)))))
217 (define-post-event-display-method FingeringEvent (event parser) #t
218 (ly:music-property event 'digit))
220 (define-post-event-display-method TextScriptEvent (event parser) #t
221 (markup->lily-string (ly:music-property event 'text)))
223 (define-post-event-display-method MultiMeasureTextEvent (event parser) #t
224 (markup->lily-string (ly:music-property event 'text)))
226 (define-post-event-display-method HarmonicEvent (event parser) #t "\\harmonic")
227 (define-post-event-display-method GlissandoEvent (event parser) #t "\\glissando")
228 (define-post-event-display-method ArpeggioEvent (event parser) #t "\\arpeggio")
229 (define-post-event-display-method AbsoluteDynamicEvent (event parser) #f
230 (format #f "\\~a" (ly:music-property event 'text)))
232 (define-span-event-display-method BeamEvent (event parser) #f "[" "]")
233 (define-span-event-display-method SlurEvent (event parser) #f "(" ")")
234 (define-span-event-display-method CrescendoEvent (event parser) #f "\\<" "\\!")
235 (define-span-event-display-method DecrescendoEvent (event parser) #f "\\>" "\\!")
236 (define-span-event-display-method PhrasingSlurEvent (event parser) #f "\\(" "\\)")
237 (define-span-event-display-method SustainEvent (event parser) #f "\\sustainOn" "\\sustainOff")
238 (define-span-event-display-method SostenutoEvent (event parser) #f "\\sostenutoOn" "\\sostenutoOff")
239 (define-span-event-display-method TextSpanEvent (event parser) #f "\\startTextSpan" "\\stopTextSpan")
240 (define-span-event-display-method TrillSpanEvent (event parser) #f "\\startTrillSpan" "\\stopTrillSpan")
241 (define-span-event-display-method StaffSpanEvent (event parser) #f "\\startStaff" "\\stopStaff")
242 (define-span-event-display-method NoteGroupingEvent (event parser) #f "\\startGroup" "\\stopGroup")
243 (define-span-event-display-method UnaCordaEvent (event parser) #f "\\unaCorda" "\\treCorde")
245 ;;;
246 ;;; Graces
247 ;;;
249 (define-display-method GraceMusic (expr parser)
250 (format #f "\\grace ~a"
251 (music->lily-string (ly:music-property expr 'element) parser)))
253 ;; \acciaccatura \appoggiatura \grace
254 ;; TODO: it would be better to compare ?start and ?stop
255 ;; with startAppoggiaturaMusic and stopAppoggiaturaMusic,
256 ;; using a custom music equality predicate.
257 (define-extra-display-method GraceMusic (expr parser)
258 "Display method for appoggiatura."
259 (with-music-match (expr (music
260 'GraceMusic
261 element (music
262 'SequentialMusic
263 elements (?start
264 ?music
265 ?stop))))
266 ;; we check whether ?start and ?stop look like
267 ;; startAppoggiaturaMusic stopAppoggiaturaMusic
268 (and (with-music-match (?start (music
269 'SequentialMusic
270 elements ((music
271 'EventChord
272 elements ((music
273 'SkipEvent
274 duration (ly:make-duration 0 0 0 1))
275 (music
276 'SlurEvent
277 span-direction START))))))
278 #t)
279 (with-music-match (?stop (music
280 'SequentialMusic
281 elements ((music
282 'EventChord
283 elements ((music
284 'SkipEvent
285 duration (ly:make-duration 0 0 0 1))
286 (music
287 'SlurEvent
288 span-direction STOP))))))
289 (format #f "\\appoggiatura ~a" (music->lily-string ?music parser))))))
292 (define-extra-display-method GraceMusic (expr parser)
293 "Display method for acciaccatura."
294 (with-music-match (expr (music
295 'GraceMusic
296 element (music
297 'SequentialMusic
298 elements (?start
299 ?music
300 ?stop))))
301 ;; we check whether ?start and ?stop look like
302 ;; startAcciaccaturaMusic stopAcciaccaturaMusic
303 (and (with-music-match (?start (music
304 'SequentialMusic
305 elements ((music
306 'EventChord
307 elements ((music
308 'SkipEvent
309 duration (ly:make-duration 0 0 0 1))
310 (music
311 'SlurEvent
312 span-direction START)))
313 (music
314 'ContextSpeccedMusic
315 element (music
316 'OverrideProperty
317 grob-property-path '(stroke-style)
318 grob-value "grace"
319 symbol 'Stem)))))
320 #t)
321 (with-music-match (?stop (music
322 'SequentialMusic
323 elements ((music
324 'ContextSpeccedMusic
325 element (music
326 'RevertProperty
327 grob-property-path '(stroke-style)
328 symbol 'Stem))
329 (music
330 'EventChord
331 elements ((music
332 'SkipEvent
333 duration (ly:make-duration 0 0 0 1))
334 (music
335 'SlurEvent
336 span-direction STOP))))))
337 (format #f "\\acciaccatura ~a" (music->lily-string ?music parser))))))
339 (define-extra-display-method GraceMusic (expr parser)
340 "Display method for grace."
341 (with-music-match (expr (music
342 'GraceMusic
343 element (music
344 'SequentialMusic
345 elements (?start
346 ?music
347 ?stop))))
348 ;; we check whether ?start and ?stop look like
349 ;; startGraceMusic stopGraceMusic
350 (and (null? (ly:music-property ?start 'elements))
351 (null? (ly:music-property ?stop 'elements))
352 (format #f "\\grace ~a" (music->lily-string ?music parser)))))
354 ;;;
355 ;;; Music sequences
356 ;;;
358 (define-display-method SequentialMusic (seq parser)
359 (let ((force-line-break (and (*force-line-break*)
360 ;; hm
361 (> (length (ly:music-property seq 'elements))
362 (*max-element-number-before-break*))))
363 (elements (ly:music-property seq 'elements))
364 (chord? (make-music-type-predicate 'EventChord))
365 (cluster? (make-music-type-predicate 'ClusterNoteEvent))
366 (note? (make-music-type-predicate 'NoteEvent)))
367 (format #f "~a~a{~v%~v_~{~a ~}~v%~v_}"
368 (if (any (lambda (e)
369 (and (chord? e)
370 (any cluster? (ly:music-property e 'elements))))
371 elements)
372 "\\makeClusters "
373 "")
374 (if (*explicit-mode*)
375 ;; if the sequence contains EventChord which contains figures ==> figuremode
376 ;; if the sequence contains EventChord which contains lyrics ==> lyricmode
377 ;; if the sequence contains EventChord which contains drum notes ==> drummode
378 (cond ((any (lambda (chord)
379 (any (make-music-type-predicate 'BassFigureEvent)
380 (ly:music-property chord 'elements)))
381 (filter chord? elements))
382 "\\figuremode ")
383 ((any (lambda (chord)
384 (any (make-music-type-predicate 'LyricEvent)
385 (ly:music-property chord 'elements)))
386 (filter chord? elements))
387 "\\lyricmode ")
388 ((any (lambda (chord)
389 (any (lambda (event)
390 (and (note? event)
391 (not (null? (ly:music-property event 'drum-type)))))
392 (ly:music-property chord 'elements)))
393 (filter chord? elements))
394 "\\drummode ")
395 (else ;; TODO: other modes?
396 ""))
397 "")
398 (if force-line-break 1 0)
399 (if force-line-break (+ 2 (*indent*)) 1)
400 (parameterize ((*indent* (+ 2 (*indent*))))
401 (map-in-order (lambda (music)
402 (music->lily-string music parser))
403 elements))
404 (if force-line-break 1 0)
405 (if force-line-break (*indent*) 0))))
407 (define-display-method SimultaneousMusic (sim parser)
408 (parameterize ((*indent* (+ 3 (*indent*))))
409 (format #f "<< ~{~a ~}>>"
410 (map-in-order (lambda (music)
411 (music->lily-string music parser))
412 (ly:music-property sim 'elements)))))
414 (define-extra-display-method SimultaneousMusic (expr parser)
415 "If `sim' is an \afterGrace expression, return \"\\afterGrace ...\".
416 Otherwise, return #f."
417 ;; TODO: do something with afterGraceFraction?
418 (with-music-match (expr (music 'SimultaneousMusic
419 elements (?before-grace
420 (music 'SequentialMusic
421 elements ((music 'SkipMusic)
422 (music 'GraceMusic
423 element ?grace))))))
424 (format #f "\\afterGrace ~a ~a"
425 (music->lily-string ?before-grace parser)
426 (music->lily-string ?grace parser))))
428 ;;;
429 ;;; Chords
430 ;;;
432 (define-display-method EventChord (chord parser)
433 ;; event_chord : simple_element post_events
434 ;; | command_element
435 ;; | note_chord_element
437 ;; TODO : tagged post_events
438 ;; post_events : ( post_event | tagged_post_event )*
439 ;; tagged_post_event: '-' \tag embedded_scm post_event
441 (let* ((elements (ly:music-property chord 'elements))
442 (simple-elements (filter (make-music-type-predicate
443 'NoteEvent 'ClusterNoteEvent 'RestEvent
444 'MultiMeasureRestEvent 'SkipEvent 'LyricEvent)
445 elements)))
446 (if ((make-music-type-predicate 'StaffSpanEvent 'BreathingEvent) (car elements))
447 ;; first, a special case: StaffSpanEvent (\startStaff, \stopStaff)
448 ;; and BreathingEvent (\breathe)
449 (music->lily-string (car elements) parser)
450 (if (and (not (null? simple-elements))
451 (null? (cdr simple-elements)))
452 ;; simple_element : note | figure | rest | mmrest | lyric_element | skip
453 (let* ((simple-element (car simple-elements))
454 (duration (ly:music-property simple-element 'duration))
455 (lily-string (format #f "~a~a~a~{~a ~}"
456 (music->lily-string simple-element parser)
457 (duration->lily-string duration)
458 (if (and ((make-music-type-predicate 'RestEvent) simple-element)
459 (ly:pitch? (ly:music-property simple-element 'pitch)))
460 "\\rest"
461 "")
462 (map-in-order (lambda (music)
463 (music->lily-string music parser))
464 (filter post-event? elements)))))
465 (*previous-duration* duration)
466 lily-string)
467 (let ((chord-elements (filter (make-music-type-predicate
468 'NoteEvent 'ClusterNoteEvent 'BassFigureEvent)
469 elements))
470 (post-events (filter post-event? elements)))
471 (if (not (null? chord-elements))
472 ;; note_chord_element : '<' (notepitch | drumpitch)* '>" duration post_events
473 (let ((lily-string (format #f "< ~{~a ~}>~a~{~a ~}"
474 (map-in-order (lambda (music)
475 (music->lily-string music parser))
476 chord-elements)
477 (duration->lily-string (ly:music-property (car chord-elements)
478 'duration))
479 (map-in-order (lambda (music)
480 (music->lily-string music parser))
481 post-events))))
482 (*previous-duration* (ly:music-property (car chord-elements) 'duration))
483 lily-string)
484 ;; command_element
485 (format #f "~{~a ~}" (map-in-order (lambda (music)
486 (music->lily-string music parser))
487 elements))))))))
489 (define-display-method MultiMeasureRestMusic (mmrest parser)
490 (let* ((dur (ly:music-property mmrest 'duration))
491 (ly (format #f "R~a~{~a ~}"
492 (duration->lily-string dur)
493 (map-in-order (lambda (music)
494 (music->lily-string music parser))
495 (ly:music-property mmrest 'articulations)))))
496 (*previous-duration* dur)
497 ly))
499 (define-display-method SkipMusic (skip parser)
500 (format #f "\\skip ~a" (duration->lily-string (ly:music-property skip 'duration) #:force-duration #t)))
502 ;;;
503 ;;; Notes, rests, skips...
504 ;;;
506 (define (simple-note->lily-string event parser)
507 (format #f "~a~a~a~a~{~a~}" ; pitchname octave !? octave-check articulations
508 (note-name->lily-string (ly:music-property event 'pitch) parser)
509 (octave->lily-string (ly:music-property event 'pitch))
510 (let ((forced (ly:music-property event 'force-accidental))
511 (cautionary (ly:music-property event 'cautionary)))
512 (cond ((and (not (null? forced))
513 forced
514 (not (null? cautionary))
515 cautionary)
516 "?")
517 ((and (not (null? forced)) forced) "!")
518 (else "")))
519 (let ((octave-check (ly:music-property event 'absolute-octave)))
520 (if (not (null? octave-check))
521 (format #f "=~a" (cond ((>= octave-check 0)
522 (make-string (1+ octave-check) #\'))
523 ((< octave-check -1)
524 (make-string (1- (* -1 octave-check)) #\,))
525 (else "")))
526 ""))
527 (map-in-order (lambda (event)
528 (music->lily-string event parser))
529 (ly:music-property event 'articulations))))
531 (define-display-method NoteEvent (note parser)
532 (cond ((not (null? (ly:music-property note 'pitch))) ;; note
533 (simple-note->lily-string note parser))
534 ((not (null? (ly:music-property note 'drum-type))) ;; drum
535 (format #f "~a" (ly:music-property note 'drum-type)))
536 (else ;; unknown?
537 "")))
539 (define-display-method ClusterNoteEvent (note parser)
540 (simple-note->lily-string note parser))
542 (define-display-method RestEvent (rest parser)
543 (if (not (null? (ly:music-property rest 'pitch)))
544 (simple-note->lily-string rest parser)
545 "r"))
547 (define-display-method MultiMeasureRestEvent (rest parser)
548 "R")
550 (define-display-method SkipEvent (rest parser)
551 "s")
553 (define-display-method MarkEvent (mark parser)
554 (let ((label (ly:music-property mark 'label)))
555 (if (null? label)
556 "\\mark \\default"
557 (format #f "\\mark ~a" (markup->lily-string label)))))
559 (define-display-method KeyChangeEvent (key parser)
560 (let ((pitch-alist (ly:music-property key 'pitch-alist))
561 (tonic (ly:music-property key 'tonic)))
562 (if (or (null? pitch-alist)
563 (null? tonic))
564 "\\key \\default"
565 (let ((c-pitch-alist (ly:transpose-key-alist pitch-alist
566 (ly:pitch-diff (ly:make-pitch 0 0 0) tonic))))
567 (format #f "\\key ~a \\~a~a"
568 (note-name->lily-string (ly:music-property key 'tonic) parser)
569 (any (lambda (mode)
570 (if (and parser
571 (equal? (ly:parser-lookup parser mode) c-pitch-alist))
572 (symbol->string mode)
573 #f))
574 '(major minor ionian locrian aeolian mixolydian lydian phrygian dorian))
575 (new-line->lily-string))))))
577 (define-display-method RelativeOctaveCheck (octave parser)
578 (let ((pitch (ly:music-property octave 'pitch)))
579 (format #f "\\octaveCheck ~a~a"
580 (note-name->lily-string pitch parser)
581 (octave->lily-string pitch))))
583 (define-display-method VoiceSeparator (sep parser)
584 "\\\\")
586 (define-display-method LigatureEvent (ligature parser)
587 (if (= START (ly:music-property ligature 'span-direction))
588 "\\["
589 "\\]"))
591 (define-display-method BarCheck (check parser)
592 (format #f "|~a" (new-line->lily-string)))
594 (define-display-method PesOrFlexaEvent (expr parser)
595 "\\~")
597 (define-display-method BassFigureEvent (figure parser)
598 (let ((alteration (ly:music-property figure 'alteration))
599 (fig (ly:music-property figure 'figure))
600 (bracket-start (ly:music-property figure 'bracket-start))
601 (bracket-stop (ly:music-property figure 'bracket-stop)))
603 (format #f "~a~a~a~a"
604 (if (null? bracket-start) "" "[")
605 (cond ((null? fig) "_")
606 ((markup? fig) (second fig)) ;; fig: (<number-markup> "number")
607 (else fig))
608 (if (null? alteration)
609 ""
610 (cond
611 ((= alteration DOUBLE-FLAT) "--")
612 ((= alteration FLAT) "-")
613 ((= alteration NATURAL) "!")
614 ((= alteration SHARP) "+")
615 ((= alteration DOUBLE-SHARP) "++")
616 (else "")))
617 (if (null? bracket-stop) "" "]"))))
619 (define-display-method LyricEvent (lyric parser)
620 (let ((text (ly:music-property lyric 'text)))
621 (if (or (string? text)
622 (eqv? (first text) simple-markup))
623 ;; a string or a simple markup
624 (let ((string (if (string? text)
625 text
626 (second text))))
627 (if (string-match "(\"| |[0-9])" string)
628 ;; TODO check exactly in which cases double quotes should be used
629 (format #f "~s" string)
630 string))
631 (markup->lily-string text))))
633 (define-display-method BreathingEvent (event parser)
634 "\\breathe")
636 ;;;
637 ;;; Staff switches
638 ;;;
640 (define-display-method AutoChangeMusic (m parser)
641 (format #f "\\autochange ~a"
642 (music->lily-string (ly:music-property m 'element) parser)))
644 (define-display-method ContextChange (m parser)
645 (format #f "\\change ~a = \"~a\""
646 (ly:music-property m 'change-to-type)
647 (ly:music-property m 'change-to-id)))
649 ;;;
651 (define-display-method TimeScaledMusic (times parser)
652 (let* ((num (ly:music-property times 'numerator))
653 (den (ly:music-property times 'denominator))
654 (nd-gcd (gcd num den)))
655 (parameterize ((*force-line-break* #f)
656 (*time-factor-numerator* (/ num nd-gcd))
657 (*time-factor-denominator* (/ den nd-gcd)))
658 (format #f "\\times ~a/~a ~a"
659 num
660 den
661 (music->lily-string (ly:music-property times 'element) parser)))))
663 (define-display-method RelativeOctaveMusic (m parser)
664 (music->lily-string (ly:music-property m 'element) parser))
666 (define-display-method TransposedMusic (m parser)
667 (music->lily-string (ly:music-property m 'element) parser))
669 ;;;
670 ;;; Repeats
671 ;;;
673 (define (repeat->lily-string expr repeat-type parser)
674 (format #f "\\repeat ~a ~a ~a ~a"
675 repeat-type
676 (ly:music-property expr 'repeat-count)
677 (music->lily-string (ly:music-property expr 'element) parser)
678 (let ((alternatives (ly:music-property expr 'elements)))
679 (if (null? alternatives)
680 ""
681 (format #f "\\alternative { ~{~a ~}}"
682 (map-in-order (lambda (music)
683 (music->lily-string music parser))
684 alternatives))))))
686 (define-display-method VoltaRepeatedMusic (expr parser)
687 (repeat->lily-string expr "volta" parser))
689 (define-display-method UnfoldedRepeatedMusic (expr parser)
690 (repeat->lily-string expr "unfold" parser))
692 (define-display-method PercentRepeatedMusic (expr parser)
693 (repeat->lily-string expr "percent" parser))
695 (define-display-method TremoloRepeatedMusic (expr parser)
696 (let* ((count (ly:music-property expr 'repeat-count))
697 (dots (if (= 0 (modulo count 3)) 0 1))
698 (shift (- (log2 (if (= 0 dots)
699 (/ (* count 2) 3)
700 count))))
701 (element (ly:music-property expr 'element))
702 (den-mult 1))
703 (if (eqv? (ly:music-property element 'name) 'SequentialMusic)
704 (begin
705 (set! shift (1- shift))
706 (set! den-mult (length (ly:music-property element 'elements)))))
707 (music-map (lambda (m)
708 (let ((duration (ly:music-property m 'duration)))
709 (if (ly:duration? duration)
710 (let* ((dlog (ly:duration-log duration))
711 (ddots (ly:duration-dot-count duration))
712 (dfactor (ly:duration-factor duration))
713 (dnum (car dfactor))
714 (dden (cdr dfactor)))
715 (set! (ly:music-property m 'duration)
716 (ly:make-duration (- dlog shift)
717 ddots ;;(- ddots dots) ; ????
718 dnum
719 (/ dden den-mult))))))
720 m)
721 element)
722 (format #f "\\repeat tremolo ~a ~a"
723 count
724 (music->lily-string element parser))))
726 ;;;
727 ;;; Contexts
728 ;;;
730 (define-display-method ContextSpeccedMusic (expr parser)
731 (let ((id (ly:music-property expr 'context-id))
732 (create-new (ly:music-property expr 'create-new))
733 (music (ly:music-property expr 'element))
734 (operations (ly:music-property expr 'property-operations))
735 (ctype (ly:music-property expr 'context-type)))
736 (format #f "~a ~a~a~a ~a"
737 (if (and (not (null? create-new)) create-new)
738 "\\new"
739 "\\context")
740 ctype
741 (if (null? id)
742 ""
743 (format #f " = ~s" id))
744 (if (null? operations)
745 ""
746 (format #f " \\with {~{~a~}~%~v_}"
747 (parameterize ((*indent* (+ (*indent*) 2)))
748 (map (lambda (op)
749 (format #f "~%~v_\\~a ~s"
750 (*indent*)
751 (first op)
752 (second op)))
753 (reverse operations)))
754 (*indent*)))
755 (parameterize ((*current-context* ctype))
756 (music->lily-string music parser)))))
758 ;; special cases: \figures \lyrics \drums
759 (define-extra-display-method ContextSpeccedMusic (expr parser)
760 (with-music-match (expr (music 'ContextSpeccedMusic
761 create-new #t
762 property-operations ?op
763 context-type ?context-type
764 element ?sequence))
765 (if (null? ?op)
766 (parameterize ((*explicit-mode* #f))
767 (case ?context-type
768 ((FiguredBass)
769 (format #f "\\figures ~a" (music->lily-string ?sequence parser)))
770 ((Lyrics)
771 (format #f "\\lyrics ~a" (music->lily-string ?sequence parser)))
772 ((DrumStaff)
773 (format #f "\\drums ~a" (music->lily-string ?sequence parser)))
774 (else
775 #f)))
776 #f)))
778 ;;; Context properties
780 (define-extra-display-method ContextSpeccedMusic (expr parser)
781 (let ((element (ly:music-property expr 'element))
782 (property-tuning? (make-music-type-predicate 'PropertySet
783 'PropertyUnset
784 'OverrideProperty
785 'RevertProperty))
786 (sequence? (make-music-type-predicate 'SequentialMusic)))
787 (if (and (ly:music? element)
788 (or (property-tuning? element)
789 (and (sequence? element)
790 (every property-tuning? (ly:music-property element 'elements)))))
791 (parameterize ((*current-context* (ly:music-property expr 'context-type)))
792 (music->lily-string element parser))
793 #f)))
795 (define (property-value->lily-string arg parser)
796 (cond ((ly:music? arg)
797 (music->lily-string arg parser))
798 ((string? arg)
799 (format #f "#~s" arg))
800 ((markup? arg)
801 (markup->lily-string arg))
802 (else
803 (format #f "#~a" (scheme-expr->lily-string arg)))))
805 (define-display-method PropertySet (expr parser)
806 (let ((property (ly:music-property expr 'symbol))
807 (value (ly:music-property expr 'value))
808 (once (ly:music-property expr 'once)))
809 (format #f "~a\\set ~a~a = ~a~a"
810 (if (and (not (null? once)))
811 "\\once "
812 "")
813 (if (eqv? (*current-context*) 'Bottom)
814 ""
815 (format #f "~a . " (*current-context*)))
816 property
817 (property-value->lily-string value parser)
818 (new-line->lily-string))))
820 (define-display-method PropertyUnset (expr parser)
821 (format #f "\\unset ~a~a~a"
822 (if (eqv? (*current-context*) 'Bottom)
823 ""
824 (format #f "~a . " (*current-context*)))
825 (ly:music-property expr 'symbol)
826 (new-line->lily-string)))
828 ;;; Layout properties
830 (define-display-method OverrideProperty (expr parser)
831 (let* ((symbol (ly:music-property expr 'symbol))
832 (property-path (ly:music-property expr 'grob-property-path))
833 (properties (if (pair? property-path)
834 property-path
835 (list (ly:music-property expr 'grob-property))))
836 (value (ly:music-property expr 'grob-value))
837 (once (ly:music-property expr 'once)))
839 (format #f "~a\\override ~a~a #'~a = ~a~a"
840 (if (or (null? once)
841 (not once))
842 ""
843 "\\once ")
844 (if (eqv? (*current-context*) 'Bottom)
845 ""
846 (format #f "~a . " (*current-context*)))
847 symbol
848 (if (null? (cdr properties))
849 (car properties)
850 properties)
851 (property-value->lily-string value parser)
852 (new-line->lily-string))))
854 (define-display-method RevertProperty (expr parser)
855 (let ((symbol (ly:music-property expr 'symbol))
856 (properties (ly:music-property expr 'grob-property-path)))
857 (format #f "\\revert ~a~a #'~a~a"
858 (if (eqv? (*current-context*) 'Bottom)
859 ""
860 (format #f "~a . " (*current-context*)))
861 symbol
862 (if (null? (cdr properties))
863 (car properties)
864 properties)
865 (new-line->lily-string))))
867 ;;; \melisma and \melismaEnd
868 (define-extra-display-method ContextSpeccedMusic (expr parser)
869 "If expr is a melisma, return \"\\melisma\", otherwise, return #f."
870 (with-music-match (expr (music 'ContextSpeccedMusic
871 element (music 'PropertySet
872 value #t
873 symbol 'melismaBusy)))
874 "\\melisma"))
876 (define-extra-display-method ContextSpeccedMusic (expr parser)
877 "If expr is a melisma end, return \"\\melismaEnd\", otherwise, return #f."
878 (with-music-match (expr (music 'ContextSpeccedMusic
879 element (music 'PropertyUnset
880 symbol 'melismaBusy)))
881 "\\melismaEnd"))
883 ;;; \tempo
884 ;;; Check for all three different syntaxes of tempo:
885 ;;; \tempo string duration=note, \tempo duration=note and \tempo string
886 (define-extra-display-method ContextSpeccedMusic (expr parser)
887 "If expr is a tempo, return \"\\tempo x = nnn\", otherwise return #f."
888 (or (with-music-match (expr (music 'ContextSpeccedMusic
889 element (music 'SequentialMusic
890 elements ((music 'PropertySet
891 value ?unit-text
892 symbol 'tempoText)
893 (music 'PropertySet
894 symbol 'tempoWholesPerMinute)
895 (music 'PropertySet
896 value ?unit-duration
897 symbol 'tempoUnitDuration)
898 (music 'PropertySet
899 value ?unit-count
900 symbol 'tempoUnitCount)))))
901 (format #f "\\tempo ~a ~a = ~a"
902 (scheme-expr->lily-string ?unit-text)
903 (duration->lily-string ?unit-duration #:force-duration #t)
904 ?unit-count))
905 (with-music-match (expr (music 'ContextSpeccedMusic
906 element (music 'SequentialMusic
907 elements ((music 'PropertyUnset
908 symbol 'tempoText)
909 (music 'PropertySet
910 symbol 'tempoWholesPerMinute)
911 (music 'PropertySet
912 value ?unit-duration
913 symbol 'tempoUnitDuration)
914 (music 'PropertySet
915 value ?unit-count
916 symbol 'tempoUnitCount)))))
917 (format #f "\\tempo ~a = ~a"
918 (duration->lily-string ?unit-duration #:force-duration #t)
919 ?unit-count))
920 (with-music-match (expr (music 'ContextSpeccedMusic
921 element (music 'SequentialMusic
922 elements ((music 'PropertySet
923 value ?tempo-text
924 symbol 'tempoText)))))
925 (format #f "\\tempo ~a" (scheme-expr->lily-string ?tempo-text)))))
927 ;;; \clef
928 (define clef-name-alist #f)
929 (define-public (memoize-clef-names clefs)
930 "Initialize `clef-name-alist', if not already set."
931 (if (not clef-name-alist)
932 (set! clef-name-alist
933 (map (lambda (name+vals)
934 (cons (cdr name+vals)
935 (car name+vals)))
936 clefs))))
938 (define-extra-display-method ContextSpeccedMusic (expr parser)
939 "If `expr' is a clef change, return \"\\clef ...\"
940 Otherwise, return #f."
941 (with-music-match (expr (music 'ContextSpeccedMusic
942 context-type 'Staff
943 element (music 'SequentialMusic
944 elements ((music 'PropertySet
945 value ?clef-glyph
946 symbol 'clefGlyph)
947 (music 'PropertySet
948 symbol 'middleCClefPosition)
949 (music 'PropertySet
950 value ?clef-position
951 symbol 'clefPosition)
952 (music 'PropertySet
953 value ?clef-octavation
954 symbol 'clefOctavation)
955 (music 'ApplyContext
956 procedure ly:set-middle-C!)))))
957 (let ((clef-prop+name (assoc (list ?clef-glyph ?clef-position 0)
958 clef-name-alist)))
959 (if clef-prop+name
960 (format #f "\\clef \"~a~{~a~a~}\"~a"
961 (cdr clef-prop+name)
962 (cond ((= 0 ?clef-octavation)
963 (list "" ""))
964 ((> ?clef-octavation 0)
965 (list "^" (1+ ?clef-octavation)))
966 (else
967 (list "_" (- 1 ?clef-octavation))))
968 (new-line->lily-string))
969 #f))))
971 ;;; \time
972 (define-extra-display-method ContextSpeccedMusic (expr parser)
973 "If `expr' is a time signature set, return \"\\time ...\".
974 Otherwise, return #f."
975 (with-music-match (expr (music
976 'ContextSpeccedMusic
977 element (music
978 'ContextSpeccedMusic
979 context-type 'Timing
980 element (music
981 'SequentialMusic
982 elements ((music
983 'PropertySet
984 value ?num+den
985 symbol 'timeSignatureFraction)
986 (music
987 'PropertySet
988 symbol 'beatLength)
989 (music
990 'PropertySet
991 symbol 'measureLength)
992 (music
993 'PropertySet
994 value ?grouping
995 symbol 'beatGrouping))))))
996 (if (null? ?grouping)
997 (format #f "\\time ~a/~a~a" (car ?num+den) (cdr ?num+den) (new-line->lily-string))
998 (format #f "#(set-time-signature ~a ~a '~s)~a"
999 (car ?num+den) (cdr ?num+den) ?grouping (new-line->lily-string)))))
1001 ;;; \bar
1002 (define-extra-display-method ContextSpeccedMusic (expr parser)
1003 "If `expr' is a bar, return \"\\bar ...\".
1004 Otherwise, return #f."
1005 (with-music-match (expr (music 'ContextSpeccedMusic
1006 context-type 'Timing
1007 element (music 'PropertySet
1008 value ?bar-type
1009 symbol 'whichBar)))
1010 (format #f "\\bar \"~a\"~a" ?bar-type (new-line->lily-string))))
1012 ;;; \partial
1013 (define (duration->moment ly-duration)
1014 (let ((log2 (ly:duration-log ly-duration))
1015 (dots (ly:duration-dot-count ly-duration))
1016 (num+den (ly:duration-factor ly-duration)))
1017 (let* ((m (expt 2 (- log2)))
1018 (factor (/ (car num+den) (cdr num+den))))
1019 (/ (do ((i 0 (1+ i))
1020 (delta (/ m 2) (/ delta 2)))
1021 ((= i dots) m)
1022 (set! m (+ m delta)))
1023 factor))))
1024 (define moment-duration-alist (map (lambda (duration)
1025 (cons (duration->moment duration)
1026 duration))
1027 (append-map (lambda (log2)
1028 (map (lambda (dots)
1029 (ly:make-duration log2 dots 1 1))
1030 (list 0 1 2 3)))
1031 (list 0 1 2 3 4))))
1033 (define (moment->duration moment)
1034 (let ((result (assoc (- moment) moment-duration-alist =)))
1035 (and result
1036 (cdr result))))
1038 (define-extra-display-method ContextSpeccedMusic (expr parser)
1039 "If `expr' is a partial measure, return \"\\partial ...\".
1040 Otherwise, return #f."
1041 (with-music-match (expr (music
1042 'ContextSpeccedMusic
1043 element (music
1044 'ContextSpeccedMusic
1045 context-type 'Timing
1046 element (music
1047 'PropertySet
1048 value ?moment
1049 symbol 'measurePosition))))
1050 (let ((duration (moment->duration (/ (ly:moment-main-numerator ?moment)
1051 (ly:moment-main-denominator ?moment)))))
1052 (and duration (format #f "\\partial ~a" (duration->lily-string duration
1053 #:force-duration #t))))))
1055 ;;;
1056 ;;;
1058 (define-display-method ApplyOutputEvent (applyoutput parser)
1059 (let ((proc (ly:music-property applyoutput 'procedure))
1060 (ctx (ly:music-property applyoutput 'context-type)))
1061 (format #f "\\applyOutput #'~a #~a"
1062 ctx
1063 (or (procedure-name proc)
1064 (with-output-to-string
1065 (lambda ()
1066 (pretty-print (procedure-source proc))))))))
1068 (define-display-method ApplyContext (applycontext parser)
1069 (let ((proc (ly:music-property applycontext 'procedure)))
1070 (format #f "\\applyContext #~a"
1071 (or (procedure-name proc)
1072 (with-output-to-string
1073 (lambda ()
1074 (pretty-print (procedure-source proc))))))))
1076 ;;; \partcombine
1077 (define-display-method PartCombineMusic (expr parser)
1078 (format #f "\\partcombine ~{~a ~}"
1079 (map-in-order (lambda (music)
1080 (music->lily-string music parser))
1081 (ly:music-property expr 'elements))))
1083 (define-extra-display-method PartCombineMusic (expr parser)
1084 (with-music-match (expr (music 'PartCombineMusic
1085 elements ((music 'UnrelativableMusic
1086 element (music 'ContextSpeccedMusic
1087 context-id "one"
1088 context-type 'Voice
1089 element ?sequence1))
1090 (music 'UnrelativableMusic
1091 element (music 'ContextSpeccedMusic
1092 context-id "two"
1093 context-type 'Voice
1094 element ?sequence2)))))
1095 (format #f "\\partcombine ~a~a~a"
1096 (music->lily-string ?sequence1 parser)
1097 (new-line->lily-string)
1098 (music->lily-string ?sequence2 parser))))
1100 (define-display-method UnrelativableMusic (expr parser)
1101 (music->lily-string (ly:music-property expr 'element) parser))
1103 ;;; Cue notes
1104 (define-display-method QuoteMusic (expr parser)
1105 (or (with-music-match (expr (music
1106 'QuoteMusic
1107 quoted-voice-direction ?quoted-voice-direction
1108 quoted-music-name ?quoted-music-name
1109 quoted-context-id "cue"
1110 quoted-context-type 'Voice
1111 element ?music))
1112 (format #f "\\cueDuring #~s #~a ~a"
1113 ?quoted-music-name
1114 ?quoted-voice-direction
1115 (music->lily-string ?music parser)))
1116 (format #f "\\quoteDuring #~s ~a"
1117 (ly:music-property expr 'quoted-music-name)
1118 (music->lily-string (ly:music-property expr 'element) parser))))
1120 ;;;
1121 ;;; Breaks
1122 ;;;
1123 (define-display-method LineBreakEvent (expr parser)
1124 (if (null? (ly:music-property expr 'break-permission))
1125 "\\noBreak"
1126 "\\break"))
1128 (define-display-method PageBreakEvent (expr parser)
1129 (if (null? (ly:music-property expr 'break-permission))
1130 "\\noPageBreak"
1131 "\\pageBreak"))
1133 (define-display-method PageTurnEvent (expr parser)
1134 (if (null? (ly:music-property expr 'break-permission))
1135 "\\noPageTurn"
1136 "\\pageTurn"))
1138 (define-extra-display-method EventChord (expr parser)
1139 (with-music-match (expr (music 'EventChord
1140 elements ((music 'LineBreakEvent
1141 break-permission 'force)
1142 (music 'PageBreakEvent
1143 break-permission 'force))))
1144 "\\pageBreak"))
1146 (define-extra-display-method EventChord (expr parser)
1147 (with-music-match (expr (music 'EventChord
1148 elements ((music 'LineBreakEvent
1149 break-permission 'force)
1150 (music 'PageBreakEvent
1151 break-permission 'force)
1152 (music 'PageTurnEvent
1153 break-permission 'force))))
1154 "\\pageTurn"))
1156 ;;;
1157 ;;; Lyrics
1158 ;;;
1160 ;;; \lyricsto
1161 (define-display-method LyricCombineMusic (expr parser)
1162 (format #f "\\lyricsto ~s ~a"
1163 (ly:music-property expr 'associated-context)
1164 (parameterize ((*explicit-mode* #f))
1165 (music->lily-string (ly:music-property expr 'element) parser))))
1167 ;; \addlyrics
1168 (define-extra-display-method SimultaneousMusic (expr parser)
1169 (with-music-match (expr (music 'SimultaneousMusic
1170 elements ((music 'ContextSpeccedMusic
1171 context-id ?id
1172 context-type 'Voice
1173 element ?note-sequence)
1174 (music 'ContextSpeccedMusic
1175 context-type 'Lyrics
1176 create-new #t
1177 element (music 'LyricCombineMusic
1178 associated-context ?associated-id
1179 element ?lyric-sequence)))))
1180 (if (string=? ?id ?associated-id)
1181 (format #f "~a~a \\addlyrics ~a"
1182 (music->lily-string ?note-sequence parser)
1183 (new-line->lily-string)
1184 (parameterize ((*explicit-mode* #f))
1185 (music->lily-string ?lyric-sequence parser)))
1186 #f)))