diff --git a/FAQ.md b/FAQ.md index 445f9d0..1eb7a5b 100644 --- a/FAQ.md +++ b/FAQ.md @@ -135,35 +135,36 @@ you are interested in, compile a pattern for those assertions, and pass that along with the trie to `trie-project/set`. - `trie-project/set` takes a trie and a pattern and returns a set of lists - - Say you are in interested in assertions of the shape `('posn x y)`. - * compile the pattern using ```(compile-projection `(posn ,(?!) ,(?!)))``` + - Say you are in interested in assertions of the shape `(posn x y)` for all `x` and `y` + within some assertion-set `asserions`. + * call `(trie-project/set #:take 2 assertions (posn (?!) (?!)))` * the `(?!)` is for **capturing** the matched value. Use `?` if you want to match but don't care about the actual value. * the lists returned by `trie-project/set` contain the captured values in order. - - Say we are receiving a patch p where the assertion `('posn 2 3)` was added. + * the argument to `#:take` must match the number of captures in + the pattern. Use `projection-arity` if you don't statically know + this number. + - Say we are receiving a patch p where the assertion `(posn 2 3)` was added. - The result of ```racket - (trie-project/set (patch-added p) - (compile-projection `(posn ,(?!) ,(?!)))) + (trie-project/set #:take 2 (patch-added p) (posn (?!) (?!))) ``` would be `(set (list 2 3))`. - If we only cared about the y position, we could instead do ```racket - (trie-project/set (patch-added p) - (compile-projection `(posn ,? ,(?!)))) + (trie-project/set #:take 1 (patch-added p) (posn ? (?!))) ``` and get the result `(set (list 3))`. - an entire structure can be captured by passing a pattern as an argument to `(?!)`. ```racket - (trie-project/set (patch-added p) - (compile-projection (?! `(posn ,? ,?)))) + (trie-project/set #:take 1 (patch-added p) (?! (posn ? ?))) ``` - with the same example yields `(set (list ('posn 2 3))`. + with the same example yields `(set (posn 2 3))`. - `trie-project/set/single` is like mapping `car` over the result of `trie-project/set`. See also `project-assertions`. - `patch-project/set` uses `values` to return the result of matching a projection diff --git a/prospect-monolithic/core.rkt b/prospect-monolithic/core.rkt index 9f53497..24774ef 100644 --- a/prospect-monolithic/core.rkt +++ b/prospect-monolithic/core.rkt @@ -14,7 +14,7 @@ (all-from-out "scn.rkt") - ;; imported from route.rkt: + ;; imported from trie.rkt: ? wildcard? ?! @@ -25,7 +25,7 @@ trie-empty? trie-empty projection->pattern - compile-projection + projection-arity trie-project trie-project/set trie-project/set/single @@ -67,7 +67,7 @@ (require racket/match) (require (only-in racket/list flatten)) (require "../prospect/functional-queue.rkt") -(require "../prospect/route.rkt") +(require "../prospect/trie.rkt") (require "scn.rkt") (require "../prospect/trace.rkt") (require "mux.rkt") @@ -133,13 +133,13 @@ (define (observe-at-meta pattern level) (if (zero? level) - (pattern->trie #t (observe pattern)) + (pattern->trie ' (observe pattern)) (trie-union - (pattern->trie #t (observe (prepend-at-meta pattern level))) - (pattern->trie #t (at-meta (embedded-trie (observe-at-meta pattern (- level 1)))))))) + (pattern->trie ' (observe (prepend-at-meta pattern level))) + (pattern->trie ' (at-meta (embedded-trie (observe-at-meta pattern (- level 1)))))))) (define (assertion pattern #:meta-level [level 0]) - (pattern->trie #t (prepend-at-meta pattern level))) + (pattern->trie ' (prepend-at-meta pattern level))) (define (subscription pattern #:meta-level [level 0]) (observe-at-meta pattern level)) @@ -152,10 +152,10 @@ (define (assertion-set-union* tries) (match tries - ['() (trie-empty)] + ['() trie-empty] [(cons t1 rest) (for/fold [(t1 t1)] [(t2 (in-list rest))] - (trie-union t1 t2 #:combiner (lambda (a b) #t)))])) + (trie-union t1 t2 #:combiner (lambda (a b) (trie-success '))))])) (define (scn/union . tries) (scn (assertion-set-union* tries))) @@ -398,7 +398,7 @@ (define-values (initial-scn remaining-initial-actions) (match initial-actions [(cons (? scn? s) rest) (values s rest)] - [other (values (scn (trie-empty)) other)])) + [other (values (scn trie-empty) other)])) (define-values (new-mux new-pid s aggregate-assertions) (mux-add-stream (network-mux w) initial-scn)) (let* ((w (struct-copy network w diff --git a/prospect-monolithic/demand-matcher.rkt b/prospect-monolithic/demand-matcher.rkt index c199b23..cbd6f0e 100644 --- a/prospect-monolithic/demand-matcher.rkt +++ b/prospect-monolithic/demand-matcher.rkt @@ -20,6 +20,8 @@ ;; exists. (struct demand-matcher (demand-spec ;; CompiledProjection supply-spec ;; CompiledProjection + demand-spec-arity ;; Natural + supply-spec-arity ;; Natural increase-handler ;; ChangeHandler decrease-handler ;; ChangeHandler current-demand ;; (Setof (Listof Any)) @@ -42,6 +44,8 @@ (define (make-demand-matcher demand-spec supply-spec increase-handler decrease-handler) (demand-matcher demand-spec supply-spec + (projection-arity demand-spec) + (projection-arity supply-spec) increase-handler decrease-handler (set) @@ -52,9 +56,16 @@ ;; demand increase and decrease sets. Calls ChangeHandlers in response ;; to increased unsatisfied demand and decreased demanded supply. (define (demand-matcher-update d s new-scn) - (match-define (demand-matcher demand-spec supply-spec inc-h dec-h demand supply) d) - (define new-demand (trie-project/set (scn-trie new-scn) demand-spec)) - (define new-supply (trie-project/set (scn-trie new-scn) supply-spec)) + (match-define (demand-matcher demand-spec + supply-spec + demand-arity + supply-arity + inc-h + dec-h + demand + supply) d) + (define new-demand (trie-project/set #:take demand-arity (scn-trie new-scn) demand-spec)) + (define new-supply (trie-project/set #:take supply-arity (scn-trie new-scn) supply-spec)) (define added-demand (set-subtract new-demand demand)) (define removed-demand (set-subtract demand new-demand)) (define added-supply (set-subtract new-supply supply)) @@ -102,8 +113,8 @@ [decrease-handler unexpected-supply-decrease] #:name [name #f] #:meta-level [meta-level 0]) - (define d (make-demand-matcher (compile-projection (prepend-at-meta demand-spec meta-level)) - (compile-projection (prepend-at-meta supply-spec meta-level)) + (define d (make-demand-matcher (prepend-at-meta demand-spec meta-level) + (prepend-at-meta supply-spec meta-level) (lambda (acs . rs) (cons (apply increase-handler rs) acs)) (lambda (acs . rs) (cons (apply decrease-handler rs) acs)))) (spawn #:name name @@ -133,7 +144,8 @@ (match e [(scn new-aggregate) (define projection-results - (map (lambda (p) (trie-project/set new-aggregate (compile-projection p))) projections)) + (map (lambda (p) (trie-project/set #:take (projection-arity p) new-aggregate p)) + projections)) (define maybe-spawn (apply check-and-maybe-spawn-fn new-aggregate projection-results)) @@ -158,8 +170,10 @@ (define (pretty-print-demand-matcher s [p (current-output-port)]) (match-define (demand-matcher demand-spec supply-spec - increase-handler - decrease-handler + _demand-arity + _supply-arity + _increase-handler + _decrease-handler current-demand current-supply) s) diff --git a/prospect-monolithic/examples/chat-no-quit-world-no-nesting.rkt b/prospect-monolithic/examples/chat-no-quit-world-no-nesting.rkt index fc99390..4dde7a9 100644 --- a/prospect-monolithic/examples/chat-no-quit-world-no-nesting.rkt +++ b/prospect-monolithic/examples/chat-no-quit-world-no-nesting.rkt @@ -7,8 +7,8 @@ (define (spawn-session them us) (define user (gensym 'user)) - (define remote-detector (compile-projection (advertise (?! (tcp-channel ? ? ?))))) - (define peer-detector (compile-projection (advertise `(,(?!) says ,?)))) + (define remote-detector (advertise (?! (tcp-channel ? ? ?)))) + (define peer-detector (advertise `(,(?!) says ,?))) (define (send-to-remote fmt . vs) (message (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))) (define (say who fmt . vs) diff --git a/prospect-monolithic/ground.rkt b/prospect-monolithic/ground.rkt index 0efeff9..8eef690 100644 --- a/prospect-monolithic/ground.rkt +++ b/prospect-monolithic/ground.rkt @@ -52,7 +52,7 @@ ;; Projection ;; Used to extract event descriptors and results from subscriptions ;; from the ground VM's contained Network. -(define event-projection (compile-projection (observe (external-event (?!) ?)))) +(define event-projection (observe (external-event (?!) ?))) ;; Interests -> (Listof RacketEvent) ;; Projects out the active event subscriptions from the given interests. @@ -78,7 +78,7 @@ (define (run-ground . boot-actions) (let await-interrupt ((inert? #f) (w (make-network boot-actions)) - (interests (trie-empty))) + (interests trie-empty)) ;; (log-info "GROUND INTERESTS:\n~a" (trie->pretty-string interests)) (if (and inert? (trie-empty? interests)) (begin (log-info "run-ground: Terminating because inert") diff --git a/prospect-monolithic/mux.rkt b/prospect-monolithic/mux.rkt index 727db45..808c169 100644 --- a/prospect-monolithic/mux.rkt +++ b/prospect-monolithic/mux.rkt @@ -16,7 +16,7 @@ (require racket/set) (require racket/match) -(require "../prospect/route.rkt") +(require "../prospect/trie.rkt") (require "scn.rkt") (require "../prospect/trace.rkt") (require "../prospect/tset.rkt") @@ -39,7 +39,7 @@ (define (meta-label? x) (eq? x 'meta)) (define (make-mux) - (mux 0 (trie-empty) (hash))) + (mux 0 trie-empty (hash))) (define (mux-add-stream m initial-scn) (define new-pid (mux-next-pid m)) @@ -48,7 +48,7 @@ initial-scn)) (define (mux-remove-stream m label) - (mux-update-stream m label (scn (trie-empty)))) + (mux-update-stream m label (scn trie-empty))) (define (mux-update-stream m label new-scn) (define old-interests (mux-interests-of m label)) @@ -66,7 +66,7 @@ new-scn ;; unnecessary? aggregate-assertions)) -(define at-meta-everything (pattern->trie #t (at-meta ?))) +(define at-meta-everything (pattern->trie ' (at-meta ?))) (define only-meta (datum-tset 'meta)) (define (echo-cancelled-routing-table m) @@ -74,8 +74,8 @@ at-meta-everything #:combiner (lambda (v1 v2) (if (tset-member? v1 'meta) - only-meta - #f)))) + (trie-success only-meta) + trie-empty)))) (define (compute-scns old-m new-m label s aggregate-assertions) (define old-routing-table (mux-routing-table old-m)) @@ -94,11 +94,9 @@ (define (compute-affected-pids routing-table cover) (trie-match-trie cover - (trie-step routing-table struct:observe) + (trie-step routing-table observe-parenthesis) #:seed datum-tset-empty - #:combiner (lambda (v1 v2 acc) (tset-union v2 acc)) - #:left-short (lambda (v r acc) - (tset-union acc (success-value (trie-step r EOS)))))) + #:combiner (lambda (v1 v2 acc) (tset-union v2 acc)))) (define (mux-route-message m body) (if (trie-lookup (mux-routing-table m) body #f) ;; some other stream has declared body @@ -106,7 +104,7 @@ (tset->list (trie-lookup (mux-routing-table m) (observe body) datum-tset-empty)))) (define (mux-interests-of m label) - (hash-ref (mux-interest-table m) label (trie-empty))) + (hash-ref (mux-interest-table m) label trie-empty)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/prospect-monolithic/scn.rkt b/prospect-monolithic/scn.rkt index 89794f7..1bbc554 100644 --- a/prospect-monolithic/scn.rkt +++ b/prospect-monolithic/scn.rkt @@ -5,6 +5,8 @@ (struct-out observe) (struct-out at-meta) (struct-out advertise) + observe-parenthesis + at-meta-parenthesis lift-scn drop-scn strip-interests @@ -15,7 +17,7 @@ (require racket/set) (require racket/match) -(require "../prospect/route.rkt") +(require "../prospect/trie.rkt") (require "../prospect/tset.rkt") (require "../prospect/pretty.rkt") (module+ test (require rackunit)) @@ -35,21 +37,20 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define at-meta-proj (compile-projection (at-meta (?!)))) +(define observe-parenthesis (open-parenthesis 1 struct:observe)) +(define at-meta-parenthesis (open-parenthesis 1 struct:at-meta)) (define (lift-scn s) - (scn (pattern->trie #t (at-meta (embedded-trie (scn-trie s)))))) + (scn (pattern->trie ' (at-meta (embedded-trie (scn-trie s)))))) (define (drop-interests pi) - (trie-project pi at-meta-proj - #:project-success (lambda (v) #t) - #:combiner (lambda (v1 v2) #t))) + (trie-step pi at-meta-parenthesis)) (define (drop-scn s) (scn (drop-interests (scn-trie s)))) (define (strip-interests g) - (trie-relabel g (lambda (v) #t))) + (trie-relabel g (lambda (v) '))) (define (label-interests g label) (trie-relabel g (lambda (v) label))) @@ -62,6 +63,5 @@ (define (biased-intersection object subject) (trie-intersect object - (trie-step subject struct:observe) - #:combiner (lambda (v1 v2) #t) - #:left-short (lambda (v r) (trie-step r EOS)))) + (trie-step subject observe-parenthesis) + #:combiner (lambda (v1 v2) (trie-success v1)))) diff --git a/prospect/actor.rkt b/prospect/actor.rkt index 7b30848..1ab5a1a 100644 --- a/prospect/actor.rkt +++ b/prospect/actor.rkt @@ -56,7 +56,7 @@ (require (except-in "core.rkt" assert network) (rename-in "core.rkt" [assert core:assert] [network core:network])) -(require "route.rkt") +(require "trie.rkt") (require "mux.rkt") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -152,7 +152,7 @@ (struct link-result (caller-id callee-id values) #:transparent) ;; message ;; Projection for observing LinkActive. -(define link-active-projection (compile-projection (link-active ? (?!)))) +(define link-active-projection (link-active ? (?!))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Producing Instruction side-effects @@ -494,13 +494,13 @@ #,(if maybe-Pred-stx #`(if #,maybe-Pred-stx (compute-new-assertions) - (trie-empty)) + trie-empty) #`(compute-new-assertions))) (and (not (eq? old-assertions new-assertions)) ((extend-pending-patch #,endpoint-index - (patch-seq (patch (trie-empty) old-assertions) - (patch new-assertions (trie-empty)))) + (patch-seq (patch trie-empty old-assertions) + (patch new-assertions trie-empty))) s)))))) (define (analyze-asserted-or-retracted! endpoint-index asserted? outer-expr-stx P-stx I-stxs L-stx) @@ -509,13 +509,15 @@ (add-assertion-maintainer! endpoint-index #'sub pat #f L-stx) (add-event-handler! (lambda (evt-stx) - #`(let ((proj (compile-projection (prepend-at-meta #,proj-stx #,L-stx)))) + #`(let* ((proj (prepend-at-meta #,proj-stx #,L-stx)) + (proj-arity (projection-arity proj))) (lambda (s) (match #,evt-stx [(? #,(if asserted? #'patch/added? #'patch/removed?) p) (sequence-transitions0* s (for/list [(entry (in-set (trie-project/set + #:take proj-arity #,(if asserted? #'(patch-added p) #'(patch-removed p)) diff --git a/prospect/big-bang.rkt b/prospect/big-bang.rkt index 9a345cd..0b2316a 100644 --- a/prospect/big-bang.rkt +++ b/prospect/big-bang.rkt @@ -26,7 +26,7 @@ (require (only-in racket/list flatten)) (require "main.rkt") -(require "route.rkt") +(require "trie.rkt") ;;--------------------------------------------------------------------------- @@ -50,7 +50,7 @@ (struct bb (network windows inbound outbound halted? x y) #:transparent) -(define window-projection (compile-projection (?! (window ? ? ? ? ?)))) +(define window-projection (?! (window ? ? ? ? ?))) (define (inject b es) (interpret-actions (struct-copy bb b [inbound (append (bb-inbound b) @@ -67,9 +67,11 @@ (set-subtract (list->set (bb-windows b)) removed))) (lambda (w1 w2) (< (window-z w1) (window-z w2))))] - [halted? (or (and (bb-halted? b) - (not (trie-lookup (patch-removed p) 'stop #f))) - (trie-lookup (patch-added p) 'stop #f))])) + [halted? (if (or (and (bb-halted? b) + (not (trie-lookup (patch-removed p) 'stop #f))) + (trie-lookup (patch-added p) 'stop #f)) + #t + #f)])) (define (deliver b e) (clean-transition (network-handle-event e (bb-network b)))) diff --git a/prospect/comprehensions.rkt b/prospect/comprehensions.rkt index 9957cae..6e4cdc4 100644 --- a/prospect/comprehensions.rkt +++ b/prospect/comprehensions.rkt @@ -26,7 +26,7 @@ ;; error, using the third argument to describe the pattern being projected. ;; If the resulting trie is finite, return it as a set. (define (project-finite t proj pat) - (define s? (trie-project/set t (compile-projection proj))) + (define s? (trie-project/set #:take (projection-arity proj) t proj)) (unless s? (error "pattern projection created infinite trie:" pat)) s?) @@ -88,7 +88,7 @@ (make-fold for-trie/set set-folder (set)) -(make-fold for-trie/patch patch-seq empty-patch) +(make-fold for-trie/patch patch-seq patch-empty) (define (ret-second a b) b) @@ -105,14 +105,15 @@ (module+ test (require rackunit) - (require "route.rkt") + (require "trie.rkt") (define (make-trie . vs) - (for/fold ([acc (trie-empty)]) + (for/fold ([acc trie-empty]) ([v (in-list vs)]) (trie-union acc (pattern->trie 'a v)))) (struct foo (bar zot) #:prefab) + (struct quasi-cons (car cdr) #:transparent) ;; This test should pass OK, since we're ignoring all the infinite ;; dimensions, and just projecting out a finite one. @@ -141,12 +142,13 @@ #:where (even? x)) (+ x 1)) (set 3 5)) - (check-equal? (for-trie/set ([(cons $x _) (make-trie 1 2 (list 0) - (list 1 2 3) - (cons 'x 'y) - (cons 3 4) - (cons 'a 'b) - "x" 'foo)]) + (check-equal? (for-trie/set ([(quasi-cons $x _) + (make-trie 1 2 (list 0) + (list 1 2 3) + (quasi-cons 'x 'y) + (quasi-cons 3 4) + (quasi-cons 'a 'b) + "x" 'foo)]) x) (set 'x 3 'a)) (check-equal? (for-trie/fold ([acc 0]) @@ -163,9 +165,10 @@ (let-values ([(acc1 acc2) (for-trie/fold ([acc1 0] [acc2 0]) - ([(cons $x $y) (make-trie (cons 1 2) - (cons 3 8) - (cons 9 7))]) + ([(quasi-cons $x $y) + (make-trie (quasi-cons 1 2) + (quasi-cons 3 8) + (quasi-cons 9 7))]) (values (+ acc1 x) (+ acc2 y)))]) (check-equal? acc1 13) @@ -178,24 +181,26 @@ (cons 3 4) (cons 3 5) (cons 3 6))) (let ([p (for-trie/patch ([$x (make-trie 1 2 3 4)]) (retract x))]) - (check-equal? (trie-project/set (patch-removed p) (compile-projection (?!))) + (check-equal? (trie-project/set #:take 1 (patch-removed p) (?!)) (set '(1) '(2) '(3) '(4)))) (check-equal? (for-trie/set ([$x (make-trie 1 2 3)] - [(cons x 3) (make-trie (cons 'x 'y) - (cons 5 5) - (cons 2 4) - (cons 3 3) - (cons 4 3))]) + [(quasi-cons x 3) + (make-trie (quasi-cons 'x 'y) + (quasi-cons 5 5) + (quasi-cons 2 4) + (quasi-cons 3 3) + (quasi-cons 4 3))]) (cons x 4)) (set (cons 3 4))) - (check-equal? (for-trie/set ([(cons $x $x) (make-trie 'a 'b - (cons 'x 'y) - (cons 2 3) - 3 4 - 'x - (cons 1 1) - "abc" - (cons 'x 'x))]) + (check-equal? (for-trie/set ([(quasi-cons $x $x) + (make-trie 'a 'b + (quasi-cons 'x 'y) + (quasi-cons 2 3) + 3 4 + 'x + (quasi-cons 1 1) + "abc" + (quasi-cons 'x 'x))]) x) (set 1 'x)) (check-equal? (for-trie/set ([$x (make-trie 1 2 3)]) diff --git a/prospect/core.rkt b/prospect/core.rkt index ab03fdf..cce2eb3 100644 --- a/prospect/core.rkt +++ b/prospect/core.rkt @@ -14,7 +14,7 @@ (all-from-out "patch.rkt") - ;; imported from route.rkt: + ;; imported from trie.rkt: ? wildcard? ?! @@ -25,7 +25,7 @@ trie-empty? trie-empty projection->pattern - compile-projection + projection-arity trie-project trie-project/set trie-project/set/single @@ -67,7 +67,7 @@ (require racket/match) (require (only-in racket/list flatten)) (require "functional-queue.rkt") -(require "route.rkt") +(require "trie.rkt") (require "patch.rkt") (require "trace.rkt") (require "mux.rkt") @@ -138,20 +138,20 @@ (define (observe-at-meta pattern level) (if (zero? level) - (pattern->trie #t (observe pattern)) + (pattern->trie ' (observe pattern)) (trie-union - (pattern->trie #t (observe (prepend-at-meta pattern level))) - (pattern->trie #t (at-meta (embedded-trie (observe-at-meta pattern (- level 1)))))))) + (pattern->trie ' (observe (prepend-at-meta pattern level))) + (pattern->trie ' (at-meta (embedded-trie (observe-at-meta pattern (- level 1)))))))) (define (assert pattern #:meta-level [level 0]) - (patch (pattern->trie #t (prepend-at-meta pattern level)) (trie-empty))) + (patch (pattern->trie ' (prepend-at-meta pattern level)) trie-empty)) (define (retract pattern #:meta-level [level 0]) - (patch (trie-empty) (pattern->trie #t (prepend-at-meta pattern level)))) + (patch trie-empty (pattern->trie ' (prepend-at-meta pattern level)))) (define (sub pattern #:meta-level [level 0]) - (patch (observe-at-meta pattern level) (trie-empty))) + (patch (observe-at-meta pattern level) trie-empty)) (define (unsub pattern #:meta-level [level 0]) - (patch (trie-empty) (observe-at-meta pattern level))) + (patch trie-empty (observe-at-meta pattern level))) (define (pub pattern #:meta-level [level 0]) (assert (advertise pattern) #:meta-level level)) (define (unpub pattern #:meta-level [level 0]) (retract (advertise pattern) #:meta-level level)) @@ -400,7 +400,7 @@ (define-values (initial-patch remaining-initial-actions) (match initial-actions [(cons (? patch? p) rest) (values p rest)] - [other (values empty-patch other)])) + [other (values patch-empty other)])) (define-values (new-mux new-pid delta delta-aggregate) (mux-add-stream (network-mux w) initial-patch)) (let* ((w (struct-copy network w diff --git a/prospect/demand-matcher.rkt b/prospect/demand-matcher.rkt index cf7a31e..b4debc4 100644 --- a/prospect/demand-matcher.rkt +++ b/prospect/demand-matcher.rkt @@ -20,6 +20,8 @@ ;; exists. (struct demand-matcher (demand-spec ;; CompiledProjection supply-spec ;; CompiledProjection + demand-spec-arity ;; Natural + supply-spec-arity ;; Natural increase-handler ;; ChangeHandler decrease-handler ;; ChangeHandler current-demand ;; (Setof (Listof Any)) @@ -42,6 +44,8 @@ (define (make-demand-matcher demand-spec supply-spec increase-handler decrease-handler) (demand-matcher demand-spec supply-spec + (projection-arity demand-spec) + (projection-arity supply-spec) increase-handler decrease-handler (set) @@ -52,9 +56,18 @@ ;; demand increase and decrease sets. Calls ChangeHandlers in response ;; to increased unsatisfied demand and decreased demanded supply. (define (demand-matcher-update d s p) - (match-define (demand-matcher demand-spec supply-spec inc-h dec-h demand supply) d) - (define-values (added-demand removed-demand) (patch-project/set p demand-spec)) - (define-values (added-supply removed-supply) (patch-project/set p supply-spec)) + (match-define (demand-matcher demand-spec + supply-spec + demand-arity + supply-arity + inc-h + dec-h + demand + supply) d) + (define-values (added-demand removed-demand) + (patch-project/set #:take demand-arity p demand-spec)) + (define-values (added-supply removed-supply) + (patch-project/set #:take supply-arity p supply-spec)) (when (not added-demand) (error 'demand-matcher "Wildcard demand of ~v:\n~a" demand-spec @@ -98,8 +111,8 @@ [decrease-handler unexpected-supply-decrease] #:name [name #f] #:meta-level [meta-level 0]) - (define d (make-demand-matcher (compile-projection (prepend-at-meta demand-spec meta-level)) - (compile-projection (prepend-at-meta supply-spec meta-level)) + (define d (make-demand-matcher (prepend-at-meta demand-spec meta-level) + (prepend-at-meta supply-spec meta-level) (lambda (acs . rs) (cons (apply increase-handler rs) acs)) (lambda (acs . rs) (cons (apply decrease-handler rs) acs)))) (spawn #:name name @@ -130,7 +143,8 @@ [(? patch? p) (define new-aggregate (update-interests current-aggregate p)) (define projection-results - (map (lambda (p) (trie-project/set new-aggregate (compile-projection p))) projections)) + (map (lambda (p) (trie-project/set #:take (projection-arity p) new-aggregate p)) + projections)) (define maybe-spawn (apply check-and-maybe-spawn-fn new-aggregate projection-results)) @@ -144,8 +158,8 @@ (when timeout-msec (message (set-timer timer-id timeout-msec 'relative))) (spawn #:name name on-claim-handler - (trie-empty) - (patch-seq (patch base-interests (trie-empty)) + trie-empty + (patch-seq (patch base-interests trie-empty) (patch-seq* (map (lambda (p) (sub projection->pattern)) projections)) (sub (timer-expired timer-id ?)))))) @@ -154,8 +168,10 @@ (define (pretty-print-demand-matcher s [p (current-output-port)]) (match-define (demand-matcher demand-spec supply-spec - increase-handler - decrease-handler + _demand-arity + _supply-arity + _increase-handler + _decrease-handler current-demand current-supply) s) diff --git a/prospect/drivers/timer.rkt b/prospect/drivers/timer.rkt index ea0433e..c3ce5cf 100644 --- a/prospect/drivers/timer.rkt +++ b/prospect/drivers/timer.rkt @@ -19,7 +19,7 @@ (struct set-timer (label msecs kind) #:prefab) (struct timer-expired (label msecs) #:prefab) -(define expiry-projection (compile-projection (at-meta (?! (timer-expired ? ?))))) +(define expiry-projection (at-meta (?! (timer-expired ? ?)))) (define (spawn-timer-driver) (define control-ch (make-channel)) @@ -56,7 +56,7 @@ (define-values (new-count actions-rev interrupt-clearing-patch) (for/fold [(count count) (actions-rev '()) - (interrupt-clearing-patch empty-patch)] + (interrupt-clearing-patch patch-empty)] [(expiry (trie-project/set/single added expiry-projection))] (values (- count 1) (cons (message expiry) actions-rev) @@ -84,7 +84,7 @@ [t (handle-evt (timer-evt (pending-timer-deadline t)) (lambda (now) (send-ground-patch - (for/fold [(interrupt-asserting-patch empty-patch)] + (for/fold [(interrupt-asserting-patch patch-empty)] [(expiry (fire-timers! heap now))] (patch-seq interrupt-asserting-patch (assert expiry)))) (loop)))]) diff --git a/prospect/endpoint.rkt b/prospect/endpoint.rkt index 4412828..b96b5d9 100644 --- a/prospect/endpoint.rkt +++ b/prospect/endpoint.rkt @@ -15,7 +15,7 @@ (require racket/set) (require racket/match) (require (only-in racket/list flatten)) -(require "route.rkt") +(require "trie.rkt") (require "patch.rkt") (require "core.rkt") (require "mux.rkt") @@ -54,7 +54,7 @@ (define (boot-endpoint-group initial-state initial-actions) (define-values (final-cumulative-patch final-actions final-g) - (interpret-endpoint-actions empty-patch + (interpret-endpoint-actions patch-empty '() (make-endpoint-group initial-state) -1 @@ -88,7 +88,7 @@ (define (sequence-handlers g tasks) (let/ec return (define-values (final-cumulative-patch final-actions final-g idle?) - (for/fold ([cumulative-patch empty-patch] + (for/fold ([cumulative-patch patch-empty] [actions '()] [g g] [idle? #t]) @@ -125,14 +125,14 @@ (match endpoint-action [(or (? message?) (? spawn?)) - (values empty-patch + (values patch-empty (cons (incorporate-cumulative-patch actions cumulative-patch) endpoint-action) g)] [(? patch? p0) (interpret-endpoint-patch cumulative-patch actions g eid p0)] [(add-endpoint function) (define-values (new-mux new-eid _p _p-aggregate) - (mux-add-stream (endpoint-group-mux g) empty-patch)) + (mux-add-stream (endpoint-group-mux g) patch-empty)) (define-values (new-ep initial-transition) (function new-eid (endpoint-group-state g))) (interpret-endpoint-actions cumulative-patch actions @@ -152,7 +152,7 @@ [endpoints (hash-remove (endpoint-group-endpoints g) eid)]) eid - (patch (trie-empty) (pattern->trie #t ?)))] + (patch trie-empty (pattern->trie ' ?)))] [(as-endpoint other-eid inner-endpoint-action) (interpret-endpoint-actions cumulative-patch actions g other-eid inner-endpoint-action)])) diff --git a/prospect/examples/big-bang.rkt b/prospect/examples/big-bang.rkt index e62259c..1d338de 100644 --- a/prospect/examples/big-bang.rkt +++ b/prospect/examples/big-bang.rkt @@ -56,9 +56,7 @@ (match e [(? patch? p) (define-values (in out) - (patch-project/set/single p - (compile-projection - (at-meta (?! (active-window ?)))))) + (patch-project/set/single p (at-meta (?! (active-window ?))))) (transition s (update-window 'active-window-label 300 0 (text (format "~v" in) 22 "black")))] [_ #f])) diff --git a/prospect/examples/chat-no-quit-world-no-nesting.rkt b/prospect/examples/chat-no-quit-world-no-nesting.rkt index f381e91..ed7c0b6 100644 --- a/prospect/examples/chat-no-quit-world-no-nesting.rkt +++ b/prospect/examples/chat-no-quit-world-no-nesting.rkt @@ -6,8 +6,8 @@ (define (spawn-session them us) (define user (gensym 'user)) - (define remote-detector (compile-projection (advertise (?! (tcp-channel ? ? ?))))) - (define peer-detector (compile-projection (advertise `(,(?!) says ,?)))) + (define remote-detector (advertise (?! (tcp-channel ? ? ?)))) + (define peer-detector (advertise `(,(?!) says ,?))) (define (send-to-remote fmt . vs) (message (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))) (define (say who fmt . vs) diff --git a/prospect/examples/chat-no-quit-world.rkt b/prospect/examples/chat-no-quit-world.rkt index b20d02b..acba332 100644 --- a/prospect/examples/chat-no-quit-world.rkt +++ b/prospect/examples/chat-no-quit-world.rkt @@ -6,8 +6,8 @@ (define (spawn-session them us) (define user (gensym 'user)) - (define remote-detector (compile-projection (at-meta (?!)))) - (define peer-detector (compile-projection (advertise `(,(?!) says ,?)))) + (define remote-detector (at-meta (?!))) + (define peer-detector (advertise `(,(?!) says ,?))) (define (send-to-remote fmt . vs) (message (at-meta (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))) (define (say who fmt . vs) diff --git a/prospect/examples/chat-simplified-internals.rkt b/prospect/examples/chat-simplified-internals.rkt index 29e1690..cd30953 100644 --- a/prospect/examples/chat-simplified-internals.rkt +++ b/prospect/examples/chat-simplified-internals.rkt @@ -48,10 +48,9 @@ [(message (says who what)) (say who "says: ~a" what)] [(? patch? p) - (if (patch/removed? (patch-project p (compile-projection (tcp-remote-open id)))) + (if (patch/removed? (patch-project p (tcp-remote-open id))) (quit) - (let-values (((arrived departed) - (patch-project/set/single p (compile-projection (present (?!)))))) + (let-values (((arrived departed) (patch-project/set/single p (present (?!))))) (list (for/list [(who arrived)] (say who "arrived.")) (for/list [(who departed)] (say who "departed.")))))] [#f #f])) diff --git a/prospect/examples/chat.rkt b/prospect/examples/chat.rkt index e820704..858f5f9 100644 --- a/prospect/examples/chat.rkt +++ b/prospect/examples/chat.rkt @@ -6,8 +6,8 @@ (define (spawn-session them us) (define user (gensym 'user)) - (define remote-detector (compile-projection (at-meta (?!)))) - (define peer-detector (compile-projection (advertise `(,(?!) says ,?)))) + (define remote-detector (at-meta (?!))) + (define peer-detector (advertise `(,(?!) says ,?))) (define (send-to-remote fmt . vs) (message (at-meta (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))) (define (say who fmt . vs) diff --git a/prospect/examples/durable-key-value-store.rkt b/prospect/examples/durable-key-value-store.rkt index a8c7c51..8852ac4 100644 --- a/prospect/examples/durable-key-value-store.rkt +++ b/prospect/examples/durable-key-value-store.rkt @@ -21,8 +21,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define observation-projector (compile-projection (observe (binding (?!) ? ? ?)))) -(define update-projector (compile-projection (?! (update ? ? ? ?)))) +(define observation-projector (observe (binding (?!) ? ? ?))) +(define update-projector (?! (update ? ? ? ?))) (struct db-state (epoch directory observed-keys) #:transparent) @@ -99,7 +99,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define binding-projector (compile-projection (?! (binding ? ? ? ?)))) +(define binding-projector (?! (binding ? ? ? ?))) (define (async-update key epoch version value on-complete on-conflict) (spawn (lambda (e s) diff --git a/prospect/examples/example-meta-echo.rkt b/prospect/examples/example-meta-echo.rkt index 2c05e4d..0532b52 100644 --- a/prospect/examples/example-meta-echo.rkt +++ b/prospect/examples/example-meta-echo.rkt @@ -1,7 +1,7 @@ #lang prospect ;; Test case for a historical bug in Syndicate. ;; -;; When the bug existed, this program receiveed four SCN events in +;; When the bug existed, this program received four SCN events in ;; total, whereas it should receive only two. ;; ;; While metamessages were "echo cancelled", and receivers only ever diff --git a/prospect/examples/example-wildcard-assertion-1.rkt b/prospect/examples/example-wildcard-assertion-1.rkt index 94e3a5f..1bd3bf1 100644 --- a/prospect/examples/example-wildcard-assertion-1.rkt +++ b/prospect/examples/example-wildcard-assertion-1.rkt @@ -14,6 +14,6 @@ (if (patch? e) (transition (update-interests s e) '()) #f)) - (trie-empty) + trie-empty (patch-seq (assert ?) (retract (at-meta ?)))) diff --git a/prospect/examples/example-wildcard-assertion-2.rkt b/prospect/examples/example-wildcard-assertion-2.rkt index 49ea2f5..fbaae20 100644 --- a/prospect/examples/example-wildcard-assertion-2.rkt +++ b/prospect/examples/example-wildcard-assertion-2.rkt @@ -16,7 +16,7 @@ (if (patch? e) (transition (update-interests s e) '()) #f)) - (trie-empty) + trie-empty (sub ?)) (spawn (lambda (e s) diff --git a/prospect/examples/forward-chaining.rkt b/prospect/examples/forward-chaining.rkt index cef1011..17e70b4 100644 --- a/prospect/examples/forward-chaining.rkt +++ b/prospect/examples/forward-chaining.rkt @@ -1,7 +1,7 @@ #lang prospect (require racket/set) -(require "../route.rkt") +(require "../trie.rkt") (require "../demand-matcher.rkt") (require "../drivers/timer.rkt") @@ -10,8 +10,7 @@ (spawn (lambda (e old-count) (match e [(? patch?) - (define-values (in out) - (patch-project/set e (compile-projection `(parent ,(?!) ,(?!))))) + (define-values (in out) (patch-project/set #:take 2 e `(parent ,(?!) ,(?!)))) (define new-count (+ old-count (set-count in) (- (set-count out)))) (printf "New parent-record count: ~v\n" new-count) (transition new-count @@ -29,7 +28,7 @@ [(? patch/removed?) (printf "Retracting ~v because dependencies ~v vanished\n" record - (set->list (trie-project/set (patch-removed e) (compile-projection (?!))))) + (set->list (trie-project/set/single (patch-removed e) (?!)))) (quit)] [(message `(retract ,(== record))) (printf "Retracting ~v because we were told to explicitly\n" record) @@ -48,9 +47,9 @@ (match e [(? patch?) (transition s - (for/list [(AB (trie-project/set - (patch-added e) - (compile-projection `(parent ,(?!) ,(?!)))))] + (for/list [(AB (trie-project/set #:take 2 + (patch-added e) + `(parent ,(?!) ,(?!))))] (match-define (list A B) AB) (insert-record `(ancestor ,A ,B) `(parent ,A ,B))))] @@ -62,30 +61,28 @@ (match e [(? patch?) (transition s - (for/list [(AC (trie-project/set - (patch-added e) - (compile-projection `(parent ,(?!) ,(?!)))))] + (for/list [(AC (trie-project/set #:take 2 + (patch-added e) + `(parent ,(?!) ,(?!))))] (match-define (list A C) AC) (printf "Inductive step for ~v asserted\n" `(parent ,A ,C)) (spawn (lambda (e s) (define removed-parents (and (patch? e) - (trie-project (patch-removed e) - (compile-projection - `(parent ,(?!) ,(?!)))))) + (trie-project (patch-removed e) `(parent ,(?!) ,(?!))))) (if (trie-non-empty? removed-parents) (begin (printf "Inductive step for ~v retracted because of removal ~v\n" `(parent ,A ,C) - (trie-key-set removed-parents)) + (trie-key-set #:take 2 removed-parents)) (quit)) (and (patch? e) (transition s (for/list [(CB (trie-project/set + #:take 2 (patch-added e) - (compile-projection - `(ancestor ,(?!) ,(?!)))))] + `(ancestor ,(?!) ,(?!))))] (match-define (list _ B) CB) (insert-record `(ancestor ,A ,B) `(parent ,A ,C) @@ -112,9 +109,8 @@ ;; [(? patch/removed?) (quit)] ;; [(? patch?) ;; (define new-facts (trie-union old-facts (patch-added e))) -;; (define triples (trie-project/set new-facts -;; (compile-projection -;; `(,(?!) ,(?!) ,(?!))))) +;; (define triples (trie-project/set #:take 3 new-facts +;; `(,(?!) ,(?!) ,(?!)))) ;; (printf "Learned new facts: ~v\n" triples) ;; (transition new-facts ;; (when (or (set-member? triples `(parent ,A ,B)) @@ -127,7 +123,7 @@ ;; `(ancestor ,A ,B)) ;; (assert `(ancestor ,A ,B))))] ;; [_ #f])) -;; (trie-empty) +;; trie-empty ;; (patch-seq ;; (sub `(parent ,A ,B)) ;; (sub `(parent ,A ,?)) diff --git a/prospect/examples/key-value-store.rkt b/prospect/examples/key-value-store.rkt index 4abf25f..af8657f 100644 --- a/prospect/examples/key-value-store.rkt +++ b/prospect/examples/key-value-store.rkt @@ -20,8 +20,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define observation-projector (compile-projection (observe (binding (?!) ? ? ?)))) -(define update-projector (compile-projection (?! (update ? ? ? ?)))) +(define observation-projector (observe (binding (?!) ? ? ?))) +(define update-projector (?! (update ? ? ? ?))) (struct db-state (epoch bindings observed-keys) #:transparent) @@ -77,7 +77,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define binding-projector (compile-projection (?! (binding ? ? ? ?)))) +(define binding-projector (?! (binding ? ? ? ?))) (define (async-update key epoch version value on-complete on-conflict) (spawn (lambda (e s) diff --git a/prospect/ground.rkt b/prospect/ground.rkt index ade1926..2832413 100644 --- a/prospect/ground.rkt +++ b/prospect/ground.rkt @@ -52,7 +52,7 @@ ;; Projection ;; Used to extract event descriptors and results from subscriptions ;; from the ground VM's contained Network. -(define event-projection (compile-projection (observe (external-event (?!) ?)))) +(define event-projection (observe (external-event (?!) ?))) ;; Interests -> (Listof RacketEvent) ;; Projects out the active event subscriptions from the given interests. @@ -78,7 +78,7 @@ (define (run-ground . boot-actions) (let await-interrupt ((inert? #f) (w (make-network boot-actions)) - (interests (trie-empty))) + (interests trie-empty)) ;; (log-info "GROUND INTERESTS:\n~a" (trie->pretty-string interests)) (if (and inert? (trie-empty? interests)) (begin (log-info "run-ground: Terminating because inert") diff --git a/prospect/mux.rkt b/prospect/mux.rkt index a4d6ddd..a4802e2 100644 --- a/prospect/mux.rkt +++ b/prospect/mux.rkt @@ -15,7 +15,7 @@ (require racket/set) (require racket/match) -(require "route.rkt") +(require "trie.rkt") (require "patch.rkt") (require "trace.rkt") (require "tset.rkt") @@ -38,7 +38,7 @@ (define (meta-label? x) (eq? x 'meta)) (define (make-mux) - (mux 0 (trie-empty) (hash))) + (mux 0 trie-empty (hash))) (define (mux-add-stream m initial-patch) (define new-pid (mux-next-pid m)) @@ -47,7 +47,7 @@ initial-patch)) (define (mux-remove-stream m label) - (mux-update-stream m label (patch (trie-empty) (pattern->trie #t ?)))) + (mux-update-stream m label (patch trie-empty (pattern->trie ' ?)))) (define (mux-update-stream m label delta-orig) (define old-interests (mux-interests-of m label)) @@ -67,22 +67,22 @@ delta delta-aggregate)) -(define at-meta-everything (pattern->trie #t (at-meta ?))) +(define at-meta-everything (pattern->trie ' (at-meta ?))) (define (echo-cancelled-trie t) (trie-subtract t at-meta-everything #:combiner (lambda (v1 v2) (if (tset-member? v1 'meta) - only-meta-tset - #f)))) + (trie-success only-meta-tset) + trie-empty)))) (define (compute-patches old-m new-m label delta delta-aggregate) (define delta-aggregate/no-echo (if (meta-label? label) delta - (patch (trie-prune-branch (patch-added delta-aggregate) struct:at-meta) - (trie-prune-branch (patch-removed delta-aggregate) struct:at-meta)))) + (patch (trie-prune-branch (patch-added delta-aggregate) at-meta-parenthesis) + (trie-prune-branch (patch-removed delta-aggregate) at-meta-parenthesis)))) (define old-routing-table (mux-routing-table old-m)) (define new-routing-table (mux-routing-table new-m)) (define affected-pids @@ -110,11 +110,9 @@ (define (compute-affected-pids routing-table delta) (define cover (trie-union (patch-added delta) (patch-removed delta))) (trie-match-trie cover - (trie-step routing-table struct:observe) + (trie-step routing-table observe-parenthesis) #:seed datum-tset-empty - #:combiner (lambda (v1 v2 acc) (tset-union v2 acc)) - #:left-short (lambda (v r acc) - (tset-union acc (success-value (trie-step r EOS)))))) + #:combiner (lambda (v1 v2 acc) (tset-union v2 acc)))) (define (mux-route-message m body) (if (trie-lookup (mux-routing-table m) body #f) ;; some other stream has declared body @@ -122,7 +120,7 @@ (tset->list (trie-lookup (mux-routing-table m) (observe body) datum-tset-empty)))) (define (mux-interests-of m label) - (hash-ref (mux-interest-table m) label (trie-empty))) + (hash-ref (mux-interest-table m) label trie-empty)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/prospect/patch.rkt b/prospect/patch.rkt index e1e871a..e5e5e7b 100644 --- a/prospect/patch.rkt +++ b/prospect/patch.rkt @@ -5,7 +5,9 @@ (struct-out observe) (struct-out at-meta) (struct-out advertise) - empty-patch + observe-parenthesis + at-meta-parenthesis + patch-empty patch-empty? patch-non-empty? patch/added? @@ -39,7 +41,7 @@ (require racket/set) (require racket/match) -(require "route.rkt") +(require "trie.rkt") (require "tset.rkt") (require "pretty.rkt") (module+ test (require rackunit)) @@ -58,11 +60,12 @@ (struct at-meta (claim) #:prefab) (struct advertise (claim) #:prefab) -(define empty-patch (patch (trie-empty) (trie-empty))) +(define patch-empty (patch trie-empty trie-empty)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define at-meta-proj (compile-projection (at-meta (?!)))) +(define observe-parenthesis (open-parenthesis 1 struct:observe)) +(define at-meta-parenthesis (open-parenthesis 1 struct:at-meta)) (define (patch-empty? p) (and (patch? p) @@ -79,13 +82,11 @@ (define (lift-patch p) (match-define (patch in out) p) - (patch (pattern->trie #t (at-meta (embedded-trie in))) - (pattern->trie #t (at-meta (embedded-trie out))))) + (patch (pattern->trie ' (at-meta (embedded-trie in))) + (pattern->trie ' (at-meta (embedded-trie out))))) (define (drop-interests pi) - (trie-project pi at-meta-proj - #:project-success (lambda (v) #t) - #:combiner (lambda (v1 v2) #t))) + (trie-step pi at-meta-parenthesis)) (define (drop-patch p) (match-define (patch in out) p) @@ -93,7 +94,7 @@ (drop-interests out))) (define (strip-interests g) - (trie-relabel g (lambda (v) #t))) + (trie-relabel g (lambda (v) '))) (define (label-interests g label) (trie-relabel g (lambda (v) label))) @@ -114,8 +115,8 @@ ;; arguments. (define (limit-patch p bound) (match-define (patch in out) p) - (patch (trie-subtract in bound #:combiner (lambda (v1 v2) #f)) - (trie-intersect out bound #:combiner (lambda (v1 v2) v1)))) + (patch (trie-subtract in bound #:combiner (lambda (v1 v2) trie-empty)) + (trie-intersect out bound #:combiner (lambda (v1 v2) (trie-success v1))))) ;; Like limit-patch, but for use when the precise bound for p's label ;; isn't known (such as when a process terminates with remaining @@ -171,8 +172,8 @@ ;; keep the point in the case that the only interest present is ;; `'meta`-labeled interest. (if (and remove-meta? (eq? v2 only-meta-tset)) ;; N.B. relies on canonicity of v2 ! - v1 - #f)) + (trie-success v1) + trie-empty)) (define (rem-combiner v1 v2) ;; Keep only points where `p` would remove, where `label` interest ;; is present, and where no non-`label` interest is present. We @@ -186,12 +187,15 @@ ;; case), or when exactly `label` and `'meta` interest exists, and ;; in no other case. (if (= (tset-count v2) 1) - v1 ;; only `label` interest (previously established) exists here. + (trie-success v1) ;; only `label` interest (previously established) exists here. (if (and remove-meta? (= (tset-count v2) 2) (tset-member? v2 'meta)) - v1 ;; remove-meta? is true, and exactly `label` and `'meta` interest exists here. - #f))) ;; other interest exists here, so we should discard this removed-point. + (trie-success v1) + ;; ^ remove-meta? is true, and exactly `label` and `'meta` interest exists here. + trie-empty + ;; ^ other interest exists here, so we should discard this removed-point. + ))) (patch (trie-subtract (patch-added p) base #:combiner add-combiner) (trie-subtract (patch-removed p) base #:combiner rem-combiner))) @@ -203,8 +207,8 @@ ;; Like apply-patch, but for use by Tries leading to True. (define (update-interests base p) (match-define (patch in out) p) - (trie-union (trie-subtract base out #:combiner (lambda (v1 v2) #f)) in - #:combiner (lambda (v1 v2) #t))) + (trie-union (trie-subtract base out #:combiner (lambda (v1 v2) trie-empty)) in + #:combiner (lambda (v1 v2) (trie-success ')))) (define (unapply-patch base p) (match-define (patch in out) p) @@ -216,14 +220,14 @@ (match-define (patch in1 out1) p1) (match-define (patch in2 out2) p2) (patch (update-interests in1 p2) - (trie-union (trie-subtract out1 in2 #:combiner (lambda (v1 v2) #f)) out2 - #:combiner (lambda (v1 v2) #t)))) + (trie-union (trie-subtract out1 in2 #:combiner (lambda (v1 v2) trie-empty)) out2 + #:combiner (lambda (v1 v2) (trie-success '))))) (define (patch-seq . patches) (patch-seq* patches)) (define (patch-seq* patches) (match patches - ['() empty-patch] + ['() patch-empty] [(cons p rest) (compose-patch (patch-seq* rest) p)])) (define (compute-patch old-base new-base) @@ -232,9 +236,8 @@ (define (biased-intersection object subject) (trie-intersect object - (trie-step subject struct:observe) - #:combiner (lambda (v1 v2) #t) - #:left-short (lambda (v r) (trie-step r EOS)))) + (trie-step subject observe-parenthesis) + #:combiner (lambda (v1 v2) (trie-success v1)))) (define (view-patch p interests) (patch (biased-intersection (patch-added p) interests) @@ -248,9 +251,10 @@ (match-define (patch in out) p) (patch (trie-project in spec) (trie-project out spec))) -(define (patch-project/set p spec) +(define (patch-project/set p spec #:take take-count) (match-define (patch in out) p) - (values (trie-project/set in spec) (trie-project/set out spec))) + (values (trie-project/set #:take take-count in spec) + (trie-project/set #:take take-count out spec))) (define (patch-project/set/single p spec) (match-define (patch in out) p) @@ -269,7 +273,7 @@ (module+ test (define (set->trie label xs) - (for/fold [(acc (trie-empty))] [(x (in-set xs))] + (for/fold [(acc trie-empty)] [(x (in-set xs))] (trie-union acc (pattern->trie label x)))) ;; Retains only entries in R labelled with any subset of the labels in label-set. @@ -282,7 +286,7 @@ (define (sanity-check-examples) (define SP (tset 'P)) - (define m0 (trie-empty)) + (define m0 trie-empty) (define ma (pattern->trie SP 'a)) (define mb (pattern->trie SP 'b)) (define mc (pattern->trie SP 'c)) @@ -427,7 +431,7 @@ (let* ((ma (set->trie (tset 'a) (set 1))) (mb (set->trie (tset 'b) (set 1))) (mmeta (set->trie (tset 'meta) (set 1))) - (R0 (trie-empty)) + (R0 trie-empty) (R1 mmeta) (R2 mb) (R3 (trie-union mb mmeta)) @@ -435,9 +439,9 @@ (R5 (trie-union ma mmeta)) (R6 (trie-union ma mb)) (R7 (trie-union (trie-union ma mb) mmeta)) - (p0 empty-patch) - (p+ (patch (set->trie (tset 'a) (set 1)) (trie-empty))) - (p- (patch (trie-empty) (set->trie (tset 'a) (set 1))))) + (p0 patch-empty) + (p+ (patch (set->trie (tset 'a) (set 1)) trie-empty)) + (p- (patch trie-empty (set->trie (tset 'a) (set 1))))) (check-equal? (compute-aggregate-patch p0 'a R0) p0) (check-equal? (compute-aggregate-patch p0 'a R1) p0) (check-equal? (compute-aggregate-patch p0 'a R2) p0) @@ -472,31 +476,23 @@ (check-equal? (compute-aggregate-patch p- 'a R7 #:remove-meta? #t) p0) ) - (let ((m1 (set->trie #t (set 1 2))) + (let ((m1 (set->trie ' (set 1 2))) (m2 (set->trie (tset 'a) (set 1 2))) - (p1 (patch (set->trie #t (set 2 3)) (trie-empty))) - (p2 (patch (set->trie (tset 'a) (set 2 3)) (trie-empty)))) - (check-equal? (limit-patch p1 m1) (patch (set->trie #t (set 3)) (trie-empty))) - ;; This is false because the resulting patch has tset labelling: - (check-false (equal? (limit-patch p2 m1) - (patch (set->trie #t (set 3)) (trie-empty)))) - (check-equal? (limit-patch p1 m2) - (patch (set->trie #t (set 3)) (trie-empty))) - (check-equal? (limit-patch p2 m2) - (patch (set->trie (tset 'a) (set 3)) (trie-empty))) + (p1 (patch (set->trie ' (set 2 3)) trie-empty)) + (p2 (patch (set->trie (tset 'a) (set 2 3)) trie-empty))) + (check-equal? (limit-patch p1 m1) (patch (set->trie ' (set 3)) trie-empty)) + (check-equal? (limit-patch p1 m2) (patch (set->trie ' (set 3)) trie-empty)) + (check-equal? (limit-patch p2 m1) (patch (set->trie (tset 'a) (set 3)) trie-empty)) + (check-equal? (limit-patch p2 m2) (patch (set->trie (tset 'a) (set 3)) trie-empty)) ) - (let ((m1 (set->trie #t (set 1 2))) + (let ((m1 (set->trie ' (set 1 2))) (m2 (set->trie (tset 'a) (set 1 2))) - (p1 (patch (trie-empty) (set->trie #t (set 2 3)))) - (p2 (patch (trie-empty) (set->trie (tset 'a) (set 2 3))))) - (check-equal? (limit-patch p1 m1) (patch (trie-empty) (set->trie #t (set 2)))) - ;; This is false because the resulting patch has tset labelling: - (check-false (equal? (limit-patch p2 m1) - (patch (trie-empty) (set->trie #t (set 2))))) - (check-equal? (limit-patch p1 m2) - (patch (trie-empty) (set->trie #t (set 2)))) - (check-equal? (limit-patch p2 m2) - (patch (trie-empty) (set->trie (tset 'a) (set 2)))) + (p1 (patch trie-empty (set->trie ' (set 2 3)))) + (p2 (patch trie-empty (set->trie (tset 'a) (set 2 3))))) + (check-equal? (limit-patch p1 m1) (patch trie-empty (set->trie ' (set 2)))) + (check-equal? (limit-patch p1 m2) (patch trie-empty (set->trie ' (set 2)))) + (check-equal? (limit-patch p2 m1) (patch trie-empty (set->trie (tset 'a) (set 2)))) + (check-equal? (limit-patch p2 m2) (patch trie-empty (set->trie (tset 'a) (set 2)))) ) ) diff --git a/prospect/pretty.rkt b/prospect/pretty.rkt index f50cb19..ada715d 100644 --- a/prospect/pretty.rkt +++ b/prospect/pretty.rkt @@ -13,7 +13,7 @@ (require racket/pretty) (require racket/exn) (require (only-in racket/string string-join string-split)) -(require "route.rkt") +(require "trie.rkt") (define-generics prospect-pretty-printable (prospect-pretty-print prospect-pretty-printable [port]) diff --git a/prospect/route.rkt b/prospect/route.rkt deleted file mode 100644 index 5714af1..0000000 --- a/prospect/route.rkt +++ /dev/null @@ -1,1656 +0,0 @@ -#lang racket/base -;; Implements a nested-word-like automaton mapping sets of messages to sets of other values. -;; A kind of "regular-expression"-keyed multimap. - -;; TODO: More global purpose statement. -;; TODO: Some examples showing the idea(s). - -;; TODO: rename to trie.rkt or similar. -;; TODO: Ontology - -;; TODO: (generally) interpretations for data definitions - -(provide ;; Patterns and Projections - ? - wildcard? - ?! - (struct-out capture) - (struct-out embedded-trie) - - trie? ;; expensive; see implementation - trie-empty - trie-empty? - trie-non-empty? - pattern->trie - pattern->trie* - trie-union - trie-intersect - empty-tset-guard - trie-subtract-combiner - trie-subtract - trie-lookup - trie-match-trie - trie-append - trie-relabel - trie-prune-branch - - SOL - SOV - ILM - EOS - trie-step - success? - success-value - - ;; Projections - compile-projection - compile-projection* - projection->pattern - trie-project - trie-key-set - trie-key-set/single - trie-project/set - trie-project/set/single - project-assertions ;; composition of trie-project/set/single with compile-projection - - ;; Printing and Serialization - pretty-print-trie - trie->abstract-graph - abstract-graph->dot - trie->dot - trie->pretty-string - trie->jsexpr - jsexpr->trie) - -(require racket/set) -(require racket/match) -(require (only-in racket/port call-with-output-string with-output-to-string)) -(require (only-in racket/class object?)) -(require "canonicalize.rkt") -(require "treap.rkt") -(require "tset.rkt") -(require "hash-order.rkt") - -(require rackunit) - -;; Constructs a structure type and a singleton instance of it. -(define-syntax-rule (define-singleton-struct singleton-name struct-name print-representation) - (begin - (struct struct-name () - #:transparent - #:property prop:custom-write - (lambda (v port mode) (display print-representation port))) - (define singleton-name (struct-name)))) - -;; A Trie is either -;; - #f, indicating no further matches possible -;; - (success Any), representing a successful match (if the end of -;; the input has been reached) -;; - (Treap (U Sigma Wildcard) Trie), {TODO} -;; TODO::: reimplement to use (ordinary-state (Option Trie) (Treap Sigma Trie)), {TODO} -;; - (wildcard-sequence Trie), {TODO} -;; If, in a treap trie, a wild key is present, it is intended -;; to catch all and ONLY those keys not otherwise present in the -;; table. -;; INVARIANT: if a key is present in a treap, then the -;; corresponding value MUST NOT be equal to the wildcard -;; continuation, bearing in mind that -;; - if the wildcard is absent, it is implicitly #f; -;; - (key-open?) keys imply rwildseq of the wild continuation -;; - (key-close?) keys imply runwildseq of the wild continuation -;; INVARIANT: success only appears right at the end. Never in the middle. Never unbalanced parens. TODO -;; TODO as part of this: figure out whether we can get rid of the seemingly mandatory EOS-success -;; pattern that always shows up -(struct success (value) #:transparent) -(struct wildcard-sequence (trie) #:transparent) - -;; A Sigma is, roughly, a token in a value being matched. It is one of: -;; - a struct-type, signifying the start of a struct. -;; - SOL, signifying the start of a list. -;; - SOV, signifying the start of a vector. -;; - ILM, signifying the transition into the cdr position of a pair -;; - EOS, signifying the notional close-paren at the end of a compound. -;; - any other value, representing itself. -;; N.B. treaps cannot be Sigmas at present. -(define-singleton-struct SOL start-of-list "<") -(define-singleton-struct SOV start-of-vector "") - -;; A Pattern is an atom, the special wildcard value (?), an -;; (embedded-trie Trie), or a Racket compound (struct, pair, or -;; vector) containing Patterns. -(define-singleton-struct ? wildcard "★") ;; alternative printing: ¿ -(struct embedded-trie (trie) #:transparent) - -;; A Projection is an atom, the special wildcard value (?), a (capture -;; Pattern), or a Racket compound (struct, pair, or vector) containing -;; Projections. A Projection is much like a Pattern, but may include -;; captures, and may not include embedded tries. -;; -;; When projecting a trie, the capturing wildcard can be used. -(struct capture (pattern) #:transparent) - -;; [Pattern] -> Projection -;; Construct a capture with default pattern of wildcard. -(define (?! [pattern ?]) (capture pattern)) - -;; A CompiledProjection is a (Listof (U Sigma ? SOC EOC)). Compiled -;; projections include start-of-capture and end-of-capture elements. -(define-singleton-struct SOC start-of-capture "{{") -(define-singleton-struct EOC end-of-capture "}}") - -;; Any -> Boolean -;; Predicate recognising Tries. Expensive! -(define (trie? x) - (or (eq? x #f) - (success? x) - (wildcard-sequence? x) - (and (treap? x) - (for/and ([v (treap-values x)]) - (trie? v))))) - -;; -> Trie -;; The empty Trie -(define (trie-empty) #f) - -;; Trie -> Boolean -;; True iff the argument is the empty trie -(define (trie-empty? r) (not r)) - -;; Trie -> Boolean -;; True iff the argument is NOT the empty trie -(define (trie-non-empty? r) (not (trie-empty? r))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Smart constructors & accessors -;; -;; Maintain this INVARIANT: A Trie is non-empty iff it contains -;; some keys that map to some Values. Essentially, don't bother -;; prepending tokens to a Trie unless there's some possibility it -;; can map to one or more Values. - -;; Trie Trie -> Boolean -;; Exploits canonicalization to replace an expensive equal? check with eq?. -(define (requal? a b) - (eq? a b)) - -;; (Option Value) -> Trie -;; If the argument is #f, returns the empty trie; otherwise, a success Trie. -(define (rsuccess v) - (and v (canonicalize (success v)))) - -;; Order for sigmas -(define (sigma-order a b) - (define sta? (struct-type? a)) - (define stb? (struct-type? b)) - (cond - [(and sta? stb?) (hash-order (struct-type-name a) (struct-type-name b))] - [sta? '<] - [stb? '>] - [else (hash-order a b)])) - -;; (Treap (U Sigma Wildcard) Trie) -;; The empty branch-trie -(define empty-smap (treap-empty sigma-order)) - -;; (U Sigma Wildcard) Trie -> Trie -;; Prepends e to r, if r is non-empty. -(define (rseq e r) - (if (trie-empty? r) - r - (treap-insert empty-smap e r))) - -;; [ (U Sigma Wildcard) Trie ] ... -> Trie -(define (rseq-multi . ers) - (let walk ((ers ers)) - (match ers - [(list* e r rest) (treap-insert (walk rest) e r)] - [(list) empty-smap]))) - -;; Trie -> Trie -;; Prepends the wildcard pseudo-Sigma to r, if r is non-empty. -(define (rwild r) - (rseq ? r)) - -;; Trie -> Trie -;; If r is non-empty, returns a trie that consumes input up to and -;; including EOS, then continuing with r. -(define (rwildseq r) - (if (trie-empty? r) r (canonicalize (wildcard-sequence r)))) - -;; Trie -> Trie -;; If r is a wildcard-sequence, return the continuation expected after -;; the wilds and EOS. Otherwise, return the empty/failing trie. -(define (runwildseq r) - (match r - [(wildcard-sequence k) k] - [_ #f])) - -;; Trie (U Sigma Wildcard) Trie -> Trie -;; r must be a treap trie. Retrieves the continuation after -;; accepting key. If key is absent, returns wild-edge-value, modified -;; depending on key. -(define (rlookup r key wild-edge-value) - (treap-get r key (lambda () - (cond - [(key-open? key) (rwildseq wild-edge-value)] - [(key-close? key) (runwildseq wild-edge-value)] - [else wild-edge-value])))) - -;; (Option (Treap (U Sigma Wildcard) Trie)) Sigma Trie -> Trie -;; Updates (installs or removes) a continuation in the Trie r. r -;; must be either #f or a treap trie. key MUST NOT be ?. -;; Preserves invariant that a key is never added if its continuation -;; is the same as the wildcard's continuation (which is implicitly #f -;; if absent, of course). -(define (rupdate r0 key k) - (when (eq? key ?) (error 'rupdate "Internal error: supplied wildcard as key")) - (define r (or r0 empty-smap)) - (empty-smap-guard - (let ((old-wild (treap-get r ? (lambda () #f)))) - (if (cond [(key-open? key) - (if (wildcard-sequence? k) - (requal? (wildcard-sequence-trie k) old-wild) - (trie-empty? k))] - [(key-close? key) - (if (wildcard-sequence? old-wild) - (requal? (wildcard-sequence-trie old-wild) k) - (trie-empty? k))] - [else - (requal? k old-wild)]) - (treap-delete r key) - (treap-insert r key k))))) - -;; Treap -> Trie -;; If the argument is empty, returns the canonical empty trie; -;; otherwise, returns the argument. -(define (empty-smap-guard h) - (and (positive? (treap-size h)) h)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Pattern compilation - -;; Value (Listof Pattern) -> Trie -;; Compiles a sequence of patterns into a trie that accepts input -;; matching that sequence, yielding v. -(define (pattern->trie* v ps0) - ;; Pattern Trie -> Trie - ;; acc is the continuation-trie for the trie created from ps. - (define (walk-pair-chain ps acc) - (match ps - ['() (rseq EOS acc)] - [(cons p ps) (walk p (walk-pair-chain ps acc))] - [other (rseq ILM (walk other (rseq EOS acc)))])) - - ;; Pattern Trie -> Trie - ;; acc is the continuation-trie for the trie created from p. - (define (walk p acc) - (match p - [(capture sub) (error 'pattern->trie* "Embedded capture in one of the patterns ~v" ps0)] - [(== ?) (rwild acc)] - [(cons p1 p2) (rseq SOL (walk p1 (walk-pair-chain p2 acc)))] - [(? vector? v) (rseq SOV (vector-foldr walk (rseq EOS acc) v))] - [(embedded-trie m) (trie-append m (lambda (_mv) acc))] - ;; TODO: consider options for treating treaps as compounds - ;; rather than (useless) atoms - [(? treap?) (error 'pattern->trie "Cannot match on treaps at present")] - [(? non-object-struct?) - (rseq (struct->struct-type p) - (walk-pair-chain (cdr (vector->list (struct->vector p))) - acc))] - [other (rseq (canonicalize other) acc)])) - - (walk-pair-chain ps0 (rsuccess v))) - -;; Value Pattern* -> Trie -;; Convenience form of pattern->trie*. -(define (pattern->trie v . ps) - (pattern->trie* v ps)) - -;; Structure -> StructType -;; Errors when given any struct that isn't completely transparent/prefab. -(define (struct->struct-type p) - (define-values (t skipped?) (struct-info p)) - (when skipped? (error 'struct->struct-type "Cannot reflect on struct instance ~v" p)) - t) - -;; Any -> Boolean -;; Racket objects are structures, so we reject them explicitly for -;; now, leaving them opaque to unification. -(define (non-object-struct? x) - (and (struct? x) - (not (object? x)))) - -;; (A B -> B) B (Vectorof A) -> B -(define (vector-foldr kons knil v) - (for/fold [(acc knil)] [(elem (in-vector v (- (vector-length v) 1) -1 -1))] - (kons elem acc))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Trie combinators - -(define (default-short v r) - (error 'default-short "Asymmetric tries; value ~v, trie ~v" v r)) - -;; Trie Trie -> Trie -;; Computes the union of the multimaps passed in. -(define (trie-union re1 re2 #:combiner [combiner tset-union]) - (trie-recurse re1 - re2 - combiner - values - values - values - values - default-short - default-short)) - -;; (A B -> C) -> A B -> B A -> C -(define ((flip f) a b) (f b a)) - -;; Trie Trie -> Trie -;; Computes the intersection of the multimaps passed in. -(define (trie-intersect re1 re2 - #:combiner [combiner tset-union] - #:left-short [left-short default-short] - #:right-short [right-short default-short]) - (trie-recurse re1 - re2 - combiner - (lambda (r) #f) - (lambda (r) #f) - (lambda (h) #f) - (lambda (h) #f) - left-short - right-short)) - -(define (empty-tset-guard s) - (if (tset-empty? s) #f s)) - -(define (trie-subtract-combiner s1 s2) - (empty-tset-guard (tset-subtract s1 s2))) - -;; Trie Trie -> Trie -;; Removes re2's mappings from re1. -;; The combine-successes function should return #f to signal "no remaining success values". -(define (trie-subtract re1 re2 #:combiner [combiner trie-subtract-combiner]) - (trie-recurse re1 - re2 - combiner - (lambda (r) #f) - values - (lambda (h) #f) - values - default-short - default-short)) - -(define (trie-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))] - [((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)) - (define w2 (rlookup h2 ? #f)) - (collapse-wildcard-sequences - (cond - [(and w1 w2) - (for/fold [(acc (rwild (f w1 w2)))] - [(key (set-remove (set-union (treap-keys h1) (treap-keys h2)) ?))] - (rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))] - [w1 - (for/fold [(acc left-base)] [(key (treap-keys h2))] - (rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))] - [w2 - (for/fold [(acc right-base)] [(key (treap-keys h1))] - (rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))] - [(< (treap-size h1) (treap-size h2)) - (for/fold [(acc right-base)] [(key (treap-keys h1))] - (rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))] - [else - (for/fold [(acc left-base)] [(key (treap-keys h2))] - (rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))]))) - -;; Trie -> Trie -;; When a trie contains only entries for (EOS -> m') and (★ -> -;; (wildcard-sequence m')), it is equivalent to (wildcard-sequence m') -;; itself. This is the inverse of expand-wildseq. -;; -;; In addition, we rewrite (★ -> (wildcard-sequence m')) to -;; (wildcard-sequence m'), since trie-lookup will fall back to -;; ★ if EOS is missing, and rlookup adjusts appropriately. -(define (collapse-wildcard-sequences m) - (if (treap? m) - (case (treap-size m) - [(2) - (if (and (treap-has-key? m ?) - (treap-has-key? m EOS)) - (let ((w (treap-get m ?)) - (k (treap-get m EOS))) - (if (and (wildcard-sequence? w) - (requal? (wildcard-sequence-trie w) k)) - w - m)) - m)] - [(1) - (if (treap-has-key? m ?) - (let ((w (treap-get m ?))) - (if (wildcard-sequence? w) - w - m)) - m)] - [else m]) - m)) - -;; Sigma -> Boolean -;; True iff k represents the start of a compound datum. -(define (key-open? k) - (or (eq? k SOL) - (eq? k SOV) - (struct-type? k))) - -;; Sigma -> Boolean -;; True iff k represents the end of a compound datum. -(define (key-close? k) - (eq? k EOS)) - -;; Trie -> Trie -;; Unrolls the implicit recursion in a wildcard-sequence. -(define (expand-wildseq r) - (treap-insert (treap-insert empty-smap ? (rwildseq r)) EOS r)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Matching single keys into a multimap - -;; (Listof Sigma) -> (Listof Sigma) -;; Hackish support for improper lists. TODO: revisit -;; Converts an improper list into a proper one with ILM in the penultimate position. -(define (transform-list-value xs) - (match xs - ['() '()] - [(cons x xs) (cons x (transform-list-value xs))] - [other (cons ILM (cons other '()))])) - -;; Trie InputValue [Value] -> Value -;; Converts the nested structure v on-the-fly into a sequence of -;; Sigmas and runs them through the Trie r. If v leads to a success -;; Trie, returns the values contained in the success Trie; -;; otherwise, returns failure-result. -(define (trie-lookup r v failure-result) - (let walk ((vs (list v)) (stack '(())) (r r)) - (match r - [#f failure-result] - [(wildcard-sequence k) - (match stack - ['() failure-result] - [(cons rest stack1) (walk rest stack1 k)])] - [(success result) - (if (and (null? vs) - (null? stack)) - result - failure-result)] - [(? treap?) - (define (get key) (treap-get r key (lambda () #f))) - (match vs - ['() - (match stack - ['() failure-result] - [(cons rest stack1) - (walk rest stack1 (rlookup r EOS (get ?)))])] - [(cons (== ?) rest) - (error 'trie-lookup "Cannot match wildcard as a value")] - [(cons (cons v1 v2) rest) - (match (get SOL) - [#f (walk rest stack (get ?))] - [k (walk (cons v1 (transform-list-value v2)) (cons rest stack) k)])] - [(cons (vector vv ...) rest) - (match (get SOV) - [#f (walk rest stack (get ?))] - [k (walk vv (cons rest stack) k)])] - [(cons (? non-object-struct? s) rest) - (match (get (struct->struct-type s)) - [#f (walk rest stack (get ?))] - [k (walk (cdr (vector->list (struct->vector s))) (cons rest stack) k)])] - [(cons v rest) - (walk rest stack (rlookup r (canonicalize v) (get ?)))])]))) - -;; Trie Trie -> Value -;; -;; Similar to trie-lookup, but instead of a single key, -;; accepts a Trie serving as *multiple* simultaneously-examined -;; keys. Returns the union of all successful values reached by the -;; probe. -(define (trie-match-trie re1 re2 - #:seed seed - #:combiner [combiner (lambda (v1 v2 a) - (cons (tset-union (car a) v1) - (tset-union (cdr a) v2)))] - #:left-short [left-short (lambda (v r acc) acc)] - #:right-short [right-short (lambda (v r acc) acc)]) - (let walk ((re1 re1) (re2 re2) (acc seed)) - (match* (re1 re2) - [(#f _) acc] - [(_ #f) acc] - - [((? treap? h1) (? treap? h2)) - (define w1 (rlookup h1 ? #f)) - (define w2 (rlookup h2 ? #f)) - (define r (walk w1 w2 acc)) - (for/fold [(r r)] - [(key (cond - [(and w1 w2) (set-remove (set-union (treap-keys h1) (treap-keys h2)) ?)] - [w1 (treap-keys h2)] - [w2 (treap-keys h1)] - [(< (treap-size h1) (treap-size h2)) (treap-keys h1)] - [else (treap-keys h2)]))] - (walk (rlookup h1 key w1) (rlookup h2 key w2) r))] - - [((wildcard-sequence r1) (wildcard-sequence r2)) (walk r1 r2 acc)] - [((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2 acc)] - [(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2) acc)] - - [((success v1) (success v2)) (combiner v1 v2 acc)] - [((success v) r) (left-short v r acc)] - [(r (success v)) (right-short v r acc)]))) - -;; Trie × (Value → Trie) → Trie -;; Since Tries accept *sequences* of input values, this appends two -;; tries into a single trie that accepts their concatenation. -;; Because tries map inputs to values, the second trie is -;; expressed as a function from success-values from the first trie -;; to a second trie. -(define (trie-append m0 m-tail-fn) - (let walk ((m m0)) - (match m - [#f #f] - [(success v) (error 'trie-append "Ill-formed trie: ~v" m0)] - [(wildcard-sequence m1) (rwildseq (walk m1))] - [(? treap?) (for/fold [(acc (rwild (walk (rlookup m ? #f))))] - [(kv (treap-to-alist m)) #:when (not (eq? (car kv) ?))] - (match-define (cons k v) kv) - (if (and (key-close? k) (success? v)) - (trie-union acc (m-tail-fn (success-value v)) - #:combiner (lambda (v1 v2) - (error 'trie-append - "Conflicting success-values ~v/~v" - v1 - v2))) - (rupdate acc k (walk v))))]))) - -;; Trie (Value -> (Option Value)) -> Trie -;; Maps f over success values in m. -(define (trie-relabel m f) - (let walk ((m m)) - (match m - [#f #f] - [(success v) (rsuccess (f v))] - [(wildcard-sequence m1) (rwildseq (walk m1))] - [(? treap?) (for/fold [(acc (rwild (walk (rlookup m ? #f))))] - [(kv (treap-to-alist m)) #:when (not (eq? (car kv) ?))] - (rupdate acc (car kv) (walk (cdr kv))))]))) - -;; Trie Sigma -> Trie -;; Outright removes tries reachable from m via edges labelled with s. -;; Useful for removing (at-meta *) when the success value along that -;; branch doesn't matter. -(define (trie-prune-branch m s) - (match m - [#f #f] - [(wildcard-sequence k) - (collapse-wildcard-sequences (rupdate (expand-wildseq k) s (trie-empty)))] - [(success _) m] - [(? treap? h) (rupdate h s (trie-empty))])) - -;; Trie Sigma -> Trie -(define (trie-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 - -;; (Listof Projection) -> CompiledProjection -;; Compiles a sequence of projections into a single CompiledProjection -;; for use with trie-project. -(define (compile-projection* ps0) - (define (walk-pair-chain ps acc) - (match ps - ['() (cons EOS acc)] - [(cons p ps) (walk p (walk-pair-chain ps acc))] - [other (cons ILM (walk other (cons EOS acc)))])) - - (define (walk p acc) - (match p - [(capture sub) (cons SOC (walk sub (cons EOC acc)))] ;; TODO: enforce non-nesting here - [(== ?) (cons ? acc)] - [(cons p1 p2) (cons SOL (walk p1 (walk-pair-chain p2 acc)))] - [(? vector? v) (cons SOV (vector-foldr walk (cons EOS acc) v))] - [(embedded-trie m) (error 'compile-projection "Cannot embed trie in projection")] - ;; TODO: consider options for treating treaps as compounds rather than (useless) atoms - [(? treap?) (error 'compile-projection "Cannot match on treaps at present")] - [(? non-object-struct?) - (cons (struct->struct-type p) - (walk-pair-chain (cdr (vector->list (struct->vector p))) - acc))] - [other (cons (canonicalize other) acc)])) - - (walk-pair-chain ps0 '())) - -;; Projection* -> CompiledProjection -;; Convenience form of compile-projection*. -(define (compile-projection . ps) - (compile-projection* ps)) - -;; Projection -> Pattern -;; Strips captures from its argument, returning an equivalent non-capturing pattern. -(define (projection->pattern p) - (let walk ((p p)) - (match p - [(capture sub) sub] ;; TODO: maybe enforce non-nesting here too? - [(cons p1 p2) (cons (walk p1) (walk p2))] - [(? vector? v) (for/vector [(e (in-vector v))] (walk e))] - ;; TODO: consider options for treating treaps as compounds - ;; rather than (useless) atoms - [(? treap?) (error 'projection->pattern "Cannot match on treaps at present")] - [(? non-object-struct?) - (apply (struct-type-make-constructor (struct->struct-type p)) - (map walk (cdr (vector->list (struct->vector p)))))] - [other other]))) - -;; Trie × CompiledProjection -> Trie -;; The result matches a sequence of inputs of length equal to the number of captures. -;; The project-success function should return #f to signal "no success values". -(define trie-project - (let () - (define (general-balanced add-wildseq add-wild add-edge m k) - (let walk ((m m) (k k)) - (match m - [(wildcard-sequence mk) (add-wildseq (k mk))] - [(? treap?) - (for/fold [(acc (add-wild (walk (rlookup m ? #f) k)))] - [(key-mk (treap-to-alist m)) #:when (not (eq? (car key-mk) ?))] - (match-define (cons key mk) key-mk) - (add-edge acc key (cond - [(key-open? key) (walk mk (lambda (mk) (walk mk k)))] - [(key-close? key) (k mk)] - [else (walk mk k)])))] - [_ (trie-empty)]))) - - (define (general-match add-wild add-edge add-sigma balanced m spec ps drop-match take-match) - (let walk ((m m) (spec spec)) - (match spec - ['() - (match m - [(success v) (rseq EOS (rsuccess (ps v)))] - [_ (trie-empty)])] - - [(cons (== EOC) k) (drop-match m k)] - [(cons (== SOC) k) (take-match m k)] - - [(cons (== ?) k) - (match m - [(wildcard-sequence _) (add-wild (walk m k))] - [(? treap?) - (for/fold [(acc (add-wild (walk (rlookup m ? #f) k)))] - [(key-mk (treap-to-alist m)) #:when (not (eq? (car key-mk) ?))] - (match-define (cons key mk) key-mk) - (add-edge acc key (cond - [(key-open? key) (balanced mk (lambda (mk) (walk mk k)))] - [(key-close? key) #f] - [else (walk mk k)])))] - [_ (trie-empty)])] - - [(cons sigma k) - (add-sigma sigma - (match m - [(wildcard-sequence mk) - (cond - [(key-open? sigma) (walk (rwildseq m) k)] - [(key-close? sigma) (walk mk k)] - [else (walk m k)])] - [(? treap?) (walk (rlookup m sigma (rlookup m ? #f)) k)] - [_ (trie-empty)]))]))) - - (lambda (m spec - #:project-success [project-success values] - #:combiner [combiner tset-union]) - (define (drop-match m spec) (general-match values drop-edge drop-sigma drop-bal m spec - project-success drop-match take-match)) - (define (take-match m spec) (general-match rwild rupdate rseq take-bal m spec - project-success drop-match take-match)) - (define (drop-bal m k) (general-balanced values values drop-edge m k)) - (define (take-bal m k) (general-balanced rwildseq rwild rupdate m k)) - (define (drop-edge acc key k) (trie-union acc k #:combiner combiner)) - (define (drop-sigma sigma k) k) - (drop-match m spec)))) - -;; (Listof Sigma) -> (Listof Sigma) -;; Hackish support for improper lists. TODO: revisit -;; Undoes the transformation of transform-list-value, converting -;; ILM-marked proper lists back into improper ones. -(define (untransform-list-value vs) - (match vs - ['() '()] - [(cons (== ILM) (cons v '())) v] - [(cons (== ILM) _) (error 'untransform-list-value "Illegal use of ILM" vs)] - [(cons v vs) (cons v (untransform-list-value vs))])) - -;; Trie → (Option (Setof (Listof Value))) -;; Extracts the "keys" in its argument multimap m, representing input -;; sequences as lists. Multiplies out unions. Returns #f if any -;; dimension of m is infinite. -(define trie-key-set - (let () - ;; Trie (Value Trie -> (Setof Value)) -> (Option (Setof Value)) - ;; Calls k with each possible atomic value at this trie - ;; position, and accumulates the results. - (define (walk m k) - (match m - [(wildcard-sequence _) #f] - [(? treap?) - (and (not (treap-has-key? m ?)) - (for/fold [(acc (set))] [(key-mk (treap-to-alist m))] - (match-define (cons key mk) key-mk) - (maybe-union - acc - (cond - [(key-open? key) - (walk-seq mk (lambda (vss vsk) - (for/fold [(acc (set))] [(vs (in-set vss))] - (maybe-union acc - (k (transform-seqs vs key) vsk)))))] - [(key-close? key) - (error 'trie-key-set "Internal error: unexpected key-close")] - [else - (k key mk)]))))] - [_ (set)])) - - ;; Trie (Value Trie -> (Setof (Listof Value))) -> (Option (Setof (Listof Value))) - ;; Calls k with each possible sequence of atomic values at this - ;; trie position, and accumulates the results. - (define (walk-seq m k) - (match m - [(wildcard-sequence _) #f] - [(? treap?) - (and (not (treap-has-key? m ?)) - (for/fold [(acc (set))] [(key-mk (treap-to-alist m))] - (match-define (cons key mk) key-mk) - (maybe-union acc (cond - [(key-close? key) (k (set '()) mk)] - [else (walk (rseq key mk) - (lambda (v vk) - (walk-seq vk (lambda (vss vsk) - (k (for/set [(vs (in-set vss))] - (cons v vs)) - vsk)))))]))))] - [_ (k (set) #f)])) - - ;; (Listof Value) Sigma -> Value - (define (transform-seqs vs opener) - (cond - [(eq? opener SOL) (untransform-list-value vs)] - [(eq? opener SOV) (list->vector vs)] - [(struct-type? opener) (apply (struct-type-make-constructor opener) vs)])) - - ;; (Option (Setof A)) (Option (Setof A)) -> (Option (Setof A)) - (define (maybe-union s1 s2) (and s1 s2 (set-union s1 s2))) - - (lambda (m) - (walk-seq m (lambda (vss vsk) vss))))) - -;; Trie → (Option (Setof Value)) -;; As trie-key-set, but extracts just the first captured subvalue. -(define (trie-key-set/single m) - (define vss (trie-key-set m)) - (and vss (for/set [(vs (in-set vss))] (car vs)))) - -;; Convenience forms for the common operation of projecting a Trie -;; followed by converting the result to a Racket set (possibly -;; containing just the first captured subvalue). -(define-syntax-rule (trie-project/set arg ...) - (trie-key-set (trie-project arg ...))) -(define-syntax-rule (trie-project/set/single arg ...) - (trie-key-set/single (trie-project arg ...))) - -;; Ultra-convenience form. -(define (project-assertions m . ps) - (trie-project/set/single m (compile-projection* ps))) - -;; struct-type -> Symbol -;; Extract just the name of the given struct-type. -(define (struct-type-name st) - (define-values (name x2 x3 x4 x5 x6 x7 x8) (struct-type-info st)) - name) - -;; Trie [OutputPort] [#:indent Nat] -> Void -;; Pretty-prints the given trie on the given port, with -;; second-and-subsequent lines indented by the given amount. -(define (pretty-print-trie m [port (current-output-port)] #:indent [initial-indent 0]) - (define (d x) (display x port)) - (define (walk i m) - (match m - [#f - (d "::: nothing")] - [(wildcard-sequence k) - (d " ...>") - (walk (+ i 5) k)] - [(success vs) - (d "{") - (d (if (tset? vs) (cons 'tset (tset->list vs)) vs)) - (d "}")] - [(? treap? h) - (if (zero? (treap-size h)) - (d " ::: empty treap!") - (for/fold [(need-sep? #f)] [(key-k (treap-to-alist h))] - (match-define (cons key k) key-k) - (when need-sep? - (newline port) - (d (make-string i #\space))) - (d " ") - (define keystr (call-with-output-string - (lambda (p) - (cond - [(struct-type? key) - (display "pretty-string m #:indent [initial-indent 0]) - (with-output-to-string (lambda () (pretty-print-trie m #:indent initial-indent)))) - -(define (trie->abstract-graph m) - (define nodes (hasheq)) - (define edges '()) - (define (add-edge! source-id label target) - (set! edges (cons (list source-id label (walk target)) edges))) - (define (walk m) - (car - (hash-ref nodes m - (lambda () - (define node-info - (match m - [#f (list 'fail)] - [(wildcard-sequence _) (list 'tail)] - [(success v) (list 'ok v)] - [(? treap?) (list 'branch)])) - (define source-id (gensym 'i)) - (define entry (cons source-id node-info)) - (set! nodes (hash-set nodes m entry)) - (match m - [#f (void)] - [(wildcard-sequence k) (add-edge! source-id #f k)] - [(success _) (void)] - [(? treap? h) (treap-fold h - (lambda (seed k v) (add-edge! source-id k v)) - (void))]) - entry)))) - (walk m) - (list (hash-values nodes) edges)) - -(define (abstract-graph->dot g) - (match-define (list nodes edges) g) - (with-output-to-string - (lambda () - (printf "digraph Trie {\n") - (for ((n nodes)) - (match n - [(list id type) (printf " ~a [label=\"~a\"];\n" id type)] - [(list id type x) (printf " ~a [label=\"~a ~v\"];\n" id type x)])) - (for ((e edges)) - (match e - [(list s #f t) (printf " ~a -> ~a;\n" s t)] - [(list s label t) (printf " ~a -> ~a [label=\"~v\"];\n" s t label)])) - (printf "}\n")))) - -(define (trie->dot m) - (abstract-graph->dot (trie->abstract-graph m))) - -;; Trie (Value -> JSExpr) -> JSExpr -;; Serializes a trie to a JSON expression. -(define (trie->jsexpr m success->jsexpr) - (let walk ((m m)) - (match m - [#f '()] - [(success v) (list "" (success->jsexpr v))] - [(wildcard-sequence m1) (list "...)" (walk m1))] - [(? treap?) - (for/list [(kv (treap-to-alist m))] - (match-define (cons k v) kv) - (list (match k - [(== ?) (list "__")] - [(== SOL) (list "(")] - [(== SOV) (list "#(")] - [(== EOS) (list ")")] - [(? struct-type? t) - (list (string-append (symbol->string (struct-type-name t)) "("))] - [else k]) - (walk v)))]))) - -;; String -> String -;; Undoes the encoding of struct-type names used in the JSON serialization of Tries. -(define (deserialize-struct-type-name stn) - (define expected-paren-pos (- (string-length stn) 1)) - (and (char=? (string-ref stn expected-paren-pos) #\() - (substring stn 0 expected-paren-pos))) - -;; JSExpr (JSExpr -> Value) [String -> (Option struct-type)] -> Trie -;; Deserializes a trie from a JSON expression. -(define (jsexpr->trie j jsexpr->success [struct-type-name->struct-type (lambda () #f)]) - (let walk ((j j)) - (match j - ['() #f] - [(list "" vj) (rsuccess (jsexpr->success vj))] - [(list "...)" j1) (rwildseq (walk j1))] - [(list (list kjs vjs) ...) - (for/fold [(acc empty-smap)] - [(kj kjs) (vj vjs)] - (treap-insert acc - (match kj - [(list "__") ?] - [(list "(") SOL] - [(list "#(") SOV] - [(list ")") EOS] - [(list (? string? s)) - (match (deserialize-struct-type-name s) - [#f (error 'jsexpr->trie - "Illegal open-parenthesis mark ~v" - kj)] - [tn (match (struct-type-name->struct-type tn) - [#f (error 'jsexpr->trie - "Unexpected struct type ~v" - tn)] - [t t])])] - [other other]) - (walk vj)))]))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(module+ test - (require racket/pretty) - - (define tset datum-tset) - - (define SA (tset 'A)) - (define SB (tset 'B)) - (define SC (tset 'C)) - (define SD (tset 'D)) - (define Sfoo (tset 'foo)) - (define S+ (tset '+)) - (define SX (tset 'X)) - (define (E v) (rseq EOS (rsuccess v))) - (check-equal? (pattern->trie SA 123) (rseq 123 (E SA))) - (check-equal? (pattern->trie SA (cons 1 2)) - (rseq SOL (rseq 1 (rseq ILM (rseq 2 (rseq EOS (E SA))))))) - (check-equal? (pattern->trie SA (cons ? 2)) - (rseq SOL (rseq ? (rseq ILM (rseq 2 (rseq EOS (E SA))))))) - (check-equal? (pattern->trie SA (list 1 2)) (rseq SOL (rseq 1 (rseq 2 (rseq EOS (E SA)))))) - (check-equal? (pattern->trie SA (list ? 2)) (rseq SOL (rseq ? (rseq 2 (rseq EOS (E SA)))))) - (check-equal? (pattern->trie SA SOL) (rseq struct:start-of-list (rseq EOS (E SA)))) - (check-equal? (pattern->trie SA ?) (rseq ? (E SA))) - ) - -(module+ test - (define (check-matches trie . tests) - (let walk ((tests tests)) - (match tests - ['() (void)] - [(list* message expectedstr rest) - (define actualset (trie-lookup trie message (tset))) - (printf "~v ==> ~v\n" message (tset->list actualset)) - (check-equal? actualset - (apply tset (map (lambda (c) (string->symbol (string c))) - (string->list expectedstr)))) - (walk rest)]))) - - (check-matches - #f - (list 'z 'x) "" - 'foo "" - (list (list 'z (list 'z))) "") - - (let ((t (trie-subtract (pattern->trie SA ?) (pattern->trie SA (list 'a))))) - ;; I expected this test to fail, because of the way (get) in - ;; (trie-lookup) returns #f when there is no entry in the treap. - ;; The choice of #f as sentinel for "no entry" is potentially - ;; problematic, since it also means "empty trie". However, things - ;; work out for us because we have the EOS step that saves us! - ;; This means that when '(a) is presented as a value, at 'a it - ;; steps to the trie EOS->empty, and then when it steps through - ;; the EOS it retrieves #f (empty), mistakes it for a sentinel, - ;; retrieves the wildcard entry, which is also #f, and thus by - ;; coincidence does the right thing. - ;; - ;; TODO: probably the right thing to do is change (get) to return - ;; e.g. 'missing -- anything not in the domain of tries -- so it - ;; is unambiguous when a lookup fails. - (check-matches t - 'b "A" - 'a "A" - (list 'b) "A" - (list 'a) "")) - - (define (pretty-print-trie* m) - (newline) - (pretty-print-trie m) - (flush-output) - m) - - (define (pretty-print-trie*/dot m) - (newline) - (display (trie->dot (trie-relabel m (lambda (v) - (if (treap? v) - (map car (treap-to-alist v)) - v))))) - (flush-output) - m) - - (void (pretty-print-trie* - (trie-union (pattern->trie SA (list (list ?) 'x)) - (pattern->trie SB (list (list ?) 'y))))) - - (void (pretty-print-trie* - (trie-union (pattern->trie SA (list (list 'a 'b) 'x)) - (pattern->trie SB (list (list 'c 'd) 'y))))) - - (void (pretty-print-trie* - (trie-union (pattern->trie SA (list (list 'a 'b) 'x)) - (pattern->trie SB (list (list ? ?) 'y))))) - - (check-matches - (pretty-print-trie* - (trie-union (pattern->trie SA (list (list 'a 'b) 'x)) - (pattern->trie SB (list (list ? ?) 'x)))) - (list 'z 'x) "" - (list (list 'z 'z) 'x) "B" - (list (list 'z (list 'z)) 'x) "B" - (list (list 'a 'b) 'x) "AB") - - (check-matches - (pretty-print-trie* - (trie-union (pattern->trie SA (list (list 'a 'b) 'x)) - (pattern->trie SB (list (list ?) 'y)))) - (list 'z 'y) "" - (list (list 'z 'z) 'y) "" - (list (list 'z 'z) 'x) "" - (list (list 'a 'b) 'x) "A") - - (check-matches - (pretty-print-trie* - (trie-union (pattern->trie SA (list (list 'a 'b) 'x)) - (pattern->trie SB (list ? 'y)))) - (list 'z 'y) "B" - (list (list 'z 'z) 'y) "B" - (list (list 'a 'b) 'x) "A") - - (check-matches - (pretty-print-trie* - (trie-union (pattern->trie SA (list 'a 'b)) - (pattern->trie SB (list 'c 'd)))) - (list 'a 'b) "A" - (list 'c 'd) "B" - (list 'a 'd) "" - (list 'c 'b) "") - - (void (pretty-print-trie* (trie-union (pattern->trie SA (list (list 'a 'b) 'x)) - ;; Note: this is a largely nonsense trie, - ;; since it expects no input at all - (rseq EOS (rsuccess (tset 'B)))))) - - (check-matches - (pretty-print-trie* - (trie-union (pattern->trie SA (list (list 'a 'b) 'x)) - (pattern->trie SB ?))) - (list (list 'a 'b) 'x) "AB" - 'p "B" - (list 'p) "B") - - (check-matches - (pretty-print-trie* - (trie-union (pattern->trie SA (list 'a ?)) - (pattern->trie SB (list 'a (list 'b))))) - - (list 'a (list 'b)) "AB" - (list 'a (list 'b 'b)) "A" - (list 'a (list 'c 'c)) "A" - (list 'a (list 'c)) "A" - (list 'a (list (list))) "A" - (list 'a (list)) "A" - (list 'a 'x) "A") - - (check-matches - (pretty-print-trie* - (trie-union (trie-union (pattern->trie SA (list 'a ?)) - (pattern->trie SA (list 'q ?))) - (pattern->trie SB (list 'a (list 'b))))) - (list 'a (list 'b)) "AB" - (list 'q (list 'b)) "A" - (list 'a 'x) "A" - (list 'q 'x) "A" - (list 'a (list)) "A" - (list 'q (list)) "A" - (list 'z (list)) "") - - (define (bigdemo) - (define ps - (for/list ((c (in-string "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))) - (define csym (string->symbol (string c))) - (pattern->trie (tset csym) (list csym ?)))) - (trie-union (foldr trie-union (trie-empty) ps) - (pattern->trie S+ (list 'Z (list ? '- ?))))) - - (newline) - (printf "Plain bigdemo\n") - - (void (pretty-print-trie* (bigdemo))) - (check-matches - (bigdemo) - (list 'a '-) "a" - (list 'Z '-) "Z" - (list '? '-) "" - (list 'a (list '- '- '-)) "a" - (list 'a (list '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '-)) "a" - (list 'Z) "" - (list 'Z 'x) "Z" - (list 'Z (list)) "Z" - (list 'Z (list '-)) "Z" - (list 'Z (list '- '-)) "Z" - (list 'Z (list '- '- '-)) "Z+" - (list 'Z (list '- '- '- '-)) "Z" - (list 'Z (list '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '-)) "Z" - (list 'Z '((()) - -)) "Z+" - (list '? (list '- '- '-)) "") - - ;; ;; Having switched from pair-based matching to list-based matching, - ;; ;; it's no longer supported to match with a wildcard in the cdr of a - ;; ;; pair. Or rather, it is, but it won't work reliably: when the - ;; ;; value to be matched is a proper list, it will fail to match. - ;; ;; Consequently: Don't Do That. - ;; (check-matches (pretty-print-trie* (pattern->trie SA (list* 'a 'b ?))) - ;; (list 'a 'b 'c 'd 'e 'f) "A" - ;; (list 'b 'c 'd 'e 'f 'a) "" - ;; 3 "") - - (newline) - (printf "bigdemo with trie-intersect 'a -> SA | 'b -> SB\n") - - (void (pretty-print-trie* (trie-intersect (pattern->trie SA (list 'a)) - (pattern->trie SB (list 'b))))) - - (newline) - (printf "various unions and intersections\n") - - (let ((r1 (trie-union (pattern->trie SA (list ? 'b)) - (pattern->trie SA (list ? 'c)))) - (r2 (trie-union (pattern->trie SB (list 'a ?)) - (pattern->trie SB (list 'b ?))))) - (pretty-print-trie* (trie-union r1 r2)) - (pretty-print-trie* (trie-union r1 r1)) - (pretty-print-trie* (trie-union r2 r2)) - (pretty-print-trie* (trie-intersect r1 r2)) - (pretty-print-trie* (trie-intersect r1 r1)) - (pretty-print-trie* (trie-intersect r2 r2)) - (void)) - - (newline) - (printf "bigdemo with trie-intersect ('m 'n) -> SX\n") - - (check-matches - (pretty-print-trie* (trie-intersect (bigdemo) (pattern->trie SX (list 'm 'n)))) - (list 'm '-) "" - (list 'm 'n) "mX" - (list 'x '-) "" - (list 'x 'n) "") - - (newline) - (printf "bigdemo with trie-intersect ('Z ?) -> SX\n") - - (check-matches - (pretty-print-trie* (trie-intersect (bigdemo) (pattern->trie SX (list 'Z ?)))) - (list 'a '-) "" - (list 'Z '-) "XZ" - (list '? '-) "" - (list 'a (list '- '- '-)) "" - (list 'a (list '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '-)) "" - (list 'Z) "" - (list 'Z 'x) "XZ" - (list 'Z (list)) "XZ" - (list 'Z (list '-)) "XZ" - (list 'Z (list '- '-)) "XZ" - (list 'Z (list '- '- '-)) "XZ+" - (list 'Z (list '- '- '- '-)) "XZ" - (list 'Z (list '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '-)) "XZ" - (list 'Z '((()) - -)) "XZ+" - (list '? (list '- '- '-)) "") - - (newline) - (printf "bigdemo with trie-intersect ('Z ?) -> SX and changed success function\n") - - (check-matches - (pretty-print-trie* (trie-intersect (bigdemo) (pattern->trie SX (list 'Z ?)) - #:combiner (lambda (a b) b))) - (list 'a '-) "" - (list 'Z '-) "X" - (list '? '-) "" - (list 'a (list '- '- '-)) "" - (list 'a (list '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '-)) "" - (list 'Z) "" - (list 'Z 'x) "X" - (list 'Z (list)) "X" - (list 'Z (list '-)) "X" - (list 'Z (list '- '-)) "X" - (list 'Z (list '- '- '-)) "X" - (list 'Z (list '- '- '- '-)) "X" - (list 'Z (list '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '-)) "X" - (list 'Z '((()) - -)) "X" - (list '? (list '- '- '-)) "") - - (newline) - (printf "bigdemo with trie-intersect ? -> SX and changed success function\n") - - (check-matches - (pretty-print-trie* (trie-intersect (bigdemo) (pattern->trie SX ?) - #:combiner (lambda (a b) b))) - (list 'a '-) "X" - (list 'Z '-) "X" - (list '? '-) "" - (list 'a (list '- '- '-)) "X" - (list 'a (list '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '-)) "X" - (list 'Z) "" - (list 'Z 'x) "X" - (list 'Z (list)) "X" - (list 'Z (list '-)) "X" - (list 'Z (list '- '-)) "X" - (list 'Z (list '- '- '-)) "X" - (list 'Z (list '- '- '- '-)) "X" - (list 'Z (list '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '- '-)) "X" - (list 'Z '((()) - -)) "X" - (list '? (list '- '- '-)) "") - - (newline) - (printf "subtraction basics\n") - - (let* ((r1 (pattern->trie SA (list ? 'b))) - (r2 (pattern->trie SB (list 'a ?))) - (r12 (trie-union r1 r2))) - (printf "\n-=-=-=-=-=-=-=-=- erase1\n") - (pretty-print-trie* r1) - (pretty-print-trie* r2) - (pretty-print-trie* r12) - (pretty-print-trie* (trie-subtract r12 r1)) - (pretty-print-trie* (trie-subtract r12 r2)) - (void)) - - (let* ((r1 (trie-union (pattern->trie SA (list 'a ?)) - (pattern->trie SA (list 'b ?)))) - (r2 (pattern->trie SB (list 'b ?))) - (r12 (trie-union r1 r2))) - (printf "\n-=-=-=-=-=-=-=-=- erase2\n") - (pretty-print-trie* r12) - (pretty-print-trie* (trie-subtract r12 r1)) - (pretty-print-trie* (trie-subtract r12 r2)) - (pretty-print-trie* (trie-subtract r12 (pattern->trie SA ?))) - (void)) - - ) - -(module+ test - (struct a (x) #:prefab) - (struct b (x) #:transparent) - - (define (intersect a b) - (trie-intersect (pattern->trie SA a) - (pattern->trie SB b))) - - (define EAB (E (tset 'A 'B))) - - (define (rseq* x . xs) - (let walk ((xs (cons x xs))) - (match xs - [(list r) r] - [(cons e xs1) (rseq e (walk xs1))]))) - - (define-syntax-rule (check-requal? actual expected) - (check-eq? actual expected)) - - (check-requal? (intersect ? ?) (rwild EAB)) - (check-requal? (intersect 'a ?) (rseq 'a EAB)) - (check-requal? (intersect 123 ?) (rseq 123 EAB)) - (check-requal? (intersect (cons ? 2) (cons 1 ?)) (rseq* SOL 1 ILM 2 EOS EAB)) - (check-requal? (intersect (list ? 2) (list 1 ?)) (rseq* SOL 1 2 EOS EAB)) - (check-requal? (intersect (cons 1 2) ?) (rseq* SOL 1 ILM 2 EOS EAB)) - (check-requal? (intersect (list 1 2) ?) (rseq* SOL 1 2 EOS EAB)) - (check-requal? (intersect 1 2) #f) - (check-requal? (intersect (cons 1 2) (cons ? 2)) (rseq* SOL 1 ILM 2 EOS EAB)) - (check-requal? (intersect (list 1 2) (list ? 2)) (rseq* SOL 1 2 EOS EAB)) - (check-requal? (intersect (cons 1 2) (cons 3 2)) #f) - (check-requal? (intersect (cons 1 2) (cons 1 3)) #f) - (check-requal? (intersect (vector 1 2) (vector 1 2)) (rseq* SOV 1 2 EOS EAB)) - (check-requal? (intersect (vector 1 2) (vector 1 2 3)) #f) - - (check-requal? (intersect (a 'a) (a 'b)) #f) - (check-requal? (intersect (a 'a) (a 'a)) (rseq* struct:a 'a EOS EAB)) - (check-requal? (intersect (a 'a) (a ?)) (rseq* struct:a 'a EOS EAB)) - (check-requal? (intersect (a 'a) ?) (rseq* struct:a 'a EOS EAB)) - (check-requal? (intersect (b 'a) (b 'b)) #f) - (check-requal? (intersect (b 'a) (b 'a)) (rseq* struct:b 'a EOS EAB)) - (check-requal? (intersect (b 'a) (b ?)) (rseq* struct:b 'a EOS EAB)) - (check-requal? (intersect (b 'a) ?) (rseq* struct:b 'a EOS EAB)) - - (check-requal? (intersect (a 'a) (b 'a)) #f) - - (check-exn #px"Cannot match on treaps at present" - (lambda () - (define (h a b c d) - (treap-insert (treap-insert empty-smap a b) c d)) - (intersect (h 'a 1 'b ?) - (h 'a ? 'b 2)))) - - (let ((H rseq-multi)) - (newline) - (printf "Checking that intersection with wildcard is identity-like\n") - (define m1 (pretty-print-trie* - (foldr trie-union (trie-empty) - (list (pattern->trie SA (list 'a ?)) - (pattern->trie SB (list 'b ?)) - (pattern->trie SC (list 'b 'c)))))) - (define m2 (pretty-print-trie* (pattern->trie SD ?))) - (define mi (pretty-print-trie* (trie-intersect m1 m2))) - (check-requal? mi - (H SOL (H 'a (H ? (H EOS (E (tset 'A 'D)))) - 'b (H ? (H EOS (E (tset 'B 'D))) - 'c (H EOS (E (tset 'B 'C 'D))))))) - (check-requal? (pretty-print-trie* (trie-intersect m1 m2 #:combiner (lambda (v1 v2) v1))) - m1)) - ) - -(module+ test - (define (trie-match-trie-list m1 m2) - (match-define (cons s1 s2) (trie-match-trie m1 m2 #:seed (cons (tset) (tset)))) - (list s1 s2)) - (define (trie-union* a b) - (trie-union a b #:combiner (lambda (v1 v2) - (match* (v1 v2) - [(#t v) v] - [(v #t) v] - [(v1 v2) (tset-union v1 v2)])))) - (let ((abc (foldr trie-union* (trie-empty) - (list (pattern->trie SA (list 'a ?)) - (pattern->trie SB (list 'b ?)) - (pattern->trie SC (list 'c ?))))) - (bcd (foldr trie-union* (trie-empty) - (list (pattern->trie SB (list 'b ?)) - (pattern->trie SC (list 'c ?)) - (pattern->trie SD (list 'd ?)))))) - (check-equal? (trie-match-trie-list abc abc) - (list (tset 'A 'B 'C) (tset 'A 'B 'C))) - (check-equal? (trie-match-trie abc abc - #:seed (tset) - #:combiner (lambda (v1 v2 a) (tset-union v2 a))) - (tset 'A 'B 'C)) - (check-equal? (trie-match-trie-list abc (trie-relabel bcd (lambda (old) (tset #t)))) - (list (tset 'B 'C) (tset #t))) - (check-equal? (trie-match-trie-list abc (pattern->trie Sfoo ?)) - (list (tset 'A 'B 'C) (tset 'foo))) - (check-equal? (trie-match-trie-list abc (pattern->trie Sfoo (list ? ?))) - (list (tset 'A 'B 'C) (tset 'foo))) - (check-equal? (trie-match-trie-list abc (pattern->trie Sfoo (list ? 'x))) - (list (tset 'A 'B 'C) (tset 'foo))) - (check-equal? (trie-match-trie-list abc (pattern->trie Sfoo (list ? 'x ?))) - (list (tset) (tset))))) - -(module+ test - (check-equal? (compile-projection (cons 'a 'b)) - (list SOL 'a ILM 'b EOS EOS)) - (check-equal? (compile-projection (cons 'a (?!))) - (list SOL 'a ILM SOC ? EOC EOS EOS)) - (check-equal? (compile-projection (list 'a 'b)) - (list SOL 'a 'b EOS EOS)) - (check-equal? (compile-projection (list 'a (?!))) - (list SOL 'a SOC ? EOC EOS EOS)) - - (let ((trie-project (lambda (m spec) - (trie-project m spec - #:project-success (lambda (v) #t) - #:combiner (lambda (v1 v2) #t))))) - (check-requal? (trie-project (trie-union (pattern->trie SA (list 'a 'a)) - (pattern->trie SB (list 'a 'b))) - (compile-projection (list 'a (?!)))) - (trie-union* (pattern->trie #t 'a) - (pattern->trie #t 'b))) - - (check-requal? (trie-project (trie-union (pattern->trie SA (list 'a 'a)) - (pattern->trie SB (list 'a (vector 'b 'c 'd)))) - (compile-projection (list 'a (?!)))) - (trie-union* (pattern->trie #t 'a) - (pattern->trie #t (vector 'b 'c 'd)))) - - (check-requal? (trie-project (trie-union (pattern->trie SA (list 'a 'a)) - (pattern->trie SB (list 'a (vector 'b ? 'd)))) - (compile-projection (list 'a (?!)))) - (trie-union* (pattern->trie #t 'a) - (pattern->trie #t (vector 'b ? 'd)))) - - (check-equal? (trie-key-set - (trie-project (trie-union (pattern->trie SA (list 'a 'a)) - (pattern->trie SB (list 'a 'b))) - (compile-projection (list 'a (?!))))) - (set '(a) '(b))) - - (check-equal? (trie-key-set - (trie-project (trie-union (pattern->trie SA (list 'a 'a)) - (pattern->trie SB (list 'a (vector 'b 'c 'd)))) - (compile-projection (list 'a (?!))))) - (set '(a) '(#(b c d)))) - - (check-equal? (trie-key-set - (trie-project (trie-union (pattern->trie SA (list 'a 'a)) - (pattern->trie SB (list 'a (vector 'b ? 'd)))) - (compile-projection (list 'a (?!))))) - #f) - - (check-equal? (trie-key-set - (trie-project (trie-union (pattern->trie SA (list 'a 'a)) - (pattern->trie SB (list 'a (vector 'b ? 'd)))) - (compile-projection (list 'a (?! 'a))))) - (set '(a))) - - (check-requal? (trie-project (trie-union (pattern->trie SA (cons 1 2)) - (pattern->trie SB (cons 3 4))) - (compile-projection (cons (?!) (?!)))) - (trie-union* (pattern->trie #t 1 2) - (pattern->trie #t 3 4))) - - (check-requal? (trie-project (foldr trie-union (trie-empty) - (list (pattern->trie SA (cons 1 2)) - (pattern->trie SB (cons 1 4)) - (pattern->trie SC (cons 3 4)))) - (compile-projection (cons (?!) (?!)))) - (foldr trie-union* (trie-empty) - (list (pattern->trie #t 1 2) - (pattern->trie #t 1 4) - (pattern->trie #t 3 4)))) - - (check-requal? (trie-project (foldr trie-union (trie-empty) - (list (pattern->trie SA (cons 1 2)) - (pattern->trie SB (cons 1 4)) - (pattern->trie SC (cons 3 4)))) - (compile-projection (?! (cons ? ?)))) - (foldr trie-union* (trie-empty) - (list (pattern->trie #t (cons 1 2)) - (pattern->trie #t (cons 1 4)) - (pattern->trie #t (cons 3 4))))) - - (check-requal? (trie-project (foldr trie-union (trie-empty) - (list (pattern->trie SA (cons 1 2)) - (pattern->trie SB (cons 1 4)) - (pattern->trie SC (cons 3 4)))) - (compile-projection (?! (cons 1 ?)))) - (foldr trie-union* (trie-empty) - (list (pattern->trie #t (cons 1 2)) - (pattern->trie #t (cons 1 4))))) - - (check-requal? (trie-project (foldr trie-union (trie-empty) - (list (pattern->trie SA (cons 1 2)) - (pattern->trie SB (cons 1 4)) - (pattern->trie SC (cons 3 4)))) - (compile-projection (cons (?! 1) (?!)))) - (foldr trie-union* (trie-empty) - (list (pattern->trie #t 1 2) - (pattern->trie #t 1 4)))) - - (check-requal? (trie-project (foldr trie-union (trie-empty) - (list (pattern->trie SA (cons 1 2)) - (pattern->trie SB (cons 1 4)) - (pattern->trie SC (cons 3 4)))) - (compile-projection (cons (?!) (?! 4)))) - (foldr trie-union* (trie-empty) - (list (pattern->trie #t 1 4) - (pattern->trie #t 3 4)))) - - (check-equal? (trie-key-set - (trie-project (foldr trie-union (trie-empty) - (list (pattern->trie SA (cons 1 2)) - (pattern->trie SC (cons ? 3)) - (pattern->trie SB (cons 3 4)))) - (compile-projection (cons (?!) (?!))))) - #f) - - (check-equal? (trie-key-set - (trie-project (foldr trie-union (trie-empty) - (list (pattern->trie SA (cons ? 2)) - (pattern->trie SC (cons 1 3)) - (pattern->trie SB (cons 3 4)))) - (compile-projection (cons ? (?!))))) - (set '(2) '(3) '(4))) - - (check-equal? (trie-key-set - (trie-project (trie-union (pattern->trie SA (cons 1 2)) - (pattern->trie SB (cons 3 4))) - (compile-projection (cons (?!) (?!))))) - (set '(1 2) '(3 4)))) - - (check-requal? (trie-project (trie-union (pattern->trie SA ?) - (pattern->trie SB (list 'a))) - (compile-projection (?! (list (list ?))))) - (pattern->trie SA (list (list ?)))) - - (check-equal? (projection->pattern (list 'a 'b)) (list 'a 'b)) - (check-equal? (projection->pattern (list 'a ?)) (list 'a ?)) - (check-equal? (projection->pattern (list 'a (?!))) (list 'a ?)) - (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 ? ?)))) (list 'a (vector ? ?))) - ) - -(module+ test - (newline) - (printf "Checking that subtraction from union is identity-like\n") - - (let ((A (pattern->trie SA ?)) - (B (pattern->trie SB (list (list (list (list 'foo))))))) - (check-requal? (pretty-print-trie* (trie-subtract (trie-union A B) B)) - A)) - (let ((A (pattern->trie SA ?)) - (B (trie-union (pattern->trie SB (list (list (list (list 'foo))))) - (pattern->trie SB (list (list (list (list 'bar)))))))) - (check-requal? (pretty-print-trie* (trie-subtract (trie-union A B) B)) - A)) - (let ((A (pattern->trie SA ?)) - (B (trie-union (pattern->trie SB (list (list (list (list 'foo))))) - (pattern->trie SB (list (list (list (list 'bar)))))))) - (check-requal? (pretty-print-trie* (trie-subtract (trie-union A B) A)) - B))) - -(module+ test - (let ((M (foldr trie-union (trie-empty) - (list (pattern->trie SA (list ? 2)) - (pattern->trie SC (list 1 3)) - (pattern->trie SD (list ? 3)) - (pattern->trie SB (list 3 4))))) - (S '((("(") - ((1 ((2 (((")") (((")") ("" ("A"))))))) - (3 (((")") (((")") ("" ("C" "D"))))))))) - (3 ((2 (((")") (((")") ("" ("A"))))))) - (3 (((")") (((")") ("" ("D"))))))) - (4 (((")") (((")") ("" ("B"))))))))) - (("__") ((2 (((")") (((")") ("" ("A"))))))) - (3 (((")") (((")") ("" ("D")))))))))))))) - (check-equal? (trie->jsexpr M (lambda (v) (map symbol->string (tset->list v)))) S) - (check-requal? (jsexpr->trie S (lambda (v) (make-tset hash-order (map string->symbol v)))) M))) - -(module+ test - (check-requal? (pretty-print-trie* - (pattern->trie SA (list 1 - (embedded-trie - (pattern->trie SB (list 2 3))) - 4))) - (pattern->trie SA (list 1 (list 2 3) 4))) - - (check-requal? (pretty-print-trie* - (pattern->trie SA - (list (embedded-trie (pattern->trie SB (list 1 2))) - (embedded-trie (pattern->trie SC (list 3 4)))))) - (pattern->trie SA (list (list 1 2) (list 3 4))))) - -(module+ test - (void - (pretty-print-trie* (trie-union (rwild (rsuccess SA)) - (rseq-multi ? (rsuccess SB) - 3 (rsuccess SC)))))) - -(module+ test - (void - (let ((m (trie-union (pattern->trie SA ?) - (pattern->trie SB (list ? '- ?))))) - (pretty-print-trie* m) - (pretty-print-trie*/dot m)))) - -(module+ test - (let () - (newline) - (printf "Biased-intersection test\n") - (struct obs (val) #:prefab) - (let ((object (trie-union (pattern->trie #t 1) - (pattern->trie #t 2))) - (subject (trie-union (pattern->trie #t 99) - (pattern->trie #t (obs ?))))) - (pretty-print-trie* object) - ;; The default, slow way of computing a biased intersection: - (pretty-print-trie* - (trie-project (trie-intersect (pattern->trie #t (obs (embedded-trie 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 (trie-intersect object - (trie-step subject struct:obs) - #:combiner (lambda (v1 v2) #t) - #:left-short (lambda (v r) - (trie-step r EOS)))) - (pretty-print-trie* intersection)) - (void))) diff --git a/prospect/trie.rkt b/prospect/trie.rkt index e9842d4..4075ac4 100644 --- a/prospect/trie.rkt +++ b/prospect/trie.rkt @@ -4,8 +4,12 @@ ;; TODO: examples showing the idea. -(provide (rename-out [success trie-success] - [success? trie-success?] +(require racket/contract) +(provide combiner/c trie-combiner/c) + +(provide (contract-out (rename success trie-success (-> (not/c trie?) trie?))) + ;; (rename-out [success trie-success]) + (rename-out [success? trie-success?] [success-value trie-success-value]) (rename-out [open-parenthesis ] @@ -18,7 +22,7 @@ (struct-out capture) ?! - (rename-out [empty trie-empty]) + trie-empty trie? trie trie-empty? @@ -35,10 +39,10 @@ tset-union-combiner tset-subtract-combiner - trie-union + (contract-out [trie-union trie-combiner/c]) + (contract-out [trie-intersect trie-combiner/c]) + (contract-out [trie-subtract trie-combiner/c]) trie-union-all - trie-intersect - trie-subtract trie-lookup trie-match-trie @@ -150,22 +154,25 @@ (define (?! [pattern ?]) (capture pattern)) ;; Trie -(define empty (canonicalize #f)) +(define trie-empty (canonicalize #f)) ;; Any -> Boolean ;; Predicate recognising Tries. (define (trie? x) - (or (eq? x empty) + (or (eq? x trie-empty) (success? x) (branch? x))) +(define combiner/c (-> any/c any/c trie?)) +(define trie-combiner/c (->* (trie? trie?) (#:combiner combiner/c) trie?)) + ;; Pattern Any {Pattern Any ...} -> Trie ;; Constructs a trie as the union of the given pattern/value pairings. ;; (trie) is the empty trie. (define (trie . args) (let loop ((args args)) (match args - ['() empty] + ['() trie-empty] [(list* pat val rest) (trie-union (loop rest) (pattern->trie val pat))] [_ (error 'trie "Uneven argument list: expects equal numbers of patterns and values")]))) @@ -234,7 +241,7 @@ ;; otherwise, returns the argument. (define (collapse r) (match r - [(branch (== empty-omap eq?) (== empty eq?) (== empty-smap eq?)) empty] + [(branch (== empty-omap eq?) (== trie-empty eq?) (== empty-smap eq?)) trie-empty] [_ r])) ;; Trie -> Trie @@ -242,7 +249,7 @@ ;; that is equivalent to the empty trie. Inverse of `collapse`. (define (expand r) (if (trie-empty? r) - (canonicalize (branch empty-omap empty empty-smap)) + (canonicalize (branch empty-omap trie-empty empty-smap)) r)) ;; Sigma Trie -> Trie @@ -250,12 +257,12 @@ (define (rsigma e r) (if (trie-empty? r) r - (canonicalize (branch empty-omap empty (treap-insert empty-smap e r))))) + (canonicalize (branch empty-omap trie-empty (treap-insert empty-smap e r))))) ;; [ Sigma Trie ] ... -> Trie (define (rsigma-multi . ers) (canonicalize (branch empty-omap - empty + trie-empty (let walk ((ers ers)) (match ers [(list* e r rest) (treap-insert (walk rest) e r)] @@ -287,7 +294,7 @@ (if (trie-empty? r) r (canonicalize (branch (treap-insert empty-omap (canonical-open-parenthesis arity type) r) - empty + trie-empty empty-smap)))) ;; Natural Trie -> Trie @@ -478,10 +485,10 @@ ;; (Listof Trie) [#:combiner (Any Any -> Trie)] -> Trie ;; n-ary trie-union. (define (trie-union-all tries #:combiner [combiner tset-union-combiner]) - (foldr (lambda (t acc) (trie-union t acc #:combiner combiner)) empty tries)) + (foldr (lambda (t acc) (trie-union t acc #:combiner combiner)) trie-empty tries)) ;; Any -> Trie -(define (->empty t) empty) +(define (->empty t) trie-empty) ;; Trie Trie -> Trie ;; Computes the intersection of the tries passed in. Treats them as multimaps by default. @@ -489,13 +496,13 @@ (define (combine-success r1 r2) (match* (r1 r2) [((success v1) (success v2)) (canonicalize (combiner v1 v2))] - [((? trie-empty?) _) empty] - [(_ (? trie-empty?)) empty] + [((? trie-empty?) _) trie-empty] + [(_ (? trie-empty?)) trie-empty] [(_ _) (asymmetric-trie-error 'trie-intersect r1 r2)])) (trie-combine combine-success ->empty ->empty ->empty ->empty re1 re2)) (define (empty-tset-guard s) - (if (tset-empty? s) empty (success s))) + (if (tset-empty? s) trie-empty (success s))) (define (tset-subtract-combiner s1 s2) (empty-tset-guard (tset-subtract s1 s2))) @@ -506,7 +513,7 @@ (define (combine-success r1 r2) (match* (r1 r2) [((success v1) (success v2)) (canonicalize (combiner v1 v2))] - [((? trie-empty?) _) empty] + [((? trie-empty?) _) trie-empty] [(r (? trie-empty?)) r] [(_ _) (asymmetric-trie-error 'trie-subtract r1 r2)])) (trie-combine combine-success ->empty values values ->empty re1 re2)) @@ -551,7 +558,7 @@ (walk vs1 (rlookup-sigma r (canonicalize v)))])])) (walk (list v) r)) -;; Trie Trie -> Value +;; Trie Trie Value (Any Any Value -> Value) -> Value ;; ;; Similar to trie-lookup, but instead of a single key, ;; accepts a Trie serving as *multiple* simultaneously-examined @@ -591,7 +598,7 @@ (define (trie-append m0 m-tail-fn) (let walk ((m m0)) (match m - [(? trie-empty?) empty] + [(? trie-empty?) trie-empty] [(success v) (canonicalize (m-tail-fn v))] [(branch os w0 h) (define w (walk w0)) @@ -611,7 +618,7 @@ (define (trie-relabel t f) (trie-append t (lambda (v) (match (f v) - [#f empty] + [#f trie-empty] [result (success result)])))) ;; Trie (U OpenParenthesis Sigma) -> Trie @@ -621,9 +628,9 @@ (define (trie-prune-branch m key) (match* (m key) [((branch os w h) (open-parenthesis arity _)) - (canonicalize (collapse (struct-copy branch m [opens (rupdate arity w os key empty)])))] + (canonicalize (collapse (struct-copy branch m [opens (rupdate arity w os key trie-empty)])))] [((branch os w h) _) - (canonicalize (collapse (struct-copy branch m [sigmas (rupdate 0 w h key empty)])))] + (canonicalize (collapse (struct-copy branch m [sigmas (rupdate 0 w h key trie-empty)])))] [(_ _) m])) ;; Trie (U OpenParenthesis Sigma) -> Trie @@ -633,7 +640,7 @@ (rlookup-open m key)] [((? branch?) _) (rlookup-sigma m key)] - [(_ _) empty])) + [(_ _) trie-empty])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Projection @@ -734,7 +741,7 @@ [other0 (define other (canonicalize other0)) (rsigma other (walk/capture (rlookup-sigma t other) specs-rest kont))])] - [_ empty])])) + [_ trie-empty])])) ;; Trie (Listof Projection) (Trie -> Trie) -> Trie ;; As walk/capture, but without capturing. @@ -773,12 +780,12 @@ [other0 (define other (canonicalize other0)) (walk (rlookup-sigma t other) specs-rest kont)])] - [_ empty])])) + [_ trie-empty])])) (walk whole-t (list whole-spec) (match-lambda [(success v) (canonicalize (project-success v))] - [_ empty]))) + [_ trie-empty]))) ;; ParenType (Listof Value) -> Value ;; Wraps a sequence of values in the given parenthesis type, reconstructing the "original" value. @@ -1025,7 +1032,7 @@ (walk rest)]))) (check-matches - empty + trie-empty (list 'z 'x) "" 'foo "" (list (list 'z (list 'z))) "") @@ -1313,21 +1320,21 @@ (check-requal? (intersect 123 ?) (rsigma 123 EAB)) (check-requal? (intersect (list ? 2) (list 1 ?)) (rlist 2 (rsigma* 1 2 EAB))) (check-requal? (intersect (list 1 2) ?) (rlist 2 (rsigma* 1 2 EAB))) - (check-requal? (intersect 1 2) empty) + (check-requal? (intersect 1 2) trie-empty) (check-requal? (intersect (list 1 2) (list ? 2)) (rlist 2 (rsigma* 1 2 EAB))) (check-requal? (intersect (vector 1 2) (vector 1 2)) (rvector 2 (rsigma* 1 2 EAB))) - (check-requal? (intersect (vector 1 2) (vector 1 2 3)) empty) + (check-requal? (intersect (vector 1 2) (vector 1 2 3)) trie-empty) - (check-requal? (intersect (a 'a) (a 'b)) empty) + (check-requal? (intersect (a 'a) (a 'b)) trie-empty) (check-requal? (intersect (a 'a) (a 'a)) (ropen 1 struct:a (rsigma* 'a EAB))) (check-requal? (intersect (a 'a) (a ?)) (ropen 1 struct:a (rsigma* 'a EAB))) (check-requal? (intersect (a 'a) ?) (ropen 1 struct:a (rsigma* 'a EAB))) - (check-requal? (intersect (b 'a) (b 'b)) empty) + (check-requal? (intersect (b 'a) (b 'b)) trie-empty) (check-requal? (intersect (b 'a) (b 'a)) (ropen 1 struct:b (rsigma* 'a EAB))) (check-requal? (intersect (b 'a) (b ?)) (ropen 1 struct:b (rsigma* 'a EAB))) (check-requal? (intersect (b 'a) ?) (ropen 1 struct:b (rsigma* 'a EAB))) - (check-requal? (intersect (a 'a) (b 'a)) empty) + (check-requal? (intersect (a 'a) (b 'a)) trie-empty) (check-exn #px"Cannot match on treaps at present" (lambda () @@ -1584,8 +1591,7 @@ (define full (trie ? default-label)) (define positive-trie/e - (pam/e (lambda (pats) (foldr trie-union empty - (map (lambda (pat) (trie pat default-label)) pats))) + (pam/e (lambda (pats) (trie-union-all (map (lambda (pat) (trie pat default-label)) pats))) #:contract trie? (listof/e pattern/e))) @@ -1664,7 +1670,7 @@ (define (reconstruct t) (match-define `((added ,a ...) (removed ,r ...)) (trie->patterns t)) (foldr (lambda (p t) (trie-subtract t (trie p default-label))) - (foldr (lambda (p t) (trie-union t (trie p default-label))) empty a) + (foldr (lambda (p t) (trie-union t (trie p default-label))) trie-empty a) r)) ;; (newline) (for ((i 15)) (void (time (reconstruct (random-instance positive-trie/e))))) @@ -1687,16 +1693,16 @@ complex-trie/e complex-trie/e) (check-property #:name 'empty-is-identity-for-union - (lambda (t) (and (requal? t (trie-union t empty)) - (requal? t (trie-union empty t)))) + (lambda (t) (and (requal? t (trie-union t trie-empty)) + (requal? t (trie-union trie-empty t)))) complex-trie/e) (check-property #:name 'full-is-zero-for-union (lambda (t) (and (requal? full (trie-union t full)) (requal? full (trie-union full t)))) complex-trie/e) (check-property #:name 'empty-is-zero-for-intersection - (lambda (t) (and (requal? empty (trie-intersect t empty)) - (requal? empty (trie-intersect empty t)))) + (lambda (t) (and (requal? trie-empty (trie-intersect t trie-empty)) + (requal? trie-empty (trie-intersect trie-empty t)))) complex-trie/e) (check-property #:name 'full-is-identity-for-intersection (lambda (t) (and (requal? t (trie-intersect t full))