Rename "matcher" to "trie".

This commit is contained in:
Tony Garnock-Jones 2016-01-21 21:55:41 -05:00
parent e1c5fd4ac1
commit 3c5a6f00ed
18 changed files with 748 additions and 748 deletions

38
FAQ.md
View File

@ -24,16 +24,16 @@
character to turn off the corresponding trace facility; the default
value of the variable is just the empty-string.
- For a more fine-grained approach, there are several ways to print specific patches/matchers inside your program:
- For a more fine-grained approach, there are several ways to print specific patches/tries inside your program:
```racket
pretty-print-patch ;; (patch matcher matcher)
pretty-print-matcher ;; matchers *are* tries
pretty-print-patch ;; (patch trie trie)
pretty-print-trie
patch->pretty-string
matcher->pretty-string
matcher->abstract-graph
trie->pretty-string
trie->abstract-graph
abstract-graph->dot
matcher->dot ;; handy for visualizing the trie structure
trie->dot ;; handy for visualizing the trie structure
```
* How do spawned processes communicate with one another?
@ -130,42 +130,42 @@
* How do I get the assertions out of a patch?
- A patch consists of two matchers, added and removed
- To get assertions out of a matcher, you have to decide what sort of assertions
- A patch consists of two tries, added and removed
- To get assertions out of a trie, you have to decide what sort of assertions
you are interested in, compile a pattern for those assertions, and pass that
along with the matcher to `matcher-project/set`.
- `matcher-project/set` takes a matcher and a pattern and returns a set of lists
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 ,(?!) ,(?!)))```
* 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 `matcher-project/set` contain the captured values in
* 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 result of
```racket
(matcher-project/set (patch-added p)
(compile-projection `(posn ,(?!) ,(?!))))
(trie-project/set (patch-added p)
(compile-projection `(posn ,(?!) ,(?!))))
```
would be `(set (list 2 3))`.
- If we only cared about the y position, we could instead do
```racket
(matcher-project/set (patch-added p)
(compile-projection `(posn ,? ,(?!))))
(trie-project/set (patch-added p)
(compile-projection `(posn ,? ,(?!))))
```
and get the result `(set (list 3))`.
- an entire structure can be captured by passing a pattern as an argument to
`(?!)`.
```racket
(matcher-project/set (patch-added p)
(compile-projection (?! `(posn ,? ,?))))
(trie-project/set (patch-added p)
(compile-projection (?! `(posn ,? ,?))))
```
with the same example yields `(set (list ('posn 2 3))`.
- `matcher-project/set/single` is like mapping `car` over the result of
`matcher-project/set`. See also `project-assertions`.
- `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
against both the added and removed bits of a patch.

View File

@ -273,7 +273,7 @@
[(? patch/removed? p)
(define continuation-table (actor-state-continuation-table s))
(define quit?
(for/or [(callee-id (matcher-project/set/single (patch-removed p) link-active-projection))]
(for/or [(callee-id (trie-project/set/single (patch-removed p) link-active-projection))]
(hash-has-key? continuation-table callee-id)))
(if quit? ;; TODO: raise exception instead? Signal the cause of the quit somehow?
(quit)
@ -471,13 +471,13 @@
#,(if maybe-Pred-stx
#`(if #,maybe-Pred-stx
(compute-new-assertions)
(matcher-empty))
(trie-empty))
#`(compute-new-assertions)))
(and (not (eq? old-assertions new-assertions))
((extend-pending-patch
#,endpoint-index
(patch-seq (patch (matcher-empty) old-assertions)
(patch new-assertions (matcher-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)
@ -491,7 +491,7 @@
[(? #,(if asserted? #'patch/added? #'patch/removed?) p)
(sequence-transitions0*
s
(for/list [(entry (in-set (matcher-project/set
(for/list [(entry (in-set (trie-project/set
#,(if asserted?
#'(patch-added p)
#'(patch-removed p))

View File

@ -68,8 +68,8 @@
removed)))
(lambda (w1 w2) (< (window-z w1) (window-z w2))))]
[halted? (or (and (bb-halted? b)
(not (matcher-match-value (patch-removed p) 'stop #f)))
(matcher-match-value (patch-added p) 'stop #f))]))
(not (trie-lookup (patch-removed p) 'stop #f)))
(trie-lookup (patch-added p) 'stop #f))]))
(define (deliver b e)
(clean-transition (network-handle-event e (bb-network b))))

View File

@ -19,16 +19,16 @@
wildcard?
?!
(struct-out capture)
pretty-print-matcher
matcher->pretty-string
matcher-non-empty?
matcher-empty?
matcher-empty
pretty-print-trie
trie->pretty-string
trie-non-empty?
trie-empty?
trie-empty
projection->pattern
compile-projection
matcher-project
matcher-project/set
matcher-project/set/single
trie-project
trie-project/set
trie-project/set/single
project-assertions
event?
@ -132,20 +132,20 @@
(define (observe-at-meta pattern level)
(if (zero? level)
(pattern->matcher #t (observe pattern))
(matcher-union
(pattern->matcher #t (observe (prepend-at-meta pattern level)))
(pattern->matcher #t (at-meta (embedded-matcher (observe-at-meta pattern (- level 1))))))))
(pattern->trie #t (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))))))))
(define (assert pattern #:meta-level [level 0])
(patch (pattern->matcher #t (prepend-at-meta pattern level)) (matcher-empty)))
(patch (pattern->trie #t (prepend-at-meta pattern level)) (trie-empty)))
(define (retract pattern #:meta-level [level 0])
(patch (matcher-empty) (pattern->matcher #t (prepend-at-meta pattern level))))
(patch (trie-empty) (pattern->trie #t (prepend-at-meta pattern level))))
(define (sub pattern #:meta-level [level 0])
(patch (observe-at-meta pattern level) (matcher-empty)))
(patch (observe-at-meta pattern level) (trie-empty)))
(define (unsub pattern #:meta-level [level 0])
(patch (matcher-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))
@ -428,7 +428,7 @@
(newline p)
(fprintf p " process ~a, behavior ~v, CLAIMS:\n" pid (hash-ref behaviors pid #f))
(display (indented-port-output 6 (lambda (p)
(pretty-print-matcher (mux-interests-of mux pid) p)))
(pretty-print-trie (mux-interests-of mux pid) p)))
p)
(newline p)))

View File

@ -14,7 +14,7 @@
on-claim)
;; A DemandMatcher keeps track of demand for services based on some
;; Projection over a Matcher, as well as a collection of functions
;; Projection over a Trie, as well as a collection of functions
;; that can be used to increase supply in response to increased
;; demand, or handle a sudden drop in supply for which demand still
;; exists.
@ -58,10 +58,10 @@
(when (not added-demand) (error 'demand-matcher "Wildcard demand of ~v:\n~a"
demand-spec
(matcher->pretty-string (patch-added p))))
(trie->pretty-string (patch-added p))))
(when (not added-supply) (error 'demand-matcher "Wildcard supply of ~v:\n~a"
supply-spec
(matcher->pretty-string (patch-added p))))
(trie->pretty-string (patch-added p))))
(set! supply (set-union supply added-supply))
(set! demand (set-subtract demand removed-demand))
@ -107,8 +107,8 @@
(sub (projection->pattern supply-spec) #:meta-level meta-level)
(pub (projection->pattern supply-spec) #:meta-level meta-level))))
;; (Matcher (Option (Setof (Listof Value))) ... -> (Option (Constreeof Action)))
;; Matcher Projection ...
;; (Trie (Option (Setof (Listof Value))) ... -> (Option (Constreeof Action)))
;; Trie Projection ...
;; -> Action
;; Spawns a process that observes the given projections. Any time the
;; environment's interests change in a relevant way, calls
@ -127,7 +127,7 @@
[(? patch? p)
(define new-aggregate (update-interests current-aggregate p))
(define projection-results
(map (lambda (p) (matcher-project/set new-aggregate p)) projections))
(map (lambda (p) (trie-project/set new-aggregate p)) projections))
(define maybe-spawn (apply check-and-maybe-spawn-fn
new-aggregate
projection-results))
@ -140,8 +140,8 @@
(list
(when timeout-msec (message (set-timer timer-id timeout-msec 'relative)))
(spawn on-claim-handler
(matcher-empty)
(patch-seq (patch base-interests (matcher-empty))
(trie-empty)
(patch-seq (patch base-interests (trie-empty))
(patch-seq* (map projection->pattern projections))
(sub (timer-expired timer-id ?))))))

View File

@ -57,7 +57,7 @@
(for/fold [(count count)
(actions-rev '())
(interrupt-clearing-patch empty-patch)]
[(expiry (matcher-project/set/single added expiry-projection))]
[(expiry (trie-project/set/single added expiry-projection))]
(values (- count 1)
(cons (message expiry) actions-rev)
(patch-seq interrupt-clearing-patch

View File

@ -59,7 +59,7 @@
(spawn (lambda (e s)
(match e
[(? patch? p)
(cond [(matcher-empty? (patch-removed p)) #f] ;; peer hasn't quit yet: do nothing.
(cond [(trie-empty? (patch-removed p)) #f] ;; peer hasn't quit yet: do nothing.
[else (channel-put control-ch 'quit)
(quit)])]
[(message (at-meta (? udp-packet? p)))

View File

@ -152,7 +152,7 @@
[endpoints
(hash-remove (endpoint-group-endpoints g) eid)])
eid
(patch (matcher-empty) (pattern->matcher #t ?)))]
(patch (trie-empty) (pattern->trie #t ?)))]
[(as-endpoint other-eid inner-endpoint-action)
(interpret-endpoint-actions cumulative-patch actions g other-eid inner-endpoint-action)]))
@ -177,4 +177,4 @@
(fprintf p " - ~a endpoints\n" (hash-count endpoints))
(fprintf p " - next eid: ~a\n" (mux-next-pid mux))
(fprintf p " - routing table:\n")
(pretty-print-matcher (mux-routing-table mux) p))
(pretty-print-trie (mux-routing-table mux) p))

View File

@ -18,7 +18,7 @@
#f)
(define (updater e _)
(if (and (patch? e) (matcher-non-empty? (patch-added e)))
(if (and (patch? e) (trie-non-empty? (patch-added e)))
(quit (list (message (deposit +100))
(message (deposit -30))))
#f))

View File

@ -87,7 +87,7 @@
[(? patch? p)
(define-values (added-observations removed-observations)
(patch-project/set/single p observation-projector))
(define added-updates (matcher-project/set/single (patch-added p) update-projector))
(define added-updates (trie-project/set/single (patch-added p) update-projector))
(transition-bind (adjust-observations added-observations removed-observations)
(for/fold [(t (transition old-state '()))]
[(suggestion (in-set added-updates))]
@ -105,7 +105,7 @@
(spawn (lambda (e s)
(match e
[(? patch? p)
(match (set->list (matcher-project/set/single (patch-added p) binding-projector))
(match (set->list (trie-project/set/single (patch-added p) binding-projector))
['() #f]
[(list (binding _ (== epoch) (== version) _)) #f]
[(list (binding _ (== epoch) (== (+ version 1)) (== value))) (quit (on-complete))]

View File

@ -29,7 +29,7 @@
[(? patch/removed?)
(printf "Retracting ~v because dependencies ~v vanished\n"
record
(set->list (matcher-project/set (patch-removed e) (compile-projection (?!)))))
(set->list (trie-project/set (patch-removed e) (compile-projection (?!)))))
(quit)]
[(message `(retract ,(== record)))
(printf "Retracting ~v because we were told to explicitly\n" record)
@ -48,7 +48,7 @@
(match e
[(? patch?)
(transition s
(for/list [(AB (matcher-project/set
(for/list [(AB (trie-project/set
(patch-added e)
(compile-projection `(parent ,(?!) ,(?!)))))]
(match-define (list A B) AB)
@ -62,7 +62,7 @@
(match e
[(? patch?)
(transition s
(for/list [(AC (matcher-project/set
(for/list [(AC (trie-project/set
(patch-added e)
(compile-projection `(parent ,(?!) ,(?!)))))]
(match-define (list A C) AC)
@ -70,19 +70,19 @@
(spawn (lambda (e s)
(define removed-parents
(and (patch? e)
(matcher-project (patch-removed e)
(compile-projection
`(parent ,(?!) ,(?!))))))
(if (matcher-non-empty? removed-parents)
(trie-project (patch-removed e)
(compile-projection
`(parent ,(?!) ,(?!))))))
(if (trie-non-empty? removed-parents)
(begin
(printf
"Inductive step for ~v retracted because of removal ~v\n"
`(parent ,A ,C)
(matcher-key-set removed-parents))
(trie-key-set removed-parents))
(quit))
(and (patch? e)
(transition s
(for/list [(CB (matcher-project/set
(for/list [(CB (trie-project/set
(patch-added e)
(compile-projection
`(ancestor ,(?!) ,(?!)))))]
@ -111,8 +111,8 @@
;; (match e
;; [(? patch/removed?) (quit)]
;; [(? patch?)
;; (define new-facts (matcher-union old-facts (patch-added e)))
;; (define triples (matcher-project/set new-facts
;; (define new-facts (trie-union old-facts (patch-added e)))
;; (define triples (trie-project/set new-facts
;; (compile-projection
;; `(,(?!) ,(?!) ,(?!)))))
;; (printf "Learned new facts: ~v\n" triples)
@ -127,7 +127,7 @@
;; `(ancestor ,A ,B))
;; (assert `(ancestor ,A ,B))))]
;; [_ #f]))
;; (matcher-empty)
;; (trie-empty)
;; (patch-seq
;; (sub `(parent ,A ,B))
;; (sub `(parent ,A ,?))

View File

@ -65,7 +65,7 @@
[(? patch? p)
(define-values (added-observations removed-observations)
(patch-project/set/single p observation-projector))
(define added-updates (matcher-project/set/single (patch-added p) update-projector))
(define added-updates (trie-project/set/single (patch-added p) update-projector))
(transition-bind (adjust-observations added-observations removed-observations)
(for/fold [(t (transition old-state '()))]
[(suggestion (in-set added-updates))]
@ -83,7 +83,7 @@
(spawn (lambda (e s)
(match e
[(? patch? p)
(match (set->list (matcher-project/set/single (patch-added p) binding-projector))
(match (set->list (trie-project/set/single (patch-added p) binding-projector))
['() #f]
[(list (binding _ (== epoch) (== version) _)) #f]
[(list (binding _ (== epoch) (== (+ version 1)) (== value))) (quit (on-complete))]

View File

@ -57,7 +57,7 @@
;; Interests -> (Listof RacketEvent)
;; Projects out the active event subscriptions from the given interests.
(define (extract-active-events interests)
(define es (matcher-project/set/single interests event-projection))
(define es (trie-project/set/single interests event-projection))
;; TODO: how should the following error be handled, ideally?
;; In principle, security restrictions should make it impossible.
;; But absent those, what should be done? Should an offending
@ -78,9 +78,9 @@
(define (run-ground . boot-actions)
(let await-interrupt ((inert? #f)
(w (make-network boot-actions))
(interests (matcher-empty)))
;; (log-info "GROUND INTERESTS:\n~a" (matcher->pretty-string interests))
(if (and inert? (matcher-empty? interests))
(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")
(void))
(let ((e (apply sync

View File

@ -38,7 +38,7 @@
(define (meta-label? x) (eq? x 'meta))
(define (make-mux)
(mux 0 (matcher-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 (matcher-empty) (pattern->matcher #t ?))))
(mux-update-stream m label (patch (trie-empty) (pattern->trie #t ?))))
(define (mux-update-stream m label delta-orig)
(define old-interests (mux-interests-of m label))
@ -60,7 +60,7 @@
(define new-routing-table (apply-patch old-routing-table delta))
(values (struct-copy mux m
[routing-table new-routing-table]
[interest-table (if (matcher-empty? new-interests)
[interest-table (if (trie-empty? new-interests)
(hash-remove (mux-interest-table m) label)
(hash-set (mux-interest-table m) label new-interests))])
label
@ -91,21 +91,21 @@
(compute-aggregate-patch delta label old-routing-table #:remove-meta? #t)))))
(define (compute-affected-pids routing-table delta)
(define cover (matcher-union (patch-added delta) (patch-removed delta)))
(matcher-match-matcher cover
(matcher-step routing-table struct:observe)
#:seed (datum-tset)
#:combiner (lambda (v1 v2 acc) (tset-union v2 acc))
#:left-short (lambda (v r acc)
(tset-union acc (success-value (matcher-step r EOS))))))
(define cover (trie-union (patch-added delta) (patch-removed delta)))
(trie-match-trie cover
(trie-step routing-table struct:observe)
#:seed (datum-tset)
#:combiner (lambda (v1 v2 acc) (tset-union v2 acc))
#:left-short (lambda (v r acc)
(tset-union acc (success-value (trie-step r EOS))))))
(define (mux-route-message m body)
(if (matcher-match-value (mux-routing-table m) body #f) ;; some other stream has declared body
(if (trie-lookup (mux-routing-table m) body #f) ;; some other stream has declared body
'()
(tset->list (matcher-match-value (mux-routing-table m) (observe body) (datum-tset)))))
(tset->list (trie-lookup (mux-routing-table m) (observe body) (datum-tset)))))
(define (mux-interests-of m label)
(hash-ref (mux-interest-table m) label (matcher-empty)))
(hash-ref (mux-interest-table m) label (trie-empty)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -115,5 +115,5 @@
(fprintf p " - ~a labelled entities with claims\n" (hash-count interest-table))
(fprintf p " - next label: ~a\n" next-pid)
(fprintf p " - routing-table:\n")
(display (indented-port-output 3 (lambda (p) (pretty-print-matcher routing-table p))) p)
(display (indented-port-output 3 (lambda (p) (pretty-print-trie routing-table p))) p)
(newline p))

View File

@ -57,7 +57,7 @@
(struct at-meta (claim) #:prefab)
(struct advertise (claim) #:prefab)
(define empty-patch (patch (matcher-empty) (matcher-empty)))
(define empty-patch (patch (trie-empty) (trie-empty)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -65,24 +65,24 @@
(define (patch-empty? p)
(and (patch? p)
(matcher-empty? (patch-added p))
(matcher-empty? (patch-removed p))))
(trie-empty? (patch-added p))
(trie-empty? (patch-removed p))))
(define (patch-non-empty? p)
(and (patch? p)
(or (matcher-non-empty? (patch-added p))
(matcher-non-empty? (patch-removed p)))))
(or (trie-non-empty? (patch-added p))
(trie-non-empty? (patch-removed p)))))
(define (patch/added? p) (and (patch? p) (matcher-non-empty? (patch-added p))))
(define (patch/removed? p) (and (patch? p) (matcher-non-empty? (patch-removed p))))
(define (patch/added? p) (and (patch? p) (trie-non-empty? (patch-added p))))
(define (patch/removed? p) (and (patch? p) (trie-non-empty? (patch-removed p))))
(define (lift-patch p)
(match-define (patch in out) p)
(patch (pattern->matcher #t (at-meta (embedded-matcher in)))
(pattern->matcher #t (at-meta (embedded-matcher out)))))
(patch (pattern->trie #t (at-meta (embedded-trie in)))
(pattern->trie #t (at-meta (embedded-trie out)))))
(define (drop-interests pi)
(matcher-project pi at-meta-proj
(trie-project pi at-meta-proj
#:project-success (lambda (v) #t)
#:combiner (lambda (v1 v2) #t)))
@ -92,10 +92,10 @@
(drop-interests out)))
(define (strip-interests g)
(matcher-relabel g (lambda (v) #t)))
(trie-relabel g (lambda (v) #t)))
(define (label-interests g label)
(matcher-relabel g (lambda (v) label)))
(trie-relabel g (lambda (v) label)))
(define (strip-patch p)
(patch (strip-interests (patch-added p))
@ -113,8 +113,8 @@
;; arguments.
(define (limit-patch p bound)
(match-define (patch in out) p)
(patch (matcher-subtract in bound #:combiner (lambda (v1 v2) #f))
(matcher-intersect out bound #:combiner (lambda (v1 v2) v1))))
(patch (trie-subtract in bound #:combiner (lambda (v1 v2) #f))
(trie-intersect out bound #:combiner (lambda (v1 v2) 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
@ -125,9 +125,9 @@
;; label sets allowed to contain arbitrary elements.
(define (limit-patch/routing-table p bound)
(match-define (patch in out) p)
(patch (matcher-subtract in bound)
(matcher-intersect out bound
#:combiner (lambda (v1 v2) (empty-tset-guard (tset-intersect v1 v2))))))
(patch (trie-subtract in bound)
(trie-intersect out bound
#:combiner (lambda (v1 v2) (empty-tset-guard (tset-intersect v1 v2))))))
;; Entries labelled with `label` may already exist in `base`; the
;; patch `p` MUST already have been limited to add only where no
@ -189,23 +189,23 @@
(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.
(patch (matcher-subtract (patch-added p) base #:combiner add-combiner)
(matcher-subtract (patch-removed p) base #:combiner rem-combiner)))
(patch (trie-subtract (patch-added p) base #:combiner add-combiner)
(trie-subtract (patch-removed p) base #:combiner rem-combiner)))
;; For use by Matchers leading to (Setof Label).
;; For use by Tries leading to (Setof Label).
(define (apply-patch base p)
(match-define (patch in out) p)
(matcher-union (matcher-subtract base out) in))
(trie-union (trie-subtract base out) in))
;; Like apply-patch, but for use by Matchers leading to True.
;; Like apply-patch, but for use by Tries leading to True.
(define (update-interests base p)
(match-define (patch in out) p)
(matcher-union (matcher-subtract base out #:combiner (lambda (v1 v2) #f)) in
#:combiner (lambda (v1 v2) #t)))
(trie-union (trie-subtract base out #:combiner (lambda (v1 v2) #f)) in
#:combiner (lambda (v1 v2) #t)))
(define (unapply-patch base p)
(match-define (patch in out) p)
(matcher-union (matcher-subtract base in) out))
(trie-union (trie-subtract base in) out))
(define (compose-patch p2 p1) ;; p2 after p1
;; Can be defined as (patch (apply-patch in1 p2) (unapply-patch out1 p2)),
@ -213,8 +213,8 @@
(match-define (patch in1 out1) p1)
(match-define (patch in2 out2) p2)
(patch (update-interests in1 p2)
(matcher-union (matcher-subtract out1 in2 #:combiner (lambda (v1 v2) #f)) out2
#:combiner (lambda (v1 v2) #t))))
(trie-union (trie-subtract out1 in2 #:combiner (lambda (v1 v2) #f)) out2
#:combiner (lambda (v1 v2) #t))))
(define (patch-seq . patches) (patch-seq* patches))
@ -224,34 +224,34 @@
[(cons p rest) (compose-patch (patch-seq* rest) p)]))
(define (compute-patch old-base new-base)
(patch (matcher-subtract new-base old-base)
(matcher-subtract old-base new-base)))
(patch (trie-subtract new-base old-base)
(trie-subtract old-base new-base)))
(define (biased-intersection object subject)
(matcher-intersect object
(matcher-step subject struct:observe)
#:combiner (lambda (v1 v2) #t)
#:left-short (lambda (v r) (matcher-step r EOS))))
(trie-intersect object
(trie-step subject struct:observe)
#:combiner (lambda (v1 v2) #t)
#:left-short (lambda (v r) (trie-step r EOS))))
(define (view-patch p interests)
(patch (biased-intersection (patch-added p) interests)
(biased-intersection (patch-removed p) interests)))
(define (patch-union p1 p2)
(patch (matcher-union (patch-added p1) (patch-added p2))
(matcher-union (patch-removed p1) (patch-removed p2))))
(patch (trie-union (patch-added p1) (patch-added p2))
(trie-union (patch-removed p1) (patch-removed p2))))
(define (patch-project p spec)
(match-define (patch in out) p)
(patch (matcher-project in spec) (matcher-project out spec)))
(patch (trie-project in spec) (trie-project out spec)))
(define (patch-project/set p spec)
(match-define (patch in out) p)
(values (matcher-project/set in spec) (matcher-project/set out spec)))
(values (trie-project/set in spec) (trie-project/set out spec)))
(define (patch-project/set/single p spec)
(match-define (patch in out) p)
(values (matcher-project/set/single in spec) (matcher-project/set/single out spec)))
(values (trie-project/set/single in spec) (trie-project/set/single out spec)))
(define (pretty-print-patch p [port (current-output-port)])
(display (patch->pretty-string p) port))
@ -259,38 +259,38 @@
(define (patch->pretty-string p)
(match-define (patch in out) p)
(format "<<<<<<<< Removed:\n~a======== Added:\n~a>>>>>>>>\n"
(matcher->pretty-string out)
(matcher->pretty-string in)))
(trie->pretty-string out)
(trie->pretty-string in)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(define (set->matcher label xs)
(for/fold [(acc (matcher-empty))] [(x (in-set xs))]
(matcher-union acc (pattern->matcher label x))))
(define (set->trie label 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.
(define (project-routing-table R label-set)
(matcher-intersect R
(pattern->matcher label-set ?)
#:combiner (lambda (v1 v2) (empty-tset-guard (tset-intersect v1 v2)))))
(trie-intersect R
(pattern->trie label-set ?)
#:combiner (lambda (v1 v2) (empty-tset-guard (tset-intersect v1 v2)))))
(define tset datum-tset)
(define (sanity-check-examples)
(define SP (tset 'P))
(define m0 (matcher-empty))
(define ma (pattern->matcher SP 'a))
(define mb (pattern->matcher SP 'b))
(define mc (pattern->matcher SP 'c))
(define mab (matcher-union ma mb))
(define mbc (matcher-union mb mc))
(define m* (pattern->matcher SP ?))
(define mA (pattern->matcher SP (at-meta 'a)))
(define mAb (matcher-union mA mb))
(define m0 (trie-empty))
(define ma (pattern->trie SP 'a))
(define mb (pattern->trie SP 'b))
(define mc (pattern->trie SP 'c))
(define mab (trie-union ma mb))
(define mbc (trie-union mb mc))
(define m* (pattern->trie SP ?))
(define mA (pattern->trie SP (at-meta 'a)))
(define mAb (trie-union mA mb))
(printf "\nmab:\n")
(void (pretty-print-matcher mab))
(void (pretty-print-trie mab))
(printf "\ncompute-patch ma mb:\n")
(void (pretty-print-patch (compute-patch ma mb)))
@ -302,7 +302,7 @@
(void (pretty-print-patch (limit-patch (patch m0 m*) mab)))
(printf "\napply mb (limit m*/m0 mab):\n")
(void (pretty-print-matcher (apply-patch mb (limit-patch (patch m* m0) mab))))
(void (pretty-print-trie (apply-patch mb (limit-patch (patch m* m0) mab))))
(printf "\nlimit mbc/ma ma:\n")
(void (pretty-print-patch (limit-patch (patch mbc ma) ma)))
@ -376,11 +376,11 @@
(let* ((pre-patch-a-keys (set 1 3 5 7))
(pre-patch-b-keys (set 2 3 6 7))
(pre-patch-keys (set 1 2 3 5 6 7))
(ma (set->matcher (tset 'a) pre-patch-a-keys))
(mb (set->matcher (tset 'b) pre-patch-b-keys))
(R (matcher-union ma mb))
(pa-raw (patch (set->matcher (tset 'a) (set 0 1 2 3 ))
(set->matcher (tset 'a) (set 4 5 6 7))))
(ma (set->trie (tset 'a) pre-patch-a-keys))
(mb (set->trie (tset 'b) pre-patch-b-keys))
(R (trie-union ma mb))
(pa-raw (patch (set->trie (tset 'a) (set 0 1 2 3 ))
(set->trie (tset 'a) (set 4 5 6 7))))
(pa1 (limit-patch pa-raw ma))
(pa2 (limit-patch/routing-table pa-raw R))
(post-patch-a-keys (set 0 1 2 3 ))
@ -392,49 +392,49 @@
(p-aggregate2 (compute-aggregate-patch pa2 'a R))
(R1 (apply-patch R pa1))
(R2 (apply-patch R pa2))
(R-relabeled (matcher-relabel R (lambda (v) (tset 'x))))
(R-relabeled (trie-relabel R (lambda (v) (tset 'x))))
(R1-relabeled (apply-patch R-relabeled (label-patch (strip-patch p-aggregate1) (tset 'x))))
(R2-relabeled (apply-patch R-relabeled (label-patch (strip-patch p-aggregate2) (tset 'x)))))
(check-equal? pa1 pa2)
(check-equal? (matcher-match-value R 0 (tset)) (tset))
(check-equal? (matcher-match-value R 1 (tset)) (tset 'a))
(check-equal? (matcher-match-value R 2 (tset)) (tset 'b))
(check-equal? (matcher-match-value R 3 (tset)) (tset 'a 'b))
(check-equal? (matcher-match-value R 4 (tset)) (tset))
(check-equal? (matcher-match-value R 5 (tset)) (tset 'a))
(check-equal? (matcher-match-value R 6 (tset)) (tset 'b))
(check-equal? (matcher-match-value R 7 (tset)) (tset 'a 'b))
(check-equal? (matcher-key-set/single (project-routing-table R (tset 'a))) pre-patch-a-keys)
(check-equal? (matcher-key-set/single (project-routing-table R (tset 'b))) pre-patch-b-keys)
(check-equal? (matcher-key-set/single R) pre-patch-keys)
(check-equal? (matcher-key-set/single R-relabeled) pre-patch-keys)
(check-equal? (trie-lookup R 0 (tset)) (tset))
(check-equal? (trie-lookup R 1 (tset)) (tset 'a))
(check-equal? (trie-lookup R 2 (tset)) (tset 'b))
(check-equal? (trie-lookup R 3 (tset)) (tset 'a 'b))
(check-equal? (trie-lookup R 4 (tset)) (tset))
(check-equal? (trie-lookup R 5 (tset)) (tset 'a))
(check-equal? (trie-lookup R 6 (tset)) (tset 'b))
(check-equal? (trie-lookup R 7 (tset)) (tset 'a 'b))
(check-equal? (trie-key-set/single (project-routing-table R (tset 'a))) pre-patch-a-keys)
(check-equal? (trie-key-set/single (project-routing-table R (tset 'b))) pre-patch-b-keys)
(check-equal? (trie-key-set/single R) pre-patch-keys)
(check-equal? (trie-key-set/single R-relabeled) pre-patch-keys)
(define (post-checks R* R*-relabeled p-aggregate)
(check-equal? (matcher-key-set/single (project-routing-table R* (tset 'a))) post-patch-a-keys)
(check-equal? (matcher-key-set/single (project-routing-table R* (tset 'b))) post-patch-b-keys)
(check-equal? (matcher-key-set/single R*) post-patch-keys)
(check-equal? (matcher-key-set/single R*-relabeled) post-patch-keys)
(check-equal? (matcher-key-set/single (patch-added p-aggregate)) aggregate-added)
(check-equal? (matcher-key-set/single (patch-removed p-aggregate)) aggregate-removed))
(check-equal? (trie-key-set/single (project-routing-table R* (tset 'a))) post-patch-a-keys)
(check-equal? (trie-key-set/single (project-routing-table R* (tset 'b))) post-patch-b-keys)
(check-equal? (trie-key-set/single R*) post-patch-keys)
(check-equal? (trie-key-set/single R*-relabeled) post-patch-keys)
(check-equal? (trie-key-set/single (patch-added p-aggregate)) aggregate-added)
(check-equal? (trie-key-set/single (patch-removed p-aggregate)) aggregate-removed))
(post-checks R1 R1-relabeled p-aggregate1)
(post-checks R2 R2-relabeled p-aggregate2)
)
(let* ((ma (set->matcher (tset 'a) (set 1)))
(mb (set->matcher (tset 'b) (set 1)))
(mmeta (set->matcher (tset 'meta) (set 1)))
(R0 (matcher-empty))
(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))
(R1 mmeta)
(R2 mb)
(R3 (matcher-union mb mmeta))
(R3 (trie-union mb mmeta))
(R4 ma)
(R5 (matcher-union ma mmeta))
(R6 (matcher-union ma mb))
(R7 (matcher-union (matcher-union ma mb) mmeta))
(R5 (trie-union ma mmeta))
(R6 (trie-union ma mb))
(R7 (trie-union (trie-union ma mb) mmeta))
(p0 empty-patch)
(p+ (patch (set->matcher (tset 'a) (set 1)) (matcher-empty)))
(p- (patch (matcher-empty) (set->matcher (tset 'a) (set 1)))))
(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)
@ -469,31 +469,31 @@
(check-equal? (compute-aggregate-patch p- 'a R7 #:remove-meta? #t) p0)
)
(let ((m1 (set->matcher #t (set 1 2)))
(m2 (set->matcher (tset 'a) (set 1 2)))
(p1 (patch (set->matcher #t (set 2 3)) (matcher-empty)))
(p2 (patch (set->matcher (tset 'a) (set 2 3)) (matcher-empty))))
(check-equal? (limit-patch p1 m1) (patch (set->matcher #t (set 3)) (matcher-empty)))
(let ((m1 (set->trie #t (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->matcher #t (set 3)) (matcher-empty))))
(patch (set->trie #t (set 3)) (trie-empty))))
(check-equal? (limit-patch p1 m2)
(patch (set->matcher #t (set 3)) (matcher-empty)))
(patch (set->trie #t (set 3)) (trie-empty)))
(check-equal? (limit-patch p2 m2)
(patch (set->matcher (tset 'a) (set 3)) (matcher-empty)))
(patch (set->trie (tset 'a) (set 3)) (trie-empty)))
)
(let ((m1 (set->matcher #t (set 1 2)))
(m2 (set->matcher (tset 'a) (set 1 2)))
(p1 (patch (matcher-empty) (set->matcher #t (set 2 3))))
(p2 (patch (matcher-empty) (set->matcher (tset 'a) (set 2 3)))))
(check-equal? (limit-patch p1 m1) (patch (matcher-empty) (set->matcher #t (set 2))))
(let ((m1 (set->trie #t (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 (matcher-empty) (set->matcher #t (set 2)))))
(patch (trie-empty) (set->trie #t (set 2)))))
(check-equal? (limit-patch p1 m2)
(patch (matcher-empty) (set->matcher #t (set 2))))
(patch (trie-empty) (set->trie #t (set 2))))
(check-equal? (limit-patch p2 m2)
(patch (matcher-empty) (set->matcher (tset 'a) (set 2))))
(patch (trie-empty) (set->trie (tset 'a) (set 2))))
)
)

View File

@ -17,9 +17,9 @@
(define-generics prospect-pretty-printable
(prospect-pretty-print prospect-pretty-printable [port])
#:defaults ([(lambda (x) (and (not (eq? x #f)) (matcher? x)))
#:defaults ([(lambda (x) (and (not (eq? x #f)) (trie? x)))
(define (prospect-pretty-print m [p (current-output-port)])
(pretty-print-matcher m p))]
(pretty-print-trie m p))]
[(lambda (x) #t)
(define (prospect-pretty-print v [p (current-output-port)])
(pretty-write v p))]))

File diff suppressed because it is too large Load Diff

View File

@ -175,9 +175,9 @@
(output "~a exiting (~a total processes remain)\n"
pidstr
(- oldcount 1)))
(unless (matcher-empty? interests)
(unless (trie-empty? interests)
(output "~a's final interests:\n" pidstr)
(pretty-print-matcher interests (current-error-port))))]
(pretty-print-trie interests (current-error-port))))]
[(quit-network)
(with-color BRIGHT-RED
(output "Process ~a performed a quit-network.\n" pidstr))]
@ -211,9 +211,9 @@
(unless (boring-state? state)
(output "~a's initial state:\n" newpidstr)
(prospect-pretty-print state (current-error-port)))
(unless (matcher-empty? interests)
(unless (trie-empty? interests)
(output "~a's initial interests:\n" newpidstr)
(pretty-print-matcher interests (current-error-port))))]
(pretty-print-trie interests (current-error-port))))]
[_
;; other cases handled in internal-action
(void)])
@ -223,7 +223,7 @@
(when (not (equal? old-table new-table))
(with-color BRIGHT-BLUE
(output "~a's routing table:\n" (format-pids (cdr pids)))
(pretty-print-matcher new-table (current-error-port))))))])
(pretty-print-trie new-table (current-error-port))))))])
(loop))))
(void (when (not (set-empty? flags))