syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

First commit switching from sets to tsets for labels in RHSs of matchers.

This commit is contained in:
Tony Garnock-Jones 2015-06-19 20:29:16 -04:00
parent ee1cf9b100
commit 7d561fc49e
4 changed files with 89 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
prospect/ground.rkt
View File

@ -8,6 +8,7 @@
(require "core.rkt") (require "core.rkt")
(require "trace.rkt") (require "trace.rkt")
(require "trace/stderr.rkt") (require "trace/stderr.rkt")
(require "tset.rkt")
(provide (struct-out external-event) (provide (struct-out external-event)
send-ground-message send-ground-message
@ -91,7 +92,7 @@
[(cons a actions) [(cons a actions)
(match a (match a
[(? patch? p) [(? 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) (log-warning "run-ground: ignoring useless meta-action ~v" a)
(process-actions actions interests)])]))]))))) (process-actions actions interests)])]))])))))

15
prospect/mux.rkt
View File

@ -16,6 +16,7 @@
(require "route.rkt") (require "route.rkt")
(require "patch.rkt") (require "patch.rkt")
(require "trace.rkt") (require "trace.rkt")
(require "tset.rkt")
;; A PID is a Nat. ;; A PID is a Nat.
;; A Label is a PID or 'meta. ;; A Label is a PID or 'meta.
@ -43,7 +44,7 @@
(define (mux-update-stream m label delta-orig) (define (mux-update-stream m label delta-orig)
(define old-interests (mux-interests-of m label)) (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)) (define new-interests (apply-patch old-interests delta))
(let* ((m (struct-copy mux m (let* ((m (struct-copy mux m
[interest-table [interest-table
@ -56,10 +57,10 @@
(define new-routing-table (apply-patch old-routing-table delta)) (define new-routing-table (apply-patch old-routing-table delta))
(define delta-aggregate (compute-aggregate-patch delta label old-routing-table)) (define delta-aggregate (compute-aggregate-patch delta label old-routing-table))
(define affected-pids (let ((pids (compute-affected-pids old-routing-table delta))) (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]) (values (struct-copy mux m [routing-table new-routing-table])
label label
(for/list [(pid affected-pids)] (for/list [(pid (tset->list affected-pids))]
(cond [(equal? pid label) (cond [(equal? pid label)
(define feedback (define feedback
(patch-union (patch-union
@ -78,10 +79,10 @@
(define cover (matcher-union (patch-added delta) (patch-removed delta))) (define cover (matcher-union (patch-added delta) (patch-removed delta)))
(matcher-match-matcher cover (matcher-match-matcher cover
(matcher-step routing-table struct:observe) (matcher-step routing-table struct:observe)
#:seed (set) #:seed (datum-tset)
#:combiner (lambda (v1 v2 acc) (set-union v2 acc)) #:combiner (lambda (v1 v2 acc) (tset-union v2 acc))
#:left-short (lambda (v r 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) (define (mux-route-message m label body)
(when (observe? body) (when (observe? body)
@ -95,7 +96,7 @@
(at-meta? body)) ;; it relates to envt, not local (at-meta? body)) ;; it relates to envt, not local
(values #t '())] (values #t '())]
[else [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) (define (mux-interests-of m label)
(hash-ref (mux-interest-table m) label (matcher-empty))) (hash-ref (mux-interest-table m) label (matcher-empty)))

65
prospect/patch.rkt
View File

@ -39,6 +39,7 @@
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require "route.rkt") (require "route.rkt")
(require "tset.rkt")
(module+ test (require rackunit)) (module+ test (require rackunit))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -116,7 +117,7 @@
(match-define (patch in out) p) (match-define (patch in out) p)
(patch (matcher-subtract in bound) (patch (matcher-subtract in bound)
(matcher-intersect out 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 ;; Entries labelled with `label` may already exist in `base`; the
;; patch `p` MUST already have been limited to add only where no ;; 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 ;; ...except when `remove-meta?` is true. In that case, we need to
;; keep the point in the case that the only interest present is ;; keep the point in the case that the only interest present is
;; `'meta`-labeled interest. ;; `'meta`-labeled interest.
(if (and remove-meta? (equal? v2 (set 'meta))) (if (and remove-meta? (equal? v2 (datum-tset 'meta)))
v1 v1
#f)) #f))
(define (rem-combiner v1 v2) (define (rem-combiner v1 v2)
@ -171,11 +172,11 @@
;; only label interest exists (which by precondition is always the ;; only label interest exists (which by precondition is always the
;; case), or when exactly `label` and `'meta` interest exists, and ;; case), or when exactly `label` and `'meta` interest exists, and
;; in no other case. ;; in no other case.
(if (= (set-count v2) 1) (if (= (tset-count v2) 1)
v1 ;; only `label` interest (previously established) exists here. v1 ;; only `label` interest (previously established) exists here.
(if (and remove-meta? (if (and remove-meta?
(= (set-count v2) 2) (= (tset-count v2) 2)
(set-member? v2 'meta)) (tset-member? v2 'meta))
v1 ;; remove-meta? is true, and exactly `label` and `'meta` interest exists here. 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. #f))) ;; other interest exists here, so we should discard this removed-point.
(patch (matcher-subtract (patch-added p) base #:combiner add-combiner) (patch (matcher-subtract (patch-added p) base #:combiner add-combiner)
@ -262,10 +263,12 @@
(define (project-routing-table R label-set) (define (project-routing-table R label-set)
(matcher-intersect R (matcher-intersect R
(pattern->matcher label-set ?) (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 (sanity-check-examples)
(define SP (set 'P)) (define SP (tset 'P))
(define m0 (matcher-empty)) (define m0 (matcher-empty))
(define ma (pattern->matcher SP 'a)) (define ma (pattern->matcher SP 'a))
(define mb (pattern->matcher SP 'b)) (define mb (pattern->matcher SP 'b))
@ -363,11 +366,11 @@
(let* ((pre-patch-a-keys (set 1 3 5 7)) (let* ((pre-patch-a-keys (set 1 3 5 7))
(pre-patch-b-keys (set 2 3 6 7)) (pre-patch-b-keys (set 2 3 6 7))
(pre-patch-keys (set 1 2 3 5 6 7)) (pre-patch-keys (set 1 2 3 5 6 7))
(ma (set->matcher (set 'a) pre-patch-a-keys)) (ma (set->matcher (tset 'a) pre-patch-a-keys))
(mb (set->matcher (set 'b) pre-patch-b-keys)) (mb (set->matcher (tset 'b) pre-patch-b-keys))
(R (matcher-union ma mb)) (R (matcher-union ma mb))
(pa-raw (patch (set->matcher (set 'a) (set 0 1 2 3 )) (pa-raw (patch (set->matcher (tset 'a) (set 0 1 2 3 ))
(set->matcher (set 'a) (set 4 5 6 7)))) (set->matcher (tset 'a) (set 4 5 6 7))))
(pa1 (limit-patch pa-raw ma)) (pa1 (limit-patch pa-raw ma))
(pa2 (limit-patch/routing-table pa-raw R)) (pa2 (limit-patch/routing-table pa-raw R))
(post-patch-a-keys (set 0 1 2 3 )) (post-patch-a-keys (set 0 1 2 3 ))
@ -379,26 +382,26 @@
(p-aggregate2 (compute-aggregate-patch pa2 'a R)) (p-aggregate2 (compute-aggregate-patch pa2 'a R))
(R1 (apply-patch R pa1)) (R1 (apply-patch R pa1))
(R2 (apply-patch R pa2)) (R2 (apply-patch R pa2))
(R-relabeled (matcher-relabel R (lambda (v) (set 'x)))) (R-relabeled (matcher-relabel R (lambda (v) (tset 'x))))
(R1-relabeled (apply-patch R-relabeled (label-patch (strip-patch p-aggregate1) (set '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) (set 'x))))) (R2-relabeled (apply-patch R-relabeled (label-patch (strip-patch p-aggregate2) (tset 'x)))))
(check-equal? pa1 pa2) (check-equal? pa1 pa2)
(check-equal? (matcher-match-value R 0) (set)) (check-equal? (matcher-match-value R 0 (tset)) (tset))
(check-equal? (matcher-match-value R 1) (set 'a)) (check-equal? (matcher-match-value R 1 (tset)) (tset 'a))
(check-equal? (matcher-match-value R 2) (set 'b)) (check-equal? (matcher-match-value R 2 (tset)) (tset 'b))
(check-equal? (matcher-match-value R 3) (set 'a 'b)) (check-equal? (matcher-match-value R 3 (tset)) (tset 'a 'b))
(check-equal? (matcher-match-value R 4) (set)) (check-equal? (matcher-match-value R 4 (tset)) (tset))
(check-equal? (matcher-match-value R 5) (set 'a)) (check-equal? (matcher-match-value R 5 (tset)) (tset 'a))
(check-equal? (matcher-match-value R 6) (set 'b)) (check-equal? (matcher-match-value R 6 (tset)) (tset 'b))
(check-equal? (matcher-match-value R 7) (set 'a 'b)) (check-equal? (matcher-match-value R 7 (tset)) (tset '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 (tset '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 (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) pre-patch-keys)
(check-equal? (matcher-key-set/single R-relabeled) pre-patch-keys) (check-equal? (matcher-key-set/single R-relabeled) pre-patch-keys)
(define (post-checks R* R*-relabeled p-aggregate) (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* (tset '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 'b))) post-patch-b-keys)
(check-equal? (matcher-key-set/single R*) post-patch-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 R*-relabeled) post-patch-keys)
(check-equal? (matcher-key-set/single (patch-added p-aggregate)) aggregate-added) (check-equal? (matcher-key-set/single (patch-added p-aggregate)) aggregate-added)
@ -408,9 +411,9 @@
(post-checks R2 R2-relabeled p-aggregate2) (post-checks R2 R2-relabeled p-aggregate2)
) )
(let* ((ma (set->matcher (set 'a) (set 1))) (let* ((ma (set->matcher (tset 'a) (set 1)))
(mb (set->matcher (set 'b) (set 1))) (mb (set->matcher (tset 'b) (set 1)))
(mmeta (set->matcher (set 'meta) (set 1))) (mmeta (set->matcher (tset 'meta) (set 1)))
(R0 (matcher-empty)) (R0 (matcher-empty))
(R1 mmeta) (R1 mmeta)
(R2 mb) (R2 mb)
@ -420,8 +423,8 @@
(R6 (matcher-union ma mb)) (R6 (matcher-union ma mb))
(R7 (matcher-union (matcher-union ma mb) mmeta)) (R7 (matcher-union (matcher-union ma mb) mmeta))
(p0 empty-patch) (p0 empty-patch)
(p+ (patch (set->matcher (set 'a) (set 1)) (matcher-empty))) (p+ (patch (set->matcher (tset 'a) (set 1)) (matcher-empty)))
(p- (patch (matcher-empty) (set->matcher (set 'a) (set 1))))) (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 R0) p0)
(check-equal? (compute-aggregate-patch p0 'a R1) p0) (check-equal? (compute-aggregate-patch p0 'a R1) p0)
(check-equal? (compute-aggregate-patch p0 'a R2) p0) (check-equal? (compute-aggregate-patch p0 'a R2) p0)

87
prospect/route.rkt
View File

@ -25,7 +25,7 @@
pattern->matcher* pattern->matcher*
matcher-union matcher-union
matcher-intersect matcher-intersect
empty-set-guard empty-tset-guard
matcher-subtract-combiner matcher-subtract-combiner
matcher-subtract matcher-subtract
matcher-match-value matcher-match-value
@ -63,6 +63,7 @@
(require (only-in racket/class object?)) (require (only-in racket/class object?))
(require "canonicalize.rkt") (require "canonicalize.rkt")
(require "treap.rkt") (require "treap.rkt")
(require "tset.rkt")
(require data/order) (require data/order)
(require rackunit) (require rackunit)
@ -333,7 +334,7 @@
;; Matcher Matcher -> Matcher ;; Matcher Matcher -> Matcher
;; Computes the union of the multimaps passed in. ;; 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 (matcher-recurse re1
re2 re2
combiner combiner
@ -350,7 +351,7 @@
;; Matcher Matcher -> Matcher ;; Matcher Matcher -> Matcher
;; Computes the intersection of the multimaps passed in. ;; Computes the intersection of the multimaps passed in.
(define (matcher-intersect re1 re2 (define (matcher-intersect re1 re2
#:combiner [combiner set-union] #:combiner [combiner tset-union]
#:left-short [left-short default-short] #:left-short [left-short default-short]
#:right-short [right-short default-short]) #:right-short [right-short default-short])
(matcher-recurse re1 (matcher-recurse re1
@ -363,11 +364,11 @@
left-short left-short
right-short)) right-short))
(define (empty-set-guard s) (define (empty-tset-guard s)
(if (set-empty? s) #f s)) (if (tset-empty? s) #f s))
(define (matcher-subtract-combiner s1 s2) (define (matcher-subtract-combiner s1 s2)
(empty-set-guard (set-subtract s1 s2))) (empty-tset-guard (tset-subtract s1 s2)))
;; Matcher Matcher -> Matcher ;; Matcher Matcher -> Matcher
;; Removes re2's mappings from re1. ;; Removes re2's mappings from re1.
@ -487,7 +488,7 @@
;; Sigmas and runs them through the Matcher r. If v leads to a success ;; Sigmas and runs them through the Matcher r. If v leads to a success
;; Matcher, returns the values contained in the success Matcher; ;; Matcher, returns the values contained in the success Matcher;
;; otherwise, returns failure-result. ;; 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)) (let walk ((vs (list v)) (stack '(())) (r r))
(match r (match r
[#f failure-result] [#f failure-result]
@ -532,10 +533,10 @@
;; keys. Returns the union of all successful values reached by the ;; keys. Returns the union of all successful values reached by the
;; probe. ;; probe.
(define (matcher-match-matcher re1 re2 (define (matcher-match-matcher re1 re2
#:seed [seed (cons (set) (set))] #:seed seed
#:combiner [combiner (lambda (v1 v2 a) #:combiner [combiner (lambda (v1 v2 a)
(cons (set-union (car a) v1) (cons (tset-union (car a) v1)
(set-union (cdr a) v2)))] (tset-union (cdr a) v2)))]
#:left-short [left-short (lambda (v r acc) acc)] #:left-short [left-short (lambda (v r acc) acc)]
#:right-short [right-short (lambda (v r acc) acc)]) #:right-short [right-short (lambda (v r acc) acc)])
(let walk ((re1 re1) (re2 re2) (acc seed)) (let walk ((re1 re1) (re2 re2) (acc seed))
@ -715,7 +716,7 @@
(lambda (m spec (lambda (m spec
#:project-success [project-success values] #: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 (define (drop-match m spec) (general-match values drop-edge drop-sigma drop-bal m spec
project-success drop-match take-match)) project-success drop-match take-match))
(define (take-match m spec) (general-match rwild rupdate rseq take-bal m spec (define (take-match m spec) (general-match rwild rupdate rseq take-bal m spec
@ -834,7 +835,7 @@
(walk (+ i 5) k)] (walk (+ i 5) k)]
[(success vs) [(success vs)
(d "{") (d "{")
(d vs) (d (if (tset? vs) (cons 'tset (tset->list vs)) vs))
(d "}")] (d "}")]
[(? treap? h) [(? treap? h)
(if (zero? (treap-size h)) (if (zero? (treap-size h))
@ -926,13 +927,15 @@
(module+ test (module+ test
(require racket/pretty) (require racket/pretty)
(define SA (set 'A)) (define tset datum-tset)
(define SB (set 'B))
(define SC (set 'C)) (define SA (tset 'A))
(define SD (set 'D)) (define SB (tset 'B))
(define Sfoo (set 'foo)) (define SC (tset 'C))
(define S+ (set '+)) (define SD (tset 'D))
(define SX (set 'X)) (define Sfoo (tset 'foo))
(define S+ (tset '+))
(define SX (tset 'X))
(define (E v) (rseq EOS (rsuccess v))) (define (E v) (rseq EOS (rsuccess v)))
(check-equal? (pattern->matcher SA 123) (rseq 123 (E SA))) (check-equal? (pattern->matcher SA 123) (rseq 123 (E SA)))
(check-equal? (pattern->matcher SA (cons 1 2)) (check-equal? (pattern->matcher SA (cons 1 2))
@ -951,10 +954,10 @@
(match tests (match tests
['() (void)] ['() (void)]
[(list* message expectedstr rest) [(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) (printf "~v ==> ~v\n" message actualset)
(check-equal? 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)))) (string->list expectedstr))))
(walk rest)]))) (walk rest)])))
@ -1020,7 +1023,7 @@
(void (pretty-print-matcher* (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x)) (void (pretty-print-matcher* (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x))
;; Note: this is a largely nonsense matcher, ;; Note: this is a largely nonsense matcher,
;; since it expects no input at all ;; since it expects no input at all
(rseq EOS (rsuccess (set 'B)))))) (rseq EOS (rsuccess (tset 'B))))))
(check-matches (check-matches
(pretty-print-matcher* (pretty-print-matcher*
@ -1060,7 +1063,7 @@
(define ps (define ps
(for/list ((c (in-string "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))) (for/list ((c (in-string "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")))
(define csym (string->symbol (string c))) (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) (matcher-union (foldr matcher-union (matcher-empty) ps)
(pattern->matcher S+ (list 'Z (list ? '- ?))))) (pattern->matcher S+ (list 'Z (list ? '- ?)))))
@ -1227,7 +1230,7 @@
(matcher-intersect (pattern->matcher SA a) (matcher-intersect (pattern->matcher SA a)
(pattern->matcher SB b))) (pattern->matcher SB b)))
(define EAB (E (set 'A 'B))) (define EAB (E (tset 'A 'B)))
(define (rseq* x . xs) (define (rseq* x . xs)
(let walk ((xs (cons x xs))) (let walk ((xs (cons x xs)))
@ -1282,23 +1285,23 @@
(define m2 (pretty-print-matcher* (pattern->matcher SD ?))) (define m2 (pretty-print-matcher* (pattern->matcher SD ?)))
(define mi (pretty-print-matcher* (matcher-intersect m1 m2))) (define mi (pretty-print-matcher* (matcher-intersect m1 m2)))
(check-requal? mi (check-requal? mi
(H SOL (H 'a (H ? (H EOS (E (set 'A 'D)))) (H SOL (H 'a (H ? (H EOS (E (tset 'A 'D))))
'b (H ? (H EOS (E (set 'B 'D))) 'b (H ? (H EOS (E (tset 'B 'D)))
'c (H EOS (E (set 'B 'C 'D))))))) 'c (H EOS (E (tset 'B 'C 'D)))))))
(check-requal? (pretty-print-matcher* (matcher-intersect m1 m2 #:combiner (lambda (v1 v2) v1))) (check-requal? (pretty-print-matcher* (matcher-intersect m1 m2 #:combiner (lambda (v1 v2) v1)))
m1)) m1))
) )
(module+ test (module+ test
(define (matcher-match-matcher-list m1 m2) (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)) (list s1 s2))
(define (matcher-union* a b) (define (matcher-union* a b)
(matcher-union a b #:combiner (lambda (v1 v2) (matcher-union a b #:combiner (lambda (v1 v2)
(match* (v1 v2) (match* (v1 v2)
[(#t v) v] [(#t v) v]
[(v #t) v] [(v #t) v]
[(v1 v2) (set-union v1 v2)])))) [(v1 v2) (tset-union v1 v2)]))))
(let ((abc (foldr matcher-union* (matcher-empty) (let ((abc (foldr matcher-union* (matcher-empty)
(list (pattern->matcher SA (list 'a ?)) (list (pattern->matcher SA (list 'a ?))
(pattern->matcher SB (list 'b ?)) (pattern->matcher SB (list 'b ?))
@ -1308,21 +1311,21 @@
(pattern->matcher SC (list 'c ?)) (pattern->matcher SC (list 'c ?))
(pattern->matcher SD (list 'd ?)))))) (pattern->matcher SD (list 'd ?))))))
(check-equal? (matcher-match-matcher-list abc abc) (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 (check-equal? (matcher-match-matcher abc abc
#:seed (set) #:seed (tset)
#:combiner (lambda (v1 v2 a) (set-union v2 a))) #:combiner (lambda (v1 v2 a) (tset-union v2 a)))
(set 'A 'B 'C)) (tset 'A 'B 'C))
(check-equal? (matcher-match-matcher-list abc (matcher-relabel bcd (lambda (old) (set #t)))) (check-equal? (matcher-match-matcher-list abc (matcher-relabel bcd (lambda (old) (tset #t))))
(list (set 'B 'C) (set #t))) (list (tset 'B 'C) (tset #t)))
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo ?)) (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 ? ?))) (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))) (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 ?))) (check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x ?)))
(list (set) (set))))) (list (tset) (tset)))))
(module+ test (module+ test
(check-equal? (compile-projection (cons 'a 'b)) (check-equal? (compile-projection (cons 'a 'b))
@ -1495,14 +1498,14 @@
(pattern->matcher SB (list 3 4))))) (pattern->matcher SB (list 3 4)))))
(S '((("(") (S '((("(")
((1 ((2 (((")") (((")") ("" ("A"))))))) ((1 ((2 (((")") (((")") ("" ("A")))))))
(3 (((")") (((")") ("" ("D" "C"))))))))) (3 (((")") (((")") ("" ("C" "D")))))))))
(3 ((2 (((")") (((")") ("" ("A"))))))) (3 ((2 (((")") (((")") ("" ("A")))))))
(3 (((")") (((")") ("" ("D"))))))) (3 (((")") (((")") ("" ("D")))))))
(4 (((")") (((")") ("" ("B"))))))))) (4 (((")") (((")") ("" ("B")))))))))
(("__") ((2 (((")") (((")") ("" ("A"))))))) (("__") ((2 (((")") (((")") ("" ("A")))))))
(3 (((")") (((")") ("" ("D")))))))))))))) (3 (((")") (((")") ("" ("D"))))))))))))))
(check-equal? (matcher->jsexpr M (lambda (v) (map symbol->string (set->list v)))) S) (check-equal? (matcher->jsexpr M (lambda (v) (map symbol->string (tset->list v)))) S)
(check-requal? (jsexpr->matcher S (lambda (v) (list->set (map string->symbol v)))) M))) (check-requal? (jsexpr->matcher S (lambda (v) (make-tset datum-order (map string->symbol v)))) M)))
(module+ test (module+ test
(check-requal? (pretty-print-matcher* (check-requal? (pretty-print-matcher*