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