From 80a2cef81c1059a9eefa8157ed9ac5609552d098 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 1 May 2014 07:36:56 -0400 Subject: [PATCH] Limited route subtraction, via erase-path. --- minimart/route.rkt | 111 ++++++++++++++++++++++++++++++++++++++------- 1 file changed, 95 insertions(+), 16 deletions(-) diff --git a/minimart/route.rkt b/minimart/route.rkt index d1fcd2d..30623d2 100644 --- a/minimart/route.rkt +++ b/minimart/route.rkt @@ -90,7 +90,7 @@ (hash-ref r key (lambda () #f))) (define (rupdate r key k) - (if k + (if (and k (not (rempty? k))) (hash-set r key k) (hash-remove r key))) @@ -120,7 +120,7 @@ [(r1 r2) (walk r1 r2)])) (define (walk re1 re2) (match* (re1 re2) - [((wildcard-sequence r1) (wildcard-sequence r2)) (wildcard-sequence (walk r1 r2))] + [((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (walk r1 r2))] [((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2)] [(r1 (wildcard-sequence r2)) (walk (expand-wildseq r2) r1)] [((? set? v1) (? set? v2)) (set-union v1 v2)] @@ -131,7 +131,7 @@ [(< (hash-count h2) (hash-count h1)) (merge/no-wildcard h2 h1)] [else (merge/no-wildcard h1 h2)])])) (define (merge/wildcard w h1 h2) - (for/fold [(acc (hash ? w))] + (for/fold [(acc (rwild w))] [(key (set-remove (set-union (hash-keys h1) (hash-keys h2)) ?))] (define k (merge (rlookup h1 key) (rlookup h2 key))) (rupdate acc @@ -162,16 +162,24 @@ (define w1 (rlookup h1 ?)) (define w2 (rlookup h2 ?)) (define w (and w1 w2 (walk w1 w2))) - (for/fold [(acc (if w (hash ? w) (hash)))] + ;; TODO: if, say, w1 is #f, then we don't need to examine + ;; every key in h2. So there are four cases: + ;; - both false -> examine the intersection of the key sets + ;; (done by enumerating keys in the smaller hash) + ;; - one nonfalse -> examine only the keys in the other + ;; - both nonfalse -> examine the union of the key sets + ;; This is important for avoiding examination of the whole + ;; structure when wildcards aren't being used. + (for/fold [(acc (if w (rwild w) (hash)))] [(key (set-remove (set-union (hash-keys h1) (hash-keys h2)) ?))] (rupdate acc key (match* ((rlookup h1 key) (rlookup h2 key)) [(#f #f) #f] - [(#f k2) (merge-wild w1 key k2)] - [(k1 #f) (merge-wild w2 key k1)] + [(#f k2) (walk-wild w1 key k2)] + [(k1 #f) (walk-wild w2 key k1)] [(k1 k2) (walk k1 k2)])))])) - (define (merge-wild w key k) + (define (walk-wild w key k) (and w (cond [(key-open? key) (walk (rwildseq w) k)] [(key-close? key) (if (wildcard-sequence? w) @@ -180,6 +188,53 @@ [else (walk w k)]))) walk)) +(define erase-path + (let () + (define (cofinite-pattern) + (error 'erase-path "Cofinite pattern required")) + (define (walk path aggregate) + (match* (path aggregate) + [((wildcard-sequence r1) (wildcard-sequence r2)) + (define r (walk r1 r2)) + (and r (rwildseq r))] + [((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2)] + [(r1 (wildcard-sequence r2)) (cofinite-pattern)] + [((? set? v1) (? set? v2)) + (define v (set-subtract v2 v1)) + (if (set-empty? v) #f v)] + [((? hash? h1) (? hash? h2)) + (define w1 (rlookup h1 ?)) + (define w2 (rlookup h2 ?)) + (define w (match* (w1 w2) + [(#f #f) #f] + [(#f r) r] + [(r #f) (cofinite-pattern)] + [(r1 r2) (walk r1 r2)])) + ;; TODO: only need to examine all keys of h2 if w1 nonfalse. + ;; TODO: need to ensure "minimal" remainder in cases where + ;; after an erasure, a particular key's continuation is the + ;; same as the wildcard's continuation. See tests/examples + ;; below. + (for/fold [(acc (if w (rwild w) (hash)))] + [(key (set-remove (set-union (hash-keys h1) (hash-keys h2)) ?))] + (rupdate acc + key + (match* ((rlookup h1 key) (rlookup h2 key)) + [(#f #f) #f] + [(#f k2) (walk-wild w1 key k2)] + [(k1 #f) (cofinite-pattern)] + [(k1 k2) (walk k1 k2)])))])) + (define (walk-wild w key k) + (if w + (cond + [(key-open? key) (walk (rwildseq w) k)] + [(key-close? key) (if (wildcard-sequence? w) + (walk (wildcard-sequence-matcher w) k) + k)] + [else (walk w k)]) + k)) + walk)) + (define (match-value r v) (let walk ((vs (list v)) (stack '(())) (r r)) (define (walk-wild vs stack) @@ -240,15 +295,17 @@ (for ((v vs)) (d v)) (d "}")] [(? hash? h) - (for/fold [(need-sep? #f)] [((key k) (in-hash h))] - (when need-sep? - (newline port) - (d (make-string i #\space))) - (d " ") - (define keystr (call-with-output-string (lambda (p) (display key p)))) - (d keystr) - (walk (+ i 1 (string-length keystr)) k) - #t)])) + (if (zero? (hash-count h)) + (d " ::: empty hash!") + (for/fold [(need-sep? #f)] [((key k) (in-hash h))] + (when need-sep? + (newline port) + (d (make-string i #\space))) + (d " ") + (define keystr (call-with-output-string (lambda (p) (display key p)))) + (d keystr) + (walk (+ i 1 (string-length keystr)) k) + #t))])) (newline port) (walk 0 m) (newline port) @@ -419,4 +476,26 @@ (list 'Z '((()) - -)) "XZ+" (list '? (list '- '- '-)) "") + (let* ((r1 (pattern->matcher 'A (list ? 'b))) + (r2 (pattern->matcher 'B (list 'a ?))) + (r12 (ror r1 r2))) + (printf "\n-=-=-=-=-=-=-=-=- erase1\n") + (pretty-print-matcher r1) + (pretty-print-matcher r2) + (pretty-print-matcher r12) + ;; TODO: these next two are not currently "minimal" + (pretty-print-matcher (erase-path r1 r12)) + (pretty-print-matcher (erase-path r2 r12)) + (void)) + + (let* ((r1 (ror (pattern->matcher 'A (list 'a ?)) + (pattern->matcher 'A (list 'b ?)))) + (r2 (pattern->matcher 'B (list 'b ?))) + (r12 (ror r1 r2))) + (printf "\n-=-=-=-=-=-=-=-=- erase2\n") + (pretty-print-matcher r12) + (pretty-print-matcher (erase-path r1 r12)) + (pretty-print-matcher (erase-path r2 r12)) + (void)) + ) \ No newline at end of file