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