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