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

Generalize route.rkt's mapped-to values from sets. Also flip arg order of matcher-erase-path.

This commit is contained in:
Tony Garnock-Jones 2014-05-19 18:41:59 -04:00
parent 25a912c900
commit cad1dbbbca
2 changed files with 209 additions and 207 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
minimart/core.rkt
View File

@ -189,12 +189,12 @@
(define (update-aggregate-gestalt w pid old-g new-g) (define (update-aggregate-gestalt w pid old-g new-g)
(struct-copy world w [aggregate-gestalt (struct-copy world w [aggregate-gestalt
(gestalt-union (gestalt-combine-straight old-g (gestalt-union (gestalt-combine-straight (world-aggregate-gestalt w)
(world-aggregate-gestalt w) old-g
(lambda (side x) (lambda (side x)
(case side (case side
[(left-longer) '()] [(left-longer) x]
[(right-longer) x])) [(right-longer) '()]))
matcher-erase-path) matcher-erase-path)
new-g)])) new-g)]))

408
minimart/route.rkt
View File

@ -55,17 +55,18 @@
;; A Matcher is either ;; A Matcher is either
;; - #f, indicating no further matches possible ;; - #f, indicating no further matches possible
;; - a Set of Any, representing a successful match (if the end of the input has been reached) ;; - a (success Any), representing a successful match (if the end of the input has been reached)
;; - a Hashtable mapping (Sigma or wildcard) to Matcher ;; - a Hashtable mapping (Sigma or wildcard) to Matcher
;; - a (wildcard-sequence Matcher) ;; - a (wildcard-sequence Matcher)
;; If, in a hashtable matcher, a wild key is present, it is intended ;; If, in a hashtable matcher, a wild key is present, it is intended
;; to catch all and ONLY those keys not otherwise present in the ;; to catch all and ONLY those keys not otherwise present in the
;; table. ;; table.
(struct success (value) #:transparent)
(struct wildcard-sequence (matcher) #:transparent) (struct wildcard-sequence (matcher) #:transparent)
(define (matcher? x) (define (matcher? x)
(or (eq? x #f) (or (eq? x #f)
(set? x) (success? x)
(wildcard-sequence? x) (wildcard-sequence? x)
(and (hash? x) (and (hash? x)
(for/and ([v (in-hash-values x)]) (for/and ([v (in-hash-values x)])
@ -74,8 +75,6 @@
(define (matcher-empty) #f) (define (matcher-empty) #f)
(define (matcher-empty? r) (not r)) (define (matcher-empty? r) (not r))
(define (rvalue v) (set v))
(define (rseq e r) (if (matcher-empty? r) r (hash e r))) (define (rseq e r) (if (matcher-empty? r) r (hash e r)))
(define (rwild r) (rseq ? r)) (define (rwild r) (rseq ? r))
(define (rwildseq r) (if (matcher-empty? r) r (wildcard-sequence r))) (define (rwildseq r) (if (matcher-empty? r) r (wildcard-sequence r)))
@ -98,7 +97,7 @@
(kons elem acc))) (kons elem acc)))
(define (pattern->matcher v p) (define (pattern->matcher v p)
(let walk ((p p) (acc (rseq EOS (rvalue v)))) (let walk ((p p) (acc (rseq EOS (success v))))
(match p (match p
[(== ?) (rwild acc)] [(== ?) (rwild acc)]
[(cons p1 p2) (rseq SOP (walk p1 (walk p2 (rseq EOS acc))))] [(cons p1 p2) (rseq SOP (walk p1 (walk p2 (rseq EOS acc))))]
@ -140,54 +139,52 @@
(matcher-union (rwild (rwildseq r)) (matcher-union (rwild (rwildseq r))
(rseq EOS r))) (rseq EOS r)))
(define matcher-union (define (matcher-union re1 re2 [combine-successes set-union])
(let () (define (merge o1 o2)
(define (merge o1 o2) (match* (o1 o2)
(match* (o1 o2) [(#f #f) #f]
[(#f #f) #f] [(#f r) r]
[(#f r) r] [(r #f) r]
[(r #f) r] [(r1 r2) (walk r1 r2)]))
[(r1 r2) (walk r1 r2)])) (define (walk re1 re2)
(define (walk re1 re2) (match* (re1 re2)
(match* (re1 re2) [((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 (expand-wildseq r2) r1)]
[(r1 (wildcard-sequence r2)) (walk (expand-wildseq r2) r1)] [((success v1) (success v2)) (success (combine-successes v1 v2))]
[((? set? v1) (? set? v2)) (set-union v1 v2)] [((? hash? h1) (? hash? h2))
[((? hash? h1) (? hash? h2)) (define w (merge (rlookup h1 ?) (rlookup h2 ?)))
(define w (merge (rlookup h1 ?) (rlookup h2 ?))) (cond
(cond [w (merge/wildcard w h1 h2)]
[w (merge/wildcard w h1 h2)] [(< (hash-count h2) (hash-count h1)) (merge/no-wildcard h2 h1)]
[(< (hash-count h2) (hash-count h1)) (merge/no-wildcard h2 h1)] [else (merge/no-wildcard h1 h2)])]))
[else (merge/no-wildcard h1 h2)])])) (define (merge/wildcard w h1 h2)
(define (merge/wildcard w h1 h2) (for/fold [(acc (rwild w))]
(for/fold [(acc (rwild w))] [(key (set-remove (set-union (hash-keys h1) (hash-keys h2)) ?))]
[(key (set-remove (set-union (hash-keys h1) (hash-keys h2)) ?))] (define k (merge (rlookup h1 key) (rlookup h2 key)))
(define k (merge (rlookup h1 key) (rlookup h2 key))) (rupdate acc
(rupdate acc key
key (cond
(cond [(key-open? key) (merge (rwildseq w) k)]
[(key-open? key) (merge (rwildseq w) k)] [(key-close? key) (if (wildcard-sequence? w)
[(key-close? key) (if (wildcard-sequence? w) (merge (wildcard-sequence-matcher w) k)
(merge (wildcard-sequence-matcher w) k) k)]
k)] [else (merge w k)]))))
[else (merge w k)])))) (define (merge/no-wildcard h1 h2)
(define (merge/no-wildcard h1 h2) (for/fold [(acc h2)] [((key k1) (in-hash h1))]
(for/fold [(acc h2)] [((key k1) (in-hash h1))] (define k (merge k1 (rlookup h2 key)))
(define k (merge k1 (rlookup h2 key))) (rupdate acc key k)))
(rupdate acc key k))) (match* (re1 re2)
(lambda (re1 re2) [(#f r) r]
(match* (re1 re2) [(r #f) r]
[(#f r) r] [(r1 r2) (walk r1 r2)]))
[(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-success-values set-union]) (define (matcher-intersect re1 re2 [combine-successes set-union])
(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
@ -197,7 +194,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))]
[((? set? v1) (? set? v2)) (combine-success-values v1 v2)] [((success v1) (success v2)) (success (combine-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 ?))
@ -239,90 +236,87 @@
[(r #f) #f] [(r #f) #f]
[(r1 r2) (walk r1 r2)]))) [(r1 r2) (walk r1 r2)])))
;; Removes re1's mappings from re2. Assumes re1 has previously been union'd into re2. ;; Removes re2's mappings from re1. Assumes re2 has previously been union'd into re1.
(define matcher-erase-path ;; The combine-successes function should return #f to signal "no remaining success values".
(let () (define (matcher-erase-path re1 re2 [combine-successes set-subtract])
(define (cofinite-pattern) (define (cofinite-pattern)
(error 'matcher-erase-path "Cofinite pattern required")) (error 'matcher-erase-path "Cofinite pattern required"))
(define (walk path aggregate) (define (walk path aggregate)
(match* (path aggregate) (match* (path aggregate)
[((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) (cofinite-pattern)]
[(r1 (wildcard-sequence r2)) (cofinite-pattern)] [(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2))]
[((? set? v1) (? set? v2)) [((success v1) (success v2)) (success (combine-successes v1 v2))]
(define v (set-subtract v2 v1)) [((? hash? h1) (? hash? h2))
(if (set-empty? v) #f v)] (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)]
[(#f r) r] [(r1 r2) (walk r1 r2)]))
[(r #f) (cofinite-pattern)] (define (examine-key acc key)
[(r1 r2) (walk r1 r2)])) (rupdate acc
(define (examine-key acc key) key
(rupdate acc (match* ((rlookup h1 key) (rlookup h2 key))
key [(#f #f) #f]
(match* ((rlookup h1 key) (rlookup h2 key)) [(#f k2) (cofinite-pattern)]
[(#f #f) #f] [(k1 #f) (walk-wild key k1 w2)]
[(#f k2) (walk-wild w1 key k2)] [(k1 k2) (walk k1 k2)])))
[(k1 #f) (cofinite-pattern)] ;; TODO: need to ensure "minimal" remainder in cases where
[(k1 k2) (walk k1 k2)]))) ;; after an erasure, a particular key's continuation is the
;; TODO: need to ensure "minimal" remainder in cases where ;; same as the wildcard's continuation. See tests/examples
;; after an erasure, a particular key's continuation is the ;; below.
;; same as the wildcard's continuation. See tests/examples ;;
;; below. ;; --
;; ;; We only need to examine all keys of h2 if w1 nonfalse.
;; -- (if w2
;; We only need to examine all keys of h2 if w1 nonfalse. (for/fold [(acc (rwild w))] [(key (set-remove (set-union (hash-keys h1)
(if w1 (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 h2)] [(key (in-hash-keys h1))] (define (walk-wild key k w)
(examine-key acc key)))])) (if w
(define (walk-wild w key k) (cond
(if w [(key-open? key) (walk k (rwildseq w))]
(cond [(key-close? key) (if (wildcard-sequence? w)
[(key-open? key) (walk (rwildseq w) k)] (walk k (wildcard-sequence-matcher w))
[(key-close? key) (if (wildcard-sequence? w) k)]
(walk (wildcard-sequence-matcher w) k) [else (walk k w)])
k)] k))
[else (walk w k)]) (match* (re1 re2)
k)) [(r #f) r]
(lambda (re1 re2) [(#f r) (cofinite-pattern)]
(match* (re1 re2) [(r1 r2) (walk r1 r2)]))
[(#f r) r]
[(r #f) (cofinite-pattern)]
[(r1 r2) (walk r1 r2)]))))
(define (matcher-match-value r v) (define (matcher-match-value r v [result-nil (set)])
(if (matcher-empty? r) (if (matcher-empty? r)
(set) result-nil
(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 (set)] [#f result-nil]
[k (walk vs stack k)])) [k (walk vs stack k)]))
(match r (match r
[(wildcard-sequence k) [(wildcard-sequence k)
(match stack (match stack
['() (set)] ['() result-nil]
[(cons rest stack1) (walk rest stack1 k)])] [(cons rest stack1) (walk rest stack1 k)])]
[(? set?) [(success result)
(if (and (null? vs) (if (and (null? vs)
(null? stack)) (null? stack))
r result
(set))] result-nil)]
[(? hash?) [(? hash?)
(match vs (match vs
['() ['()
(match stack (match stack
['() (set)] ['() result-nil]
[(cons rest stack1) [(cons rest stack1)
(match (rlookup r EOS) (match (rlookup r EOS)
[#f (set)] [#f result-nil]
[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")]
@ -346,14 +340,15 @@
[#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 re1 re2 [combine-successes set-union] [result-nil (set)])
(let () (let ()
(define (walk re1 re2 acc1 acc2) (define (walk re1 re2 acc1 acc2)
(match* (re1 re2) (match* (re1 re2)
[((wildcard-sequence r1) (wildcard-sequence r2)) (walk r1 r2 acc1 acc2)] [((wildcard-sequence r1) (wildcard-sequence r2)) (walk r1 r2 acc1 acc2)]
[((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2 acc1 acc2)] [((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2 acc1 acc2)]
[(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2) acc1 acc2)] [(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2) acc1 acc2)]
[((? set? v1) (? set? v2)) (values (set-union acc1 v1) (set-union acc2 v2))] [((success v1) (success v2)) (values (combine-successes acc1 v1)
(combine-successes acc2 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 ?))
@ -390,15 +385,15 @@
[else (walk w k acc1 acc2)]) [else (walk w k acc1 acc2)])
(values acc1 acc2))) (values acc1 acc2)))
(match* (re1 re2) (match* (re1 re2)
[(#f r) (values (set) (set))] [(#f r) (values result-nil result-nil)]
[(r #f) (values (set) (set))] [(r #f) (values result-nil result-nil)]
[(r1 r2) (walk r1 r2 (set) (set))]))) [(r1 r2) (walk r1 r2 result-nil result-nil)])))
(define (matcher-relabel m f) (define (matcher-relabel m f)
(let walk ((m m)) (let walk ((m m))
(match m (match m
[#f #f] [#f #f]
[(? set?) (f m)] [(success v) (success (f v))]
[(wildcard-sequence m1) (wildcard-sequence (walk m1))] [(wildcard-sequence m1) (wildcard-sequence (walk m1))]
[(? hash?) (for/hash [((k v) (in-hash m))] (values k (walk v)))]))) [(? hash?) (for/hash [((k v) (in-hash m))] (values k (walk v)))])))
@ -458,7 +453,7 @@
(match spec (match spec
['() ['()
(match m (match m
[(? set?) (rseq EOS (rseq EOS (set #t)))] [(success v) (rseq EOS (rseq EOS (success #t)))]
;; ^ the #t yields a matcher that does not preserve map values. ;; ^ the #t yields a matcher that does not preserve map values.
[_ (matcher-empty)])] [_ (matcher-empty)])]
@ -571,9 +566,9 @@
[(wildcard-sequence k) [(wildcard-sequence k)
(d "...>") (d "...>")
(walk (+ i 4) k)] (walk (+ i 4) k)]
[(? set? vs) [(success vs)
(d "{") (d "{")
(for ((v vs)) (d v)) (d vs)
(d "}")] (d "}")]
[(? hash? h) [(? hash? h)
(if (zero? (hash-count h)) (if (zero? (hash-count h))
@ -601,12 +596,19 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test (module+ test
(define (E . vs) (hash EOS (apply set vs))) (define SA (set 'A))
(check-equal? (pattern->matcher 'A 123) (hash 123 (E 'A))) (define SB (set 'B))
(check-equal? (pattern->matcher 'A (cons 1 2)) (hash SOP (hash 1 (hash 2 (hash EOS (E 'A)))))) (define SC (set 'C))
(check-equal? (pattern->matcher 'A (cons ? 2)) (hash SOP (hash ? (hash 2 (hash EOS (E 'A)))))) (define SD (set 'D))
(check-equal? (pattern->matcher 'A SOP) (hash struct:start-of-pair (hash EOS (E 'A)))) (define Sfoo (set 'foo))
(check-equal? (pattern->matcher 'A ?) (hash ? (E 'A))) (define S+ (set '+))
(define SX (set 'X))
(define (E v) (hash EOS (success v)))
(check-equal? (pattern->matcher SA 123) (hash 123 (E SA)))
(check-equal? (pattern->matcher SA (cons 1 2)) (hash SOP (hash 1 (hash 2 (hash EOS (E SA))))))
(check-equal? (pattern->matcher SA (cons ? 2)) (hash SOP (hash ? (hash 2 (hash EOS (E SA))))))
(check-equal? (pattern->matcher SA SOP) (hash struct:start-of-pair (hash EOS (E SA))))
(check-equal? (pattern->matcher SA ?) (hash ? (E SA)))
) )
(module+ test (module+ test
@ -635,21 +637,21 @@
m) m)
(void (pretty-print-matcher* (void (pretty-print-matcher*
(matcher-union (pattern->matcher 'A (list (list ?) 'x)) (matcher-union (pattern->matcher SA (list (list ?) 'x))
(pattern->matcher 'B (list (list ?) 'y))))) (pattern->matcher SB (list (list ?) 'y)))))
(void (pretty-print-matcher* (void (pretty-print-matcher*
(matcher-union (pattern->matcher 'A (list (list 'a 'b) 'x)) (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x))
(pattern->matcher 'B (list (list 'c 'd) 'y))))) (pattern->matcher SB (list (list 'c 'd) 'y)))))
(void (pretty-print-matcher* (void (pretty-print-matcher*
(matcher-union (pattern->matcher 'A (list (list 'a 'b) 'x)) (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x))
(pattern->matcher 'B (list (list ? ?) 'y))))) (pattern->matcher SB (list (list ? ?) 'y)))))
(check-matches (check-matches
(pretty-print-matcher* (pretty-print-matcher*
(matcher-union (pattern->matcher 'A (list (list 'a 'b) 'x)) (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x))
(pattern->matcher 'B (list (list ? ?) 'x)))) (pattern->matcher SB (list (list ? ?) 'x))))
(list 'z 'x) "" (list 'z 'x) ""
(list (list 'z 'z) 'x) "B" (list (list 'z 'z) 'x) "B"
(list (list 'z (list 'z)) 'x) "B" (list (list 'z (list 'z)) 'x) "B"
@ -657,8 +659,8 @@
(check-matches (check-matches
(pretty-print-matcher* (pretty-print-matcher*
(matcher-union (pattern->matcher 'A (list (list 'a 'b) 'x)) (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x))
(pattern->matcher 'B (list (list ?) 'y)))) (pattern->matcher SB (list (list ?) 'y))))
(list 'z 'y) "" (list 'z 'y) ""
(list (list 'z 'z) 'y) "" (list (list 'z 'z) 'y) ""
(list (list 'z 'z) 'x) "" (list (list 'z 'z) 'x) ""
@ -666,38 +668,38 @@
(check-matches (check-matches
(pretty-print-matcher* (pretty-print-matcher*
(matcher-union (pattern->matcher 'A (list (list 'a 'b) 'x)) (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x))
(pattern->matcher 'B (list ? 'y)))) (pattern->matcher SB (list ? 'y))))
(list 'z 'y) "B" (list 'z 'y) "B"
(list (list 'z 'z) 'y) "B" (list (list 'z 'z) 'y) "B"
(list (list 'a 'b) 'x) "A") (list (list 'a 'b) 'x) "A")
(check-matches (check-matches
(pretty-print-matcher* (pretty-print-matcher*
(matcher-union (pattern->matcher 'A (list 'a 'b)) (matcher-union (pattern->matcher SA (list 'a 'b))
(pattern->matcher 'B (list 'c 'd)))) (pattern->matcher SB (list 'c 'd))))
(list 'a 'b) "A" (list 'a 'b) "A"
(list 'c 'd) "B" (list 'c 'd) "B"
(list 'a 'd) "" (list 'a 'd) ""
(list 'c 'b) "") (list 'c 'b) "")
(void (pretty-print-matcher* (matcher-union (pattern->matcher 'A (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 (rvalue 'B))))) (rseq EOS (success (set 'B))))))
(check-matches (check-matches
(pretty-print-matcher* (pretty-print-matcher*
(matcher-union (pattern->matcher 'A (list (list 'a 'b) 'x)) (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x))
(pattern->matcher 'B ?))) (pattern->matcher SB ?)))
(list (list 'a 'b) 'x) "AB" (list (list 'a 'b) 'x) "AB"
'p "B" 'p "B"
(list 'p) "B") (list 'p) "B")
(check-matches (check-matches
(pretty-print-matcher* (pretty-print-matcher*
(matcher-union (pattern->matcher 'A (list 'a ?)) (matcher-union (pattern->matcher SA (list 'a ?))
(pattern->matcher 'B (list 'a (list 'b))))) (pattern->matcher SB (list 'a (list 'b)))))
(list 'a (list 'b)) "AB" (list 'a (list 'b)) "AB"
(list 'a (list 'b 'b)) "A" (list 'a (list 'b 'b)) "A"
@ -709,9 +711,9 @@
(check-matches (check-matches
(pretty-print-matcher* (pretty-print-matcher*
(matcher-union (matcher-union (pattern->matcher 'A (list 'a ?)) (matcher-union (matcher-union (pattern->matcher SA (list 'a ?))
(pattern->matcher 'A (list 'q ?))) (pattern->matcher SA (list 'q ?)))
(pattern->matcher 'B (list 'a (list 'b))))) (pattern->matcher SB (list 'a (list 'b)))))
(list 'a (list 'b)) "AB" (list 'a (list 'b)) "AB"
(list 'q (list 'b)) "A" (list 'q (list 'b)) "A"
(list 'a 'x) "A" (list 'a 'x) "A"
@ -724,9 +726,9 @@
(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 csym (list csym ?)))) (pattern->matcher (set csym) (list csym ?))))
(matcher-union (foldr matcher-union (matcher-empty) ps) (matcher-union (foldr matcher-union (matcher-empty) ps)
(pattern->matcher '+ (list 'Z (list ? '- ?))))) (pattern->matcher S+ (list 'Z (list ? '- ?)))))
(void (pretty-print-matcher* (bigdemo))) (void (pretty-print-matcher* (bigdemo)))
(check-matches (check-matches
@ -748,18 +750,18 @@
(list 'Z '((()) - -)) "Z+" (list 'Z '((()) - -)) "Z+"
(list '? (list '- '- '-)) "") (list '? (list '- '- '-)) "")
(check-matches (pretty-print-matcher* (pattern->matcher 'A (list* 'a 'b ?))) (check-matches (pretty-print-matcher* (pattern->matcher SA (list* 'a 'b ?)))
(list 'a 'b 'c 'd 'e 'f) "A" (list 'a 'b 'c 'd 'e 'f) "A"
(list 'b 'c 'd 'e 'f 'a) "" (list 'b 'c 'd 'e 'f 'a) ""
3 "") 3 "")
(void (pretty-print-matcher* (matcher-intersect (pattern->matcher 'A (list 'a)) (void (pretty-print-matcher* (matcher-intersect (pattern->matcher SA (list 'a))
(pattern->matcher 'B (list 'b))))) (pattern->matcher SB (list 'b)))))
(let ((r1 (matcher-union (pattern->matcher 'A (list ? 'b)) (let ((r1 (matcher-union (pattern->matcher SA (list ? 'b))
(pattern->matcher 'A (list ? 'c)))) (pattern->matcher SA (list ? 'c))))
(r2 (matcher-union (pattern->matcher 'B (list 'a ?)) (r2 (matcher-union (pattern->matcher SB (list 'a ?))
(pattern->matcher 'B (list 'b ?))))) (pattern->matcher SB (list 'b ?)))))
(pretty-print-matcher* (matcher-union r1 r2)) (pretty-print-matcher* (matcher-union r1 r2))
(pretty-print-matcher* (matcher-union r1 r1)) (pretty-print-matcher* (matcher-union r1 r1))
(pretty-print-matcher* (matcher-union r2 r2)) (pretty-print-matcher* (matcher-union r2 r2))
@ -768,10 +770,10 @@
(pretty-print-matcher* (matcher-intersect r2 r2)) (pretty-print-matcher* (matcher-intersect r2 r2))
(void)) (void))
(void (pretty-print-matcher* (matcher-intersect (bigdemo) (pattern->matcher 'X (list 'm 'n))))) (void (pretty-print-matcher* (matcher-intersect (bigdemo) (pattern->matcher SX (list 'm 'n)))))
(check-matches (check-matches
(pretty-print-matcher* (matcher-intersect (bigdemo) (pattern->matcher 'X (list 'Z ?)))) (pretty-print-matcher* (matcher-intersect (bigdemo) (pattern->matcher SX (list 'Z ?))))
(list 'a '-) "" (list 'a '-) ""
(list 'Z '-) "XZ" (list 'Z '-) "XZ"
(list '? '-) "" (list '? '-) ""
@ -790,7 +792,7 @@
(list '? (list '- '- '-)) "") (list '? (list '- '- '-)) "")
(check-matches (check-matches
(pretty-print-matcher* (matcher-intersect (bigdemo) (pattern->matcher 'X (list 'Z ?)) (pretty-print-matcher* (matcher-intersect (bigdemo) (pattern->matcher SX (list 'Z ?))
(lambda (a b) b))) (lambda (a b) b)))
(list 'a '-) "" (list 'a '-) ""
(list 'Z '-) "X" (list 'Z '-) "X"
@ -810,7 +812,7 @@
(list '? (list '- '- '-)) "") (list '? (list '- '- '-)) "")
(check-matches (check-matches
(pretty-print-matcher* (matcher-intersect (bigdemo) (pattern->matcher 'X ?) (pretty-print-matcher* (matcher-intersect (bigdemo) (pattern->matcher SX ?)
(lambda (a b) b))) (lambda (a b) b)))
(list 'a '-) "X" (list 'a '-) "X"
(list 'Z '-) "X" (list 'Z '-) "X"
@ -829,26 +831,26 @@
(list 'Z '((()) - -)) "X" (list 'Z '((()) - -)) "X"
(list '? (list '- '- '-)) "") (list '? (list '- '- '-)) "")
(let* ((r1 (pattern->matcher 'A (list ? 'b))) (let* ((r1 (pattern->matcher SA (list ? 'b)))
(r2 (pattern->matcher 'B (list 'a ?))) (r2 (pattern->matcher SB (list 'a ?)))
(r12 (matcher-union r1 r2))) (r12 (matcher-union r1 r2)))
(printf "\n-=-=-=-=-=-=-=-=- erase1\n") (printf "\n-=-=-=-=-=-=-=-=- erase1\n")
(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" ;; TODO: these next two are not currently "minimal"
(pretty-print-matcher* (matcher-erase-path r1 r12)) (pretty-print-matcher* (matcher-erase-path r12 r1))
(pretty-print-matcher* (matcher-erase-path r2 r12)) (pretty-print-matcher* (matcher-erase-path r12 r2))
(void)) (void))
(let* ((r1 (matcher-union (pattern->matcher 'A (list 'a ?)) (let* ((r1 (matcher-union (pattern->matcher SA (list 'a ?))
(pattern->matcher 'A (list 'b ?)))) (pattern->matcher SA (list 'b ?))))
(r2 (pattern->matcher 'B (list 'b ?))) (r2 (pattern->matcher SB (list 'b ?)))
(r12 (matcher-union r1 r2))) (r12 (matcher-union r1 r2)))
(printf "\n-=-=-=-=-=-=-=-=- erase2\n") (printf "\n-=-=-=-=-=-=-=-=- erase2\n")
(pretty-print-matcher* r12) (pretty-print-matcher* r12)
(pretty-print-matcher* (matcher-erase-path r1 r12)) (pretty-print-matcher* (matcher-erase-path r12 r1))
(pretty-print-matcher* (matcher-erase-path r2 r12)) (pretty-print-matcher* (matcher-erase-path r12 r2))
(void)) (void))
) )
@ -858,10 +860,10 @@
(struct b (x) #:transparent) (struct b (x) #:transparent)
(define (intersect a b) (define (intersect a b)
(matcher-intersect (pattern->matcher 'A a) (matcher-intersect (pattern->matcher SA a)
(pattern->matcher 'B b))) (pattern->matcher SB b)))
(define EAB (E 'A 'B)) (define EAB (E (set 'A 'B)))
(check-equal? (intersect ? ?) (rwild EAB)) (check-equal? (intersect ? ?) (rwild EAB))
(check-equal? (intersect 'a ?) (rseq 'a EAB)) (check-equal? (intersect 'a ?) (rseq 'a EAB))
@ -906,24 +908,24 @@
(define-values (s1 s2) (matcher-match-matcher m1 m2)) (define-values (s1 s2) (matcher-match-matcher m1 m2))
(list s1 s2)) (list s1 s2))
(let ((abc (foldr matcher-union (matcher-empty) (let ((abc (foldr matcher-union (matcher-empty)
(list (pattern->matcher 'A (list 'a ?)) (list (pattern->matcher SA (list 'a ?))
(pattern->matcher 'B (list 'b ?)) (pattern->matcher SB (list 'b ?))
(pattern->matcher 'C (list 'c ?))))) (pattern->matcher SC (list 'c ?)))))
(bcd (foldr matcher-union (matcher-empty) (bcd (foldr matcher-union (matcher-empty)
(list (pattern->matcher 'B (list 'b ?)) (list (pattern->matcher SB (list 'b ?))
(pattern->matcher 'C (list 'c ?)) (pattern->matcher SC (list 'c ?))
(pattern->matcher 'D(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-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)))
(check-equal? (matcher-match-matcher-list abc (pattern->matcher 'foo ?)) (check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo ?))
(list (set 'A 'B 'C) (set 'foo))) (list (set 'A 'B 'C) (set 'foo)))
(check-equal? (matcher-match-matcher-list abc (pattern->matcher 'foo (list ? ?))) (check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? ?)))
(list (set 'A 'B 'C) (set 'foo))) (list (set 'A 'B 'C) (set 'foo)))
(check-equal? (matcher-match-matcher-list abc (pattern->matcher 'foo (list ? 'x))) (check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x)))
(list (set 'A 'B 'C) (set 'foo))) (list (set 'A 'B 'C) (set 'foo)))
(check-equal? (matcher-match-matcher-list abc (pattern->matcher 'foo (list ? 'x ?))) (check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x ?)))
(list (set) (set))))) (list (set) (set)))))
(module+ test (module+ test
@ -932,51 +934,51 @@
(check-equal? (compile-projection (list 'a ?!)) (check-equal? (compile-projection (list 'a ?!))
(list SOP 'a SOP ?! '() EOS EOS EOS)) (list SOP 'a SOP ?! '() EOS EOS EOS))
(check-equal? (matcher-project (matcher-union (pattern->matcher 'A (list 'a 'a)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher 'B (list 'a 'b))) (pattern->matcher SB (list 'a 'b)))
(compile-projection (list 'a ?!))) (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 'A (list 'a 'a)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher 'B (list 'a (vector 'b 'c 'd)))) (pattern->matcher SB (list 'a (vector 'b 'c 'd))))
(compile-projection (list 'a ?!))) (compile-projection (list 'a ?!)))
(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 'A (list 'a 'a)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher 'B (list 'a (vector 'b ? 'd)))) (pattern->matcher SB (list 'a (vector 'b ? 'd))))
(compile-projection (list 'a ?!))) (compile-projection (list 'a ?!)))
(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->finite-set (check-equal? (matcher->finite-set
(matcher-project (matcher-union (pattern->matcher 'A (list 'a 'a)) (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher 'B (list 'a 'b))) (pattern->matcher SB (list 'a 'b)))
(compile-projection (list 'a ?!)))) (compile-projection (list 'a ?!))))
(set '#(a) '#(b))) (set '#(a) '#(b)))
(check-equal? (matcher->finite-set (check-equal? (matcher->finite-set
(matcher-project (matcher-union (pattern->matcher 'A (list 'a 'a)) (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher 'B (list 'a (vector 'b 'c 'd)))) (pattern->matcher SB (list 'a (vector 'b 'c 'd))))
(compile-projection (list 'a ?!)))) (compile-projection (list 'a ?!))))
(set '#(a) '#(#(b c d)))) (set '#(a) '#(#(b c d))))
(check-equal? (matcher->finite-set (check-equal? (matcher->finite-set
(matcher-project (matcher-union (pattern->matcher 'A (list 'a 'a)) (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher 'B (list 'a (vector 'b ? 'd)))) (pattern->matcher SB (list 'a (vector 'b ? 'd))))
(compile-projection (list 'a ?!)))) (compile-projection (list 'a ?!))))
#f) #f)
(check-equal? (matcher-project (matcher-union (pattern->matcher 'A (cons 1 2)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (cons 1 2))
(pattern->matcher 'B (cons 3 4))) (pattern->matcher SB (cons 3 4)))
(compile-projection (cons ?! ?!))) (compile-projection (cons ?! ?!)))
(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->finite-set (check-equal? (matcher->finite-set
(matcher-project (matcher-union (pattern->matcher 'A (cons 1 2)) (matcher-project (matcher-union (pattern->matcher SA (cons 1 2))
(pattern->matcher 'B (cons 3 4))) (pattern->matcher SB (cons 3 4)))
(compile-projection (cons ?! ?!)))) (compile-projection (cons ?! ?!))))
(set '#(1 2) '#(3 4))) (set '#(1 2) '#(3 4)))
) )