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

Introduce parameters controlling route success merges; Ensure "minimal" path erasure

This commit is contained in:
Tony Garnock-Jones 2014-05-21 23:20:49 -04:00
parent aea07d16cc
commit d37eaa1236
2 changed files with 301 additions and 297 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
minimart/gestalt.rkt
View File

@ -168,11 +168,16 @@
;; View on g1 from g2's perspective. ;; View on g1 from g2's perspective.
(define (gestalt-filter g1 g2) (define (gestalt-filter g1 g2)
(gestalt (map-zip shorter-imbalance-handler (parameterize ((matcher-union-successes (lambda (v1 v2)
filter-one-metalevel (match* (v1 v2)
cons-metalevel [(#t v) v]
(gestalt-metalevels g1) [(v #t) v]
(gestalt-metalevels g2)))) [(v1 v2) (set-union v1 v2)]))))
(gestalt (map-zip shorter-imbalance-handler
filter-one-metalevel
cons-metalevel
(gestalt-metalevels g1)
(gestalt-metalevels g2)))))
;; Much like gestalt-filter, takes a view on gestalt g1 from g2's ;; Much like gestalt-filter, takes a view on gestalt g1 from g2's
;; perspective. However, instead of returning the filtered g1, returns ;; perspective. However, instead of returning the filtered g1, returns
@ -202,17 +207,20 @@
(safe-cdr ls))) (safe-cdr ls)))
(define (filter-one-metalevel ls1 ls2) (define (filter-one-metalevel ls1 ls2)
(let loop ((ls1 ls1) (ls2 (smear-levels ls2))) (parameterize ((matcher-intersect-successes (lambda (v1 v2) v1)))
(cond [(null? ls1) '()] (let loop ((ls1 ls1) (ls2 (smear-levels ls2)))
[(null? ls2) '()] (cond [(null? ls1) '()]
[else (match-define (cons (cons subs1 advs1) rest1) ls1) [(null? ls2) '()]
(match-define (cons (cons subs2 advs2) rest2) ls2) [else (match-define (cons (cons subs1 advs1) rest1) ls1)
(cons-level (cons (matcher-intersect subs1 advs2 #:combine (lambda (v1 v2) v1)) (match-define (cons (cons subs2 advs2) rest2) ls2)
(matcher-intersect advs1 subs2 #:combine (lambda (v1 v2) v1))) (cons-level (cons (matcher-intersect subs1 advs2)
(loop rest1 rest2))]))) (matcher-intersect advs1 subs2))
(loop rest1 rest2))]))))
(define (match-matchers m1 m2) (define (match-matchers m1 m2)
(matcher-match-matcher m1 m2 #:combine (lambda (v1 v2 acc) (set-union v2 acc)) #:empty (set))) (parameterize ((matcher-match-matcher-successes (lambda (v1 v2 acc) (set-union v2 acc)))
(matcher-match-matcher-unit (set)))
(matcher-match-matcher m1 m2)))
(define (match-one-metalevel ls1 ls2) (define (match-one-metalevel ls1 ls2)
(let loop ((ls1 ls1) (ls2 (smear-levels ls2))) (let loop ((ls1 ls1) (ls2 (smear-levels ls2)))

562
minimart/route.rkt
View File

@ -25,10 +25,25 @@
projection->pattern projection->pattern
matcher-project matcher-project
matcher-key-set matcher-key-set
pretty-print-matcher) pretty-print-matcher
;; TODO: consider currying matcher-union and friends to specialize matcher-union-successes
;; them for specific combiners. matcher-intersect-successes
matcher-erase-path-successes
matcher-match-matcher-successes
matcher-match-matcher-unit
matcher-project-success)
(define matcher-union-successes (make-parameter set-union))
(define matcher-intersect-successes (make-parameter set-union))
(define matcher-erase-path-successes (make-parameter (lambda (s1 s2)
(define r (set-subtract s1 s2))
(if (set-empty? r) #f r))))
(define matcher-match-matcher-successes (make-parameter (lambda (v1 v2 a)
(cons (set-union (car a) v1)
(set-union (cdr a) v2)))))
(define matcher-match-matcher-unit (make-parameter (cons (set) (set))))
(define matcher-project-success (make-parameter values))
(define-syntax-rule (define-singleton-struct singleton-name struct-name print-representation) (define-syntax-rule (define-singleton-struct singleton-name struct-name print-representation)
(begin (begin
@ -153,52 +168,50 @@
(matcher-union (rwild (rwildseq r)) (matcher-union (rwild (rwildseq r))
(rseq EOS r))) (rseq EOS r)))
(define (matcher-union re1 re2 #:combine [combine-successes set-union]) (define matcher-union
(define (merge o1 o2) (let ()
(match* (o1 o2) (define (merge o1 o2)
[(#f #f) #f] (match* (o1 o2)
[(#f r) r] [(#f #f) #f]
[(r #f) r] [(#f r) r]
[(r1 r2) (walk r1 r2)])) [(r #f) r]
(define (walk re1 re2) [(r1 r2) (walk r1 r2)]))
(match* (re1 re2) (define (walk re1 re2)
[((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (walk r1 r2))] (match* (re1 re2)
[((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2)] [((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (walk r1 r2))]
[(r1 (wildcard-sequence r2)) (walk (expand-wildseq r2) r1)] [((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2)]
[((success v1) (success v2)) (rsuccess (combine-successes v1 v2))] [(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2))]
[((? hash? h1) (? hash? h2)) [((success v1) (success v2)) (rsuccess ((matcher-union-successes) v1 v2))]
(define w (merge (rlookup h1 ?) (rlookup h2 ?))) [((? hash? h1) (? hash? h2))
(cond (define w (merge (rlookup h1 ?) (rlookup h2 ?)))
[w (merge/wildcard w h1 h2)] (cond
[(< (hash-count h2) (hash-count h1)) (merge/no-wildcard h2 h1)] [w (merge/wildcard w h1 h2)]
[else (merge/no-wildcard h1 h2)])])) [(< (hash-count h1) (hash-count h2)) (merge/no-wildcard merge h1 h2)]
(define (merge/wildcard w h1 h2) [else (merge/no-wildcard (lambda (o2 o1) (merge o1 o2)) h2 h1)])]))
(for/fold [(acc (rwild w))] (define (merge/wildcard w h1 h2)
[(key (set-remove (set-union (hash-keys h1) (hash-keys h2)) ?))] (for/fold [(acc (rwild w))]
(define k (merge (rlookup h1 key) (rlookup h2 key))) [(key (set-remove (set-union (hash-keys h1) (hash-keys h2)) ?))]
(rupdate acc (define k (merge (rlookup h1 key) (rlookup h2 key)))
key (rupdate acc
(cond key
[(key-open? key) (merge (rwildseq w) k)] (cond
[(key-close? key) (if (wildcard-sequence? w) [(key-open? key) (merge (rwildseq w) k)]
(merge (wildcard-sequence-matcher w) k) [(key-close? key) (if (wildcard-sequence? w)
k)] (merge (wildcard-sequence-matcher w) k)
[else (merge w k)])))) k)]
(define (merge/no-wildcard h1 h2) [else (merge w k)]))))
(for/fold [(acc h2)] [((key k1) (in-hash h1))] (define (merge/no-wildcard merge-fn h1 h2)
(define k (merge k1 (rlookup h2 key))) (for/fold [(acc h2)] [((key k1) (in-hash h1))]
(rupdate acc key k))) (define k (merge-fn k1 (rlookup h2 key)))
(match* (re1 re2) (rupdate acc key k)))
[(#f r) r] merge))
[(r #f) r]
[(r1 r2) (walk r1 r2)]))
(define (smaller-hash h1 h2) (define (smaller-hash h1 h2)
(if (< (hash-count h1) (hash-count h2)) (if (< (hash-count h1) (hash-count h2))
h1 h1
h2)) h2))
(define (matcher-intersect re1 re2 #:combine [combine-successes set-union]) (define matcher-intersect
(let () (let ()
;; INVARIANT: re1 is a part of the original re1, and likewise for ;; INVARIANT: re1 is a part of the original re1, and likewise for
;; re2. This is so that the first arg to combine-success-values ;; re2. This is so that the first arg to combine-success-values
@ -208,7 +221,7 @@
[((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (walk r1 r2))] [((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (walk r1 r2))]
[((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2)] [((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2)]
[(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2))] [(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2))]
[((success v1) (success v2)) (rsuccess (combine-successes v1 v2))] [((success v1) (success v2)) (rsuccess ((matcher-intersect-successes) v1 v2))]
[((? hash? h1) (? hash? h2)) [((? hash? h1) (? hash? h2))
(define w1 (rlookup h1 ?)) (define w1 (rlookup h1 ?))
(define w2 (rlookup h2 ?)) (define w2 (rlookup h2 ?))
@ -245,96 +258,92 @@
(walk-fn (wildcard-sequence-matcher w) k) (walk-fn (wildcard-sequence-matcher w) k)
#f)] #f)]
[else (walk-fn w k)]))) [else (walk-fn w k)])))
(match* (re1 re2) (lambda (re1 re2)
[(#f r) #f] (match* (re1 re2)
[(r #f) #f] [(#f r) #f]
[(r1 r2) (walk r1 r2)]))) [(r #f) #f]
[(r1 r2) (walk r1 r2)]))))
(define (set-subtract/false s1 s2)
(define r (set-subtract s1 s2))
(if (set-empty? r) #f r))
;; Removes re2's mappings from re1. Assumes re2 has previously been union'd into re1. ;; Removes re2's mappings from re1. Assumes re2 has previously been union'd into re1.
;; The combine-successes function should return #f to signal "no remaining success values". ;; The combine-successes function should return #f to signal "no remaining success values".
(define (matcher-erase-path re1 re2 #:combine [combine-successes set-subtract/false]) (define matcher-erase-path
(define (cofinite-pattern) (let ()
(error 'matcher-erase-path "Cofinite pattern required")) (define (cofinite-pattern)
(define (walk path aggregate) (error 'matcher-erase-path "Cofinite pattern required"))
(match* (path aggregate) (define (walk path aggregate)
[((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (walk r1 r2))] (match* (path aggregate)
[((wildcard-sequence r1) r2) (cofinite-pattern)] [((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (walk r1 r2))]
[(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2))] [((wildcard-sequence r1) r2) (cofinite-pattern)]
[((success v1) (success v2)) (rsuccess (combine-successes v1 v2))] [(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2))]
[((? hash? h1) (? hash? h2)) [((success v1) (success v2)) (rsuccess ((matcher-erase-path-successes) v1 v2))]
(define w1 (rlookup h1 ?)) [((? hash? h1) (? hash? h2))
(define w2 (rlookup h2 ?)) (define w1 (rlookup h1 ?))
(define w (match* (w1 w2) (define w2 (rlookup h2 ?))
[(#f #f) #f] (define w (match* (w1 w2)
[(r #f) r] [(#f #f) #f]
[(#f r) (cofinite-pattern)] [(r #f) r]
[(r1 r2) (walk r1 r2)])) [(#f r) (cofinite-pattern)]
(define (examine-key acc key) [(r1 r2) (walk r1 r2)]))
(rupdate acc (define (examine-key acc key)
key (define updated-k (match* ((rlookup h1 key) (rlookup h2 key))
(match* ((rlookup h1 key) (rlookup h2 key)) [(#f #f) #f]
[(#f #f) #f] [(#f k2) (cofinite-pattern)]
[(#f k2) (cofinite-pattern)] [(k1 #f) (walk-wild key k1 w2)]
[(k1 #f) (walk-wild key k1 w2)] [(k1 k2) (walk k1 k2)]))
[(k1 k2) (walk k1 k2)]))) ;; Here we ensure a "minimal" remainder in cases where
;; TODO: need to ensure "minimal" remainder in cases where ;; after an erasure, a particular key's continuation is the
;; after an erasure, a particular key's continuation is the ;; same as the wildcard's continuation.
;; same as the wildcard's continuation. See tests/examples ;; TODO: the equal? check may be expensive. If so, how can it be made cheaper?
;; below. (rupdate acc key (if (equal? updated-k w) #f updated-k)))
;; ;; We only need to examine all keys of h1 if w2 nonfalse.
;; -- (if w2
;; We only need to examine all keys of h1 if w2 nonfalse. (for/fold [(acc (rwild w))] [(key (set-remove (set-union (hash-keys h1)
(if w2 (hash-keys h2))
(for/fold [(acc (rwild w))] [(key (set-remove (set-union (hash-keys h1) ?))]
(hash-keys h2)) (examine-key acc key))
?))] (for/fold [(acc h1)] [(key (in-hash-keys h2))]
(examine-key acc key)) (examine-key acc key)))]))
(for/fold [(acc h1)] [(key (in-hash-keys h2))] (define (walk-wild key k w)
(examine-key acc key)))])) (if w
(define (walk-wild key k w) (cond
(if w [(key-open? key) (walk k (rwildseq w))]
(cond [(key-close? key) (if (wildcard-sequence? w)
[(key-open? key) (walk k (rwildseq w))] (walk k (wildcard-sequence-matcher w))
[(key-close? key) (if (wildcard-sequence? w) k)]
(walk k (wildcard-sequence-matcher w)) [else (walk k w)])
k)] k))
[else (walk k w)]) (lambda (re1 re2)
k)) (match* (re1 re2)
(match* (re1 re2) [(r #f) r]
[(r #f) r] [(#f r) (cofinite-pattern)]
[(#f r) (cofinite-pattern)] [(r1 r2) (walk r1 r2)]))))
[(r1 r2) (walk r1 r2)]))
(define (matcher-match-value r v [result-nil (set)]) (define (matcher-match-value r v [failure-result (set)])
(if (matcher-empty? r) (if (matcher-empty? r)
result-nil failure-result
(let walk ((vs (list v)) (stack '(())) (r r)) (let walk ((vs (list v)) (stack '(())) (r r))
(define (walk-wild vs stack) (define (walk-wild vs stack)
(match (rlookup r ?) (match (rlookup r ?)
[#f result-nil] [#f failure-result]
[k (walk vs stack k)])) [k (walk vs stack k)]))
(match r (match r
[(wildcard-sequence k) [(wildcard-sequence k)
(match stack (match stack
['() result-nil] ['() failure-result]
[(cons rest stack1) (walk rest stack1 k)])] [(cons rest stack1) (walk rest stack1 k)])]
[(success result) [(success result)
(if (and (null? vs) (if (and (null? vs)
(null? stack)) (null? stack))
result result
result-nil)] failure-result)]
[(? hash?) [(? hash?)
(match vs (match vs
['() ['()
(match stack (match stack
['() result-nil] ['() failure-result]
[(cons rest stack1) [(cons rest stack1)
(match (rlookup r EOS) (match (rlookup r EOS)
[#f result-nil] [#f failure-result]
[k (walk rest stack1 k)])])] [k (walk rest stack1 k)])])]
[(cons (== ?) rest) [(cons (== ?) rest)
(error 'matcher-match-value "Cannot match wildcard as a value")] (error 'matcher-match-value "Cannot match wildcard as a value")]
@ -358,18 +367,14 @@
[#f (walk-wild rest stack)] [#f (walk-wild rest stack)]
[k (walk rest stack k)])])])))) [k (walk rest stack k)])])]))))
(define (matcher-match-matcher re1 re2 (define matcher-match-matcher
#:combine [combine-successes (lambda (v1 v2 a)
(cons (set-union (car a) v1)
(set-union (cdr a) v2)))]
#:empty [result-nil (cons (set) (set))])
(let () (let ()
(define (walk re1 re2 acc) (define (walk re1 re2 acc)
(match* (re1 re2) (match* (re1 re2)
[((wildcard-sequence r1) (wildcard-sequence r2)) (walk r1 r2 acc)] [((wildcard-sequence r1) (wildcard-sequence r2)) (walk r1 r2 acc)]
[((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2 acc)] [((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2 acc)]
[(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2) acc)] [(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2) acc)]
[((success v1) (success v2)) (combine-successes v1 v2 acc)] [((success v1) (success v2)) ((matcher-match-matcher-successes) v1 v2 acc)]
[((? hash? h1) (? hash? h2)) [((? hash? h1) (? hash? h2))
(define w1 (rlookup h1 ?)) (define w1 (rlookup h1 ?))
(define w2 (rlookup h2 ?)) (define w2 (rlookup h2 ?))
@ -398,10 +403,11 @@
acc)] acc)]
[else (walker w k acc)]) [else (walker w k acc)])
acc)) acc))
(match* (re1 re2) (lambda (re1 re2)
[(#f r) result-nil] (match* (re1 re2)
[(r #f) result-nil] [(#f r) (matcher-match-matcher-unit)]
[(r1 r2) (walk r1 r2 result-nil)]))) [(r #f) (matcher-match-matcher-unit)]
[(r1 r2) (walk r1 r2 (matcher-match-matcher-unit))]))))
(define (matcher-relabel m f) (define (matcher-relabel m f)
(let walk ((m m)) (let walk ((m m))
@ -480,62 +486,63 @@
[else (rupdate acc key (capture-nested mk k))])))] [else (rupdate acc key (capture-nested mk k))])))]
[_ (matcher-empty)])) [_ (matcher-empty)]))
(lambda (m spec #:project-success [project-success values]) (define (walk capturing? m spec)
(define (walk capturing? m spec) (match spec
(match spec ['()
['() (when capturing? (error 'matcher-project "Bad specification: unclosed capture"))
(when capturing? (error 'matcher-project "Bad specification: unclosed capture")) (match m
(match m [(success v) (rseq EOS (rseq EOS (rsuccess ((matcher-project-success) v))))]
[(success v) (rseq EOS (rseq EOS (rsuccess (project-success v))))] [_ (matcher-empty)])]
[_ (matcher-empty)])]
[(cons (== EOC) k) [(cons (== EOC) k)
(when (not capturing?) (error 'matcher-project "Bad specification: unexpected EOC")) (when (not capturing?) (error 'matcher-project "Bad specification: unexpected EOC"))
(walk #f m k)] (walk #f m k)]
[(cons (== SOC) k) [(cons (== SOC) k)
(when capturing? (error 'matcher-project "Bad specification: nested capture")) (when capturing? (error 'matcher-project "Bad specification: nested capture"))
(walk #t m k)] (walk #t m k)]
[(cons (== ?) k) [(cons (== ?) k)
(match m (match m
[(wildcard-sequence _) [(wildcard-sequence _)
((if capturing? rwild values) (walk capturing? m k))] ((if capturing? rwild values) (walk capturing? m k))]
[(? hash?) [(? hash?)
(if capturing? (if capturing?
(for/fold [(acc (rwild (walk capturing? (rlookup m ?) k)))] (for/fold [(acc (rwild (walk capturing? (rlookup m ?) k)))]
[((key mk) (in-hash m))] [((key mk) (in-hash m))]
(if (eq? key ?) (if (eq? key ?)
acc acc
(cond (cond
[(key-open? key) [(key-open? key)
(rupdate acc key (capture-nested mk (lambda (mk) (rupdate acc key (capture-nested mk (lambda (mk)
(walk capturing? mk k))))] (walk capturing? mk k))))]
[(key-close? key) acc] [(key-close? key) acc]
[else (rupdate acc key (walk capturing? mk k))]))) [else (rupdate acc key (walk capturing? mk k))])))
(for/fold [(acc (walk capturing? (rlookup m ?) k))] [((key mk) (in-hash m))] (for/fold [(acc (walk capturing? (rlookup m ?) k))] [((key mk) (in-hash m))]
(if (eq? key ?) (if (eq? key ?)
acc acc
(matcher-union acc (cond (matcher-union acc (cond
[(key-open? key) [(key-open? key)
(skip-nested mk (lambda (mk) (walk capturing? mk k)))] (skip-nested mk (lambda (mk) (walk capturing? mk k)))]
[(key-close? key) #f] [(key-close? key) #f]
[else (walk capturing? mk k)])))))] [else (walk capturing? mk k)])))))]
[_ (matcher-empty)])] [_ (matcher-empty)])]
[(cons sigma k) [(cons sigma k)
((if capturing? ((if capturing?
(lambda (m1) (rseq sigma m1)) (lambda (m1) (rseq sigma m1))
values) values)
(match m (match m
[(wildcard-sequence mk) [(wildcard-sequence mk)
(if (key-close? sigma) (if (key-close? sigma)
(walk capturing? mk k) (walk capturing? mk k)
(walk capturing? m k))] (walk capturing? m k))]
[(? hash?) [(? hash?)
(matcher-union (walk capturing? (rlookup m sigma) k) (matcher-union (walk capturing? (rlookup m sigma) k)
(walk capturing? (rlookup m ?) k))] (walk capturing? (rlookup m ?) k))]
[_ (matcher-empty)]))])) [_ (matcher-empty)]))]))
(lambda (m spec)
(rseq SOV (walk #f m spec))))) (rseq SOV (walk #f m spec)))))
;; Matcher → (Option (Setof Value)) ;; Matcher → (Option (Setof Value))
@ -832,8 +839,8 @@
(list '? (list '- '- '-)) "") (list '? (list '- '- '-)) "")
(check-matches (check-matches
(pretty-print-matcher* (matcher-intersect (bigdemo) (pattern->matcher SX (list 'Z ?)) (pretty-print-matcher* (parameterize ((matcher-intersect-successes (lambda (a b) b)))
#:combine (lambda (a b) b))) (matcher-intersect (bigdemo) (pattern->matcher SX (list 'Z ?)))))
(list 'a '-) "" (list 'a '-) ""
(list 'Z '-) "X" (list 'Z '-) "X"
(list '? '-) "" (list '? '-) ""
@ -852,8 +859,8 @@
(list '? (list '- '- '-)) "") (list '? (list '- '- '-)) "")
(check-matches (check-matches
(pretty-print-matcher* (matcher-intersect (bigdemo) (pattern->matcher SX ?) (pretty-print-matcher* (parameterize ((matcher-intersect-successes (lambda (a b) b)))
#:combine (lambda (a b) b))) (matcher-intersect (bigdemo) (pattern->matcher SX ?))))
(list 'a '-) "X" (list 'a '-) "X"
(list 'Z '-) "X" (list 'Z '-) "X"
(list '? '-) "" (list '? '-) ""
@ -878,7 +885,6 @@
(pretty-print-matcher* r1) (pretty-print-matcher* r1)
(pretty-print-matcher* r2) (pretty-print-matcher* r2)
(pretty-print-matcher* r12) (pretty-print-matcher* r12)
;; TODO: these next two are not currently "minimal"
(pretty-print-matcher* (matcher-erase-path r12 r1)) (pretty-print-matcher* (matcher-erase-path r12 r1))
(pretty-print-matcher* (matcher-erase-path r12 r2)) (pretty-print-matcher* (matcher-erase-path r12 r2))
(void)) (void))
@ -955,7 +961,9 @@
(H SOP (H 'a (H SOP (H ? (H '() (H EOS (H EOS (E (set 'A 'D))))))) (H SOP (H 'a (H SOP (H ? (H '() (H EOS (H EOS (E (set 'A 'D)))))))
'b (H SOP (H ? (H '() (H EOS (H EOS (E (set 'B 'D))))) 'b (H SOP (H ? (H '() (H EOS (H EOS (E (set 'B 'D)))))
'c (H '() (H EOS (H EOS (E (set 'B 'C 'D)))))))))) 'c (H '() (H EOS (H EOS (E (set 'B 'C 'D))))))))))
(check-equal? (pretty-print-matcher* (matcher-intersect m1 m2 #:combine (lambda (v1 v2) v1))) (check-equal? (pretty-print-matcher*
(parameterize ((matcher-intersect-successes (lambda (v1 v2) v1)))
(matcher-intersect m1 m2)))
m1)) m1))
) )
@ -973,9 +981,10 @@
(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 (set 'A 'B 'C) (set 'A 'B 'C)))
(check-equal? (matcher-match-matcher abc abc (check-equal? (parameterize ((matcher-match-matcher-successes (lambda (v1 v2 a)
#:combine (lambda (v1 v2 a) (set-union v2 a)) (set-union v2 a)))
#:empty (set)) (matcher-match-matcher-unit (set)))
(matcher-match-matcher abc abc))
(set 'A 'B 'C)) (set '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) (set #t))))
(list (set 'B 'C) (set #t))) (list (set 'B 'C) (set #t)))
@ -994,120 +1003,107 @@
(check-equal? (compile-projection (list 'a (?!))) (check-equal? (compile-projection (list 'a (?!)))
(list SOP 'a SOP SOC ? EOC '() EOS EOS EOS)) (list SOP 'a SOP SOC ? EOC '() EOS EOS EOS))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (parameterize ((matcher-project-success (lambda (v) #t)))
(pattern->matcher SB (list 'a 'b))) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(compile-projection (list 'a (?!))) (pattern->matcher SB (list 'a 'b)))
#:project-success (lambda (v) #t)) (compile-projection (list 'a (?!))))
(matcher-union (pattern->matcher #t (vector 'a)) (matcher-union (pattern->matcher #t (vector 'a))
(pattern->matcher #t (vector 'b)))) (pattern->matcher #t (vector 'b))))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a (vector 'b 'c 'd)))) (pattern->matcher SB (list 'a (vector 'b 'c 'd))))
(compile-projection (list 'a (?!))) (compile-projection (list 'a (?!))))
#:project-success (lambda (v) #t)) (matcher-union (pattern->matcher #t (vector 'a))
(matcher-union (pattern->matcher #t (vector 'a)) (pattern->matcher #t (vector (vector 'b 'c 'd)))))
(pattern->matcher #t (vector (vector 'b 'c 'd)))))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a (vector 'b ? 'd)))) (pattern->matcher SB (list 'a (vector 'b ? 'd))))
(compile-projection (list 'a (?!))) (compile-projection (list 'a (?!))))
#:project-success (lambda (v) #t)) (matcher-union (pattern->matcher #t (vector 'a))
(matcher-union (pattern->matcher #t (vector 'a)) (pattern->matcher #t (vector (vector 'b ? 'd)))))
(pattern->matcher #t (vector (vector 'b ? 'd)))))
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a 'b))) (pattern->matcher SB (list 'a 'b)))
(compile-projection (list 'a (?!))) (compile-projection (list 'a (?!)))))
#:project-success (lambda (v) #t))) (set '#(a) '#(b)))
(set '#(a) '#(b)))
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a (vector 'b 'c 'd)))) (pattern->matcher SB (list 'a (vector 'b 'c 'd))))
(compile-projection (list 'a (?!))) (compile-projection (list 'a (?!)))))
#:project-success (lambda (v) #t))) (set '#(a) '#(#(b c d))))
(set '#(a) '#(#(b c d))))
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a (vector 'b ? 'd)))) (pattern->matcher SB (list 'a (vector 'b ? 'd))))
(compile-projection (list 'a (?!))) (compile-projection (list 'a (?!)))))
#:project-success (lambda (v) #t))) #f)
#f)
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a (vector 'b ? 'd)))) (pattern->matcher SB (list 'a (vector 'b ? 'd))))
(compile-projection (list 'a (?! 'a))) (compile-projection (list 'a (?! 'a)))))
#:project-success (lambda (v) #t))) (set '#(a)))
(set '#(a)))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (cons 1 2)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 3 4))) (pattern->matcher SB (cons 3 4)))
(compile-projection (cons (?!) (?!))) (compile-projection (cons (?!) (?!))))
#:project-success (lambda (v) #t)) (matcher-union (pattern->matcher #t (vector 1 2))
(matcher-union (pattern->matcher #t (vector 1 2)) (pattern->matcher #t (vector 3 4))))
(pattern->matcher #t (vector 3 4))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4)) (pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (cons (?!) (?!))) (compile-projection (cons (?!) (?!))))
#:project-success (lambda (v) #t)) (foldr matcher-union (matcher-empty)
(foldr matcher-union (matcher-empty) (list (pattern->matcher #t (vector 1 2))
(list (pattern->matcher #t (vector 1 2)) (pattern->matcher #t (vector 1 4))
(pattern->matcher #t (vector 1 4)) (pattern->matcher #t (vector 3 4)))))
(pattern->matcher #t (vector 3 4)))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4)) (pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (?! (cons ? ?))) (compile-projection (?! (cons ? ?))))
#:project-success (lambda (v) #t)) (foldr matcher-union (matcher-empty)
(foldr matcher-union (matcher-empty) (list (pattern->matcher #t (vector (cons 1 2)))
(list (pattern->matcher #t (vector (cons 1 2))) (pattern->matcher #t (vector (cons 1 4)))
(pattern->matcher #t (vector (cons 1 4))) (pattern->matcher #t (vector (cons 3 4))))))
(pattern->matcher #t (vector (cons 3 4))))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4)) (pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (?! (cons 1 ?))) (compile-projection (?! (cons 1 ?))))
#:project-success (lambda (v) #t)) (foldr matcher-union (matcher-empty)
(foldr matcher-union (matcher-empty) (list (pattern->matcher #t (vector (cons 1 2)))
(list (pattern->matcher #t (vector (cons 1 2))) (pattern->matcher #t (vector (cons 1 4))))))
(pattern->matcher #t (vector (cons 1 4))))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4)) (pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (cons (?! 1) (?!))) (compile-projection (cons (?! 1) (?!))))
#:project-success (lambda (v) #t)) (foldr matcher-union (matcher-empty)
(foldr matcher-union (matcher-empty) (list (pattern->matcher #t (vector 1 2))
(list (pattern->matcher #t (vector 1 2)) (pattern->matcher #t (vector 1 4)))))
(pattern->matcher #t (vector 1 4)))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4)) (pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (cons (?!) (?! 4))) (compile-projection (cons (?!) (?! 4))))
#:project-success (lambda (v) #t)) (foldr matcher-union (matcher-empty)
(foldr matcher-union (matcher-empty) (list (pattern->matcher #t (vector 1 4))
(list (pattern->matcher #t (vector 1 4)) (pattern->matcher #t (vector 3 4)))))
(pattern->matcher #t (vector 3 4)))))
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (matcher-union (pattern->matcher SA (cons 1 2)) (matcher-project (matcher-union (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 3 4))) (pattern->matcher SB (cons 3 4)))
(compile-projection (cons (?!) (?!))) (compile-projection (cons (?!) (?!)))))
#:project-success (lambda (v) #t))) (set '#(1 2) '#(3 4))))
(set '#(1 2) '#(3 4)))
(check-equal? (projection->pattern (list 'a 'b)) (list 'a 'b)) (check-equal? (projection->pattern (list 'a 'b)) (list 'a 'b))
(check-equal? (projection->pattern (list 'a ?)) (list 'a ?)) (check-equal? (projection->pattern (list 'a ?)) (list 'a ?))