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