Fix incorrect compute-aggregate-patch logic.
This commit is contained in:
parent
98bfbef056
commit
e4c0f7e95d
|
@ -329,9 +329,12 @@
|
||||||
(struct-copy world w [process-table (hash-set (world-process-table w) label p)]))))
|
(struct-copy world w [process-table (hash-set (world-process-table w) label p)]))))
|
||||||
(apply-patch-in-world label delta new-w)]
|
(apply-patch-in-world label delta new-w)]
|
||||||
[else ;; we can still apply actions for nonexistent processes,
|
[else ;; we can still apply actions for nonexistent processes,
|
||||||
;; but we can't limit the patches, making their zombie
|
;; but we have to limit the patches by consulting the
|
||||||
;; patch actions potentially less efficient.
|
;; whole routing table, making their zombie patch actions
|
||||||
(apply-patch-in-world label delta-orig w)])]
|
;; 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))
|
[(and m (message body))
|
||||||
(when (observe? body)
|
(when (observe? body)
|
||||||
(log-warning "Process ~a sent message containing query ~v"
|
(log-warning "Process ~a sent message containing query ~v"
|
||||||
|
@ -351,6 +354,8 @@
|
||||||
(and local-to-meta?
|
(and local-to-meta?
|
||||||
(message (at-meta-claim body))))])]))
|
(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 (apply-patch-in-world label delta w)
|
||||||
(define old-routing-table (world-routing-table w))
|
(define old-routing-table (world-routing-table w))
|
||||||
(define new-routing-table (apply-patch old-routing-table delta))
|
(define new-routing-table (apply-patch old-routing-table delta))
|
||||||
|
|
|
@ -16,6 +16,7 @@
|
||||||
strip-patch
|
strip-patch
|
||||||
label-patch
|
label-patch
|
||||||
limit-patch
|
limit-patch
|
||||||
|
limit-patch/routing-table
|
||||||
compute-aggregate-patch
|
compute-aggregate-patch
|
||||||
apply-patch
|
apply-patch
|
||||||
update-interests
|
update-interests
|
||||||
|
@ -94,15 +95,67 @@
|
||||||
(patch (label-interests (patch-added p) label)
|
(patch (label-interests (patch-added p) label)
|
||||||
(label-interests (patch-removed 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)
|
(define (limit-patch p bound)
|
||||||
(match-define (patch in out) p)
|
(match-define (patch in out) p)
|
||||||
(patch (matcher-subtract in bound #:combiner (lambda (v1 v2) #f))
|
(patch (matcher-subtract in bound #:combiner (lambda (v1 v2) #f))
|
||||||
(matcher-intersect out bound #:combiner (lambda (v1 v2) v1))))
|
(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 (compute-aggregate-patch p label base)
|
||||||
(define (combiner v1 v2) (matcher-subtract-combiner v1 (set-remove v2 label)))
|
(define (add-combiner v1 v2)
|
||||||
(patch (matcher-subtract (patch-added p) base #:combiner combiner)
|
;; Keep only points where `p` would add, where no `label` interest
|
||||||
(matcher-subtract (patch-removed p) base #:combiner combiner)))
|
;; 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).
|
;; For use by Matchers leading to (Setof Label).
|
||||||
(define (apply-patch base p)
|
(define (apply-patch base p)
|
||||||
|
@ -163,90 +216,157 @@
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(define SP (set 'P))
|
(define (set->matcher label xs)
|
||||||
(define m0 (matcher-empty))
|
(for/fold [(acc (matcher-empty))] [(x (in-set xs))]
|
||||||
(define ma (pattern->matcher SP 'a))
|
(matcher-union acc (pattern->matcher label x))))
|
||||||
(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 ?))
|
|
||||||
|
|
||||||
(printf "\nmab:\n")
|
;; Retains only entries in R labelled with any subset of the labels in label-set.
|
||||||
(void (pretty-print-matcher mab))
|
(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")
|
(define (sanity-check-examples)
|
||||||
(void (pretty-print-patch (compute-patch ma mb)))
|
(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")
|
(printf "\nmab:\n")
|
||||||
(void (pretty-print-patch (limit-patch (patch m* m0) mab)))
|
(void (pretty-print-matcher mab))
|
||||||
|
|
||||||
(printf "\nlimit-patch m0/m* mab:\n")
|
(printf "\ncompute-patch ma mb:\n")
|
||||||
(void (pretty-print-patch (limit-patch (patch m0 m*) mab)))
|
(void (pretty-print-patch (compute-patch ma mb)))
|
||||||
|
|
||||||
(printf "\napply mb (limit m*/m0 mab):\n")
|
(printf "\nlimit-patch m*/m0 mab:\n")
|
||||||
(void (pretty-print-matcher (apply-patch mb (limit-patch (patch m* m0) mab))))
|
(void (pretty-print-patch (limit-patch (patch m* m0) mab)))
|
||||||
|
|
||||||
(printf "\nlimit mbc/ma ma:\n")
|
(printf "\nlimit-patch m0/m* mab:\n")
|
||||||
(void (pretty-print-patch (limit-patch (patch mbc ma) ma)))
|
(void (pretty-print-patch (limit-patch (patch m0 m*) mab)))
|
||||||
|
|
||||||
(printf "\nlimit mab/mc ma:\n")
|
(printf "\napply mb (limit m*/m0 mab):\n")
|
||||||
(void (pretty-print-patch (limit-patch (patch mab mc) ma)))
|
(void (pretty-print-matcher (apply-patch mb (limit-patch (patch m* m0) mab))))
|
||||||
|
|
||||||
(printf "\nlimit mc/mab ma:\n")
|
(printf "\nlimit mbc/ma ma:\n")
|
||||||
(void (pretty-print-patch (limit-patch (patch mc mab) ma)))
|
(void (pretty-print-patch (limit-patch (patch mbc ma) ma)))
|
||||||
|
|
||||||
(printf "\ncompute-aggregate-patch m*/m0 Q mab:\n")
|
(printf "\nlimit mab/mc ma:\n")
|
||||||
(void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'Q mab)))
|
(void (pretty-print-patch (limit-patch (patch mab mc) ma)))
|
||||||
|
|
||||||
(printf "\ncompute-aggregate-patch m0/m* Q mab:\n")
|
(printf "\nlimit mc/mab ma:\n")
|
||||||
(void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'Q mab)))
|
(void (pretty-print-patch (limit-patch (patch mc mab) ma)))
|
||||||
|
|
||||||
(printf "\ncompute-aggregate-patch m*/m0 P mab:\n")
|
(printf "\ncompute-aggregate-patch m*/m0 Q mab:\n")
|
||||||
(void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'P mab)))
|
(void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'Q mab)))
|
||||||
|
|
||||||
(printf "\ncompute-aggregate-patch m0/m* P mab:\n")
|
(printf "\ncompute-aggregate-patch m0/m* Q mab:\n")
|
||||||
(void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'P mab)))
|
(void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'Q mab)))
|
||||||
|
|
||||||
(printf "\ncompute-aggregate-patch m*/m0 Q m*:\n")
|
(printf "\ncompute-aggregate-patch m*/m0 P mab:\n")
|
||||||
(void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'Q m*)))
|
(void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'P mab)))
|
||||||
|
|
||||||
(printf "\ncompute-aggregate-patch m0/m* Q m*:\n")
|
(printf "\ncompute-aggregate-patch m0/m* P mab:\n")
|
||||||
(void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'Q m*)))
|
(void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'P mab)))
|
||||||
|
|
||||||
(printf "\ncompute-aggregate-patch m*/m0 P m*:\n")
|
(printf "\ncompute-aggregate-patch m*/m0 Q m*:\n")
|
||||||
(void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'P m*)))
|
(void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'Q m*)))
|
||||||
|
|
||||||
(printf "\ncompute-aggregate-patch m0/m* P m*:\n")
|
(printf "\ncompute-aggregate-patch m0/m* Q m*:\n")
|
||||||
(void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'P m*)))
|
(void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'Q m*)))
|
||||||
|
|
||||||
(printf "\nlift mc/mab:\n")
|
(printf "\ncompute-aggregate-patch m*/m0 P m*:\n")
|
||||||
(void (pretty-print-patch (lift-patch (patch mc mab))))
|
(void (pretty-print-patch (compute-aggregate-patch (patch m* m0) 'P m*)))
|
||||||
|
|
||||||
(printf "\ndrop after lift mc/mab:\n")
|
(printf "\ncompute-aggregate-patch m0/m* P m*:\n")
|
||||||
(void (pretty-print-patch (drop-patch (lift-patch (patch mc mab)))))
|
(void (pretty-print-patch (compute-aggregate-patch (patch m0 m*) 'P m*)))
|
||||||
|
|
||||||
(printf "\ncompose mbc/m0 after mc/mab:\n")
|
(printf "\nlift mc/mab:\n")
|
||||||
(void (pretty-print-patch (compose-patch (patch mbc m0) (patch mc mab))))
|
(void (pretty-print-patch (lift-patch (patch mc mab))))
|
||||||
|
|
||||||
(printf "\ncompose mc/mab after mbc/m0:\n")
|
(printf "\ndrop after lift mc/mab:\n")
|
||||||
(void (pretty-print-patch (compose-patch (patch mc mab) (patch mbc m0))))
|
(void (pretty-print-patch (drop-patch (lift-patch (patch mc mab)))))
|
||||||
|
|
||||||
(printf "\ncompose mc/m* (not disjoint) after mbc/m0:\n")
|
(printf "\ncompose mbc/m0 after mc/mab:\n")
|
||||||
(void (pretty-print-patch (compose-patch (patch mc m*) (patch mbc m0))))
|
(void (pretty-print-patch (compose-patch (patch mbc m0) (patch mc mab))))
|
||||||
|
|
||||||
(printf "\ncompose mbc/m0 after mc/m* (not disjoint):\n")
|
(printf "\ncompose mc/mab after mbc/m0:\n")
|
||||||
(void (pretty-print-patch (compose-patch (patch mbc m0) (patch mc m*))))
|
(void (pretty-print-patch (compose-patch (patch mc mab) (patch mbc m0))))
|
||||||
|
|
||||||
(printf "\ncompose mbc/m0 after lift mc/mab:\n")
|
(printf "\ncompose mc/m* (not disjoint) after mbc/m0:\n")
|
||||||
(void (pretty-print-patch (compose-patch (patch mbc m0)
|
(void (pretty-print-patch (compose-patch (patch mc m*) (patch mbc m0))))
|
||||||
(lift-patch (patch mc mab)))))
|
|
||||||
|
|
||||||
(printf "\ndrop (compose mbc/m0 after lift mc/mab):\n")
|
(printf "\ncompose mbc/m0 after mc/m* (not disjoint):\n")
|
||||||
(void (pretty-print-patch (drop-patch (compose-patch (patch mbc m0)
|
(void (pretty-print-patch (compose-patch (patch mbc m0) (patch mc m*))))
|
||||||
(lift-patch (patch mc mab))))))
|
|
||||||
|
|
||||||
(printf "\nstripped compose mc/m* (not disjoint) after mbc/m0:\n")
|
(printf "\ncompose mbc/m0 after lift mc/mab:\n")
|
||||||
(void (pretty-print-patch (compose-patch (strip-patch (patch mc m*))
|
(void (pretty-print-patch (compose-patch (patch mbc m0)
|
||||||
(strip-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)
|
||||||
|
)
|
||||||
)
|
)
|
||||||
|
|
Loading…
Reference in New Issue