diff --git a/prospect/core.rkt b/prospect/core.rkt index 4668fea..b4a04bd 100644 --- a/prospect/core.rkt +++ b/prospect/core.rkt @@ -329,9 +329,12 @@ (struct-copy world w [process-table (hash-set (world-process-table w) label p)])))) (apply-patch-in-world label delta new-w)] [else ;; we can still apply actions for nonexistent processes, - ;; but we can't limit the patches, making their zombie - ;; patch actions potentially less efficient. - (apply-patch-in-world label delta-orig w)])] + ;; but we have to limit the patches by consulting the + ;; whole routing table, making their zombie patch actions + ;; potentially less efficient. + (define delta (limit-patch/routing-table (label-patch delta-orig (set label)) + (world-routing-table w))) + (apply-patch-in-world label delta w)])] [(and m (message body)) (when (observe? body) (log-warning "Process ~a sent message containing query ~v" @@ -351,6 +354,8 @@ (and local-to-meta? (message (at-meta-claim body))))])])) +;; PRECONDITION: delta has been limited to be minimal with respect to +;; existing interests of its label in w's routing table. (define (apply-patch-in-world label delta w) (define old-routing-table (world-routing-table w)) (define new-routing-table (apply-patch old-routing-table delta)) diff --git a/prospect/patch.rkt b/prospect/patch.rkt index 9004319..7b40c01 100644 --- a/prospect/patch.rkt +++ b/prospect/patch.rkt @@ -16,6 +16,7 @@ strip-patch label-patch limit-patch + limit-patch/routing-table compute-aggregate-patch apply-patch update-interests @@ -94,15 +95,67 @@ (patch (label-interests (patch-added p) label) (label-interests (patch-removed p) label))) +;; Requires set-labelled p and bound, but assumes that the label sets +;; only ever contain one element. (define (limit-patch p bound) (match-define (patch in out) p) (patch (matcher-subtract in bound #:combiner (lambda (v1 v2) #f)) (matcher-intersect out bound #:combiner (lambda (v1 v2) v1)))) +;; Like limit-patch, but for use when the precise bound for p's label +;; isn't known (such as when a process terminates with remaining +;; queued actions), so we have to examine the whole area of the +;; routing table touched by p. +;; +;; Unlike limit-patch, accepts label sets with arbitrary elements. +(define (limit-patch/routing-table p bound) + (match-define (patch in out) p) + (patch (matcher-subtract in bound) + (matcher-intersect out bound + #:combiner (lambda (v1 v2) (empty-set-guard (set-intersect v1 v2)))))) + +;; Entries labelled with `label` may already exist in `base`; the +;; patch `p` MUST already have been limited to add only where no +;; `label`-labelled portions of `base` exist, and to remove only where +;; `label`-labelled portions of `base` exist. `base` must, then, be a +;; "pre-modification" routing table. Use `limit-patch` to compute a +;; suitable `p`, where the bound is known; otherwise, use +;; `limit-patch/routing-table`. +;; +;; The goal here is to say "here is the effect of `p` on the overall +;; coverage established by the non-`label` participants in the +;; interest-set `base`". While `p` might add quite a bit of coverage +;; to `label`'s interests, it might overlap with coverage previously +;; established by others, in which case those portions would +;; experience /no effect/ from p. Likewise, `p` may remove interests +;; from `label`'s own interests, but where interest remains from other +;; peers, the overall effect will be nil. +;; +;; PRECONDITION: `p` is (set label)-labelled +;; PRECONDITION: `base` is (set ...)-labelled (define (compute-aggregate-patch p label base) - (define (combiner v1 v2) (matcher-subtract-combiner v1 (set-remove v2 label))) - (patch (matcher-subtract (patch-added p) base #:combiner combiner) - (matcher-subtract (patch-removed p) base #:combiner combiner))) + (define (add-combiner v1 v2) + ;; Keep only points where `p` would add, where no `label` interest + ;; is present*, and where no non-`label` interest is present. That + ;; is, keep only points where no existing interest is present at + ;; all. Since add-combiner is called only for points where v2 is + ;; non-empty, meaning that some existing interest is present (and + ;; furthermore, we know that a previous patch-limiting operation + ;; has established that no `label` interest is present at these + ;; points), we can always discard such points by returning a + ;; constant #f. + #f) + (define (rem-combiner v1 v2) + ;; Keep only points where `p` would remove, where `label` interest + ;; is present, and where no non-`label` interest is present. We + ;; know that a previous patch-limiting operation has ensured that + ;; `label` interest is present, so we only need to check whether + ;; any other interest exists at each point. + (if (= (set-count v2) 1) + v1 ;; only `label` interest (previously established) exists here. + #f)) ;; other interest exists here, so we should discard this removed-point. + (patch (matcher-subtract (patch-added p) base #:combiner add-combiner) + (matcher-subtract (patch-removed p) base #:combiner rem-combiner))) ;; For use by Matchers leading to (Setof Label). (define (apply-patch base p) @@ -163,90 +216,157 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (module+ test - (define SP (set 'P)) - (define m0 (matcher-empty)) - (define ma (pattern->matcher SP 'a)) - (define mb (pattern->matcher SP 'b)) - (define mc (pattern->matcher SP 'c)) - (define mab (matcher-union ma mb)) - (define mbc (matcher-union mb mc)) - (define m* (pattern->matcher SP ?)) + (define (set->matcher label xs) + (for/fold [(acc (matcher-empty))] [(x (in-set xs))] + (matcher-union acc (pattern->matcher label x)))) - (printf "\nmab:\n") - (void (pretty-print-matcher mab)) + ;; Retains only entries in R labelled with any subset of the labels in label-set. + (define (project-routing-table R label-set) + (matcher-intersect R + (pattern->matcher label-set ?) + #:combiner (lambda (v1 v2) (empty-set-guard (set-intersect v1 v2))))) - (printf "\ncompute-patch ma mb:\n") - (void (pretty-print-patch (compute-patch ma mb))) + (define (sanity-check-examples) + (define SP (set 'P)) + (define m0 (matcher-empty)) + (define ma (pattern->matcher SP 'a)) + (define mb (pattern->matcher SP 'b)) + (define mc (pattern->matcher SP 'c)) + (define mab (matcher-union ma mb)) + (define mbc (matcher-union mb mc)) + (define m* (pattern->matcher SP ?)) + (define mA (pattern->matcher SP (at-meta 'a))) + (define mAb (matcher-union mA mb)) - (printf "\nlimit-patch m*/m0 mab:\n") - (void (pretty-print-patch (limit-patch (patch m* m0) mab))) + (printf "\nmab:\n") + (void (pretty-print-matcher mab)) - (printf "\nlimit-patch m0/m* mab:\n") - (void (pretty-print-patch (limit-patch (patch m0 m*) mab))) + (printf "\ncompute-patch ma mb:\n") + (void (pretty-print-patch (compute-patch ma mb))) - (printf "\napply mb (limit m*/m0 mab):\n") - (void (pretty-print-matcher (apply-patch mb (limit-patch (patch m* m0) mab)))) + (printf "\nlimit-patch m*/m0 mab:\n") + (void (pretty-print-patch (limit-patch (patch m* m0) mab))) - (printf "\nlimit mbc/ma ma:\n") - (void (pretty-print-patch (limit-patch (patch mbc ma) ma))) + (printf "\nlimit-patch m0/m* mab:\n") + (void (pretty-print-patch (limit-patch (patch m0 m*) mab))) - (printf "\nlimit mab/mc ma:\n") - (void (pretty-print-patch (limit-patch (patch mab mc) ma))) + (printf "\napply mb (limit m*/m0 mab):\n") + (void (pretty-print-matcher (apply-patch mb (limit-patch (patch m* m0) mab)))) - (printf "\nlimit mc/mab ma:\n") - (void (pretty-print-patch (limit-patch (patch mc mab) ma))) + (printf "\nlimit mbc/ma ma:\n") + (void (pretty-print-patch (limit-patch (patch mbc ma) ma))) - (printf "\ncompute-aggregate-patch m*/m0 Q mab:\n") - (void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'Q mab))) + (printf "\nlimit mab/mc ma:\n") + (void (pretty-print-patch (limit-patch (patch mab mc) ma))) - (printf "\ncompute-aggregate-patch m0/m* Q mab:\n") - (void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'Q mab))) + (printf "\nlimit mc/mab ma:\n") + (void (pretty-print-patch (limit-patch (patch mc mab) ma))) - (printf "\ncompute-aggregate-patch m*/m0 P mab:\n") - (void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'P mab))) + (printf "\ncompute-aggregate-patch m*/m0 Q mab:\n") + (void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'Q mab))) - (printf "\ncompute-aggregate-patch m0/m* P mab:\n") - (void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'P mab))) + (printf "\ncompute-aggregate-patch m0/m* Q mab:\n") + (void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'Q mab))) - (printf "\ncompute-aggregate-patch m*/m0 Q m*:\n") - (void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'Q m*))) + (printf "\ncompute-aggregate-patch m*/m0 P mab:\n") + (void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'P mab))) - (printf "\ncompute-aggregate-patch m0/m* Q m*:\n") - (void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'Q m*))) + (printf "\ncompute-aggregate-patch m0/m* P mab:\n") + (void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'P mab))) - (printf "\ncompute-aggregate-patch m*/m0 P m*:\n") - (void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'P m*))) + (printf "\ncompute-aggregate-patch m*/m0 Q m*:\n") + (void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'Q m*))) - (printf "\ncompute-aggregate-patch m0/m* P m*:\n") - (void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'P m*))) + (printf "\ncompute-aggregate-patch m0/m* Q m*:\n") + (void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'Q m*))) - (printf "\nlift mc/mab:\n") - (void (pretty-print-patch (lift-patch (patch mc mab)))) + (printf "\ncompute-aggregate-patch m*/m0 P m*:\n") + (void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'P m*))) - (printf "\ndrop after lift mc/mab:\n") - (void (pretty-print-patch (drop-patch (lift-patch (patch mc mab))))) + (printf "\ncompute-aggregate-patch m0/m* P m*:\n") + (void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'P m*))) - (printf "\ncompose mbc/m0 after mc/mab:\n") - (void (pretty-print-patch (compose-patch (patch mbc m0) (patch mc mab)))) + (printf "\nlift mc/mab:\n") + (void (pretty-print-patch (lift-patch (patch mc mab)))) - (printf "\ncompose mc/mab after mbc/m0:\n") - (void (pretty-print-patch (compose-patch (patch mc mab) (patch mbc m0)))) + (printf "\ndrop after lift mc/mab:\n") + (void (pretty-print-patch (drop-patch (lift-patch (patch mc mab))))) - (printf "\ncompose mc/m* (not disjoint) after mbc/m0:\n") - (void (pretty-print-patch (compose-patch (patch mc m*) (patch mbc m0)))) + (printf "\ncompose mbc/m0 after mc/mab:\n") + (void (pretty-print-patch (compose-patch (patch mbc m0) (patch mc mab)))) - (printf "\ncompose mbc/m0 after mc/m* (not disjoint):\n") - (void (pretty-print-patch (compose-patch (patch mbc m0) (patch mc m*)))) + (printf "\ncompose mc/mab after mbc/m0:\n") + (void (pretty-print-patch (compose-patch (patch mc mab) (patch mbc m0)))) - (printf "\ncompose mbc/m0 after lift mc/mab:\n") - (void (pretty-print-patch (compose-patch (patch mbc m0) - (lift-patch (patch mc mab))))) + (printf "\ncompose mc/m* (not disjoint) after mbc/m0:\n") + (void (pretty-print-patch (compose-patch (patch mc m*) (patch mbc m0)))) - (printf "\ndrop (compose mbc/m0 after lift mc/mab):\n") - (void (pretty-print-patch (drop-patch (compose-patch (patch mbc m0) - (lift-patch (patch mc mab)))))) + (printf "\ncompose mbc/m0 after mc/m* (not disjoint):\n") + (void (pretty-print-patch (compose-patch (patch mbc m0) (patch mc m*)))) - (printf "\nstripped compose mc/m* (not disjoint) after mbc/m0:\n") - (void (pretty-print-patch (compose-patch (strip-patch (patch mc m*)) - (strip-patch (patch mbc m0))))) + (printf "\ncompose mbc/m0 after lift mc/mab:\n") + (void (pretty-print-patch (compose-patch (patch mbc m0) + (lift-patch (patch mc mab))))) + + (printf "\ndrop (compose mbc/m0 after lift mc/mab):\n") + (void (pretty-print-patch (drop-patch (compose-patch (patch mbc m0) + (lift-patch (patch mc mab)))))) + + (printf "\nstripped compose mc/m* (not disjoint) after mbc/m0:\n") + (void (pretty-print-patch (compose-patch (strip-patch (patch mc m*)) + (strip-patch (patch mbc m0))))) + + (printf "\ndrop mAb/m0:\n") + (void (pretty-print-patch (drop-patch (patch mAb m0)))) + ) + + ;; (sanity-check-examples) + + (let* ((pre-patch-a-keys (set 1 3 5 7)) + (pre-patch-b-keys (set 2 3 6 7)) + (pre-patch-keys (set 1 2 3 5 6 7)) + (ma (set->matcher (set 'a) pre-patch-a-keys)) + (mb (set->matcher (set 'b) pre-patch-b-keys)) + (R (matcher-union ma mb)) + (pa-raw (patch (set->matcher (set 'a) (set 0 1 2 3 )) + (set->matcher (set 'a) (set 4 5 6 7)))) + (pa1 (limit-patch pa-raw ma)) + (pa2 (limit-patch/routing-table pa-raw R)) + (post-patch-a-keys (set 0 1 2 3 )) + (post-patch-b-keys pre-patch-b-keys) + (post-patch-keys (set 0 1 2 3 6 7)) + (aggregate-added (set 0 )) + (aggregate-removed (set 5 )) + (p-aggregate1 (compute-aggregate-patch pa1 'a R)) + (p-aggregate2 (compute-aggregate-patch pa2 'a R)) + (R1 (apply-patch R pa1)) + (R2 (apply-patch R pa2)) + (R-relabeled (matcher-relabel R (lambda (v) (set 'x)))) + (R1-relabeled (apply-patch R-relabeled (label-patch (strip-patch p-aggregate1) (set 'x)))) + (R2-relabeled (apply-patch R-relabeled (label-patch (strip-patch p-aggregate2) (set 'x))))) + (check-equal? pa1 pa2) + (check-equal? (matcher-match-value R 0) (set)) + (check-equal? (matcher-match-value R 1) (set 'a)) + (check-equal? (matcher-match-value R 2) (set 'b)) + (check-equal? (matcher-match-value R 3) (set 'a 'b)) + (check-equal? (matcher-match-value R 4) (set)) + (check-equal? (matcher-match-value R 5) (set 'a)) + (check-equal? (matcher-match-value R 6) (set 'b)) + (check-equal? (matcher-match-value R 7) (set 'a 'b)) + (check-equal? (matcher-key-set/single (project-routing-table R (set 'a))) pre-patch-a-keys) + (check-equal? (matcher-key-set/single (project-routing-table R (set 'b))) pre-patch-b-keys) + (check-equal? (matcher-key-set/single R) pre-patch-keys) + (check-equal? (matcher-key-set/single R-relabeled) pre-patch-keys) + + (define (post-checks R* R*-relabeled p-aggregate) + (check-equal? (matcher-key-set/single (project-routing-table R* (set 'a))) post-patch-a-keys) + (check-equal? (matcher-key-set/single (project-routing-table R* (set 'b))) post-patch-b-keys) + (check-equal? (matcher-key-set/single R*) post-patch-keys) + (check-equal? (matcher-key-set/single R*-relabeled) post-patch-keys) + (check-equal? (matcher-key-set/single (patch-added p-aggregate)) aggregate-added) + (check-equal? (matcher-key-set/single (patch-removed p-aggregate)) aggregate-removed)) + + (post-checks R1 R1-relabeled p-aggregate1) + (post-checks R2 R2-relabeled p-aggregate2) + ) )