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