diff --git a/racket/syndicate/actor.rkt b/racket/syndicate/actor.rkt index 4299479..e60e438 100644 --- a/racket/syndicate/actor.rkt +++ b/racket/syndicate/actor.rkt @@ -124,6 +124,8 @@ aggregates ;; Aggregates pending-patch ;; (Option Patch) - aggregate patch being accumulated mux ;; Mux + prev-assertions ;; Trie - assertions from envt at the start of this event + curr-assertions ;; Trie - prev-assertions, updated by the incoming event ) #:transparent #:methods gen:syndicate-pretty-printable @@ -303,6 +305,32 @@ ;; TODO: Revisit this, it is a bit ugly (define *linkage-label* -2) +;; Behavior +(define (generic-query-updater e s) + (transition (if (patch? e) + (let ((t (actor-state-curr-assertions s))) + (struct-copy actor-state s + [prev-assertions t] + [curr-assertions (update-interests t e)])) + s) + '())) + +(define (interests-pre-and-post-patch s pat) + (define (or* a b) (or a b)) + (define old (trie-lookup (actor-state-prev-assertions s) pat #f #:wildcard-union or*)) + (define new (trie-lookup (actor-state-curr-assertions s) pat #f #:wildcard-union or*)) + (values old new)) + +;; ActorState Pattern -> Boolean +(define (interest-just-appeared-matching? s pat) + (define-values (old new) (interests-pre-and-post-patch s pat)) + (and (not old) new)) + +;; ActorState Pattern -> Boolean +(define (interest-just-disappeared-matching? s pat) + (define-values (old new) (interests-pre-and-post-patch s pat)) + (and old (not new))) + ;; Behavior (define (generic-actor-behavior e s) (match e @@ -545,10 +573,14 @@ #'(patch-removed p)) proj)))] (lambda (s) - (match (actor-state-variables s) - [(vector #,@binding-names) - (match-define (list #,@bindings) entry) - #,(make-run-script-call outer-expr-stx #'s I-stxs)]))))] + (define instantiated (instantiate-projection proj entry)) + (and (#,(if asserted? + #'interest-just-appeared-matching? + #'interest-just-disappeared-matching?) s instantiated) + (match (actor-state-variables s) + [(vector #,@binding-names) + (match-define (list #,@bindings) entry) + #,(make-run-script-call outer-expr-stx #'s I-stxs)])))))] [_ #f])))))) (define (prepend-at-meta-stx context-stx stx level) @@ -661,6 +693,11 @@ [(E I0 I ...) (analyze-event! edge-index #'E #'((call-with-values (lambda () I0 I ...) return!)))])) + ;; ...the generic query-updater... + (add-query-updater! + (lambda (evt-stx) + #`(lambda (s) (generic-query-updater #,evt-stx s)))) + ;; ...and generic linkage-related behaviors. (add-event-handler! (lambda (evt-stx) @@ -692,7 +729,9 @@ (init-idx (in-naturals))] #`(cons #,init-idx #,init-stx)))) #f - (mux))) + (mux) + trie-empty + trie-empty)) (define (subscribe-to-linkage s) (define sub-to-callees @@ -885,7 +924,15 @@ (define (pretty-print-actor-state s [p (current-output-port)]) (match-define - (actor-state continuation-table caller-id self-id variables aggregates pending-patch mux) + (actor-state continuation-table + caller-id + self-id + variables + aggregates + pending-patch + mux + prev-assertions + curr-assertions) s) (fprintf p "ACTOR id ~a (caller-id ~a):\n" self-id caller-id) (fprintf p " - ~a pending continuations\n" (hash-count continuation-table)) @@ -906,6 +953,12 @@ (fprintf p " - pending-patch:\n") (display (indented-port-output 3 (lambda (p) (syndicate-pretty-print pending-patch p))) p) (newline p) + (fprintf p " - previous assertions:\n") + (pretty-print-trie prev-assertions p #:indent 3) + (newline p) + (fprintf p " - current assertions:\n") + (pretty-print-trie curr-assertions p #:indent 3) + (newline p) (fprintf p " - ") (display (indented-port-output 3 (lambda (p) (syndicate-pretty-print mux p)) #:first-line? #f) p) (newline p)) diff --git a/racket/syndicate/trie.rkt b/racket/syndicate/trie.rkt index 78d56f2..faa8ff4 100644 --- a/racket/syndicate/trie.rkt +++ b/racket/syndicate/trie.rkt @@ -55,6 +55,7 @@ trie-step* projection->pattern + instantiate-projection projection-arity trie-project trie-key-set @@ -543,7 +544,7 @@ ;; Sigmas and OpenParentheses and runs them through the Trie r. If v ;; leads to a success Trie, returns the values contained in the ;; success Trie; otherwise, returns failure-result. -(define (trie-lookup r v failure-result) +(define (trie-lookup r v failure-result #:wildcard-union [wildcard-union #f]) (define (walk vs r) (match r [(? trie-empty?) failure-result] @@ -556,8 +557,14 @@ (treap-get os (canonical-open-parenthesis arity type) (lambda () 'missing))) (match vs ['() failure-result] - [(cons (== ?) _) - (error 'trie-lookup "Cannot match wildcard as a value")] + [(cons (== ?) vs1) + (when (not wildcard-union) (error 'trie-lookup "Cannot match wildcard as a value")) + (let* ((seed (walk vs1 w)) + (seed (for/fold [(seed seed)] [(k (in-list (treap-values os)))] + (wildcard-union seed (walk vs1 k)))) + (seed (for/fold [(seed seed)] [(k (in-list (treap-values h)))] + (wildcard-union seed (walk vs1 k))))) + seed)] [(cons (? list? l) vs1) (match (get-open (length l) 'list) ['missing (walk vs1 w)] @@ -687,6 +694,30 @@ (map walk (cdr (vector->list (struct->vector p)))))] [other other]))) +;; Projection (Listof Pattern) -> Pattern +;; Instantiates captures in its first argument with values from its second. +;; ASSUMPTION: that each captured val matches the subpattern in each capture +;; ASSUMPTION: (length captured-vals) == number of captures in p +(define (instantiate-projection p captured-vals) + (define (consume-capture!) + (begin0 (car captured-vals) + (set! captured-vals (cdr captured-vals)))) + (let walk ((p p)) + (match p + [(capture sub) (consume-capture!)] + [(cons p1 p2) + (define s1 (walk p1)) + (define s2 (walk p2)) + (cons s1 s2)] + [(? vector? v) (for/vector [(e (in-vector v))] (walk e))] + ;; TODO: consider options for treating treaps as compounds + ;; rather than (useless) atoms + [(? treap?) (error 'projection->pattern "Cannot match on treaps at present")] + [(? non-object-struct?) + (apply (struct-type-make-constructor (struct->struct-type p)) + (map walk (cdr (vector->list (struct->vector p)))))] + [other other]))) + ;; Projection -> Natural ;; Counts the number of captures in its argument. (define (projection-arity p)