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