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