From 2e67feee6d4712e7c3d00a14a90b3c894b6890a8 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 6 Apr 2018 11:37:59 +0100 Subject: [PATCH] POC imperative dataspace implementation, with set-box example --- syndicate/bag.rkt | 32 +++ syndicate/dataspace.rkt | 448 ++++++++++++++++++++++++++++++++++++++++ syndicate/pattern.rkt | 13 +- syndicate/skeleton.rkt | 355 +++++++++++++++++++++++++++++++ 4 files changed, 842 insertions(+), 6 deletions(-) create mode 100644 syndicate/bag.rkt create mode 100644 syndicate/dataspace.rkt create mode 100644 syndicate/skeleton.rkt diff --git a/syndicate/bag.rkt b/syndicate/bag.rkt new file mode 100644 index 0000000..c374e0a --- /dev/null +++ b/syndicate/bag.rkt @@ -0,0 +1,32 @@ +#lang racket/base +;; Bags and Deltas (which are Bags where item-counts can be negative). + +(provide make-bag + bag-change! + bag-ref + bag-clear! + in-bag) + +;; A `(Bagof X)` is a `(MutableHash X Nat)`, where the `Nat` against +;; an `X` is its replication count in the bag. +;; +;; A `(Deltaof X)` is a `(MutableHash X Int)`, just like a `(Bagof X)` +;; except the replication counts can be negative. + +(define make-bag make-hash) + +(define (bag-change! b x delta) + (define old-count (bag-ref b x)) + (define new-count (+ old-count delta)) + (if (zero? new-count) + (begin (hash-remove! b x) + (if (zero? old-count) 'absent->absent 'present->absent)) + (begin (hash-set! b x new-count) + (if (zero? old-count) 'absent->present 'present->present)))) + +(define (bag-ref b x) + (hash-ref b x 0)) + +(define bag-clear! hash-clear!) + +(define-syntax-rule (in-bag piece ...) (in-hash piece ...)) diff --git a/syndicate/dataspace.rkt b/syndicate/dataspace.rkt new file mode 100644 index 0000000..9b65463 --- /dev/null +++ b/syndicate/dataspace.rkt @@ -0,0 +1,448 @@ +#lang racket/base + +(require syndicate/functional-queue) +(require syndicate/dataflow) +(require racket/match) +(require racket/set) + +(module+ test (require rackunit)) + +(require "skeleton.rkt") +(require "pattern.rkt") +(require "bag.rkt") + +;; A `FID` is a Facet ID, uniquely identifying both a facet and its +;; ancestry in a `Dataspace`. +;; +;; FID = (Listof Nat) +;; +;; The first `Nat` in the list is the unique identifier for this +;; facet; the `cdr` of the list is the FID of its parent facet. No two +;; `FID`s in a `Dataspace` have the same first `Nat`. + +;; A `Dataspace` is a ... TODO + +;; An `Action` is either `(patch (Deltaof Assertion))` or `(message +;; Assertion)` or `(spawn BootProc)`. +(struct patch (changes) #:prefab) +(struct message (body) #:prefab) +(struct spawn (boot-proc) #:prefab) + +(struct dataspace ([next-id #:mutable] ;; Nat + routing-table ;; Skeleton + facets ;; (MutableHash FID Facet) + actors ;; (MutableSetof FID) + assertions ;; (Bagof Assertion) + dataflow ;; DataflowGraph + pending-scripts ;; (MutableVectorof (Queueof (-> Any))) + [pending-actions #:mutable] ;; (Queueof Action) + ) + #:transparent) + +(struct facet (id ;; FID + endpoints ;; (MutableHash EID Endpoint) + [stop-scripts #:mutable] ;; (Listof Script) -- IN REVERSE ORDER + [children #:mutable] ;; (Setof FID) + ) + #:transparent) + +(struct endpoint (id ;; EID + [assertion #:mutable] ;; Assertion + assertion-fn ;; (-> Assertion) + handler ;; (Option SkInterest) + ) + #:transparent) + +;; TODO: field ownership: record actor (root facet) ID in field, check +;; it on access. +(struct field-handle (name ;; Symbol + id ;; Nat + owner ;; FID + [value #:mutable] ;; Any + ) + #:methods gen:custom-write + [(define (write-proc f port mode) + (fprintf port "#" (field-handle-name f) (field-handle-id f)))] + #:property prop:procedure + (case-lambda + [(f) + (dataflow-record-observation! (dataspace-dataflow (current-dataspace)) f) + (field-handle-value f)] + [(f v) + (dataflow-record-damage! (dataspace-dataflow (current-dataspace)) f) + (set-field-handle-value! f v)])) + +;; Parameterof Dataspace +(define current-dataspace (make-parameter #f)) + +;; Parameterof FID +(define current-actor (make-parameter #f)) + +;; Parameterof FID +(define current-facet-id (make-parameter #f)) + +;; Parameterof Facet +(define current-facet (make-parameter #f)) + +;; Parameterof Boolean +(define in-script? (make-parameter #t)) + +;;--------------------------------------------------------------------------- + +;; Script priorities. These are used to ensure that the results of +;; some *side effects* are visible to certain pieces of code. + +(module priorities racket/base + (require (for-syntax racket/base)) + + (define-syntax (define-priority-levels stx) + (let loop ((counter 0) (stx (syntax-case stx () + [(_ level ...) #'(level ...)]))) + (syntax-case stx () + [() + #'(void)] + [(#:count c) + #`(begin (define c #,counter) + (provide c))] + [(this-level more ...) + #`(begin (define this-level #,counter) + (provide this-level) + #,(loop (+ counter 1) #'(more ...)))]))) + + (define-priority-levels ;; highest-priority to lowest-priority + *query-priority-high* + *query-priority* + *query-handler-priority* + *normal-priority* + *gc-priority* + *idle-priority* + #:count priority-count)) + +(require (submod "." priorities)) + +;;--------------------------------------------------------------------------- + +(define (make-dataspace) + (dataspace 0 + (make-empty-skeleton) + (make-hash) + (mutable-set) + (make-bag) + (make-dataflow-graph) + (make-vector priority-count (make-queue)) + (make-queue))) + +(define (generate-id! ds) + (let ((id (dataspace-next-id ds))) + (set-dataspace-next-id! ds (+ id 1)) + id)) + +(define (fid-parent fid) + (cdr fid)) + +(define (generate-fid! ds parent-fid) + (cons (generate-id! ds) parent-fid)) + +(define (actor-fid? fid) + (null? (fid-parent fid))) + +(define (add-actor! ds boot-proc) + (define actor-fid (generate-fid! ds '())) + (set-add! (dataspace-actors ds) actor-fid) + (add-facet! ds actor-fid actor-fid boot-proc)) + +(define (lookup-facet ds fid) + (hash-ref (dataspace-facets ds) fid #f)) + +(define-syntax-rule (with-current-facet [ds actor-fid fid f script?] body ...) + (parameterize ((current-dataspace ds) + (current-actor actor-fid) + (current-facet-id fid) + (current-facet f) + (in-script? script?)) + body ...)) + +(define (capture-facet-context proc) + (let ((ds (current-dataspace)) + (actor-fid (current-actor)) + (fid (current-facet-id)) + (f (current-facet))) + (lambda args + (with-current-facet [ds actor-fid fid f #t] + (apply proc args))))) + +(define (pop-next-script! ds) + (define priority-levels (dataspace-pending-scripts ds)) + (let loop ((level 0)) + (and (< level (vector-length priority-levels)) + (let ((q (vector-ref priority-levels level))) + (if (queue-empty? q) + (loop (+ level 1)) + (let-values (((script q) (dequeue q))) + (vector-set! priority-levels level q) + script)))))) + +(define (run-all-pending-scripts! ds) + (define script (pop-next-script! ds)) + (and script + (begin (script) + (dataflow-repair-damage! (dataspace-dataflow ds) + (lambda (subject-id) + (match-define (list fid eid) subject-id) + (define f (lookup-facet ds fid)) + (when f + (define ep (hash-ref (facet-endpoints f) eid)) + (define old-assertion (endpoint-assertion ep)) + (define new-assertion ((endpoint-assertion-fn ep))) + (when (not (equal? old-assertion new-assertion)) + (set-endpoint-assertion! ep new-assertion) + (dataspace-retract! ds old-assertion) + (dataspace-assert! ds new-assertion) + (define h (endpoint-handler ep)) + (when h + (dataspace-unsubscribe! ds h) + (dataspace-subscribe! ds h)))))) + (run-all-pending-scripts! ds)))) + +(define (perform-pending-actions! ds) + (define actions (queue->list (dataspace-pending-actions ds))) + (set-dataspace-pending-actions! ds (make-queue)) + (for [(action actions)] + (match action + [(patch delta) + (for [((a count) (in-bag delta))] + (match (bag-change! (dataspace-assertions ds) a count) + ['present->absent (remove-assertion! (dataspace-routing-table ds) a)] + ['absent->present (add-assertion! (dataspace-routing-table ds) a)] + ;; 'absent->absent absurd + ['present->present (void)]))] ;; i.e. no visible change + [(message body) + (send-assertion! (dataspace-routing-table ds) body)] + [(spawn boot-proc) + (add-actor! ds boot-proc)])) + (not (null? actions))) + +(define (run-scripts! ds) + (define ran-a-script (run-all-pending-scripts! ds)) + (define performed-an-action (perform-pending-actions! ds)) + ;; TODO: figure out when a dataspace should quit itself. Given the + ;; mutable nature of the implementation, maybe never? It might be + ;; being held elsewhere! + (or ran-a-script performed-an-action)) + +(define (add-facet! ds actor-fid fid boot-proc) + (define parent-fid (fid-parent fid)) + (define f (facet fid + (make-hash) + '() + (set))) + (hash-set! (dataspace-facets ds) fid f) + (when (pair? parent-fid) + (define pf (lookup-facet ds parent-fid)) + (when pf (set-facet-children! pf (set-add (facet-children pf) fid)))) + (with-current-facet [ds actor-fid fid f #f] + (boot-proc)) + (schedule-script! ds (lambda () + (when (and (facet-live? ds fid) + (or (and (pair? parent-fid) (not (facet-live? ds parent-fid))) + (facet-live-but-inert? ds fid))) + (terminate-facet! ds actor-fid fid))))) + +(define (facet-live? ds fid) + (hash-has-key? (dataspace-facets ds) fid)) + +(define (facet-live-but-inert? ds fid) + (define f (lookup-facet ds fid)) + (and f + (hash-empty? (facet-endpoints f)) + (set-empty? (facet-children f)))) + +(define (schedule-script! #:priority [priority *normal-priority*] ds thunk) + (define v (dataspace-pending-scripts ds)) + (vector-set! v priority (enqueue (vector-ref v priority) thunk))) + +(define (terminate-facet! ds actor-fid fid) + (define f (lookup-facet ds fid)) + (when f + (define parent-fid (fid-parent fid)) + + (when (pair? parent-fid) + (define pf (lookup-facet ds parent-fid)) + (when pf (set-facet-children! (set-remove (facet-children pf) fid)))) + + (hash-remove! (dataspace-facets ds) fid) + + (for [(child-fid (in-set (facet-children f)))] + (terminate-facet! ds actor-fid child-fid)) + + ;; Run stop-scripts after terminating children. This means that + ;; children's stop-scripts run before ours. + (for [(script (reverse (facet-stop-scripts f)))] + (schedule-script! ds script)) + + (schedule-script! + ds + (lambda () + (for [((eid ep) (in-hash (facet-endpoints f)))] + (dataflow-forget-subject! (dataspace-dataflow ds) (list fid eid)) + (dataspace-retract! ds (endpoint-assertion ep)) + (define h (endpoint-handler ep)) + (when h (dataspace-unsubscribe! ds h))))) + + (schedule-script! + #:priority *gc-priority* + ds + (lambda () + (when (and (pair? parent-fid) (facet-live-but-inert? ds parent-fid)) + (log-info "terminating ~v because it's dead and child ~v terminated" parent-fid fid) + (terminate-facet! ds actor-fid parent-fid)))))) + +(define (add-endpoint! ds where assertion-fn handler) + (when (in-script?) + (error 'add-endpoint! + "~a: Cannot add endpoint in script; are you missing a (react ...)?" + where)) + (define eid (generate-id! ds)) + (define assertion + (parameterize ((current-dataflow-subject-id (list (current-facet-id) eid))) + (assertion-fn))) + (define ep (endpoint eid assertion assertion-fn handler)) + (dataspace-assert! ds assertion) + (when handler (dataspace-subscribe! ds handler)) + (hash-set! (facet-endpoints (current-facet)) eid ep)) + +(define (ensure-patch-action! ds) + (define old-q (dataspace-pending-actions ds)) + (when (or (queue-empty? old-q) (not (patch? (queue-last old-q)))) + (set-dataspace-pending-actions! ds (enqueue old-q (patch (make-bag))))) + (patch-changes (queue-last (dataspace-pending-actions ds)))) + +(define (dataspace-retract! ds assertion) + (when (not (void? assertion)) + (bag-change! (ensure-patch-action! ds) assertion -1))) + +(define (dataspace-assert! ds assertion) + (when (not (void? assertion)) + (bag-change! (ensure-patch-action! ds) assertion +1))) + +(define (dataspace-unsubscribe! ds h) + (remove-interest! (dataspace-routing-table ds) h)) + +(define (dataspace-subscribe! ds h) + (add-interest! (dataspace-routing-table ds) h)) + +(define (dataspace-send! ds body) + (set-dataspace-pending-actions! ds (enqueue (dataspace-pending-actions ds) (message body)))) + +(module+ test + ;; TODO: move somewhere sensible + ;; Thin veneers over `struct` for declaring intent. + (define-syntax-rule (assertion-struct item ...) (struct item ... #:prefab)) + (define-syntax-rule (message-struct item ...) (struct item ... #:prefab)) + + (message-struct set-box (new-value)) + (assertion-struct box-state (value)) + + ;; TODO: move somewhere sensible + (assertion-struct observe (specification)) + + (define ds (make-dataspace)) + (add-actor! ds + (lambda () + (define current-value (field-handle 'current-value + (generate-id! (current-dataspace)) + (current-facet-id) + 0)) + (add-endpoint! (current-dataspace) + 'stop-when-ten + (capture-facet-context + (lambda () + (when (= (current-value) 10) + (schedule-script! (current-dataspace) + (capture-facet-context + (lambda () + (schedule-script! + (current-dataspace) + (capture-facet-context + (lambda () + (printf "box: terminating\n")))) + (terminate-facet! (current-dataspace) + (current-actor) + (current-facet-id)))))) + (void))) + #f) + (add-endpoint! (current-dataspace) + 'assert-box-state + (capture-facet-context + (lambda () (box-state (current-value)))) + #f) + (add-endpoint! (current-dataspace) + 'on-message-set-box + (capture-facet-context + (lambda () (observe (set-box (capture (discard)))))) + (skeleton-interest (list struct:set-box #f) + '() + '() + '((0 0)) + (capture-facet-context + (lambda (op new-value) + (when (eq? '! op) + (schedule-script! + (current-dataspace) + (capture-facet-context + (lambda () + (printf "new-value ~a ~v\n" op new-value) + (current-value new-value))))))))))) + (add-actor! ds + (lambda () + (add-endpoint! (current-dataspace) + 'stop-when-retracted-observe-set-box + (capture-facet-context + (lambda () (observe (observe (set-box (discard)))))) + (skeleton-interest (list struct:observe (list struct:set-box #f)) + '() + '() + '() + (capture-facet-context + (lambda (op) + (when (eq? '- op) + (schedule-script! + (current-dataspace) + (capture-facet-context + (lambda () + (schedule-script! + (current-dataspace) + (capture-facet-context + (lambda () + (printf "client: box has gone\n")))) + (terminate-facet! (current-dataspace) + (current-actor) + (current-facet-id)))))))))) + (add-endpoint! (current-dataspace) + 'on-asserted-box-state + (capture-facet-context + (lambda () (observe (box-state (capture (discard)))))) + (skeleton-interest (list struct:box-state #f) + '() + '() + '((0 0)) + (capture-facet-context + (lambda (op v) + (when (eq? '+ op) + (schedule-script! + (current-dataspace) + (capture-facet-context + (lambda () + (printf "v ~a ~v\n" op v) + (dataspace-send! (current-dataspace) + (set-box (+ v 1))))))))))))) + + (require racket/pretty) + (pretty-print ds) + (let loop ((i 0)) + (printf "--- i = ~v\n" i) + (when (run-scripts! ds) + (pretty-print ds) + (loop (+ i 1)))) + (pretty-print ds) + ) diff --git a/syndicate/pattern.rkt b/syndicate/pattern.rkt index 65b0025..e4c8b1c 100644 --- a/syndicate/pattern.rkt +++ b/syndicate/pattern.rkt @@ -1,6 +1,8 @@ #lang racket/base -(provide analyse-pattern +(provide (struct-out discard) + (struct-out capture) + analyse-pattern desc->key desc->skeleton-proj desc->capture-proj @@ -11,9 +13,8 @@ (require racket/struct-info) (require syntax/stx) -(struct wildcard () #:prefab) - -(define ? (wildcard)) +(struct discard () #:prefab) +(struct capture (detail) #:prefab) ;;--------------------------------------------------------------------------- ;; ## Analysing patterns @@ -119,6 +120,6 @@ #`(list #,@(map desc->assertion-stx pieces))] [`(compound (,_struct-type ,ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...) #`(#,ctor #,@(map desc->assertion-stx pieces))] - [`(capture ,_ ,p) (desc->assertion-stx p)] - [`(discard) #'?] + [`(capture ,_ ,p) #`(capture #,(desc->assertion-stx p))] + [`(discard) #'(discard)] [`(atom ,v) v])) diff --git a/syndicate/skeleton.rkt b/syndicate/skeleton.rkt new file mode 100644 index 0000000..2723096 --- /dev/null +++ b/syndicate/skeleton.rkt @@ -0,0 +1,355 @@ +#lang racket/base +;; "Skeletons" describe the indexed structure of a dataspace. +;; In particular, they efficiently connect assertions to matching interests. + +(provide (struct-out skeleton-interest) + make-empty-skeleton + add-interest! + remove-interest! + add-assertion! + remove-assertion! + send-assertion! + apply-projection + apply-projection-path) + +(require syndicate/support/struct) +(require racket/match) +(require racket/set) +(require racket/hash) +(require racket/list) + +(module+ test (require rackunit)) + +;; A `Skeleton` is a structural guard on an assertion: essentially, +;; specification of (the outline of) its shape; its silhouette. +;; Following a skeleton's structure leads to zero or more `SkCont`s. +;; +;; Skeleton = (skeleton-node SkCont (AListof SkSelector (MutableHash SkClass SkNode))) +;; SkSelector = (skeleton-selector Nat Nat) +;; SkClass = StructType | (list-type Nat) +;; +(struct skeleton-node (continuation [edges #:mutable]) #:transparent) +(struct skeleton-selector (pop-count index) #:transparent) +(struct list-type (arity) #:transparent) +;; +;; A `SkDesc` is a single assertion silhouette, usually the +;; evaluation-result of `desc->skeleton-stx` from `pattern.rkt`. +;; +;; A `SkCont` is a *skeleton continuation*, a collection of "next +;; steps" after a `Skeleton` has matched the general outline of an +;; assertion. +;; +;; INVARIANT: At each level, the caches correspond to the +;; appropriately filtered and projected contents of the dataspace +;; containing the structures. +;; +;; SkCont = (skeleton-continuation +;; (MutableSet Assertion) +;; (MutableHash SkProj (MutableHash SkKey SkConst))) +;; SkConst = (skeleton-matched-constant +;; (MutableSet Assertion) +;; (MutableHash SkProj SkAcc)) +;; SkAcc = (skeleton-accumulator +;; (MutableSet SkKey) +;; (MutableSet (... -> Any))) +;; +(struct skeleton-continuation (cache table) #:transparent) +(struct skeleton-matched-constant (cache table) #:transparent) +(struct skeleton-accumulator (cache handlers) #:transparent) +;; +;; A `SkProj` is a *skeleton projection*, a specification of loci +;; within a tree-shaped assertion to collect into a flat list. +;; +;; SkProj = (Listof (Listof Nat)) +;; +;; The outer list specifies elements of the flat list; the inner lists +;; specify paths via zero-indexed links to child nodes in the +;; tree-shaped assertion being examined. A precondition for use of a +;; `SkProj` is that the assertion being examined has been checked for +;; conformance to the skeleton being projected. +;; +;; A `SkKey` is the result of running a `SkProj` over a term, +;; extracting the values at the denoted locations. +;; +;; SkKey = (Listof Any) +;; +;; Each `SkProj` in `SkCont` selects *constant* portions of the term +;; for more matching against the `SkKey`s in the table associated with +;; the `SkProj`. Each `SkProj` in `SkConst`, if any, selects +;; *variable* portions of the term to be given to the handler +;; functions in the associated `SkAcc`. + +;; A `SkInterest` is a specification for an addition to or removal +;; from an existing `Skeleton`. +;; +;; SkInterest = (skeleton-interest SkDesc SkProj SkKey SkProj (... -> Any)) +;; +;; The `SkDesc` gives the silhouette. The first `SkProj` is the +;; constant-portion selector, to be matched against the `SkKey`. The +;; second `SkProj` is used on matching assertions to extract the +;; variable portions, to be passed to the handler function. +;; +(struct skeleton-interest (desc const-selector const-value var-selector handler) #:transparent) + +;;--------------------------------------------------------------------------- + +(define (make-empty-skeleton/cache cache) + (skeleton-node (skeleton-continuation cache + (make-hash)) + '())) + +(define (make-empty-skeleton) + (make-empty-skeleton/cache (mutable-set))) + +(define (skcont-add! c i apply-handler!) + (match-define (skeleton-interest _desc cs cv vs h) i) + (define (make-matched-constant) + (skeleton-matched-constant (for/mutable-set [(a (skeleton-continuation-cache c)) + #:when (equal? (apply-projection a cs) cv)] + a) + (make-hash))) + (define cvt (hash-ref! (skeleton-continuation-table c) cs make-hash)) + (define sc (hash-ref! cvt cv make-matched-constant)) + (define (make-accumulator) + (skeleton-accumulator (for/mutable-set [(a (skeleton-matched-constant-cache sc))] + (apply-projection a vs)) + (mutable-set))) + (define acc (hash-ref! (skeleton-matched-constant-table sc) vs make-accumulator)) + (set-add! (skeleton-accumulator-handlers acc) h) + (for [(vars (skeleton-accumulator-cache acc))] (apply-handler! h vars))) + +(define (skcont-remove! c i apply-handler!) + (match-define (skeleton-interest _desc cs cv vs h) i) + (define cvt (hash-ref (skeleton-continuation-table c) cs #f)) + (when cvt + (define sc (hash-ref cvt cv #f)) + (when sc + (define acc (hash-ref (skeleton-matched-constant-table sc) vs #f)) + (when acc + (for [(vars (skeleton-accumulator-cache acc))] (apply-handler! h vars)) + (set-remove! (skeleton-accumulator-handlers acc) h) + (when (set-empty? (skeleton-accumulator-handlers acc)) + (hash-remove! (skeleton-matched-constant-table sc) vs))) + (when (hash-empty? (skeleton-matched-constant-table sc)) + (hash-remove! cvt cv))) + (when (hash-empty? cvt) + (hash-remove! (skeleton-continuation-table c) cs)))) + +(define (term-matches-class? term class) + (cond + [(list-type? class) (and (list? term) (= (length term) (list-type-arity class)))] + [(struct-type? class) (and (non-object-struct? term) (eq? (struct->struct-type term) class))] + [else (error 'term-matches-class? "Invalid class: ~v" class)])) + +(define (subterm-matches-class? term path class) + (term-matches-class? (apply-projection-path term path) class)) + +(define (update-path path pop-count index) + (append (drop-right path pop-count) (list index))) + +(define (extend-skeleton! sk desc) + (define (walk-node! path sk pop-count index desc) + (match desc + [(list class-desc pieces ...) + (define class + (cond [(eq? class-desc 'list) (list-type (length pieces))] + [(struct-type? class-desc) class-desc] + [else (error 'extend-skeleton! "Invalid class-desc: ~v" class-desc)])) + (define selector (skeleton-selector pop-count index)) + (define table + (match (assoc selector (skeleton-node-edges sk)) + [#f (let ((table (make-hash))) + (set-skeleton-node-edges! sk (cons (cons selector table) (skeleton-node-edges sk))) + table)] + [(cons _selector table) table])) + (define (make-skeleton-node-with-cache) + (define unfiltered (skeleton-continuation-cache (skeleton-node-continuation sk))) + (make-empty-skeleton/cache + (for/mutable-set [(a unfiltered) #:when (subterm-matches-class? a path class)] a))) + (define next (hash-ref! table class make-skeleton-node-with-cache)) + (walk-edge! (update-path path pop-count 0) next 0 0 pieces)] + [_ + (values pop-count sk)])) + (define (walk-edge! path sk pop-count index pieces) + (match pieces + ['() + (values (+ pop-count 1) sk)] + [(cons p pieces) + (let-values (((pop-count sk) (walk-node! path sk pop-count index p))) + (walk-edge! (update-path path 1 (+ index 1)) sk pop-count (+ index 1) pieces))])) + (let-values (((_pop-count sk) (walk-edge! '(0) sk 0 0 (list desc)))) + sk)) + +(define (add-interest! sk i) + (let ((sk (extend-skeleton! sk (skeleton-interest-desc i)))) + (skcont-add! (skeleton-node-continuation sk) + i + (lambda (h vars) (apply h '+ vars))))) + +(define (remove-interest! sk i) + (let ((sk (extend-skeleton! sk (skeleton-interest-desc i)))) + (skcont-remove! (skeleton-node-continuation sk) + i + (lambda (h vars) (apply h '- vars))))) + +(define (skeleton-modify! sk term0 modify-skcont! modify-skconst! modify-skacc!) + (define (walk-node! sk term-stack) + (match-define (skeleton-node continuation edges) sk) + + (modify-skcont! continuation term0) + (for [((constant-proj key-proj-handler) (in-hash (skeleton-continuation-table continuation)))] + (define constants (apply-projection term0 constant-proj)) + (define proj-handler (hash-ref key-proj-handler constants #f)) + (when proj-handler + (modify-skconst! proj-handler term0) + (for [((variable-proj acc) (in-hash (skeleton-matched-constant-table proj-handler)))] + (define variables (apply-projection term0 variable-proj)) + (modify-skacc! acc variables term0)))) + + (for [(edge edges)] + (match-define (cons (skeleton-selector pop-count index) table) edge) + (define popped-stack (drop term-stack pop-count)) + (define pieces (car popped-stack)) + (define term (vector-ref pieces (+ index 1))) ;; adjust for struct identifier at beginning + (define entry (hash-ref table + (cond [(list? term) (list-type (length term))] + [(non-object-struct? term) (struct->struct-type term)] + [else #f]) + #f)) + (when entry + (define new-pieces + (cond [(list? term) (list->vector (cons 'list term))] + [(non-object-struct? term) (struct->vector term)])) + (walk-node! entry (cons new-pieces term-stack))))) + + (walk-node! sk (list (vector 'list term0)))) + +(define (add-term-to-skcont! skcont term) + (set-add! (skeleton-continuation-cache skcont) term)) +(define (add-term-to-skconst! skconst term) + (set-add! (skeleton-matched-constant-cache skconst) term)) +(define (add-term-to-skacc! skacc vars _term) + (define cache (skeleton-accumulator-cache skacc)) + (set-add! cache vars) + (for [(handler (skeleton-accumulator-handlers skacc))] + (apply handler '+ vars))) + +(define (add-assertion! sk term) + (skeleton-modify! sk + term + add-term-to-skcont! + add-term-to-skconst! + add-term-to-skacc!)) + +(define (remove-term-from-skcont! skcont term) + (set-remove! (skeleton-continuation-cache skcont) term)) +(define (remove-term-from-skconst! skconst term) + (set-remove! (skeleton-matched-constant-cache skconst) term)) +(define (remove-term-from-skacc! skacc vars _term) + (define cache (skeleton-accumulator-cache skacc)) + (set-remove! cache vars) + (for [(handler (skeleton-accumulator-handlers skacc))] + (apply handler '- vars))) + +(define (remove-assertion! sk term) + (skeleton-modify! sk + term + remove-term-from-skcont! + remove-term-from-skconst! + remove-term-from-skacc!)) + +(define (send-assertion! sk term) + (skeleton-modify! sk + term + void + void + (lambda (skacc vars _term) + (for [(handler (skeleton-accumulator-handlers skacc))] + (apply handler '! vars))))) + +;; TODO: avoid repeated descent into `term` by factoring out prefixes of paths in `proj` +(define (apply-projection term proj) + (for/list [(path proj)] + (apply-projection-path term path))) + +(define (apply-projection-path term path) + (for/fold [(term (list term))] [(index path)] + (cond [(list? term) (list-ref term index)] + [(non-object-struct? term) (vector-ref (struct->vector term) (+ index 1))] + [else (error 'apply-projection "Term representation not supported: ~v" term)]))) + +;;--------------------------------------------------------------------------- + +(module+ test + (struct a (x y) #:transparent) + (struct b (v) #:transparent) + (struct c (v) #:transparent) + (struct d (x y z) #:transparent) + + (define sk + (make-empty-skeleton/cache (mutable-set (a (b 'bee) (b 'cat)) + (a (b 'foo) (c 'bar)) + (a (b 'foo) (c 'BAR)) + (a (c 'bar) (b 'foo)) + (a (c 'dog) (c 'fox)) + (d (b 'DBX) (b 'DBY) (b 'DBZ)) + (d (c 'DCX) (c 'DCY) (c 'DCZ)) + (b 'zot) + 123))) + + (add-interest! sk + (skeleton-interest (list struct:a (list struct:b #f) #f) + '((0 0 0)) + '(foo) + '((0 1)) + (lambda (op . bindings) + (printf "xAB HANDLER: ~v ~v\n" op bindings)))) + + (void (extend-skeleton! sk (list struct:a (list struct:b #f) #f))) + (void (extend-skeleton! sk (list struct:a #f (list struct:c #f)))) + (void (extend-skeleton! sk (list struct:a #f (list struct:c (list struct:b #f))))) + (void (extend-skeleton! sk (list struct:a #f #f))) + (void (extend-skeleton! sk (list struct:c #f))) + (void (extend-skeleton! sk (list struct:b #f))) + (void (extend-skeleton! sk (list struct:d (list struct:b #f) #f (list struct:b #f)))) + (void (extend-skeleton! sk (list struct:d (list struct:b #f) #f (list struct:c #f)))) + (void (extend-skeleton! sk (list struct:d (list struct:c #f) #f (list struct:b #f)))) + (void (extend-skeleton! sk (list struct:d (list struct:c #f) #f (list struct:c #f)))) + (check-eq? sk (extend-skeleton! sk #f)) + + (add-interest! sk + (skeleton-interest (list struct:d (list struct:b #f) #f (list struct:c #f)) + '((0 2 0)) + '(DCZ) + '((0) (0 0) (0 0 0) (0 1)) + (lambda (op . bindings) + (printf "DBC HANDLER: ~v ~v\n" op bindings)))) + + (remove-assertion! sk (a (b 'foo) (c 'bar))) + (remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ))) + (add-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ))) + (add-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ))) + (add-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX))) + (add-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ))) + (add-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ))) + (add-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX))) + + (add-interest! sk + (skeleton-interest (list struct:d #f (list struct:b #f) #f) + '((0 1 0)) + '(DBY) + '((0 0) (0 2)) + (lambda (op . bindings) + (printf "xDB HANDLER: ~v ~v\n" op bindings)))) + + (send-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ))) + (send-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ))) + + (remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ))) + (remove-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ))) + (remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX))) + (remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ))) + (remove-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ))) + (remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX))) + ;; sk + )