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