diff --git a/minimart/core.rkt b/minimart/core.rkt index ecb6e7c..4d2faf6 100644 --- a/minimart/core.rkt +++ b/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))] diff --git a/minimart/examples/example-lang.rkt b/minimart/examples/example-lang.rkt index 540d365..37b4e17 100644 --- a/minimart/examples/example-lang.rkt +++ b/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] diff --git a/minimart/examples/example-plain.rkt b/minimart/examples/example-plain.rkt index 0de583b..f02ca20 100644 --- a/minimart/examples/example-plain.rkt +++ b/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] diff --git a/minimart/gestalt.rkt b/minimart/gestalt.rkt index 2b25dc6..b9d60bc 100644 --- a/minimart/gestalt.rkt +++ b/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))))))) diff --git a/minimart/ground.rkt b/minimart/ground.rkt index c1156fe..6fa52ba 100644 --- a/minimart/ground.rkt +++ 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 diff --git a/minimart/main.rkt b/minimart/main.rkt index f98df88..cdf15d7 100644 --- a/minimart/main.rkt +++ b/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")) diff --git a/minimart/route.rkt b/minimart/route.rkt index 04b10dd..6f3a7cf 100644 --- a/minimart/route.rkt +++ b/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 ()