Avoid inefficiency in filter and match by reordering union and intersection
This commit is contained in:
parent
8a7fce46fa
commit
720f84a4a6
|
@ -51,10 +51,6 @@
|
||||||
;; Convention: A GestaltSet is a Gestalt where the Matchers map to #t
|
;; Convention: A GestaltSet is a Gestalt where the Matchers map to #t
|
||||||
;; instead of (NonemptySetof PID) or any other value.
|
;; instead of (NonemptySetof PID) or any other value.
|
||||||
|
|
||||||
;; TODO: consider caching the unioning that happens when a high-level
|
|
||||||
;; subscription is smeared across lower levels for the purposes of
|
|
||||||
;; filtering and matching of routing-updates.
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define (safe-list-ref xs n [fail-thunk (lambda () (error 'safe-list-ref "No such index ~v" n))])
|
(define (safe-list-ref xs n [fail-thunk (lambda () (error 'safe-list-ref "No such index ~v" n))])
|
||||||
|
@ -157,68 +153,73 @@
|
||||||
|
|
||||||
(define (gestalt-union1 g1 g2) (gestalt-combine-straight g1 g2 (lambda (side x) x) matcher-union))
|
(define (gestalt-union1 g1 g2) (gestalt-combine-straight g1 g2 (lambda (side x) x) matcher-union))
|
||||||
|
|
||||||
(define (shorter-imbalance-handler side x) '())
|
|
||||||
|
|
||||||
;; View on g1 from g2's perspective.
|
;; View on g1 from g2's perspective.
|
||||||
(define (gestalt-filter g1 g2)
|
(define gestalt-filter
|
||||||
(gestalt (map-zip shorter-imbalance-handler
|
(let ()
|
||||||
filter-one-metalevel
|
(define (filter-metalevels mls1 mls2)
|
||||||
cons-metalevel
|
(match* (mls1 mls2)
|
||||||
(gestalt-metalevels g1)
|
[('() _) '()]
|
||||||
(gestalt-metalevels g2))))
|
[(_ '()) '()]
|
||||||
|
[((cons ls1 mrest1) (cons ls2-unshifted mrest2))
|
||||||
|
(cons-metalevel (filter-levels ls1 (safe-cdr ls2-unshifted))
|
||||||
|
(filter-metalevels mrest1 mrest2))]))
|
||||||
|
|
||||||
|
(define (filter-levels ls1 ls2)
|
||||||
|
(match ls1
|
||||||
|
['() '()]
|
||||||
|
[(cons (cons subs1 advs1) lrest1)
|
||||||
|
(if (null? ls2)
|
||||||
|
'()
|
||||||
|
(cons-level (filter-single-level subs1 advs1 ls2)
|
||||||
|
(filter-levels lrest1 (cdr ls2))))]))
|
||||||
|
|
||||||
|
(define (filter-single-level subs1 advs1 ls2)
|
||||||
|
(let loop ((ls2 ls2) (subs #f) (advs #f))
|
||||||
|
(match ls2
|
||||||
|
['() (cons subs advs)]
|
||||||
|
[(cons (cons subs2 advs2) lrest2)
|
||||||
|
(loop lrest2
|
||||||
|
(matcher-union subs (matcher-intersect subs1 advs2))
|
||||||
|
(matcher-union advs (matcher-intersect advs1 subs2)))])))
|
||||||
|
|
||||||
|
(lambda (g1 g2)
|
||||||
|
(parameterize ((matcher-intersect-successes (lambda (v1 v2) v1)))
|
||||||
|
(gestalt (filter-metalevels (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
|
||||||
;; just the set of values in the g2-map that were overlapped by some
|
;; just the set of values in the g2-map that were overlapped by some
|
||||||
;; part of g1.
|
;; part of g1.
|
||||||
(define (gestalt-match g1 g2)
|
(define gestalt-match
|
||||||
(let loop ((mls1 (gestalt-metalevels g1))
|
(let ()
|
||||||
(mls2 (gestalt-metalevels g2)))
|
(define (match-metalevels mls1 mls2 acc)
|
||||||
(cond [(null? mls1) (set)]
|
(match* (mls1 mls2)
|
||||||
[(null? mls2) (set)]
|
[('() _) acc]
|
||||||
[else (match-define (cons ls1 rest1) mls1)
|
[(_ '()) acc]
|
||||||
(match-define (cons ls2 rest2) mls2)
|
[((cons ls1 mrest1) (cons ls2-unshifted mrest2))
|
||||||
(set-union (match-one-metalevel ls1 ls2)
|
(match-levels ls1 (cdr ls2-unshifted) (match-metalevels mrest1 mrest2 acc))]))
|
||||||
(loop rest1 rest2))])))
|
|
||||||
|
|
||||||
;; Returns ls, with one level dropped, and with the remaining matchers
|
(define (match-levels ls1 ls2 acc)
|
||||||
;; "smeared" across lower levels. This could end up being reasonably
|
(match ls1
|
||||||
;; expensive - see above TODO about possibly caching it.
|
['() acc]
|
||||||
(define (smear-levels ls)
|
[(cons (cons subs1 advs1) lrest1)
|
||||||
(foldr (lambda (p acc)
|
(if (null? ls2)
|
||||||
(match-define (cons acc-subs acc-advs) (if (null? acc) empty-level (car acc)))
|
acc
|
||||||
(match-define (cons new-subs new-advs) p)
|
(match-single-level subs1 advs1 ls2 (match-levels lrest1 (cdr ls2) acc)))]))
|
||||||
(cons (cons (matcher-union new-subs acc-subs)
|
|
||||||
(matcher-union new-advs acc-advs))
|
|
||||||
acc))
|
|
||||||
'()
|
|
||||||
(safe-cdr ls)))
|
|
||||||
|
|
||||||
(define (filter-one-metalevel ls1 ls2)
|
(define (match-single-level subs1 advs1 ls2 acc)
|
||||||
(parameterize ((matcher-intersect-successes (lambda (v1 v2) v1)))
|
(let loop ((ls2 ls2) (acc acc))
|
||||||
(let loop ((ls1 ls1) (ls2 (smear-levels ls2)))
|
(match ls2
|
||||||
(cond [(null? ls1) '()]
|
['() acc]
|
||||||
[(null? ls2) '()]
|
[(cons (cons subs2 advs2) lrest2)
|
||||||
[else (match-define (cons (cons subs1 advs1) rest1) ls1)
|
(loop lrest2 (set-union (matcher-match-matcher subs1 advs2)
|
||||||
(match-define (cons (cons subs2 advs2) rest2) ls2)
|
(matcher-match-matcher advs1 subs2)
|
||||||
(cons-level (cons (matcher-intersect subs1 advs2)
|
acc))])))
|
||||||
(matcher-intersect advs1 subs2))
|
|
||||||
(loop rest1 rest2))]))))
|
|
||||||
|
|
||||||
(define (match-matchers m1 m2)
|
(lambda (g1 g2)
|
||||||
(parameterize ((matcher-match-matcher-successes (lambda (v1 v2 acc) (set-union v2 acc)))
|
(parameterize ((matcher-match-matcher-successes (lambda (v1 v2 acc) (set-union v2 acc)))
|
||||||
(matcher-match-matcher-unit (set)))
|
(matcher-match-matcher-unit (set)))
|
||||||
(matcher-match-matcher m1 m2)))
|
(match-metalevels (gestalt-metalevels g1) (gestalt-metalevels g2) (set))))))
|
||||||
|
|
||||||
(define (match-one-metalevel ls1 ls2)
|
|
||||||
(let loop ((ls1 ls1) (ls2 (smear-levels ls2)))
|
|
||||||
(cond [(null? ls1) (set)]
|
|
||||||
[(null? ls2) (set)]
|
|
||||||
[else (match-define (cons (cons subs1 advs1) rest1) ls1)
|
|
||||||
(match-define (cons (cons subs2 advs2) rest2) ls2)
|
|
||||||
(set-union (match-matchers subs1 advs2)
|
|
||||||
(match-matchers advs1 subs2)
|
|
||||||
(loop rest1 rest2))])))
|
|
||||||
|
|
||||||
(define (gestalt-erase-path g1 g2)
|
(define (gestalt-erase-path g1 g2)
|
||||||
(gestalt-combine-straight g1 g2
|
(gestalt-combine-straight g1 g2
|
||||||
|
|
Loading…
Reference in New Issue