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
|
aggregates ;; Aggregates
|
||||||
pending-patch ;; (Option Patch) - aggregate patch being accumulated
|
pending-patch ;; (Option Patch) - aggregate patch being accumulated
|
||||||
mux ;; Mux
|
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
|
#:transparent
|
||||||
#:methods gen:syndicate-pretty-printable
|
#:methods gen:syndicate-pretty-printable
|
||||||
|
@ -303,6 +305,32 @@
|
||||||
;; TODO: Revisit this, it is a bit ugly
|
;; TODO: Revisit this, it is a bit ugly
|
||||||
(define *linkage-label* -2)
|
(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
|
;; Behavior
|
||||||
(define (generic-actor-behavior e s)
|
(define (generic-actor-behavior e s)
|
||||||
(match e
|
(match e
|
||||||
|
@ -545,10 +573,14 @@
|
||||||
#'(patch-removed p))
|
#'(patch-removed p))
|
||||||
proj)))]
|
proj)))]
|
||||||
(lambda (s)
|
(lambda (s)
|
||||||
|
(define instantiated (instantiate-projection proj entry))
|
||||||
|
(and (#,(if asserted?
|
||||||
|
#'interest-just-appeared-matching?
|
||||||
|
#'interest-just-disappeared-matching?) s instantiated)
|
||||||
(match (actor-state-variables s)
|
(match (actor-state-variables s)
|
||||||
[(vector #,@binding-names)
|
[(vector #,@binding-names)
|
||||||
(match-define (list #,@bindings) entry)
|
(match-define (list #,@bindings) entry)
|
||||||
#,(make-run-script-call outer-expr-stx #'s I-stxs)]))))]
|
#,(make-run-script-call outer-expr-stx #'s I-stxs)])))))]
|
||||||
[_ #f]))))))
|
[_ #f]))))))
|
||||||
|
|
||||||
(define (prepend-at-meta-stx context-stx stx level)
|
(define (prepend-at-meta-stx context-stx stx level)
|
||||||
|
@ -661,6 +693,11 @@
|
||||||
[(E I0 I ...)
|
[(E I0 I ...)
|
||||||
(analyze-event! edge-index #'E #'((call-with-values (lambda () I0 I ...) return!)))]))
|
(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.
|
;; ...and generic linkage-related behaviors.
|
||||||
(add-event-handler!
|
(add-event-handler!
|
||||||
(lambda (evt-stx)
|
(lambda (evt-stx)
|
||||||
|
@ -692,7 +729,9 @@
|
||||||
(init-idx (in-naturals))]
|
(init-idx (in-naturals))]
|
||||||
#`(cons #,init-idx #,init-stx))))
|
#`(cons #,init-idx #,init-stx))))
|
||||||
#f
|
#f
|
||||||
(mux)))
|
(mux)
|
||||||
|
trie-empty
|
||||||
|
trie-empty))
|
||||||
|
|
||||||
(define (subscribe-to-linkage s)
|
(define (subscribe-to-linkage s)
|
||||||
(define sub-to-callees
|
(define sub-to-callees
|
||||||
|
@ -885,7 +924,15 @@
|
||||||
|
|
||||||
(define (pretty-print-actor-state s [p (current-output-port)])
|
(define (pretty-print-actor-state s [p (current-output-port)])
|
||||||
(match-define
|
(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)
|
s)
|
||||||
(fprintf p "ACTOR id ~a (caller-id ~a):\n" self-id caller-id)
|
(fprintf p "ACTOR id ~a (caller-id ~a):\n" self-id caller-id)
|
||||||
(fprintf p " - ~a pending continuations\n" (hash-count continuation-table))
|
(fprintf p " - ~a pending continuations\n" (hash-count continuation-table))
|
||||||
|
@ -906,6 +953,12 @@
|
||||||
(fprintf p " - pending-patch:\n")
|
(fprintf p " - pending-patch:\n")
|
||||||
(display (indented-port-output 3 (lambda (p) (syndicate-pretty-print pending-patch p))) p)
|
(display (indented-port-output 3 (lambda (p) (syndicate-pretty-print pending-patch p))) p)
|
||||||
(newline 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 " - ")
|
(fprintf p " - ")
|
||||||
(display (indented-port-output 3 (lambda (p) (syndicate-pretty-print mux p)) #:first-line? #f) p)
|
(display (indented-port-output 3 (lambda (p) (syndicate-pretty-print mux p)) #:first-line? #f) p)
|
||||||
(newline p))
|
(newline p))
|
||||||
|
|
|
@ -55,6 +55,7 @@
|
||||||
trie-step*
|
trie-step*
|
||||||
|
|
||||||
projection->pattern
|
projection->pattern
|
||||||
|
instantiate-projection
|
||||||
projection-arity
|
projection-arity
|
||||||
trie-project
|
trie-project
|
||||||
trie-key-set
|
trie-key-set
|
||||||
|
@ -543,7 +544,7 @@
|
||||||
;; Sigmas and OpenParentheses and runs them through the Trie r. If v
|
;; Sigmas and OpenParentheses and runs them through the Trie r. If v
|
||||||
;; leads to a success Trie, returns the values contained in the
|
;; leads to a success Trie, returns the values contained in the
|
||||||
;; success Trie; otherwise, returns failure-result.
|
;; 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)
|
(define (walk vs r)
|
||||||
(match r
|
(match r
|
||||||
[(? trie-empty?) failure-result]
|
[(? trie-empty?) failure-result]
|
||||||
|
@ -556,8 +557,14 @@
|
||||||
(treap-get os (canonical-open-parenthesis arity type) (lambda () 'missing)))
|
(treap-get os (canonical-open-parenthesis arity type) (lambda () 'missing)))
|
||||||
(match vs
|
(match vs
|
||||||
['() failure-result]
|
['() failure-result]
|
||||||
[(cons (== ?) _)
|
[(cons (== ?) vs1)
|
||||||
(error 'trie-lookup "Cannot match wildcard as a value")]
|
(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)
|
[(cons (? list? l) vs1)
|
||||||
(match (get-open (length l) 'list)
|
(match (get-open (length l) 'list)
|
||||||
['missing (walk vs1 w)]
|
['missing (walk vs1 w)]
|
||||||
|
@ -687,6 +694,30 @@
|
||||||
(map walk (cdr (vector->list (struct->vector p)))))]
|
(map walk (cdr (vector->list (struct->vector p)))))]
|
||||||
[other other])))
|
[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
|
;; Projection -> Natural
|
||||||
;; Counts the number of captures in its argument.
|
;; Counts the number of captures in its argument.
|
||||||
(define (projection-arity p)
|
(define (projection-arity p)
|
||||||
|
|
Loading…
Reference in New Issue