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 : command_element
 423   ;;               | note_chord_element
 424
 425   ;; TODO : tagged post_events
 426   ;; post_events : ( post_event | tagged_post_event )*
 427   ;; tagged_post_event: '-' \tag embedded_scm post_event
 428
 429   (let* ((elements (append (ly:music-property chord 'elements)
 430                            (ly:music-property chord 'articulations)))
 431          (chord-elements (filter (lambda (m)
 432                                     (music-is-of-type? m 'rhythmic-event))
 433                                  elements))
 434          (post-events (filter post-event? elements))
 435          (chord-repeat (ly:music-property chord 'duration)))
 436     (cond ((ly:duration? chord-repeat)
 437            (let ((duration (duration->lily-string chord-repeat #:remember #t)))
 438              (format #f "q~a~{~a~^ ~}"
 439                      duration
 440                      (map-in-order (lambda (music)
 441                                      (music->lily-string music parser))
 442                                    post-events))))
 443           ((pair? chord-elements)
 444            ;; note_chord_element : '<' (notepitch | drumpitch)* '>" duration post_events
 445            (let ((duration (duration->lily-string (ly:music-property
 446                                                    (car chord-elements)
 447                                                    'duration) #:remember #t)))
 448              ;; Format duration first so that it does not appear on chord elements
 449              (format #f "< ~{~a ~}>~a~{~a~^ ~}"
 450                      (map-in-order (lambda (music)
 451                                      (music->lily-string music parser))
 452                                    chord-elements)
 453                      duration
 454                      (map-in-order (lambda (music)
 455                                      (music->lily-string music parser))
 456                                    post-events))))
 457           (else
 458            ;; command_element
 459            (format #f "~{~a~^ ~}" (map-in-order (lambda (music)
 460                                                   (music->lily-string music parser))
 461                                                 elements))))))
 462
 463 (define-display-method MultiMeasureRestMusic (mmrest parser)
 464   (format #f "R~a~{~a~^ ~}"
 465           (duration->lily-string (ly:music-property mmrest 'duration)
 466                                  #:remember #t)
 467           (map-in-order (lambda (music)
 468                           (music->lily-string music parser))
 469                         (ly:music-property mmrest 'articulations))))
 470
 471 (define-display-method SkipMusic (skip parser)
 472   (format #f "\\skip ~a" (duration->lily-string (ly:music-property skip 'duration) #:force-duration #t)))
 473
 474 (define-display-method OttavaMusic (ottava parser)
 475   (format #f "\\ottava #~a" (ly:music-property ottava 'ottava-number)))
 476
 477 ;;;
 478 ;;; Notes, rests, skips...
 479 ;;;
 480
 481 (define (simple-note->lily-string event parser)
 482   (format #f "~a~a~a~a~a~a~{~a~}" ; pitchname octave !? octave-check duration optional_rest articulations
 483           (note-name->lily-string (ly:music-property event 'pitch) parser)
 484           (octave->lily-string (ly:music-property event 'pitch))
 485           (let ((forced (ly:music-property event 'force-accidental))
 486                 (cautionary (ly:music-property event 'cautionary)))
 487             (cond ((and (not (null? forced))
 488                         forced
 489                         (not (null? cautionary))
 490                         cautionary)
 491                    "?")
 492                   ((and (not (null? forced)) forced) "!")
 493                   (else "")))
 494           (let ((octave-check (ly:music-property event 'absolute-octave)))
 495             (if (not (null? octave-check))
 496                 (format #f "=~a" (cond ((>= octave-check 0)
 497                                         (make-string (1+ octave-check) #\'))
 498                                        ((< octave-check -1)
 499                                         (make-string (1- (* -1 octave-check)) #\,))
 500                                        (else "")))
 501                 ""))
 502           (duration->lily-string (ly:music-property event 'duration)
 503                                  #:remember #t)
 504           (if ((make-music-type-predicate 'RestEvent) event)
 505               "\\rest" "")
 506           (map-in-order (lambda (event)
 507                           (music->lily-string event parser))
 508                         (ly:music-property event 'articulations))))
 509
 510 (define-display-method NoteEvent (note parser)
 511   (cond ((not (null? (ly:music-property note 'pitch))) ;; note
 512          (simple-note->lily-string note parser))
 513         ((not (null? (ly:music-property note 'drum-type))) ;; drum
 514          (format #f "~a~a" (ly:music-property note 'drum-type)
 515                  (duration->lily-string (ly:music-property note 'duration)
 516                                         #:remember #t)))
 517         (else ;; unknown?
 518          "")))
 519
 520 (define-display-method ClusterNoteEvent (note parser)
 521   (simple-note->lily-string note parser))
 522
 523 (define-display-method RestEvent (rest parser)
 524   (if (not (null? (ly:music-property rest 'pitch)))
 525       (simple-note->lily-string rest parser)
 526       (string-append "r" (duration->lily-string (ly:music-property rest 'duration)
 527                                                 #:remember #t))))
 528
 529 (define-display-method MultiMeasureRestEvent (rest parser)
 530   (string-append "R" (duration->lily-string (ly:music-property rest 'duration)
 531                                             #:remember #t)))
 532
 533 (define-display-method SkipEvent (rest parser)
 534   (string-append "s" (duration->lily-string (ly:music-property rest 'duration)
 535                                             #:remember #t)))
 536
 537 (define-display-method RepeatedChord (chord parser)
 538   (music->lily-string (ly:music-property chord 'element) parser))
 539
 540 (define-display-method MarkEvent (mark parser)
 541   (let ((label (ly:music-property mark 'label)))
 542     (if (null? label)
 543         "\\mark \\default"
 544         (format #f "\\mark ~a" (markup->lily-string label)))))
 545
 546 (define-display-method KeyChangeEvent (key parser)
 547   (let ((pitch-alist (ly:music-property key 'pitch-alist))
 548         (tonic (ly:music-property key 'tonic)))
 549     (if (or (null? pitch-alist)
 550             (null? tonic))
 551         "\\key \\default"
 552         (let ((c-pitch-alist (ly:transpose-key-alist pitch-alist
 553                                                      (ly:pitch-diff (ly:make-pitch 0 0 0) tonic))))
 554           (format #f "\\key ~a \\~a~a"
 555                   (note-name->lily-string (ly:music-property key 'tonic) parser)
 556                   (any (lambda (mode)
 557                          (if (and parser
 558                                   (equal? (ly:parser-lookup parser mode) c-pitch-alist))
 559                              (symbol->string mode)
 560                              #f))
 561                        '(major minor ionian locrian aeolian mixolydian lydian phrygian dorian))
 562                   (new-line->lily-string))))))
 563
 564 (define-display-method RelativeOctaveCheck (octave parser)
 565   (let ((pitch (ly:music-property octave 'pitch)))
 566     (format #f "\\octaveCheck ~a~a"
 567             (note-name->lily-string pitch parser)
 568             (octave->lily-string pitch))))
 569
 570 (define-display-method VoiceSeparator (sep parser)
 571   "\\\\")
 572
 573 (define-display-method LigatureEvent (ligature parser)
 574   (if (= START (ly:music-property ligature 'span-direction))
 575       "\\["
 576       "\\]"))
 577
 578 (define-display-method BarCheck (check parser)
 579   (format #f "|~a" (new-line->lily-string)))
 580
 581 (define-display-method PesOrFlexaEvent (expr parser)
 582   "\\~")
 583
 584 (define-display-method BassFigureEvent (figure parser)
 585   (let ((alteration (ly:music-property figure 'alteration))
 586         (fig (ly:music-property figure 'figure))
 587         (bracket-start (ly:music-property figure 'bracket-start))
 588         (bracket-stop (ly:music-property figure 'bracket-stop)))
 589
 590     (format #f "~a~a~a~a"
 591             (if (null? bracket-start) "" "[")
 592             (cond ((null? fig) "_")
 593                   ((markup? fig) (second fig)) ;; fig: (<number-markup> "number")
 594                   (else fig))
 595             (if (null? alteration)
 596                 ""
 597                 (cond
 598                   ((= alteration DOUBLE-FLAT) "--")
 599                   ((= alteration FLAT) "-")
 600                   ((= alteration NATURAL) "!")
 601                   ((= alteration SHARP) "+")
 602                   ((= alteration DOUBLE-SHARP) "++")
 603                   (else "")))
 604             (if (null? bracket-stop) "" "]"))))
 605
 606 (define-display-method LyricEvent (lyric parser)
 607   (format "~a~{~a~^ ~}"
 608           (let ((text (ly:music-property lyric 'text)))
 609             (if (or (string? text)
 610                     (eqv? (first text) simple-markup))
 611                 ;; a string or a simple markup
 612                 (let ((string (if (string? text)
 613                                   text
 614                                   (second text))))
 615                   (if (string-match "(\"| |[0-9])" string)
 616                       ;; TODO check exactly in which cases double quotes should be used
 617                       (format #f "~s" string)
 618                       string))
 619                 (markup->lily-string text)))
 620           (map-in-order (lambda (m) (music->lily-string m parser))
 621                         (ly:music-property lyric 'articulations))))
 622
 623 (define-display-method BreathingEvent (event parser)
 624   "\\breathe")
 625
 626 ;;;
 627 ;;; Staff switches
 628 ;;;
 629
 630 (define-display-method AutoChangeMusic (m parser)
 631   (format #f "\\autochange ~a"
 632           (music->lily-string (ly:music-property m 'element) parser)))
 633
 634 (define-display-method ContextChange (m parser)
 635   (format #f "\\change ~a = \"~a\""
 636           (ly:music-property m 'change-to-type)
 637           (ly:music-property m 'change-to-id)))
 638
 639 ;;;
 640
 641 (define-display-method TimeScaledMusic (times parser)
 642   (let* ((num (ly:music-property times 'numerator))
 643          (den (ly:music-property times 'denominator))
 644          (nd-gcd (gcd num den)))
 645     (parameterize ((*force-line-break* #f)
 646                    (*time-factor-numerator* (/ num nd-gcd))
 647                    (*time-factor-denominator* (/ den nd-gcd)))
 648       (format #f "\\times ~a/~a ~a"
 649               num
 650               den
 651               (music->lily-string (ly:music-property times 'element) parser)))))
 652
 653 (define-display-method RelativeOctaveMusic (m parser)
 654   (music->lily-string (ly:music-property m 'element) parser))
 655
 656 (define-display-method TransposedMusic (m parser)
 657   (music->lily-string (ly:music-property m 'element) parser))
 658
 659 ;;;
 660 ;;; Repeats
 661 ;;;
 662
 663 (define-display-method AlternativeEvent (alternative parser) "")
 664
 665 (define (repeat->lily-string expr repeat-type parser)
 666   (format #f "\\repeat ~a ~a ~a ~a"
 667           repeat-type
 668           (ly:music-property expr 'repeat-count)
 669           (music->lily-string (ly:music-property expr 'element) parser)
 670           (let ((alternatives (ly:music-property expr 'elements)))
 671             (if (null? alternatives)
 672                 ""
 673                 (format #f "\\alternative { ~{~a ~}}"
 674                         (map-in-order (lambda (music)
 675                                         (music->lily-string music parser))
 676                                       alternatives))))))
 677
 678 (define-display-method VoltaRepeatedMusic (expr parser)
 679   (repeat->lily-string expr "volta" parser))
 680
 681 (define-display-method UnfoldedRepeatedMusic (expr parser)
 682   (repeat->lily-string expr "unfold" parser))
 683
 684 (define-display-method PercentRepeatedMusic (expr parser)
 685   (repeat->lily-string expr "percent" parser))
 686
 687 (define-display-method TremoloRepeatedMusic (expr parser)
 688   (let* ((count (ly:music-property expr 'repeat-count))
 689          (dots (if (= 0 (modulo count 3)) 0 1))
 690          (shift (- (log2 (if (= 0 dots)
 691                              (/ (* count 2) 3)
 692                              count))))
 693          (element (ly:music-property expr 'element))
 694          (den-mult 1))
 695     (if (eqv? (ly:music-property element 'name) 'SequentialMusic)
 696         (begin
 697           (set! shift (1- shift))
 698           (set! den-mult (length (ly:music-property element 'elements)))))
 699     (music-map (lambda (m)
 700                  (let ((duration (ly:music-property m 'duration)))
 701                    (if (ly:duration? duration)
 702                        (let* ((dlog (ly:duration-log duration))
 703                               (ddots (ly:duration-dot-count duration))
 704                               (dfactor (ly:duration-factor duration))
 705                               (dnum (car dfactor))
 706                               (dden (cdr dfactor)))
 707                          (set! (ly:music-property m 'duration)
 708                                (ly:make-duration (- dlog shift)
 709                                                  ddots ;;(- ddots dots) ; ????
 710                                                  dnum
 711                                                  (/ dden den-mult))))))
 712                  m)
 713                element)
 714     (format #f "\\repeat tremolo ~a ~a"
 715             count
 716             (music->lily-string element parser))))
 717
 718 ;;;
 719 ;;; Contexts
 720 ;;;
 721
 722 (define-display-method ContextSpeccedMusic (expr parser)
 723   (let ((id    (ly:music-property expr 'context-id))
 724         (create-new (ly:music-property expr 'create-new))
 725         (music (ly:music-property expr 'element))
 726         (operations (ly:music-property expr 'property-operations))
 727         (ctype (ly:music-property expr 'context-type)))
 728     (format #f "~a ~a~a~a ~a"
 729             (if (and (not (null? create-new)) create-new)
 730                 "\\new"
 731                 "\\context")
 732             ctype
 733             (if (null? id)
 734                 ""
 735                 (format #f " = ~s" id))
 736             (if (null? operations)
 737                 ""
 738                 (format #f " \\with {~{~a~}~%~v_}"
 739                         (parameterize ((*indent* (+ (*indent*) 2)))
 740                           (map (lambda (op)
 741                                  (format #f "~%~v_\\~a ~s"
 742                                          (*indent*)
 743                                          (first op)
 744                                          (second op)))
 745                                operations))
 746                         (*indent*)))
 747             (parameterize ((*current-context* ctype))
 748               (music->lily-string music parser)))))
 749
 750 ;; special cases: \figures \lyrics \drums
 751 (define-extra-display-method ContextSpeccedMusic (expr parser)
 752   (with-music-match (expr (music 'ContextSpeccedMusic
 753                                  create-new #t
 754                                  property-operations ?op
 755                                  context-type ?context-type
 756                                  element ?sequence))
 757     (if (null? ?op)
 758         (parameterize ((*explicit-mode* #f))
 759           (case ?context-type
 760             ((FiguredBass)
 761              (format #f "\\figures ~a" (music->lily-string ?sequence parser)))
 762             ((Lyrics)
 763              (format #f "\\lyrics ~a" (music->lily-string ?sequence parser)))
 764             ((DrumStaff)
 765              (format #f "\\drums ~a" (music->lily-string ?sequence parser)))
 766             (else
 767              #f)))
 768         #f)))
 769
 770 ;;; Context properties
 771
 772 (define-extra-display-method ContextSpeccedMusic (expr parser)
 773   (let ((element (ly:music-property expr 'element))
 774         (property-tuning? (make-music-type-predicate 'PropertySet
 775                                                      'PropertyUnset
 776                                                      'OverrideProperty
 777                                                      'RevertProperty))
 778         (sequence? (make-music-type-predicate 'SequentialMusic)))
 779     (if (and (ly:music? element)
 780              (or (property-tuning? element)
 781                  (and (sequence? element)
 782                       (every property-tuning? (ly:music-property element 'elements)))))
 783         (parameterize ((*current-context* (ly:music-property expr 'context-type)))
 784           (music->lily-string element parser))
 785         #f)))
 786
 787 (define (property-value->lily-string arg parser)
 788   (cond ((ly:music? arg)
 789          (music->lily-string arg parser))
 790         ((string? arg)
 791          (format #f "#~s" arg))
 792         ((markup? arg)
 793          (markup->lily-string arg))
 794         (else
 795          (format #f "#~a" (scheme-expr->lily-string arg)))))
 796
 797 (define-display-method PropertySet (expr parser)
 798   (let ((property (ly:music-property expr 'symbol))
 799         (value (ly:music-property expr 'value))
 800         (once (ly:music-property expr 'once)))
 801     (format #f "~a\\set ~a~a = ~a~a"
 802             (if (and (not (null? once)))
 803                 "\\once "
 804                 "")
 805             (if (eqv? (*current-context*) 'Bottom)
 806                 ""
 807                 (format #f "~a . " (*current-context*)))
 808             property
 809             (property-value->lily-string value parser)
 810             (new-line->lily-string))))
 811
 812 (define-display-method PropertyUnset (expr parser)
 813   (format #f "\\unset ~a~a~a"
 814           (if (eqv? (*current-context*) 'Bottom)
 815               ""
 816               (format #f "~a . " (*current-context*)))
 817           (ly:music-property expr 'symbol)
 818           (new-line->lily-string)))
 819
 820 ;;; Layout properties
 821
 822 (define-display-method OverrideProperty (expr parser)
 823   (let* ((symbol          (ly:music-property expr 'symbol))
 824          (properties   (ly:music-property expr 'grob-property-path
 825                                              (list (ly:music-property expr 'grob-property))))
 826          (value   (ly:music-property expr 'grob-value))
 827          (once    (ly:music-property expr 'once)))
 828
 829     (format #f "~a\\override ~a~a #'~a = ~a~a"
 830             (if (or (null? once)
 831                     (not once))
 832                 ""
 833                 "\\once ")
 834             (if (eqv? (*current-context*) 'Bottom)
 835                 ""
 836                 (format #f "~a . " (*current-context*)))
 837             symbol
 838             (if (null? (cdr properties))
 839                 (car properties)
 840                 properties)
 841             (property-value->lily-string value parser)
 842             (new-line->lily-string))))
 843
 844 (define-display-method RevertProperty (expr parser)
 845   (let* ((symbol (ly:music-property expr 'symbol))
 846          (properties (ly:music-property expr 'grob-property-path
 847                                              (list (ly:music-property expr 'grob-property)))))
 848     (format #f "\\revert ~a~a #'~a~a"
 849             (if (eqv? (*current-context*) 'Bottom)
 850                 ""
 851                 (format #f "~a . " (*current-context*)))
 852             symbol
 853             (if (null? (cdr properties))
 854                 (car properties)
 855                 properties)
 856             (new-line->lily-string))))
 857
 858 (define-display-method TimeSignatureMusic (expr parser)
 859   (let* ((num (ly:music-property expr 'numerator))
 860          (den (ly:music-property expr 'denominator))
 861          (structure (ly:music-property expr 'beat-structure)))
 862     (if (null? structure)
 863         (format #f
 864                 "\\time ~a/~a~a"
 865                 num den
 866                 (new-line->lily-string))
 867         (format #f
 868                 "\\time #'~a ~a/~a~a"
 869                 structure num den
 870                 (new-line->lily-string)))))
 871
 872 ;;; \melisma and \melismaEnd
 873 (define-extra-display-method ContextSpeccedMusic (expr parser)
 874   "If expr is a melisma, return \"\\melisma\", otherwise, return #f."
 875   (with-music-match (expr (music 'ContextSpeccedMusic
 876                                  element (music 'PropertySet
 877                                                 value #t
 878                                                 symbol 'melismaBusy)))
 879     "\\melisma"))
 880
 881 (define-extra-display-method ContextSpeccedMusic (expr parser)
 882   "If expr is a melisma end, return \"\\melismaEnd\", otherwise, return #f."
 883   (with-music-match (expr (music 'ContextSpeccedMusic
 884                                  element (music 'PropertyUnset
 885                                                 symbol 'melismaBusy)))
 886     "\\melismaEnd"))
 887
 888 ;;; \tempo
 889 (define-extra-display-method SequentialMusic (expr parser)
 890   (with-music-match (expr (music 'SequentialMusic
 891                                  elements ((music 'TempoChangeEvent
 892                                                   text ?text
 893                                                   tempo-unit ?unit
 894                                                   metronome-count ?count)
 895                                            (music 'ContextSpeccedMusic
 896                                                   element (music 'PropertySet
 897                                                                  symbol 'tempoWholesPerMinute)))))
 898     (format #f "\\tempo ~{~a~a~}~a = ~a~a"
 899             (if (markup? ?text)
 900                 (list (markup->lily-string ?text) " ")
 901                 '())
 902             (duration->lily-string ?unit #:force-duration #t)
 903             (if (pair? ?count)
 904                 (format #f "~a ~~ ~a" (car ?count) (cdr ?count))
 905                 ?count)
 906             (new-line->lily-string))))
 907
 908 (define-display-method TempoChangeEvent (expr parser)
 909   (let ((text (ly:music-property expr 'text)))
 910     (format #f "\\tempo ~a~a"
 911             (markup->lily-string text)
 912             (new-line->lily-string))))
 913
 914 ;;; \clef
 915 (define clef-name-alist #f)
 916 (define-public (memoize-clef-names clefs)
 917   "Initialize @code{clef-name-alist}, if not already set."
 918   (if (not clef-name-alist)
 919       (set! clef-name-alist
 920             (map (lambda (name+vals)
 921                    (cons (cdr name+vals)
 922                          (car name+vals)))
 923                  clefs))))
 924
 925 (define-extra-display-method ContextSpeccedMusic (expr parser)
 926   "If @var{expr} is a clef change, return \"\\clef ...\".
 927 Otherwise, return @code{#f}."
 928   (with-music-match (expr (music 'ContextSpeccedMusic
 929                                  context-type 'Staff
 930                                  element (music 'SequentialMusic
 931                                                 elements ((music 'PropertySet
 932                                                                  value ?clef-glyph
 933                                                                  symbol 'clefGlyph)
 934                                                           (music 'PropertySet
 935                                                                  symbol 'middleCClefPosition)
 936                                                           (music 'PropertySet
 937                                                                  value ?clef-position
 938                                                                  symbol 'clefPosition)
 939                                                           (music 'PropertySet
 940                                                                  value ?clef-octavation
 941                                                                  symbol 'clefOctavation)
 942                                                           (music 'ApplyContext
 943                                                                  procedure ly:set-middle-C!)))))
 944     (let ((clef-name (assoc-get (list ?clef-glyph ?clef-position 0)
 945                                 clef-name-alist)))
 946       (if clef-name
 947           (format #f "\\clef \"~a~{~a~a~}\"~a"
 948                   clef-name
 949                   (cond ((= 0 ?clef-octavation)
 950                          (list "" ""))
 951                         ((> ?clef-octavation 0)
 952                          (list "^" (1+ ?clef-octavation)))
 953                         (else
 954                          (list "_" (- 1 ?clef-octavation))))
 955                   (new-line->lily-string))
 956           #f))))
 957
 958 ;;; \bar
 959 (define-extra-display-method ContextSpeccedMusic (expr parser)
 960   "If `expr' is a bar, return \"\\bar ...\".
 961 Otherwise, return #f."
 962   (with-music-match (expr (music 'ContextSpeccedMusic
 963                                  context-type 'Timing
 964                                  element (music 'PropertySet
 965                                                 value ?bar-type
 966                                                 symbol 'whichBar)))
 967     (format #f "\\bar \"~a\"~a" ?bar-type (new-line->lily-string))))
 968
 969 ;;; \partial
 970 (define-extra-display-method ContextSpeccedMusic (expr parser)
 971   "If `expr' is a partial measure, return \"\\partial ...\".
 972 Otherwise, return #f."
 973   (with-music-match (expr (music
 974                            'ContextSpeccedMusic
 975                            element (music
 976                                     'ContextSpeccedMusic
 977                                     context-type 'Timing
 978                                     element (music
 979                                              'PartialSet
 980                                              partial-duration ?duration))))
 981
 982     (and ?duration
 983          (format #f "\\partial ~a"
 984                  (duration->lily-string ?duration #:force-duration #t)))))
 985
 986 ;;;
 987 ;;;
 988
 989 (define-display-method ApplyOutputEvent (applyoutput parser)
 990   (let ((proc (ly:music-property applyoutput 'procedure))
 991         (ctx  (ly:music-property applyoutput 'context-type)))
 992     (format #f "\\applyOutput #'~a #~a"
 993             ctx
 994             (or (procedure-name proc)
 995                 (with-output-to-string
 996                   (lambda ()
 997                     (pretty-print (procedure-source proc))))))))
 998
 999 (define-display-method ApplyContext (applycontext parser)
1000   (let ((proc (ly:music-property applycontext 'procedure)))
1001     (format #f "\\applyContext #~a"
1002             (or (procedure-name proc)
1003                 (with-output-to-string
1004                   (lambda ()
1005                     (pretty-print (procedure-source proc))))))))
1006
1007 ;;; \partcombine
1008 (define-display-method PartCombineMusic (expr parser)
1009   (format #f "\\partcombine ~{~a ~}"
1010           (map-in-order (lambda (music)
1011                           (music->lily-string music parser))
1012                         (ly:music-property expr 'elements))))
1013
1014 (define-extra-display-method PartCombineMusic (expr parser)
1015   (with-music-match (expr (music 'PartCombineMusic
1016                                  elements ((music 'UnrelativableMusic
1017                                                   element (music 'ContextSpeccedMusic
1018                                                                  context-id "one"
1019                                                                  context-type 'Voice
1020                                                                  element ?sequence1))
1021                                            (music 'UnrelativableMusic
1022                                                   element (music 'ContextSpeccedMusic
1023                                                                  context-id "two"
1024                                                                  context-type 'Voice
1025                                                                  element ?sequence2)))))
1026     (format #f "\\partcombine ~a~a~a"
1027             (music->lily-string ?sequence1 parser)
1028             (new-line->lily-string)
1029             (music->lily-string ?sequence2 parser))))
1030
1031 (define-display-method UnrelativableMusic (expr parser)
1032   (music->lily-string (ly:music-property expr 'element) parser))
1033
1034 ;;; Cue notes
1035 (define-display-method QuoteMusic (expr parser)
1036   (or (with-music-match (expr (music
1037                                'QuoteMusic
1038                                quoted-voice-direction ?quoted-voice-direction
1039                                quoted-music-name ?quoted-music-name
1040                                quoted-context-id "cue"
1041                                quoted-context-type 'Voice
1042                                element ?music))
1043         (format #f "\\cueDuring #~s #~a ~a"
1044                 ?quoted-music-name
1045                 ?quoted-voice-direction
1046                 (music->lily-string ?music parser)))
1047       (format #f "\\quoteDuring #~s ~a"
1048               (ly:music-property expr 'quoted-music-name)
1049               (music->lily-string (ly:music-property expr 'element) parser))))
1050
1051 ;;;
1052 ;;; Breaks
1053 ;;;
1054 (define-display-method LineBreakEvent (expr parser)
1055   (if (null? (ly:music-property expr 'break-permission))
1056       "\\noBreak"
1057       "\\break"))
1058
1059 (define-display-method PageBreakEvent (expr parser)
1060   (if (null? (ly:music-property expr 'break-permission))
1061       "\\noPageBreak"
1062       "\\pageBreak"))
1063
1064 (define-display-method PageTurnEvent (expr parser)
1065   (if (null? (ly:music-property expr 'break-permission))
1066       "\\noPageTurn"
1067       "\\pageTurn"))
1068
1069 (define-extra-display-method EventChord (expr parser)
1070   (with-music-match (expr (music 'EventChord
1071                             elements ((music 'LineBreakEvent
1072                                              break-permission 'force)
1073                                       (music 'PageBreakEvent
1074                                              break-permission 'force))))
1075     "\\pageBreak"))
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                                       (music 'PageTurnEvent
1084                                              break-permission 'force))))
1085     "\\pageTurn"))
1086
1087 ;;;
1088 ;;; Lyrics
1089 ;;;
1090
1091 ;;; \lyricsto
1092 (define-display-method LyricCombineMusic (expr parser)
1093   (format #f "\\lyricsto ~s ~a"
1094           (ly:music-property expr 'associated-context)
1095           (parameterize ((*explicit-mode* #f))
1096             (music->lily-string (ly:music-property expr 'element) parser))))
1097
1098 ;; \addlyrics
1099 (define-extra-display-method SimultaneousMusic (expr parser)
1100   (with-music-match (expr (music 'SimultaneousMusic
1101                                  elements ((music 'ContextSpeccedMusic
1102                                                   context-id ?id
1103                                                   context-type 'Voice
1104                                                   element ?note-sequence)
1105                                            (music 'ContextSpeccedMusic
1106                                                   context-type 'Lyrics
1107                                                   create-new #t
1108                                                   element (music 'LyricCombineMusic
1109                                                                  associated-context ?associated-id
1110                                                                  element ?lyric-sequence)))))
1111     (if (string=? ?id ?associated-id)
1112         (format #f "~a~a \\addlyrics ~a"
1113                 (music->lily-string ?note-sequence parser)
1114                 (new-line->lily-string)
1115                 (parameterize ((*explicit-mode* #f))
1116                   (music->lily-string ?lyric-sequence parser)))
1117         #f)))
1118
1119 ;; Silence internal event sent at end of each lyrics block
1120 (define-display-method CompletizeExtenderEvent (expr parser)
1121   "")