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