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