diff --git a/minimart/core.rkt b/minimart/core.rkt index 8de10dc..ab0435f 100644 --- a/minimart/core.rkt +++ b/minimart/core.rkt @@ -22,10 +22,9 @@ (struct-out capture) pretty-print-matcher matcher->pretty-string - matcher-key-set - matcher-key-set/single - projection->pattern matcher-empty? + (rename-out [projection->pattern matcher-projection->pattern] + [compile-projection compile-matcher-projection]) sub pub diff --git a/minimart/demand-matcher.rkt b/minimart/demand-matcher.rkt index d175926..9e2c223 100644 --- a/minimart/demand-matcher.rkt +++ b/minimart/demand-matcher.rkt @@ -5,6 +5,7 @@ (require racket/match) (require "core.rkt") (require "gestalt.rkt") +(require (only-in "route.rkt" matcher-key-set)) (provide (except-out (struct-out demand-matcher) demand-matcher) (rename-out [make-demand-matcher demand-matcher]) @@ -48,8 +49,8 @@ increase-handler ;; ChangeHandler [decrease-handler default-decrease-handler]) ;; ChangeHandler (demand-matcher demand-is-subscription? - (projection->pattern projection) - (compile-gestalt-projection projection) + (matcher-projection->pattern projection) + (compile-matcher-projection projection) meta-level demand-level supply-level @@ -65,8 +66,8 @@ ;; demanded supply. (define (demand-matcher-update d s g) (match-define (demand-matcher demand-is-sub? _ spec ml dl sl inc-h dec-h old-demand old-supply) d) - (define new-demand (matcher-key-set (gestalt-project g ml dl (not demand-is-sub?) spec))) - (define new-supply (matcher-key-set (gestalt-project g ml sl demand-is-sub? spec))) + (define new-demand (matcher-key-set (gestalt-project* g ml dl (not demand-is-sub?) spec))) + (define new-supply (matcher-key-set (gestalt-project* g ml sl demand-is-sub? spec))) (define demand+ (set-subtract (set-subtract new-demand old-demand) new-supply)) (define supply- (set-intersect (set-subtract old-supply new-supply) new-demand)) (define new-d (struct-copy demand-matcher d diff --git a/minimart/examples/chat-userland.rkt b/minimart/examples/chat-userland.rkt index 6e292de..262abca 100644 --- a/minimart/examples/chat-userland.rkt +++ b/minimart/examples/chat-userland.rkt @@ -19,9 +19,7 @@ (sub (tcp-channel them us ?) #:meta-level 1 #:level 1) (sub (tcp-channel them us ?) #:meta-level 1))) - (define (gestalt->peers g) - (matcher-key-set/single - (gestalt-project g 0 0 #t (compile-gestalt-projection `(,(?!) says ,?))))) + (define (gestalt->peers g) (gestalt-project/single g (project-pubs `(,(?!) says ,?)))) (userland-thread #:gestalt (gestalt-union tcp-gestalt (sub `(,? says ,?)) diff --git a/minimart/examples/chat-userland2.rkt b/minimart/examples/chat-userland2.rkt index 0f2db70..2bc17e2 100644 --- a/minimart/examples/chat-userland2.rkt +++ b/minimart/examples/chat-userland2.rkt @@ -43,9 +43,7 @@ (loop old-peers)] [(routing-update g) (when (gestalt-empty? (gestalt-filter g tcp-gestalt)) (do (quit))) - (define new-peers - (matcher-key-set/single - (gestalt-project g 0 0 #t (compile-gestalt-projection `(,(?!) says ,?))))) + (define new-peers (gestalt-project/single g (project-pubs `(,(?!) says ,?)))) (for/list [(who (set-subtract new-peers old-peers))] (say who "arrived.")) (for/list [(who (set-subtract old-peers new-peers))] (say who "departed.")) (loop new-peers)])))) diff --git a/minimart/examples/chat.rkt b/minimart/examples/chat.rkt index d86050f..fbd2c47 100644 --- a/minimart/examples/chat.rkt +++ b/minimart/examples/chat.rkt @@ -7,8 +7,8 @@ (define (spawn-session them us) (define user (gensym 'user)) - (define remote-detector (compile-gestalt-projection (?!))) - (define peer-detector (compile-gestalt-projection `(,(?!) says ,?))) + (define remote-detector (project-pubs #:meta-level 1 (?!))) + (define peer-detector (project-pubs `(,(?!) says ,?))) (define (send-to-remote fmt . vs) (send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))) (define (say who fmt . vs) @@ -23,11 +23,10 @@ [(message `(,who says ,what) 0 #f) (transition old-peers (say who "says: ~a" what))] [(routing-update g) - (define new-peers - (matcher-key-set/single (gestalt-project g 0 0 #t peer-detector))) + (define new-peers (gestalt-project/single g peer-detector)) (transition new-peers - (list (when (matcher-empty? (gestalt-project g 1 0 #t remote-detector)) (quit)) + (list (when (matcher-empty? (gestalt-project g remote-detector)) (quit)) (for/list [(who (set-subtract new-peers old-peers))] (say who "arrived.")) (for/list [(who (set-subtract old-peers new-peers))] diff --git a/minimart/gestalt.rkt b/minimart/gestalt.rkt index 6b7d730..9388cd0 100644 --- a/minimart/gestalt.rkt +++ b/minimart/gestalt.rkt @@ -9,9 +9,16 @@ (provide (struct-out gestalt) gestalt-match-value - compile-gestalt-projection - compile-gestalt-projection* + + project-subs + project-pubs + projection? + projection->gestalt + gestalt-project* gestalt-project + gestalt-project/keys + gestalt-project/single + drop-gestalt lift-gestalt simple-gestalt @@ -67,6 +74,10 @@ ;; Convention: A GestaltSet is a Gestalt where the Matchers map to #t ;; instead of (NonemptySetof PID) or any other value. +;; A GestaltProjection is a single-metalevel, single-level fragment of +;; a gestalt with capture-groups. See matcher-project in route.rkt. +(struct projection (metalevel level get-advertisements? spec compiled) #:transparent) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; (Listof X) Nat [-> X] -> X @@ -117,24 +128,48 @@ (define (pids-at level) (matcher-match-value (extract-matcher level) body)) (apply set-union (set) (map pids-at (gestalt-metalevel-ref g metalevel)))) -;; (Listof Projection) -> CompiledProjection -;; For use with gestalt-project. -(define (compile-gestalt-projection* specs) - (compile-projection* specs)) +;; project-subs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection +;; project-pubs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection +;; +;; Construct projectors representing subscriptions/advertisements +;; matching the given pattern, at the given meta-level and level. +;; Used with gestalt-project. +(define (project-subs p #:meta-level [ml 0] #:level [l 0]) + (projection ml l #f p (compile-projection p))) +(define (project-pubs p #:meta-level [ml 0] #:level [l 0]) + (projection ml l #t p (compile-projection p))) -;; Projection* -> CompiledProjection -;; For use with gestalt-project. -(define (compile-gestalt-projection . specs) - (compile-gestalt-projection* specs)) +;; GestaltProjection -> Gestalt +;; Converts a projection to an atomic unit of gestalt. +(define (projection->gestalt pr) + (simple-gestalt (not (projection-get-advertisements? pr)) + (projection->pattern (projection-spec pr)) + (projection-level pr) + (projection-metalevel pr))) -;; Gestalt × Natural × Natural × Boolean × CompiledProjection → Matcher -;; Retrieves the Matcher within g at the given metalevel and level, -;; representing subscriptions or advertisements, projected by capture-spec. -(define (gestalt-project g metalevel level get-advertisements? capture-spec) +;; Gestalt × Nat × Nat × Boolean × CompiledProjection → Matcher +;; Retrieves the Matcher within g projected by the arguments. +(define (gestalt-project* g metalevel level get-advertisements? capture-spec) (define extract-matcher (if get-advertisements? cdr car)) (define l (safe-list-ref (gestalt-metalevel-ref g metalevel) level (lambda () empty-level))) (matcher-project (extract-matcher l) capture-spec)) +;; Gestalt × GestaltProjection → Matcher +;; Retrieves the Matcher within g projected by pr. +(define (gestalt-project g pr) + (match-define (projection metalevel level get-advertisements? _ capture-spec) pr) + (gestalt-project* g metalevel level get-advertisements? capture-spec)) + +;; Gestalt × GestaltProjection → (Option (Setof (Listof Value))) +;; Projects g with pr and calls matcher-key-set on the result. +(define (gestalt-project/keys g pr) + (matcher-key-set (gestalt-project g pr))) + +;; Gestalt × GestaltProjection → (Option (Setof Value)) +;; Projects g with pr and calls matcher-key-set/single on the result. +(define (gestalt-project/single g pr) + (matcher-key-set/single (gestalt-project g pr))) + ;; Gestalt -> Gestalt ;; Discards the 0th metalevel, renumbering others appropriately. ;; Used to map a Gestalt from a World to Gestalts of its containing World. diff --git a/minimart/ground.rkt b/minimart/ground.rkt index b751508..b3ae042 100644 --- a/minimart/ground.rkt +++ b/minimart/ground.rkt @@ -35,23 +35,21 @@ (define (event-handler descriptor) (handle-evt descriptor (lambda vs (send (event descriptor vs))))) -;; CompiledProjection +;; GestaltProjection ;; Used to extract event descriptors and results from subscriptions ;; from the ground VM's contained World. -(define event-projection (compile-gestalt-projection (event (?!) ?))) +(define event-projection (project-subs (event (?!) ?))) ;; Gestalt -> (Listof RacketEvent) ;; Projects out the active event subscriptions from the given gestalt. (define (extract-active-events gestalt) - (define es (matcher-key-set (gestalt-project gestalt 0 0 #f event-projection))) + (define es (gestalt-project/single gestalt 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 ;; process be identified and terminated? (unless es (error 'extract-active-events "User program subscribed to wildcard event")) - (for/list [(ev (in-set es))] - (match-define (list e) ev) - (event-handler e))) + (for/list [(e (in-set es))] (event-handler e))) ;; RacketEvent ;; Used only when the system is not provably inert, in order to let it