Avoid inefficiency in filter and match by reordering union and intersection

This commit is contained in:
Tony Garnock-Jones 2014-05-26 15:33:02 -04:00
parent 8a7fce46fa
commit 720f84a4a6
1 changed files with 58 additions and 57 deletions

View File

@ -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