scm/define-music-display-methods.scm

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