diff --git a/prospect/ground.rkt b/prospect/ground.rkt index 8e34f32..1c0bd36 100644 --- a/prospect/ground.rkt +++ b/prospect/ground.rkt @@ -8,6 +8,7 @@ (require "core.rkt") (require "trace.rkt") (require "trace/stderr.rkt") +(require "tset.rkt") (provide (struct-out external-event) send-ground-message @@ -91,7 +92,7 @@ [(cons a actions) (match a [(? patch? p) - (process-actions actions (apply-patch interests (label-patch p (set 'root))))] + (process-actions actions (apply-patch interests (label-patch p (datum-tset 'root))))] [_ (log-warning "run-ground: ignoring useless meta-action ~v" a) (process-actions actions interests)])]))]))))) diff --git a/prospect/mux.rkt b/prospect/mux.rkt index 8d896c3..1f6e191 100644 --- a/prospect/mux.rkt +++ b/prospect/mux.rkt @@ -16,6 +16,7 @@ (require "route.rkt") (require "patch.rkt") (require "trace.rkt") +(require "tset.rkt") ;; A PID is a Nat. ;; A Label is a PID or 'meta. @@ -43,7 +44,7 @@ (define (mux-update-stream m label delta-orig) (define old-interests (mux-interests-of m label)) - (define delta (limit-patch (label-patch delta-orig (set label)) old-interests)) + (define delta (limit-patch (label-patch delta-orig (datum-tset label)) old-interests)) (define new-interests (apply-patch old-interests delta)) (let* ((m (struct-copy mux m [interest-table @@ -56,10 +57,10 @@ (define new-routing-table (apply-patch old-routing-table delta)) (define delta-aggregate (compute-aggregate-patch delta label old-routing-table)) (define affected-pids (let ((pids (compute-affected-pids old-routing-table delta))) - (set-remove (set-add pids label) 'meta))) ;; TODO: removing meta is weird + (tset-remove (tset-add pids label) 'meta))) ;; TODO: removing meta is weird (values (struct-copy mux m [routing-table new-routing-table]) label - (for/list [(pid affected-pids)] + (for/list [(pid (tset->list affected-pids))] (cond [(equal? pid label) (define feedback (patch-union @@ -78,10 +79,10 @@ (define cover (matcher-union (patch-added delta) (patch-removed delta))) (matcher-match-matcher cover (matcher-step routing-table struct:observe) - #:seed (set) - #:combiner (lambda (v1 v2 acc) (set-union v2 acc)) + #:seed (datum-tset) + #:combiner (lambda (v1 v2 acc) (tset-union v2 acc)) #:left-short (lambda (v r acc) - (set-union acc (success-value (matcher-step r EOS)))))) + (tset-union acc (success-value (matcher-step r EOS)))))) (define (mux-route-message m label body) (when (observe? body) @@ -95,7 +96,7 @@ (at-meta? body)) ;; it relates to envt, not local (values #t '())] [else - (values #f (set->list (matcher-match-value (mux-routing-table m) (observe body))))])) + (values #f (tset->list (matcher-match-value (mux-routing-table m) (observe body) (datum-tset))))])) (define (mux-interests-of m label) (hash-ref (mux-interest-table m) label (matcher-empty))) diff --git a/prospect/patch.rkt b/prospect/patch.rkt index e2e7935..16f3557 100644 --- a/prospect/patch.rkt +++ b/prospect/patch.rkt @@ -39,6 +39,7 @@ (require racket/set) (require racket/match) (require "route.rkt") +(require "tset.rkt") (module+ test (require rackunit)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -116,7 +117,7 @@ (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)))))) + #:combiner (lambda (v1 v2) (empty-tset-guard (tset-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 @@ -156,7 +157,7 @@ ;; ...except when `remove-meta?` is true. In that case, we need to ;; keep the point in the case that the only interest present is ;; `'meta`-labeled interest. - (if (and remove-meta? (equal? v2 (set 'meta))) + (if (and remove-meta? (equal? v2 (datum-tset 'meta))) v1 #f)) (define (rem-combiner v1 v2) @@ -171,11 +172,11 @@ ;; only label interest exists (which by precondition is always the ;; case), or when exactly `label` and `'meta` interest exists, and ;; in no other case. - (if (= (set-count v2) 1) + (if (= (tset-count v2) 1) v1 ;; only `label` interest (previously established) exists here. (if (and remove-meta? - (= (set-count v2) 2) - (set-member? v2 'meta)) + (= (tset-count v2) 2) + (tset-member? v2 'meta)) v1 ;; remove-meta? is true, and exactly `label` and `'meta` interest exists here. #f))) ;; other interest exists here, so we should discard this removed-point. (patch (matcher-subtract (patch-added p) base #:combiner add-combiner) @@ -262,10 +263,12 @@ (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))))) + #:combiner (lambda (v1 v2) (empty-tset-guard (tset-intersect v1 v2))))) + + (define tset datum-tset) (define (sanity-check-examples) - (define SP (set 'P)) + (define SP (tset 'P)) (define m0 (matcher-empty)) (define ma (pattern->matcher SP 'a)) (define mb (pattern->matcher SP 'b)) @@ -363,11 +366,11 @@ (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)) + (ma (set->matcher (tset 'a) pre-patch-a-keys)) + (mb (set->matcher (tset '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)))) + (pa-raw (patch (set->matcher (tset 'a) (set 0 1 2 3 )) + (set->matcher (tset '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 )) @@ -379,26 +382,26 @@ (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))))) + (R-relabeled (matcher-relabel R (lambda (v) (tset 'x)))) + (R1-relabeled (apply-patch R-relabeled (label-patch (strip-patch p-aggregate1) (tset 'x)))) + (R2-relabeled (apply-patch R-relabeled (label-patch (strip-patch p-aggregate2) (tset '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-match-value R 0 (tset)) (tset)) + (check-equal? (matcher-match-value R 1 (tset)) (tset 'a)) + (check-equal? (matcher-match-value R 2 (tset)) (tset 'b)) + (check-equal? (matcher-match-value R 3 (tset)) (tset 'a 'b)) + (check-equal? (matcher-match-value R 4 (tset)) (tset)) + (check-equal? (matcher-match-value R 5 (tset)) (tset 'a)) + (check-equal? (matcher-match-value R 6 (tset)) (tset 'b)) + (check-equal? (matcher-match-value R 7 (tset)) (tset 'a 'b)) + (check-equal? (matcher-key-set/single (project-routing-table R (tset 'a))) pre-patch-a-keys) + (check-equal? (matcher-key-set/single (project-routing-table R (tset '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 (project-routing-table R* (tset 'a))) post-patch-a-keys) + (check-equal? (matcher-key-set/single (project-routing-table R* (tset '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) @@ -408,9 +411,9 @@ (post-checks R2 R2-relabeled p-aggregate2) ) - (let* ((ma (set->matcher (set 'a) (set 1))) - (mb (set->matcher (set 'b) (set 1))) - (mmeta (set->matcher (set 'meta) (set 1))) + (let* ((ma (set->matcher (tset 'a) (set 1))) + (mb (set->matcher (tset 'b) (set 1))) + (mmeta (set->matcher (tset 'meta) (set 1))) (R0 (matcher-empty)) (R1 mmeta) (R2 mb) @@ -420,8 +423,8 @@ (R6 (matcher-union ma mb)) (R7 (matcher-union (matcher-union ma mb) mmeta)) (p0 empty-patch) - (p+ (patch (set->matcher (set 'a) (set 1)) (matcher-empty))) - (p- (patch (matcher-empty) (set->matcher (set 'a) (set 1))))) + (p+ (patch (set->matcher (tset 'a) (set 1)) (matcher-empty))) + (p- (patch (matcher-empty) (set->matcher (tset 'a) (set 1))))) (check-equal? (compute-aggregate-patch p0 'a R0) p0) (check-equal? (compute-aggregate-patch p0 'a R1) p0) (check-equal? (compute-aggregate-patch p0 'a R2) p0) diff --git a/prospect/route.rkt b/prospect/route.rkt index a2b0035..57c8cf1 100644 --- a/prospect/route.rkt +++ b/prospect/route.rkt @@ -25,7 +25,7 @@ pattern->matcher* matcher-union matcher-intersect - empty-set-guard + empty-tset-guard matcher-subtract-combiner matcher-subtract matcher-match-value @@ -63,6 +63,7 @@ (require (only-in racket/class object?)) (require "canonicalize.rkt") (require "treap.rkt") +(require "tset.rkt") (require data/order) (require rackunit) @@ -333,7 +334,7 @@ ;; Matcher Matcher -> Matcher ;; Computes the union of the multimaps passed in. -(define (matcher-union re1 re2 #:combiner [combiner set-union]) +(define (matcher-union re1 re2 #:combiner [combiner tset-union]) (matcher-recurse re1 re2 combiner @@ -350,7 +351,7 @@ ;; Matcher Matcher -> Matcher ;; Computes the intersection of the multimaps passed in. (define (matcher-intersect re1 re2 - #:combiner [combiner set-union] + #:combiner [combiner tset-union] #:left-short [left-short default-short] #:right-short [right-short default-short]) (matcher-recurse re1 @@ -363,11 +364,11 @@ left-short right-short)) -(define (empty-set-guard s) - (if (set-empty? s) #f s)) +(define (empty-tset-guard s) + (if (tset-empty? s) #f s)) (define (matcher-subtract-combiner s1 s2) - (empty-set-guard (set-subtract s1 s2))) + (empty-tset-guard (tset-subtract s1 s2))) ;; Matcher Matcher -> Matcher ;; Removes re2's mappings from re1. @@ -487,7 +488,7 @@ ;; Sigmas and runs them through the Matcher r. If v leads to a success ;; Matcher, returns the values contained in the success Matcher; ;; otherwise, returns failure-result. -(define (matcher-match-value r v [failure-result (set)]) +(define (matcher-match-value r v failure-result) (let walk ((vs (list v)) (stack '(())) (r r)) (match r [#f failure-result] @@ -532,10 +533,10 @@ ;; keys. Returns the union of all successful values reached by the ;; probe. (define (matcher-match-matcher re1 re2 - #:seed [seed (cons (set) (set))] + #:seed seed #:combiner [combiner (lambda (v1 v2 a) - (cons (set-union (car a) v1) - (set-union (cdr a) v2)))] + (cons (tset-union (car a) v1) + (tset-union (cdr a) v2)))] #:left-short [left-short (lambda (v r acc) acc)] #:right-short [right-short (lambda (v r acc) acc)]) (let walk ((re1 re1) (re2 re2) (acc seed)) @@ -715,7 +716,7 @@ (lambda (m spec #:project-success [project-success values] - #:combiner [combiner set-union]) + #:combiner [combiner tset-union]) (define (drop-match m spec) (general-match values drop-edge drop-sigma drop-bal m spec project-success drop-match take-match)) (define (take-match m spec) (general-match rwild rupdate rseq take-bal m spec @@ -834,7 +835,7 @@ (walk (+ i 5) k)] [(success vs) (d "{") - (d vs) + (d (if (tset? vs) (cons 'tset (tset->list vs)) vs)) (d "}")] [(? treap? h) (if (zero? (treap-size h)) @@ -926,13 +927,15 @@ (module+ test (require racket/pretty) - (define SA (set 'A)) - (define SB (set 'B)) - (define SC (set 'C)) - (define SD (set 'D)) - (define Sfoo (set 'foo)) - (define S+ (set '+)) - (define SX (set 'X)) + (define tset datum-tset) + + (define SA (tset 'A)) + (define SB (tset 'B)) + (define SC (tset 'C)) + (define SD (tset 'D)) + (define Sfoo (tset 'foo)) + (define S+ (tset '+)) + (define SX (tset 'X)) (define (E v) (rseq EOS (rsuccess v))) (check-equal? (pattern->matcher SA 123) (rseq 123 (E SA))) (check-equal? (pattern->matcher SA (cons 1 2)) @@ -951,10 +954,10 @@ (match tests ['() (void)] [(list* message expectedstr rest) - (define actualset (matcher-match-value matcher message)) + (define actualset (matcher-match-value matcher message (tset))) (printf "~v ==> ~v\n" message actualset) (check-equal? actualset - (apply set (map (lambda (c) (string->symbol (string c))) + (apply tset (map (lambda (c) (string->symbol (string c))) (string->list expectedstr)))) (walk rest)]))) @@ -1020,7 +1023,7 @@ (void (pretty-print-matcher* (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x)) ;; Note: this is a largely nonsense matcher, ;; since it expects no input at all - (rseq EOS (rsuccess (set 'B)))))) + (rseq EOS (rsuccess (tset 'B)))))) (check-matches (pretty-print-matcher* @@ -1060,7 +1063,7 @@ (define ps (for/list ((c (in-string "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))) (define csym (string->symbol (string c))) - (pattern->matcher (set csym) (list csym ?)))) + (pattern->matcher (tset csym) (list csym ?)))) (matcher-union (foldr matcher-union (matcher-empty) ps) (pattern->matcher S+ (list 'Z (list ? '- ?))))) @@ -1227,7 +1230,7 @@ (matcher-intersect (pattern->matcher SA a) (pattern->matcher SB b))) - (define EAB (E (set 'A 'B))) + (define EAB (E (tset 'A 'B))) (define (rseq* x . xs) (let walk ((xs (cons x xs))) @@ -1282,23 +1285,23 @@ (define m2 (pretty-print-matcher* (pattern->matcher SD ?))) (define mi (pretty-print-matcher* (matcher-intersect m1 m2))) (check-requal? mi - (H SOL (H 'a (H ? (H EOS (E (set 'A 'D)))) - 'b (H ? (H EOS (E (set 'B 'D))) - 'c (H EOS (E (set 'B 'C 'D))))))) + (H SOL (H 'a (H ? (H EOS (E (tset 'A 'D)))) + 'b (H ? (H EOS (E (tset 'B 'D))) + 'c (H EOS (E (tset 'B 'C 'D))))))) (check-requal? (pretty-print-matcher* (matcher-intersect m1 m2 #:combiner (lambda (v1 v2) v1))) m1)) ) (module+ test (define (matcher-match-matcher-list m1 m2) - (match-define (cons s1 s2) (matcher-match-matcher m1 m2)) + (match-define (cons s1 s2) (matcher-match-matcher m1 m2 #:seed (cons (tset) (tset)))) (list s1 s2)) (define (matcher-union* a b) (matcher-union a b #:combiner (lambda (v1 v2) (match* (v1 v2) [(#t v) v] [(v #t) v] - [(v1 v2) (set-union v1 v2)])))) + [(v1 v2) (tset-union v1 v2)])))) (let ((abc (foldr matcher-union* (matcher-empty) (list (pattern->matcher SA (list 'a ?)) (pattern->matcher SB (list 'b ?)) @@ -1308,21 +1311,21 @@ (pattern->matcher SC (list 'c ?)) (pattern->matcher SD (list 'd ?)))))) (check-equal? (matcher-match-matcher-list abc abc) - (list (set 'A 'B 'C) (set 'A 'B 'C))) + (list (tset 'A 'B 'C) (tset 'A 'B 'C))) (check-equal? (matcher-match-matcher abc abc - #:seed (set) - #:combiner (lambda (v1 v2 a) (set-union v2 a))) - (set 'A 'B 'C)) - (check-equal? (matcher-match-matcher-list abc (matcher-relabel bcd (lambda (old) (set #t)))) - (list (set 'B 'C) (set #t))) + #:seed (tset) + #:combiner (lambda (v1 v2 a) (tset-union v2 a))) + (tset 'A 'B 'C)) + (check-equal? (matcher-match-matcher-list abc (matcher-relabel bcd (lambda (old) (tset #t)))) + (list (tset 'B 'C) (tset #t))) (check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo ?)) - (list (set 'A 'B 'C) (set 'foo))) + (list (tset 'A 'B 'C) (tset 'foo))) (check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? ?))) - (list (set 'A 'B 'C) (set 'foo))) + (list (tset 'A 'B 'C) (tset 'foo))) (check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x))) - (list (set 'A 'B 'C) (set 'foo))) + (list (tset 'A 'B 'C) (tset 'foo))) (check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x ?))) - (list (set) (set))))) + (list (tset) (tset))))) (module+ test (check-equal? (compile-projection (cons 'a 'b)) @@ -1495,14 +1498,14 @@ (pattern->matcher SB (list 3 4))))) (S '((("(") ((1 ((2 (((")") (((")") ("" ("A"))))))) - (3 (((")") (((")") ("" ("D" "C"))))))))) + (3 (((")") (((")") ("" ("C" "D"))))))))) (3 ((2 (((")") (((")") ("" ("A"))))))) (3 (((")") (((")") ("" ("D"))))))) (4 (((")") (((")") ("" ("B"))))))))) (("__") ((2 (((")") (((")") ("" ("A"))))))) (3 (((")") (((")") ("" ("D")))))))))))))) - (check-equal? (matcher->jsexpr M (lambda (v) (map symbol->string (set->list v)))) S) - (check-requal? (jsexpr->matcher S (lambda (v) (list->set (map string->symbol v)))) M))) + (check-equal? (matcher->jsexpr M (lambda (v) (map symbol->string (tset->list v)))) S) + (check-requal? (jsexpr->matcher S (lambda (v) (make-tset datum-order (map string->symbol v)))) M))) (module+ test (check-requal? (pretty-print-matcher*