Only fire (on (asserted)) when no previous matching assertions have been seen.
This makes (on (asserted)), (on (retracted)) and (during) behave as if they are *grouping* by their named captures, which is what we want. It gives a much easier to understand programming model. Note the differences in execution of example-partial-retraction.rkt before and after this patch. This patch gives example-partial-retraction.rkt, and programs like it, a more natural behaviour.
This commit is contained in:
parent
3db6177ce9
commit
b1f7816418
|
@ -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))
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue