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.

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))

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)