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