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