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