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