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