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