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