From a4e1d882f8d2f92505114d08e63004ed60cc1723 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Tue, 20 May 2014 22:12:50 -0400
Subject: [PATCH] Reintroduce trigger-guards

---
 minimart/core.rkt | 31 +++++++++++++++++++++++++++----
 1 file changed, 27 insertions(+), 4 deletions(-)

diff --git a/minimart/core.rkt b/minimart/core.rkt
index 021dfd6..ecb6e7c 100644
--- a/minimart/core.rkt
+++ b/minimart/core.rkt
@@ -70,10 +70,6 @@
 ;; Behavior : maybe event * state -> transition
 (struct transition (state actions) #:transparent)
 
-;; TODO: Reintroduce "trigger-guard" from the naive implementation
-;; perhaps. "Process table maps to these; idea is to avoid redundant
-;; signalling of routing-updates where possible"
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Protocol and utilities
 
@@ -107,6 +103,32 @@
 (define (sequence-transitions t0 . steps)
   (foldl transition-bind t0 steps))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Trigger guards
+
+;; Trigger-guards only pass through routing updates if there has been
+;; a change.
+(struct trigger-guard (gestalt handler state) #:transparent)
+
+(define (trigger-guard-handle e s0)
+  (match-define (trigger-guard old-gestalt handler old-state) s0)
+  (define (deliver s)
+    (match (handler e old-state)
+      [#f
+       (if (eq? s s0) #f (transition s '()))]
+      [(transition new-state actions)
+       (transition (struct-copy trigger-guard s [state new-state]) actions)]))
+  (match e
+    [(routing-update new-gestalt)
+     (if (equal? new-gestalt old-gestalt)
+	 #f
+	 (deliver (struct-copy trigger-guard s0 [gestalt new-gestalt])))]
+    [_ (deliver s0)]))
+
+(define (trigger-guard-process p)
+  (match-define (process _ b s) p)
+  (struct-copy process p [behavior trigger-guard-handle] [state (trigger-guard (gestalt-empty) b s)]))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; World implementation
 
@@ -210,6 +232,7 @@
   (match a
     [(? process? new-p)
      (let* ((new-pid (world-next-pid w))
+	    (new-p (trigger-guard-process new-p))
 	    (new-gestalt (label-gestalt (process-gestalt new-p) new-pid))
 	    (new-p (struct-copy process new-p [gestalt new-gestalt]))
 	    (w (struct-copy world w