Reformulate gestalts (again). Back to metalevel/level/pattern rather than metalevel/pattern/level.

minimart/core.rkt

@@ -20,20 +20,10 @@
 	 ?!
 	 capture?
 	 pretty-print-matcher
+	 matcher-key-set
 
 	 sub
 	 pub
-	 gestalt-empty
-	 gestalt-union
-	 gestalt-filter
-	 gestalt-empty?
-	 gestalt-ref
-	 compile-gestalt-projection
-	 gestalt-project
-	 matcher-project-level
-	 matcher-project
-	 matcher-key-set
-	 pretty-print-gestalt
 
 	 spawn
 	 send
@@ -269,8 +259,7 @@
 (define (dispatch-event e w)
   (match e
     [(message body meta-level feedback?)
-     (define matcher (gestalt-ref (world-aggregate-gestalt w) meta-level feedback?))
-     (define pids (levels->pids (matcher-match-value matcher body '())))
+     (define pids (gestalt-match-value (world-aggregate-gestalt w) body meta-level feedback?))
      (define pt (world-process-table w))
      (for/fold ([w w]) [(pid (in-set pids))]
        (apply-transition pid (deliver-event e pid (hash-ref pt pid)) w))]

minimart/examples/example-lang.rkt

@@ -46,8 +46,6 @@
   (match e
     [(routing-update g)
      (printf "EMPTY? ~v\n" (gestalt-empty? g))
-     (printf "REF:")
-     (pretty-print-matcher (gestalt-ref g 0 #f) #:indent 4)
      (printf "INTERSECTED:\n")
      (pretty-print-gestalt (gestalt-filter g (pub (set-timer ? ? ?) #:level 1)))
      #f]

minimart/examples/example-plain.rkt

@@ -38,8 +38,6 @@
   (match e
     [(routing-update g)
      (printf "EMPTY? ~v\n" (gestalt-empty? g))
-     (printf "REF:")
-     (pretty-print-matcher (gestalt-ref g 0 #f) #:indent 4)
      (printf "INTERSECTED:\n")
      (pretty-print-gestalt (gestalt-filter g (pub (set-timer ? ? ?) #:level 1)))
      #f]

minimart/gestalt.rkt

@@ -7,11 +7,9 @@
 (require "route.rkt")
 
 (provide (struct-out gestalt)
-	 gestalt-ref
+	 gestalt-match-value
 	 compile-gestalt-projection
 	 gestalt-project
-	 matcher-project-level
-	 levels->pids
 	 drop-gestalt
 	 lift-gestalt
 	 simple-gestalt
@@ -25,19 +23,20 @@
 	 label-gestalt
 	 pretty-print-gestalt)
 
-;; A Gestalt is a (gestalt (Listof (Pairof Matcher Matcher))),
+;; A Gestalt is a (gestalt (Listof (Listof (Pairof Matcher Matcher)))),
 ;; representing the total interests of a process or group of
-;; processes. The outer list has a present entry for each active
-;; metalevel, starting with metalevel 0 in the car. The inner pairs
-;; have cars holding matchers representing active subscriptions, and
-;; cdrs representing active advertisements. Each of the Matchers maps
-;; to (Listof (Option (Setof PID))), with the nth entry in the list
-;; corresponding to level n, and #f corresponding to empty-set.
+;; processes.
 ;;
-;; So,
-;; - metalevels: entries in the outermost list.
-;; - sub/adv: car or cdr of each inner pair, respectively.
-;; - levels: entries in the list at each Matcher success value.
+;; The outer list has an entry for each active metalevel, starting
+;; with metalevel 0 in the car.
+;;
+;; The middle list has an entry for each active level within its
+;; metalevel, starting with level 0 in the car.
+;;
+;; The inner pairs have cars holding matchers representing active
+;; subscriptions, and cdrs representing active advertisements.
+;;
+;; Each of the Matchers maps to (NonemptySetof PID).
 ;;
 ;;
 ;;    "... a few standardised subsystems, identical from citizen to
@@ -49,9 +48,12 @@
 ;;
 (struct gestalt (metalevels) #:prefab)
 
-;; Convention: A GestaltSet is a Gestalt where all the Matchers map to
-;; (Listof (Option #t)) rather than the (Listof (Option (Setof PID)))
-;; described above or any other value.
+;; Convention: A GestaltSet is a Gestalt where the Matchers map to #t
+;; instead of (NonemptySetof PID) or any other value.
+
+;; TODO: consider caching the unioning that happens when a high-level
+;; subscription is smeared across lower levels for the purposes of
+;; filtering and matching of routing-updates.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -61,12 +63,6 @@
       ['() (fail-thunk)]
       [(cons x xs) (if (zero? n) x (loop xs (- n 1)))])))
 
-(define (safe-take gcons xs n)
-  (let walk ((xs xs) (n n))
-    (cond [(null? xs) '()]
-	  [(zero? n) '()]
-	  [else (gcons (car xs) (walk (cdr xs) (- n 1)))])))
-
 (define (safe-cdr xs)
   (if (null? xs)
       '()
@@ -77,33 +73,37 @@
       '()
       (cons a d)))
 
-(define cons-level (guarded-cons #f))
-(define cons-metalevel (guarded-cons '(#f . #f)))
+(define (guarded-map gcons f xs)
+  (foldr (lambda (e acc) (gcons (f e) acc)) '() xs))
 
-;; Gestalt × Natural × Boolean → Matcher
-(define (gestalt-ref g metalevel get-advertisements?)
-  (define v (safe-list-ref (gestalt-metalevels g) metalevel (lambda () '(#f . #f))))
-  ((if get-advertisements? cdr car) v))
+(define empty-level '(#f . #f))
+(define empty-metalevel '())
+
+(define cons-level (guarded-cons empty-level))
+(define cons-metalevel (guarded-cons empty-metalevel))
+
+;; Gestalt × Value × Natural × Boolean → (Setof PID)
+(define (gestalt-match-value g body metalevel is-feedback?)
+  (define levels (safe-list-ref (gestalt-metalevels g) metalevel (lambda () empty-metalevel)))
+  (for/fold [(acc (set))] [(level (in-list levels))]
+    (define matcher ((if is-feedback? cdr car) level)) ;; feedback targets advertisers/publishers
+    (set-union (matcher-match-value matcher body) acc)))
 
 (define (compile-gestalt-projection spec)
   (compile-projection spec))
 
-;; Limits the given matcher to only include keys when a subscription
-;; at *exactly* the given level exists.
-(define (matcher-project-level m level)
-  (matcher-relabel m (lambda (v) (and (safe-list-ref v level (lambda () #f)) #t))))
-
-(define (gestalt-project g metalevel get-advertisements? capture-spec)
-  (matcher-project (gestalt-ref g metalevel get-advertisements?) capture-spec))
-
-(define (levels->pids ls)
-  (foldl (lambda (e acc) (if e (set-union e acc) acc)) (set) ls))
+;; Gestalt × Natural × Natural × Boolean × CompiledSpec → Matcher
+(define (gestalt-project g metalevel level get-advertisements? capture-spec)
+  (define levels (safe-list-ref (gestalt-metalevels g) metalevel (lambda () empty-metalevel)))
+  (define matcher ((if get-advertisements? cdr car)
+		   (safe-list-ref levels level (lambda () empty-level))))
+  (matcher-project matcher capture-spec))
 
 (define (drop-gestalt g)
   (gestalt (safe-cdr (gestalt-metalevels g))))
 
 (define (lift-gestalt g)
-  (gestalt (cons-metalevel '(#f . #f) (gestalt-metalevels g))))
+  (gestalt (cons-metalevel empty-metalevel (gestalt-metalevels g))))
 
 (define (prepend n x xs)
   (if (zero? n)
@@ -111,13 +111,16 @@
       (cons x (prepend (- n 1) x xs))))
 
 (define (simple-gestalt is-adv? p level metalevel)
-  (define m (pattern->matcher (prepend level #f (list #t)) p))
-  (gestalt (prepend metalevel '(#f . #f) (list (if is-adv? (cons #f m) (cons m #f))))))
+  (define m (pattern->matcher #t p))
+  (gestalt (prepend metalevel empty-metalevel
+		    (list (prepend level empty-level
+				   (list (if is-adv? (cons #f m) (cons m #f))))))))
 
 (define (gestalt-empty) (gestalt '()))
 
 (define (gestalt-empty? g)
-  (andmap (lambda (ml) (and (matcher-empty? (car ml)) (matcher-empty? (cdr ml))))
+  (andmap (lambda (ml)
+	    (andmap (lambda (l) (and (matcher-empty? (car l)) (matcher-empty? (cdr l)))) ml))
 	  (gestalt-metalevels g)))
 
 (define (map-zip imbalance-handler item-handler gcons ls1 ls2)
@@ -130,7 +133,10 @@
        (gcons (item-handler l1 l2) (walk ls1 ls2))])))
 
 (define (gestalt-combine g1 g2 imbalance-handler matcher-pair-combiner)
-  (gestalt (map-zip imbalance-handler matcher-pair-combiner cons-metalevel
+  (gestalt (map-zip imbalance-handler
+		    (lambda (ls1 ls2)
+		      (map-zip imbalance-handler matcher-pair-combiner cons-level ls1 ls2))
+		    cons-metalevel
 		    (gestalt-metalevels g1)
 		    (gestalt-metalevels g2))))
 
@@ -148,20 +154,6 @@
 		     (cons (matcher-combiner (car sa1) (cdr sa2))
 			   (matcher-combiner (car sa2) (cdr sa1))))))
 
-(define (empty->false s) (if (set-empty? s) #f s))
-
-(define (union-levels m1 m2)
-  (matcher-union m1 m2
-		 #:combine
-		 (lambda (ls1 ls2)
-		   (map-zip (lambda (side x) x)
-			    (lambda (s1 s2) (empty->false (set-union (or s1 (set)) (or s2 (set)))))
-			    cons-level
-			    ls1
-			    ls2))))
-
-(define (gestalt-union1 g1 g2) (gestalt-combine-straight g1 g2 (lambda (side x) x) union-levels))
-
 (define (gestalt-union . gs)
   (if (null? gs)
       (gestalt-empty)
@@ -170,27 +162,17 @@
 	  [(list g) g]
 	  [(cons g rest) (gestalt-union1 g (walk rest))]))))
 
-(define (filter-levels ls1 ls2)
-  (define r (safe-take cons-level ls1 (- (length ls2) 1)))
-  (if (null? r) #f r))
-(define (filter-matchers m1 m2) (matcher-intersect m1 m2 #:combine filter-levels))
+(define (gestalt-union1 g1 g2) (gestalt-combine-straight g1 g2 (lambda (side x) x) matcher-union))
+
+(define (shorter-imbalance-handler side x) '())
 
 ;; View on g1 from g2's perspective.
-;; Drops a level from g2 and intersects crossed.
 (define (gestalt-filter g1 g2)
-  (gestalt-combine-crossed g1 g2 (lambda (side x) '()) filter-matchers))
-
-;; Here we want all pids in sets in ls2 such that there are some pids
-;; at lower levels in ls1.
-(define (match-combine-levels ls1 ls2 acc)
-  (let loop ((ls1 ls1) (ls2 ls2))
-    (cond
-     [(null? ls1) acc]
-     [(null? ls2) acc]
-     [(not (car ls1)) (loop (cdr ls1) (cdr ls2))]
-     [else ;; aha! here's a real sub/adv in ls1. The remaining
-	   ;; sub/advs in (cdr ls2) can see it.
-      (levels->pids (cdr ls2))])))
+  (gestalt (map-zip shorter-imbalance-handler
+		    filter-one-metalevel
+		    cons-metalevel
+		    (gestalt-metalevels g1)
+		    (gestalt-metalevels g2))))
 
 ;; Much like gestalt-filter, takes a view on gestalt g1 from g2's
 ;; perspective. However, instead of returning the filtered g1, returns
@@ -201,72 +183,104 @@
 	     (mls2 (gestalt-metalevels g2)))
     (cond [(null? mls1) (set)]
 	  [(null? mls2) (set)]
-	  [else (match-define (cons subs1 advs1) (car mls1))
-		(match-define (cons subs2 advs2) (car mls2))
-		(let* ((acc (loop (cdr mls1) (cdr mls2)))
-		       (acc (matcher-match-matcher subs1 advs2
-						   #:combine match-combine-levels
-						   #:empty acc))
-		       (acc (matcher-match-matcher advs1 subs2
-						   #:combine match-combine-levels
-						   #:empty acc)))
-		  acc)])))
+	  [else (match-define (cons ls1 rest1) mls1)
+		(match-define (cons ls2 rest2) mls2)
+		(set-union (match-one-metalevel ls1 ls2)
+			   (loop rest1 rest2))])))
+
+;; Returns ls, with one level dropped, and with the remaining matchers
+;; "smeared" across lower levels. This could end up being reasonably
+;; expensive - see above TODO about possibly caching it.
+(define (smear-levels ls)
+  (foldr (lambda (p acc)
+	   (match-define (cons acc-subs acc-advs) (if (null? acc) empty-level (car acc)))
+	   (match-define (cons new-subs new-advs) p)
+	   (cons (cons (matcher-union new-subs acc-subs)
+		       (matcher-union new-advs acc-advs))
+		 acc))
+	 '()
+	 (safe-cdr ls)))
+
+(define (filter-one-metalevel ls1 ls2)
+  (let loop ((ls1 ls1) (ls2 (smear-levels ls2)))
+    (cond [(null? ls1) '()]
+	  [(null? ls2) '()]
+	  [else (match-define (cons (cons subs1 advs1) rest1) ls1)
+		(match-define (cons (cons subs2 advs2) rest2) ls2)
+		(cons-level (cons (matcher-intersect subs1 advs2 #:combine (lambda (v1 v2) v1))
+				  (matcher-intersect advs1 subs2 #:combine (lambda (v1 v2) v1)))
+			    (loop rest1 rest2))])))
+
+(define (match-matchers m1 m2)
+  (matcher-match-matcher m1 m2 #:combine (lambda (v1 v2 acc) (set-union v2 acc)) #:empty (set)))
+
+(define (match-one-metalevel ls1 ls2)
+  (let loop ((ls1 ls1) (ls2 (smear-levels ls2)))
+    (cond [(null? ls1) (set)]
+	  [(null? ls2) (set)]
+	  [else (match-define (cons (cons subs1 advs1) rest1) ls1)
+		(match-define (cons (cons subs2 advs2) rest2) ls2)
+		(set-union (match-matchers subs1 advs2)
+			   (match-matchers advs1 subs2)
+			   (loop rest1 rest2))])))
+
+(define (gestalt-erase-path g1 g2)
+  (gestalt-combine-straight g1 g2
+			    erase-imbalance-handler
+			    matcher-erase-path))
 
 (define (erase-imbalance-handler side x)
   (case side
     [(left-longer) x]
     [(right-longer) '()]))
 
-(define (erase-levels ls1 ls2)
-  (map-zip erase-imbalance-handler
-	   (lambda (v1 v2) (empty->false (set-subtract (or v1 (set)) (or v2 (set)))))
-	   cons-level
-	   ls1
-	   ls2))
-
-(define (gestalt-erase-path g1 g2)
-  (gestalt-combine-straight g1 g2
-			    erase-imbalance-handler
-			    (lambda (m1 m2) (matcher-erase-path m1 m2 #:combine erase-levels))))
-
-(define ((guarded-map gcons) f xs)
-  (foldr (lambda (e acc) (gcons (f e) acc)) '() xs))
-
-(define map-metalevels (guarded-map cons-metalevel))
-
 (define (gestalt-matcher-transform g f)
-  (gestalt (map-metalevels (lambda (p) (cons (f (car p)) (f (cdr p))))
-			   (gestalt-metalevels g))))
+  (gestalt (guarded-map cons-metalevel
+			(lambda (ls)
+			  (guarded-map cons-level (lambda (p) (cons (f (car p)) (f (cdr p)))) ls))
+			(gestalt-metalevels g))))
 
 (define (strip-gestalt-label g)
-  (define (xform ls) (map (lambda (l) (and l #t)) ls))
-  (gestalt-matcher-transform g (lambda (m) (matcher-relabel m xform))))
+  (gestalt-matcher-transform g (lambda (m) (matcher-relabel m (lambda (v) #t)))))
 
 (define (label-gestalt g pid)
   (define pidset (set pid))
-  (define (xform ls) (map (lambda (l) (and l pidset)) ls))
-  (gestalt-matcher-transform g (lambda (m) (matcher-relabel m xform))))
+  (gestalt-matcher-transform g (lambda (m) (matcher-relabel m (lambda (v) pidset)))))
 
 (define (pretty-print-gestalt g [port (current-output-port)])
-  (for [(metalevel (in-naturals)) (p (in-list (gestalt-metalevels g)))]
-    (match-define (cons subs advs) p)
-    (when (or subs advs)
-      (fprintf port "GESTALT metalevel ~v:\n" metalevel)
-      (when subs (fprintf port "  - subs:") (pretty-print-matcher subs port #:indent 9))
-      (when advs (fprintf port "  - advs:") (pretty-print-matcher advs port #:indent 9)))))
+  (for [(metalevel (in-naturals)) (ls (in-list (gestalt-metalevels g)))]
+    (for [(level (in-naturals)) (p (in-list ls))]
+      (match-define (cons subs advs) p)
+      (when (or subs advs)
+	(fprintf port "GESTALT metalevel ~v level ~v:\n" metalevel level)
+	(when subs (fprintf port "  - subs:") (pretty-print-matcher subs port #:indent 9))
+	(when advs (fprintf port "  - advs:") (pretty-print-matcher advs port #:indent 9))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (module+ test
   (require rackunit)
 
+  (check-equal? (simple-gestalt #f 'a 0 0)
+		(gestalt (list (list (cons (pattern->matcher #t 'a) #f)))))
+  (check-equal? (simple-gestalt #t 'b 0 0)
+		(gestalt (list (list (cons #f (pattern->matcher #t 'b))))))
+  (check-equal? (simple-gestalt #f 'a 2 2)
+		(gestalt (list empty-metalevel empty-metalevel
+			       (list empty-level empty-level
+				     (cons (pattern->matcher #t 'a) #f)))))
+  (check-equal? (simple-gestalt #t 'b 2 2)
+		(gestalt (list empty-metalevel empty-metalevel
+			       (list empty-level empty-level
+				     (cons #f (pattern->matcher #t 'b))))))
+
   (check-equal? (gestalt-union (simple-gestalt #f 'a 0 0)
 			       (simple-gestalt #t 'b 0 0))
-		(gestalt (list (cons (pattern->matcher (list #t) 'a)
-				     (pattern->matcher (list #t) 'b)))))
+		(gestalt (list (list (cons (pattern->matcher #t 'a)
+					   (pattern->matcher #t 'b))))))
   (check-equal? (gestalt-union (simple-gestalt #f 'a 2 2)
 			       (simple-gestalt #t 'b 2 2))
-		(gestalt (list (cons #f #f)
-			       (cons #f #f)
-			       (cons (pattern->matcher (list #f #f #t) 'a)
-				     (pattern->matcher (list #f #f #t) 'b))))))
+		(gestalt (list empty-metalevel empty-metalevel
+			       (list empty-level empty-level
+				     (cons (pattern->matcher #t 'a)
+					   (pattern->matcher #t 'b)))))))

minimart/ground.rkt

@@ -4,6 +4,7 @@
 (require racket/match)
 (require racket/list)
 (require "core.rkt")
+(require "gestalt.rkt")
 
 (provide (struct-out event)
 	 run-ground)
@@ -16,8 +17,7 @@
 (define event-projection (compile-gestalt-projection (event ?! ?)))
 
 (define (extract-active-events gestalt)
-  (define es
-    (matcher-key-set (matcher-project-level (gestalt-project gestalt 0 #f event-projection) 0)))
+  (define es (matcher-key-set (gestalt-project gestalt 0 0 #f event-projection)))
   ;; TODO: how should the following error be handled, ideally?
   ;; In principle, security restrictions should make it impossible.
   ;; But absent those, what should be done? Should an offending

minimart/main.rkt

@@ -1,8 +1,10 @@
 #lang racket/base
 
 (require "core.rkt")
+(require "gestalt.rkt")
 (require "ground.rkt")
 
 (provide (all-from-out "core.rkt")
+	 (all-from-out "gestalt.rkt")
 	 (all-from-out "ground.rkt"))
 

minimart/route.rkt

@@ -26,6 +26,9 @@
 	 matcher-key-set
 	 pretty-print-matcher)
 
+;; TODO: consider currying matcher-union and friends to specialize
+;; them for specific combiners.
+
 (define-syntax-rule (define-singleton-struct singleton-name struct-name print-representation)
   (begin
     (struct struct-name ()