Initial steps toward refactoring erase-path into subtract
This commit is contained in:
parent
41666ff408
commit
35ccad13d2
|
@ -409,7 +409,7 @@
|
||||||
;; Process used to be interested in; new-gestalt is its new interests.
|
;; Process used to be interested in; new-gestalt is its new interests.
|
||||||
(define (apply-and-issue-routing-update w old-gestalt new-gestalt known-target)
|
(define (apply-and-issue-routing-update w old-gestalt new-gestalt known-target)
|
||||||
(define new-partial
|
(define new-partial
|
||||||
(gestalt-union (gestalt-erase-path (world-partial-gestalt w) old-gestalt) new-gestalt))
|
(gestalt-union (gestalt-subtract (world-partial-gestalt w) old-gestalt) new-gestalt))
|
||||||
(issue-routing-update (update-full-gestalt (struct-copy world w [partial-gestalt new-partial]))
|
(issue-routing-update (update-full-gestalt (struct-copy world w [partial-gestalt new-partial]))
|
||||||
(gestalt-union old-gestalt new-gestalt)
|
(gestalt-union old-gestalt new-gestalt)
|
||||||
known-target))
|
known-target))
|
||||||
|
|
|
@ -30,7 +30,7 @@
|
||||||
gestalt-union
|
gestalt-union
|
||||||
gestalt-filter
|
gestalt-filter
|
||||||
gestalt-match
|
gestalt-match
|
||||||
gestalt-erase-path
|
gestalt-subtract
|
||||||
gestalt-transform
|
gestalt-transform
|
||||||
strip-gestalt-label
|
strip-gestalt-label
|
||||||
label-gestalt
|
label-gestalt
|
||||||
|
@ -359,10 +359,10 @@
|
||||||
|
|
||||||
;; Gestalt Gestalt -> Gestalt
|
;; Gestalt Gestalt -> Gestalt
|
||||||
;; Erases the g2-subset of g1 from g1, yielding the result.
|
;; Erases the g2-subset of g1 from g1, yielding the result.
|
||||||
(define (gestalt-erase-path g1 g2)
|
(define (gestalt-subtract g1 g2)
|
||||||
(gestalt-combine-straight g1 g2
|
(gestalt-combine-straight g1 g2
|
||||||
erase-imbalance-handler
|
erase-imbalance-handler
|
||||||
matcher-erase-path))
|
matcher-subtract))
|
||||||
|
|
||||||
;; (U 'right-longer 'left-longer) (Listof X) -> (Listof X)
|
;; (U 'right-longer 'left-longer) (Listof X) -> (Listof X)
|
||||||
;; Asymmetric imbalance handler suitable for use in subtraction operations.
|
;; Asymmetric imbalance handler suitable for use in subtraction operations.
|
||||||
|
|
|
@ -23,7 +23,7 @@
|
||||||
pattern->matcher*
|
pattern->matcher*
|
||||||
matcher-union
|
matcher-union
|
||||||
matcher-intersect
|
matcher-intersect
|
||||||
matcher-erase-path
|
matcher-subtract
|
||||||
matcher-match-value
|
matcher-match-value
|
||||||
matcher-match-matcher
|
matcher-match-matcher
|
||||||
matcher-append
|
matcher-append
|
||||||
|
@ -45,7 +45,7 @@
|
||||||
|
|
||||||
matcher-union-successes
|
matcher-union-successes
|
||||||
matcher-intersect-successes
|
matcher-intersect-successes
|
||||||
matcher-erase-path-successes
|
matcher-subtract-successes
|
||||||
matcher-match-matcher-successes
|
matcher-match-matcher-successes
|
||||||
matcher-match-matcher-unit
|
matcher-match-matcher-unit
|
||||||
matcher-project-success)
|
matcher-project-success)
|
||||||
|
@ -72,7 +72,7 @@
|
||||||
|
|
||||||
(define matcher-intersect-successes (make-parameter set-union))
|
(define matcher-intersect-successes (make-parameter set-union))
|
||||||
|
|
||||||
(define matcher-erase-path-successes
|
(define matcher-subtract-successes
|
||||||
(make-parameter
|
(make-parameter
|
||||||
(lambda (s1 s2)
|
(lambda (s1 s2)
|
||||||
(define r (set-subtract s1 s2))
|
(define r (set-subtract s1 s2))
|
||||||
|
@ -385,30 +385,27 @@
|
||||||
[(r1 r2) (walk r1 r2)]))))
|
[(r1 r2) (walk r1 r2)]))))
|
||||||
|
|
||||||
;; Matcher Matcher -> Matcher
|
;; Matcher Matcher -> Matcher
|
||||||
;; Removes re2's mappings from re1. Assumes re2 has previously been union'd into re1.
|
;; Removes re2's mappings from 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 original1 original2)
|
(define (matcher-subtract original1 original2)
|
||||||
(let ()
|
(let ()
|
||||||
(define (cofinite-pattern)
|
(define (cofinite-pattern)
|
||||||
(error 'matcher-erase-path "Cofinite pattern required subtracting:\n ~a\nfrom ~a"
|
(error 'matcher-subtract "Cofinite pattern required subtracting:\n ~a\nfrom ~a"
|
||||||
(matcher->pretty-string original2 #:indent 5)
|
(matcher->pretty-string original2 #:indent 5)
|
||||||
(matcher->pretty-string original1 #:indent 5)))
|
(matcher->pretty-string original1 #:indent 5)))
|
||||||
(define (erase-path r1 r2)
|
(define (walk r1 r2)
|
||||||
(match* (r1 r2)
|
(match* (r1 r2)
|
||||||
[(#f #f) #f]
|
[(#f #f) #f]
|
||||||
[(r #f) r]
|
[(r #f) r]
|
||||||
[(#f r) (cofinite-pattern)]
|
[(#f r) (cofinite-pattern)]
|
||||||
[(r1 r2) (walk r1 r2)]))
|
|
||||||
(define (walk 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) (cofinite-pattern)]
|
[((wildcard-sequence r1) r2) (cofinite-pattern)]
|
||||||
[(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2))]
|
[(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2))]
|
||||||
[((success v1) (success v2)) (rsuccess ((matcher-erase-path-successes) v1 v2))]
|
[((success v1) (success v2)) (rsuccess ((matcher-subtract-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 ?))
|
||||||
(define w (erase-path w1 w2))
|
(define w (walk w1 w2))
|
||||||
(define (examine-key acc key)
|
(define (examine-key acc key)
|
||||||
(define updated-k (match* ((rlookup h1 key) (rlookup h2 key))
|
(define updated-k (match* ((rlookup h1 key) (rlookup h2 key))
|
||||||
[(#f #f) #f]
|
[(#f #f) #f]
|
||||||
|
@ -447,7 +444,7 @@
|
||||||
k)]
|
k)]
|
||||||
[else (walk k w)])
|
[else (walk k w)])
|
||||||
k))
|
k))
|
||||||
(erase-path original1 original2)))
|
(walk original1 original2)))
|
||||||
|
|
||||||
;; Matcher -> Matcher
|
;; Matcher -> Matcher
|
||||||
;; Checks for redundant branches in its argument: when a matcher
|
;; Checks for redundant branches in its argument: when a matcher
|
||||||
|
@ -1192,8 +1189,8 @@
|
||||||
(pretty-print-matcher* r1)
|
(pretty-print-matcher* r1)
|
||||||
(pretty-print-matcher* r2)
|
(pretty-print-matcher* r2)
|
||||||
(pretty-print-matcher* r12)
|
(pretty-print-matcher* r12)
|
||||||
(pretty-print-matcher* (matcher-erase-path r12 r1))
|
(pretty-print-matcher* (matcher-subtract r12 r1))
|
||||||
(pretty-print-matcher* (matcher-erase-path r12 r2))
|
(pretty-print-matcher* (matcher-subtract r12 r2))
|
||||||
(void))
|
(void))
|
||||||
|
|
||||||
(let* ((r1 (matcher-union (pattern->matcher SA (list 'a ?))
|
(let* ((r1 (matcher-union (pattern->matcher SA (list 'a ?))
|
||||||
|
@ -1202,8 +1199,8 @@
|
||||||
(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 r12 r1))
|
(pretty-print-matcher* (matcher-subtract r12 r1))
|
||||||
(pretty-print-matcher* (matcher-erase-path r12 r2))
|
(pretty-print-matcher* (matcher-subtract r12 r2))
|
||||||
(void))
|
(void))
|
||||||
|
|
||||||
)
|
)
|
||||||
|
@ -1461,17 +1458,17 @@
|
||||||
(module+ test
|
(module+ test
|
||||||
(let ((A (pattern->matcher SA ?))
|
(let ((A (pattern->matcher SA ?))
|
||||||
(B (pattern->matcher SB (list (list (list (list 'foo)))))))
|
(B (pattern->matcher SB (list (list (list (list 'foo)))))))
|
||||||
(check-requal? (pretty-print-matcher* (matcher-erase-path (matcher-union A B) B))
|
(check-requal? (pretty-print-matcher* (matcher-subtract (matcher-union A B) B))
|
||||||
A))
|
A))
|
||||||
(let ((A (pattern->matcher SA ?))
|
(let ((A (pattern->matcher SA ?))
|
||||||
(B (matcher-union (pattern->matcher SB (list (list (list (list 'foo)))))
|
(B (matcher-union (pattern->matcher SB (list (list (list (list 'foo)))))
|
||||||
(pattern->matcher SB (list (list (list (list 'bar))))))))
|
(pattern->matcher SB (list (list (list (list 'bar))))))))
|
||||||
(check-requal? (pretty-print-matcher* (matcher-erase-path (matcher-union A B) B))
|
(check-requal? (pretty-print-matcher* (matcher-subtract (matcher-union A B) B))
|
||||||
A))
|
A))
|
||||||
(let ((A (pattern->matcher SA ?))
|
(let ((A (pattern->matcher SA ?))
|
||||||
(B (matcher-union (pattern->matcher SB (list (list (list (list 'foo)))))
|
(B (matcher-union (pattern->matcher SB (list (list (list (list 'foo)))))
|
||||||
(pattern->matcher SB (list (list (list (list 'bar))))))))
|
(pattern->matcher SB (list (list (list (list 'bar))))))))
|
||||||
(check-requal? (pretty-print-matcher* (matcher-erase-path (matcher-union A B) A))
|
(check-requal? (pretty-print-matcher* (matcher-subtract (matcher-union A B) A))
|
||||||
B)))
|
B)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
|
|
Loading…
Reference in New Issue