scm/define-music-display-methods.scm

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