diff --git a/prospect/patch.rkt b/prospect/patch.rkt index 28f4a34..8f1202c 100644 --- a/prospect/patch.rkt +++ b/prospect/patch.rkt @@ -55,7 +55,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define at-meta-proj (compile-projection (at-meta (?!)))) -(define observe-proj (compile-projection (observe (?!)))) (define (patch-empty? p) (and (patch? p) @@ -197,12 +196,10 @@ (matcher-subtract old-base new-base))) (define (biased-intersection object subject) - (matcher-project (matcher-intersect (pattern->matcher #t (observe (embedded-matcher object))) - subject - #:combiner (lambda (v1 v2) #t)) - observe-proj - #:project-success (lambda (v) #t) - #:combiner (lambda (v1 v2) #t))) + (matcher-intersect object + (matcher-step subject struct:observe) + #:combiner (lambda (v1 v2) #t) + #:left-short (lambda (v r) (matcher-step r EOS)))) (define (view-patch p interests) (patch (biased-intersection (patch-added p) interests) diff --git a/prospect/route.rkt b/prospect/route.rkt index 6b32ba0..c9735a7 100644 --- a/prospect/route.rkt +++ b/prospect/route.rkt @@ -33,6 +33,12 @@ matcher-append matcher-relabel + SOL + SOV + ILM + EOS + matcher-step + ;; Projections compile-projection compile-projection* @@ -320,6 +326,9 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Matcher combinators +(define (default-short v r) + (error 'default-short "Asymmetric matchers; value ~v, matcher ~v" v r)) + ;; Matcher Matcher -> Matcher ;; Computes the union of the multimaps passed in. (define (matcher-union re1 re2 #:combiner [combiner set-union]) @@ -329,21 +338,28 @@ values values values - values)) + values + default-short + default-short)) ;; (A B -> C) -> A B -> B A -> C (define ((flip f) a b) (f b a)) ;; Matcher Matcher -> Matcher ;; Computes the intersection of the multimaps passed in. -(define (matcher-intersect re1 re2 #:combiner [combiner set-union]) +(define (matcher-intersect re1 re2 + #:combiner [combiner set-union] + #:left-short [left-short default-short] + #:right-short [right-short default-short]) (matcher-recurse re1 re2 combiner (lambda (r) #f) (lambda (r) #f) (lambda (h) #f) - (lambda (h) #f))) + (lambda (h) #f) + left-short + right-short)) (define (empty-set-guard s) (if (set-empty? s) #f s)) @@ -361,19 +377,26 @@ (lambda (r) #f) values (lambda (h) #f) - values)) + values + default-short + default-short)) -(define (matcher-recurse re1 re2 vf left-false right-false right-base left-base) +(define (matcher-recurse re1 re2 vf left-false right-false right-base left-base left-short right-short) (let f ((re1 re1) (re2 re2)) (match* (re1 re2) [(#f r) (left-false r)] [(r #f) (right-false r)] + + [((? treap? h1) (? treap? h2)) + (fold-over-keys h1 h2 f (left-base h1) (right-base h2))] + [((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (f r1 r2))] [((wildcard-sequence r1) r2) (f (expand-wildseq r1) r2)] [(r1 (wildcard-sequence r2)) (f r1 (expand-wildseq r2))] + [((success v1) (success v2)) (rsuccess (vf v1 v2))] - [((? treap? h1) (? treap? h2)) - (fold-over-keys h1 h2 f (left-base h1) (right-base h2))]))) + [((success v) r) (left-short v r)] + [(r (success v)) (right-short v r)]))) (define (fold-over-keys h1 h2 f left-base right-base) (define w1 (rlookup h1 ? #f)) @@ -568,6 +591,14 @@ [(kv (treap-to-alist m)) #:when (not (eq? (car kv) ?))] (rupdate acc (car kv) (walk (cdr kv))))]))) +;; Matcher Sigma -> Matcher +(define (matcher-step m s) + (match m + [#f #f] + [(wildcard-sequence k) (if (key-close? s) k m)] + [(success _) #f] + [(? treap? h) (rlookup h s (treap-get h ? (lambda () #f)))])) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Projection @@ -1488,3 +1519,30 @@ (void (pretty-print-matcher* (matcher-union (pattern->matcher SA ?) (pattern->matcher SB (list ? '- ?)))))) + +(module+ test + (let () + (newline) + (printf "Biased-intersection test\n") + (struct obs (val) #:prefab) + (let ((object (matcher-union (pattern->matcher #t 1) + (pattern->matcher #t 2))) + (subject (matcher-union (pattern->matcher #t 99) + (pattern->matcher #t (obs ?))))) + (pretty-print-matcher* object) + ;; The default, slow way of computing a biased intersection: + (pretty-print-matcher* + (matcher-project (matcher-intersect (pattern->matcher #t (obs (embedded-matcher object))) + subject + #:combiner (lambda (v1 v2) #t)) + (compile-projection (obs (?!))) + #:project-success (lambda (v) #t) + #:combiner (lambda (v1 v2) #t))) + ;; A hopefully quicker way of doing the same: + (define intersection (matcher-intersect object + (matcher-step subject struct:obs) + #:combiner (lambda (v1 v2) #t) + #:left-short (lambda (v r) + (matcher-step r EOS)))) + (pretty-print-matcher* intersection)) + (void)))