Hi Kieren,
I added a function editionMMod, which takes a list of positions.
Function name and argument order should be chenged ...
For now, the position-list replaces measure and moment.
So
\editionMod FTE-vocalbook 5 0/4 FTE-vocalbook-A.Score.A \break
should be equal to
\editionMMod FTE-vocalbook #'((5 0/4)) FTE-vocalbook-A.Score.A \break
More on that on tuesday.
Best, Jan-Peter
On 01.03.2014 13:36, Kieren MacMillan wrote:
> The other thing that would be very helpful is a listing function, so that
>
> \editionMod FTE-vocalbook 5 0/4 FTE-vocalbook-A.Score.A \break
> \editionMod FTE-vocalbook 9 0/4 FTE-vocalbook-A.Score.A \break
> \editionMod FTE-vocalbook 13 0/4 FTE-vocalbook-A.Score.A \break
> \editionMod FTE-vocalbook 16 0/4 FTE-vocalbook-A.Score.A \break
> \editionMod FTE-vocalbook 22 0/4 FTE-vocalbook-A.Score.A \break
> \editionMod FTE-vocalbook 25 0/4 FTE-vocalbook-A.Score.A \break
> \editionMod FTE-vocalbook 28 0/4 FTE-vocalbook-A.Score.A \pageBreak
> \editionMod FTE-vocalbook 58 0/4 FTE-vocalbook-A.Score.A \pageBreak
> \editionMod FTE-vocalbook 94 0/4 FTE-vocalbook-A.Score.A \pageBreak
> \editionMod FTE-vocalbook 110 0/4 FTE-vocalbook-A.Score.A \pageBreak
> …
>
> could rather be something like
>
> \editionMod FTE-vocalbook FTE-vocalbook-A.Score.A \break ‘((5 0/4) (9
> 0/4) (13 0/4) (16 0/4) (22 0/4) (25 0/4))
> \editionMod FTE-vocalbook FTE-vocalbook-A.Score.A \pageBreak ‘((28 0/4)
> (58 0/4) (94 0/4) (110 0/4))
>
> There are many, many duplicate/multiple tweaks that I would love to apply in
> such a manner.
\version "2.18.0"
\include "util.ily"
#(use-modules (oop goops))
% custom string representation of a moment
#(define-public (moment->string mom)
(if (ly:moment? mom)
(let ((num (ly:moment-main-numerator mom))
(den (ly:moment-main-denominator mom))
(gnum (ly:moment-grace-numerator mom))
(gden (ly:moment-grace-denominator mom)))
(format "(~A/~A~A)" num den
(cond
((> gnum 0)(format "+~A/~A" gnum gden))
((< gnum 0)(format "~A/~A" gnum gden))
(else "")
))
)
"(?:?)"
))
%%%%%%%%%%%%%
% class to store for example \set stanza = "1."
#(define-class <propset> ()
(once #:init-value #t #:accessor is-once #:setter set-once! #:init-keyword
#:once)
(symbol #:accessor get-symbol #:setter set-symbol! #:init-keyword #:symbol)
(value #:accessor get-value #:setter set-value! #:init-keyword #:value)
(previous #:accessor get-previous #:setter set-previous! #:init-value #f)
(context #:accessor get-context #:setter set-context! #:init-keyword
#:context)
)
% apply set to context
#(define-method (do-propset context (prop <propset>))
(if (get-context prop)
(let ((parctx (ly:context-find context (get-context prop))))
(if (ly:context? parctx) (set! context parctx))))
(set-previous! prop (ly:context-property context (get-symbol prop)))
(ly:context-set-property! context (get-symbol prop) (get-value prop))
)
%(export do-propset)
% apply unset to context
#(define-method (reset-prop context (prop <propset>))
(if (get-context prop)
(let ((parctx (ly:context-find context (get-context prop))))
(if (ly:context? parctx) (set! context parctx))))
(ly:context-set-property! context (get-symbol prop) (get-previous prop))
)
%(export reset-prop)
% predicate
#(define-public (propset? p)(is-a? p <propset>))
% serialize to string
#(define-method (propset->string (ps <propset>))
(format "~A\\set ~A = ~A" (if (is-once ps) "once " "") (string-append (if
(get-context ps) (format "~A." (get-context ps)) "") (format "~A" (get-symbol
ps))) (get-value ps)))
%(export propset->string)
% implement display
#(define-method (display (o <propset>) port) (display (propset->string o) port))
%%%%%%%%%%%%%
% store applyContext
#(define-class <apply-context> ()
(proc #:accessor procedure #:setter set-procedure! #:init-keyword #:proc)
)
% apply stored function to context
#(define-method (do-apply ctx (a <apply-context>))
((procedure a) ctx))
%(export do-apply)
% predicate
#(define-public (apply-context? a)(is-a? a <apply-context>))
% store overrides
#(define-class <override> ()
(once #:init-value #t #:accessor is-once #:setter set-once! #:init-keyword
#:once)
(revert #:init-value #f #:accessor is-revert #:setter set-revert!
#:init-keyword #:revert)
(grob #:accessor get-grob #:setter set-grob! #:init-keyword #:grob)
(prop #:accessor get-prop #:setter set-prop! #:init-keyword #:prop)
(value #:accessor get-value #:setter set-value! #:init-keyword #:value)
(context #:accessor get-context #:setter set-context! #:init-keyword
#:context)
)
% serialize to string
#(define-method (oop->string (o <override>))
(let* ((ctxn (get-context o))
(ctxp (if ctxn (format "~A." ctxn) "")))
(if (is-revert o)
(string-append "\\revert " ctxp (format "~A " (get-grob o)) (format
"#'~A" (get-prop o)))
(string-append (if (is-once o) "\\once " "") "\\override " ctxp
(format "~A " (get-grob o)) (format "#'~A" (get-prop o)) " = " (format "~A"
(get-value o)))
)))
%(export oop->string)
% implement display
#(define-method (display (o <override>) port) (display (oop->string o) port))
% predicate
#(define-public (override? o)(is-a? o <override>))
% apply stored override to context
#(define-method (do-override ctx (mod <override>))
(if (get-context mod)
(let ((parctx (ly:context-find ctx (get-context mod))))
(if (ly:context? parctx) (set! ctx parctx))))
(ly:context-pushpop-property ctx (get-grob mod) (get-prop mod) (get-value
mod)))
%(export do-override)
% apply revert to context
#(define-method (do-revert ctx (mod <override>))
(if (get-context mod)
(let ((parctx (ly:context-find ctx (get-context mod))))
(if (ly:context? parctx) (set! ctx parctx))))
(ly:context-pushpop-property ctx (get-grob mod) (get-prop mod)))
%(export do-revert)
%%%%%%%%%%%%%
% stored edition tags
#(define-public (editions) #f)
% set edition tags
#(define-public (set-editions! ed) #f)
% add edition modification
#(define-public (add-edmod edition takt pos path mod) #f)
% create edition engraver with path
#(define-public (edition-engraver tag-path) #f)
% call proc with arg edition-engraver for all active
#(define-public (walk-edition-engravers proc) #f)
% display all stored modifications
#(define-public (display-mods) #f)
% display all registered edition-engraver paths
#(define-public (display-edition) #f)
% find edition-engraver in this or any parent context
#(define-public (context-find-edition-engraver context) #f)
#(define lalily:edition-tags 'lalily:edition-tags)
% now actually implement the needed functions
#(let ((mod-tree (tree-create 'mods))
(edition-list '())
(edition-tree (tree-create 'edition))
(context-count (tree-create 'context)))
(define (o->sym o) (cond ((symbol? o) o) ((string? o) (string->symbol o))
(else (string->symbol (format "~A" o)))))
(set! editions (lambda () (if (list? edition-list) edition-list '())))
(set! set-editions! (lambda (eds) (if (list? eds) (set! edition-list eds)
(ly:error "list expected: ~A" eds))))
(set! add-edmod
(lambda (edition takt pos path modm)
(let* ((edition (if (string? edition) (string->symbol edition)
edition))
(path `(,edition ,takt ,pos ,@path))
(mods (tree-get mod-tree path)))
(if (not (list? mods)) (set! mods '()))
(cond
((ly:music? modm)
(let ((x 0))
(define (add-mods modmus ctx)
(for-some-music
(lambda (m)
(cond
((eq? 'ContextSpeccedMusic (ly:music-property m 'name))
(let* ((ct (ly:music-property m 'context-type))
(elm (ly:music-property m 'element)))
(if (eq? 'Bottom ct)
#f
(begin
(add-mods elm ct)
#t)
)
))
((eq? 'OverrideProperty (ly:music-property m 'name))
(let* ((once (ly:music-property m 'once #f))
(grob (ly:music-property m 'symbol))
(prop (ly:music-property m 'grob-property))
(prop (if (symbol? prop)
prop
(car (ly:music-property m
'grob-property-path))))
(value (ly:music-property m 'grob-value))
(mod (make <override> #:once once #:grob grob
#:prop prop #:value value #:context ctx)))
(set! mods `(,@mods ,mod))
#t
))
((eq? 'RevertProperty (ly:music-property m 'name))
(let* ((grob (ly:music-property m 'symbol))
(prop (ly:music-property m 'grob-property))
(prop (if (symbol? prop)
prop
(car (ly:music-property m
'grob-property-path))))
(mod (make <override> #:once #f #:revert #t
#:grob grob #:prop prop #:value #f #:context ctx)))
(set! mods `(,@mods ,mod))
#t
))
((eq? 'PropertySet (ly:music-property m 'name))
(let* ((once (ly:music-property m 'once #f))
(symbol (ly:music-property m 'symbol))
(value (ly:music-property m 'value))
(mod (make <propset> #:once once #:symbol symbol
#:value value #:context ctx)))
(set! mods `(,@mods ,mod))
#t
))
((eq? 'ApplyContext (ly:music-property m 'name))
(let* ((proc (ly:music-property m 'procedure))
(mod (make <apply-context> #:proc proc)))
(set! mods `(,@mods ,mod))
))
((or
(eq? 'TextScriptEvent (ly:music-property m 'name))
(eq? 'LineBreakEvent (ly:music-property m 'name))
(eq? 'PageBreakEvent (ly:music-property m 'name))
(eq? 'PageTurnEvent (ly:music-property m 'name))
(eq? 'OttavaMusic (ly:music-property m 'name))
(eq? 'PartCombineForceEvent (ly:music-property m
'name))
(eq? 'ExtenderEvent (ly:music-property m 'name))
(eq? 'HyphenEvent (ly:music-property m 'name))
)
(set! mods `(,@mods ,m))
#t
)
(else #f)
)
)
modmus))
(add-mods modm #f)))
((ly:context-mod? modm)(set! mods `(,@mods ,modm)))
)
(tree-set! mod-tree path mods)
#f
)))
(set! edition-engraver
(lambda (tag-path . props)
(let ((eng #f)
(cmf (if (eq? #t tag-path) (get-music-folder)))) ; current
music folder
(define (get-sym c)(string->symbol (base26 c)))
(set! eng (lambda (context)
(let* ((tag-path tag-path)
(tag '())
(barnum 0)
(measurepos (ly:make-moment 0 1))
(get-path (lambda (edition takt pos) `(,edition
,takt ,pos ,@tag)))
(initialize
(lambda (trans)
(if (procedure? tag-path) (set! tag-path
(tag-path)))
(if (not (list? tag-path))
(let ((parent (ly:context-parent
context))
(peng #f))
(define (search-peng path eng)
(if (eqv? (object-property eng
'context) parent)
(set! peng eng)))
(if (ly:context? parent)
(walk-edition-engravers search-peng))
(if peng (set! tag-path
(object-property peng 'tag-path)))
(if (not (list? tag-path))
(set! tag-path (if (list? cmf) cmf
(get-music-folder))))
))
(let* ((cn (ly:context-name context))
(path `(,@tag-path ,(o->sym cn)))
(ccid (tree-get context-count path)))
(define (topctx context)
(let ((par (ly:context-find context
'Score)))
(if (ly:context? par) (topctx par)
context)))
(if (not (integer? ccid))(set! ccid 0))
(tree-set! context-count path (+ ccid 1))
; (ly:message "~A ~A" ccid path)
(set! path `(,@path ,(get-sym ccid)))
(set! tag path)
(tree-set! edition-tree path
(cons eng
(let* ((c context)
(takt (ly:context-property c
'currentBarNumber))
(mpos (ly:context-property c
'measurePosition)))
(cons takt mpos) )))
(set-object-property! eng 'context context)
(set-object-property! eng 'tag-path
tag-path)
(set-object-property! eng 'path path)
; (if (lalily:verbose) (ly:message
"looking for editions in ~A" (glue-list path "/")))
)))
; paper column interface
(paper-column-interface (lambda (engraver grob
source-engraver)
(let ((takt
(ly:context-property context 'currentBarNumber))
(pos
(ly:context-property context 'measurePosition)))
(if (eq? #t
(ly:grob-property grob 'non-musical))
(for-each
(lambda
(edition)
(let* ((path
(get-path edition takt pos))
(mods
(tree-get mod-tree path)))
(if (list?
mods)
(for-each
(lambda (mod)
(cond
((and (ly:music? mod) (eq? 'LineBreakEvent (ly:music-property mod 'name)))
(set! (ly:grob-property grob 'line-break-permission) (ly:music-property mod
'break-permission)))
((and (ly:music? mod) (eq? 'PageBreakEvent (ly:music-property mod 'name)))
(set! (ly:grob-property grob 'page-break-permission) (ly:music-property mod
'break-permission)))
((and (ly:music? mod) (eq? 'PageTurnEvent (ly:music-property mod 'name)))
(set! (ly:grob-property grob 'page-turn-permission) (ly:music-property mod
'break-permission)))
))
mods)))) (editions)))
)))
(start-translation-timestep
(lambda (trans . recall) ; recall from
process-music
(let ((takt (ly:context-property context
'currentBarNumber))
(pos (ly:context-property context
'measurePosition))
(modc '()))
(define (modc+ mod)(set! modc `(,@modc
,mod)))
(set! barnum takt)(set! measurepos pos)
(for-each (lambda (edition)
(let* ((path (get-path edition
takt pos))
(mods (tree-get
mod-tree path)))
;(display path)(display
mods)(newline)
(if (list? mods)
(for-each (lambda (mod)
(cond
((override?
mod)
(if
(is-revert mod)
(do-revert context mod)
(do-override context mod))
(modc+
mod))
((propset?
mod)
(do-propset context mod)
(modc+
mod))
((apply-context? mod)
(do-apply
context mod))
((ly:context-mod? mod)
(ly:context-mod-apply! context mod)
(modc+
mod))
)) mods)
)
)) (editions))
; warning if start-translation-timestep is
not called in first place
(if (and (> (length modc) 0)(> (length
recall) 0) (eq? #t (car recall)))
(begin
(ly:warning "missing @ ~A ~A ~A" takt
pos (glue-list tag "/"))
(for-each (lambda (mod) (ly:warning
"---> ~A" mod)) modc)
))
)))
(stop-translation-timestep
(lambda (trans)
(let ((takt (ly:context-property context
'currentBarNumber))
(pos (ly:context-property context
'measurePosition)))
(for-each (lambda (edition)
(let* ((path (get-path edition
takt pos))
(mods (tree-get
mod-tree path)))
(if (list? mods)
(for-each (lambda (mod)
(cond
((and
(override? mod)(is-once mod))
(do-revert
context mod))
((and
(propset? mod)(is-once mod))
(reset-prop context mod))
))
mods))
)) (editions))
)))
(process-music
(lambda (trans)
(let ((takt (ly:context-property context
'currentBarNumber))
(pos (ly:context-property context
'measurePosition)))
; recall start-translation-timestep, if it
is not called already
(if (or (not (equal? takt barnum))(not
(equal? measurepos pos)))
(start-translation-timestep trans #t))
(for-each (lambda (edition)
(let* ((path (get-path edition
takt pos))
(mods (tree-get
mod-tree path)))
(if (list? mods)
(for-each (lambda (mod)
(cond
((and
(ly:music? mod) (eq? 'TextScriptEvent (ly:music-property mod 'name)))
(let
((grob (ly:engraver-make-grob trans 'TextScript '()))
(text (ly:music-property mod 'text))
(direction (ly:music-property mod 'direction #f)))
(ly:grob-set-property! grob 'text text)
(if
direction (ly:grob-set-property! grob 'direction direction))
))
))
mods))
)) (editions))
)))
(finalize
(lambda (trans)
(if (eq? 'Score (ly:context-name context))
(let* ((takt (ly:context-property
context 'currentBarNumber))
(pos (ly:context-property context
'measurePosition))
(parser (ly:assoc-get 'parser
props #f #f)))
(ly:message "(~A) finalize ~A (~A ~A)"
(glue-list (editions) ", ")
(glue-list tag "/")
takt (if (ly:moment? pos)
(moment->string pos) pos))
(if parser
(let* ((outname
(ly:parser-output-name parser))
(logfile (format
"~A.edition.log" outname)))
(ly:message "writing '~A' ..."
logfile)
(with-output-to-file logfile
(lambda()
(display-edition)
(display "<--- mods
--->")(newline)
(display-mods)
))
))
(set! context-count (tree-create
'context))
))))
)
`(
(initialize . ,initialize)
(acknowledgers
(paper-column-interface .
,paper-column-interface)
)
(start-translation-timestep .
,start-translation-timestep)
(stop-translation-timestep .
,stop-translation-timestep)
(process-music . ,process-music)
(finalize . ,finalize)
))))
eng)))
(set! walk-edition-engravers
(lambda (proc)
(tree-walk edition-tree '() ; walk all
(lambda (path key value)
(proc path (if (pair? value) (car value) value))
) '(empty . #f) '(sort . #f))
))
(set! context-find-edition-engraver
(lambda (context)
(let ((peng #f))
(define (search-peng path eng)
(if (eqv? (object-property eng 'context) context)
(set! peng eng)))
(if (ly:context? context) (walk-edition-engravers search-peng))
peng
)))
(set! display-edition (lambda () (tree-display edition-tree
'(pathsep . " ")
`(vformat . ,(lambda (p) (let ((m (if
(pair? p) (cdr p) p)))
(if (and
(pair? m)(ly:moment? (cdr m)))
(format
"(~A . ~A)" (car m)(moment->string (cdr m)))
(format
"~A" m))
)))
)))
(set! display-mods
(lambda ()
(tree-display mod-tree
'(pathsep . " ")
`(pformat . ,(lambda (v) (cond
((ly:moment? v) (moment->string v))
(else (format "~A" v))
)))
`(vformat . ,(lambda (v)
(if (list? v)
(glue-list (map (lambda (e)
(cond
((ly:music? e)
(format "[M] ~A"
(ly:music-property e 'name))
)
(else (format "~A" e)))) v)
"\n") (format "~A" v)))))))
)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#(define (frac-or-mom? v) (or (fraction? v)(ly:moment? v)))
#(define (music-or-contextmod? v) (or (ly:music? v)(ly:context-mod? v)))
#(define-public editionMod
(define-music-function (parser location edition takt pos path mod)
(string-or-symbol? integer? frac-or-mom? list? music-or-contextmod?)
"Add modification to edition @ measure moment"
(if (fraction? pos)(set! pos (ly:make-moment (car pos)(cdr pos))))
(add-edmod edition takt pos path mod)
(make-music 'SequentialMusic 'void #t))
)
#(define (memom? v)
(and (pair? v)(integer? (car v))
(let ((cv (cdr v)))
(if (list? cv)(set! cv (car cv)))
(or (rational? cv)(frac-or-mom? cv))
)))
#(define (limemom? v)(and (list? v)(every memom? v)))
#(define-public editionMMod
(define-void-function (parser location edition mposl path mod)
(string-or-symbol? limemom? list? music-or-contextmod?)
"Add modification to edition at all positions in mposl"
(for-each
(lambda (p)
(let ((takt (car p))
(pos (cdr p)))
(if (list? pos)(set! pos (car pos)))
(if (fraction? pos)(set! pos (fraction->moment pos)))
(if (rational? pos)
(set! pos (ly:make-moment (numerator pos)(denominator pos))))
(add-edmod edition takt pos path mod)
)) mposl)
))
#(define (list-or-boolean? v) (or (boolean? v)(list? v)(procedure? v)))
#(define-public editionEngraver
(define-scheme-function (parser location tag)(list-or-boolean?)
(edition-engraver tag `(parser . ,parser))))
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
%;;; music functions
% activate edition
#(define-public addEdition
(define-music-function (parser location edition)(string-or-symbol?)
"Add edition to edition-list.
Every edition from the global edition-list will be listened for by the
edition-engraver."
(if (string? edition) (set! edition (string->symbol edition)))
(if (not (memq edition (editions))) (set-editions! `(,@(editions)
,edition)))
(make-music 'SequentialMusic 'void #t)
))
% deactivate edition
#(define-public removeEdition
(define-music-function (parser location edition)(string-or-symbol?)
"Remove edition from edition-list.
Every edition from the global edition-list will be listened for by the
edition-engraver."
(if (string? edition) (set! edition (string->symbol edition)))
(set-editions! (delete edition (editions)))
(make-music 'SequentialMusic 'void #t)
))
% set editions
#(define-public setEditions
(define-void-function (parser location editions)(list?)
"Set edition-list to editions.
Every edition from the global edition-list will be listened for by the
edition-engraver.
This will override the previously set list."
(set-editions! (map (lambda (edition)
(cond
((symbol? edition) edition)
((string? edition) (string->symbol edition))
(else (string->symbol (format "~A" edition)))
)) editions))
))
\version "2.18.0"
\include "edition-engraver.ily"
% color the notehead red on the second quarter in the second measure
\editionMod fullscore 2 1/4 my.test.Staff.A \once \override NoteHead #'color = #red
% destroy the slur starting on the second quarter in the first measure
\editionMod fullscore 1 2/4 my.test.Staff.A \shape #'((0 . 0)(0 . 1)(0 . -1)(0 . 0)) Slur
\editionMMod fullscore #'((2 1/4)) my.test.Score.A { \bar "" \break }
\editionMod fullscore 2 0/4 my.test.Voice.A -\markup { \with-color #red "what's that?" }
\editionMMod fullscore #'((1 1/4)(1 3/4)(2 2/4)) my.test.Staff.A \once \override NoteHead.color = #green
\layout {
\context {
\Score
\consists \editionEngraver my.test
}
}
% edition flightname activated
\addEdition fullscore
\new Staff \with {
\consists \editionEngraver my.test
} <<
\new Voice \with {
\consists \editionEngraver ##f
} \relative c'' { c4 bes a( g) f e d c }
>>
\version "2.18.0"
#(use-modules (oop goops))
#(define-public (base26 i)
"produce a string A, B, ..., Z, AA, AB, ... for numbers
usable to allow 2.17+ list input like in: \\editionMod notes.sop.Voice.A
ATTENTION: there will be no ZZ but YZ -> AAA and YZZ -> AAAA"
(let ((A (char->integer (if (< i 0) #\a #\A)))
(i (if (< i 0) (- -1 i) i)))
(define (baseX x i)
(let ((q (quotient i x))
(r (remainder i x)))
(if (and (> q 0) (< q x))
(list (- q 1) r)
(let ((ret '()))
(if (> q 0) (set! ret (baseX x q)))
`(,@ret ,r))
)))
(list->string
(map
(lambda (d) (integer->char (+ A d)))
(baseX 26 i)))
))
#(define-public (glue-list lst glue)
"create string from list containing arbitrary objects"
(string-join (map (lambda (s) (format "~A" s)) lst) glue 'infix))
#(define-public (glue-symbol lst . glue)
"create symbol from list containig arbitrary objects"
(string->symbol (string-join (map (lambda (s) (format "~A" s)) lst) (if (>
(length glue) 0)(car glue) ":") 'infix)))
%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
%;;; stack
%; a stack implementation with methods push, pop and get
#(define-class <stack> ()
(name #:accessor name #:setter set-name! #:init-value "stack")
(store #:accessor store #:setter set-store! #:init-value '())
)
#(define-method (push (stack <stack>) val)
(set! (store stack) (cons val (store stack))))
#(define-method (get (stack <stack>))
(let ((st (store stack)))
(if (> (length st) 0)
(car st)
#f)))
#(define-method (pop (stack <stack>))
(let ((st (store stack)))
(if (> (length st) 0)
(let ((ret (car st)))
(set! (store stack) (cdr st))
ret)
#f)))
#(define-method (display (stack <stack>) port)
(for-each (lambda (e)
(format #t "~A> " (name stack))(display e)(newline)) (store
stack)))
#(define-public (stack-create)(make <stack>))
%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
%;;; tree
%; a tree implementation
%; every tree-node has a hashtable of children and a value
%; main methods are:
%; tree-set! <tree> path-list val: set a value in the tree
%; tree-get <tree> path-list: get a value from the tree or #f if not present
#(define-class <tree> ()
(children #:accessor children #:init-thunk make-hash-table)
(key #:accessor key #:init-keyword #:key #:init-value 'node)
(value #:accessor value #:setter set-value! #:init-value #f)
)
#(define-method (tree-set! (tree <tree>) (path <list>) val)
(if (= (length path) 0)
(set! (value tree) val)
(let* ((ckey (car path))
(cpath (cdr path))
(child (hash-ref (children tree) ckey))
)
(if (not (is-a? child <tree>))
(begin (set! child (make <tree> #:key ckey))
(hash-set! (children tree) ckey child)
))
(tree-set! child cpath val)
))
val)
#(define-method (tree-merge! (tree <tree>) (path <list>) (proc <procedure>) val)
(let ((ctree (tree-get-tree tree path)))
(if (is-a? ctree <tree>)
(set! (value ctree) (proc (value ctree) val))
(tree-set! tree path (proc #f val)))
))
#(define-method (tree-get-tree (tree <tree>) (path <list>))
(if (= (length path) 0)
tree
(let* ((ckey (car path))
(cpath (cdr path))
(child (hash-ref (children tree) ckey))
)
(if (is-a? child <tree>)
(tree-get-tree child cpath)
#f)
)))
#(define-method (tree-get (tree <tree>) (path <list>))
(let ((ctree (tree-get-tree tree path)))
(if (is-a? ctree <tree>) (value ctree) #f)))
#(define-method (tree-get-from-path (tree <tree>) (path <list>) skey val)
(if (equal? skey (key tree))(set! val (value tree)))
(let ((child (hash-ref (children tree) skey)))
(if (is-a? child <tree>)(set! val (value child))))
(if (= (length path) 0)
val
(let* ((ckey (car path))
(cpath (cdr path))
(child (hash-ref (children tree) ckey))
)
(if (is-a? child <tree>)
(tree-get-from-path child cpath skey val)
val)
)))
#(define-method (tree-get-keys (tree <tree>) (path <list>))
(if (= (length path) 0)
(hash-map->list (lambda (key value) key) (children tree))
(let* ((ckey (car path))
(cpath (cdr path))
(child (hash-ref (children tree) ckey))
)
(if (is-a? child <tree>)
(tree-get-keys child cpath)
#f)
)))
#(define-method (tree-dispatch (tree <tree>) (path <list>) (relative <list>)
def)
(let ((val (value tree)))
(if (= (length path) 0)
(if val (cons '() val)(cons relative def))
(let* ((ckey (car path))
(cpath (cdr path))
(child (hash-ref (children tree) ckey))
)
(if (or val (not (list? relative))) (set! relative '()))
(if val (set! def (value tree)))
(if (is-a? child <tree>)
(tree-dispatch child cpath `(,@relative ,ckey) def)
`((,@relative ,@path) . ,def))
))))
#(define-method (tree-collect (tree <tree>) (path <list>) (vals <stack>))
(let ((val (value tree)))
(if (> (length path) 0)
(let* ((ckey (car path))
(cpath (cdr path))
(child (hash-ref (children tree) ckey))
)
(if (is-a? child <tree>) (tree-collect child cpath vals))
))
(if val (push vals val))
(reverse (store vals))
))
#(define (stdsort p1 p2)
(let ((v1 (car p1))
(v2 (car p2)))
(cond
((and (number? v1) (number? v2)) (< v1 v2))
((and (ly:moment? v1) (ly:moment? v2)) (ly:moment<? v1 v2))
(else (string-ci<? (format "~A" v1) (format "~A" v2)))
)))
#(define-method (tree-walk (tree <tree>) (path <list>) (callback <procedure>) .
opts)
(let ((dosort (assoc-get 'sort opts))
(sortby (assoc-get 'sortby opts stdsort))
(doempty (assoc-get 'empty opts)))
(if (or doempty (value tree))
(callback path (key tree) (value tree)))
(for-each (lambda (p)
(tree-walk (cdr p) `(,@path ,(car p)) callback `(sort .
,dosort) `(sortby . ,sortby) `(empty . ,doempty)))
(if dosort (sort (hash-table->alist (children tree)) sortby)
(hash-table->alist (children tree)) ))
))
#(define-method (tree-walk-branch (tree <tree>) (path <list>) (callback
<procedure>) . opts)
(let ((dosort (assoc-get 'sort opts))
(sortby (assoc-get 'sortby opts stdsort))
(doempty (assoc-get 'empty opts))
(ctree (tree-get-tree tree path)))
(if (is-a? ctree <tree>)
(tree-walk ctree path callback `(sort . ,dosort) `(sortby . ,sortby)
`(empty . ,doempty)))
))
#(define-public (tree-display tree . opt)
(let ((path (ly:assoc-get 'path opt '() #f))
(dosort (ly:assoc-get 'sort opt #t #f))
(sortby (assoc-get 'sortby opt stdsort))
(empty (ly:assoc-get 'empty opt #f #f))
(dval (ly:assoc-get 'value opt #t #f))
(vformat (ly:assoc-get 'vformat opt (lambda (v)(format "~A" v)) #f))
(pformat (ly:assoc-get 'pformat opt (lambda (v)(format "~A" v)) #f))
(pathsep (ly:assoc-get 'pathsep opt "/" #f))
(port (ly:assoc-get 'port opt (current-output-port))))
(tree-walk-branch tree path
(lambda (path k val)
(format #t "[~A] ~A" (key tree) (string-join (map pformat path) pathsep
'infix) port)
(if (and dval val) (begin
(display ": " port)
(display (vformat val) port)
))
(newline port)
) `(sort . ,dosort) `(sortby . ,sortby) `(empty . ,empty) )
))
#(define-public (tree->string tree . opt)
(call-with-output-string
(lambda (port)
(apply tree-display tree (assoc-set! opt 'port port))
)))
#(define-method (display (tree <tree>) port)
(let ((tkey (key tree)))
(tree-display tree)))
#(define-public (tree? tree)(is-a? tree <tree>))
#(define-public (tree-create . key)
(let ((k (if (> (length key) 0)(car key) 'node)))
(make <tree> #:key k)
))
_______________________________________________
lilypond-devel mailing list
lilypond-devel@gnu.org
https://lists.gnu.org/mailman/listinfo/lilypond-devel
