More tests of projection; change to default matcher-union-successes
This commit is contained in:
parent
a9c750ab6b
commit
5058330e80
|
@ -168,16 +168,11 @@
|
||||||
|
|
||||||
;; View on g1 from g2's perspective.
|
;; View on g1 from g2's perspective.
|
||||||
(define (gestalt-filter g1 g2)
|
(define (gestalt-filter g1 g2)
|
||||||
(parameterize ((matcher-union-successes (lambda (v1 v2)
|
(gestalt (map-zip shorter-imbalance-handler
|
||||||
(match* (v1 v2)
|
filter-one-metalevel
|
||||||
[(#t v) v]
|
cons-metalevel
|
||||||
[(v #t) v]
|
(gestalt-metalevels g1)
|
||||||
[(v1 v2) (set-union v1 v2)]))))
|
(gestalt-metalevels g2))))
|
||||||
(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
|
||||||
|
|
|
@ -35,7 +35,11 @@
|
||||||
matcher-project-success)
|
matcher-project-success)
|
||||||
|
|
||||||
;; TODO: perhaps avoid the parameters on the fast-path, if they are causing measurable slowdown.
|
;; TODO: perhaps avoid the parameters on the fast-path, if they are causing measurable slowdown.
|
||||||
(define matcher-union-successes (make-parameter set-union))
|
(define matcher-union-successes (make-parameter (lambda (v1 v2)
|
||||||
|
(match* (v1 v2)
|
||||||
|
[(#t v) v]
|
||||||
|
[(v #t) v]
|
||||||
|
[(v1 v2) (set-union v1 v2)]))))
|
||||||
(define matcher-intersect-successes (make-parameter set-union))
|
(define matcher-intersect-successes (make-parameter set-union))
|
||||||
(define matcher-erase-path-successes (make-parameter (lambda (s1 s2)
|
(define matcher-erase-path-successes (make-parameter (lambda (s1 s2)
|
||||||
(define r (set-subtract s1 s2))
|
(define r (set-subtract s1 s2))
|
||||||
|
@ -1106,6 +1110,22 @@
|
||||||
(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
|
||||||
|
(matcher-project (foldr matcher-union (matcher-empty)
|
||||||
|
(list (pattern->matcher SA (cons 1 2))
|
||||||
|
(pattern->matcher SC (cons ? 3))
|
||||||
|
(pattern->matcher SB (cons 3 4))))
|
||||||
|
(compile-projection (cons (?!) (?!)))))
|
||||||
|
#f)
|
||||||
|
|
||||||
|
(check-equal? (matcher-key-set
|
||||||
|
(matcher-project (foldr matcher-union (matcher-empty)
|
||||||
|
(list (pattern->matcher SA (cons ? 2))
|
||||||
|
(pattern->matcher SC (cons 1 3))
|
||||||
|
(pattern->matcher SB (cons 3 4))))
|
||||||
|
(compile-projection (cons ? (?!)))))
|
||||||
|
(set '#(2) '#(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)))
|
||||||
|
@ -1123,4 +1143,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 (?! (vector 'b)))) (list 'a (vector 'b)))
|
(check-equal? (projection->pattern (list 'a (?! (vector 'b)))) (list 'a (vector 'b)))
|
||||||
(check-equal? (projection->pattern (list 'a (?! (vector ? ?)))) (list 'a (vector ? ?)))
|
(check-equal? (projection->pattern (list 'a (?! (vector ? ?)))) (list 'a (vector ? ?)))
|
||||||
)
|
)
|
||||||
|
|
Loading…
Reference in New Issue