--- /dev/null
+\version "2.7.2"
+
+#(use-modules (srfi srfi-13)
+ (ice-9 format))
+
+%%%
+%%% Testing utilities
+%%%
+#(define (my-parse-string-result str parser)
+ "Parse `str', which is supposed to contain a music expression."
+ (ly:parser-parse-string parser
+ (format #f "parseStringResult = \\notemode { ~a }" str))
+ (ly:parser-lookup parser 'parseStringResult))
+
+#(define (my-read-lily-expression chr port)
+ (let ((lily-string (call-with-output-string
+ (lambda (out)
+ (do ((c (read-char port) (read-char port)))
+ ((and (char=? c #\#)
+ (char=? (peek-char port) #\]))
+ (read-char port))
+ (display c out))))))
+ `(let* ((parser-clone (ly:clone-parser parser))
+ (input-str (string-trim-both ,lily-string))
+ (music (car (ly:music-property (my-parse-string-result input-str parser-clone)
+ 'elements)))
+ (result-str (string-trim-both (music->lily-string music))))
+ (cons input-str result-str))))
+
+#(read-hash-extend #\[ my-read-lily-expression)
+
+#(display-lily-init parser)
+#(define test-number 0)
+
+#(define (lily-string->markup str)
+ (make-column-markup (string-split str #\NewLine)))
+
+test = #(def-music-function (parser location result-info strings) (string? pair?)
+ (let ((input (car strings))
+ (output (cdr strings)))
+ (set! test-number (1+ test-number))
+ (if (string=? input output)
+ (make-music 'SequentialMusic)
+ (make-music 'SequentialMusic
+ 'elements
+ (list (make-music 'EventChord
+ 'elements (list (make-music 'BreakEvent
+ 'page-penalty 0
+ 'penalty -10001)))
+ (make-music 'EventChord
+ 'elements (list (make-music 'SkipEvent
+ 'duration (ly:make-duration 0 0 1 1))
+ (make-music 'TextScriptEvent
+ 'direction -1
+ 'text (markup #:column (#:simple (format #f "Test #~a "
+ test-number)
+ (if (string-null? result-info)
+ (markup #:bold "BUG")
+ (markup #:simple result-info))
+ #:typewriter (lily-string->markup input)
+ #:typewriter (lily-string->markup output)))))))))))
+
+%%%
+%%% Tests
+%%%
+\header {
+ texidoc = \markup \column { \line { \typewriter display-lily-music unit tests }
+ \line { Real bugs (regressions) are marked as \bold BUG. }
+ \line { Known bugs are marked as TODO. } }
+}
+
+\layout {
+ raggedright = ##t
+ indent = 0.0\cm
+ \context {
+ \Staff
+ \override StaffSymbol #'line-count = #1
+ %\remove "Staff_symbol_engraver"
+ \remove "Time_signature_engraver"
+ \remove "Clef_engraver"
+ }
+ \context {
+ \Score
+ \remove "Bar_number_engraver"
+ }
+}
+{
+ %% Sequential music
+ \test #"" ##[ { { a b } { c d } } #] % SequentialMusic
+ \test #"" ##[ << { a b } { c d } >> #] % SimultaneousMusic
+ \test #"" ##[ << { a b } \\ { c d } >> #] % VoiceSeparator
+
+ %% Chords and Notes
+ \test #"" ##[ { ceses ces c cis cisis } #] % NoteEvent
+ \test #"" ##[ { deses des d dis disis } #]
+ \test #"" ##[ { eeses ees e eis eisis } #]
+ \test #"" ##[ { feses fes f fis fisis } #]
+ \test #"" ##[ { geses ges g gis gisis } #]
+ \test #"" ##[ { aeses aes a ais aisis } #]
+ \test #"" ##[ { beses bes b bis bisis } #]
+ \test #"" ##[ { c,, d' } #]
+ \test #"" ##[ { c' d'=' } #]
+ \test #"" ##[ { c! c? } #]
+ \test #"" ##[ r1.*4/3 #] % RestEvent
+ \test #"" ##[ c1\rest #] % RestEvent
+ \test #"" ##[ s2..*3/4 #] % SkipEvent
+ \test #"" ##[ R1.*2/3 #] % MultiMeasureRestMusicGroup, MultiMeasureRestEvent
+ \test #"" ##[ \skip 2.*3/4 #] % SkipMusic
+ \test #"" ##[ < c\1 e\3 >4.*3/4-. #] % EventChord, NoteEvent, StringNumberEvent, ArticulationEvent
+
+ %% tags
+ \test #"" ##[ { \tag #'foo { c4 d } } #]
+ \test #"" ##[ c-\tag #'(foo baz) -^ -. #]
+
+ %% Graces
+ \test #"" ##[ { \grace c8 d2 } #] % GraceMusic
+ \test #"" ##[ { \appoggiatura c8 d2 } #]
+ \test #"" ##[ { \acciaccatura c8 d2 } #]
+ \test #"" ##[ { c1 \afterGrace { b,16 c } d2 } #]
+
+ %% Clusters
+ \test #"" ##[ { \makeClusters { c4 g } } #] % ClusterNoteEvent
+
+ %% Figured bass
+ \test #"" ##[ \figures { < 6 > } #] % BassFigureEvent
+ \test #"" ##[ \figuremode { < 1-- 3- > < 2+ 4++ > < _! 7! > } #]
+ \test #"" ##[ \figuremode { < [6 > < 5] > } #]
+
+ %% Lyrics
+ \test #"" ##[ \lyrics { a b } #]
+ \test #"" ##[ \lyricmode { a -- b } #] % HyphenEvent
+ \test #"" ##[ \lyricmode { a __ b } #] % ExtenderEvent
+ \test #"" ##[ \lyricmode { "a " } #] % LyricEvent
+ \test #"" ##[ \lyricsto "foo" { bla bla } #] % LyricCombineMusic
+ \test #"" ##[ { { c d }
+ \addlyrics { bla bla } } #]
+ \test #"" ##[ \oldaddlyrics { c d }
+\lyricmode { bla bla } #] % OldLyricCombineMusic
+
+ %% Drums
+ \test #"" ##[ \drums { hihat } #]
+ \test #"" ##[ \drummode { hihat4.*3/4 } #]
+
+ %% Expressive marks
+ \test #"" ##[ c4 ~ #] % TieEvent
+ \test #"" ##[ c\noBeam #] % BeamForbidEvent
+ \test #"" ##[ c\1 #] % StringNumberEvent
+ \test #"" ##[ { c: c:1 } #] % TremoloEvent
+ \test #"" ##[ { c-^ c^^ c_^ } #] % ArticulationEvent
+ \test #"" ##[ { c-+ c^+ c_+ } #]
+ \test #"" ##[ { c-- c^- c_- } #]
+ \test #"" ##[ { c-| c^| c_| } #]
+ \test #"" ##[ { c-> c^> c_> } #]
+ \test #"" ##[ { c-. c^. c_. } #]
+ \test #"" ##[ { c-_ c^_ c__ } #]
+ \test #"" ##[ { c-\trill c^\trill c_\trill } #]
+ \test #"" ##[ { c-1 c^2 c_3 } #] % FingerEvent
+ \test #"" ##[ { c-"foo" c^"foo" c_"foo" } #] % TextScriptEvent
+ \test #"" ##[ { R1*4 -"foo" R ^"foo" R _"foo" } #] % MultiMeasureTextEvent
+ \test #"" ##[ { c4-\harmonic c^\harmonic c_\harmonic } #] % HarmonicEvent
+ \test #"" ##[ { c-\glissando c^\glissando c_\glissando } #] % GlissandoEvent
+ \test #"" ##[ { c-\arpeggio c^\arpeggio c_\arpeggio } #] % ArpeggioEvent
+ \test #"" ##[ { c\p c^\ff c_\sfz } #] % AbsoluteDynamicEvent
+ \test #"" ##[ { c[ c] c^[ c^] c_[ c_] } #] % BeamEvent
+ \test #"" ##[ { c( c) c^( c^) c_( c_) } #] % SlurEvent
+ \test #"" ##[ { c\< c\! c^\< c^\! c_\< c_\! } #] % CrescendoEvent
+ \test #"" ##[ { c\> c\! c^\> c^\! c_\> c_\! } #] % DecrescendoEvent
+ \test #"" ##[ { c\( c\) c^\( c^\) c_\( c_\) } #] % PhrasingSlurEvent
+ \test #"" ##[ { c\sustainDown c\sustainUp } #] % SustainEvent
+ \test #"" ##[ { c\sostenutoDown c\sostenutoUp } #] % SostenutoEvent
+ \test #"" ##[ { c\melisma c\melismaEnd } #] % ManualMelismaEvent
+ \test #"" ##[ { c\startTextSpan c\stopTextSpan } #] % TextSpanEvent
+ \test #"" ##[ { c\startTrillSpan c\stopTrillSpan } #] % TrillSpanEvent
+ \test #"" ##[ { c \startStaff c \stopStaff } #] % StaffSpanEvent
+ \test #"" ##[ { c\startGroup c\stopGroup c^\startGroup c^\stopGroup c_\startGroup c_\stopGroup } #] % NoteGroupingEvent
+ \test #"" ##[ { c\unaCorda c\treCorde } #] % UnaCordaEvent
+ \test #"" ##[ \breathe #]
+ \test #"" ##[ { c \[ c \] } #] % LigatureEvent
+ \test #"" ##[ \~ #] % PesOrFlexaEvent
+
+ \test #"" ##[ \break #]
+
+ %% Checks
+ \test #"" ##[ \octave a' #] % RelativeOctaveCheck
+ \test #"" ##[ | #] % BarCheck
+
+ %% Marks
+ \test #"" ##[ \mark \default #] % MarkEvent
+ \test #"" ##[ \mark "Allegro" #]
+ \test #"" ##[ \tempo 4 = 120 #] % MetronomeChangeEvent
+
+ %% key, time, clef, bar
+ \test #"" ##[ \key \default #] % KeyChangeEvent
+ \test #"" ##[ \key e \minor #]
+ \test #"" ##[ \clef "bass" #]
+ \test #"" ##[ \clef "french^2" #]
+ \test #"" ##[ \clef "alto_3" #]
+ \test #"" ##[ \time 2/4 #]
+ \test #"" ##[ #(set-time-signature 5 8 '(3 2)) #]
+ \test #"" ##[ \bar "|." #]
+
+ %% staff switches
+ \test #"" ##[ \autochange { c d } #] % AutoChangeMusic
+ \test #"" ##[ { \change Staff = "up" { c d } } #] % ContextChange
+
+ %% Tuplets
+ \test #"" ##[ \times 2/3 { c8 d e } #] % TimeScaledMusic
+ \test #"" ##[ \times 4/6 { c16 d e f g a } #]
+
+ %% \relative and \tranpose
+ \test #"NOT A BUG" ##[ \relative c' { c b } #] % RelativeOctaveMusic
+ \test #"NOT A BUG" ##[ \transpose c d { c d } #] % TransposedMusic
+
+ %% Repeats
+ \test #"" ##[ \repeat volta 2 { c d } #] % VoltaRepeatedMusic
+ \test #"" ##[ \repeat unfold 2 { c d } #] % UnfoldedRepeatedMusic
+ \test #"" ##[ \repeat fold 2 { c d } #] % FoldedRepeatedMusic
+ \test #"" ##[ \repeat percent 2 { c d } #] % PercentRepeatedMusic
+ \test #"" ##[ \repeat tremolo 4 { c16 d } #] % TremoloRepeatedMusic
+ \test #"" ##[ \repeat volta 2 { c4 d } \alternative { { c d } { e f } } #] %
+
+ %% Context creation
+ \test #"" ##[ \new Staff { c d } #] % ContextSpeccedMusic
+ \test #"" ##[ \context Staff { c d } #]
+ \test #"" ##[ \context Staff = "up" { c d } #]
+ \test #"" ##[
+\new Staff \with {
+ \consists "Timing_engraver"
+ \remove "Clef_engraver"
+} { c d } #]
+ %% Context properties
+ \test #"" ##[ \once \set Score . skipBars = ##t #] % PropertySet
+ \test #"" ##[ \set autoBeaming = ##f #]
+ \test #"" ##[ \unset Score . skipBars #] % PropertyUnset
+ \test #"" ##[ \unset autoBeaming #]
+ %% Layout properties
+ \test #"" ##[ \override Staff . Stem #'thickness = #4.0 #] % OverrideProperty
+ \test #"" ##[ \once \override Beam #'thickness = #0.6 #]
+ \test #"" ##[ \revert Staff . Stem #'thickness #] % RevertProperty
+ \test #"" ##[ \revert Beam #'thickness #]
+
+ %% \partial
+
+
+ \test #"" ##[ \partial 2 #]
+ \test #"" ##[ \partial 8. #]
+ \test #"TODO? exotic durations in \\partial" ##[ \partial 4*2/3 #]
+
+ %% \partcombine
+ \test #"" ##[ \partcombine { c e }
+{ d f } #] % PartCombineMusic UnrelativableMusic
+
+ %% Cue notes
+ \test #"" ##[ \cueDuring #"foo" #1 { c d } #]
+ \test #"" ##[ \quoteDuring #"foo" { c d } #]
+}
+
--- /dev/null
+;;; define-music-display-methods.scm -- data for displaying music
+;;; expressions using LilyPond notation.
+;;;
+;;; (c) 2005 Nicolas Sceaux <nicolas.sceaux@free.fr>
+;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Display method implementation
+;;;
+
+(define-module (scm display-lily))
+
+
+;;; `display-lily-init' must be called before using `display-lily-music'. It
+;;; takes a parser object as an argument.
+(define-public (display-lily-init parser)
+ (*parser* parser)
+ (set-note-names! (ly:parser-lookup (*parser*) 'pitchnames))
+ #t)
+
+;;;
+;;; Scheme forms
+;;;
+(define (scheme-expr->lily-string scm-arg)
+ (cond ((or (number? scm-arg)
+ (string? scm-arg))
+ (format #f "~s" scm-arg))
+ ((or (symbol? scm-arg)
+ (list? scm-arg))
+ (format #f "'~s" scm-arg))
+ ((procedure? scm-arg)
+ (format #f "~a"
+ (or (procedure-name scm-arg)
+ (with-output-to-string
+ (lambda ()
+ (pretty-print (procedure-source scm-arg)))))))
+ (else
+ (format #f "~a"
+ (with-output-to-string
+ (lambda ()
+ (display-scheme-music scm-arg)))))))
+;;;
+;;; Markups
+;;;
+
+(define-public (markup->lily-string markup-expr)
+ "Return a string describing, in LilyPond syntax, the given markup expression."
+ (define (proc->command proc)
+ (let ((cmd-markup (symbol->string (procedure-name proc))))
+ (substring cmd-markup 0 (- (string-length cmd-markup)
+ (string-length "-markup")))))
+ (define (arg->string arg)
+ (cond ((string? arg)
+ (format #f "~s" arg))
+ ((markup? arg) ;; a markup
+ (markup->lily-string-aux arg))
+ ((and (pair? arg) (every markup? arg)) ;; a markup list
+ (format #f "{~{ ~a~}}" (map-in-order markup->lily-string-aux arg)))
+ (else ;; a scheme argument
+ (format #f "#~a" (scheme-expr->lily-string arg)))))
+ (define (markup->lily-string-aux expr)
+ (let ((cmd (car expr))
+ (args (cdr expr)))
+ (if (eqv? cmd simple-markup) ;; a simple string
+ (format #f "~s" (car args))
+ (format #f "\\~a~{ ~a~}"
+ (proc->command cmd)
+ (map-in-order arg->string args)))))
+ (cond ((string? markup-expr)
+ (format #f "~s" markup-expr))
+ ((eqv? (car markup-expr) simple-markup)
+ (format #f "~s" (second markup-expr)))
+ (else
+ (format #f "\\markup ~a"
+ (markup->lily-string-aux markup-expr)))))
+;;;
+;;; pitch names
+;;;
+(define note-names '())
+
+(define (set-note-names! pitchnames)
+ (set! note-names (map-in-order (lambda (name+lypitch)
+ (cons (cdr name+lypitch) (car name+lypitch)))
+ pitchnames)))
+
+(define (note-name->lily-string ly-pitch)
+ ;; here we define a custom pitch= function, since we do not want to
+ ;; test whether octaves are also equal. (otherwise, we would be using equal?)
+ (define (pitch= pitch1 pitch2)
+ (and (= (ly:pitch-notename pitch1) (ly:pitch-notename pitch2))
+ (= (ly:pitch-alteration pitch1) (ly:pitch-alteration pitch2))))
+ (let ((result (assoc ly-pitch note-names pitch=))) ;; assoc from srfi-1
+ (if result
+ (cdr result)
+ #f)))
+
+(define (octave->lily-string pitch)
+ (let ((octave (ly:pitch-octave pitch)))
+ (cond ((>= octave 0)
+ (make-string (1+ octave) #\'))
+ ((< octave -1)
+ (make-string (1- (* -1 octave)) #\,))
+ (else ""))))
+
+;;;
+;;; durations
+;;;
+(define* (duration->lily-string ly-duration #:key (prev-duration (*previous-duration*))
+ (force-duration (*force-duration*))
+ (time-factor-numerator (*time-factor-numerator*))
+ (time-factor-denominator (*time-factor-denominator*)))
+ (let ((log2 (ly:duration-log ly-duration))
+ (dots (ly:duration-dot-count ly-duration))
+ (num+den (ly:duration-factor ly-duration)))
+ (if (or force-duration (not prev-duration) (not (equal? ly-duration prev-duration)))
+ (string-append (case log2
+ ((-1) "\\breve")
+ ((-2) "\\longa")
+ ((-3) "\\maxima")
+ (else (number->string (expt 2 log2))))
+ (make-string dots #\.)
+ (let ((num? (not (or (= 1 (car num+den))
+ (and time-factor-numerator
+ (= (car num+den) time-factor-numerator)))))
+ (den? (not (or (= 1 (cdr num+den))
+ (and time-factor-denominator
+ (= (cdr num+den) time-factor-denominator))))))
+ (cond (den?
+ (format #f "*~a/~a" (car num+den) (cdr num+den)))
+ (num?
+ (format #f "*~a" (car num+den)))
+ (else ""))))
+ "")))
+
+;;;
+;;; post events
+;;;
+
+(define post-event? (make-music-type-predicate
+ 'StringNumberEvent
+ 'ArticulationEvent
+ 'FingerEvent
+ 'TextScriptEvent
+ 'MultiMeasureTextEvent
+ 'HyphenEvent
+ 'ExtenderEvent
+ 'BeamEvent
+ 'SlurEvent
+ 'TieEvent
+ 'CrescendoEvent
+ 'DecrescendoEvent
+ 'PhrasingSlurEvent
+ 'TremoloEvent
+ 'SustainEvent
+ 'SostenutoEvent
+ 'ManualMelismaEvent
+ 'TextSpanEvent
+ 'HarmonicEvent
+ 'BeamForbidEvent
+ 'AbsoluteDynamicEvent
+ 'TrillSpanEvent
+ 'GlissandoEvent
+ 'ArpeggioEvent
+ 'NoteGroupingEvent
+ 'UnaCordaEvent))
+
+(define* (event-direction->lily-string event #:optional (required #t))
+ (let ((direction (ly:music-property event 'direction)))
+ (cond ((or (not direction) (null? direction) (= 0 direction))
+ (if required "-" ""))
+ ((= 1 direction) "^")
+ ((= -1 direction) "_")
+ (else ""))))
+
+(define-macro (define-post-event-display-method type vars direction-required str)
+ `(define-display-method ,type ,vars
+ (format #f "~a~a"
+ (event-direction->lily-string ,(car vars) ,direction-required)
+ ,str)))
+
+(define-macro (define-span-event-display-method type vars direction-required str-start str-stop)
+ `(define-display-method ,type ,vars
+ (format #f "~a~a"
+ (event-direction->lily-string ,(car vars) ,direction-required)
+ (if (= -1 (ly:music-property ,(car vars) 'span-direction))
+ ,str-start
+ ,str-stop))))
+
+(define-display-method HyphenEvent (event)
+ " --")
+(define-display-method ExtenderEvent (event)
+ " __")
+(define-display-method TieEvent (event)
+ " ~")
+(define-display-method BeamForbidEvent (event)
+ "\\noBeam")
+(define-display-method StringNumberEvent (event)
+ (format #f "\\~a" (ly:music-property event 'string-number)))
+
+
+(define-display-method TremoloEvent (event)
+ (let ((tremolo-type (ly:music-property event 'tremolo-type)))
+ (format #f ":~a" (if (= 0 tremolo-type)
+ ""
+ tremolo-type))))
+
+(define-post-event-display-method ArticulationEvent (event) #t
+ (let ((articulation (ly:music-property event 'articulation-type)))
+ (case (string->symbol articulation)
+ ((marcato) "^")
+ ((stopped) "+")
+ ((tenuto) "-")
+ ((staccatissimo) "|")
+ ((accent) ">")
+ ((staccato) ".")
+ ((portato) "_")
+ (else (format #f "\\~a" articulation)))))
+
+(define-post-event-display-method FingerEvent (event) #t
+ (ly:music-property event 'digit))
+
+(define-post-event-display-method TextScriptEvent (event) #t
+ (markup->lily-string (ly:music-property event 'text)))
+
+(define-post-event-display-method MultiMeasureTextEvent (event) #t
+ (markup->lily-string (ly:music-property event 'text)))
+
+(define-post-event-display-method HarmonicEvent (event) #t "\\harmonic")
+(define-post-event-display-method GlissandoEvent (event) #t "\\glissando")
+(define-post-event-display-method ArpeggioEvent (event) #t "\\arpeggio")
+(define-post-event-display-method AbsoluteDynamicEvent (event) #f
+ (format #f "\\~a" (ly:music-property event 'text)))
+
+(define-span-event-display-method BeamEvent (event) #f "[" "]")
+(define-span-event-display-method SlurEvent (event) #f "(" ")")
+(define-span-event-display-method CrescendoEvent (event) #f "\\<" "\\!")
+(define-span-event-display-method DecrescendoEvent (event) #f "\\>" "\\!")
+(define-span-event-display-method PhrasingSlurEvent (event) #f "\\(" "\\)")
+(define-span-event-display-method SustainEvent (event) #f "\\sustainDown" "\\sustainUp")
+(define-span-event-display-method SostenutoEvent (event) #f "\\sostenutoDown" "\\sostenutoUp")
+(define-span-event-display-method ManualMelismaEvent (event) #f "\\melisma" "\\melismaEnd")
+(define-span-event-display-method TextSpanEvent (event) #f "\\startTextSpan" "\\stopTextSpan")
+(define-span-event-display-method TrillSpanEvent (event) #f "\\startTrillSpan" "\\stopTrillSpan")
+(define-span-event-display-method StaffSpanEvent (event) #f "\\startStaff" "\\stopStaff")
+(define-span-event-display-method NoteGroupingEvent (event) #f "\\startGroup" "\\stopGroup")
+(define-span-event-display-method UnaCordaEvent (event) #f "\\unaCorda" "\\treCorde")
+
+;;;
+;;; Graces
+;;;
+
+(define-display-method GraceMusic (expr)
+ (format #f "\\grace ~a"
+ (music->lily-string (ly:music-property expr 'element))))
+
+;; \acciaccatura \appoggiatura \grace
+;; TODO: it would be better to compare ?start and ?stop
+;; with startAppoggiaturaMusic and stopAppoggiaturaMusic,
+;; using a custom music equality predicate.
+(define-extra-display-method GraceMusic (expr)
+ "Display method for appoggiatura."
+ (with-music-match (expr (music
+ 'GraceMusic
+ element (music
+ 'SequentialMusic
+ elements (?start
+ ?music
+ ?stop))))
+ ;; we check whether ?start and ?stop look like
+ ;; startAppoggiaturaMusic stopAppoggiaturaMusic
+ (and (with-music-match (?start (music
+ 'SequentialMusic
+ elements ((music
+ 'EventChord
+ elements ((music
+ 'SkipEvent
+ duration (ly:make-duration 0 0 0 1))
+ (music
+ 'SlurEvent
+ span-direction -1))))))
+ #t)
+ (with-music-match (?stop (music
+ 'SequentialMusic
+ elements ((music
+ 'EventChord
+ elements ((music
+ 'SkipEvent
+ duration (ly:make-duration 0 0 0 1))
+ (music
+ 'SlurEvent
+ span-direction 1))))))
+ (format #f "\\appoggiatura ~a" (music->lily-string ?music))))))
+
+
+(define-extra-display-method GraceMusic (expr)
+ "Display method for acciaccatura."
+ (with-music-match (expr (music
+ 'GraceMusic
+ element (music
+ 'SequentialMusic
+ elements (?start
+ ?music
+ ?stop))))
+ ;; we check whether ?start and ?stop look like
+ ;; startAcciaccaturaMusic stopAcciaccaturaMusic
+ (and (with-music-match (?start (music
+ 'SequentialMusic
+ elements ((music
+ 'EventChord
+ elements ((music
+ 'SkipEvent
+ duration (ly:make-duration 0 0 0 1))
+ (music
+ 'SlurEvent
+ span-direction -1)))
+ (music
+ 'ContextSpeccedMusic
+ element (music
+ 'OverrideProperty
+ grob-property 'stroke-style
+ grob-value "grace"
+ symbol 'Stem)))))
+ #t)
+ (with-music-match (?stop (music
+ 'SequentialMusic
+ elements ((music
+ 'ContextSpeccedMusic
+ element (music
+ 'RevertProperty
+ grob-property 'stroke-style
+ symbol 'Stem))
+ (music
+ 'EventChord
+ elements ((music
+ 'SkipEvent
+ duration (ly:make-duration 0 0 0 1))
+ (music
+ 'SlurEvent
+ span-direction 1))))))
+ (format #f "\\acciaccatura ~a" (music->lily-string ?music))))))
+
+(define-extra-display-method GraceMusic (expr)
+ "Display method for grace."
+ (with-music-match (expr (music
+ 'GraceMusic
+ element (music
+ 'SequentialMusic
+ elements (?start
+ ?music
+ ?stop))))
+ ;; we check whether ?start and ?stop look like
+ ;; startGraceMusic stopGraceMusic
+ (and (null? (ly:music-property ?start 'elements))
+ (null? (ly:music-property ?stop 'elements))
+ (format #f "\\grace ~a" (music->lily-string ?music)))))
+
+;;;
+;;; Music sequences
+;;;
+
+(define-display-method SequentialMusic (seq)
+ (let ((force-line-break (and (*force-line-break*)
+ ;; hm
+ (> (length (ly:music-property seq 'elements))
+ (*max-element-number-before-break*))))
+ (elements (ly:music-property seq 'elements))
+ (chord? (make-music-type-predicate 'EventChord))
+ (cluster? (make-music-type-predicate 'ClusterNoteEvent))
+ (note? (make-music-type-predicate 'NoteEvent)))
+ (format #f "~a~a{~v%~v_~{~a ~}~v%~v_}"
+ (if (any (lambda (e)
+ (and (chord? e)
+ (any cluster? (ly:music-property e 'elements))))
+ elements)
+ "\\makeClusters "
+ "")
+ (if (*explicit-mode*)
+ ;; if the sequence contains EventChord which contains figures ==> figuremode
+ ;; if the sequence contains EventChord which contains lyrics ==> lyricmode
+ ;; if the sequence contains EventChord which contains drum notes ==> drummode
+ (cond ((any (lambda (chord)
+ (any (make-music-type-predicate 'BassFigureEvent)
+ (ly:music-property chord 'elements)))
+ (filter chord? elements))
+ "\\figuremode ")
+ ((any (lambda (chord)
+ (any (make-music-type-predicate 'LyricEvent)
+ (ly:music-property chord 'elements)))
+ (filter chord? elements))
+ "\\lyricmode ")
+ ((any (lambda (chord)
+ (any (lambda (event)
+ (and (note? event)
+ (not (null? (ly:music-property event 'drum-type)))))
+ (ly:music-property chord 'elements)))
+ (filter chord? elements))
+ "\\drummode ")
+ (else ;; TODO: other modes?
+ ""))
+ "")
+ (if force-line-break 1 0)
+ (if force-line-break (+ 2 (*indent*)) 1)
+ (parameterize ((*indent* (+ 2 (*indent*))))
+ (map-in-order music->lily-string elements))
+ (if force-line-break 1 0)
+ (if force-line-break (*indent*) 0))))
+
+(define-display-method SimultaneousMusic (sim)
+ (parameterize ((*indent* (+ 3 (*indent*))))
+ (format #f "<< ~{~a ~}>>"
+ (map-in-order music->lily-string (ly:music-property sim 'elements)))))
+
+(define-extra-display-method SimultaneousMusic (expr)
+ "If `sim' is an \afterGrace expression, return \"\\afterGrace ...\".
+Otherwise, return #f."
+ ;; TODO: do something with afterGraceFraction?
+ (with-music-match (expr (music 'SimultaneousMusic
+ elements (?before-grace
+ (music 'SequentialMusic
+ elements ((music 'SkipMusic)
+ (music 'GraceMusic
+ element ?grace))))))
+ (format #f "\\afterGrace ~a ~a"
+ (music->lily-string ?before-grace)
+ (music->lily-string ?grace))))
+
+;;;
+;;; Chords
+;;;
+
+(define-display-method EventChord (chord)
+ ;; event_chord : simple_element post_events
+ ;; | command_element
+ ;; | note_chord_element
+
+ ;; TODO : tagged post_events
+ ;; post_events : ( post_event | tagged_post_event )*
+ ;; tagged_post_event: '-' \tag embedded_scm post_event
+
+ (let* ((elements (ly:music-property chord 'elements))
+ (simple-elements (filter (make-music-type-predicate
+ 'NoteEvent 'ClusterNoteEvent 'RestEvent
+ 'MultiMeasureRestEvent 'SkipEvent 'LyricEvent)
+ elements)))
+ (if ((make-music-type-predicate 'StaffSpanEvent 'BreathingSignEvent) (car elements))
+ ;; first, a special case: StaffSpanEvent (\startStaff, \stopStaff)
+ ;; and BreathingSignEvent (\breathe)
+ (music->lily-string (car elements))
+ (if (and (not (null? simple-elements))
+ (null? (cdr simple-elements)))
+ ;; simple_element : note | figure | rest | mmrest | lyric_element | skip
+ (let* ((simple-element (car simple-elements))
+ (duration (ly:music-property simple-element 'duration))
+ (lily-string (format #f "~a~a~a~{~a ~}"
+ (music->lily-string simple-element)
+ (duration->lily-string duration)
+ (if (and ((make-music-type-predicate 'RestEvent) simple-element)
+ (ly:pitch? (ly:music-property simple-element 'pitch)))
+ "\\rest"
+ "")
+ (map-in-order music->lily-string (filter post-event? elements)))))
+ (*previous-duration* duration)
+ lily-string)
+ (let ((chord-elements (filter (make-music-type-predicate
+ 'NoteEvent 'ClusterNoteEvent 'BassFigureEvent)
+ elements))
+ (post-events (filter post-event? elements)))
+ (if (not (null? chord-elements))
+ ;; note_chord_element : '<' (notepitch | drumpitch)* '>" duration post_events
+ (let ((lily-string (format #f "< ~{~a ~}>~a~{~a ~}"
+ (map-in-order music->lily-string chord-elements)
+ (duration->lily-string (ly:music-property (car chord-elements)
+ 'duration))
+ (map-in-order music->lily-string post-events))))
+ (*previous-duration* (ly:music-property (car chord-elements) 'duration))
+ lily-string)
+ ;; command_element
+ (format #f "~{~a ~}" (map-in-order music->lily-string elements))))))))
+
+(define-display-method MultiMeasureRestMusicGroup (mmrest)
+ (format #f "~{~a ~}"
+ (map-in-order music->lily-string
+ (remove (make-music-type-predicate 'BarCheck)
+ (ly:music-property mmrest 'elements)))))
+
+(define-display-method SkipMusic (skip)
+ (format #f "\\skip ~a" (duration->lily-string (ly:music-property skip 'duration) #:force-duration #t)))
+
+;;;
+;;; Notes, rests, skips...
+;;;
+
+(define (simple-note->lily-string event)
+ (format #f "~a~a~a~a~{~a~}" ; pitchname octave !? octave-check articulations
+ (note-name->lily-string (ly:music-property event 'pitch))
+ (octave->lily-string (ly:music-property event 'pitch))
+ (let ((forced (ly:music-property event 'force-accidental))
+ (cautionary (ly:music-property event 'cautionary)))
+ (cond ((and (not (null? forced))
+ forced
+ (not (null? cautionary))
+ cautionary)
+ "?")
+ ((and (not (null? forced)) forced) "!")
+ (else "")))
+ (let ((octave-check (ly:music-property event 'absolute-octave)))
+ (if (not (null? octave-check))
+ (format #f "=~a" (cond ((>= octave-check 0)
+ (make-string (1+ octave-check) #\'))
+ ((< octave-check -1)
+ (make-string (1- (* -1 octave-check)) #\,))
+ (else "")))
+ ""))
+ (map-in-order music->lily-string (ly:music-property event 'articulations))))
+
+(define-display-method NoteEvent (note)
+ (cond ((not (null? (ly:music-property note 'pitch))) ;; note
+ (simple-note->lily-string note))
+ ((not (null? (ly:music-property note 'drum-type))) ;; drum
+ (format #f "~a" (ly:music-property note 'drum-type)))
+ (else ;; unknown?
+ "")))
+
+(define-display-method ClusterNoteEvent (note)
+ (simple-note->lily-string note))
+
+(define-display-method RestEvent (rest)
+ (if (not (null? (ly:music-property rest 'pitch)))
+ (simple-note->lily-string rest)
+ "r"))
+
+(define-display-method MultiMeasureRestEvent (rest)
+ "R")
+
+(define-display-method SkipEvent (rest)
+ "s")
+
+(define-display-method MarkEvent (mark)
+ (let ((label (ly:music-property mark 'label)))
+ (if (null? label)
+ "\\mark \\default"
+ (format #f "\\mark ~a" (markup->lily-string label)))))
+
+(define-display-method MetronomeChangeEvent (tempo)
+ (format #f "\\tempo ~a = ~a"
+ (duration->lily-string (ly:music-property tempo 'tempo-unit) #:force-duration #f #:prev-duration #f)
+ (ly:music-property tempo 'metronome-count)))
+
+(define-display-method KeyChangeEvent (key)
+ (let ((pitch-alist (ly:music-property key 'pitch-alist))
+ (tonic (ly:music-property key 'tonic)))
+ (if (or (null? pitch-alist)
+ (null? tonic))
+ "\\key \\default"
+ (let ((c-pitch-alist (ly:transpose-key-alist pitch-alist
+ (ly:pitch-diff (ly:make-pitch 0 0 0) tonic))))
+ (format #f "\\key ~a \\~a~a"
+ (note-name->lily-string (ly:music-property key 'tonic))
+ (any (lambda (mode)
+ (if (equal? (ly:parser-lookup (*parser*) mode) c-pitch-alist)
+ (symbol->string mode)
+ #f))
+ '(major minor ionian locrian aeolian mixolydian lydian phrygian dorian))
+ (new-line->lily-string))))))
+
+(define-display-method RelativeOctaveCheck (octave)
+ (let ((pitch (ly:music-property octave 'pitch)))
+ (format #f "\\octave ~a~a"
+ (note-name->lily-string pitch)
+ (octave->lily-string pitch))))
+
+(define-display-method VoiceSeparator (sep)
+ "\\\\")
+
+(define-display-method LigatureEvent (ligature)
+ (if (= -1 (ly:music-property ligature 'span-direction))
+ "\\["
+ "\\]"))
+
+(define-display-method BarCheck (check)
+ (format #f "|~a" (new-line->lily-string)))
+
+(define-display-method BreakEvent (br)
+ "\\break") ;; TODO: use page-penalty, penalty properties?
+
+(define-display-method PesOrFlexaEvent (expr)
+ "\\~")
+
+(define-display-method BassFigureEvent (figure)
+ (let ((alteration (ly:music-property figure 'alteration))
+ (fig (ly:music-property figure 'figure))
+ (bracket-start (ly:music-property figure 'bracket-start))
+ (bracket-stop (ly:music-property figure 'bracket-stop)))
+ (format #f "~a~a~a~a"
+ (if (null? bracket-start) "" "[")
+ (if (null? fig)
+ "_"
+ (second fig)) ;; fig: (<number-markup> "number")
+ (if (null? alteration)
+ ""
+ (case alteration
+ ((-4) "--")
+ ((-2) "-")
+ ((0) "!")
+ ((2) "+")
+ ((4) "++")
+ (else "")))
+ (if (null? bracket-stop) "" "]"))))
+
+(define-display-method LyricEvent (lyric)
+ (let ((text (ly:music-property lyric 'text)))
+ (if (or (string? text)
+ (eqv? (first text) simple-markup))
+ ;; a string or a simple markup
+ (let ((string (if (string? text)
+ text
+ (second text))))
+ (if (string-match "(\"| |[0-9])" string)
+ ;; TODO check exactly in which cases double quotes should be used
+ (format #f "~s" string)
+ string))
+ (markup->lily-string text))))
+
+(define-display-method BreathingSignEvent (event)
+ "\\breathe")
+
+;;;
+;;; Staff switches
+;;;
+
+(define-display-method AutoChangeMusic (m)
+ (format #f "\\autochange ~a"
+ (music->lily-string (ly:music-property m 'element))))
+
+(define-display-method ContextChange (m)
+ (format #f "\\change ~a = \"~a\""
+ (ly:music-property m 'change-to-type)
+ (ly:music-property m 'change-to-id)))
+
+;;;
+
+(define-display-method TimeScaledMusic (times)
+ (let* ((num (ly:music-property times 'numerator))
+ (den (ly:music-property times 'denominator))
+ (nd-gcd (gcd num den)))
+ (parameterize ((*force-line-break* #f)
+ (*time-factor-numerator* (/ num nd-gcd))
+ (*time-factor-denominator* (/ den nd-gcd)))
+ (format #f "\\times ~a/~a ~a"
+ num
+ den
+ (music->lily-string (ly:music-property times 'element))))))
+
+(define-display-method RelativeOctaveMusic (m)
+ (music->lily-string (ly:music-property m 'element)))
+
+(define-display-method TransposedMusic (m)
+ (music->lily-string (ly:music-property m 'element)))
+
+;;;
+;;; Repeats
+;;;
+
+(define (repeat->lily-string expr repeat-type)
+ (format #f "\\repeat ~a ~a ~a ~a"
+ repeat-type
+ (ly:music-property expr 'repeat-count)
+ (music->lily-string (ly:music-property expr 'element))
+ (let ((alternatives (ly:music-property expr 'elements)))
+ (if (null? alternatives)
+ ""
+ (format #f "\\alternative { ~{~a ~}}"
+ (map-in-order music->lily-string alternatives))))))
+
+(define-display-method VoltaRepeatedMusic (expr)
+ (repeat->lily-string expr "volta"))
+
+(define-display-method UnfoldedRepeatedMusic (expr)
+ (repeat->lily-string expr "unfold"))
+
+(define-display-method FoldedRepeatedMusic (expr)
+ (repeat->lily-string expr "fold"))
+
+(define-display-method PercentRepeatedMusic (expr)
+ (repeat->lily-string expr "percent"))
+
+(define-display-method TremoloRepeatedMusic (expr)
+ (let* ((count (ly:music-property expr 'repeat-count))
+ (dots (if (= 0 (modulo count 3)) 0 1))
+ (shift (- (log2 (if (= 0 dots)
+ (/ (* count 2) 3)
+ count))))
+ (element (ly:music-property expr 'element))
+ (den-mult 1))
+ (if (eqv? (ly:music-property element 'name) 'SequentialMusic)
+ (begin
+ (set! shift (1- shift))
+ (set! den-mult (length (ly:music-property element 'elements)))))
+ (music-map (lambda (m)
+ (let ((duration (ly:music-property m 'duration)))
+ (if (ly:duration? duration)
+ (let* ((dlog (ly:duration-log duration))
+ (ddots (ly:duration-dot-count duration))
+ (dfactor (ly:duration-factor duration))
+ (dnum (car dfactor))
+ (dden (cdr dfactor)))
+ (set! (ly:music-property m 'duration)
+ (ly:make-duration (- dlog shift)
+ ddots ;;(- ddots dots) ; ????
+ dnum
+ (/ dden den-mult))))))
+ m)
+ element)
+ (format #f "\\repeat tremolo ~a ~a"
+ count
+ (music->lily-string element))))
+
+;;;
+;;; Contexts
+;;;
+
+(define-display-method ContextSpeccedMusic (expr)
+ (let ((id (ly:music-property expr 'context-id))
+ (music (ly:music-property expr 'element))
+ (operations (ly:music-property expr 'property-operations))
+ (ctype (ly:music-property expr 'context-type)))
+ (format #f "~a ~a~a~a ~a"
+ (if (and (not (null? id))
+ (equal? id "$uniqueContextId"))
+ "\\new"
+ "\\context")
+ ctype
+ (if (or (null? id)
+ (equal? id "$uniqueContextId"))
+ ""
+ (format #f " = ~s" id))
+ (if (null? operations)
+ ""
+ (format #f " \\with {~{~a~}~%~v_}"
+ (parameterize ((*indent* (+ (*indent*) 2)))
+ (map (lambda (op)
+ (format #f "~%~v_\\~a ~s"
+ (*indent*)
+ (first op)
+ (second op)))
+ (reverse operations)))
+ (*indent*)))
+ (parameterize ((*current-context* ctype))
+ (music->lily-string music)))))
+
+;; special cases: \figures \lyrics \drums
+(define-extra-display-method ContextSpeccedMusic (expr)
+ (with-music-match (expr (music 'ContextSpeccedMusic
+ context-id "$uniqueContextId"
+ property-operations ?op
+ context-type ?context-type
+ element ?sequence))
+ (if (null? ?op)
+ (parameterize ((*explicit-mode* #f))
+ (case ?context-type
+ ((FiguredBass)
+ (format #f "\\figures ~a" (music->lily-string ?sequence)))
+ ((Lyrics)
+ (format #f "\\lyrics ~a" (music->lily-string ?sequence)))
+ ((DrumStaff)
+ (format #f "\\drums ~a" (music->lily-string ?sequence)))
+ (else
+ #f)))
+ #f)))
+
+;;; Context properties
+
+(define-extra-display-method ContextSpeccedMusic (expr)
+ (let ((element (ly:music-property expr 'element))
+ (property-tuning? (make-music-type-predicate 'PropertySet
+ 'PropertyUnset
+ 'OverrideProperty
+ 'RevertProperty))
+ (sequence? (make-music-type-predicate 'SequentialMusic)))
+ (if (and (ly:music? element)
+ (or (property-tuning? element)
+ (and (sequence? element)
+ (every property-tuning? (ly:music-property element 'elements)))))
+ (parameterize ((*current-context* (ly:music-property expr 'context-type)))
+ (music->lily-string element))
+ #f)))
+
+(define (property-value->lily-string arg)
+ (cond ((ly:music? arg)
+ (music->lily-string arg))
+ ((string? arg)
+ (format #f "#~s" arg))
+ ((markup? arg)
+ (markup->lily-string arg))
+ (else
+ (format #f "#~a" (scheme-expr->lily-string arg)))))
+
+(define-display-method PropertySet (expr)
+ (let ((property (ly:music-property expr 'symbol))
+ (value (ly:music-property expr 'value))
+ (once (ly:music-property expr 'once)))
+ (format #f "~a\\set ~a~a = ~a~a"
+ (if (and (not (null? once)))
+ "\\once "
+ "")
+ (if (eqv? (*current-context*) 'Bottom)
+ ""
+ (format #f "~a . " (*current-context*)))
+ property
+ (property-value->lily-string value)
+ (new-line->lily-string))))
+
+(define-display-method PropertyUnset (expr)
+ (format #f "\\unset ~a~a~a"
+ (if (eqv? (*current-context*) 'Bottom)
+ ""
+ (format #f "~a . " (*current-context*)))
+ (ly:music-property expr 'symbol)
+ (new-line->lily-string)))
+
+;;; Layout properties
+
+(define-display-method OverrideProperty (expr)
+ (let ((symbol (ly:music-property expr 'symbol))
+ (property (ly:music-property expr 'grob-property))
+ (value (ly:music-property expr 'grob-value))
+ (once (ly:music-property expr 'once)))
+ (format #f "~a\\override ~a~a #'~a = ~a~a"
+ (if (or (null? once)
+ (not once))
+ ""
+ "\\once ")
+ (if (eqv? (*current-context*) 'Bottom)
+ ""
+ (format #f "~a . " (*current-context*)))
+ symbol
+ property
+ (property-value->lily-string value)
+ (new-line->lily-string))))
+
+(define-display-method RevertProperty (expr)
+ (let ((symbol (ly:music-property expr 'symbol))
+ (property (ly:music-property expr 'grob-property)))
+ (format #f "\\revert ~a~a #'~a~a"
+ (if (eqv? (*current-context*) 'Bottom)
+ ""
+ (format #f "~a . " (*current-context*)))
+ symbol
+ property
+ (new-line->lily-string))))
+
+;;; \clef
+(define clef-name-alist (map (lambda (name+vals)
+ (cons (cdr name+vals)
+ (car name+vals)))
+ supported-clefs))
+
+(define-extra-display-method ContextSpeccedMusic (expr)
+ "If `expr' is a clef change, return \"\\clef ...\"
+Otherwise, return #f."
+ (with-music-match (expr (music 'ContextSpeccedMusic
+ context-type 'Staff
+ element (music 'SequentialMusic
+ elements ((music 'PropertySet
+ value ?clef-glyph
+ symbol 'clefGlyph)
+ (music 'PropertySet
+ symbol 'middleCPosition)
+ (music 'PropertySet
+ value ?clef-position
+ symbol 'clefPosition)
+ (music 'PropertySet
+ value ?clef-octavation
+ symbol 'clefOctavation)))))
+ (let ((clef-prop+name (assoc (list ?clef-glyph ?clef-position 0)
+ clef-name-alist)))
+ (if clef-prop+name
+ (format #f "\\clef \"~a~{~a~a~}\"~a"
+ (cdr clef-prop+name)
+ (cond ((= 0 ?clef-octavation)
+ (list "" ""))
+ ((> ?clef-octavation 0)
+ (list "^" (1+ ?clef-octavation)))
+ (else
+ (list "_" (- 1 ?clef-octavation))))
+ (new-line->lily-string))
+ #f))))
+
+;;; \time
+(define-extra-display-method ContextSpeccedMusic (expr)
+ "If `expr' is a time signature set, return \"\\time ...\".
+Otherwise, return #f."
+ (with-music-match (expr (music
+ 'ContextSpeccedMusic
+ element (music
+ 'ContextSpeccedMusic
+ context-type 'Timing
+ element (music
+ 'SequentialMusic
+ elements ((music
+ 'PropertySet
+ value ?num+den
+ symbol 'timeSignatureFraction)
+ (music
+ 'PropertySet
+ symbol 'beatLength)
+ (music
+ 'PropertySet
+ symbol 'measureLength)
+ (music
+ 'PropertySet
+ value ?grouping
+ symbol 'beatGrouping))))))
+ (if (null? ?grouping)
+ (format #f "\\time ~a/~a~a" (car ?num+den) (cdr ?num+den) (new-line->lily-string))
+ (format #f "#(set-time-signature ~a ~a '~s)~a"
+ (car ?num+den) (cdr ?num+den) ?grouping (new-line->lily-string)))))
+
+;;; \bar
+(define-extra-display-method ContextSpeccedMusic (expr)
+ "If `expr' is a bar, return \"\\bar ...\".
+Otherwise, return #f."
+ (with-music-match (expr (music
+ 'ContextSpeccedMusic
+ element (music
+ 'ContextSpeccedMusic
+ context-type 'Timing
+ element (music
+ 'PropertySet
+ value ?bar-type
+ symbol 'whichBar))))
+ (format #f "\\bar \"~a\"~a" ?bar-type (new-line->lily-string))))
+
+;;; \partial
+(define (duration->moment ly-duration)
+ (let ((log2 (ly:duration-log ly-duration))
+ (dots (ly:duration-dot-count ly-duration))
+ (num+den (ly:duration-factor ly-duration)))
+ (let* ((m (expt 2 (- log2)))
+ (factor (/ (car num+den) (cdr num+den))))
+ (/ (do ((i 0 (1+ i))
+ (delta (/ m 2) (/ delta 2)))
+ ((= i dots) m)
+ (set! m (+ m delta)))
+ factor))))
+(define moment-duration-alist (map (lambda (duration)
+ (cons (duration->moment duration)
+ duration))
+ (append-map (lambda (log2)
+ (map (lambda (dots)
+ (ly:make-duration log2 dots 1 1))
+ (list 0 1 2 3)))
+ (list 0 1 2 3 4))))
+
+(define (moment->duration moment)
+ (let ((result (assoc (- moment) moment-duration-alist)))
+ (and result
+ (cdr result))))
+
+(define-extra-display-method ContextSpeccedMusic (expr)
+ "If `expr' is a partial measure, return \"\\partial ...\".
+Otherwise, return #f."
+ (with-music-match (expr (music
+ 'ContextSpeccedMusic
+ element (music
+ 'ContextSpeccedMusic
+ context-type 'Timing
+ element (music
+ 'PropertySet
+ value ?moment
+ symbol 'measurePosition))))
+ (let ((duration (moment->duration (/ (ly:moment-main-numerator ?moment)
+ (ly:moment-main-denominator ?moment)))))
+ (and duration (format #f "\\partial ~a" (duration->lily-string duration #:force-duration #t))))))
+
+;;;
+;;;
+
+(define-display-method ApplyOutputEvent (applyoutput)
+ (let ((proc (ly:music-property applyoutput 'procedure))))
+ (format #f "\\applyoutput #~a"
+ (or (procedure-name proc)
+ (with-output-to-string
+ (lambda ()
+ (pretty-print (procedure-source proc)))))))
+
+(define-display-method ApplyContext (applycontext)
+ (let ((proc (ly:music-property applycontext 'procedure))))
+ (format #f "\\applycontext #~a"
+ (or (procedure-name proc)
+ (with-output-to-string
+ (lambda ()
+ (pretty-print (procedure-source proc)))))))
+
+;;; \partcombine
+(define-display-method PartCombineMusic (expr)
+ (format #f "\\partcombine ~{~a ~}"
+ (map-in-order music->lily-string (ly:music-property expr 'elements))))
+
+(define-extra-display-method PartCombineMusic (expr)
+ (with-music-match (expr (music 'PartCombineMusic
+ elements ((music 'UnrelativableMusic
+ element (music 'ContextSpeccedMusic
+ context-id "one"
+ context-type 'Voice
+ element ?sequence1))
+ (music 'UnrelativableMusic
+ element (music 'ContextSpeccedMusic
+ context-id "two"
+ context-type 'Voice
+ element ?sequence2)))))
+ (format #f "\\partcombine ~a~a~a"
+ (music->lily-string ?sequence1)
+ (new-line->lily-string)
+ (music->lily-string ?sequence2))))
+
+(define-display-method UnrelativableMusic (expr)
+ (music->lily-string (ly:music-property expr 'element)))
+
+;;; Cue notes
+(define-display-method QuoteMusic (expr)
+ (or (with-music-match (expr (music
+ 'QuoteMusic
+ quoted-voice-direction ?quoted-voice-direction
+ quoted-music-name ?quoted-music-name
+ quoted-context-id "cue"
+ quoted-context-type 'Voice
+ element ?music))
+ (format #f "\\cueDuring #~s #~a ~a"
+ ?quoted-music-name
+ ?quoted-voice-direction
+ (music->lily-string ?music)))
+ (format #f "\\quoteDuring #~s ~a"
+ (ly:music-property expr 'quoted-music-name)
+ (music->lily-string (ly:music-property expr 'element)))))
+
+;;;
+;;; Lyrics
+;;;
+
+;;; \lyricsto
+(define-display-method LyricCombineMusic (expr)
+ (format #f "\\lyricsto ~s ~a"
+ (ly:music-property expr 'associated-context)
+ (parameterize ((*explicit-mode* #f))
+ (music->lily-string (ly:music-property expr 'element)))))
+
+(define-display-method OldLyricCombineMusic (expr)
+ (format #f "\\oldaddlyrics ~a~a~a"
+ (music->lily-string (first (ly:music-property expr 'elements)))
+ (new-line->lily-string)
+ (music->lily-string (second (ly:music-property expr 'elements)))))
+
+;; \addlyrics
+(define-extra-display-method SimultaneousMusic (expr)
+ (with-music-match (expr (music 'SimultaneousMusic
+ elements ((music 'ContextSpeccedMusic
+ context-id ?id
+ ;;property-operations '()
+ context-type 'Voice
+ element ?note-sequence)
+ (music 'ContextSpeccedMusic
+ context-id "$uniqueContextId"
+ ;;property-operations '()
+ context-type 'Lyrics
+ element (music 'LyricCombineMusic
+ associated-context ?associated-id
+ element ?lyric-sequence)))))
+ (if (string=? ?id ?associated-id)
+ (format #f "~a~a \\addlyrics ~a"
+ (music->lily-string ?note-sequence)
+ (new-line->lily-string)
+ (parameterize ((*explicit-mode* #f))
+ (music->lily-string ?lyric-sequence)))
+ #f)))
+
+
--- /dev/null
+;;; display-lily.scm -- Display music expressions using LilyPond notation
+;;;
+;;;
+;;;
+;;; (c) 2005 Nicolas Sceaux <nicolas.sceaux@free.fr>
+;;;
+
+;;; - This file defines the procedures used to define display methods for each
+;;; music type: define-display-method and define-extra-display-method.
+;;; See scm/define-music-display-methods.scm
+;;; Display methods are stored in the `display-methods' property of each music
+;;; type.
+;;;
+;;; - `display-lily-music' can be called to display a music expression using
+;;; LilyPond notation. `music->lily-string' return a string describing a music
+;;; expression using LilyPond notation.
+;;;
+;;; - `with-music-match' can be used to destructure a music expression, extracting
+;;; some interesting music properties.
+
+
+(define-module (scm display-lily)
+ #:use-module (ice-9 optargs)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-13)
+ #:use-module (srfi srfi-39)
+ #:use-module (lily)
+ #:use-syntax (srfi srfi-39)
+ #:use-syntax (ice-9 optargs))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Display method definition and call
+;;;
+
+
+(define-macro (define-display-method music-type vars . body)
+ "Define a display method for a music type and store it in the
+`display-methods' property of the music type entry found in the
+`music-name-to-property-table' hash table. Print methods previously
+defined for that music type are lost.
+Syntax: (define-display-method MusicType (expression)
+ ...body...))"
+ `(let ((type-props (hashq-ref music-name-to-property-table
+ ',music-type '()))
+ (method (lambda ,vars
+ ,@body)))
+ (set! type-props
+ (assoc-set! type-props 'display-methods (list method)))
+ (hashq-set! music-name-to-property-table
+ ',music-type
+ type-props)
+ method))
+
+(define-macro (define-extra-display-method music-type vars . body)
+ "Add a display method for a music type. A primary display method
+is supposed to have been previously defined with `define-display-method'.
+This new method should return a string or #f. If #f is returned, the next
+display method will be called."
+ `(let* ((type-props (hashq-ref music-name-to-property-table
+ ',music-type '()))
+ (methods (assoc-ref type-props 'display-methods))
+ (new-method (lambda ,vars
+ ,@body)))
+ (set! type-props
+ (assoc-set! type-props
+ 'display-methods
+ (cons new-method methods)))
+ (hashq-set! music-name-to-property-table
+ ',music-type
+ type-props)
+ new-method))
+
+(define* (tag->lily-string expr #:optional (post-event? #f))
+ (let ((tags (ly:music-property expr 'tags)))
+ (cond ((null? tags)
+ "")
+ ((null? (cdr tags))
+ (format #f "~a\\tag #'~a " (if post-event? "-" "") (car tags)))
+ (else
+ (format #f "~a\\tag #'(~a~{ ~a~}) " (if post-event? "-" "") (car tags) (cdr tags))))))
+
+(define-public (music->lily-string expr)
+ "Print expr, a music expression, in LilyPond syntax"
+ (if (ly:music? expr)
+ (let* ((music-type (ly:music-property expr 'name))
+ (procs (assoc-ref (hashq-ref music-name-to-property-table
+ music-type '())
+ 'display-methods))
+ (result-string (and procs (any (lambda (proc)
+ (proc expr))
+ procs))))
+ (if result-string
+ (format #f "~a~a"
+ (tag->lily-string expr (post-event? expr))
+ result-string)
+ (format #f "%{ Print method not implemented for music type ~a %}"
+ music-type)))
+ (format #f "%{ expecting a music expression: ~a %}" expr)))
+
+(define*-public (display-lily-music expr #:key force-duration)
+ (parameterize ((*indent* 0)
+ (*previous-duration* (ly:make-duration 2))
+ (*force-duration* force-duration))
+ (display (music->lily-string expr))
+ (newline)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Music pattern matching
+;;;
+
+(define (var? x)
+ (and (symbol? x) (char=? #\? (string-ref (symbol->string x) 0))))
+
+(define (music? x)
+ (and (pair? x) (eqv? (car x) 'music)))
+
+(define (music-list? x)
+ (and (pair? x)
+ (every music? x)))
+
+(define (music-or-var-list? x)
+ (and (pair? x)
+ (every (lambda (e)
+ (or (music? e) (var? e)))
+ x)))
+
+(define (key-val-list->alist lst)
+ (define (key-val-list->alist-aux lst prev-result)
+ (if (null? lst)
+ prev-result
+ (key-val-list->alist-aux (cddr lst)
+ (cons (cons (first lst) (second lst))
+ prev-result))))
+ (reverse! (key-val-list->alist-aux lst (list))))
+
+(define (gen-condition expr pattern)
+ "Helper function for `with-music-match'.
+Generate an form that checks if the properties of `expr'
+match thoses desscribed in `pattern'."
+ (let* (;; all (property . value) found at the first depth in pattern,
+ ;; including a (name . <Musictype>) pair.
+ (pat-all-props (cons (cons 'name (second pattern))
+ (key-val-list->alist (cddr pattern))))
+ ;; all (property . value) pairs found in pattern, where value is not
+ ;; a ?var, a music expression or a music list.
+ (prop-vals (remove (lambda (kons)
+ (or (var? (cdr kons))
+ (music? (cdr kons))
+ (music-or-var-list? (cdr kons))))
+ pat-all-props))
+ ;; list of (property . element) pairs, where element is a music expression
+ (element-list (filter (lambda (kons) (music? (cdr kons)))
+ pat-all-props))
+ ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a
+ ;; list a music expressions
+ (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons)))
+ pat-all-props)))
+ `(and
+ ;; a form that checks that `expr' is a music expression
+ ;; before actually accessing its properties...
+ (ly:music? ,expr)
+ ;; a form that checks that `expr' properties have the same
+ ;; values as those given in `pattern'
+ ,@(map (lambda (prop-val)
+ (let ((prop (car prop-val))
+ (val (cdr prop-val)))
+ `(and (not (null? (ly:music-property ,expr ',prop)))
+ (equal? (ly:music-property ,expr ',prop) ,val))))
+ prop-vals)
+ ;; build the test condition for each element found in a (property . element) pair.
+ ;; (typically, property will be 'element)
+ ,@(map (lambda (prop-element)
+ (gen-condition `(ly:music-property ,expr ',(car prop-element)) (cdr prop-element)))
+ element-list)
+ ;; build the test conditions for each element found in a (property . (e1 e2 ...)) pair.
+ ;; this requires accessing to an element of a list, hence the index.
+ ;; (typically, property will be 'elements)
+ ,@(map (lambda (prop-elements)
+ (let ((ges (gensym))
+ (index -1))
+ `(and ,@(map (lambda (e)
+ (set! index (1+ index))
+ (if (music? e)
+ (gen-condition `(and (> (length (ly:music-property ,expr ',(car prop-elements)))
+ ,index)
+ (list-ref (ly:music-property ,expr ',(car prop-elements))
+ ,index))
+ e)
+ #t))
+ (cdr prop-elements)))))
+ elements-list))))
+
+(define (gen-bindings expr pattern)
+ "Helper function for `with-music-match'.
+Generate binding forms by looking for ?var symbol in pattern."
+ (let* (;; all (property . value) found at the first depth of pattern,
+ ;; including a (name . <Musictype>) pair.
+ (pat-all-props (cons (cons 'name (second pattern))
+ (key-val-list->alist (cddr pattern))))
+ ;; all (property . ?var) pairs
+ (prop-vars (filter (lambda (kons) (var? (cdr kons)))
+ pat-all-props))
+ ;; list of (property . element) pairs, where element is a music expression
+ (element-list (filter (lambda (kons) (music? (cdr kons)))
+ pat-all-props))
+ ;; list of (property . (e1 e2 ..)) pairs, where (e1 e2 ...) is a
+ ;; list a music expressions
+ (elements-list (filter (lambda (kons) (music-or-var-list? (cdr kons)))
+ pat-all-props)))
+ (append
+ ;; the binding form for the ?var variable found in pattern (first depth).
+ ;; ?var is bound to the value of `expr' property
+ (map (lambda (prop-var)
+ `(,(cdr prop-var) (ly:music-property ,expr ',(car prop-var))))
+ prop-vars)
+ ;; generate bindings for each element found in a (property . element) pair.
+ ;; (typically, property will be 'element)
+ (append-map (lambda (prop-element)
+ (gen-bindings `(ly:music-property ,expr ',(car prop-element))
+ (cdr prop-element)))
+ element-list)
+ ;; generate bindings for each element found in a (property . (e1 e2 ...)) pair
+ ;; (typically, property will be 'elements)
+ (append-map (lambda (prop-elements)
+ (let ((index -1))
+ (append-map (lambda (e)
+ (set! index (1+ index))
+ (if (var? e)
+ `((,e (list-ref (ly:music-property ,expr ',(car prop-elements)) ,index)))
+ (gen-bindings `(list-ref (ly:music-property ,expr ',(car prop-elements))
+ ,index)
+ e)))
+ (cdr prop-elements))))
+ elements-list))))
+
+(define-macro (with-music-match music-expr+pattern . body)
+ "If `music-expr' matches `pattern', call `body'. `pattern' should look like:
+ '(music <MusicType>
+ property value
+ property ?var1
+ element (music <MusicType> ...)
+ elements ((music <MusicType> ...)
+ ?var2
+ (music <MusicType> ...)))
+The properties of `music-expr' are checked against the values given in the
+pattern (the name property being the <MusicType> symbol after the `music'
+keyword), then all music expression found in its properties (such as 'element
+or 'elements).
+When ?var is found instead of a property value, ?var is bound that property value,
+as read inside `music-expr'. ?var may also be used to refere to a whole music
+expression inside an elements list for instance. These bindings are accessible
+inside body."
+ (let ((music-expr (first music-expr+pattern))
+ (pattern (second music-expr+pattern))
+ (expr-sym (gensym)))
+ `(let ((,expr-sym ,music-expr))
+ (if ,(gen-condition expr-sym pattern)
+ (let ,(gen-bindings expr-sym pattern)
+ ,@body)
+ #f))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Special parameters
+;;;
+
+;;; indentation
+(define *indent* (make-parameter 0))
+
+;;; set to #t to force duration printing
+(define *force-duration* (make-parameter #f))
+
+;;; last duration found
+(define *previous-duration* (make-parameter (ly:make-duration 2)))
+
+;;; Set to #t to force a line break with some kinds of expressions (eg sequential music)
+(define *force-line-break* (make-parameter #t))
+(define *max-element-number-before-break* (make-parameter 6))
+
+;; \times factor (used in durations)
+(define *time-factor-denominator* (make-parameter #f))
+(define *time-factor-numerator* (make-parameter #f))
+
+(define *parser* (make-parameter #f))
+
+(define *current-context* (make-parameter 'Bottom))
+
+(define *explicit-mode* (make-parameter #t))
+
+(define (new-line->lily-string)
+ (format #f "~%~v_" (max 0 (1- (*indent*)))))
+
+;;;
+;;; music type predicate maker
+;;;
+
+(define (make-music-type-predicate . music-types)
+ (define ((make-music-type-predicate-aux mtypes) expr)
+ (if (null? mtypes)
+ #f
+ (or (eqv? (car mtypes) (ly:music-property expr 'name))
+ ((make-music-type-predicate-aux (cdr mtypes)) expr))))
+ (make-music-type-predicate-aux music-types))
+
+(load "define-music-display-methods.scm")
\ No newline at end of file
projects / lilypond.git / commitdiff