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