From 01b6bf92ee18fdd8f63c5ca47e0e574623b3226a Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Thu, 11 Feb 2016 22:26:53 -0500
Subject: [PATCH] Echo cancellation for prospect.

---
 prospect/examples/example-meta-echo.rkt | 14 ++++++-------
 prospect/mux.rkt                        | 28 ++++++++++++++++++++-----
 prospect/route.rkt                      | 13 ++++++++++++
 3 files changed, 43 insertions(+), 12 deletions(-)

diff --git a/prospect/examples/example-meta-echo.rkt b/prospect/examples/example-meta-echo.rkt
index 67d2efa..2c05e4d 100644
--- a/prospect/examples/example-meta-echo.rkt
+++ b/prospect/examples/example-meta-echo.rkt
@@ -1,16 +1,16 @@
 #lang prospect
-;; Demonstrates a (hopefully soon historical!) bug in Syndicate.
+;; Test case for a historical bug in Syndicate.
 ;;
-;; When the bug exists, this program receives four patch events in
+;; When the bug existed, this program receiveed four SCN events in
 ;; total, whereas it should receive only two.
 ;;
-;; While metamessages are "echo cancelled", and receivers only ever
-;; get one copy of a sent metamessage no matter how many metas there
-;; are, state changes are not (yet). Issuing a quick enough "pulse" of
-;; metaassertion while maintaining interest in it leads to an "echo":
+;; While metamessages were "echo cancelled", and receivers only ever
+;; got one copy of a sent metamessage no matter how many metas there
+;; were, state changes were not. Issuing a quick enough "pulse" of
+;; metaassertion while maintaining interest in it led to an "echo":
 ;; multiple receipts of the pulse.
 ;;
-;; The fix is to adjust the implementation of state change
+;; The fix was to adjust the implementation of state change
 ;; notifications to cancel the echo for metaassertions.
 
 (require prospect/pretty)
diff --git a/prospect/mux.rkt b/prospect/mux.rkt
index 62c5aa7..4c508ea 100644
--- a/prospect/mux.rkt
+++ b/prospect/mux.rkt
@@ -67,7 +67,23 @@
           delta
           delta-aggregate))
 
+(define at-meta-everything (pattern->trie #t (at-meta ?)))
+(define only-meta (datum-tset 'meta))
+
+(define (echo-cancelled-trie t)
+  (trie-subtract t
+                 at-meta-everything
+                 #:combiner (lambda (v1 v2)
+                              (if (tset-member? v1 'meta)
+                                  only-meta
+                                  #f))))
+
 (define (compute-patches old-m new-m label delta delta-aggregate)
+  (define delta-aggregate/no-echo
+    (if (meta-label? label)
+        delta-aggregate
+        (patch (trie-prune-branch (patch-added delta-aggregate) struct:at-meta)
+               (trie-prune-branch (patch-removed delta-aggregate) struct:at-meta))))
   (define old-routing-table (mux-routing-table old-m))
   (define new-routing-table (mux-routing-table new-m))
   (define affected-pids
@@ -77,15 +93,17 @@
             (cond [(equal? pid label)
                    (define feedback
                      (patch-union
-                      (patch (biased-intersection new-routing-table (patch-added delta))
-                             (biased-intersection old-routing-table (patch-removed delta)))
-                      (patch (biased-intersection (patch-added delta-aggregate)
+                      (patch (echo-cancelled-trie
+                              (biased-intersection new-routing-table (patch-added delta)))
+                             (echo-cancelled-trie
+                              (biased-intersection old-routing-table (patch-removed delta))))
+                      (patch (biased-intersection (patch-added delta-aggregate/no-echo)
                                                   (mux-interests-of new-m label))
-                             (biased-intersection (patch-removed delta-aggregate)
+                             (biased-intersection (patch-removed delta-aggregate/no-echo)
                                                   (mux-interests-of old-m label)))))
                    (cons label feedback)]
                   [else
-                   (cons pid (view-patch delta-aggregate (mux-interests-of old-m pid)))]))
+                   (cons pid (view-patch delta-aggregate/no-echo (mux-interests-of old-m pid)))]))
           (and (not (meta-label? label))
                (drop-patch
                 (compute-aggregate-patch delta label old-routing-table #:remove-meta? #t)))))
diff --git a/prospect/route.rkt b/prospect/route.rkt
index 2d82615..e48ac3a 100644
--- a/prospect/route.rkt
+++ b/prospect/route.rkt
@@ -32,6 +32,7 @@
 	 trie-match-trie
 	 trie-append
 	 trie-relabel
+         trie-prune-branch
 
 	 SOL
 	 SOV
@@ -605,6 +606,18 @@
 		      [(kv (treap-to-alist m)) #:when (not (eq? (car kv) ?))]
 		    (rupdate acc (car kv) (walk (cdr kv))))])))
 
+;; Trie Sigma -> Trie
+;; Outright removes tries reachable from m via edges labelled with s.
+;; Useful for removing (at-meta *) when the success value along that
+;; branch doesn't matter.
+(define (trie-prune-branch m s)
+  (match m
+    [#f #f]
+    [(wildcard-sequence k)
+     (collapse-wildcard-sequences (rupdate (expand-wildseq k) s (trie-empty)))]
+    [(success _) m]
+    [(? treap? h) (rupdate h s (trie-empty))]))
+
 ;; Trie Sigma -> Trie
 (define (trie-step m s)
   (match m