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

20
prospect-monolithic/core.rkt
View File

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

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

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

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

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

4
prospect-monolithic/ground.rkt
View File

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

20
prospect-monolithic/mux.rkt
View File

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

20
prospect-monolithic/scn.rkt
View File

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

14
prospect/actor.rkt
View File

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

12
prospect/big-bang.rkt
View File

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

59
prospect/comprehensions.rkt
View File

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

22
prospect/core.rkt
View File

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

36
prospect/demand-matcher.rkt
View File

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

6
prospect/drivers/timer.rkt
View File

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

12
prospect/endpoint.rkt
View File

@ -15,7 +15,7 @@
(require racket/set)
(require racket/match)
(require (only-in racket/list flatten))
(require "route.rkt")
(require "trie.rkt")
(require "patch.rkt")
(require "core.rkt")
(require "mux.rkt")
@ -54,7 +54,7 @@
(define (boot-endpoint-group initial-state initial-actions)
(define-values (final-cumulative-patch final-actions final-g)
(interpret-endpoint-actions empty-patch
(interpret-endpoint-actions patch-empty
'()
(make-endpoint-group initial-state)
-1
@ -88,7 +88,7 @@
(define (sequence-handlers g tasks)
(let/ec return
(define-values (final-cumulative-patch final-actions final-g idle?)
(for/fold ([cumulative-patch empty-patch]
(for/fold ([cumulative-patch patch-empty]
[actions '()]
[g g]
[idle? #t])
@ -125,14 +125,14 @@
(match endpoint-action
[(or (? message?)
(? spawn?))
(values empty-patch
(values patch-empty
(cons (incorporate-cumulative-patch actions cumulative-patch) endpoint-action)
g)]
[(? patch? p0)
(interpret-endpoint-patch cumulative-patch actions g eid p0)]
[(add-endpoint function)
(define-values (new-mux new-eid _p _p-aggregate)
(mux-add-stream (endpoint-group-mux g) empty-patch))
(mux-add-stream (endpoint-group-mux g) patch-empty))
(define-values (new-ep initial-transition) (function new-eid (endpoint-group-state g)))
(interpret-endpoint-actions cumulative-patch
actions
@ -152,7 +152,7 @@
[endpoints
(hash-remove (endpoint-group-endpoints g) eid)])
eid
(patch (trie-empty) (pattern->trie #t ?)))]
(patch trie-empty (pattern->trie '<delete-endpoint> ?)))]
[(as-endpoint 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
[(? patch? p)
(define-values (in out)
(patch-project/set/single p
(compile-projection
(at-meta (?! (active-window ?))))))
(patch-project/set/single p (at-meta (?! (active-window ?)))))
(transition s (update-window 'active-window-label 300 0
(text (format "~v" in) 22 "black")))]
[_ #f]))

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

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

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

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

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

@ -48,10 +48,9 @@
[(message (says who what))
(say who "says: ~a" what)]
[(? patch? p)
(if (patch/removed? (patch-project p (compile-projection (tcp-remote-open id))))
(if (patch/removed? (patch-project p (tcp-remote-open id)))
(quit)
(let-values (((arrived departed)
(patch-project/set/single p (compile-projection (present (?!))))))
(let-values (((arrived departed) (patch-project/set/single p (present (?!)))))
(list (for/list [(who arrived)] (say who "arrived."))
(for/list [(who departed)] (say who "departed.")))))]
[#f #f]))

4
prospect/examples/chat.rkt
View File

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

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

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

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

@ -1,7 +1,7 @@
#lang prospect
;; Test case for a historical bug in Syndicate.
;;
;; When the bug existed, this program receiveed four SCN events in
;; When the bug existed, this program received four SCN events in
;; total, whereas it should receive only two.
;;
;; While metamessages were "echo cancelled", and receivers only ever

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

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

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

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

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

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

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

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

4
prospect/ground.rkt
View File

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

24
prospect/mux.rkt
View File

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

106
prospect/patch.rkt
View File

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

2
prospect/pretty.rkt
View File

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

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