scm/define-music-display-methods.scm

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