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