Nested context properties -- an implementation sketch

[David Kastrup]

Ok, so I have been trying to get a hold on the nested context property
thing.  The main issue is getting a grip of how to update stuff on
removal.  With regard to nested context properties, an update further
down in the nested property alist can have repercussions further up if
some parts of the lower hierarchies have been used in setting up a
nested context property alist further up in the hierarchy.

There are basically two approaches I see possible for dealing with this:
a) when removing a higher-level property further down in the stack,
replace its conses, possibly consulted further up, with copies of the
next property lower down in the stack.  But if I have set a property 'x
with a value ((y . ((z . 4)))), then the property handler has no
business overwriting the internals of my property just because he copied
them for filling in the blanks when setting a nested property (x y c).

b) update stuff further up the stack.

I've implemented this as Scheme for experimenting with, probably with
bugs remaining.

Other key elements:
A revert will _only_ match an override with the _same_ signature, the
signature consisting of the state of the \once flag as well as the full
property path.

This makes sure that unexpected pairings of reverts with overrides will
be kept to a minimum.  \once\override will _not_ register the old value
of the setting.  Instead, every not-yet cancelled \once will get
cancelled at the end of the time step.

I don't think that anything close to a sensible implementation can be
significantly simpler or significantly more efficient.  There are some
things that may be nicer to do in C, and some shortcuts that may be
taken.  But as a functional sketch, this should more or less be what it
takes.

I don't think we can get this much cheaper.

;; Plan: context contains, in contrast to the current Lilypond
;; implementation, an additional source list for context overrides
;; corresponding to the cache list member by member.  The source list
;; stops with the last override in the context and does not continue
;; into parenting contexts.
;;
;; In this file, this list is titled "source" and the actual override
;; list is titled "cache".  "source" is not really the most accurate
;; description since it merely contains _additional_ data.
;;
;; Structure of "context" (only changed destructively).
;;   car   ->  parenting context or #f
;;   cadr  ->  source
;;   cddr  ->  list head for contexts as currently existing:
;;   caddr ->  cache, the property list for this context including
;;             parents
;;   cdddr ->  tail.  The cache is only valid if the cache of the
;;             parent is valid and eq to this context's tail.
;;
;; Structure of source: a list exactly as long as the list reaching
;; from cache inclusively to tail exclusively, and associated 1:1 with
;; the respective list elements.  Each element of source has the
;; following parts:
;;   car   ->  records whether this property was entered with \once or
;;             not.
;;   cdr   ->  length of nested property path.  After this many cdar
;;             calls on the property alist, you reach the set value of
;;             the nested property.  All other content of the property
;;             alist entry is taken from other alist entries.
;;
;; The cache is never changed destructively, instead new copies are
;; created for changes.  Any parts of the cache that are eq to some
;; part of the structure at an arbitrary different point of time, are
;; for this reason unchanged.

(use-modules (ice-9 optargs) (srfi srfi-1) (srfi srfi-2))
(use-modules (ice-9 debug))

(define* (make-context #:optional parent)
  (cons parent (cons '() (cons '() (if parent (caddr parent) '())))))


(define (updatecache source oldcache newcache)
  "updatecache should be called with
 (fold-right updatecache cachetail oldcachelist sourcelist)
cachetail contains the new tail for the cache which has lost
sync with the previous cache."
  (let loop ((depth (cdr source))
             (oldcache oldcache)
             (newcache newcache))
    (if (zero? depth)
        ;; entry is the original data entry in this list without copied
        ;; material so we just cons it up and continue.
        (cons oldcache newcache)
        ;; Now we may need to update a nested property override.  This
        ;; is tricky.  The property (car oldcache)'s nested property
        ;; list (cdr oldcache) starts with an override in the first
        ;; position (cadr oldcache) followed by the top level
        ;; original nested list (cddr oldcache).  If the original for
        ;; the copied nested list has remained eq, the whole entry can
        ;; stay the way it is.  If we had a sibling override, we need
        ;; not copy the whole depth of the recursion but only up to
        ;; the level where the chain is again intact.  So we can solve
        ;; this problem in a recursive manner.  Don't even dream of
        ;; using ly:assoc-get here: strict eq is vital for getting
        ;; this right.
        ;;
        ;; We don't let non-lists leak into the copied property list
        ;; structures: those appear as empty lists in order not to
        ;; mess up the data structures.
        (let* ((newprop (assq-ref newcache (car oldcache)))
               (oldprop (cddr oldcache)))
          (if (not (pair? newprop))
              (set! newprop '()))
          (if (eq? newprop oldprop)
              (cons oldcache newcache)
              ;; The original nested list has changed, so we need to
              ;; splice together a new copy based on the newly found
              ;; current original.
              (acons (car oldcache)
                     (loop (1- depth) (cadr oldcache) newprop)
                     newcache))))))


(define (updated-context context)
  "Make sure that the tail of this context corresponds to an updated
parent context.  If it doesn't, update the tail as well as all copies
to nested properties in this context's alist.  Returns a valid
cache alist."
  (if context
      (let ((tail (updated-context (car context))))
        (if (not (eq? (cdddr context) tail))
            (begin
              (set-cdr! (cddr context) tail)
              (set-car! (cddr context)
                        (fold-right updatecache
                                    tail
                                    (cadr context)
                                    (caddr context)))))
        (caddr context))
      '()))

(define (get-property context . property-path)
  (fold (lambda (a b)
          (let ((found (assq a b)))
            (if found (cdr found) '())))
        (updated-context context)
        property-path))

(define (push-property once value context property . property-path)
  (set-car! (cdr context)
            (acons once (length property-path) (cadr context)))
  (set-car! (cddr context)
            (let loop ((alist (updated-context context))
                       (property property)
                       (property-path property-path))
              (acons
               property
               (if (null? property-path)
                   value
                   (loop (let ((ref (assq-ref alist property)))
                           (if (pair? ref) ref '()))
                         (car property-path)
                         (cdr property-path)))
               alist))))

(define (property-path-match? cache property property-path)
  (and (eq? (car cache) property)
       (or (null? property-path)
           (property-path-match?
            (cadr cache) (car property-path) (cdr property-path)))))

(use-modules (ice-9 receive))

(define (pop-property once context property . property-path)
  (let* ((depth (length property-path))
         (found
          (list-index (lambda (source cache)
                        (and (eq? once (car source))
                             (= depth (cdr source))
                             (property-path-match? cache
                                                   property property-path)))
                      (cadr context) (updated-context context))))
    (if found
        (begin
          (receive (head tail)
                   (split-at! (caddr context) found)
                   (set-car! (cddr context) (fold-right updatecache
                                                        (cdr tail)
                                                        (cadr context)
                                                        head)))
          (receive (head tail)
                   (split-at! (cadr context) found)
                   (set-car! (cdr context)
                             (append! head (cdr tail))))))))



  
;; Ok, this is quite too cons-intensive, but you get the drift.  We walk
;; the source pairs, throwing away those marked as "once" together
;; with the corresponding cache pairs.  An efficient implementation
;; would be careful to keep a common tail so that the lists would not
;; change at all in the absence of "once" overrides.

(define (clean-of-once context)
  (let loop ((sources '())
             (caches '())
             (source (cadr context))
             (cache (updated-context context)))
    (let ((found (list-index car source)))
      (if found
          (receive (shead stail)
                   (split-at! source found)
                   (receive (chead ctail)
                            (split-at! cache found)
                            (loop (cons shead sources)
                                  (cons chead caches)
                                  (cdr stail)
                                  (cdr ctail))))
          (if sources
              (begin
                (set! sources (concatenate! (reverse! sources)))
                (set-car! (cddr context)
                          (fold-right updatecache
                                      cache
                                      sources
                                      (concatenate! (reverse! caches))
                (set-car! (cdr context)
                          (append! sources source))))))))))
                
       
(define-macro (niceeval . explist)
  (cons 'begin
        (map (lambda (expr)
               `(format #t "~s =>~a\n" ',expr
                        (let ((x ,expr))
                          (if (eq? x (begin)) ""
                              (format #f " ~s" x)))))
             explist)))
     

(niceeval
(define StaffGroup (make-context))
(define Staff (make-context StaffGroup))
(define Voice (make-context Staff))
(push-property #f 3 StaffGroup 'x 'y 'z)
(push-property #f '((z . 5)) Voice 'x 'y)
(get-property Voice 'x 'y)
(get-property Voice 'x)
(pop-property #f StaffGroup 'x 'y 'z)
(get-property Voice 'x)
(push-property #f 7 StaffGroup 'x)
(get-property Voice 'x 'y)
(get-property Voice 'x)
(push-property #f 2 Staff 'x 'y)
(get-property Voice)
(pop-property #f Voice 'x 'y)
(get-property Voice 'x)
(push-property #t 13 Voice 'x 'y 'z)
(get-property Voice)
(clean-of-once Voice)
(get-property Voice)
)


-- 
David Kastrup