Hi Kieren, James and all,
I extracted my edition-engraver from lalily. The example compiles here
with 2.18.
You can try this and comment ... I will add more comments to the code,
if this is of interest ;)
The compilation creates a file example.edition.log containing all
edition-engraver paths.
I use this inside lalily. There is always a current "music-path", which
is used to create the path for the engraver. Then the edition-engraver
paths are made by the template in use, so I don't have to deal with them.
HTH
Best, Jan-Peter
On 14.01.2014 14:46, James wrote:
> On 14/01/14 07:17, Jan-Peter Voigt wrote:
>> Hi Kieren and all,
>>
>> I use an engraver for this task, that looks for overrides, sets and
>> clefs at the current measure (of the context consisting this engraver)
>> and at the current moment inside this measure. So this is a little bit
>> different from your example in that it listens during compilation, while
>> your example modifies a music expression /before/ compilation.
>>
>> My intention was the ability to use a pen and mark all grobs to modify
>> on a printed sheet of music - without any links to the source.
>> Now I just write
>>
>> \editionMod <the edition name> <measure> <moment> <engraver-id> {...}
>>
>> and I can switch on and off the edition-overrides as needed.
>> This approach should be able to produce any grob, but beside overrides
>> and sets I have only implemented inserting clefs and TextScript-grobs.
>>
>> To implement a function, that modifies the music expression without
>> compiling means, that you have to know the run of time-signatures. If
>> you don't know that, you don't know when measure X starts.
>> If you have a global variable for all time signatures, you might look
>> for all time-signature-events and accumulate them to produce a
>> skip-expression.
>>
>> addAt =
>> #(define-music-function (parser location music measure moment
>> addition)(ly:music? integer? ly:moment ly:music?)
>> ; ... create myAdd = { \skip #to-measure-moment $addition }
>> ; and return
>> (make-music 'SimultaneousMusic 'elements (list music myAdd))
>> )
>>
>> HTHOIALI (hth or is at least interesting)
>>
>> Cheers,
>> Jan-Peter
>
> Could you give a working .ly example?
>
> It might prove helpful for other users that cannot necessarily
> understand scheme (like me :) )
>
> Also if it compiles on 2.14 then we could add it to the LSR for other
> users.
>
> James
\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 (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"
\addEdition test
% color the notehead red on the second quarter in the second measure
\editionMod test 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 test 1 2/4 my.test.Staff.A \shape #'((0 . 0)(0 . 1)(0 . -1)(0 . 0)) Slur
\layout {
\context {
\Score
\consists \editionEngraver my.test
}
}
\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
