gestalt-intersect is probably not useful as an API

(original commit adapted to naive-routing setting)

minimart/core.rkt

@@ -16,6 +16,13 @@
 	 wildcard?
 	 sub
 	 pub
+	 gestalt-ref
+	 gestalt-empty
+	 gestalt-empty?
+	 gestalt-union
+	 gestalt-filter
+	 pretty-print-matcher
+	 pretty-print-gestalt
 	 spawn
 	 send
 	 feedback
@@ -26,6 +33,7 @@
 	 deliver-event
 	 transition-bind
 	 sequence-transitions
+	 routing-implementation
 
 	 log-events-and-actions?)
 
@@ -64,6 +72,24 @@
 (define (sub p #:meta-level [ml 0] #:level [l 0]) (route #t p ml l))
 (define (pub p #:meta-level [ml 0] #:level [l 0]) (route #f p ml l))
 
+(define (gestalt-ref g metalevel level get-advertisements?)
+  (filter-map (lambda (r)
+		(match-define (route is-sub? p ml l) r)
+		(and (= ml metalevel)
+		     (= l level)
+		     (eq? get-advertisements? (not is-sub?))
+		     p))
+	      (flatten g)))
+
+(define (gestalt-union . gs) (flatten gs))
+(define (gestalt-filter g1 g2) (intersect-routes (flatten g1) (flatten g2)))
+(define (gestalt-empty) '())
+(define (gestalt-empty? g) (null? g))
+
+(require racket/pretty)
+(define (pretty-print-matcher x #:indent [ignored-indent 0]) (pretty-print x))
+(define (pretty-print-gestalt x) (pretty-print x))
+
 (define (spawn behavior state [initial-routes '()]) (process initial-routes behavior state))
 (define (send body #:meta-level [ml 0]) (message body ml #f))
 (define (feedback body #:meta-level [ml 0]) (message body ml #t))
@@ -217,6 +243,7 @@
   (match a
     [(? process? new-p)
      (let* ((new-pid (world-next-pid w))
+	    (new-p (struct-copy process new-p [routes (flatten (process-routes new-p))]))
 	    (w (struct-copy world w [next-pid (+ new-pid 1)]))
 	    (w (struct-copy world w [process-table
 				     (hash-set (world-process-table w)
@@ -228,7 +255,8 @@
      (when (hash-has-key? (world-process-table w) pid) (log-info "Process ~a terminating" pid))
      (let* ((w (struct-copy world w [process-table (hash-remove (world-process-table w) pid)])))
        (issue-routing-update w))]
-    [(routing-update routes)
+    [(routing-update routes0)
+     (define routes (flatten routes0))
      (if (upward-routes-change-ignorable? pid w routes)
 	 (transition w '())
 	 (let* ((w (transform-process pid w
@@ -282,3 +310,5 @@
      (issue-local-routing-update (struct-copy world w [downward-routes (lift-routes routes)]))]
     [(message body meta-level feedback?)
      (enqueue-event (message body (+ meta-level 1) feedback?) w)]))
+
+(define routing-implementation 'naive)

minimart/drivers/timer.rkt

@@ -48,12 +48,12 @@
 
 (define (timer-subscriptions s)
   (define t (next-timer (driver-state-heap s)))
-  (append (list (sub (set-timer ? ? 'relative))
-		(sub (set-timer ? ? 'absolute))
-		(pub (timer-expired ? ?)))
-	  (if t
-	      (list (sub (event (timer-evt (pending-timer-deadline t)) ?) #:meta-level 1))
-	      '())))
+  (gestalt-union (sub (set-timer ? ? 'relative))
+		 (sub (set-timer ? ? 'absolute))
+		 (pub (timer-expired ? ?))
+		 (if t
+		     (sub (event (timer-evt (pending-timer-deadline t)) ?) #:meta-level 1)
+		     (gestalt-empty))))
 
 (define (spawn-timer-driver)
   (define s (driver-state (make-timer-heap)))

minimart/examples/example-lang.rkt

@@ -1,10 +1,11 @@
 #lang minimart
 
 (require (only-in racket/port read-line-evt))
+(require "../drivers/timer.rkt")
 
 (define (r e s)
   (match e
-    [(message body _ _) (transition s (send `(got ,body) #:meta-level 1))]
+    [(message body _ _) (transition s (send `(print got ,body) #:meta-level 1))]
     [_ #f]))
 
 (define (b e n)
@@ -14,20 +15,44 @@
 	    #f)]
     [_ #f]))
 
-(spawn-world (spawn r (void) (list (sub ?)))
+(spawn-world (spawn r (void) (sub ?))
 	     (spawn b 0))
 
-(define (spy e s)
-  (when e (log-info "SPY: ~v" e))
-  #f)
-
-(spawn spy (void) (list (sub ? #:level 1000) (pub ? #:level 1000)))
-
 (define (echoer e s)
   (match e
     [(message (event _ (list (? eof-object?))) _ _) (transition s (quit))]
-    [(message (event _ (list line)) _ _) (transition s (send `(got-line ,line)))]
+    [(message (event _ (list line)) _ _) (transition s (send `(print got-line ,line)))]
     [_ #f]))
 
-(spawn echoer (void) (list (sub (event (read-line-evt (current-input-port) 'any) ?)
-				#:meta-level 1)))
+(spawn echoer (void) (sub (event (read-line-evt (current-input-port) 'any) ?)
+			  #:meta-level 1))
+
+(define (ticker e s)
+  (match e
+    [(routing-update g)
+     (printf "EMPTY? ~v\n" (gestalt-empty? g))
+     (printf "REF:")
+     (pretty-print-matcher (gestalt-ref g 0 0 #f) #:indent 4)
+     (printf "INTERSECTED:\n")
+     (pretty-print-gestalt (gestalt-filter g (pub (set-timer ? ? ?) #:level 1)))
+     #f]
+    [(message (timer-expired 'tick now) _ _)
+     (printf "TICK ~v\n" now)
+     (transition (+ s 1) (if (< s 3)
+			     (send (set-timer 'tick 1000 'relative))
+			     (quit)))]
+    [_ #f]))
+
+(spawn-timer-driver)
+(send (set-timer 'tick 1000 'relative))
+(spawn ticker 1 (gestalt-union (pub (set-timer ? ? ?) #:level 1)
+			       (sub (timer-expired 'tick ?))))
+
+(define (printer e s)
+  (match e
+    [(message (cons 'print v) _ _)
+     (log-info "PRINTER: ~a" v)
+     #f]
+    [_ #f]))
+
+(spawn printer (void) (sub `(print . ,?)))

minimart/examples/example-plain.rkt

@@ -3,10 +3,11 @@
 (require racket/match)
 (require (only-in racket/port read-line-evt))
 (require "../main.rkt")
+(require "../drivers/timer.rkt")
 
 (define (r e s)
   (match e
-    [(message body _ _) (transition s (send `(got ,body) #:meta-level 1))]
+    [(message body _ _) (transition s (send `(print got ,body) #:meta-level 1))]
     [_ #f]))
 
 (define (b e n)
@@ -16,18 +17,41 @@
 	    #f)]
     [_ #f]))
 
-(define (spy e s)
-  (when e (log-info "SPY: ~v" e))
-  #f)
-
 (define (echoer e s)
   (match e
     [(message (event _ (list (? eof-object?))) _ _) (transition s (quit))]
-    [(message (event _ (list line)) _ _) (transition s (send `(got-line ,line)))]
+    [(message (event _ (list line)) _ _) (transition s (send `(print got-line ,line)))]
     [_ #f]))
 
-(run-ground (spawn-world (spawn r (void) (list (sub ?)))
+(define (ticker e s)
+  (match e
+    [(routing-update g)
+     (printf "EMPTY? ~v\n" (gestalt-empty? g))
+     (printf "REF:")
+     (pretty-print-matcher (gestalt-ref g 0 0 #f) #:indent 4)
+     (printf "INTERSECTED:\n")
+     (pretty-print-gestalt (gestalt-filter g (pub (set-timer ? ? ?) #:level 1)))
+     #f]
+    [(message (timer-expired 'tick now) _ _)
+     (printf "TICK ~v\n" now)
+     (transition (+ s 1) (if (< s 3)
+			     (send (set-timer 'tick 1000 'relative))
+			     (quit)))]
+    [_ #f]))
+
+(define (printer e s)
+  (match e
+    [(message (cons 'print v) _ _)
+     (log-info "PRINTER: ~a" v)
+     #f]
+    [_ #f]))
+
+(run-ground (spawn-timer-driver)
+	    (send (set-timer 'tick 1000 'relative))
+	    (spawn ticker 1 (gestalt-union (pub (set-timer ? ? ?) #:level 1)
+					   (sub (timer-expired 'tick ?))))
+	    (spawn-world (spawn r (void) (sub ?))
 			 (spawn b 0))
-	    (spawn echoer (void) (list (sub (event (read-line-evt (current-input-port) 'any) ?)
-					    #:meta-level 1)))
-	    (spawn spy (void) (list (sub ? #:level 1000) (pub ? #:level 1000))))
+	    (spawn echoer (void) (sub (event (read-line-evt (current-input-port) 'any) ?)
+				      #:meta-level 1))
+	    (spawn printer (void) (sub `(print . ,?))))