syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Switch Syndicate implementation from route.rkt to trie.rkt.

This commit is contained in:
Tony Garnock-Jones 2016-03-12 16:54:31 +00:00
parent 86d55338f1
commit fc271b6398
31 changed files with 306 additions and 1931 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
FAQ.md
View File

@ -135,35 +135,36 @@
you are interested in, compile a pattern for those assertions, and pass that you are interested in, compile a pattern for those assertions, and pass that
along with the trie to `trie-project/set`. along with the trie to `trie-project/set`.
- `trie-project/set` takes a trie and a pattern and returns a set of lists - `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)`. - Say you are in interested in assertions of the shape `(posn x y)` for all `x` and `y`
* compile the pattern using ```(compile-projection `(posn ,(?!) ,(?!)))``` 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 * the `(?!)` is for **capturing** the matched value. Use `?` if you want to
match but don't care about the actual value. match but don't care about the actual value.
* the lists returned by `trie-project/set` contain the captured values in * the lists returned by `trie-project/set` contain the captured values in
order. 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 - The result of
```racket ```racket
(trie-project/set (patch-added p) (trie-project/set #:take 2 (patch-added p) (posn (?!) (?!)))
(compile-projection `(posn ,(?!) ,(?!))))
``` ```
would be `(set (list 2 3))`. would be `(set (list 2 3))`.
- If we only cared about the y position, we could instead do - If we only cared about the y position, we could instead do
```racket ```racket
(trie-project/set (patch-added p) (trie-project/set #:take 1 (patch-added p) (posn ? (?!)))
(compile-projection `(posn ,? ,(?!))))
``` ```
and get the result `(set (list 3))`. and get the result `(set (list 3))`.
- an entire structure can be captured by passing a pattern as an argument to - an entire structure can be captured by passing a pattern as an argument to
`(?!)`. `(?!)`.
```racket ```racket
(trie-project/set (patch-added p) (trie-project/set #:take 1 (patch-added p) (?! (posn ? ?)))
(compile-projection (?! `(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/single` is like mapping `car` over the result of
`trie-project/set`. See also `project-assertions`. `trie-project/set`. See also `project-assertions`.
- `patch-project/set` uses `values` to return the result of matching a projection - `patch-project/set` uses `values` to return the result of matching a projection

20
prospect-monolithic/core.rkt
View File

@ -14,7 +14,7 @@
(all-from-out "scn.rkt") (all-from-out "scn.rkt")
;; imported from route.rkt: ;; imported from trie.rkt:
? ?
wildcard? wildcard?
?! ?!
@ -25,7 +25,7 @@
trie-empty? trie-empty?
trie-empty trie-empty
projection->pattern projection->pattern
compile-projection projection-arity
trie-project trie-project
trie-project/set trie-project/set
trie-project/set/single trie-project/set/single
@ -67,7 +67,7 @@
(require racket/match) (require racket/match)
(require (only-in racket/list flatten)) (require (only-in racket/list flatten))
(require "../prospect/functional-queue.rkt") (require "../prospect/functional-queue.rkt")
(require "../prospect/route.rkt") (require "../prospect/trie.rkt")
(require "scn.rkt") (require "scn.rkt")
(require "../prospect/trace.rkt") (require "../prospect/trace.rkt")
(require "mux.rkt") (require "mux.rkt")
@ -133,13 +133,13 @@
(define (observe-at-meta pattern level) (define (observe-at-meta pattern level)
(if (zero? level) (if (zero? level)
(pattern->trie #t (observe pattern)) (pattern->trie '<observe-at-meta> (observe pattern))
(trie-union (trie-union
(pattern->trie #t (observe (prepend-at-meta pattern level))) (pattern->trie '<observe-at-meta> (observe (prepend-at-meta pattern level)))
(pattern->trie #t (at-meta (embedded-trie (observe-at-meta pattern (- level 1)))))))) (pattern->trie '<observe-at-meta> (at-meta (embedded-trie (observe-at-meta pattern (- level 1))))))))
(define (assertion pattern #:meta-level [level 0]) (define (assertion pattern #:meta-level [level 0])
(pattern->trie #t (prepend-at-meta pattern level))) (pattern->trie '<assertion> (prepend-at-meta pattern level)))
(define (subscription pattern #:meta-level [level 0]) (define (subscription pattern #:meta-level [level 0])
(observe-at-meta pattern level)) (observe-at-meta pattern level))
@ -152,10 +152,10 @@
(define (assertion-set-union* tries) (define (assertion-set-union* tries)
(match tries (match tries
['() (trie-empty)] ['() trie-empty]
[(cons t1 rest) [(cons t1 rest)
(for/fold [(t1 t1)] [(t2 (in-list 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 '<assertion-set-union*>))))]))
(define (scn/union . tries) (define (scn/union . tries)
(scn (assertion-set-union* tries))) (scn (assertion-set-union* tries)))
@ -398,7 +398,7 @@
(define-values (initial-scn remaining-initial-actions) (define-values (initial-scn remaining-initial-actions)
(match initial-actions (match initial-actions
[(cons (? scn? s) rest) (values s rest)] [(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) (define-values (new-mux new-pid s aggregate-assertions)
(mux-add-stream (network-mux w) initial-scn)) (mux-add-stream (network-mux w) initial-scn))
(let* ((w (struct-copy network w (let* ((w (struct-copy network w

30
prospect-monolithic/demand-matcher.rkt
View File

@ -20,6 +20,8 @@
;; exists. ;; exists.
(struct demand-matcher (demand-spec ;; CompiledProjection (struct demand-matcher (demand-spec ;; CompiledProjection
supply-spec ;; CompiledProjection supply-spec ;; CompiledProjection
demand-spec-arity ;; Natural
supply-spec-arity ;; Natural
increase-handler ;; ChangeHandler increase-handler ;; ChangeHandler
decrease-handler ;; ChangeHandler decrease-handler ;; ChangeHandler
current-demand ;; (Setof (Listof Any)) current-demand ;; (Setof (Listof Any))
@ -42,6 +44,8 @@
(define (make-demand-matcher demand-spec supply-spec increase-handler decrease-handler) (define (make-demand-matcher demand-spec supply-spec increase-handler decrease-handler)
(demand-matcher demand-spec (demand-matcher demand-spec
supply-spec supply-spec
(projection-arity demand-spec)
(projection-arity supply-spec)
increase-handler increase-handler
decrease-handler decrease-handler
(set) (set)
@ -52,9 +56,16 @@
;; demand increase and decrease sets. Calls ChangeHandlers in response ;; demand increase and decrease sets. Calls ChangeHandlers in response
;; to increased unsatisfied demand and decreased demanded supply. ;; to increased unsatisfied demand and decreased demanded supply.
(define (demand-matcher-update d s new-scn) (define (demand-matcher-update d s new-scn)
(match-define (demand-matcher demand-spec supply-spec inc-h dec-h demand supply) d) (match-define (demand-matcher demand-spec
(define new-demand (trie-project/set (scn-trie new-scn) demand-spec)) supply-spec
(define new-supply (trie-project/set (scn-trie new-scn) 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 added-demand (set-subtract new-demand demand))
(define removed-demand (set-subtract demand new-demand)) (define removed-demand (set-subtract demand new-demand))
(define added-supply (set-subtract new-supply supply)) (define added-supply (set-subtract new-supply supply))
@ -102,8 +113,8 @@
[decrease-handler unexpected-supply-decrease] [decrease-handler unexpected-supply-decrease]
#:name [name #f] #:name [name #f]
#:meta-level [meta-level 0]) #:meta-level [meta-level 0])
(define d (make-demand-matcher (compile-projection (prepend-at-meta demand-spec meta-level)) (define d (make-demand-matcher (prepend-at-meta demand-spec meta-level)
(compile-projection (prepend-at-meta supply-spec meta-level)) (prepend-at-meta supply-spec meta-level)
(lambda (acs . rs) (cons (apply increase-handler rs) acs)) (lambda (acs . rs) (cons (apply increase-handler rs) acs))
(lambda (acs . rs) (cons (apply decrease-handler rs) acs)))) (lambda (acs . rs) (cons (apply decrease-handler rs) acs))))
(spawn #:name name (spawn #:name name
@ -133,7 +144,8 @@
(match e (match e
[(scn new-aggregate) [(scn new-aggregate)
(define projection-results (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 (define maybe-spawn (apply check-and-maybe-spawn-fn
new-aggregate new-aggregate
projection-results)) projection-results))
@ -158,8 +170,10 @@
(define (pretty-print-demand-matcher s [p (current-output-port)]) (define (pretty-print-demand-matcher s [p (current-output-port)])
(match-define (demand-matcher demand-spec (match-define (demand-matcher demand-spec
supply-spec supply-spec
increase-handler _demand-arity
decrease-handler _supply-arity
_increase-handler
_decrease-handler
current-demand current-demand
current-supply) current-supply)
s) s)

4
prospect-monolithic/examples/chat-no-quit-world-no-nesting.rkt
View File

@ -7,8 +7,8 @@
(define (spawn-session them us) (define (spawn-session them us)
(define user (gensym 'user)) (define user (gensym 'user))
(define remote-detector (compile-projection (advertise (?! (tcp-channel ? ? ?))))) (define remote-detector (advertise (?! (tcp-channel ? ? ?))))
(define peer-detector (compile-projection (advertise `(,(?!) says ,?)))) (define peer-detector (advertise `(,(?!) says ,?)))
(define (send-to-remote fmt . vs) (define (send-to-remote fmt . vs)
(message (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))) (message (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))
(define (say who fmt . vs) (define (say who fmt . vs)

4
prospect-monolithic/ground.rkt
View File

@ -52,7 +52,7 @@
;; Projection ;; Projection
;; Used to extract event descriptors and results from subscriptions ;; Used to extract event descriptors and results from subscriptions
;; from the ground VM's contained Network. ;; from the ground VM's contained Network.
(define event-projection (compile-projection (observe (external-event (?!) ?)))) (define event-projection (observe (external-event (?!) ?)))
;; Interests -> (Listof RacketEvent) ;; Interests -> (Listof RacketEvent)
;; Projects out the active event subscriptions from the given interests. ;; Projects out the active event subscriptions from the given interests.
@ -78,7 +78,7 @@
(define (run-ground . boot-actions) (define (run-ground . boot-actions)
(let await-interrupt ((inert? #f) (let await-interrupt ((inert? #f)
(w (make-network boot-actions)) (w (make-network boot-actions))
(interests (trie-empty))) (interests trie-empty))
;; (log-info "GROUND INTERESTS:\n~a" (trie->pretty-string interests)) ;; (log-info "GROUND INTERESTS:\n~a" (trie->pretty-string interests))
(if (and inert? (trie-empty? interests)) (if (and inert? (trie-empty? interests))
(begin (log-info "run-ground: Terminating because inert") (begin (log-info "run-ground: Terminating because inert")

20
prospect-monolithic/mux.rkt
View File

@ -16,7 +16,7 @@
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require "../prospect/route.rkt") (require "../prospect/trie.rkt")
(require "scn.rkt") (require "scn.rkt")
(require "../prospect/trace.rkt") (require "../prospect/trace.rkt")
(require "../prospect/tset.rkt") (require "../prospect/tset.rkt")
@ -39,7 +39,7 @@
(define (meta-label? x) (eq? x 'meta)) (define (meta-label? x) (eq? x 'meta))
(define (make-mux) (define (make-mux)
(mux 0 (trie-empty) (hash))) (mux 0 trie-empty (hash)))
(define (mux-add-stream m initial-scn) (define (mux-add-stream m initial-scn)
(define new-pid (mux-next-pid m)) (define new-pid (mux-next-pid m))
@ -48,7 +48,7 @@
initial-scn)) initial-scn))
(define (mux-remove-stream m label) (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 (mux-update-stream m label new-scn)
(define old-interests (mux-interests-of m label)) (define old-interests (mux-interests-of m label))
@ -66,7 +66,7 @@
new-scn ;; unnecessary? new-scn ;; unnecessary?
aggregate-assertions)) aggregate-assertions))
(define at-meta-everything (pattern->trie #t (at-meta ?))) (define at-meta-everything (pattern->trie '<at-meta-everything> (at-meta ?)))
(define only-meta (datum-tset 'meta)) (define only-meta (datum-tset 'meta))
(define (echo-cancelled-routing-table m) (define (echo-cancelled-routing-table m)
@ -74,8 +74,8 @@
at-meta-everything at-meta-everything
#:combiner (lambda (v1 v2) #:combiner (lambda (v1 v2)
(if (tset-member? v1 'meta) (if (tset-member? v1 'meta)
only-meta (trie-success only-meta)
#f)))) trie-empty))))
(define (compute-scns old-m new-m label s aggregate-assertions) (define (compute-scns old-m new-m label s aggregate-assertions)
(define old-routing-table (mux-routing-table old-m)) (define old-routing-table (mux-routing-table old-m))
@ -94,11 +94,9 @@
(define (compute-affected-pids routing-table cover) (define (compute-affected-pids routing-table cover)
(trie-match-trie cover (trie-match-trie cover
(trie-step routing-table struct:observe) (trie-step routing-table observe-parenthesis)
#:seed datum-tset-empty #:seed datum-tset-empty
#:combiner (lambda (v1 v2 acc) (tset-union v2 acc)) #: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) (define (mux-route-message m body)
(if (trie-lookup (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
@ -106,7 +104,7 @@
(tset->list (trie-lookup (mux-routing-table m) (observe body) datum-tset-empty)))) (tset->list (trie-lookup (mux-routing-table m) (observe body) datum-tset-empty))))
(define (mux-interests-of m label) (define (mux-interests-of m label)
(hash-ref (mux-interest-table m) label (trie-empty))) (hash-ref (mux-interest-table m) label trie-empty))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

20
prospect-monolithic/scn.rkt
View File

@ -5,6 +5,8 @@
(struct-out observe) (struct-out observe)
(struct-out at-meta) (struct-out at-meta)
(struct-out advertise) (struct-out advertise)
observe-parenthesis
at-meta-parenthesis
lift-scn lift-scn
drop-scn drop-scn
strip-interests strip-interests
@ -15,7 +17,7 @@
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require "../prospect/route.rkt") (require "../prospect/trie.rkt")
(require "../prospect/tset.rkt") (require "../prospect/tset.rkt")
(require "../prospect/pretty.rkt") (require "../prospect/pretty.rkt")
(module+ test (require rackunit)) (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) (define (lift-scn s)
(scn (pattern->trie #t (at-meta (embedded-trie (scn-trie s)))))) (scn (pattern->trie '<lift-scn> (at-meta (embedded-trie (scn-trie s))))))
(define (drop-interests pi) (define (drop-interests pi)
(trie-project pi at-meta-proj (trie-step pi at-meta-parenthesis))
#:project-success (lambda (v) #t)
#:combiner (lambda (v1 v2) #t)))
(define (drop-scn s) (define (drop-scn s)
(scn (drop-interests (scn-trie s)))) (scn (drop-interests (scn-trie s))))
(define (strip-interests g) (define (strip-interests g)
(trie-relabel g (lambda (v) #t))) (trie-relabel g (lambda (v) '<strip-interests>)))
(define (label-interests g label) (define (label-interests g label)
(trie-relabel g (lambda (v) label))) (trie-relabel g (lambda (v) label)))
@ -62,6 +63,5 @@
(define (biased-intersection object subject) (define (biased-intersection object subject)
(trie-intersect object (trie-intersect object
(trie-step subject struct:observe) (trie-step subject observe-parenthesis)
#:combiner (lambda (v1 v2) #t) #:combiner (lambda (v1 v2) (trie-success v1))))
#:left-short (lambda (v r) (trie-step r EOS))))

14
prospect/actor.rkt
View File

@ -56,7 +56,7 @@
(require (except-in "core.rkt" assert network) (require (except-in "core.rkt" assert network)
(rename-in "core.rkt" [assert core:assert] [network core:network])) (rename-in "core.rkt" [assert core:assert] [network core:network]))
(require "route.rkt") (require "trie.rkt")
(require "mux.rkt") (require "mux.rkt")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -152,7 +152,7 @@
(struct link-result (caller-id callee-id values) #:transparent) ;; message (struct link-result (caller-id callee-id values) #:transparent) ;; message
;; Projection for observing LinkActive. ;; Projection for observing LinkActive.
(define link-active-projection (compile-projection (link-active ? (?!)))) (define link-active-projection (link-active ? (?!)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Producing Instruction side-effects ;; Producing Instruction side-effects
@ -494,13 +494,13 @@
#,(if maybe-Pred-stx #,(if maybe-Pred-stx
#`(if #,maybe-Pred-stx #`(if #,maybe-Pred-stx
(compute-new-assertions) (compute-new-assertions)
(trie-empty)) trie-empty)
#`(compute-new-assertions))) #`(compute-new-assertions)))
(and (not (eq? old-assertions new-assertions)) (and (not (eq? old-assertions new-assertions))
((extend-pending-patch ((extend-pending-patch
#,endpoint-index #,endpoint-index
(patch-seq (patch (trie-empty) old-assertions) (patch-seq (patch trie-empty old-assertions)
(patch new-assertions (trie-empty)))) (patch new-assertions trie-empty)))
s)))))) s))))))
(define (analyze-asserted-or-retracted! endpoint-index asserted? outer-expr-stx P-stx I-stxs L-stx) (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-assertion-maintainer! endpoint-index #'sub pat #f L-stx)
(add-event-handler! (add-event-handler!
(lambda (evt-stx) (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) (lambda (s)
(match #,evt-stx (match #,evt-stx
[(? #,(if asserted? #'patch/added? #'patch/removed?) p) [(? #,(if asserted? #'patch/added? #'patch/removed?) p)
(sequence-transitions0* (sequence-transitions0*
s s
(for/list [(entry (in-set (trie-project/set (for/list [(entry (in-set (trie-project/set
#:take proj-arity
#,(if asserted? #,(if asserted?
#'(patch-added p) #'(patch-added p)
#'(patch-removed p)) #'(patch-removed p))

12
prospect/big-bang.rkt
View File

@ -26,7 +26,7 @@
(require (only-in racket/list flatten)) (require (only-in racket/list flatten))
(require "main.rkt") (require "main.rkt")
(require "route.rkt") (require "trie.rkt")
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
@ -50,7 +50,7 @@
(struct bb (network windows inbound outbound halted? x y) #:transparent) (struct bb (network windows inbound outbound halted? x y) #:transparent)
(define window-projection (compile-projection (?! (window ? ? ? ? ?)))) (define window-projection (?! (window ? ? ? ? ?)))
(define (inject b es) (define (inject b es)
(interpret-actions (struct-copy bb b [inbound (append (bb-inbound b) (interpret-actions (struct-copy bb b [inbound (append (bb-inbound b)
@ -67,9 +67,11 @@
(set-subtract (list->set (bb-windows b)) (set-subtract (list->set (bb-windows b))
removed))) removed)))
(lambda (w1 w2) (< (window-z w1) (window-z w2))))] (lambda (w1 w2) (< (window-z w1) (window-z w2))))]
[halted? (or (and (bb-halted? b) [halted? (if (or (and (bb-halted? b)
(not (trie-lookup (patch-removed p) 'stop #f))) (not (trie-lookup (patch-removed p) 'stop #f)))
(trie-lookup (patch-added p) 'stop #f))])) (trie-lookup (patch-added p) 'stop #f))
#t
#f)]))
(define (deliver b e) (define (deliver b e)
(clean-transition (network-handle-event e (bb-network b)))) (clean-transition (network-handle-event e (bb-network b))))

59
prospect/comprehensions.rkt
View File

@ -26,7 +26,7 @@
;; error, using the third argument to describe the pattern being projected. ;; error, using the third argument to describe the pattern being projected.
;; If the resulting trie is finite, return it as a set. ;; If the resulting trie is finite, return it as a set.
(define (project-finite t proj pat) (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? (unless s?
(error "pattern projection created infinite trie:" pat)) (error "pattern projection created infinite trie:" pat))
s?) s?)
@ -88,7 +88,7 @@
(make-fold for-trie/set set-folder (set)) (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) (define (ret-second a b) b)
@ -105,14 +105,15 @@
(module+ test (module+ test
(require rackunit) (require rackunit)
(require "route.rkt") (require "trie.rkt")
(define (make-trie . vs) (define (make-trie . vs)
(for/fold ([acc (trie-empty)]) (for/fold ([acc trie-empty])
([v (in-list vs)]) ([v (in-list vs)])
(trie-union acc (pattern->trie 'a v)))) (trie-union acc (pattern->trie 'a v))))
(struct foo (bar zot) #:prefab) (struct foo (bar zot) #:prefab)
(struct quasi-cons (car cdr) #:transparent)
;; This test should pass OK, since we're ignoring all the infinite ;; This test should pass OK, since we're ignoring all the infinite
;; dimensions, and just projecting out a finite one. ;; dimensions, and just projecting out a finite one.
@ -141,12 +142,13 @@
#:where (even? x)) #:where (even? x))
(+ x 1)) (+ x 1))
(set 3 5)) (set 3 5))
(check-equal? (for-trie/set ([(cons $x _) (make-trie 1 2 (list 0) (check-equal? (for-trie/set ([(quasi-cons $x _)
(list 1 2 3) (make-trie 1 2 (list 0)
(cons 'x 'y) (list 1 2 3)
(cons 3 4) (quasi-cons 'x 'y)
(cons 'a 'b) (quasi-cons 3 4)
"x" 'foo)]) (quasi-cons 'a 'b)
"x" 'foo)])
x) x)
(set 'x 3 'a)) (set 'x 3 'a))
(check-equal? (for-trie/fold ([acc 0]) (check-equal? (for-trie/fold ([acc 0])
@ -163,9 +165,10 @@
(let-values ([(acc1 acc2) (let-values ([(acc1 acc2)
(for-trie/fold ([acc1 0] (for-trie/fold ([acc1 0]
[acc2 0]) [acc2 0])
([(cons $x $y) (make-trie (cons 1 2) ([(quasi-cons $x $y)
(cons 3 8) (make-trie (quasi-cons 1 2)
(cons 9 7))]) (quasi-cons 3 8)
(quasi-cons 9 7))])
(values (+ acc1 x) (values (+ acc1 x)
(+ acc2 y)))]) (+ acc2 y)))])
(check-equal? acc1 13) (check-equal? acc1 13)
@ -178,24 +181,26 @@
(cons 3 4) (cons 3 5) (cons 3 6))) (cons 3 4) (cons 3 5) (cons 3 6)))
(let ([p (for-trie/patch ([$x (make-trie 1 2 3 4)]) (let ([p (for-trie/patch ([$x (make-trie 1 2 3 4)])
(retract x))]) (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)))) (set '(1) '(2) '(3) '(4))))
(check-equal? (for-trie/set ([$x (make-trie 1 2 3)] (check-equal? (for-trie/set ([$x (make-trie 1 2 3)]
[(cons x 3) (make-trie (cons 'x 'y) [(quasi-cons x 3)
(cons 5 5) (make-trie (quasi-cons 'x 'y)
(cons 2 4) (quasi-cons 5 5)
(cons 3 3) (quasi-cons 2 4)
(cons 4 3))]) (quasi-cons 3 3)
(quasi-cons 4 3))])
(cons x 4)) (cons x 4))
(set (cons 3 4))) (set (cons 3 4)))
(check-equal? (for-trie/set ([(cons $x $x) (make-trie 'a 'b (check-equal? (for-trie/set ([(quasi-cons $x $x)
(cons 'x 'y) (make-trie 'a 'b
(cons 2 3) (quasi-cons 'x 'y)
3 4 (quasi-cons 2 3)
'x 3 4
(cons 1 1) 'x
"abc" (quasi-cons 1 1)
(cons 'x 'x))]) "abc"
(quasi-cons 'x 'x))])
x) x)
(set 1 'x)) (set 1 'x))
(check-equal? (for-trie/set ([$x (make-trie 1 2 3)]) (check-equal? (for-trie/set ([$x (make-trie 1 2 3)])

22
prospect/core.rkt
View File

@ -14,7 +14,7 @@
(all-from-out "patch.rkt") (all-from-out "patch.rkt")
;; imported from route.rkt: ;; imported from trie.rkt:
? ?
wildcard? wildcard?
?! ?!
@ -25,7 +25,7 @@
trie-empty? trie-empty?
trie-empty trie-empty
projection->pattern projection->pattern
compile-projection projection-arity
trie-project trie-project
trie-project/set trie-project/set
trie-project/set/single trie-project/set/single
@ -67,7 +67,7 @@
(require racket/match) (require racket/match)
(require (only-in racket/list flatten)) (require (only-in racket/list flatten))
(require "functional-queue.rkt") (require "functional-queue.rkt")
(require "route.rkt") (require "trie.rkt")
(require "patch.rkt") (require "patch.rkt")
(require "trace.rkt") (require "trace.rkt")
(require "mux.rkt") (require "mux.rkt")
@ -138,20 +138,20 @@
(define (observe-at-meta pattern level) (define (observe-at-meta pattern level)
(if (zero? level) (if (zero? level)
(pattern->trie #t (observe pattern)) (pattern->trie '<observe-at-meta> (observe pattern))
(trie-union (trie-union
(pattern->trie #t (observe (prepend-at-meta pattern level))) (pattern->trie '<observe-at-meta> (observe (prepend-at-meta pattern level)))
(pattern->trie #t (at-meta (embedded-trie (observe-at-meta pattern (- level 1)))))))) (pattern->trie '<observe-at-meta> (at-meta (embedded-trie (observe-at-meta pattern (- level 1))))))))
(define (assert pattern #:meta-level [level 0]) (define (assert pattern #:meta-level [level 0])
(patch (pattern->trie #t (prepend-at-meta pattern level)) (trie-empty))) (patch (pattern->trie '<assert> (prepend-at-meta pattern level)) trie-empty))
(define (retract pattern #:meta-level [level 0]) (define (retract pattern #:meta-level [level 0])
(patch (trie-empty) (pattern->trie #t (prepend-at-meta pattern level)))) (patch trie-empty (pattern->trie '<retract> (prepend-at-meta pattern level))))
(define (sub pattern #:meta-level [level 0]) (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]) (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 (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)) (define (unpub pattern #:meta-level [level 0]) (retract (advertise pattern) #:meta-level level))
@ -400,7 +400,7 @@
(define-values (initial-patch remaining-initial-actions) (define-values (initial-patch remaining-initial-actions)
(match initial-actions (match initial-actions
[(cons (? patch? p) rest) (values p rest)] [(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) (define-values (new-mux new-pid delta delta-aggregate)
(mux-add-stream (network-mux w) initial-patch)) (mux-add-stream (network-mux w) initial-patch))
(let* ((w (struct-copy network w (let* ((w (struct-copy network w

36
prospect/demand-matcher.rkt
View File

@ -20,6 +20,8 @@
;; exists. ;; exists.
(struct demand-matcher (demand-spec ;; CompiledProjection (struct demand-matcher (demand-spec ;; CompiledProjection
supply-spec ;; CompiledProjection supply-spec ;; CompiledProjection
demand-spec-arity ;; Natural
supply-spec-arity ;; Natural
increase-handler ;; ChangeHandler increase-handler ;; ChangeHandler
decrease-handler ;; ChangeHandler decrease-handler ;; ChangeHandler
current-demand ;; (Setof (Listof Any)) current-demand ;; (Setof (Listof Any))
@ -42,6 +44,8 @@
(define (make-demand-matcher demand-spec supply-spec increase-handler decrease-handler) (define (make-demand-matcher demand-spec supply-spec increase-handler decrease-handler)
(demand-matcher demand-spec (demand-matcher demand-spec
supply-spec supply-spec
(projection-arity demand-spec)
(projection-arity supply-spec)
increase-handler increase-handler
decrease-handler decrease-handler
(set) (set)
@ -52,9 +56,18 @@
;; demand increase and decrease sets. Calls ChangeHandlers in response ;; demand increase and decrease sets. Calls ChangeHandlers in response
;; to increased unsatisfied demand and decreased demanded supply. ;; to increased unsatisfied demand and decreased demanded supply.
(define (demand-matcher-update d s p) (define (demand-matcher-update d s p)
(match-define (demand-matcher demand-spec supply-spec inc-h dec-h demand supply) d) (match-define (demand-matcher demand-spec
(define-values (added-demand removed-demand) (patch-project/set p demand-spec)) supply-spec
(define-values (added-supply removed-supply) (patch-project/set p 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" (when (not added-demand) (error 'demand-matcher "Wildcard demand of ~v:\n~a"
demand-spec demand-spec
@ -98,8 +111,8 @@
[decrease-handler unexpected-supply-decrease] [decrease-handler unexpected-supply-decrease]
#:name [name #f] #:name [name #f]
#:meta-level [meta-level 0]) #:meta-level [meta-level 0])
(define d (make-demand-matcher (compile-projection (prepend-at-meta demand-spec meta-level)) (define d (make-demand-matcher (prepend-at-meta demand-spec meta-level)
(compile-projection (prepend-at-meta supply-spec meta-level)) (prepend-at-meta supply-spec meta-level)
(lambda (acs . rs) (cons (apply increase-handler rs) acs)) (lambda (acs . rs) (cons (apply increase-handler rs) acs))
(lambda (acs . rs) (cons (apply decrease-handler rs) acs)))) (lambda (acs . rs) (cons (apply decrease-handler rs) acs))))
(spawn #:name name (spawn #:name name
@ -130,7 +143,8 @@
[(? patch? p) [(? patch? p)
(define new-aggregate (update-interests current-aggregate p)) (define new-aggregate (update-interests current-aggregate p))
(define projection-results (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 (define maybe-spawn (apply check-and-maybe-spawn-fn
new-aggregate new-aggregate
projection-results)) projection-results))
@ -144,8 +158,8 @@
(when timeout-msec (message (set-timer timer-id timeout-msec 'relative))) (when timeout-msec (message (set-timer timer-id timeout-msec 'relative)))
(spawn #:name name (spawn #:name name
on-claim-handler on-claim-handler
(trie-empty) trie-empty
(patch-seq (patch base-interests (trie-empty)) (patch-seq (patch base-interests trie-empty)
(patch-seq* (map (lambda (p) (sub projection->pattern)) projections)) (patch-seq* (map (lambda (p) (sub projection->pattern)) projections))
(sub (timer-expired timer-id ?)))))) (sub (timer-expired timer-id ?))))))
@ -154,8 +168,10 @@
(define (pretty-print-demand-matcher s [p (current-output-port)]) (define (pretty-print-demand-matcher s [p (current-output-port)])
(match-define (demand-matcher demand-spec (match-define (demand-matcher demand-spec
supply-spec supply-spec
increase-handler _demand-arity
decrease-handler _supply-arity
_increase-handler
_decrease-handler
current-demand current-demand
current-supply) current-supply)
s) s)

6
prospect/drivers/timer.rkt
View File

@ -19,7 +19,7 @@
(struct set-timer (label msecs kind) #:prefab) (struct set-timer (label msecs kind) #:prefab)
(struct timer-expired (label msecs) #: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 (spawn-timer-driver)
(define control-ch (make-channel)) (define control-ch (make-channel))
@ -56,7 +56,7 @@
(define-values (new-count actions-rev interrupt-clearing-patch) (define-values (new-count actions-rev interrupt-clearing-patch)
(for/fold [(count count) (for/fold [(count count)
(actions-rev '()) (actions-rev '())
(interrupt-clearing-patch empty-patch)] (interrupt-clearing-patch patch-empty)]
[(expiry (trie-project/set/single added expiry-projection))] [(expiry (trie-project/set/single added expiry-projection))]
(values (- count 1) (values (- count 1)
(cons (message expiry) actions-rev) (cons (message expiry) actions-rev)
@ -84,7 +84,7 @@
[t (handle-evt (timer-evt (pending-timer-deadline t)) [t (handle-evt (timer-evt (pending-timer-deadline t))
(lambda (now) (lambda (now)
(send-ground-patch (send-ground-patch
(for/fold [(interrupt-asserting-patch empty-patch)] (for/fold [(interrupt-asserting-patch patch-empty)]
[(expiry (fire-timers! heap now))] [(expiry (fire-timers! heap now))]
(patch-seq interrupt-asserting-patch (assert expiry)))) (patch-seq interrupt-asserting-patch (assert expiry))))
(loop)))]) (loop)))])

12
prospect/endpoint.rkt
View File

@ -15,7 +15,7 @@
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require (only-in racket/list flatten)) (require (only-in racket/list flatten))
(require "route.rkt") (require "trie.rkt")
(require "patch.rkt") (require "patch.rkt")
(require "core.rkt") (require "core.rkt")
(require "mux.rkt") (require "mux.rkt")
@ -54,7 +54,7 @@
(define (boot-endpoint-group initial-state initial-actions) (define (boot-endpoint-group initial-state initial-actions)
(define-values (final-cumulative-patch final-actions final-g) (define-values (final-cumulative-patch final-actions final-g)
(interpret-endpoint-actions empty-patch (interpret-endpoint-actions patch-empty
'() '()
(make-endpoint-group initial-state) (make-endpoint-group initial-state)
-1 -1
@ -88,7 +88,7 @@
(define (sequence-handlers g tasks) (define (sequence-handlers g tasks)
(let/ec return (let/ec return
(define-values (final-cumulative-patch final-actions final-g idle?) (define-values (final-cumulative-patch final-actions final-g idle?)
(for/fold ([cumulative-patch empty-patch] (for/fold ([cumulative-patch patch-empty]
[actions '()] [actions '()]
[g g] [g g]
[idle? #t]) [idle? #t])
@ -125,14 +125,14 @@
(match endpoint-action (match endpoint-action
[(or (? message?) [(or (? message?)
(? spawn?)) (? spawn?))
(values empty-patch (values patch-empty
(cons (incorporate-cumulative-patch actions cumulative-patch) endpoint-action) (cons (incorporate-cumulative-patch actions cumulative-patch) endpoint-action)
g)] g)]
[(? patch? p0) [(? patch? p0)
(interpret-endpoint-patch cumulative-patch actions g eid p0)] (interpret-endpoint-patch cumulative-patch actions g eid p0)]
[(add-endpoint function) [(add-endpoint function)
(define-values (new-mux new-eid _p _p-aggregate) (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))) (define-values (new-ep initial-transition) (function new-eid (endpoint-group-state g)))
(interpret-endpoint-actions cumulative-patch (interpret-endpoint-actions cumulative-patch
actions actions
@ -152,7 +152,7 @@
[endpoints [endpoints
(hash-remove (endpoint-group-endpoints g) eid)]) (hash-remove (endpoint-group-endpoints g) eid)])
eid eid
(patch (trie-empty) (pattern->trie #t ?)))] (patch trie-empty (pattern->trie '<delete-endpoint> ?)))]
[(as-endpoint other-eid inner-endpoint-action) [(as-endpoint other-eid inner-endpoint-action)
(interpret-endpoint-actions cumulative-patch actions g other-eid inner-endpoint-action)])) (interpret-endpoint-actions cumulative-patch actions g other-eid inner-endpoint-action)]))

4
prospect/examples/big-bang.rkt
View File

@ -56,9 +56,7 @@
(match e (match e
[(? patch? p) [(? patch? p)
(define-values (in out) (define-values (in out)
(patch-project/set/single p (patch-project/set/single p (at-meta (?! (active-window ?)))))
(compile-projection
(at-meta (?! (active-window ?))))))
(transition s (update-window 'active-window-label 300 0 (transition s (update-window 'active-window-label 300 0
(text (format "~v" in) 22 "black")))] (text (format "~v" in) 22 "black")))]
[_ #f])) [_ #f]))

4
prospect/examples/chat-no-quit-world-no-nesting.rkt
View File

@ -6,8 +6,8 @@
(define (spawn-session them us) (define (spawn-session them us)
(define user (gensym 'user)) (define user (gensym 'user))
(define remote-detector (compile-projection (advertise (?! (tcp-channel ? ? ?))))) (define remote-detector (advertise (?! (tcp-channel ? ? ?))))
(define peer-detector (compile-projection (advertise `(,(?!) says ,?)))) (define peer-detector (advertise `(,(?!) says ,?)))
(define (send-to-remote fmt . vs) (define (send-to-remote fmt . vs)
(message (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))) (message (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))
(define (say who fmt . vs) (define (say who fmt . vs)

4
prospect/examples/chat-no-quit-world.rkt
View File

@ -6,8 +6,8 @@
(define (spawn-session them us) (define (spawn-session them us)
(define user (gensym 'user)) (define user (gensym 'user))
(define remote-detector (compile-projection (at-meta (?!)))) (define remote-detector (at-meta (?!)))
(define peer-detector (compile-projection (advertise `(,(?!) says ,?)))) (define peer-detector (advertise `(,(?!) says ,?)))
(define (send-to-remote fmt . vs) (define (send-to-remote fmt . vs)
(message (at-meta (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))) (message (at-meta (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
(define (say who fmt . vs) (define (say who fmt . vs)

5
prospect/examples/chat-simplified-internals.rkt
View File

@ -48,10 +48,9 @@
[(message (says who what)) [(message (says who what))
(say who "says: ~a" what)] (say who "says: ~a" what)]
[(? patch? p) [(? 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) (quit)
(let-values (((arrived departed) (let-values (((arrived departed) (patch-project/set/single p (present (?!)))))
(patch-project/set/single p (compile-projection (present (?!))))))
(list (for/list [(who arrived)] (say who "arrived.")) (list (for/list [(who arrived)] (say who "arrived."))
(for/list [(who departed)] (say who "departed.")))))] (for/list [(who departed)] (say who "departed.")))))]
[#f #f])) [#f #f]))

4
prospect/examples/chat.rkt
View File

@ -6,8 +6,8 @@
(define (spawn-session them us) (define (spawn-session them us)
(define user (gensym 'user)) (define user (gensym 'user))
(define remote-detector (compile-projection (at-meta (?!)))) (define remote-detector (at-meta (?!)))
(define peer-detector (compile-projection (advertise `(,(?!) says ,?)))) (define peer-detector (advertise `(,(?!) says ,?)))
(define (send-to-remote fmt . vs) (define (send-to-remote fmt . vs)
(message (at-meta (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))) (message (at-meta (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
(define (say who fmt . vs) (define (say who fmt . vs)

6
prospect/examples/durable-key-value-store.rkt
View File

@ -21,8 +21,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define observation-projector (compile-projection (observe (binding (?!) ? ? ?)))) (define observation-projector (observe (binding (?!) ? ? ?)))
(define update-projector (compile-projection (?! (update ? ? ? ?)))) (define update-projector (?! (update ? ? ? ?)))
(struct db-state (epoch directory observed-keys) #:transparent) (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) (define (async-update key epoch version value on-complete on-conflict)
(spawn (lambda (e s) (spawn (lambda (e s)

2
prospect/examples/example-meta-echo.rkt
View File

@ -1,7 +1,7 @@
#lang prospect #lang prospect
;; Test case for a historical bug in Syndicate. ;; 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. ;; total, whereas it should receive only two.
;; ;;
;; While metamessages were "echo cancelled", and receivers only ever ;; While metamessages were "echo cancelled", and receivers only ever

2
prospect/examples/example-wildcard-assertion-1.rkt
View File

@ -14,6 +14,6 @@
(if (patch? e) (if (patch? e)
(transition (update-interests s e) '()) (transition (update-interests s e) '())
#f)) #f))
(trie-empty) trie-empty
(patch-seq (assert ?) (patch-seq (assert ?)
(retract (at-meta ?)))) (retract (at-meta ?))))

2
prospect/examples/example-wildcard-assertion-2.rkt
View File

@ -16,7 +16,7 @@
(if (patch? e) (if (patch? e)
(transition (update-interests s e) '()) (transition (update-interests s e) '())
#f)) #f))
(trie-empty) trie-empty
(sub ?)) (sub ?))
(spawn (lambda (e s) (spawn (lambda (e s)

36
prospect/examples/forward-chaining.rkt
View File

@ -1,7 +1,7 @@
#lang prospect #lang prospect
(require racket/set) (require racket/set)
(require "../route.rkt") (require "../trie.rkt")
(require "../demand-matcher.rkt") (require "../demand-matcher.rkt")
(require "../drivers/timer.rkt") (require "../drivers/timer.rkt")
@ -10,8 +10,7 @@
(spawn (lambda (e old-count) (spawn (lambda (e old-count)
(match e (match e
[(? patch?) [(? patch?)
(define-values (in out) (define-values (in out) (patch-project/set #:take 2 e `(parent ,(?!) ,(?!))))
(patch-project/set e (compile-projection `(parent ,(?!) ,(?!)))))
(define new-count (+ old-count (set-count in) (- (set-count out)))) (define new-count (+ old-count (set-count in) (- (set-count out))))
(printf "New parent-record count: ~v\n" new-count) (printf "New parent-record count: ~v\n" new-count)
(transition new-count (transition new-count
@ -29,7 +28,7 @@
[(? patch/removed?) [(? patch/removed?)
(printf "Retracting ~v because dependencies ~v vanished\n" (printf "Retracting ~v because dependencies ~v vanished\n"
record record
(set->list (trie-project/set (patch-removed e) (compile-projection (?!))))) (set->list (trie-project/set/single (patch-removed e) (?!))))
(quit)] (quit)]
[(message `(retract ,(== record))) [(message `(retract ,(== record)))
(printf "Retracting ~v because we were told to explicitly\n" record) (printf "Retracting ~v because we were told to explicitly\n" record)
@ -48,9 +47,9 @@
(match e (match e
[(? patch?) [(? patch?)
(transition s (transition s
(for/list [(AB (trie-project/set (for/list [(AB (trie-project/set #:take 2
(patch-added e) (patch-added e)
(compile-projection `(parent ,(?!) ,(?!)))))] `(parent ,(?!) ,(?!))))]
(match-define (list A B) AB) (match-define (list A B) AB)
(insert-record `(ancestor ,A ,B) (insert-record `(ancestor ,A ,B)
`(parent ,A ,B))))] `(parent ,A ,B))))]
@ -62,30 +61,28 @@
(match e (match e
[(? patch?) [(? patch?)
(transition s (transition s
(for/list [(AC (trie-project/set (for/list [(AC (trie-project/set #:take 2
(patch-added e) (patch-added e)
(compile-projection `(parent ,(?!) ,(?!)))))] `(parent ,(?!) ,(?!))))]
(match-define (list A C) AC) (match-define (list A C) AC)
(printf "Inductive step for ~v asserted\n" `(parent ,A ,C)) (printf "Inductive step for ~v asserted\n" `(parent ,A ,C))
(spawn (lambda (e s) (spawn (lambda (e s)
(define removed-parents (define removed-parents
(and (patch? e) (and (patch? e)
(trie-project (patch-removed e) (trie-project (patch-removed e) `(parent ,(?!) ,(?!)))))
(compile-projection
`(parent ,(?!) ,(?!))))))
(if (trie-non-empty? removed-parents) (if (trie-non-empty? removed-parents)
(begin (begin
(printf (printf
"Inductive step for ~v retracted because of removal ~v\n" "Inductive step for ~v retracted because of removal ~v\n"
`(parent ,A ,C) `(parent ,A ,C)
(trie-key-set removed-parents)) (trie-key-set #:take 2 removed-parents))
(quit)) (quit))
(and (patch? e) (and (patch? e)
(transition s (transition s
(for/list [(CB (trie-project/set (for/list [(CB (trie-project/set
#:take 2
(patch-added e) (patch-added e)
(compile-projection `(ancestor ,(?!) ,(?!))))]
`(ancestor ,(?!) ,(?!)))))]
(match-define (list _ B) CB) (match-define (list _ B) CB)
(insert-record `(ancestor ,A ,B) (insert-record `(ancestor ,A ,B)
`(parent ,A ,C) `(parent ,A ,C)
@ -112,9 +109,8 @@
;; [(? patch/removed?) (quit)] ;; [(? patch/removed?) (quit)]
;; [(? patch?) ;; [(? patch?)
;; (define new-facts (trie-union old-facts (patch-added e))) ;; (define new-facts (trie-union old-facts (patch-added e)))
;; (define triples (trie-project/set new-facts ;; (define triples (trie-project/set #:take 3 new-facts
;; (compile-projection ;; `(,(?!) ,(?!) ,(?!))))
;; `(,(?!) ,(?!) ,(?!)))))
;; (printf "Learned new facts: ~v\n" triples) ;; (printf "Learned new facts: ~v\n" triples)
;; (transition new-facts ;; (transition new-facts
;; (when (or (set-member? triples `(parent ,A ,B)) ;; (when (or (set-member? triples `(parent ,A ,B))
@ -127,7 +123,7 @@
;; `(ancestor ,A ,B)) ;; `(ancestor ,A ,B))
;; (assert `(ancestor ,A ,B))))] ;; (assert `(ancestor ,A ,B))))]
;; [_ #f])) ;; [_ #f]))
;; (trie-empty) ;; trie-empty
;; (patch-seq ;; (patch-seq
;; (sub `(parent ,A ,B)) ;; (sub `(parent ,A ,B))
;; (sub `(parent ,A ,?)) ;; (sub `(parent ,A ,?))

6
prospect/examples/key-value-store.rkt
View File

@ -20,8 +20,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define observation-projector (compile-projection (observe (binding (?!) ? ? ?)))) (define observation-projector (observe (binding (?!) ? ? ?)))
(define update-projector (compile-projection (?! (update ? ? ? ?)))) (define update-projector (?! (update ? ? ? ?)))
(struct db-state (epoch bindings observed-keys) #:transparent) (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) (define (async-update key epoch version value on-complete on-conflict)
(spawn (lambda (e s) (spawn (lambda (e s)

4
prospect/ground.rkt
View File

@ -52,7 +52,7 @@
;; Projection ;; Projection
;; Used to extract event descriptors and results from subscriptions ;; Used to extract event descriptors and results from subscriptions
;; from the ground VM's contained Network. ;; from the ground VM's contained Network.
(define event-projection (compile-projection (observe (external-event (?!) ?)))) (define event-projection (observe (external-event (?!) ?)))
;; Interests -> (Listof RacketEvent) ;; Interests -> (Listof RacketEvent)
;; Projects out the active event subscriptions from the given interests. ;; Projects out the active event subscriptions from the given interests.
@ -78,7 +78,7 @@
(define (run-ground . boot-actions) (define (run-ground . boot-actions)
(let await-interrupt ((inert? #f) (let await-interrupt ((inert? #f)
(w (make-network boot-actions)) (w (make-network boot-actions))
(interests (trie-empty))) (interests trie-empty))
;; (log-info "GROUND INTERESTS:\n~a" (trie->pretty-string interests)) ;; (log-info "GROUND INTERESTS:\n~a" (trie->pretty-string interests))
(if (and inert? (trie-empty? interests)) (if (and inert? (trie-empty? interests))
(begin (log-info "run-ground: Terminating because inert") (begin (log-info "run-ground: Terminating because inert")

24
prospect/mux.rkt
View File

@ -15,7 +15,7 @@
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require "route.rkt") (require "trie.rkt")
(require "patch.rkt") (require "patch.rkt")
(require "trace.rkt") (require "trace.rkt")
(require "tset.rkt") (require "tset.rkt")
@ -38,7 +38,7 @@
(define (meta-label? x) (eq? x 'meta)) (define (meta-label? x) (eq? x 'meta))
(define (make-mux) (define (make-mux)
(mux 0 (trie-empty) (hash))) (mux 0 trie-empty (hash)))
(define (mux-add-stream m initial-patch) (define (mux-add-stream m initial-patch)
(define new-pid (mux-next-pid m)) (define new-pid (mux-next-pid m))
@ -47,7 +47,7 @@
initial-patch)) initial-patch))
(define (mux-remove-stream m label) (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 '<mux-remove-stream> ?))))
(define (mux-update-stream m label delta-orig) (define (mux-update-stream m label delta-orig)
(define old-interests (mux-interests-of m label)) (define old-interests (mux-interests-of m label))
@ -67,22 +67,22 @@
delta delta
delta-aggregate)) delta-aggregate))
(define at-meta-everything (pattern->trie #t (at-meta ?))) (define at-meta-everything (pattern->trie '<at-meta-everything> (at-meta ?)))
(define (echo-cancelled-trie t) (define (echo-cancelled-trie t)
(trie-subtract t (trie-subtract t
at-meta-everything at-meta-everything
#:combiner (lambda (v1 v2) #:combiner (lambda (v1 v2)
(if (tset-member? v1 'meta) (if (tset-member? v1 'meta)
only-meta-tset (trie-success only-meta-tset)
#f)))) trie-empty))))
(define (compute-patches old-m new-m label delta delta-aggregate) (define (compute-patches old-m new-m label delta delta-aggregate)
(define delta-aggregate/no-echo (define delta-aggregate/no-echo
(if (meta-label? label) (if (meta-label? label)
delta delta
(patch (trie-prune-branch (patch-added delta-aggregate) struct:at-meta) (patch (trie-prune-branch (patch-added delta-aggregate) at-meta-parenthesis)
(trie-prune-branch (patch-removed delta-aggregate) struct:at-meta)))) (trie-prune-branch (patch-removed delta-aggregate) at-meta-parenthesis))))
(define old-routing-table (mux-routing-table old-m)) (define old-routing-table (mux-routing-table old-m))
(define new-routing-table (mux-routing-table new-m)) (define new-routing-table (mux-routing-table new-m))
(define affected-pids (define affected-pids
@ -110,11 +110,9 @@
(define (compute-affected-pids routing-table delta) (define (compute-affected-pids routing-table delta)
(define cover (trie-union (patch-added delta) (patch-removed delta))) (define cover (trie-union (patch-added delta) (patch-removed delta)))
(trie-match-trie cover (trie-match-trie cover
(trie-step routing-table struct:observe) (trie-step routing-table observe-parenthesis)
#:seed datum-tset-empty #:seed datum-tset-empty
#:combiner (lambda (v1 v2 acc) (tset-union v2 acc)) #: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) (define (mux-route-message m body)
(if (trie-lookup (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
@ -122,7 +120,7 @@
(tset->list (trie-lookup (mux-routing-table m) (observe body) datum-tset-empty)))) (tset->list (trie-lookup (mux-routing-table m) (observe body) datum-tset-empty))))
(define (mux-interests-of m label) (define (mux-interests-of m label)
(hash-ref (mux-interest-table m) label (trie-empty))) (hash-ref (mux-interest-table m) label trie-empty))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

106
prospect/patch.rkt
View File

@ -5,7 +5,9 @@
(struct-out observe) (struct-out observe)
(struct-out at-meta) (struct-out at-meta)
(struct-out advertise) (struct-out advertise)
empty-patch observe-parenthesis
at-meta-parenthesis
patch-empty
patch-empty? patch-empty?
patch-non-empty? patch-non-empty?
patch/added? patch/added?
@ -39,7 +41,7 @@
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require "route.rkt") (require "trie.rkt")
(require "tset.rkt") (require "tset.rkt")
(require "pretty.rkt") (require "pretty.rkt")
(module+ test (require rackunit)) (module+ test (require rackunit))
@ -58,11 +60,12 @@
(struct at-meta (claim) #:prefab) (struct at-meta (claim) #:prefab)
(struct advertise (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) (define (patch-empty? p)
(and (patch? p) (and (patch? p)
@ -79,13 +82,11 @@
(define (lift-patch p) (define (lift-patch p)
(match-define (patch in out) p) (match-define (patch in out) p)
(patch (pattern->trie #t (at-meta (embedded-trie in))) (patch (pattern->trie '<lift-patch> (at-meta (embedded-trie in)))
(pattern->trie #t (at-meta (embedded-trie out))))) (pattern->trie '<lift-patch> (at-meta (embedded-trie out)))))
(define (drop-interests pi) (define (drop-interests pi)
(trie-project pi at-meta-proj (trie-step pi at-meta-parenthesis))
#:project-success (lambda (v) #t)
#:combiner (lambda (v1 v2) #t)))
(define (drop-patch p) (define (drop-patch p)
(match-define (patch in out) p) (match-define (patch in out) p)
@ -93,7 +94,7 @@
(drop-interests out))) (drop-interests out)))
(define (strip-interests g) (define (strip-interests g)
(trie-relabel g (lambda (v) #t))) (trie-relabel g (lambda (v) '<strip-interests>)))
(define (label-interests g label) (define (label-interests g label)
(trie-relabel g (lambda (v) label))) (trie-relabel g (lambda (v) label)))
@ -114,8 +115,8 @@
;; arguments. ;; arguments.
(define (limit-patch p bound) (define (limit-patch p bound)
(match-define (patch in out) p) (match-define (patch in out) p)
(patch (trie-subtract in bound #:combiner (lambda (v1 v2) #f)) (patch (trie-subtract in bound #:combiner (lambda (v1 v2) trie-empty))
(trie-intersect out bound #:combiner (lambda (v1 v2) v1)))) (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 ;; 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 ;; 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 ;; keep the point in the case that the only interest present is
;; `'meta`-labeled interest. ;; `'meta`-labeled interest.
(if (and remove-meta? (eq? v2 only-meta-tset)) ;; N.B. relies on canonicity of v2 ! (if (and remove-meta? (eq? v2 only-meta-tset)) ;; N.B. relies on canonicity of v2 !
v1 (trie-success v1)
#f)) trie-empty))
(define (rem-combiner v1 v2) (define (rem-combiner v1 v2)
;; Keep only points where `p` would remove, where `label` interest ;; Keep only points where `p` would remove, where `label` interest
;; is present, and where no non-`label` interest is present. We ;; 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 ;; case), or when exactly `label` and `'meta` interest exists, and
;; in no other case. ;; in no other case.
(if (= (tset-count v2) 1) (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? (if (and remove-meta?
(= (tset-count v2) 2) (= (tset-count v2) 2)
(tset-member? v2 'meta)) (tset-member? v2 'meta))
v1 ;; remove-meta? is true, and exactly `label` and `'meta` interest exists here. (trie-success v1)
#f))) ;; other interest exists here, so we should discard this removed-point. ;; ^ 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) (patch (trie-subtract (patch-added p) base #:combiner add-combiner)
(trie-subtract (patch-removed p) base #:combiner rem-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. ;; Like apply-patch, but for use by Tries leading to True.
(define (update-interests base p) (define (update-interests base p)
(match-define (patch in out) p) (match-define (patch in out) p)
(trie-union (trie-subtract base out #:combiner (lambda (v1 v2) #f)) in (trie-union (trie-subtract base out #:combiner (lambda (v1 v2) trie-empty)) in
#:combiner (lambda (v1 v2) #t))) #:combiner (lambda (v1 v2) (trie-success '<update-interests>))))
(define (unapply-patch base p) (define (unapply-patch base p)
(match-define (patch in out) p) (match-define (patch in out) p)
@ -216,14 +220,14 @@
(match-define (patch in1 out1) p1) (match-define (patch in1 out1) p1)
(match-define (patch in2 out2) p2) (match-define (patch in2 out2) p2)
(patch (update-interests in1 p2) (patch (update-interests in1 p2)
(trie-union (trie-subtract out1 in2 #:combiner (lambda (v1 v2) #f)) out2 (trie-union (trie-subtract out1 in2 #:combiner (lambda (v1 v2) trie-empty)) out2
#:combiner (lambda (v1 v2) #t)))) #:combiner (lambda (v1 v2) (trie-success '<compose-patch>)))))
(define (patch-seq . patches) (patch-seq* patches)) (define (patch-seq . patches) (patch-seq* patches))
(define (patch-seq* patches) (define (patch-seq* patches)
(match patches (match patches
['() empty-patch] ['() patch-empty]
[(cons p rest) (compose-patch (patch-seq* rest) p)])) [(cons p rest) (compose-patch (patch-seq* rest) p)]))
(define (compute-patch old-base new-base) (define (compute-patch old-base new-base)
@ -232,9 +236,8 @@
(define (biased-intersection object subject) (define (biased-intersection object subject)
(trie-intersect object (trie-intersect object
(trie-step subject struct:observe) (trie-step subject observe-parenthesis)
#:combiner (lambda (v1 v2) #t) #:combiner (lambda (v1 v2) (trie-success v1))))
#:left-short (lambda (v r) (trie-step r EOS))))
(define (view-patch p interests) (define (view-patch p interests)
(patch (biased-intersection (patch-added p) interests) (patch (biased-intersection (patch-added p) interests)
@ -248,9 +251,10 @@
(match-define (patch in out) p) (match-define (patch in out) p)
(patch (trie-project in spec) (trie-project out spec))) (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) (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) (define (patch-project/set/single p spec)
(match-define (patch in out) p) (match-define (patch in out) p)
@ -269,7 +273,7 @@
(module+ test (module+ test
(define (set->trie label xs) (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)))) (trie-union acc (pattern->trie label x))))
;; Retains only entries in R labelled with any subset of the labels in label-set. ;; Retains only entries in R labelled with any subset of the labels in label-set.
@ -282,7 +286,7 @@
(define (sanity-check-examples) (define (sanity-check-examples)
(define SP (tset 'P)) (define SP (tset 'P))
(define m0 (trie-empty)) (define m0 trie-empty)
(define ma (pattern->trie SP 'a)) (define ma (pattern->trie SP 'a))
(define mb (pattern->trie SP 'b)) (define mb (pattern->trie SP 'b))
(define mc (pattern->trie SP 'c)) (define mc (pattern->trie SP 'c))
@ -427,7 +431,7 @@
(let* ((ma (set->trie (tset 'a) (set 1))) (let* ((ma (set->trie (tset 'a) (set 1)))
(mb (set->trie (tset 'b) (set 1))) (mb (set->trie (tset 'b) (set 1)))
(mmeta (set->trie (tset 'meta) (set 1))) (mmeta (set->trie (tset 'meta) (set 1)))
(R0 (trie-empty)) (R0 trie-empty)
(R1 mmeta) (R1 mmeta)
(R2 mb) (R2 mb)
(R3 (trie-union mb mmeta)) (R3 (trie-union mb mmeta))
@ -435,9 +439,9 @@
(R5 (trie-union ma mmeta)) (R5 (trie-union ma mmeta))
(R6 (trie-union ma mb)) (R6 (trie-union ma mb))
(R7 (trie-union (trie-union ma mb) mmeta)) (R7 (trie-union (trie-union ma mb) mmeta))
(p0 empty-patch) (p0 patch-empty)
(p+ (patch (set->trie (tset 'a) (set 1)) (trie-empty))) (p+ (patch (set->trie (tset 'a) (set 1)) trie-empty))
(p- (patch (trie-empty) (set->trie (tset 'a) (set 1))))) (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 R0) p0)
(check-equal? (compute-aggregate-patch p0 'a R1) p0) (check-equal? (compute-aggregate-patch p0 'a R1) p0)
(check-equal? (compute-aggregate-patch p0 'a R2) 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) (check-equal? (compute-aggregate-patch p- 'a R7 #:remove-meta? #t) p0)
) )
(let ((m1 (set->trie #t (set 1 2))) (let ((m1 (set->trie '<m1> (set 1 2)))
(m2 (set->trie (tset 'a) (set 1 2))) (m2 (set->trie (tset 'a) (set 1 2)))
(p1 (patch (set->trie #t (set 2 3)) (trie-empty))) (p1 (patch (set->trie '<p1> (set 2 3)) trie-empty))
(p2 (patch (set->trie (tset 'a) (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))) (check-equal? (limit-patch p1 m1) (patch (set->trie '<p1> (set 3)) trie-empty))
;; This is false because the resulting patch has tset labelling: (check-equal? (limit-patch p1 m2) (patch (set->trie '<p1> (set 3)) trie-empty))
(check-false (equal? (limit-patch p2 m1) (check-equal? (limit-patch p2 m1) (patch (set->trie (tset 'a) (set 3)) trie-empty))
(patch (set->trie #t (set 3)) (trie-empty)))) (check-equal? (limit-patch p2 m2) (patch (set->trie (tset 'a) (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)))
) )
(let ((m1 (set->trie #t (set 1 2))) (let ((m1 (set->trie '<m1> (set 1 2)))
(m2 (set->trie (tset 'a) (set 1 2))) (m2 (set->trie (tset 'a) (set 1 2)))
(p1 (patch (trie-empty) (set->trie #t (set 2 3)))) (p1 (patch trie-empty (set->trie '<p1> (set 2 3))))
(p2 (patch (trie-empty) (set->trie (tset 'a) (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)))) (check-equal? (limit-patch p1 m1) (patch trie-empty (set->trie '<p1> (set 2))))
;; This is false because the resulting patch has tset labelling: (check-equal? (limit-patch p1 m2) (patch trie-empty (set->trie '<p1> (set 2))))
(check-false (equal? (limit-patch p2 m1) (check-equal? (limit-patch p2 m1) (patch trie-empty (set->trie (tset 'a) (set 2))))
(patch (trie-empty) (set->trie #t (set 2))))) (check-equal? (limit-patch p2 m2) (patch trie-empty (set->trie (tset 'a) (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))))
) )
) )

2
prospect/pretty.rkt
View File

@ -13,7 +13,7 @@
(require racket/pretty) (require racket/pretty)
(require racket/exn) (require racket/exn)
(require (only-in racket/string string-join string-split)) (require (only-in racket/string string-join string-split))
(require "route.rkt") (require "trie.rkt")
(define-generics prospect-pretty-printable (define-generics prospect-pretty-printable
(prospect-pretty-print prospect-pretty-printable [port]) (prospect-pretty-print prospect-pretty-printable [port])

1656
prospect/route.rkt
View File

File diff suppressed because it is too large Load Diff

90
prospect/trie.rkt
View File

@ -4,8 +4,12 @@
;; TODO: examples showing the idea. ;; TODO: examples showing the idea.
(provide (rename-out [success trie-success] (require racket/contract)
[success? trie-success?] (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]) [success-value trie-success-value])
(rename-out [open-parenthesis <open-parenthesis>] (rename-out [open-parenthesis <open-parenthesis>]
@ -18,7 +22,7 @@
(struct-out capture) (struct-out capture)
?! ?!
(rename-out [empty trie-empty]) trie-empty
trie? trie?
trie trie
trie-empty? trie-empty?
@ -35,10 +39,10 @@
tset-union-combiner tset-union-combiner
tset-subtract-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-union-all
trie-intersect
trie-subtract
trie-lookup trie-lookup
trie-match-trie trie-match-trie
@ -150,22 +154,25 @@
(define (?! [pattern ?]) (capture pattern)) (define (?! [pattern ?]) (capture pattern))
;; Trie ;; Trie
(define empty (canonicalize #f)) (define trie-empty (canonicalize #f))
;; Any -> Boolean ;; Any -> Boolean
;; Predicate recognising Tries. ;; Predicate recognising Tries.
(define (trie? x) (define (trie? x)
(or (eq? x empty) (or (eq? x trie-empty)
(success? x) (success? x)
(branch? 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 ;; Pattern Any {Pattern Any ...} -> Trie
;; Constructs a trie as the union of the given pattern/value pairings. ;; Constructs a trie as the union of the given pattern/value pairings.
;; (trie) is the empty trie. ;; (trie) is the empty trie.
(define (trie . args) (define (trie . args)
(let loop ((args args)) (let loop ((args args))
(match args (match args
['() empty] ['() trie-empty]
[(list* pat val rest) (trie-union (loop rest) (pattern->trie val pat))] [(list* pat val rest) (trie-union (loop rest) (pattern->trie val pat))]
[_ (error 'trie "Uneven argument list: expects equal numbers of patterns and values")]))) [_ (error 'trie "Uneven argument list: expects equal numbers of patterns and values")])))
@ -234,7 +241,7 @@
;; otherwise, returns the argument. ;; otherwise, returns the argument.
(define (collapse r) (define (collapse r)
(match 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])) [_ r]))
;; Trie -> Trie ;; Trie -> Trie
@ -242,7 +249,7 @@
;; that is equivalent to the empty trie. Inverse of `collapse`. ;; that is equivalent to the empty trie. Inverse of `collapse`.
(define (expand r) (define (expand r)
(if (trie-empty? r) (if (trie-empty? r)
(canonicalize (branch empty-omap empty empty-smap)) (canonicalize (branch empty-omap trie-empty empty-smap))
r)) r))
;; Sigma Trie -> Trie ;; Sigma Trie -> Trie
@ -250,12 +257,12 @@
(define (rsigma e r) (define (rsigma e r)
(if (trie-empty? r) (if (trie-empty? r)
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 ;; [ Sigma Trie ] ... -> Trie
(define (rsigma-multi . ers) (define (rsigma-multi . ers)
(canonicalize (branch empty-omap (canonicalize (branch empty-omap
empty trie-empty
(let walk ((ers ers)) (let walk ((ers ers))
(match ers (match ers
[(list* e r rest) (treap-insert (walk rest) e r)] [(list* e r rest) (treap-insert (walk rest) e r)]
@ -287,7 +294,7 @@
(if (trie-empty? r) (if (trie-empty? r)
r r
(canonicalize (branch (treap-insert empty-omap (canonical-open-parenthesis arity type) r) (canonicalize (branch (treap-insert empty-omap (canonical-open-parenthesis arity type) r)
empty trie-empty
empty-smap)))) empty-smap))))
;; Natural Trie -> Trie ;; Natural Trie -> Trie
@ -478,10 +485,10 @@
;; (Listof Trie) [#:combiner (Any Any -> Trie)] -> Trie ;; (Listof Trie) [#:combiner (Any Any -> Trie)] -> Trie
;; n-ary trie-union. ;; n-ary trie-union.
(define (trie-union-all tries #:combiner [combiner tset-union-combiner]) (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 ;; Any -> Trie
(define (->empty t) empty) (define (->empty t) trie-empty)
;; Trie Trie -> Trie ;; Trie Trie -> Trie
;; Computes the intersection of the tries passed in. Treats them as multimaps by default. ;; Computes the intersection of the tries passed in. Treats them as multimaps by default.
@ -489,13 +496,13 @@
(define (combine-success r1 r2) (define (combine-success r1 r2)
(match* (r1 r2) (match* (r1 r2)
[((success v1) (success v2)) (canonicalize (combiner v1 v2))] [((success v1) (success v2)) (canonicalize (combiner v1 v2))]
[((? trie-empty?) _) empty] [((? trie-empty?) _) trie-empty]
[(_ (? trie-empty?)) empty] [(_ (? trie-empty?)) trie-empty]
[(_ _) (asymmetric-trie-error 'trie-intersect r1 r2)])) [(_ _) (asymmetric-trie-error 'trie-intersect r1 r2)]))
(trie-combine combine-success ->empty ->empty ->empty ->empty re1 re2)) (trie-combine combine-success ->empty ->empty ->empty ->empty re1 re2))
(define (empty-tset-guard s) (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) (define (tset-subtract-combiner s1 s2)
(empty-tset-guard (tset-subtract s1 s2))) (empty-tset-guard (tset-subtract s1 s2)))
@ -506,7 +513,7 @@
(define (combine-success r1 r2) (define (combine-success r1 r2)
(match* (r1 r2) (match* (r1 r2)
[((success v1) (success v2)) (canonicalize (combiner v1 v2))] [((success v1) (success v2)) (canonicalize (combiner v1 v2))]
[((? trie-empty?) _) empty] [((? trie-empty?) _) trie-empty]
[(r (? trie-empty?)) r] [(r (? trie-empty?)) r]
[(_ _) (asymmetric-trie-error 'trie-subtract r1 r2)])) [(_ _) (asymmetric-trie-error 'trie-subtract r1 r2)]))
(trie-combine combine-success ->empty values values ->empty re1 re2)) (trie-combine combine-success ->empty values values ->empty re1 re2))
@ -551,7 +558,7 @@
(walk vs1 (rlookup-sigma r (canonicalize v)))])])) (walk vs1 (rlookup-sigma r (canonicalize v)))])]))
(walk (list v) r)) (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, ;; Similar to trie-lookup, but instead of a single key,
;; accepts a Trie serving as *multiple* simultaneously-examined ;; accepts a Trie serving as *multiple* simultaneously-examined
@ -591,7 +598,7 @@
(define (trie-append m0 m-tail-fn) (define (trie-append m0 m-tail-fn)
(let walk ((m m0)) (let walk ((m m0))
(match m (match m
[(? trie-empty?) empty] [(? trie-empty?) trie-empty]
[(success v) (canonicalize (m-tail-fn v))] [(success v) (canonicalize (m-tail-fn v))]
[(branch os w0 h) [(branch os w0 h)
(define w (walk w0)) (define w (walk w0))
@ -611,7 +618,7 @@
(define (trie-relabel t f) (define (trie-relabel t f)
(trie-append t (lambda (v) (trie-append t (lambda (v)
(match (f v) (match (f v)
[#f empty] [#f trie-empty]
[result (success result)])))) [result (success result)]))))
;; Trie (U OpenParenthesis Sigma) -> Trie ;; Trie (U OpenParenthesis Sigma) -> Trie
@ -621,9 +628,9 @@
(define (trie-prune-branch m key) (define (trie-prune-branch m key)
(match* (m key) (match* (m key)
[((branch os w h) (open-parenthesis arity _)) [((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) _) [((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])) [(_ _) m]))
;; Trie (U OpenParenthesis Sigma) -> Trie ;; Trie (U OpenParenthesis Sigma) -> Trie
@ -633,7 +640,7 @@
(rlookup-open m key)] (rlookup-open m key)]
[((? branch?) _) [((? branch?) _)
(rlookup-sigma m key)] (rlookup-sigma m key)]
[(_ _) empty])) [(_ _) trie-empty]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Projection ;; Projection
@ -734,7 +741,7 @@
[other0 [other0
(define other (canonicalize other0)) (define other (canonicalize other0))
(rsigma other (walk/capture (rlookup-sigma t other) specs-rest kont))])] (rsigma other (walk/capture (rlookup-sigma t other) specs-rest kont))])]
[_ empty])])) [_ trie-empty])]))
;; Trie (Listof Projection) (Trie -> Trie) -> Trie ;; Trie (Listof Projection) (Trie -> Trie) -> Trie
;; As walk/capture, but without capturing. ;; As walk/capture, but without capturing.
@ -773,12 +780,12 @@
[other0 [other0
(define other (canonicalize other0)) (define other (canonicalize other0))
(walk (rlookup-sigma t other) specs-rest kont)])] (walk (rlookup-sigma t other) specs-rest kont)])]
[_ empty])])) [_ trie-empty])]))
(walk whole-t (list whole-spec) (walk whole-t (list whole-spec)
(match-lambda (match-lambda
[(success v) (canonicalize (project-success v))] [(success v) (canonicalize (project-success v))]
[_ empty]))) [_ trie-empty])))
;; ParenType (Listof Value) -> Value ;; ParenType (Listof Value) -> Value
;; Wraps a sequence of values in the given parenthesis type, reconstructing the "original" value. ;; Wraps a sequence of values in the given parenthesis type, reconstructing the "original" value.
@ -1025,7 +1032,7 @@
(walk rest)]))) (walk rest)])))
(check-matches (check-matches
empty trie-empty
(list 'z 'x) "" (list 'z 'x) ""
'foo "" 'foo ""
(list (list 'z (list 'z))) "") (list (list 'z (list 'z))) "")
@ -1313,21 +1320,21 @@
(check-requal? (intersect 123 ?) (rsigma 123 EAB)) (check-requal? (intersect 123 ?) (rsigma 123 EAB))
(check-requal? (intersect (list ? 2) (list 1 ?)) (rlist 2 (rsigma* 1 2 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 (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 (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)) (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 '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) (a ?)) (ropen 1 struct:a (rsigma* 'a EAB)))
(check-requal? (intersect (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 '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) (b ?)) (ropen 1 struct:b (rsigma* 'a EAB)))
(check-requal? (intersect (b 'a) ?) (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" (check-exn #px"Cannot match on treaps at present"
(lambda () (lambda ()
@ -1584,8 +1591,7 @@
(define full (trie ? default-label)) (define full (trie ? default-label))
(define positive-trie/e (define positive-trie/e
(pam/e (lambda (pats) (foldr trie-union empty (pam/e (lambda (pats) (trie-union-all (map (lambda (pat) (trie pat default-label)) pats)))
(map (lambda (pat) (trie pat default-label)) pats)))
#:contract trie? #:contract trie?
(listof/e pattern/e))) (listof/e pattern/e)))
@ -1664,7 +1670,7 @@
(define (reconstruct t) (define (reconstruct t)
(match-define `((added ,a ...) (removed ,r ...)) (trie->patterns 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-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)) r))
;; (newline) (for ((i 15)) (void (time (reconstruct (random-instance positive-trie/e))))) ;; (newline) (for ((i 15)) (void (time (reconstruct (random-instance positive-trie/e)))))
@ -1687,16 +1693,16 @@
complex-trie/e complex-trie/e
complex-trie/e) complex-trie/e)
(check-property #:name 'empty-is-identity-for-union (check-property #:name 'empty-is-identity-for-union
(lambda (t) (and (requal? t (trie-union t empty)) (lambda (t) (and (requal? t (trie-union t trie-empty))
(requal? t (trie-union empty t)))) (requal? t (trie-union trie-empty t))))
complex-trie/e) complex-trie/e)
(check-property #:name 'full-is-zero-for-union (check-property #:name 'full-is-zero-for-union
(lambda (t) (and (requal? full (trie-union t full)) (lambda (t) (and (requal? full (trie-union t full))
(requal? full (trie-union full t)))) (requal? full (trie-union full t))))
complex-trie/e) complex-trie/e)
(check-property #:name 'empty-is-zero-for-intersection (check-property #:name 'empty-is-zero-for-intersection
(lambda (t) (and (requal? empty (trie-intersect t empty)) (lambda (t) (and (requal? trie-empty (trie-intersect t trie-empty))
(requal? empty (trie-intersect empty t)))) (requal? trie-empty (trie-intersect trie-empty t))))
complex-trie/e) complex-trie/e)
(check-property #:name 'full-is-identity-for-intersection (check-property #:name 'full-is-identity-for-intersection
(lambda (t) (and (requal? t (trie-intersect t full)) (lambda (t) (and (requal? t (trie-intersect t full))