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

Reimplement Syndicate/Racket with a new design. 

This is Syndicate/Racket v2, modeled more closely after Syndicate/js.
Facets and Endpoints are now contained within a single actor, unlike
Syndicate/Racket v1, where a linkage protocol between multiple actors
was used. The approach to actor and facet state has been revised as a
consequence.

Almost all the examples using syndicate/actor have been updated.
This commit is contained in:
Tony Garnock-Jones 2016-07-09 16:18:30 -04:00
parent 52aed3111c
commit 8ca2b1ac0c
25 changed files with 890 additions and 1029 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1436
racket/syndicate/actor.rkt
View File

File diff suppressed because it is too large Load Diff

4
racket/syndicate/broker/server.rkt
View File

@ -121,7 +121,7 @@
[_ #f])) [_ #f]))
(run-ground (spawn-timer-driver) (run-ground (spawn-timer-driver)
(spawn-websocket-driver) (spawn-websocket-driver)
(dataspace (perform-core-action! (spawn-broker-server 8000)) (dataspace (schedule-action! (spawn-broker-server 8000))
(when ssl-options (when ssl-options
(perform-core-action! (spawn-broker-server 8443 #:ssl-options ssl-options))) (schedule-action! (spawn-broker-server 8443 #:ssl-options ssl-options)))
(forever)))) (forever))))

12
racket/syndicate/examples/actor/bank-account.rkt
View File

@ -6,13 +6,13 @@
(struct account (balance) #:prefab) (struct account (balance) #:prefab)
(struct deposit (amount) #:prefab) (struct deposit (amount) #:prefab)
(actor (forever #:collect [(balance 0)] (actor (react (field [balance 0])
(assert (account balance)) (assert (account (balance)))
(on (message (deposit $amount)) (on (message (deposit $amount))
(+ balance amount)))) (balance (+ (balance) amount)))))
(actor (forever (on (asserted (account $balance)) (actor (react (on (asserted (account $balance))
(printf "Balance changed to ~a\n" balance)))) (printf "Balance changed to ~a\n" balance))))
(actor (until (asserted (observe (deposit _)))) (actor (until (asserted (observe (deposit _))))
(send! (deposit +100)) (send! (deposit +100))

20
racket/syndicate/examples/actor/box-and-client.rkt
View File

@ -6,12 +6,16 @@
(struct set-box (new-value) #:transparent) (struct set-box (new-value) #:transparent)
(struct box-state (value) #:transparent) (struct box-state (value) #:transparent)
(actor (forever #:collect [(current-value 0)] (actor (react (field [current-value 0])
(assert (box-state current-value)) (assert (box-state (current-value)))
(on (message (set-box $new-value)) (stop-when (rising-edge (= (current-value) 10))
(log-info "box: taking on new-value ~v" new-value) (log-info "box: terminating"))
new-value))) (on (message (set-box $new-value))
(log-info "box: taking on new-value ~v" new-value)
(current-value new-value))))
(actor (forever (on (asserted (box-state $v)) (actor (react (stop-when (retracted (observe (set-box _)))
(log-info "client: learned that box's value is now ~v" v) (log-info "client: box has gone"))
(send! (set-box (+ v 1)))))) (on (asserted (box-state $v))
(log-info "client: learned that box's value is now ~v" v)
(send! (set-box (+ v 1))))))

8
racket/syndicate/examples/actor/broadcast-messages.rkt
View File

@ -5,11 +5,11 @@
(struct envelope (destination message) #:prefab) (struct envelope (destination message) #:prefab)
(actor (forever (on (message (envelope 'alice $message)) (actor (react (on (message (envelope 'alice $message))
(log-info "Alice received ~v" message)))) (log-info "Alice received ~v" message))))
(actor (forever (on (message (envelope 'bob $message)) (actor (react (on (message (envelope 'bob $message))
(log-info "Bob received ~v" message)))) (log-info "Bob received ~v" message))))
(actor (actor
(log-info "Waiting for Alice and Bob.") (log-info "Waiting for Alice and Bob.")

2
racket/syndicate/examples/actor/chain.rkt
View File

@ -8,7 +8,7 @@
(define (sleep sec) (define (sleep sec)
(define timer-id (gensym 'sleep)) (define timer-id (gensym 'sleep))
(until (message (timer-expired timer-id _)) (until (message (timer-expired timer-id _))
#:init [(send! (set-timer timer-id (* sec 1000.0) 'relative))])) (on-start (send! (set-timer timer-id (* sec 1000.0) 'relative)))))
(define (chain-step n) (define (chain-step n)
(printf "chain-step ~v\n" n) (printf "chain-step ~v\n" n)

20
racket/syndicate/examples/actor/chat-client.rkt
View File

@ -10,13 +10,15 @@
(spawn-tcp-driver) (spawn-tcp-driver)
(forever (on (message (external-event stdin-evt (list $line)) #:meta-level 1) (actor
(if (eof-object? line) (react/suspend (quit)
(return!) (on (message (external-event stdin-evt (list $line)) #:meta-level 1)
(send! (tcp-channel local-handle remote-handle line)))) (if (eof-object? line)
(quit)
(send! (tcp-channel local-handle remote-handle line))))
(assert (advertise (tcp-channel local-handle remote-handle _))) (assert (advertise (tcp-channel local-handle remote-handle _)))
(on (retracted (advertise (tcp-channel remote-handle local-handle _))) (return!)) (on (retracted (advertise (tcp-channel remote-handle local-handle _))) (quit))
(on (message (tcp-channel remote-handle local-handle $bs)) (on (message (tcp-channel remote-handle local-handle $bs))
(write-bytes bs) (write-bytes bs)
(flush-output))) (flush-output))))

7
racket/syndicate/examples/actor/chat-no-quit-world-no-nesting.rkt
View File

@ -31,6 +31,7 @@
(spawn-tcp-driver) (spawn-tcp-driver)
(define us (tcp-listener 5999)) (define us (tcp-listener 5999))
(forever (assert (advertise (observe (tcp-channel _ us _)))) (actor
(on (asserted (advertise (tcp-channel $them us _))) (forever (assert (advertise (observe (tcp-channel _ us _))))
(spawn-session them us))) (on (asserted (advertise (tcp-channel $them us _)))
(spawn-session them us))))

18
racket/syndicate/examples/actor/chat-simplified-internals.rkt
View File

@ -40,13 +40,13 @@
(actor (forever (assert (advertise (observe (tcp-channel _ us _)))) (actor (forever (assert (advertise (observe (tcp-channel _ us _))))
(on (asserted (advertise (tcp-channel $them us _))) (on (asserted (advertise (tcp-channel $them us _)))
(define id (seal (list them us))) (define id (seal (list them us)))
(actor (state [(assert (tcp-remote-open id)) (actor (react (stop-when (retracted (advertise (tcp-channel them us _))))
(on (message (tcp-channel them us $bs)) (stop-when (retracted (tcp-local-open id)))
(send! (tcp-incoming-data id bs))) (assert (tcp-remote-open id))
(on (message (tcp-outgoing-data id $bs)) (on (message (tcp-channel them us $bs))
(send! (tcp-channel us them bs)))] (send! (tcp-incoming-data id bs)))
[(retracted (advertise (tcp-channel them us _))) (void)] (on (message (tcp-outgoing-data id $bs))
[(retracted (tcp-local-open id)) (void)]))))) (send! (tcp-channel us them bs))))))))
(forever (on (asserted (tcp-remote-open $id)) (actor (forever (on (asserted (tcp-remote-open $id))
(spawn-session id))) (spawn-session id))))

16
racket/syndicate/examples/actor/echo.rkt
View File

@ -6,11 +6,11 @@
(spawn-tcp-driver) (spawn-tcp-driver)
(define server-id (tcp-listener 5999)) (define server-id (tcp-listener 5999))
(forever (assert (advertise (observe (tcp-channel _ server-id _)))) (actor
(on (asserted (advertise (tcp-channel $c server-id _))) (forever (assert (advertise (observe (tcp-channel _ server-id _))))
(printf "Accepted connection from ~v\n" c) (during/actor (advertise (tcp-channel $c server-id _))
(actor (until (retracted (advertise (tcp-channel c server-id _))) (on-start (printf "Accepted connection from ~v\n" c))
(assert (advertise (tcp-channel server-id c _))) (assert (advertise (tcp-channel server-id c _)))
(on (message (tcp-channel c server-id $bs)) (on (message (tcp-channel c server-id $bs))
(send! (tcp-channel server-id c bs)))) (send! (tcp-channel server-id c bs)))
(printf "Closed connection ~v\n" c)))) (on-stop (printf "Closed connection ~v\n" c)))))

9
racket/syndicate/examples/actor/example-during-criterion-snapshotting.rkt
View File

@ -19,9 +19,10 @@
(struct foo (x y) #:prefab) (struct foo (x y) #:prefab)
(actor (define x 123) (actor (define x 123)
(forever (react
(assert (foo x 999)) (assert (foo x 999))
(during (foo x $v) (during (foo x $v)
#:init [(log-info "x=~a v=~a" x v) (log-info "x=~a v=~a" x v)
(when (= x 123) (set! x 124))] (when (= x 123) (set! x 124))
#:done [(log-info "finally for x=~a v=~a" x v)]))) (on-stop
(log-info "finally for x=~a v=~a" x v)))))

17
racket/syndicate/examples/actor/example-partial-retraction.rkt
View File

@ -7,7 +7,7 @@
(struct ready (what) #:prefab) (struct ready (what) #:prefab)
(struct entry (key val) #:prefab) (struct entry (key val) #:prefab)
(actor (forever (actor (react
(assert (ready 'listener)) (assert (ready 'listener))
(on (asserted (entry $key _)) (on (asserted (entry $key _))
(log-info "key ~v asserted" key) (log-info "key ~v asserted" key)
@ -18,19 +18,20 @@
(log-info "del binding: ~v -> ~v" key value))) (log-info "del binding: ~v -> ~v" key value)))
(log-info "key ~v retracted" key)))) (log-info "key ~v retracted" key))))
(actor (forever (actor (react
(assert (ready 'other-listener)) (assert (ready 'other-listener))
(during (entry $key _) (during (entry $key _)
#:init [(log-info "(other-listener) key ~v asserted" key)] (log-info "(other-listener) key ~v asserted" key)
#:done [(log-info "(other-listener) key ~v retracted" key)] (on-stop (log-info "(other-listener) key ~v retracted" key))
(during (entry key $value) (during (entry key $value)
#:init [(log-info "(other-listener) ~v ---> ~v" key value)] (log-info "(other-listener) ~v ---> ~v" key value)
#:done [(log-info "(other-listener) ~v -/-> ~v" key value)])))) (on-stop (log-info "(other-listener) ~v -/-> ~v" key value))))))
(define (pause) (define (pause)
(log-info "pause") (log-info "pause")
(until (asserted (ready 'pause)) (define token (gensym 'pause)) ;; FIXME:: If we use the same token every time, need epochs!
(assert (ready 'pause)))) (until (asserted (ready token))
(assert (ready token))))
(actor (until (asserted (ready 'listener))) (actor (until (asserted (ready 'listener)))
(until (asserted (ready 'other-listener))) (until (asserted (ready 'other-listener)))

22
racket/syndicate/examples/actor/file-system-during.rkt
View File

@ -13,21 +13,21 @@
(spawn-timer-driver) (spawn-timer-driver)
(actor (forever #:collect [(files (hash))] (actor (react (field [files (hash)])
(during (observe (file $name _)) (during (observe (file $name _))
#:init [(printf "At least one reader exists for ~v\n" name)] (on-start (printf "At least one reader exists for ~v\n" name))
#:done [(printf "No remaining readers exist for ~v\n" name)] (on-stop (printf "No remaining readers exist for ~v\n" name))
#:collect [(content (hash-ref files name #f))] (field [content (hash-ref (files) name #f)])
(assert (file name content)) (assert (file name (content)))
(on (message (save (file name $content))) content) (on (message (save (file name $new-content))) (content new-content))
(on (message (delete name)) #f)) (on (message (delete name)) (content #f)))
(on (message (save (file $name $content))) (hash-set files name content)) (on (message (save (file $name $content))) (files (hash-set (files) name content)))
(on (message (delete $name)) (hash-remove files name)))) (on (message (delete $name)) (files (hash-remove (files) name)))))
(define (sleep sec) (define (sleep sec)
(define timer-id (gensym 'sleep)) (define timer-id (gensym 'sleep))
(until (message (timer-expired timer-id _)) (until (message (timer-expired timer-id _))
#:init [(send! (set-timer timer-id (* sec 1000.0) 'relative))])) (on-start (send! (set-timer timer-id (* sec 1000.0) 'relative)))))
;; Shell ;; Shell
(let ((e (read-bytes-line-evt (current-input-port) 'any))) (let ((e (read-bytes-line-evt (current-input-port) 'any)))

2
racket/syndicate/examples/actor/file-system-lll.rkt
View File

@ -58,7 +58,7 @@
(define (sleep sec) (define (sleep sec)
(define timer-id (gensym 'sleep)) (define timer-id (gensym 'sleep))
(until (message (timer-expired timer-id _)) (until (message (timer-expired timer-id _))
#:init [(send! (set-timer timer-id (* sec 1000.0) 'relative))])) (on-start (send! (set-timer timer-id (* sec 1000.0) 'relative)))))
;; Shell ;; Shell
(let ((e (read-bytes-line-evt (current-input-port) 'any))) (let ((e (read-bytes-line-evt (current-input-port) 'any)))

2
racket/syndicate/examples/actor/file-system-lll2.rkt
View File

@ -59,7 +59,7 @@
(define (sleep sec) (define (sleep sec)
(define timer-id (gensym 'sleep)) (define timer-id (gensym 'sleep))
(until (message (timer-expired timer-id _)) (until (message (timer-expired timer-id _))
#:init [(send! (set-timer timer-id (* sec 1000.0) 'relative))])) (on-start (send! (set-timer timer-id (* sec 1000.0) 'relative)))))
;; Shell ;; Shell
(let ((e (read-bytes-line-evt (current-input-port) 'any))) (let ((e (read-bytes-line-evt (current-input-port) 'any)))

24
racket/syndicate/examples/actor/file-system.rkt
View File

@ -13,22 +13,22 @@
(spawn-timer-driver) (spawn-timer-driver)
(actor (forever #:collect [(files (hash))] (actor (react (field [files (hash)])
(on (asserted (observe (file $name _))) (on (asserted (observe (file $name _)))
(printf "At least one reader exists for ~v\n" name) (printf "At least one reader exists for ~v\n" name)
(begin0 (until (retracted (observe (file name _))) (begin0 (until (retracted (observe (file name _)))
#:collect [(content (hash-ref files name #f))] (field [content (hash-ref (files) name #f)])
(assert (file name content)) (assert (file name (content)))
(on (message (save (file name $content))) content) (on (message (save (file name $new-content))) (content new-content))
(on (message (delete name)) #f)) (on (message (delete name)) (content #f)))
(printf "No remaining readers exist for ~v\n" name))) (printf "No remaining readers exist for ~v\n" name)))
(on (message (save (file $name $content))) (hash-set files name content)) (on (message (save (file $name $content))) (files (hash-set (files) name content)))
(on (message (delete $name)) (hash-remove files name)))) (on (message (delete $name)) (files (hash-remove (files) name)))))
(define (sleep sec) (define (sleep sec)
(define timer-id (gensym 'sleep)) (define timer-id (gensym 'sleep))
(until (message (timer-expired timer-id _)) (until (message (timer-expired timer-id _))
#:init [(send! (set-timer timer-id (* sec 1000.0) 'relative))])) (on-start (send! (set-timer timer-id (* sec 1000.0) 'relative)))))
;; Shell ;; Shell
(let ((e (read-bytes-line-evt (current-input-port) 'any))) (let ((e (read-bytes-line-evt (current-input-port) 'any)))

40
racket/syndicate/examples/actor/file-system2.rkt
View File

@ -14,30 +14,30 @@
(spawn-timer-driver) (spawn-timer-driver)
(actor (forever #:collect [(files (hash)) (monitored (set))] (actor (react (field [files (hash)] [monitored (set)])
(on (asserted (observe (file $name _))) (on (asserted (observe (file $name _)))
(printf "At least one reader exists for ~v\n" name) (printf "At least one reader exists for ~v\n" name)
(assert! (file name (hash-ref files name #f))) (assert! (file name (hash-ref (files) name #f)))
(values files (set-add monitored name))) (monitored (set-add (monitored) name)))
(on (retracted (observe (file $name _))) (on (retracted (observe (file $name _)))
(printf "No remaining readers exist for ~v\n" name) (printf "No remaining readers exist for ~v\n" name)
(retract! (file name (hash-ref files name #f))) (retract! (file name (hash-ref (files) name #f)))
(values files (set-remove monitored name))) (monitored (set-remove (monitored) name)))
(on (message (save (file $name $content))) (on (message (save (file $name $content)))
(when (set-member? monitored name) (when (set-member? (monitored) name)
(retract! (file name (hash-ref files name #f))) (retract! (file name (hash-ref (files) name #f)))
(assert! (file name content))) (assert! (file name content)))
(values (hash-set files name content) monitored)) (files (hash-set (files) name content)))
(on (message (delete $name)) (on (message (delete $name))
(when (set-member? monitored name) (when (set-member? (monitored) name)
(retract! (file name (hash-ref files name #f))) (retract! (file name (hash-ref (files) name #f)))
(assert! (file name #f))) (assert! (file name #f)))
(values (hash-remove files name) monitored)))) (files (hash-remove (files) name)))))
(define (sleep sec) (define (sleep sec)
(define timer-id (gensym 'sleep)) (define timer-id (gensym 'sleep))
(until (message (timer-expired timer-id _)) (until (message (timer-expired timer-id _))
#:init [(send! (set-timer timer-id (* sec 1000.0) 'relative))])) (on-start (send! (set-timer timer-id (* sec 1000.0) 'relative)))))
;; Shell ;; Shell
(let ((e (read-bytes-line-evt (current-input-port) 'any))) (let ((e (read-bytes-line-evt (current-input-port) 'any)))

18
racket/syndicate/examples/actor/forward-chaining-mini.rkt
View File

@ -3,17 +3,17 @@
(require syndicate/actor) (require syndicate/actor)
(actor (forever (assert `(parent john douglas)))) (actor (react (assert `(parent john douglas))))
(actor (forever (assert `(parent bob john)))) (actor (react (assert `(parent bob john))))
(actor (forever (assert `(parent ebbon bob)))) (actor (react (assert `(parent ebbon bob))))
;; This looks like an implication: ;; This looks like an implication:
;; (parent A C) ⇒ ((ancestor A C) ∧ ((ancestor C B) ⇒ (ancestor A B))) ;; (parent A C) ⇒ ((ancestor A C) ∧ ((ancestor C B) ⇒ (ancestor A B)))
;; ;;
(actor (forever (during `(parent ,$A ,$C) (actor (react (during `(parent ,$A ,$C)
(assert `(ancestor ,A ,C)) (assert `(ancestor ,A ,C))
(during `(ancestor ,C ,$B) (during `(ancestor ,C ,$B)
(assert `(ancestor ,A ,B)))))) (assert `(ancestor ,A ,B))))))
(actor (forever (on (asserted `(ancestor ,$A ,$B)) (actor (react (on (asserted `(ancestor ,$A ,$B))
(log-info "~a is an ancestor of ~a" A B)))) (log-info "~a is an ancestor of ~a" A B))))

12
racket/syndicate/examples/actor/mini-echo.rkt
View File

@ -5,13 +5,13 @@
(struct echo-req (body) #:prefab) (struct echo-req (body) #:prefab)
(struct echo-resp (body) #:prefab) (struct echo-resp (body) #:prefab)
(actor (forever #:collect [(count 0)] (actor (react (field [count 0])
(on (message (echo-req $body)) (on (message (echo-req $body))
(send! (echo-resp body)) (send! (echo-resp body))
(+ count 1)))) (count (+ (count) 1)))))
(actor (forever (on (message (echo-resp $body)) (actor (react (on (message (echo-resp $body))
(printf "Received: ~v\n" body)))) (printf "Received: ~v\n" body))))
(actor (until (asserted (observe (echo-req _)))) (actor (until (asserted (observe (echo-req _))))
(until (asserted (observe (echo-resp _)))) (until (asserted (observe (echo-resp _))))

26
racket/syndicate/examples/actor/spreadsheet.rkt
View File

@ -24,26 +24,28 @@
[(cons a d) (set-union (walk a) (walk d))] [(cons a d) (set-union (walk a) (walk d))]
[_ (set)]))) [_ (set)])))
(define (non-void? v) (not (void? v))) (define (non-void-field? f) (not (void? (f))))
(define (cell-expr->actor-expr name expr) (define (cell-expr->actor-expr name expr)
(define bindings (set->list (extract-bindings expr))) (define bindings (set->list (extract-bindings expr)))
`(actor (until (message (set-cell ',name _)) `(actor (until (message (set-cell ',name _))
#:collect [,@(for/list [(b bindings)] `(,b (void)))] (field ,@(for/list [(b bindings)] `[,b (void)]))
(assert #:when (andmap non-void? (list ,@bindings)) (cell ',name ,expr)) (assert #:when (andmap non-void-field? (list ,@bindings))
(cell ',name
(let (,@(for/list [(b bindings)] `(,b (,b))))
,expr)))
,@(for/list [(b bindings)] ,@(for/list [(b bindings)]
`(on (asserted (cell ',b $value)) `(on (asserted (cell ',b $value))
(values ,@(for/list [(b1 bindings)] (,b value))))))
(if (eq? b b1) 'value b1))))))))
(actor (forever (on (message (set-cell $name $expr)) (actor (react (on (message (set-cell $name $expr))
(define actor-expr (cell-expr->actor-expr name expr)) (define actor-expr (cell-expr->actor-expr name expr))
;; (local-require racket/pretty) (pretty-print actor-expr) ;; (local-require racket/pretty) (pretty-print actor-expr)
(eval actor-expr (namespace-anchor->namespace ns))))) (eval actor-expr (namespace-anchor->namespace ns)))))
(actor (forever (on (asserted (cell $name $value)) (actor (react (on (asserted (cell $name $value))
(printf ">>> ~a ~v\n" name value) (printf ">>> ~a ~v\n" name value)
(flush-output)))) (flush-output))))
(actor (void (thread (lambda () (actor (void (thread (lambda ()
(let loop () (let loop ()

128
racket/syndicate/examples/actor/two-buyer-protocol.rkt
View File

@ -3,6 +3,8 @@
;; given in Honda/Yoshida/Carbone 2008, "Multiparty Asynchronous ;; given in Honda/Yoshida/Carbone 2008, "Multiparty Asynchronous
;; Session Types". ;; Session Types".
;; TODO:: code this up in Syndicate/js. See whether the killing-child-facets problems exists there.
;; SAMPLE OUTPUT: ;; SAMPLE OUTPUT:
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
;; A learns that the price of "Catch 22" is 2.22 ;; A learns that the price of "Catch 22" is 2.22
@ -89,38 +91,43 @@
;; SELLER ;; SELLER
;; ;;
(define (seller) (define (seller)
(actor (forever #:collect [(books (hash "The Wind in the Willows" 3.95 (actor (react (field [books (hash "The Wind in the Willows" 3.95
"Catch 22" 2.22 "Catch 22" 2.22
"Candide" 34.95)) "Candide" 34.95)]
(next-order-id 10001483)] [next-order-id 10001483])
;; Give quotes to interested parties. ;; Give quotes to interested parties.
;; ;;
(during (observe (book-quote $title _)) (during (observe (book-quote $title _))
(assert (book-quote title (hash-ref books title #f)))) (assert (book-quote title (hash-ref (books) title #f))))
;; Respond to order requests. ;; Respond to order requests.
;; ;;
(on (asserted (observe (order $title $offer-price _ _))) (on (asserted (observe (order $title $offer-price _ _)))
(define asking-price (hash-ref books title #f)) (define asking-price (hash-ref (books) title #f))
(cond (cond
[(or (not asking-price) (< offer-price asking-price)) [(or (not asking-price) (< offer-price asking-price))
;; We cannot sell a book we do not have, and we will not sell for less ;; We cannot sell a book we do not have, and we will not sell for less
;; than our asking price. ;; than our asking price.
;; ;;
(while-relevant-assert (order title offer-price #f #f))] (while-relevant-assert (order title offer-price #f #f))]
[else [else
;; Tell the ordering party their order ID and delivery date. ;; Allocate an order ID.
;; ;;
(actor (define order-id (next-order-id))
(while-relevant-assert (next-order-id (+ order-id 1))
(order title offer-price next-order-id "March 9th")))
;; Remove the book from our shelves, and increment our order ID. ;; Remove the book from our shelves.
;; ;;
(values (hash-remove books title) (+ next-order-id 1))]))))) (books (hash-remove (books) title))
;; Tell the ordering party their order ID and delivery date.
;;
(actor
(while-relevant-assert
(order title offer-price order-id "March 9th")))])))))
;; Serial SPLIT-PROPOSER ;; Serial SPLIT-PROPOSER
;; ;;
@ -136,7 +143,8 @@
;; First, retrieve a quote for the title, and analyze the result. ;; First, retrieve a quote for the title, and analyze the result.
;; ;;
(match (state [] [(asserted (book-quote title $price)) price]) (match (react/suspend (yield)
(stop-when (asserted (book-quote title $price)) (yield price)))
[#f [#f
(log-info "A learns that ~v is out-of-stock." title) (log-info "A learns that ~v is out-of-stock." title)
(try-to-buy remaining-titles)] (try-to-buy remaining-titles)]
@ -161,31 +169,14 @@
[else [else
;; Make our proposal, and wait for a response. ;; Make our proposal, and wait for a response.
;; SEE NOTE (A).
;; ;;
(match (state [] [(asserted (split-proposal title price contribution $accepted?)) (react
accepted?]) (stop-when (asserted (split-proposal title price contribution #t))
[#t (log-info "A learns that the split-proposal for ~v was accepted" title)
(log-info "A learns that the split-proposal for ~v was accepted" title) (try-to-buy remaining-titles))
(try-to-buy remaining-titles)] (stop-when (asserted (split-proposal title price contribution #f))
[#f (log-info "A learns that the split-proposal for ~v was rejected" title)
(log-info "A learns that the split-proposal for ~v was rejected" title) (try-to-split (+ contribution (/ (- price contribution) 2)))))]))])]))
;; Offer to contribute a little more.
(try-to-split (+ contribution (/ (- price contribution) 2)))])]))])]))
;; NOTE (A): Wrote this originally where the anchor to this note is found. The code here
;; doesn't release assertions properly; we fall foul of the "run the continuation clauses
;; while the subscriptions are still active" property of the current actor.rkt
;; implementation.
;;
;; (state []
;; [(asserted (split-proposal title price contribution #t))
;; (log-info "A learns that the split-proposal for ~v was accepted" title)
;; (try-to-buy remaining-titles)]
;; [(asserted (split-proposal title price contribution #f))
;; (log-info "A learns that the split-proposal for ~v was rejected" title)
;; (try-to-split (+ contribution (/ (- price contribution) 2)))])
;;
(actor (try-to-buy (list "Catch 22" (actor (try-to-buy (list "Catch 22"
"Encyclopaedia Brittannica" "Encyclopaedia Brittannica"
@ -195,11 +186,11 @@
;; Serial SPLIT-DISPOSER ;; Serial SPLIT-DISPOSER
;; ;;
(define (buyer-b) (define (buyer-b)
(actor (forever (actor (react
;; This actor maintains a record of the amount of money it has to spend. ;; This actor maintains a record of the amount of money it has to spend.
;; ;;
#:collect [(funds 5.00)] (field [funds 5.00])
(on (asserted (observe (split-proposal $title $price $their-contribution _))) (on (asserted (observe (split-proposal $title $price $their-contribution _)))
@ -210,8 +201,8 @@
price) price)
(cond (cond
[(> my-contribution funds) [(> my-contribution (funds))
(log-info "B hasn't enough funds (~a remaining)" funds) (log-info "B hasn't enough funds (~a remaining)" (funds))
(while-relevant-assert (split-proposal title price their-contribution #f))] (while-relevant-assert (split-proposal title price their-contribution #f))]
[else [else
@ -221,16 +212,17 @@
;; actual purchase now that we have agreed on a split. ;; actual purchase now that we have agreed on a split.
;; ;;
(actor (define-values (order-id delivery-date) (actor (define-values (order-id delivery-date)
(state (react/suspend (yield)
[;; While we are in this state, waiting for order confirmation, take ;; While we are in this state, waiting for order confirmation, take
;; the opportunity to signal to our SPLIT-PROPOSER that we accepted ;; the opportunity to signal to our SPLIT-PROPOSER that we accepted
;; their proposal. ;; their proposal.
;; ;;
(assert (split-proposal title price their-contribution #t))] (assert (split-proposal title price their-contribution #t))
[(asserted (order title price $id $date))
;; We have received order confirmation from the SELLER. (stop-when (asserted (order title price $id $date))
;; ;; We have received order confirmation from the SELLER.
(values id date)])) ;;
(yield id date))))
(log-info "The order for ~v has id ~a, and will be delivered on ~a" (log-info "The order for ~v has id ~a, and will be delivered on ~a"
title title
order-id order-id
@ -239,10 +231,10 @@
;; Meanwhile, update our records of our available funds, and continue to wait ;; Meanwhile, update our records of our available funds, and continue to wait
;; for more split-proposals to arrive. ;; for more split-proposals to arrive.
;; ;;
(define remaining-funds (- funds my-contribution)) (define remaining-funds (- (funds) my-contribution))
(log-info "B accepts the offer, leaving them with ~a remaining funds" (log-info "B accepts the offer, leaving them with ~a remaining funds"
remaining-funds) remaining-funds)
remaining-funds]))))) (funds remaining-funds)])))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

18
racket/syndicate/examples/all-pairs-shortest-paths/all-pairs-shortest-paths.rkt
View File

@ -29,18 +29,18 @@
(assert (path A C (+ link-cost path-cost))))))) (assert (path A C (+ link-cost path-cost)))))))
(actor (forever (during (path-exists $from $to) (actor (forever (during (path-exists $from $to)
#:collect [(costs (set)) (least +inf.0)] (field [costs (set)] [least +inf.0])
(assert (min-cost from to least)) (assert (min-cost from to (least)))
(on (asserted (path from to $cost)) (on (asserted (path from to $cost))
(values (set-add costs cost) (costs (set-add (costs) cost))
(min least cost))) (least (min (least) cost)))
(on (retracted (path from to $cost)) (on (retracted (path from to $cost))
(define new-costs (set-remove costs cost)) (define new-costs (set-remove (costs) cost))
(values new-costs (costs new-costs)
(for/fold [(least +inf.0)] [(x new-costs)] (min x least))))))) (least (for/fold [(least +inf.0)] [(x new-costs)] (min x least)))))))
;; (actor (forever (during (path $from $to $cost) ;; (actor (forever (during (path $from $to $cost)
;; #:init [(displayln `(+ ,(path from to cost)))] ;; (on-start (displayln `(+ ,(path from to cost))))
;; #:done [(displayln `(- ,(path from to cost)))]))) ;; (on-stop (displayln `(- ,(path from to cost)))))))
(actor (forever (on (asserted (min-cost $from $to $cost)) (actor (forever (on (asserted (min-cost $from $to $cost))
(displayln (min-cost from to cost))))) (displayln (min-cost from to cost)))))

18
racket/syndicate/examples/all-pairs-shortest-paths/all-pairs-shortest-paths2.rkt
View File

@ -29,18 +29,18 @@
(path A C (set-add seen A) (+ link-cost path-cost))))))) (path A C (set-add seen A) (+ link-cost path-cost)))))))
(actor (forever (during (path-exists $from $to) (actor (forever (during (path-exists $from $to)
#:collect [(costs (set)) (least +inf.0)] (field [costs (set)] [least +inf.0])
(assert (min-cost from to least)) (assert (min-cost from to (least)))
(on (asserted (path from to _ $cost)) (on (asserted (path from to _ $cost))
(values (set-add costs cost) (costs (set-add (costs) cost))
(min least cost))) (least (min (least) cost)))
(on (retracted (path from to _ $cost)) (on (retracted (path from to _ $cost))
(define new-costs (set-remove costs cost)) (define new-costs (set-remove (costs) cost))
(values new-costs (costs new-costs)
(for/fold [(least +inf.0)] [(x new-costs)] (min x least))))))) (least (for/fold [(least +inf.0)] [(x new-costs)] (min x least)))))))
(actor (forever (during (path $from $to $seen $cost) (actor (forever (during (path $from $to $seen $cost)
#:init [(displayln `(+ ,(path from to seen cost)))] (on-start (displayln `(+ ,(path from to seen cost))))
#:done [(displayln `(- ,(path from to seen cost)))]))) (on-stop (displayln `(- ,(path from to seen cost)))))))
(actor (forever (on (asserted (min-cost $from $to $cost)) (actor (forever (on (asserted (min-cost $from $to $cost))
(displayln (min-cost from to cost))))) (displayln (min-cost from to cost)))))

28
racket/syndicate/examples/ws-echo-client.rkt
View File

@ -7,7 +7,10 @@
(require syndicate/actor) (require syndicate/actor)
(require racket/port) (require racket/port)
(match-define (vector url) (current-command-line-arguments)) (define url
(match (current-command-line-arguments)
[(vector url) url]
[(vector) "http://localhost:8081/ws-echo"]))
(spawn-websocket-driver) (spawn-websocket-driver)
@ -19,14 +22,15 @@
(define (generate-reader-id) (define (generate-reader-id)
(begin0 reader-count (begin0 reader-count
(set! reader-count (+ reader-count 1)))) (set! reader-count (+ reader-count 1))))
(actor (state [(assert (advertise (websocket-message c s _))) (actor (react (assert (advertise (websocket-message c s _)))
(on (asserted (websocket-peer-details c s $la _ $ra _)) (on (asserted (websocket-peer-details c s $la _ $ra _))
(log-info "~a: local ~v :: remote ~v" c la ra)) (log-info "~a: local ~v :: remote ~v" c la ra))
(on (message (external-event e (list (? bytes? $bs))) #:meta-level 1) (on (message (external-event e (list (? bytes? $bs))) #:meta-level 1)
(send! (websocket-message c s bs))) (send! (websocket-message c s bs)))
(on (message (websocket-message s c $bs)) (on (message (websocket-message s c $bs))
(printf "(From server: ~v)\n" bs))] (printf "(From server: ~v)\n" bs))
[(message (external-event e (list (? eof-object? _))) #:meta-level 1) (stop-when (message (external-event e (list (? eof-object? _)))
(printf "Local EOF. Terminating.\n")] #:meta-level 1)
[(retracted (advertise (websocket-message s c _))) (printf "Local EOF. Terminating.\n"))
(printf "Server disconnected.\n")]))) (stop-when (retracted (advertise (websocket-message s c _)))
(printf "Server disconnected.\n")))))

12
racket/syndicate/support/dsl.rkt
View File

@ -1,12 +0,0 @@
#lang racket/base
(require (for-syntax racket/base))
(provide define&provide-dsl-helper-syntaxes)
(define-for-syntax (illegal-use id context stx)
(raise-syntax-error #f (format "Illegal use of ~a outside ~a" id context) stx))
(define-syntax-rule (define&provide-dsl-helper-syntaxes context (identifier ...))
(begin (provide identifier ...)
(define-syntax (identifier stx) (illegal-use 'identifier context stx))
...))