scm/define-music-display-methods.scm

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