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