[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
\displayLilyMusic -- continued
|
From: |
Nicolas Sceaux |
|
Subject: |
\displayLilyMusic -- continued |
|
Date: |
Fri, 15 Jul 2005 20:34:34 +0200 |
|
User-agent: |
Gnus/5.11 (Gnus v5.11) Emacs/22.0.50 (darwin) |
Here is a patch for \displayLilyMusic, plus three new files (I don't
know if I can make them appear directly in the patch?)
- scm/display-lily.scm contains the code that makes it possible to
define display methods;
- in scm/define-music-display-methods.scm the methods are actually
defined for each music type;
- input/regression/display-lily-tests.ly contains the regression tests
(should be pretty complete, but eh...);
- ly/music-functions-init.ly has a new definition: \displayLilyMusic,
which acts like \displayMusic;
- scm/lily.scm loads the new scheme files;
- scm/markups.scm: an obsolete debug function (for displaying markups)
is removed. One can use \displayLilyMusic instead (with \mark for
instance)
In addition, (display-lily-init parser) could called somewhere in a .ly
init file.
nicolas
? input/regression/display-lily-tests.ly
? scm/define-music-display-methods.scm
? scm/display-lily.scm
Index: ly/music-functions-init.ly
===================================================================
RCS file: /cvsroot/lilypond/lilypond/ly/music-functions-init.ly,v
retrieving revision 1.29
diff -u -r1.29 music-functions-init.ly
--- ly/music-functions-init.ly 8 Jul 2005 21:34:52 -0000 1.29
+++ ly/music-functions-init.ly 15 Jul 2005 18:01:18 -0000
@@ -47,6 +47,13 @@
#(def-music-function (parser location music) (ly:music?)
(display-scheme-music music)
music)
+
+displayLilyMusic =
+#(def-music-function (parser location music) (ly:music?)
+ (display-lily-init parser)
+ (display-lily-music music)
+ music)
+
applyoutput =
#(def-music-function (parser location proc) (procedure?)
(make-music 'ApplyOutputEvent
Index: scm/lily.scm
===================================================================
RCS file: /cvsroot/lilypond/lilypond/scm/lily.scm,v
retrieving revision 1.370
diff -u -r1.370 lily.scm
--- scm/lily.scm 13 Jul 2005 18:22:35 -0000 1.370
+++ scm/lily.scm 15 Jul 2005 18:01:18 -0000
@@ -246,6 +246,9 @@
"backend-library.scm"
"x11-color.scm"
+ "display-lily.scm"
+ "define-music-display-methods.scm"
+
;; must be after everything has been defined
"safe-lily.scm"))
Index: scm/markup.scm
===================================================================
RCS file: /cvsroot/lilypond/lilypond/scm/markup.scm,v
retrieving revision 1.6
diff -u -r1.6 markup.scm
--- scm/markup.scm 1 Jun 2005 14:26:13 -0000 1.6
+++ scm/markup.scm 15 Jul 2005 18:01:19 -0000
@@ -221,43 +221,6 @@
(else (values (car expr) (cdr expr)))))
;;;;;;;;;;;;;;;
-;;; Debugging utilities: print markup expressions in a friendly fashion
-
-(use-modules (ice-9 format))
-(define (markup->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 ((and (pair? arg) (pair? (car arg))) ;; markup list
- (format #f "~{ ~a~}" (map markup->string arg)))
- ((pair? arg) ;; markup
- (markup->string arg))
- ((string? arg) ;; scheme string argument
- (format #f "#\"~a\"" arg))
- (else ;; other scheme arg
- (format #f "#~a" arg))))
- (let ((cmd (car markup-expr))
- (args (cdr markup-expr)))
- (cond ((eqv? cmd simple-markup) ;; a simple string
- (format #f "\"~a\"" (car args)))
- ((eqv? cmd line-markup) ;; { ... }
- (format #f "{~a}" (arg->string (car args))))
- ((eqv? cmd center-align-markup) ;; \center < ... >
- (format #f "\\center-align <~a>" (arg->string (car args))))
- ((eqv? cmd column-markup) ;; \column < ... >
- (format #f "\\column <~a>" (arg->string (car args))))
- (else ;; \command ...
- (format #f "\\~a~{ ~a~} " (proc->command cmd) (map arg->string
args))))))
-
-(define-public (display-markup markup-expr)
- "Print a LilyPond-syntax equivalent for the given markup expression."
- (display "\\markup ")
- (display (markup->string markup-expr)))
-
-;;;;;;;;;;;;;;;
;;; Utilities for storing and accessing markup commands signature
;;; and keyword.
;;; Examples:
;;; define-music-display-methods.scm -- data for displaying music
;;; expressions using LilyPond notation.
;;;
;;; (c) 2005 Nicolas Sceaux <address@hidden>
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Display method implementation
;;;
;;;
;;; 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 (pitch= pitch1 pitch2)
(and (= (ly:pitch-notename pitch1) (ly:pitch-notename pitch2))
(= (ly:pitch-alteration pitch1) (ly:pitch-alteration pitch2))))
(define (note-name->lily-string ly-pitch)
(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= lydur1 lydur2)
(and (= (ly:duration-log lydur1) (ly:duration-log lydur2))
(= (ly:duration-dot-count lydur1) (ly:duration-dot-count lydur2))
(equal? (ly:duration-factor lydur1) (ly:duration-factor lydur2))))
(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 (duration= 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 (eqv? (first text) simple-markup) ;; a simple markup
(let ((string (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)
;; TODO: do something with the split-list property?
(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)))
;;; display-lily.scm -- Display music expressions using LilyPond notation
;;;
;;;
;;;
;;; (c) 2005 Nicolas Sceaux <address@hidden>
;;;
;;; - 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 properties.
;;;
;;; - `display-lily-init' must be called before using `display-lily-music'. It
;;; takes a parser object as an argument.
(use-modules (ice-9 optargs)
(ice-9 format)
(ice-9 regex)
(ice-9 pretty-print)
(srfi srfi-1)
(srfi srfi-13)
(srfi srfi-39))
;;(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*)))))
(define-public (display-lily-init parser)
(*parser* parser)
(set-note-names! (ly:parser-lookup (*parser*) 'pitchnames))
#t)
;;;
;;; 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))
\version "2.7.0"
#(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 } #]
}
- \displayLilyMusic -- continued,
Nicolas Sceaux <=