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