From 14dfbf5b4561d3de6574a27b74f859f7235c6375 Mon Sep 17 00:00:00 2001 From: Nicolas Sceaux Date: Fri, 22 Jul 2005 18:39:34 +0000 Subject: [PATCH] * scm/display-lily.scm: new file. Define a `display-lily-music' function, that displays the music expression given as an argument, using LilyPond notation. * scm/define-music-display-methods.scm: new file. Implementation of display methods for each music type. * input/regression/display-lily-tests.ly: new regression test file for `display-lily-music'. --- input/regression/display-lily-tests.ly | 257 ++++++ scm/define-music-display-methods.scm | 1078 ++++++++++++++++++++++++ scm/display-lily.scm | 310 +++++++ 3 files changed, 1645 insertions(+) create mode 100644 input/regression/display-lily-tests.ly create mode 100644 scm/define-music-display-methods.scm create mode 100644 scm/display-lily.scm diff --git a/input/regression/display-lily-tests.ly b/input/regression/display-lily-tests.ly new file mode 100644 index 0000000000..369e338fda --- /dev/null +++ b/input/regression/display-lily-tests.ly @@ -0,0 +1,257 @@ +\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 } #] +} + diff --git a/scm/define-music-display-methods.scm b/scm/define-music-display-methods.scm new file mode 100644 index 0000000000..7dba2143dd --- /dev/null +++ b/scm/define-music-display-methods.scm @@ -0,0 +1,1078 @@ +;;; define-music-display-methods.scm -- data for displaying music +;;; expressions using LilyPond notation. +;;; +;;; (c) 2005 Nicolas Sceaux +;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; 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") + (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))) + + diff --git a/scm/display-lily.scm b/scm/display-lily.scm new file mode 100644 index 0000000000..a19a3f7974 --- /dev/null +++ b/scm/display-lily.scm @@ -0,0 +1,310 @@ +;;; display-lily.scm -- Display music expressions using LilyPond notation +;;; +;;; +;;; +;;; (c) 2005 Nicolas Sceaux +;;; + +;;; - 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 . ) 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 . ) 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 + property value + property ?var1 + element (music ...) + elements ((music ...) + ?var2 + (music ...))) +The properties of `music-expr' are checked against the values given in the +pattern (the name property being the 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 -- 2.39.5