Be more consistent about use of #f in matcher functions.
This commit is contained in:
parent
80a2cef81c
commit
ba006264fc
|
@ -7,9 +7,6 @@
|
||||||
|
|
||||||
(require rackunit)
|
(require rackunit)
|
||||||
|
|
||||||
;; TODO: Harmonize usage of #f (indicating "empty matcher") and rnull/rempty?.
|
|
||||||
;; I suspect #f and not should entirely replace rnull and rempty?.
|
|
||||||
|
|
||||||
(provide )
|
(provide )
|
||||||
|
|
||||||
(define-syntax-rule (define-singleton-struct singleton-name struct-name print-representation)
|
(define-syntax-rule (define-singleton-struct singleton-name struct-name print-representation)
|
||||||
|
@ -37,6 +34,7 @@
|
||||||
(define-singleton-struct ? wildcard "★") ;; alternative printing: ¿
|
(define-singleton-struct ? wildcard "★") ;; alternative printing: ¿
|
||||||
|
|
||||||
;; A Matcher is either
|
;; A Matcher is either
|
||||||
|
;; - #f, indicating no further matches possible
|
||||||
;; - a Set of Any, representing a successful match (if the end of the input has been reached)
|
;; - a Set of 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)
|
||||||
|
@ -45,11 +43,8 @@
|
||||||
;; table.
|
;; table.
|
||||||
(struct wildcard-sequence (matcher) #:transparent)
|
(struct wildcard-sequence (matcher) #:transparent)
|
||||||
|
|
||||||
(define (rnull) (hash))
|
(define (rnull) #f)
|
||||||
|
(define (rempty? r) (not r))
|
||||||
(define (rempty? r)
|
|
||||||
(and (hash? r)
|
|
||||||
(zero? (hash-count r))))
|
|
||||||
|
|
||||||
(define (rvalue v) (set v))
|
(define (rvalue v) (set v))
|
||||||
|
|
||||||
|
@ -90,9 +85,9 @@
|
||||||
(hash-ref r key (lambda () #f)))
|
(hash-ref r key (lambda () #f)))
|
||||||
|
|
||||||
(define (rupdate r key k)
|
(define (rupdate r key k)
|
||||||
(if (and k (not (rempty? k)))
|
(if (rempty? k)
|
||||||
(hash-set r key k)
|
(and r (hash-remove r key))
|
||||||
(hash-remove r key)))
|
(hash-set (or r (hash)) key k)))
|
||||||
|
|
||||||
(define (key-open? k)
|
(define (key-open? k)
|
||||||
(or (eq? k SOP)
|
(or (eq? k SOP)
|
||||||
|
@ -146,15 +141,17 @@
|
||||||
(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)))
|
||||||
walk))
|
(lambda (re1 re2)
|
||||||
|
(match* (re1 re2)
|
||||||
|
[(#f r) r]
|
||||||
|
[(r #f) r]
|
||||||
|
[(r1 r2) (walk r1 r2)]))))
|
||||||
|
|
||||||
(define rand
|
(define rand
|
||||||
(let ()
|
(let ()
|
||||||
(define (walk re1 re2)
|
(define (walk re1 re2)
|
||||||
(match* (re1 re2)
|
(match* (re1 re2)
|
||||||
[((wildcard-sequence r1) (wildcard-sequence r2))
|
[((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (walk r1 r2))]
|
||||||
(define r (walk r1 r2))
|
|
||||||
(and r (rwildseq r))]
|
|
||||||
[((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)]
|
||||||
[((? set? v1) (? set? v2)) (set-union v1 v2)]
|
[((? set? v1) (? set? v2)) (set-union v1 v2)]
|
||||||
|
@ -170,7 +167,7 @@
|
||||||
;; - both nonfalse -> examine the union of the key sets
|
;; - both nonfalse -> examine the union of the key sets
|
||||||
;; This is important for avoiding examination of the whole
|
;; This is important for avoiding examination of the whole
|
||||||
;; structure when wildcards aren't being used.
|
;; structure when wildcards aren't being used.
|
||||||
(for/fold [(acc (if w (rwild w) (hash)))]
|
(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)) ?))]
|
||||||
(rupdate acc
|
(rupdate acc
|
||||||
key
|
key
|
||||||
|
@ -186,7 +183,11 @@
|
||||||
(walk (wildcard-sequence-matcher w) k)
|
(walk (wildcard-sequence-matcher w) k)
|
||||||
#f)]
|
#f)]
|
||||||
[else (walk w k)])))
|
[else (walk w k)])))
|
||||||
walk))
|
(lambda (re1 re2)
|
||||||
|
(match* (re1 re2)
|
||||||
|
[(#f r) #f]
|
||||||
|
[(r #f) #f]
|
||||||
|
[(r1 r2) (walk r1 r2)]))))
|
||||||
|
|
||||||
(define erase-path
|
(define erase-path
|
||||||
(let ()
|
(let ()
|
||||||
|
@ -194,9 +195,7 @@
|
||||||
(error 'erase-path "Cofinite pattern required"))
|
(error '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))
|
[((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (walk r1 r2))]
|
||||||
(define r (walk r1 r2))
|
|
||||||
(and r (rwildseq r))]
|
|
||||||
[((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2)]
|
[((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2)]
|
||||||
[(r1 (wildcard-sequence r2)) (cofinite-pattern)]
|
[(r1 (wildcard-sequence r2)) (cofinite-pattern)]
|
||||||
[((? set? v1) (? set? v2))
|
[((? set? v1) (? set? v2))
|
||||||
|
@ -215,7 +214,7 @@
|
||||||
;; 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. See tests/examples
|
;; same as the wildcard's continuation. See tests/examples
|
||||||
;; below.
|
;; below.
|
||||||
(for/fold [(acc (if w (rwild w) (hash)))]
|
(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)) ?))]
|
||||||
(rupdate acc
|
(rupdate acc
|
||||||
key
|
key
|
||||||
|
@ -233,7 +232,11 @@
|
||||||
k)]
|
k)]
|
||||||
[else (walk w k)])
|
[else (walk w k)])
|
||||||
k))
|
k))
|
||||||
walk))
|
(lambda (re1 re2)
|
||||||
|
(match* (re1 re2)
|
||||||
|
[(#f r) r]
|
||||||
|
[(r #f) (cofinite-pattern)]
|
||||||
|
[(r1 r2) (walk r1 r2)]))))
|
||||||
|
|
||||||
(define (match-value r v)
|
(define (match-value r v)
|
||||||
(let walk ((vs (list v)) (stack '(())) (r r))
|
(let walk ((vs (list v)) (stack '(())) (r r))
|
||||||
|
@ -287,6 +290,8 @@
|
||||||
(define (d x) (display x port))
|
(define (d x) (display x port))
|
||||||
(define (walk i m)
|
(define (walk i m)
|
||||||
(match m
|
(match m
|
||||||
|
[#f
|
||||||
|
(d "::: no further matches possible")]
|
||||||
[(wildcard-sequence k)
|
[(wildcard-sequence k)
|
||||||
(d "...>")
|
(d "...>")
|
||||||
(walk (+ i 4) k)]
|
(walk (+ i 4) k)]
|
||||||
|
@ -443,6 +448,9 @@
|
||||||
(list 'b 'c 'd 'e 'f 'a) ""
|
(list 'b 'c 'd 'e 'f 'a) ""
|
||||||
3 "")
|
3 "")
|
||||||
|
|
||||||
|
(void (pretty-print-matcher (rand (pattern->matcher 'A (list 'a))
|
||||||
|
(pattern->matcher 'B (list 'b)))))
|
||||||
|
|
||||||
(let ((r1 (ror (pattern->matcher 'A (list ? 'b))
|
(let ((r1 (ror (pattern->matcher 'A (list ? 'b))
|
||||||
(pattern->matcher 'A (list ? 'c))))
|
(pattern->matcher 'A (list ? 'c))))
|
||||||
(r2 (ror (pattern->matcher 'B (list 'a ?))
|
(r2 (ror (pattern->matcher 'B (list 'a ?))
|
||||||
|
|
Loading…
Reference in New Issue