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   (format #f "\\repeat ~a ~a ~a ~a"
 700           repeat-type
 701           (ly:music-property expr 'repeat-count)
 702           (music->lily-string (ly:music-property expr 'element) parser)
 703           (let ((alternatives (ly:music-property expr 'elements)))
 704             (if (null? alternatives)
 705                 ""
 706                 (format #f "\\alternative { ~{~a ~}}"
 707                         (map-in-order (lambda (music)
 708                                         (music->lily-string music parser))
 709                                       alternatives))))))
 710
 711 (define-display-method VoltaRepeatedMusic (expr parser)
 712   (repeat->lily-string expr "volta" parser))
 713
 714 (define-display-method UnfoldedRepeatedMusic (expr parser)
 715   (repeat->lily-string expr "unfold" parser))
 716
 717 (define-display-method PercentRepeatedMusic (expr parser)
 718   (repeat->lily-string expr "percent" parser))
 719
 720 (define-display-method TremoloRepeatedMusic (expr parser)
 721   (let* ((count (ly:music-property expr 'repeat-count))
 722          (dots (if (= 0 (modulo count 3)) 0 1))
 723          (shift (- (log2 (if (= 0 dots)
 724                              (/ (* count 2) 3)
 725                              count))))
 726          (element (ly:music-property expr 'element))
 727          (den-mult 1))
 728     (if (eqv? (ly:music-property element 'name) 'SequentialMusic)
 729         (begin
 730           (set! shift (1- shift))
 731           (set! den-mult (length (ly:music-property element 'elements)))))
 732     (music-map (lambda (m)
 733                  (let ((duration (ly:music-property m 'duration)))
 734                    (if (ly:duration? duration)
 735                        (let* ((dlog (ly:duration-log duration))
 736                               (ddots (ly:duration-dot-count duration))
 737                               (dfactor (ly:duration-factor duration))
 738                               (dnum (car dfactor))
 739                               (dden (cdr dfactor)))
 740                          (set! (ly:music-property m 'duration)
 741                                (ly:make-duration (- dlog shift)
 742                                                  ddots ;;(- ddots dots) ; ????
 743                                                  dnum
 744                                                  (/ dden den-mult))))))
 745                  m)
 746                element)
 747     (format #f "\\repeat tremolo ~a ~a"
 748             count
 749             (music->lily-string element parser))))
 750
 751 ;;;
 752 ;;; Contexts
 753 ;;;
 754
 755 (define-display-method ContextSpeccedMusic (expr parser)
 756   (let ((id    (ly:music-property expr 'context-id))
 757         (create-new (ly:music-property expr 'create-new))
 758         (music (ly:music-property expr 'element))
 759         (operations (ly:music-property expr 'property-operations))
 760         (ctype (ly:music-property expr 'context-type)))
 761     (format #f "~a ~a~a~a ~a"
 762             (if (and (not (null? create-new)) create-new)
 763                 "\\new"
 764                 "\\context")
 765             ctype
 766             (if (null? id)
 767                 ""
 768                 (format #f " = ~s" id))
 769             (if (null? operations)
 770                 ""
 771                 (format #f " \\with {~{~a~}~%~v_}"
 772                         (parameterize ((*indent* (+ (*indent*) 2)))
 773                           (map (lambda (op)
 774                                  (format #f "~%~v_\\~a ~s"
 775                                          (*indent*)
 776                                          (first op)
 777                                          (second op)))
 778                                operations))
 779                         (*indent*)))
 780             (parameterize ((*current-context* ctype))
 781               (music->lily-string music parser)))))
 782
 783 ;; special cases: \figures \lyrics \drums
 784 (define-extra-display-method ContextSpeccedMusic (expr parser)
 785   (with-music-match (expr (music 'ContextSpeccedMusic
 786                                  create-new #t
 787                                  property-operations ?op
 788                                  context-type ?context-type
 789                                  element ?sequence))
 790     (if (null? ?op)
 791         (parameterize ((*explicit-mode* #f))
 792           (case ?context-type
 793             ((FiguredBass)
 794              (format #f "\\figures ~a" (music->lily-string ?sequence parser)))
 795             ((Lyrics)
 796              (format #f "\\lyrics ~a" (music->lily-string ?sequence parser)))
 797             ((DrumStaff)
 798              (format #f "\\drums ~a" (music->lily-string ?sequence parser)))
 799             (else
 800              #f)))
 801         #f)))
 802
 803 ;;; Context properties
 804
 805 (define-extra-display-method ContextSpeccedMusic (expr parser)
 806   (let ((element (ly:music-property expr 'element))
 807         (property-tuning? (make-music-type-predicate 'PropertySet
 808                                                      'PropertyUnset
 809                                                      'OverrideProperty
 810                                                      'RevertProperty))
 811         (sequence? (make-music-type-predicate 'SequentialMusic)))
 812     (if (and (ly:music? element)
 813              (or (property-tuning? element)
 814                  (and (sequence? element)
 815                       (every property-tuning? (ly:music-property element 'elements)))))
 816         (parameterize ((*current-context* (ly:music-property expr 'context-type)))
 817           (music->lily-string element parser))
 818         #f)))
 819
 820 (define (property-value->lily-string arg parser)
 821   (cond ((ly:music? arg)
 822          (music->lily-string arg parser))
 823         ((string? arg)
 824          (format #f "#~s" arg))
 825         ((markup? arg)
 826          (markup->lily-string arg))
 827         (else
 828          (format #f "#~a" (scheme-expr->lily-string arg)))))
 829
 830 (define-display-method PropertySet (expr parser)
 831   (let ((property (ly:music-property expr 'symbol))
 832         (value (ly:music-property expr 'value))
 833         (once (ly:music-property expr 'once)))
 834     (format #f "~a\\set ~a~a = ~a~a"
 835             (if (and (not (null? once)))
 836                 "\\once "
 837                 "")
 838             (if (eqv? (*current-context*) 'Bottom)
 839                 ""
 840                 (format #f "~a . " (*current-context*)))
 841             property
 842             (property-value->lily-string value parser)
 843             (new-line->lily-string))))
 844
 845 (define-display-method PropertyUnset (expr parser)
 846   (format #f "\\unset ~a~a~a"
 847           (if (eqv? (*current-context*) 'Bottom)
 848               ""
 849               (format #f "~a . " (*current-context*)))
 850           (ly:music-property expr 'symbol)
 851           (new-line->lily-string)))
 852
 853 ;;; Layout properties
 854
 855 (define-display-method OverrideProperty (expr parser)
 856   (let* ((symbol          (ly:music-property expr 'symbol))
 857          (properties   (ly:music-property expr 'grob-property-path
 858                                              (list (ly:music-property expr 'grob-property))))
 859          (value   (ly:music-property expr 'grob-value))
 860          (once    (ly:music-property expr 'once)))
 861
 862     (format #f "~a\\override ~a~a #'~a = ~a~a"
 863             (if (or (null? once)
 864                     (not once))
 865                 ""
 866                 "\\once ")
 867             (if (eqv? (*current-context*) 'Bottom)
 868                 ""
 869                 (format #f "~a . " (*current-context*)))
 870             symbol
 871             (if (null? (cdr properties))
 872                 (car properties)
 873                 properties)
 874             (property-value->lily-string value parser)
 875             (new-line->lily-string))))
 876
 877 (define-display-method RevertProperty (expr parser)
 878   (let* ((symbol (ly:music-property expr 'symbol))
 879          (properties (ly:music-property expr 'grob-property-path
 880                                              (list (ly:music-property expr 'grob-property)))))
 881     (format #f "\\revert ~a~a #'~a~a"
 882             (if (eqv? (*current-context*) 'Bottom)
 883                 ""
 884                 (format #f "~a . " (*current-context*)))
 885             symbol
 886             (if (null? (cdr properties))
 887                 (car properties)
 888                 properties)
 889             (new-line->lily-string))))
 890
 891 (define-display-method TimeSignatureMusic (expr parser)
 892   (let* ((num (ly:music-property expr 'numerator))
 893          (den (ly:music-property expr 'denominator))
 894          (structure (ly:music-property expr 'beat-structure)))
 895     (if (null? structure)
 896         (format #f
 897                 "\\time ~a/~a~a"
 898                 num den
 899                 (new-line->lily-string))
 900         (format #f
 901                 "\\time #'~a ~a/~a~a"
 902                 structure num den
 903                 (new-line->lily-string)))))
 904
 905 ;;; \melisma and \melismaEnd
 906 (define-extra-display-method ContextSpeccedMusic (expr parser)
 907   "If expr is a melisma, return \"\\melisma\", otherwise, return #f."
 908   (with-music-match (expr (music 'ContextSpeccedMusic
 909                                  element (music 'PropertySet
 910                                                 value #t
 911                                                 symbol 'melismaBusy)))
 912     "\\melisma"))
 913
 914 (define-extra-display-method ContextSpeccedMusic (expr parser)
 915   "If expr is a melisma end, return \"\\melismaEnd\", otherwise, return #f."
 916   (with-music-match (expr (music 'ContextSpeccedMusic
 917                                  element (music 'PropertyUnset
 918                                                 symbol 'melismaBusy)))
 919     "\\melismaEnd"))
 920
 921 ;;; \tempo
 922 (define-extra-display-method SequentialMusic (expr parser)
 923   (with-music-match (expr (music 'SequentialMusic
 924                                  elements ((music 'TempoChangeEvent
 925                                                   text ?text
 926                                                   tempo-unit ?unit
 927                                                   metronome-count ?count)
 928                                            (music 'ContextSpeccedMusic
 929                                                   element (music 'PropertySet
 930                                                                  symbol 'tempoWholesPerMinute)))))
 931     (format #f "\\tempo ~{~a~a~}~a = ~a~a"
 932             (if (markup? ?text)
 933                 (list (markup->lily-string ?text) " ")
 934                 '())
 935             (duration->lily-string ?unit #:force-duration #t)
 936             (if (pair? ?count)
 937                 (format #f "~a ~~ ~a" (car ?count) (cdr ?count))
 938                 ?count)
 939             (new-line->lily-string))))
 940
 941 (define-display-method TempoChangeEvent (expr parser)
 942   (let ((text (ly:music-property expr 'text)))
 943     (format #f "\\tempo ~a~a"
 944             (markup->lily-string text)
 945             (new-line->lily-string))))
 946
 947 ;;; \clef
 948 (define clef-name-alist #f)
 949 (define-public (memoize-clef-names clefs)
 950   "Initialize @code{clef-name-alist}, if not already set."
 951   (if (not clef-name-alist)
 952       (set! clef-name-alist
 953             (map (lambda (name+vals)
 954                    (cons (cdr name+vals)
 955                          (car name+vals)))
 956                  clefs))))
 957
 958 (define-extra-display-method ContextSpeccedMusic (expr parser)
 959   "If @var{expr} is a clef change, return \"\\clef ...\".
 960 Otherwise, return @code{#f}."
 961   (with-music-match (expr (music 'ContextSpeccedMusic
 962                                  context-type 'Staff
 963                                  element (music 'SequentialMusic
 964                                                 elements ((music 'PropertySet
 965                                                                  value ?clef-glyph
 966                                                                  symbol 'clefGlyph)
 967                                                           (music 'PropertySet
 968                                                                  symbol 'middleCClefPosition)
 969                                                           (music 'PropertySet
 970                                                                  value ?clef-position
 971                                                                  symbol 'clefPosition)
 972                                                           (music 'PropertySet
 973                                                                  value ?clef-octavation
 974                                                                  symbol 'clefOctavation)
 975                                                           (music 'ApplyContext
 976                                                                  procedure ly:set-middle-C!)))))
 977     (let ((clef-name (assoc-get (list ?clef-glyph ?clef-position 0)
 978                                 clef-name-alist)))
 979       (if clef-name
 980           (format #f "\\clef \"~a~{~a~a~}\"~a"
 981                   clef-name
 982                   (cond ((= 0 ?clef-octavation)
 983                          (list "" ""))
 984                         ((> ?clef-octavation 0)
 985                          (list "^" (1+ ?clef-octavation)))
 986                         (else
 987                          (list "_" (- 1 ?clef-octavation))))
 988                   (new-line->lily-string))
 989           #f))))
 990
 991 ;;; \bar
 992 (define-extra-display-method ContextSpeccedMusic (expr parser)
 993   "If `expr' is a bar, return \"\\bar ...\".
 994 Otherwise, return #f."
 995   (with-music-match (expr (music 'ContextSpeccedMusic
 996                                  context-type 'Timing
 997                                  element (music 'PropertySet
 998                                                 value ?bar-type
 999                                                 symbol 'whichBar)))
1000     (format #f "\\bar \"~a\"~a" ?bar-type (new-line->lily-string))))
1001
1002 ;;; \partial
1003 (define-extra-display-method ContextSpeccedMusic (expr parser)
1004   "If `expr' is a partial measure, return \"\\partial ...\".
1005 Otherwise, return #f."
1006   (with-music-match (expr (music
1007                            'ContextSpeccedMusic
1008                            element (music
1009                                     'ContextSpeccedMusic
1010                                     context-type 'Timing
1011                                     element (music
1012                                              'PartialSet
1013                                              partial-duration ?duration))))
1014
1015     (and ?duration
1016          (format #f "\\partial ~a"
1017                  (duration->lily-string ?duration #:force-duration #t)))))
1018
1019 ;;;
1020 ;;;
1021
1022 (define-display-method ApplyOutputEvent (applyoutput parser)
1023   (let ((proc (ly:music-property applyoutput 'procedure))
1024         (ctx  (ly:music-property applyoutput 'context-type)))
1025     (format #f "\\applyOutput #'~a #~a"
1026             ctx
1027             (or (procedure-name proc)
1028                 (with-output-to-string
1029                   (lambda ()
1030                     (pretty-print (procedure-source proc))))))))
1031
1032 (define-display-method ApplyContext (applycontext parser)
1033   (let ((proc (ly:music-property applycontext 'procedure)))
1034     (format #f "\\applyContext #~a"
1035             (or (procedure-name proc)
1036                 (with-output-to-string
1037                   (lambda ()
1038                     (pretty-print (procedure-source proc))))))))
1039
1040 ;;; \partcombine
1041 (define-display-method PartCombineMusic (expr parser)
1042   (format #f "\\partcombine ~{~a ~}"
1043           (map-in-order (lambda (music)
1044                           (music->lily-string music parser))
1045                         (ly:music-property expr 'elements))))
1046
1047 (define-extra-display-method PartCombineMusic (expr parser)
1048   (with-music-match (expr (music 'PartCombineMusic
1049                                  elements ((music 'UnrelativableMusic
1050                                                   element (music 'ContextSpeccedMusic
1051                                                                  context-id "one"
1052                                                                  context-type 'Voice
1053                                                                  element ?sequence1))
1054                                            (music 'UnrelativableMusic
1055                                                   element (music 'ContextSpeccedMusic
1056                                                                  context-id "two"
1057                                                                  context-type 'Voice
1058                                                                  element ?sequence2)))))
1059     (format #f "\\partcombine ~a~a~a"
1060             (music->lily-string ?sequence1 parser)
1061             (new-line->lily-string)
1062             (music->lily-string ?sequence2 parser))))
1063
1064 (define-display-method UnrelativableMusic (expr parser)
1065   (music->lily-string (ly:music-property expr 'element) parser))
1066
1067 ;;; Cue notes
1068 (define-display-method QuoteMusic (expr parser)
1069   (or (with-music-match (expr (music
1070                                'QuoteMusic
1071                                quoted-voice-direction ?quoted-voice-direction
1072                                quoted-music-name ?quoted-music-name
1073                                quoted-context-id "cue"
1074                                quoted-context-type 'Voice
1075                                element ?music))
1076         (format #f "\\cueDuring #~s #~a ~a"
1077                 ?quoted-music-name
1078                 ?quoted-voice-direction
1079                 (music->lily-string ?music parser)))
1080       (format #f "\\quoteDuring #~s ~a"
1081               (ly:music-property expr 'quoted-music-name)
1082               (music->lily-string (ly:music-property expr 'element) parser))))
1083
1084 ;;;
1085 ;;; Breaks
1086 ;;;
1087 (define-display-method LineBreakEvent (expr parser)
1088   (if (null? (ly:music-property expr 'break-permission))
1089       "\\noBreak"
1090       "\\break"))
1091
1092 (define-display-method PageBreakEvent (expr parser)
1093   (if (null? (ly:music-property expr 'break-permission))
1094       "\\noPageBreak"
1095       "\\pageBreak"))
1096
1097 (define-display-method PageTurnEvent (expr parser)
1098   (if (null? (ly:music-property expr 'break-permission))
1099       "\\noPageTurn"
1100       "\\pageTurn"))
1101
1102 (define-extra-display-method EventChord (expr parser)
1103   (with-music-match (expr (music 'EventChord
1104                             elements ((music 'LineBreakEvent
1105                                              break-permission 'force)
1106                                       (music 'PageBreakEvent
1107                                              break-permission 'force))))
1108     "\\pageBreak"))
1109
1110 (define-extra-display-method EventChord (expr parser)
1111   (with-music-match (expr (music 'EventChord
1112                             elements ((music 'LineBreakEvent
1113                                              break-permission 'force)
1114                                       (music 'PageBreakEvent
1115                                              break-permission 'force)
1116                                       (music 'PageTurnEvent
1117                                              break-permission 'force))))
1118     "\\pageTurn"))
1119
1120 ;;;
1121 ;;; Lyrics
1122 ;;;
1123
1124 ;;; \lyricsto
1125 (define-display-method LyricCombineMusic (expr parser)
1126   (format #f "\\lyricsto ~s ~a"
1127           (ly:music-property expr 'associated-context)
1128           (parameterize ((*explicit-mode* #f))
1129             (music->lily-string (ly:music-property expr 'element) parser))))
1130
1131 ;; \addlyrics
1132 (define-extra-display-method SimultaneousMusic (expr parser)
1133   (with-music-match (expr (music 'SimultaneousMusic
1134                                  elements ((music 'ContextSpeccedMusic
1135                                                   context-id ?id
1136                                                   context-type 'Voice
1137                                                   element ?note-sequence)
1138                                            (music 'ContextSpeccedMusic
1139                                                   context-type 'Lyrics
1140                                                   create-new #t
1141                                                   element (music 'LyricCombineMusic
1142                                                                  associated-context ?associated-id
1143                                                                  element ?lyric-sequence)))))
1144     (if (string=? ?id ?associated-id)
1145         (format #f "~a~a \\addlyrics ~a"
1146                 (music->lily-string ?note-sequence parser)
1147                 (new-line->lily-string)
1148                 (parameterize ((*explicit-mode* #f))
1149                   (music->lily-string ?lyric-sequence parser)))
1150         #f)))
1151
1152 ;; Silence internal event sent at end of each lyrics block
1153 (define-display-method CompletizeExtenderEvent (expr parser)
1154   "")