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

First commit moving from (actor (react ...)) to (actor ...)

This commit is contained in:
Tony Garnock-Jones 2016-08-24 17:35:38 +01:00
parent 56e893fac4
commit 0bc775a89f
48 changed files with 996 additions and 1005 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
racket/syndicate-gl/examples/basic.rkt
View File

@ -6,58 +6,56 @@
(define (spawn-background) (define (spawn-background)
(actor (actor
(react (during (inbound (window $width $height))
(during (inbound (window $width $height)) (assert (outbound
(assert (outbound (scene (seal `((push-matrix (scale ,width ,(* height 2))
(scene (seal `((push-matrix (scale ,width ,(* height 2)) (translate 0 -0.25)
(translate 0 -0.25) (texture
(texture ,(overlay/xy (rectangle 1 1 "solid" "white")
,(overlay/xy (rectangle 1 1 "solid" "white") 0 0
0 0 (rectangle 1 2 "solid" "black"))))
(rectangle 1 2 "solid" "black")))) ;; (rotate -30)
;; (rotate -30) ;; (scale 5 5)
;; (scale 5 5) ))
)) (seal `())))))))
(seal `()))))))))
(define (spawn-player-avatar) (define (spawn-player-avatar)
(local-require 2htdp/planetcute) (local-require 2htdp/planetcute)
(define CC character-cat-girl) (define CC character-cat-girl)
(actor (react (actor (field [x 100] [y 100])
(field [x 100] [y 100]) (assert (outbound (simple-sprite -0.5 (x) (y) (image-width CC) (image-height CC) CC)))
(assert (outbound (simple-sprite -0.5 (x) (y) (image-width CC) (image-height CC) CC)))
(field [keys-down (set)]) (field [keys-down (set)])
(on (asserted (key-pressed $k)) (keys-down (set-add (keys-down) k))) (on (asserted (key-pressed $k)) (keys-down (set-add (keys-down) k)))
(on (retracted (key-pressed $k)) (keys-down (set-remove (keys-down) k))) (on (retracted (key-pressed $k)) (keys-down (set-remove (keys-down) k)))
(define (key->delta k distance) (if (set-member? (keys-down) k) distance 0)) (define (key->delta k distance) (if (set-member? (keys-down) k) distance 0))
(on (message (inbound (frame-event _ _ $elapsed-ms _))) (on (message (inbound (frame-event _ _ $elapsed-ms _)))
(define-values (old-x old-y) (values (x) (y))) (define-values (old-x old-y) (values (x) (y)))
(define distance (* 0.360 elapsed-ms)) (define distance (* 0.360 elapsed-ms))
(define nx (+ old-x (key->delta 'right distance) (key->delta 'left (- distance)))) (define nx (+ old-x (key->delta 'right distance) (key->delta 'left (- distance))))
(define ny (+ old-y (key->delta 'down distance) (key->delta 'up (- distance)))) (define ny (+ old-y (key->delta 'down distance) (key->delta 'up (- distance))))
(when (not (and (= nx old-x) (= ny old-y))) (when (not (and (= nx old-x) (= ny old-y)))
(x nx) (x nx)
(y ny)))))) (y ny)))))
(define (spawn-frame-counter) (define (spawn-frame-counter)
(actor (react (field [i empty-image]) (actor (field [i empty-image])
(assert (outbound (assert (outbound
(simple-sprite -10 300 10 (image-width (i)) (image-height (i)) (i)))) (simple-sprite -10 300 10 (image-width (i)) (image-height (i)) (i))))
(on (message (inbound (frame-event $counter $sim-time-ms _ _))) (on (message (inbound (frame-event $counter $sim-time-ms _ _)))
(when (> sim-time-ms 0) (when (> sim-time-ms 0)
(define fps (/ counter (/ sim-time-ms 1000.0))) (define fps (/ counter (/ sim-time-ms 1000.0)))
(i (text (format "~a fps" fps) 22 "black"))))))) (i (text (format "~a fps" fps) 22 "black"))))))
(spawn-keyboard-integrator) (spawn-keyboard-integrator)
(spawn-background) (spawn-background)
;; (spawn-frame-counter) ;; (spawn-frame-counter)
(spawn-player-avatar) (spawn-player-avatar)
(actor (react (assert (outbound (simple-sprite 0 50 50 50 50 (circle 50 "solid" "orange")))) (actor (assert (outbound (simple-sprite 0 50 50 50 50 (circle 50 "solid" "orange"))))
(assert (outbound (simple-sprite -1 60 60 50 50 (circle 50 "solid" "green")))))) (assert (outbound (simple-sprite -1 60 60 50 50 (circle 50 "solid" "green")))))
(actor (until (message (inbound (key-event #\q #t _)))) (actor* (until (message (inbound (key-event #\q #t _))))
(assert! (outbound 'stop))) (assert! (outbound 'stop)))
(module+ main (current-ground-dataspace (2d-dataspace))) (module+ main (current-ground-dataspace (2d-dataspace)))

14
racket/syndicate/actor.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(provide actor (provide actor
actor*
dataspace dataspace
react react
@ -277,6 +278,15 @@
name.N))))])) name.N))))]))
(define-syntax (actor stx) (define-syntax (actor stx)
(syntax-parse stx
[(_ name:name O ...)
(quasisyntax/loc stx
(let ((spawn-action (actor-action #:name name.N (react O ...))))
(if (syndicate-effects-available?)
(schedule-action! spawn-action)
spawn-action)))]))
(define-syntax (actor* stx)
(syntax-parse stx (syntax-parse stx
[(_ name:name script ...) [(_ name:name script ...)
(quasisyntax/loc stx (quasisyntax/loc stx
@ -433,8 +443,8 @@
(on #,E-stx (on #,E-stx
(let ((p #,instantiated)) (let ((p #,instantiated))
(w.wrapper #:name name.N (w.wrapper #:name name.N
(react (stop-when (retracted p)) (stop-when (retracted p))
O ...)))))])) O ...))))]))
(define-syntax (begin/dataflow stx) (define-syntax (begin/dataflow stx)
(syntax-parse stx (syntax-parse stx

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

@ -51,32 +51,33 @@
(define (send-event e) (define (send-event e)
(send! (outbound (websocket-message server-id c (jsexpr->string (lift-json-event e)))))) (send! (outbound (websocket-message server-id c (jsexpr->string (lift-json-event e))))))
(arm-ping-timer!) (on-start (arm-ping-timer!)
(log-syndicate-broker-info "Starting broker connection from ~v" c))
(log-syndicate-broker-info "Starting broker connection from ~v" c) (stop-when (retracted (inbound (advertise (websocket-message c server-id _)))))
(until (retracted (inbound (advertise (websocket-message c server-id _)))) (assert (outbound (advertise (websocket-message server-id c _))))
(assert (outbound (advertise (websocket-message server-id c _))))
(on (asserted (inbound (on (asserted (inbound
(websocket-peer-details server-id c _ _ $remote-addr $remote-port))) (websocket-peer-details server-id c _ _ $remote-addr $remote-port)))
(log-syndicate-broker-info "Connection ~v is from ~a:~a" c remote-addr remote-port)) (log-syndicate-broker-info "Connection ~v is from ~a:~a" c remote-addr remote-port))
(on (message (inbound (timer-expired c _))) (on (message (inbound (timer-expired c _)))
(arm-ping-timer!) (arm-ping-timer!)
(send-event 'ping)) (send-event 'ping))
(on (message (inbound (websocket-message c server-id $data))) (on (message (inbound (websocket-message c server-id $data)))
(match (drop-json-action (string->jsexpr data)) (match (drop-json-action (string->jsexpr data))
['ping (send-event 'pong)] ['ping (send-event 'pong)]
['pong (void)] ['pong (void)]
[(? patch? p) (patch! (log-packet c 'inbound 'patch (wrap-patch scope p)))] [(? patch? p) (patch! (log-packet c 'inbound 'patch (wrap-patch scope p)))]
[(message body) (send! (log-packet c 'inbound 'message (broker-data scope body)))])) [(message body) (send! (log-packet c 'inbound 'message (broker-data scope body)))]))
(on-event (on-event
[(? patch? p) (send-event (log-packet c 'outbound 'patch (unwrap-patch scope p)))] [(? patch? p) (send-event (log-packet c 'outbound 'patch (unwrap-patch scope p)))]
[(message (broker-data (== scope) body)) [(message (broker-data (== scope) body))
(send-event (message (log-packet c 'outbound 'message body)))])) (send-event (message (log-packet c 'outbound 'message body)))])
(log-syndicate-broker-info "Ending broker connection from ~v" c)))
(on-stop (log-syndicate-broker-info "Ending broker connection from ~v" c))))
(define (log-packet c direction kind value) (define (log-packet c direction kind value)
(log-syndicate-broker-debug "Broker: ~v: ~a ~a\n~v" c direction kind value) (log-syndicate-broker-debug "Broker: ~v: ~a ~a\n~v" c direction kind value)

22
racket/syndicate/drivers/line-reader.rkt
View File

@ -14,15 +14,13 @@
[(eqv? (bytes-ref bs i) b) i] [(eqv? (bytes-ref bs i) b) i]
[else (loop (+ i 1))]))) [else (loop (+ i 1))])))
(actor (actor (during/actor (observe (tcp-channel-line $src $dst _))
(react (field [buffer #""])
(during/actor (observe (tcp-channel-line $src $dst _)) (on (message (tcp-channel src dst $bs))
(field [buffer #""]) (buffer (bytes-append (buffer) bs)))
(on (message (tcp-channel src dst $bs)) (begin/dataflow
(buffer (bytes-append (buffer) bs))) (define newline-pos (bytes-index (buffer) (char->integer #\newline)))
(begin/dataflow (when newline-pos
(define newline-pos (bytes-index (buffer) (char->integer #\newline))) (define line (subbytes (buffer) 0 newline-pos))
(when newline-pos (buffer (subbytes (buffer) (+ newline-pos 1)))
(define line (subbytes (buffer) 0 newline-pos)) (send! (tcp-channel-line src dst line))))))
(buffer (subbytes (buffer) (+ newline-pos 1)))
(send! (tcp-channel-line src dst line)))))))

50
racket/syndicate/drivers/web.rkt
View File

@ -143,18 +143,16 @@
(define (spawn-web-driver) (define (spawn-web-driver)
(actor #:name 'web-server-manager (actor #:name 'web-server-manager
(react (during/actor (web-virtual-host "http" _ $port)
(during/actor (web-virtual-host "http" _ $port) #:name (list 'web-server port)
#:name (list 'web-server port) (setup-web-server "http"
(setup-web-server "http" (or (web-server-connection-manager)
(or (web-server-connection-manager) (start-connection-manager))
(start-connection-manager)) port)))
port))))
(actor #:name 'web-client-manager (actor #:name 'web-client-manager
(react (on (message (web-request $id 'outbound $req $body))
(on (message (web-request $id 'outbound $req $body)) (actor #:name (list 'web-client id)
(actor #:name (list 'web-client id) (do-client-request id req body)))))
(do-client-request id req body))))))
(define (setup-web-server scheme cm port) (define (setup-web-server scheme cm port)
(define listener (tcp-listen port (web-server-max-waiting) #t)) (define listener (tcp-listen port (web-server-max-waiting) #t))
@ -184,21 +182,21 @@
(url-query (request-uri lowlevel-req))) (url-query (request-uri lowlevel-req)))
(request-post-data/raw lowlevel-req))) (request-post-data/raw lowlevel-req)))
(actor #:name (list 'web-req id) (actor #:name (list 'web-req id)
(react (on-start (send! (set-timer (list 'web-req id) 100 'relative)) (on-start (send! (set-timer (list 'web-req id) 100 'relative))
(send! web-req)) (send! web-req))
(stop-when (message (timer-expired (list 'web-req id) _)) (stop-when (message (timer-expired (list 'web-req id) _))
(do-response-complete control-ch (do-response-complete control-ch
id id
(make-web-response-header (make-web-response-header
#:code 404 #:code 404
#:message #"Not found") #:message #"Not found")
'())) '()))
(stop-when (message (web-response-complete id $rh $body)) (stop-when (message (web-response-complete id $rh $body))
(do-response-complete control-ch id rh body)) (do-response-complete control-ch id rh body))
(stop-when (asserted (web-response-chunked id $rh)) (stop-when (asserted (web-response-chunked id $rh))
(do-response-chunked control-ch id rh)) (do-response-chunked control-ch id rh))
(stop-when (asserted (web-response-websocket id $headers)) (stop-when (asserted (web-response-websocket id $headers))
(do-response-websocket control-ch id headers)))))) (do-response-websocket control-ch id headers)))))
(define (do-response-complete control-ch id rh constree-of-bytes) (define (do-response-complete control-ch id rh constree-of-bytes)
(match-define (web-response-header code resp-message last-modified-seconds mime-type headers) rh) (match-define (web-response-header code resp-message last-modified-seconds mime-type headers) rh)

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

@ -4,14 +4,14 @@
(struct account (balance) #:prefab) (struct account (balance) #:prefab)
(struct deposit (amount) #:prefab) (struct deposit (amount) #:prefab)
(actor (react (field [balance 0]) (actor (field [balance 0])
(assert (account (balance))) (assert (account (balance)))
(on (message (deposit $amount)) (on (message (deposit $amount))
(balance (+ (balance) amount))))) (balance (+ (balance) amount))))
(actor (react (on (asserted (account $balance)) (actor (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))
(send! (deposit -30))) (send! (deposit -30)))

28
racket/syndicate/examples/actor/big-bang.rkt
View File

@ -8,16 +8,15 @@
#:font-size [font-size 22] #:font-size [font-size 22]
name x y label callback) name x y label callback)
(define label-image (text label font-size foreground)) (define label-image (text label font-size foreground))
(actor (forever (actor (on (message (inbound (mouse-event _ _ name "button-down"))) (callback))
(on (message (inbound (mouse-event _ _ name "button-down"))) (callback)) (assert (outbound
(assert (outbound (window name x y 0
(window name x y 0 (seal
(seal (overlay label-image
(overlay label-image (rectangle (+ (image-width label-image) 20)
(rectangle (+ (image-width label-image) 20) (+ (image-height label-image) 20)
(+ (image-height label-image) 20) "solid"
"solid" background))))))))
background)))))))))
(define (draggable-shape name orig-x orig-y image) (define (draggable-shape name orig-x orig-y image)
(define (window-at x y) (window name x y 10 (seal image))) (define (window-at x y) (window name x y 10 (seal image)))
@ -38,12 +37,11 @@
(my nmy)) (my nmy))
(stop-when (message (inbound (mouse-event $mx $my _ (? mouse-left-event-type? $t)))) (stop-when (message (inbound (mouse-event $mx $my _ (? mouse-left-event-type? $t))))
(idle 0 (- mx dx) (- my dy))))) (idle 0 (- mx dx) (- my dy)))))
(actor (idle 0 orig-x orig-y))) (actor* (idle 0 orig-x orig-y)))
(actor (forever (actor (during (inbound (active-window $id))
(during (inbound (active-window $id)) (assert (outbound (window 'active-window-label 300 0 0
(assert (outbound (window 'active-window-label 300 0 0 (seal (text (format "~v" id) 22 "black")))))))
(seal (text (format "~v" id) 22 "black"))))))))
(button #:background "red" 'stop-button 0 0 "Exit" (button #:background "red" 'stop-button 0 0 "Exit"
(lambda () (assert! (outbound 'stop)))) (lambda () (assert! (outbound 'stop))))
(draggable-shape 'c1 50 50 (circle 30 "solid" "orange")) (draggable-shape 'c1 50 50 (circle 30 "solid" "orange"))

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

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

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

@ -3,13 +3,13 @@
(struct envelope (destination message) #:prefab) (struct envelope (destination message) #:prefab)
(actor (react (on (message (envelope 'alice $message)) (actor (on (message (envelope 'alice $message))
(log-info "Alice received ~v" message)))) (log-info "Alice received ~v" message)))
(actor (react (on (message (envelope 'bob $message)) (actor (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.")
(until (asserted (observe (envelope 'alice _)))) (until (asserted (observe (envelope 'alice _))))
(until (asserted (observe (envelope 'bob _)))) (until (asserted (observe (envelope 'bob _))))

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

@ -9,9 +9,9 @@
(define (chain-step n) (define (chain-step n)
(printf "chain-step ~v\n" n) (printf "chain-step ~v\n" n)
(actor (sleep 1) (actor* (sleep 1)
(if (< n 5) (if (< n 5)
(chain-step (+ n 1)) (chain-step (+ n 1))
(printf "done.\n")))) (printf "done.\n"))))
(chain-step 0) (chain-step 0)

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

@ -8,15 +8,13 @@
(define remote-handle (tcp-address "localhost" 5999)) (define remote-handle (tcp-address "localhost" 5999))
(define stdin-evt (read-bytes-line-evt (current-input-port) 'any)) (define stdin-evt (read-bytes-line-evt (current-input-port) 'any))
(actor (actor (stop-when (message (inbound (external-event stdin-evt (list (? eof-object? _))))))
(react/suspend (quit) (stop-when (retracted (advertise (tcp-channel remote-handle local-handle _))))
(on (message (inbound (external-event stdin-evt (list $line)))) (assert (advertise (tcp-channel local-handle remote-handle _)))
(if (eof-object? line)
(quit)
(send! (tcp-channel local-handle remote-handle line))))
(assert (advertise (tcp-channel local-handle remote-handle _))) (on (message (inbound (external-event stdin-evt (list (? bytes? $line)))))
(on (retracted (advertise (tcp-channel remote-handle local-handle _))) (quit)) (send! (tcp-channel local-handle remote-handle line)))
(on (message (tcp-channel remote-handle local-handle $bs))
(write-bytes bs) (on (message (tcp-channel remote-handle local-handle $bs))
(flush-output)))) (write-bytes bs)
(flush-output)))

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

@ -16,21 +16,21 @@
(send-to-remote "~a ~a\n" who (apply format fmt vs)))) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
(define user (gensym 'user)) (define user (gensym 'user))
(send-to-remote "Welcome, ~a.\n" user) (on-start (send-to-remote "Welcome, ~a.\n" user))
(until (retracted (advertise (tcp-channel them us _))) (stop-when (retracted (advertise (tcp-channel them us _))))
(assert (present user))
(on (asserted (present $who)) (say who "arrived."))
(on (retracted (present $who)) (say who "departed."))
(on (message (says $who $what)) (say who "says: ~a" what)) (assert (present user))
(on (asserted (present $who)) (say who "arrived."))
(on (retracted (present $who)) (say who "departed."))
(assert (advertise (tcp-channel us them _))) (on (message (says $who $what)) (say who "says: ~a" what))
(on (message (tcp-channel them us $bs))
(send! (says user (string-trim (bytes->string/utf-8 bs)))))))) (assert (advertise (tcp-channel us them _)))
(on (message (tcp-channel them us $bs))
(send! (says user (string-trim (bytes->string/utf-8 bs)))))))
(define us (tcp-listener 5999)) (define us (tcp-listener 5999))
(actor (actor (assert (advertise (observe (tcp-channel _ us _))))
(forever (assert (advertise (observe (tcp-channel _ us _)))) (on (asserted (advertise (tcp-channel $them us _)))
(on (asserted (advertise (tcp-channel $them us _))) (spawn-session them us)))
(spawn-session them us))))

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

@ -16,18 +16,19 @@
(send-to-remote "~a ~a\n" who (apply format fmt vs)))) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
(define user (gensym 'user)) (define user (gensym 'user))
(send-to-remote "Welcome, ~a.\n" user) (on-start (send-to-remote "Welcome, ~a.\n" user))
(until (retracted (inbound (advertise (tcp-channel them us _)))) (stop-when (retracted (inbound (advertise (tcp-channel them us _)))))
(assert (present user))
(on (asserted (present $who)) (say who "arrived."))
(on (retracted (present $who)) (say who "departed."))
(on (message (says $who $what)) (say who "says: ~a" what)) (assert (present user))
(on (asserted (present $who)) (say who "arrived."))
(on (retracted (present $who)) (say who "departed."))
(assert (outbound (advertise (tcp-channel us them _)))) (on (message (says $who $what)) (say who "says: ~a" what))
(on (message (inbound (tcp-channel them us $bs)))
(send! (says user (string-trim (bytes->string/utf-8 bs)))))))) (assert (outbound (advertise (tcp-channel us them _))))
(on (message (inbound (tcp-channel them us $bs)))
(send! (says user (string-trim (bytes->string/utf-8 bs)))))))
(dataspace (define us (tcp-listener 5999)) (dataspace (define us (tcp-listener 5999))
(forever (assert (outbound (advertise (observe (tcp-channel _ us _))))) (forever (assert (outbound (advertise (observe (tcp-channel _ us _)))))

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

@ -21,30 +21,30 @@
(send-to-remote "~a ~a\n" who (apply format fmt vs)))) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
(define user (gensym 'user)) (define user (gensym 'user))
(send-to-remote "Welcome, ~a.\n" user) (on-start (send-to-remote "Welcome, ~a.\n" user))
(until (retracted (tcp-remote-open id)) (stop-when (retracted (tcp-remote-open id)))
(assert (tcp-local-open id)) (assert (tcp-local-open id))
(assert (present user)) (assert (present user))
(on (asserted (present $who)) (say who "arrived.")) (on (asserted (present $who)) (say who "arrived."))
(on (retracted (present $who)) (say who "departed.")) (on (retracted (present $who)) (say who "departed."))
(on (message (says $who $what)) (say who "says: ~a" what)) (on (message (says $who $what)) (say who "says: ~a" what))
(on (message (tcp-incoming-data id $bs)) (on (message (tcp-incoming-data id $bs))
(send! (says user (string-trim (bytes->string/utf-8 bs)))))))) (send! (says user (string-trim (bytes->string/utf-8 bs)))))))
(define us (tcp-listener 5999)) (define us (tcp-listener 5999))
(actor (forever (assert (advertise (observe (tcp-channel _ us _)))) (actor (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 (react (stop-when (retracted (advertise (tcp-channel them us _)))) (actor (stop-when (retracted (advertise (tcp-channel them us _))))
(stop-when (retracted (tcp-local-open id))) (stop-when (retracted (tcp-local-open id)))
(assert (tcp-remote-open id)) (assert (tcp-remote-open id))
(on (message (tcp-channel them us $bs)) (on (message (tcp-channel them us $bs))
(send! (tcp-incoming-data id bs))) (send! (tcp-incoming-data id bs)))
(on (message (tcp-outgoing-data id $bs)) (on (message (tcp-outgoing-data id $bs))
(send! (tcp-channel us them bs)))))))) (send! (tcp-channel us them bs))))))
(actor (forever (on (asserted (tcp-remote-open $id)) (actor (on (asserted (tcp-remote-open $id))
(spawn-session id)))) (spawn-session id)))

25
racket/syndicate/examples/actor/chat.rkt
View File

@ -17,21 +17,22 @@
(send-to-remote "~a ~a\n" who (apply format fmt vs)))) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
(define user (gensym 'user)) (define user (gensym 'user))
(send-to-remote "Welcome, ~a.\n" user) (on-start (send-to-remote "Welcome, ~a.\n" user))
(until (retracted (inbound (advertise (tcp-channel them us _)))) (stop-when (retracted (inbound (advertise (tcp-channel them us _)))))
(assert (present user))
(on (asserted (present $who)) (say who "arrived."))
(on (retracted (present $who)) (say who "departed."))
(on (message (says $who $what)) (say who "says: ~a" what)) (assert (present user))
(on (asserted (present $who)) (say who "arrived."))
(on (retracted (present $who)) (say who "departed."))
(assert (outbound (advertise (tcp-channel us them _)))) (on (message (says $who $what)) (say who "says: ~a" what))
(on (message (inbound (tcp-channel them us $bs)))
(define input-string (string-trim (bytes->string/utf-8 bs))) (assert (outbound (advertise (tcp-channel us them _))))
(if (equal? input-string "quit-dataspace") (on (message (inbound (tcp-channel them us $bs)))
(send! (shutdown)) (define input-string (string-trim (bytes->string/utf-8 bs)))
(send! (says user input-string))))))) (if (equal? input-string "quit-dataspace")
(send! (shutdown))
(send! (says user input-string))))))
(dataspace (define us (tcp-listener 5999)) (dataspace (define us (tcp-listener 5999))
(until (message (shutdown)) (until (message (shutdown))

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

@ -4,11 +4,10 @@
(require/activate syndicate/drivers/tcp) (require/activate syndicate/drivers/tcp)
(define server-id (tcp-listener 5999)) (define server-id (tcp-listener 5999))
(actor (actor (assert (advertise (observe (tcp-channel _ server-id _))))
(forever (assert (advertise (observe (tcp-channel _ server-id _)))) (during/actor (advertise (tcp-channel $c server-id _))
(during/actor (advertise (tcp-channel $c server-id _)) (on-start (printf "Accepted connection from ~v\n" c))
(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))) (on-stop (printf "Closed connection ~v\n" c))))
(on-stop (printf "Closed connection ~v\n" c)))))

33
racket/syndicate/examples/actor/example-action-after-suspension.rkt
View File

@ -16,24 +16,23 @@
(struct x (v) #:prefab) (struct x (v) #:prefab)
(actor (forever (on (message (x 'ping)) (actor (on (message (x 'ping))
(send! (x 'pong))))) (send! (x 'pong))))
(actor (react (actor (field [flag 'clear])
(field [flag 'clear]) (begin/dataflow
(begin/dataflow (printf "flag: ~v\n" (flag)))
(printf "flag: ~v\n" (flag)))
(field [spec #f]) (field [spec #f])
(begin/dataflow (begin/dataflow
(when (spec) (when (spec)
(let-event [(asserted (observe (x (spec))))] (let-event [(asserted (observe (x (spec))))]
(send! (x (list 'saw (spec)))) (send! (x (list 'saw (spec))))
(flag 'set)))) (flag 'set))))
(on-start (send! (x 'first))) (on-start (send! (x 'first)))
(on (message (x 'first)) (on (message (x 'first))
(spec 'ping)))) (spec 'ping)))
(actor (forever (on (message (x $v)) (actor (on (message (x $v))
(printf "- ~v\n" v)))) (printf "- ~v\n" v)))

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

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

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

@ -5,25 +5,23 @@
(struct ready (what) #:prefab) (struct ready (what) #:prefab)
(struct entry (key val) #:prefab) (struct entry (key val) #:prefab)
(actor (react (actor (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) (until (retracted (entry key _))
(until (retracted (entry key _)) (on (asserted (entry key $value))
(on (asserted (entry key $value)) (log-info "add binding: ~v -> ~v" key value))
(log-info "add binding: ~v -> ~v" key value)) (on (retracted (entry key $value))
(on (retracted (entry key $value)) (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 (react (actor (assert (ready 'other-listener))
(assert (ready 'other-listener)) (during (entry $key _)
(during (entry $key _) (log-info "(other-listener) key ~v asserted" key)
(log-info "(other-listener) key ~v asserted" key) (on-stop (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) (log-info "(other-listener) ~v ---> ~v" key value)
(log-info "(other-listener) ~v ---> ~v" key value) (on-stop (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")
@ -31,18 +29,18 @@
(until (asserted (ready token)) (until (asserted (ready token))
(assert (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)))
(assert! (entry 'a 1)) (assert! (entry 'a 1))
(assert! (entry 'a 2)) (assert! (entry 'a 2))
(assert! (entry 'b 3)) (assert! (entry 'b 3))
(assert! (entry 'c 33)) (assert! (entry 'c 33))
(assert! (entry 'a 4)) (assert! (entry 'a 4))
(assert! (entry 'a 5)) (assert! (entry 'a 5))
(pause) (pause)
(retract! (entry 'a 2)) (retract! (entry 'a 2))
(retract! (entry 'c 33)) (retract! (entry 'c 33))
(assert! (entry 'a 9)) (assert! (entry 'a 9))
(pause) (pause)
(retract! (entry 'a ?)) (retract! (entry 'a ?))
(pause)) (pause))

28
racket/syndicate/examples/actor/example-synthetic-patch.rkt
View File

@ -24,18 +24,18 @@
(struct outer (v) #:prefab) (struct outer (v) #:prefab)
(struct show () #:prefab) (struct show () #:prefab)
(actor (react (field [v "first"]) (actor (field [v "first"])
(assert (outer (v))) (assert (outer (v)))
(assert (show)) (assert (show))
(on (message 2) (on (message 2)
(v "second")))) (v "second")))
(actor (react (on-start (send! 1)) (actor (on-start (send! 1))
(during (outer $v) (during (outer $v)
(on-start (log-info "+outer ~v" v)) (on-start (log-info "+outer ~v" v))
(on-stop (log-info "-outer ~v" v)) (on-stop (log-info "-outer ~v" v))
(during (show) (during (show)
(on-start (log-info "+show")) (on-start (log-info "+show"))
(on-stop (log-info "-show")))) (on-stop (log-info "-show"))))
(on (message 1) (on (message 1)
(send! 2)))) (send! 2)))

45
racket/syndicate/examples/actor/fib-server.rkt
View File

@ -4,25 +4,24 @@
(require/activate syndicate/drivers/timer) (require/activate syndicate/drivers/timer)
(actor (actor
(react (during/actor (observe `(fib ,$n ,_))
(during/actor (observe `(fib ,$n ,_)) #:actor actor/thread
#:actor actor/thread (on-start (log-info "Computing fib ~a..." n))
(on-start (log-info "Computing fib ~a..." n)) (on-stop (log-info "Leaving fib ~a" n))
(on-stop (log-info "Leaving fib ~a" n)) (assert `(up ,n))
(assert `(up ,n)) (on-start
(on-start (flush!)
(flush!) (react
(react (assert `(fib ,n
(assert `(fib ,n ,(let ((answer
,(let ((answer (let f ((n n))
(let f ((n n)) (if (< n 2)
(if (< n 2) n
n (+ (f (- n 1))
(+ (f (- n 1)) (f (- n 2)))))))
(f (- n 2))))))) (if (= n 36)
(if (= n 36) (error 'fib "Deliberate, hardcoded failure for n=36")
(error 'fib "Deliberate, hardcoded failure for n=36") answer))))))))
answer)))))))))
(dataspace/thread (dataspace/thread
(actor (actor
@ -30,10 +29,10 @@
(define (arm!) (define (arm!)
(log-info "Tick ~v!" (tick-count)) (log-info "Tick ~v!" (tick-count))
(send! (outbound (set-timer 'tick 1000 'relative)))) (send! (outbound (set-timer 'tick 1000 'relative))))
(react (on (message (inbound (timer-expired 'tick _))) (on (message (inbound (timer-expired 'tick _)))
(tick-count (+ (tick-count) 1)) (tick-count (+ (tick-count) 1))
(arm!)) (arm!))
(on-start (arm!)))) (on-start (arm!)))
(field [counter 0]) (field [counter 0])
(react (react

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

@ -5,13 +5,13 @@
(require/activate "fs-shell.rkt") (require/activate "fs-shell.rkt")
(require/activate "fs-protocol.rkt") (require/activate "fs-protocol.rkt")
(actor (react (field [files (hash)]) (actor (field [files (hash)])
(during (observe (file $name _)) (during (observe (file $name _))
(on-start (printf "At least one reader exists for ~v\n" name)) (on-start (printf "At least one reader exists for ~v\n" name))
(on-stop (printf "No remaining readers exist for ~v\n" name)) (on-stop (printf "No remaining readers exist for ~v\n" name))
(field [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 $new-content))) (content new-content)) (on (message (save (file name $new-content))) (content new-content))
(on (message (delete name)) (content #f))) (on (message (delete name)) (content #f)))
(on (message (save (file $name $content))) (files (hash-set (files) name content))) (on (message (save (file $name $content))) (files (hash-set (files) name content)))
(on (message (delete $name)) (files (hash-remove (files) name))))) (on (message (delete $name)) (files (hash-remove (files) name))))

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

@ -5,10 +5,10 @@
(require/activate "fs-shell.rkt") (require/activate "fs-shell.rkt")
(require/activate "fs-protocol.rkt") (require/activate "fs-protocol.rkt")
(actor (react (field [files (hash)]) (actor (field [files (hash)])
(during (observe (file $name _)) (during (observe (file $name _))
(on-start (printf "At least one reader exists for ~v\n" name)) (on-start (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)))
(on-stop (printf "No remaining readers exist for ~v\n" name))) (on-stop (printf "No remaining readers exist for ~v\n" name)))
(on (message (save (file $name $content))) (files (hash-set (files) name content))) (on (message (save (file $name $content))) (files (hash-set (files) name content)))
(on (message (delete $name)) (files (hash-remove (files) name))))) (on (message (delete $name)) (files (hash-remove (files) name))))

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

@ -5,14 +5,14 @@
(require/activate "fs-shell.rkt") (require/activate "fs-shell.rkt")
(require/activate "fs-protocol.rkt") (require/activate "fs-protocol.rkt")
(actor (react (field [files (hash)]) (actor (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)
(until (retracted (observe (file name _))) (until (retracted (observe (file name _)))
(field [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 $new-content))) (content new-content)) (on (message (save (file name $new-content))) (content new-content))
(on (message (delete name)) (content #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))) (files (hash-set (files) name content))) (on (message (save (file $name $content))) (files (hash-set (files) name content)))
(on (message (delete $name)) (files (hash-remove (files) name))))) (on (message (delete $name)) (files (hash-remove (files) name))))

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

@ -6,22 +6,22 @@
(require/activate "fs-protocol.rkt") (require/activate "fs-protocol.rkt")
(require racket/set) (require racket/set)
(actor (react (field [files (hash)] [monitored (set)]) (actor (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)))
(monitored (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)))
(monitored (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)))
(files (hash-set (files) name content))) (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)))
(files (hash-remove (files) name))))) (files (hash-remove (files) name))))

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

@ -1,17 +1,17 @@
#lang syndicate/actor #lang syndicate/actor
;; Minimal syndicate/actor variation on examples/forward-chaining.rkt. ;; Minimal syndicate/actor variation on examples/forward-chaining.rkt.
(actor (react (assert `(parent john douglas)))) (actor (assert `(parent john douglas)))
(actor (react (assert `(parent bob john)))) (actor (assert `(parent bob john)))
(actor (react (assert `(parent ebbon bob)))) (actor (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 (react (during `(parent ,$A ,$C) (actor (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 (react (on (asserted `(ancestor ,$A ,$B)) (actor (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)))

58
racket/syndicate/examples/actor/fs-shell.rkt
View File

@ -18,32 +18,32 @@
(printf "> ") (printf "> ")
(flush-output)) (flush-output))
(actor (field [reader-count 0]) (actor (field [reader-count 0])
(print-prompt) (on-start (print-prompt))
(until (message (inbound (external-event e (list (? eof-object? _))))) (stop-when (message (inbound (external-event e (list (? eof-object? _))))))
(on (message (inbound (external-event e (list (? bytes? $bs))))) (on (message (inbound (external-event e (list (? bytes? $bs)))))
(match (string-split (string-trim (bytes->string/utf-8 bs))) (match (string-split (string-trim (bytes->string/utf-8 bs)))
[(list "open" name) [(list "open" name)
(define reader-id (reader-count)) (define reader-id (reader-count))
(reader-count (+ (reader-count) 1)) (reader-count (+ (reader-count) 1))
(actor (printf "Reader ~a opening file ~v.\n" reader-id name) (actor (on-start (printf "Reader ~a opening file ~v.\n" reader-id name))
(until (message `(stop-watching ,name)) (stop-when (message `(stop-watching ,name)))
(on (asserted (file name $contents)) (on (asserted (file name $contents))
(printf "Reader ~a sees that ~v contains: ~v\n" (printf "Reader ~a sees that ~v contains: ~v\n"
reader-id reader-id
name name
contents))) contents))
(printf "Reader ~a closing file ~v.\n" reader-id name))] (on-stop (printf "Reader ~a closing file ~v.\n" reader-id name)))]
[(list "close" name) [(list "close" name)
(send! `(stop-watching ,name))] (send! `(stop-watching ,name))]
[(list* "write" name words) [(list* "write" name words)
(send! (save (file name words)))] (send! (save (file name words)))]
[(list "delete" name) [(list "delete" name)
(send! (delete name))] (send! (delete name))]
[_ [_
(printf "I'm afraid I didn't understand that.\n") (printf "I'm afraid I didn't understand that.\n")
(printf "Try: open filename\n") (printf "Try: open filename\n")
(printf " close filename\n") (printf " close filename\n")
(printf " write filename some text goes here\n") (printf " write filename some text goes here\n")
(printf " delete filename\n")]) (printf " delete filename\n")])
(sleep 0.1) (sleep 0.1)
(print-prompt))))) (print-prompt))))

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

@ -3,16 +3,16 @@
(struct echo-req (body) #:prefab) (struct echo-req (body) #:prefab)
(struct echo-resp (body) #:prefab) (struct echo-resp (body) #:prefab)
(actor (react (field [count 0]) (actor (field [count 0])
(on (message (echo-req $body)) (on (message (echo-req $body))
(send! (echo-resp body)) (send! (echo-resp body))
(count (+ (count) 1))))) (count (+ (count) 1))))
(actor (react (on (message (echo-resp $body)) (actor (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 _))))
(send! (echo-req 0)) (send! (echo-req 0))
(send! (echo-req 1)) (send! (echo-req 1))
(send! (echo-req 2))) (send! (echo-req 2)))

114
racket/syndicate/examples/actor/mutex.rkt
View File

@ -9,37 +9,36 @@
(struct resource-status (resource-id waiter-count) #:prefab) (struct resource-status (resource-id waiter-count) #:prefab)
(define (spawn-resource resource-id total-available-leases) (define (spawn-resource resource-id total-available-leases)
(actor (actor (field [waiters (make-queue)]
(react (field [waiters (make-queue)] [free-lease-count total-available-leases])
[free-lease-count total-available-leases])
(begin/dataflow (log-info "~as available: ~a" resource-id (free-lease-count))) (begin/dataflow (log-info "~as available: ~a" resource-id (free-lease-count)))
(begin/dataflow ;; This might be a nice place to put a kind of "class contract" (begin/dataflow ;; This might be a nice place to put a kind of "class contract"
(unless (and (>= (free-lease-count) 0) (unless (and (>= (free-lease-count) 0)
(<= (free-lease-count) total-available-leases) (<= (free-lease-count) total-available-leases)
(or (zero? (free-lease-count)) (or (zero? (free-lease-count))
(queue-empty? (waiters)))) (queue-empty? (waiters))))
(error 'resource "~a: Invariant violated" resource-id))) (error 'resource "~a: Invariant violated" resource-id)))
(on (asserted (lease-request resource-id $w)) (on (asserted (lease-request resource-id $w))
(cond [(positive? (free-lease-count)) (cond [(positive? (free-lease-count))
(assert! (lease-assignment resource-id w)) (assert! (lease-assignment resource-id w))
(free-lease-count (- (free-lease-count) 1))] (free-lease-count (- (free-lease-count) 1))]
[else [else
(waiters (enqueue (waiters) w))])) (waiters (enqueue (waiters) w))]))
(on (retracted (lease-request resource-id $w)) (on (retracted (lease-request resource-id $w))
(waiters (queue-filter (lambda (x) (not (equal? w x))) (waiters))) (waiters (queue-filter (lambda (x) (not (equal? w x))) (waiters)))
(retract! (lease-assignment resource-id w))) (retract! (lease-assignment resource-id w)))
(on (retracted (lease-assignment resource-id $w)) (on (retracted (lease-assignment resource-id $w))
(cond [(queue-empty? (waiters)) (cond [(queue-empty? (waiters))
(free-lease-count (+ (free-lease-count) 1))] (free-lease-count (+ (free-lease-count) 1))]
[else [else
(define-values (w remainder) (dequeue (waiters))) (define-values (w remainder) (dequeue (waiters)))
(assert! (lease-assignment resource-id w)) (assert! (lease-assignment resource-id w))
(waiters remainder)]))))) (waiters remainder)]))))
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
@ -47,42 +46,41 @@
(struct philosopher-status (name status) #:prefab) (struct philosopher-status (name status) #:prefab)
(actor (react (define/query-hash-set thinkers (philosopher-status $who $status) status who) (actor (define/query-hash-set thinkers (philosopher-status $who $status) status who)
(begin/dataflow (begin/dataflow
(log-info "~a" (for/list (((status names) (in-hash (thinkers)))) (log-info "~a" (for/list (((status names) (in-hash (thinkers))))
(format "~a: ~a" status (set->list names))))))) (format "~a: ~a" status (set->list names))))))
(define (philosopher name) (define (philosopher name)
(actor (actor (field [status 'starting])
(react (field [status 'starting]) (assert (philosopher-status name (status)))
(assert (philosopher-status name (status)))
(stop-when (rising-edge (eq? (status) 'inspired))) (stop-when (rising-edge (eq? (status) 'inspired)))
(on-start (on-start
(let loop () (let loop ()
(define thinking-duration (* (random) 4)) (define thinking-duration (* (random) 4))
(log-info "~a thinks for ~a seconds" name thinking-duration) (log-info "~a thinks for ~a seconds" name thinking-duration)
(status 'thinking) (status 'thinking)
(until (message (timer-expired name _)) (until (message (timer-expired name _))
(on-start (send! (set-timer name (* thinking-duration 1000.0) 'relative)))) (on-start (send! (set-timer name (* thinking-duration 1000.0) 'relative))))
(if (> (random) 0.95) (if (> (random) 0.95)
(begin (begin
(log-info "~a stops thinking, leaps up, shouts \"EUREKA!\", and leaves.\n" name) (log-info "~a stops thinking, leaps up, shouts \"EUREKA!\", and leaves.\n" name)
(status 'inspired)) (status 'inspired))
(begin (begin
(log-info "~a stops thinking, and waits for a fork" name) (log-info "~a stops thinking, and waits for a fork" name)
(status 'waiting) (status 'waiting)
(react (assert (lease-request 'fork name)) (react (assert (lease-request 'fork name))
(on (asserted (lease-assignment 'fork name)) (on (asserted (lease-assignment 'fork name))
(status 'eating) (status 'eating)
(log-info "~a claims a fork" name) (log-info "~a claims a fork" name)
(define eating-duration (* (random) 4)) (define eating-duration (* (random) 4))
(log-info "~a is eating for ~a seconds" name eating-duration) (log-info "~a is eating for ~a seconds" name eating-duration)
(send! (set-timer name (* eating-duration 1000.0) 'relative))) (send! (set-timer name (* eating-duration 1000.0) 'relative)))
(stop-when (message (timer-expired name _)) (stop-when (message (timer-expired name _))
(log-info "~a finishes eating and puts down the fork" name) (log-info "~a finishes eating and puts down the fork" name)
(loop)))))))))) (loop)))))))))
(spawn-resource 'fork 2) (spawn-resource 'fork 2)
(philosopher 'Socrates) (philosopher 'Socrates)

13
racket/syndicate/examples/actor/parameters.rkt
View File

@ -33,14 +33,13 @@
(define p-at-spawn-time (p)) (define p-at-spawn-time (p))
(actor #:name (list 'spawn-one p-at-spawn-time) (actor #:name (list 'spawn-one p-at-spawn-time)
(define p-at-start-time (p)) (define p-at-start-time (p))
(react (assert `(p-at-spawn-time ,p-at-spawn-time))
(assert `(p-at-spawn-time ,p-at-spawn-time)) (assert `(p-at-start-time ,p-at-start-time))
(assert `(p-at-start-time ,p-at-start-time)) (assert `(p ,(p)))
(assert `(p ,(p))) (on (message 'survey)
(on (message 'survey) (send! `(survey-response ,(p))))))
(send! `(survey-response ,(p)))))))
(actor (actor*
(spawn-one) (spawn-one)
(parameterize ((p 'first)) (spawn-one)) (parameterize ((p 'first)) (spawn-one))
(parameterize ((p 'second)) (spawn-one)) (parameterize ((p 'second)) (spawn-one))

104
racket/syndicate/examples/actor/query-set.rkt
View File

@ -3,58 +3,57 @@
(require racket/set) (require racket/set)
(actor #:name 'queryer (actor #:name 'queryer
(forever (define/query-value as-value 'absent `(item ,$a ,$b) (list a b))
(define/query-value as-value 'absent `(item ,$a ,$b) (list a b)) (define/query-set as-set `(item ,$a ,$b) (list a b)
(define/query-set as-set `(item ,$a ,$b) (list a b) #:on-add (log-info "as-set adding ~v/~v" a b)
#:on-add (log-info "as-set adding ~v/~v" a b) #:on-remove (log-info "as-set removing ~v/~v" a b))
#:on-remove (log-info "as-set removing ~v/~v" a b)) (define/query-hash as-hash `(item ,$a ,$b) a b)
(define/query-hash as-hash `(item ,$a ,$b) a b) (define/query-hash-set as-hash-set `(item ,$a ,$b) a b)
(define/query-hash-set as-hash-set `(item ,$a ,$b) a b)
(field [as-value-notification-counter 0]) (field [as-value-notification-counter 0])
(begin/dataflow (begin/dataflow
(log-info "Notification counter: ~v" (as-value-notification-counter)) (log-info "Notification counter: ~v" (as-value-notification-counter))
(local-require (only-in racket/base sleep)) (local-require (only-in racket/base sleep))
(sleep 1)) (sleep 1))
(let ((shadow-counter 0)) (let ((shadow-counter 0))
(begin/dataflow (begin/dataflow
(log-info "as-value is now: ~v" (as-value)) (log-info "as-value is now: ~v" (as-value))
(set! shadow-counter (+ shadow-counter 1)) (set! shadow-counter (+ shadow-counter 1))
(as-value-notification-counter shadow-counter))) (as-value-notification-counter shadow-counter)))
(on (message 'dump) (on (message 'dump)
(printf "----------------------------------------\n") (printf "----------------------------------------\n")
(printf "Queried as-value: ~v\n" (as-value)) (printf "Queried as-value: ~v\n" (as-value))
(newline) (newline)
(printf "Queried as-set:\n") (printf "Queried as-set:\n")
(for [(item (as-set))] (for [(item (as-set))]
(match-define (list a b) item) (match-define (list a b) item)
(printf " ~v -> ~v\n" a b)) (printf " ~v -> ~v\n" a b))
(newline) (newline)
(printf "Queried as-hash:\n") (printf "Queried as-hash:\n")
(for [((k v) (in-hash (as-hash)))] (for [((k v) (in-hash (as-hash)))]
(printf " ~v -> ~v\n" k v)) (printf " ~v -> ~v\n" k v))
(newline) (newline)
(printf "Queried as-hash-set:\n") (printf "Queried as-hash-set:\n")
(for [((k vs) (in-hash (as-hash-set)))] (for [((k vs) (in-hash (as-hash-set)))]
(printf " ~v -> ~v\n" k vs)) (printf " ~v -> ~v\n" k vs))
(printf "----------------------------------------\n") (printf "----------------------------------------\n")
(flush-output)))) (flush-output)))
(actor #:name 'mutator (actor* #:name 'mutator
(until (asserted 'observer-in-ds-ready)) (until (asserted 'observer-in-ds-ready))
(assert! `(item a 1)) (assert! `(item a 1))
(assert! `(item b 2)) (assert! `(item b 2))
(assert! `(item b 3)) (assert! `(item b 3))
(send! 'dump) (send! 'dump)
(retract! `(item b ,?)) (retract! `(item b ,?))
(send! 'dump) (send! 'dump)
(assert! `(item c 1)) (assert! `(item c 1))
(assert! `(item c 4)) (assert! `(item c 4))
(send! 'dump) (send! 'dump)
(forever)) (forever))
(let ((anchor (level-anchor))) (let ((anchor (level-anchor)))
(dataspace (define LEVEL (level-anchor->meta-level anchor)) (dataspace (define LEVEL (level-anchor->meta-level anchor))
@ -62,10 +61,9 @@
(log-info "Inner level anchor: ~a" (level-anchor)) (log-info "Inner level anchor: ~a" (level-anchor))
(log-info "Computed meta-level: ~v" LEVEL) (log-info "Computed meta-level: ~v" LEVEL)
(actor #:name 'observer-in-ds (actor #:name 'observer-in-ds
(forever (assert (outbound* LEVEL 'observer-in-ds-ready))
(assert (outbound* LEVEL 'observer-in-ds-ready)) (on-start (log-info "observer-in-ds: STARTING"))
(on-start (log-info "observer-in-ds: STARTING")) (define/query-set items (inbound* LEVEL `(item ,$a ,$b)) (list a b))
(define/query-set items (inbound* LEVEL `(item ,$a ,$b)) (list a b)) (on (message (inbound* LEVEL 'dump))
(on (message (inbound* LEVEL 'dump)) (log-info "observer-in-ds: ~v" (items))))
(log-info "observer-in-ds: ~v" (items)))))
(forever))) (forever)))

86
racket/syndicate/examples/actor/queue-no-credit.rkt
View File

@ -41,65 +41,65 @@
;; EFFECT: Spawn a queue process named `queue-id`. ;; EFFECT: Spawn a queue process named `queue-id`.
(define (spawn-queue queue-id) (define (spawn-queue queue-id)
(actor #:name (list 'queue queue-id) (actor #:name (list 'queue queue-id)
(react (field [waiters (make-queue)]) (field [waiters (make-queue)])
(field [messages (make-queue)]) (field [messages (make-queue)])
(define/query-set subscribers (subscription queue-id $who) who (define/query-set subscribers (subscription queue-id $who) who
#:on-add (enq! waiters who)) #:on-add (enq! waiters who))
(on (message (delivery $who queue-id $body)) (enq! messages body)) (on (message (delivery $who queue-id $body)) (enq! messages body))
(begin/dataflow (begin/dataflow
(when (and (not (queue-empty? (waiters))) (when (and (not (queue-empty? (waiters)))
(not (queue-empty? (messages)))) (not (queue-empty? (messages))))
(define who (deq! waiters)) (define who (deq! waiters))
(when (set-member? (subscribers) who) ;; lazily remove entries from waiters (when (set-member? (subscribers) who) ;; lazily remove entries from waiters
(enq! waiters who) (enq! waiters who)
(define msg (deq! messages)) (define msg (deq! messages))
(log-info "~a: sending ~a message ~a" queue-id who msg) (log-info "~a: sending ~a message ~a" queue-id who msg)
(send! (delivery queue-id who msg))))) (send! (delivery queue-id who msg)))))
(assert (metric (list 'subscriber-count queue-id) (set-count (subscribers)))) (assert (metric (list 'subscriber-count queue-id) (set-count (subscribers))))
(assert (metric (list 'backlog queue-id) (queue-length (messages)))) (assert (metric (list 'backlog queue-id) (queue-length (messages))))
;;------------------------------------------------------------ ;;------------------------------------------------------------
(local-require (submod syndicate/actor priorities)) (local-require (submod syndicate/actor priorities))
(begin/dataflow #:priority *idle-priority* ;; Check invariants (begin/dataflow #:priority *idle-priority* ;; Check invariants
(define has-waiters? (not (queue-empty? (waiters)))) (define has-waiters? (not (queue-empty? (waiters))))
(define has-messages? (not (queue-empty? (messages)))) (define has-messages? (not (queue-empty? (messages))))
(unless (and (or (not has-waiters?) (not has-messages?)) (unless (and (or (not has-waiters?) (not has-messages?))
(or (not has-messages?) (not has-waiters?))) (or (not has-messages?) (not has-waiters?)))
(error 'queue (error 'queue
"~a: invariant violated: ~v" "~a: invariant violated: ~v"
queue-id queue-id
`((has-waiters? ,has-waiters?) `((has-waiters? ,has-waiters?)
(has-messages? ,has-messages?) (has-messages? ,has-messages?)
(waiters ,(queue->list (waiters))) (waiters ,(queue->list (waiters)))
(messages ,(queue->list (messages)))))))))) (messages ,(queue->list (messages)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Example ;; Example
(define (spawn-consumer consumer-id #:variant [variant 'normal]) (define (spawn-consumer consumer-id #:variant [variant 'normal])
(actor #:name (list 'consumer consumer-id) (actor #:name (list 'consumer consumer-id)
(react (assert (subscription 'q consumer-id)) (assert (subscription 'q consumer-id))
(on (message (delivery 'q consumer-id $body)) (on (message (delivery 'q consumer-id $body))
(log-info "Consumer ~a got: ~a" consumer-id body) (log-info "Consumer ~a got: ~a" consumer-id body)
(when (eq? variant 'crashy) (when (eq? variant 'crashy)
(error consumer-id (error consumer-id
"Hark, canst thou hear me? I will play the swan / and die in music.")))))) "Hark, canst thou hear me? I will play the swan / and die in music.")))))
(actor (react (define/query-hash metrics (metric $k $v) k v) (actor (define/query-hash metrics (metric $k $v) k v)
(begin/dataflow (log-info " ~a" (hash->list (metrics)))))) (begin/dataflow (log-info " ~a" (hash->list (metrics)))))
(spawn-queue 'q) (spawn-queue 'q)
(spawn-consumer 'c1) (spawn-consumer 'c1)
(spawn-consumer 'c2 #:variant 'crashy) (spawn-consumer 'c2 #:variant 'crashy)
(spawn-consumer 'c3) (spawn-consumer 'c3)
(actor (until (asserted (observe (delivery _ 'q _)))) (actor* (until (asserted (observe (delivery _ 'q _))))
(for ((n (in-range 10))) (for ((n (in-range 10)))
(send! (delivery #f 'q n)) (send! (delivery #f 'q n))
;; (flush!) ;; (flush!)
)) ))

84
racket/syndicate/examples/actor/queue-no-credit2.rkt
View File

@ -41,63 +41,63 @@
;; EFFECT: Spawn a queue process named `queue-id`. ;; EFFECT: Spawn a queue process named `queue-id`.
(define (spawn-queue queue-id) (define (spawn-queue queue-id)
(actor #:name (list 'queue queue-id) (actor #:name (list 'queue queue-id)
(react (field [waiters (make-queue)]) (field [waiters (make-queue)])
(field [messages (make-queue)]) (field [messages (make-queue)])
(on (asserted (subscription queue-id $who)) (enq! waiters who)) (on (asserted (subscription queue-id $who)) (enq! waiters who))
(on (retracted (subscription queue-id $who)) (waiters (queue-remove who (waiters)))) (on (retracted (subscription queue-id $who)) (waiters (queue-remove who (waiters))))
(on (message (delivery $who queue-id $body)) (enq! messages body)) (on (message (delivery $who queue-id $body)) (enq! messages body))
(begin/dataflow (begin/dataflow
(when (and (not (queue-empty? (waiters))) (when (and (not (queue-empty? (waiters)))
(not (queue-empty? (messages)))) (not (queue-empty? (messages))))
(define who (deq! waiters)) (define who (deq! waiters))
(define msg (deq! messages)) (define msg (deq! messages))
(log-info "~a: sending ~a message ~a" queue-id who msg) (log-info "~a: sending ~a message ~a" queue-id who msg)
(send! (delivery queue-id who msg)) (send! (delivery queue-id who msg))
(enq! waiters who))) (enq! waiters who)))
(assert (metric (list 'subscriber-count queue-id) (queue-length (waiters)))) (assert (metric (list 'subscriber-count queue-id) (queue-length (waiters))))
(assert (metric (list 'backlog queue-id) (queue-length (messages)))) (assert (metric (list 'backlog queue-id) (queue-length (messages))))
;;------------------------------------------------------------ ;;------------------------------------------------------------
(local-require (submod syndicate/actor priorities)) (local-require (submod syndicate/actor priorities))
(begin/dataflow #:priority *idle-priority* ;; Check invariants (begin/dataflow #:priority *idle-priority* ;; Check invariants
(define has-waiters? (not (queue-empty? (waiters)))) (define has-waiters? (not (queue-empty? (waiters))))
(define has-messages? (not (queue-empty? (messages)))) (define has-messages? (not (queue-empty? (messages))))
(unless (and (or (not has-waiters?) (not has-messages?)) (unless (and (or (not has-waiters?) (not has-messages?))
(or (not has-messages?) (not has-waiters?))) (or (not has-messages?) (not has-waiters?)))
(error 'queue (error 'queue
"~a: invariant violated: ~v" "~a: invariant violated: ~v"
queue-id queue-id
`((has-waiters? ,has-waiters?) `((has-waiters? ,has-waiters?)
(has-messages? ,has-messages?) (has-messages? ,has-messages?)
(waiters ,(queue->list (waiters))) (waiters ,(queue->list (waiters)))
(messages ,(queue->list (messages)))))))))) (messages ,(queue->list (messages)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Example ;; Example
(define (spawn-consumer consumer-id #:variant [variant 'normal]) (define (spawn-consumer consumer-id #:variant [variant 'normal])
(actor #:name (list 'consumer consumer-id) (actor #:name (list 'consumer consumer-id)
(react (assert (subscription 'q consumer-id)) (assert (subscription 'q consumer-id))
(on (message (delivery 'q consumer-id $body)) (on (message (delivery 'q consumer-id $body))
(log-info "Consumer ~a got: ~a" consumer-id body) (log-info "Consumer ~a got: ~a" consumer-id body)
(when (eq? variant 'crashy) (when (eq? variant 'crashy)
(error consumer-id (error consumer-id
"Hark, canst thou hear me? I will play the swan / and die in music.")))))) "Hark, canst thou hear me? I will play the swan / and die in music.")))))
(actor (react (define/query-hash metrics (metric $k $v) k v) (actor (define/query-hash metrics (metric $k $v) k v)
(begin/dataflow (log-info " ~a" (hash->list (metrics)))))) (begin/dataflow (log-info " ~a" (hash->list (metrics)))))
(spawn-queue 'q) (spawn-queue 'q)
(spawn-consumer 'c1) (spawn-consumer 'c1)
(spawn-consumer 'c2 #:variant 'crashy) (spawn-consumer 'c2 #:variant 'crashy)
(spawn-consumer 'c3) (spawn-consumer 'c3)
(actor (until (asserted (observe (delivery _ 'q _)))) (actor* (until (asserted (observe (delivery _ 'q _))))
(for ((n (in-range 10))) (for ((n (in-range 10)))
(send! (delivery #f 'q n)) (send! (delivery #f 'q n))
(when (odd? n) (flush!)) (when (odd? n) (flush!))
)) ))

126
racket/syndicate/examples/actor/queue.rkt
View File

@ -44,86 +44,86 @@
;; EFFECT: Spawn a queue process named `queue-id`. ;; EFFECT: Spawn a queue process named `queue-id`.
(define (spawn-queue queue-id) (define (spawn-queue queue-id)
(actor #:name (list 'queue queue-id) (actor #:name (list 'queue queue-id)
(react (field [waiters (make-queue)]) (field [waiters (make-queue)])
(field [messages (make-queue)]) (field [messages (make-queue)])
(define/query-hash credits (subscription queue-id $who) who 0) ;; Start with no credit (define/query-hash credits (subscription queue-id $who) who 0) ;; Start with no credit
(on (message (credit queue-id $who $amount)) (on (message (credit queue-id $who $amount))
(define old-credit (hash-ref (credits) who #f)) (define old-credit (hash-ref (credits) who #f))
(when old-credit (when old-credit
(credits (hash-set (credits) who (+ amount old-credit))) (credits (hash-set (credits) who (+ amount old-credit)))
(when (zero? old-credit) (enq! waiters who)))) (when (zero? old-credit) (enq! waiters who))))
(on (message (delivery $who queue-id $body)) (on (message (delivery $who queue-id $body))
(send! (credit who queue-id 1)) (send! (credit who queue-id 1))
(enq! messages body)) (enq! messages body))
(begin/dataflow (begin/dataflow
(when (and (not (queue-empty? (waiters))) (when (and (not (queue-empty? (waiters)))
(not (queue-empty? (messages)))) (not (queue-empty? (messages))))
(define who (deq! waiters)) (define who (deq! waiters))
(define old-credit (hash-ref (credits) who 0)) (define old-credit (hash-ref (credits) who 0))
(when (positive? old-credit) ;; lazily remove entries from waiters (when (positive? old-credit) ;; lazily remove entries from waiters
(define new-credit (- old-credit 1)) (define new-credit (- old-credit 1))
(credits (hash-set (credits) who new-credit)) (credits (hash-set (credits) who new-credit))
(when (positive? new-credit) (enq! waiters who)) (when (positive? new-credit) (enq! waiters who))
(define msg (deq! messages)) (define msg (deq! messages))
(log-info "~a: sending ~a message ~a" queue-id who msg) (log-info "~a: sending ~a message ~a" queue-id who msg)
(send! (delivery queue-id who msg))))) (send! (delivery queue-id who msg)))))
(during (subscription queue-id $who) (during (subscription queue-id $who)
(assert (metric (list 'credit queue-id who) (hash-ref (credits) who 0)))) (assert (metric (list 'credit queue-id who) (hash-ref (credits) who 0))))
(assert (metric (list 'backlog queue-id) (queue-length (messages)))) (assert (metric (list 'backlog queue-id) (queue-length (messages))))
;;------------------------------------------------------------ ;;------------------------------------------------------------
(local-require (submod syndicate/actor priorities)) (local-require (submod syndicate/actor priorities))
(begin/dataflow #:priority *idle-priority* ;; Check invariants (begin/dataflow #:priority *idle-priority* ;; Check invariants
(define has-waiters? (not (queue-empty? (waiters)))) (define has-waiters? (not (queue-empty? (waiters))))
(define has-messages? (not (queue-empty? (messages)))) (define has-messages? (not (queue-empty? (messages))))
(define total-credits (for/sum ((v (in-hash-values (credits)))) v)) (define total-credits (for/sum ((v (in-hash-values (credits)))) v))
(unless (and (or (not has-messages?) (zero? total-credits)) (unless (and (or (not has-messages?) (zero? total-credits))
(or (not has-waiters?) (not has-messages?)) (or (not has-waiters?) (not has-messages?))
(equal? has-waiters? (positive? total-credits))) (equal? has-waiters? (positive? total-credits)))
(error 'queue (error 'queue
"~a: invariant violated: ~v" "~a: invariant violated: ~v"
queue-id queue-id
`((has-waiters? ,has-waiters?) `((has-waiters? ,has-waiters?)
(has-messages? ,has-messages?) (has-messages? ,has-messages?)
(total-credits ,total-credits) (total-credits ,total-credits)
(waiters ,(queue->list (waiters))) (waiters ,(queue->list (waiters)))
(messages ,(queue->list (messages))) (messages ,(queue->list (messages)))
(credits ,(hash->list (credits)))))))))) (credits ,(hash->list (credits)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Example ;; Example
(define (spawn-consumer consumer-id initial-credit #:variant [variant 'normal]) (define (spawn-consumer consumer-id initial-credit #:variant [variant 'normal])
(actor #:name (list 'consumer consumer-id) (actor #:name (list 'consumer consumer-id)
(react (assert (subscription 'q consumer-id)) (assert (subscription 'q consumer-id))
(on-start (send! (credit 'q consumer-id initial-credit))) (on-start (send! (credit 'q consumer-id initial-credit)))
(on (message (delivery 'q consumer-id $body)) (on (message (delivery 'q consumer-id $body))
(log-info "Consumer ~a got: ~a" consumer-id body) (log-info "Consumer ~a got: ~a" consumer-id body)
(case variant (case variant
[(normal) [(normal)
(send! (credit 'q consumer-id 1))] (send! (credit 'q consumer-id 1))]
[(crashy) [(crashy)
(error consumer-id (error consumer-id
"Hark, canst thou hear me? I will play the swan / and die in music.")] "Hark, canst thou hear me? I will play the swan / and die in music.")]
[(overloaded) ;; don't issue credit [(overloaded) ;; don't issue credit
(void)]))))) (void)]))))
(actor (react (define/query-hash metrics (metric $k $v) k v) (actor (define/query-hash metrics (metric $k $v) k v)
(begin/dataflow (log-info " ~a" (hash->list (metrics)))))) (begin/dataflow (log-info " ~a" (hash->list (metrics)))))
(spawn-queue 'q) (spawn-queue 'q)
(spawn-consumer 'c1 2) (spawn-consumer 'c1 2)
(spawn-consumer 'c2 2 #:variant 'crashy) (spawn-consumer 'c2 2 #:variant 'crashy)
(spawn-consumer 'c3 3 #:variant 'overloaded) (spawn-consumer 'c3 3 #:variant 'overloaded)
(actor (until (asserted (observe (delivery _ 'q _)))) (actor* (until (asserted (observe (delivery _ 'q _))))
(for ((n (in-range 10))) (for ((n (in-range 10)))
(send! (delivery #f 'q n)) (send! (delivery #f 'q n))
;; (flush!) ;; (flush!)
)) ))

15
racket/syndicate/examples/actor/show-field-scope-enforcement1.rkt
View File

@ -2,14 +2,13 @@
;; Demonstrates that fields may not be passed between actors. ;; Demonstrates that fields may not be passed between actors.
(actor #:name 'reading-actor (actor #:name 'reading-actor
(react (on (message `(read-from ,$this-field))
(on (message `(read-from ,$this-field)) (log-info "Trying to read from ~a" this-field)
(log-info "Trying to read from ~a" this-field) (log-info "Read: ~a" (this-field))
(log-info "Read: ~a" (this-field)) (send! `(read-successfully ,this-field))))
(send! `(read-successfully ,this-field)))))
(actor #:name 'requesting-actor (actor #:name 'requesting-actor
(field [a 123]) (field [a 123])
(send! `(read-from ,a)) (on-start (send! `(read-from ,a)))
(until (message `(read-successfully ,a))) (stop-when (message `(read-successfully ,a)))
(log-info "Done.")) (on-stop (log-info "Done.")))

31
racket/syndicate/examples/actor/show-field-scope-enforcement2.rkt
View File

@ -3,19 +3,18 @@
;; facet, but not the other way around. ;; facet, but not the other way around.
(actor #:name 'reading-actor (actor #:name 'reading-actor
(react (field [top 123])
(field [top 123]) (on (message `(read-from ,$this-field))
(on (message `(read-from ,$this-field)) (log-info "Trying to read from ~a" this-field)
(log-info "Trying to read from ~a" this-field) (log-info "Read: ~a" (this-field))
(log-info "Read: ~a" (this-field)) (send! `(read-successfully ,this-field)))
(send! `(read-successfully ,this-field))) (on-start
(on-start (react (field [inner 234])
(react (field [inner 234]) (on-start
(on-start (log-info "Inner access to ~a: ~a" top (top)) ;; OK
(log-info "Inner access to ~a: ~a" top (top)) ;; OK (log-info "Inner access to ~a: ~a" inner (inner)) ;; OK
(log-info "Inner access to ~a: ~a" inner (inner)) ;; OK (send! `(read-from ,top)) ;; OK
(send! `(read-from ,top)) ;; OK (until (message `(read-successfully ,top)))
(until (message `(read-successfully ,top))) (send! `(read-from ,inner)) ;; Will cause a failure.
(send! `(read-from ,inner)) ;; Will cause a failure. (until (message `(read-successfully ,inner))) ;; Will never happen.
(until (message `(read-successfully ,inner))) ;; Will never happen. (log-info "Done.")))))
(log-info "Done."))))))

22
racket/syndicate/examples/actor/show-field-scope-enforcement3.rkt
View File

@ -1,14 +1,14 @@
#lang syndicate/actor #lang syndicate/actor
;; Demonstrates that fields may not be passed between sibling facets. ;; Demonstrates that fields may not be passed between sibling facets.
(actor (react (actor (on (message `(read-from ,$this-field))
(on (message `(read-from ,$this-field)) (log-info "Trying to read from ~a" this-field)
(log-info "Trying to read from ~a" this-field) (log-info "Read: ~a" (this-field))
(log-info "Read: ~a" (this-field)) (send! `(read-successfully ,this-field)))
(send! `(read-successfully ,this-field)))) (on-start
(react (react
(field [a 123]) (field [a 123])
(on-start (on-start
(send! `(read-from ,a)) (send! `(read-from ,a))
(until (message `(read-successfully ,a))) (until (message `(read-successfully ,a)))
(log-info "Done.")))) (log-info "Done.")))))

24
racket/syndicate/examples/actor/show-field-scope-enforcement4.rkt
View File

@ -1,15 +1,15 @@
#lang syndicate/actor #lang syndicate/actor
;; Demonstrates that fields at actor scope are visible to facets. ;; Demonstrates that fields at actor scope are visible to facets.
(actor (field [x 123]) (actor* (field [x 123])
(react (react
(on (message `(read-from ,$this-field)) (on (message `(read-from ,$this-field))
(log-info "Trying to read from ~a" this-field) (log-info "Trying to read from ~a" this-field)
(log-info "Read: ~a" (this-field)) (log-info "Read: ~a" (this-field))
(send! `(read-successfully ,this-field)))) (send! `(read-successfully ,this-field))))
(react (react
(on-start (on-start
(log-info "x in second facet: ~v (should be 123)" (x)) (log-info "x in second facet: ~v (should be 123)" (x))
(send! `(read-from ,x)) (send! `(read-from ,x))
(until (message `(read-successfully ,x))) (until (message `(read-successfully ,x)))
(log-info "Done.")))) (log-info "Done."))))

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

@ -26,33 +26,33 @@
(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 (stop-when (message (set-cell ',name _)))
(field ,@(for/list [(b bindings)] `[,b (void)])) (field ,@(for/list [(b bindings)] `[,b (void)]))
(assert #:when (andmap non-void-field? (list ,@bindings)) (assert #:when (andmap non-void-field? (list ,@bindings))
(cell ',name (cell ',name
(let (,@(for/list [(b bindings)] `(,b (,b)))) (let (,@(for/list [(b bindings)] `(,b (,b))))
,expr))) ,expr)))
,@(for/list [(b bindings)] ,@(for/list [(b bindings)]
`(on (asserted (cell ',b $value)) `(on (asserted (cell ',b $value))
(,b value)))))) (,b value)))))
(actor (react (on (message (set-cell $name $expr)) (actor (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 (react (on (asserted (cell $name $value)) (actor (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 (stop-when (message (inbound 'quit)))
(on (message (inbound (set-cell $name $expr)))
(send! (set-cell name expr)))
(void (thread (lambda ()
(let loop () (let loop ()
(define cell-name (read)) (define cell-name (read))
(if (eof-object? cell-name) (if (eof-object? cell-name)
(send-ground-message 'quit) (send-ground-message 'quit)
(let ((new-expr (read))) (let ((new-expr (read)))
(send-ground-message (set-cell cell-name new-expr)) (send-ground-message (set-cell cell-name new-expr))
(loop))))))) (loop))))))))
(until (message (inbound 'quit))
(on (message (inbound (set-cell $name $expr)))
(send! (set-cell name expr)))))

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

@ -75,7 +75,7 @@
(define-syntax while-relevant-assert (define-syntax while-relevant-assert
(syntax-rules () (syntax-rules ()
[(_ P) [(_ P)
(until (retracted (observe P)) (begin (stop-when (retracted (observe P)))
(assert P))])) (assert P))]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -83,43 +83,43 @@
;; SELLER ;; SELLER
;; ;;
(define (seller) (define (seller)
(actor (react (field [books (hash "The Wind in the Willows" 3.95 (actor (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 _))
(assert (book-quote title (hash-ref (books) title #f))))
;; Respond to order requests.
;;
(on (asserted (observe (order $title $offer-price _ _)))
(define asking-price (hash-ref (books) title #f))
(cond
[(or (not asking-price) (< offer-price asking-price))
;; We cannot sell a book we do not have, and we will not sell for less
;; than our asking price.
;; ;;
(during (observe (book-quote $title _)) (react (while-relevant-assert (order title offer-price #f #f)))]
(assert (book-quote title (hash-ref (books) title #f))))
;; Respond to order requests. [else
;; Allocate an order ID.
;; ;;
(on (asserted (observe (order $title $offer-price _ _))) (define order-id (next-order-id))
(define asking-price (hash-ref (books) title #f)) (next-order-id (+ order-id 1))
(cond
[(or (not asking-price) (< offer-price asking-price)) ;; Remove the book from our shelves.
;; We cannot sell a book we do not have, and we will not sell for less ;;
;; than our asking price. (books (hash-remove (books) title))
;;
(while-relevant-assert (order title offer-price #f #f))]
[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 order-id "March 9th")))]))))
;; Remove the book from our shelves.
;;
(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
;; ;;
@ -175,64 +175,62 @@
(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)))))]))])])) (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"
"Candide" "Candide"
"The Wind in the Willows") "The Wind in the Willows")
35.00))) 35.00)))
;; Serial SPLIT-DISPOSER ;; Serial SPLIT-DISPOSER
;; ;;
(define (buyer-b) (define (buyer-b)
(actor (react (actor ;; This actor maintains a record of the amount of money it has to spend.
;;
(field [funds 5.00])
;; This actor maintains a record of the amount of money it has to spend. (on (asserted (observe (split-proposal $title $price $their-contribution _)))
;;
(field [funds 5.00])
(on (asserted (observe (split-proposal $title $price $their-contribution _))) (define my-contribution (- price their-contribution))
(log-info "B is being asked to contribute ~a toward ~v at price ~a"
my-contribution
title
price)
(define my-contribution (- price their-contribution)) (cond
(log-info "B is being asked to contribute ~a toward ~v at price ~a" [(> my-contribution (funds))
my-contribution (log-info "B hasn't enough funds (~a remaining)" (funds))
title (react (while-relevant-assert (split-proposal title price their-contribution #f)))]
price)
(cond [else
[(> my-contribution (funds))
(log-info "B hasn't enough funds (~a remaining)" (funds))
(while-relevant-assert (split-proposal title price their-contribution #f))]
[else ;; Spawn a small actor (TODO: when we revise actor.rkt's implementation style,
;; this could perhaps be a facet rather than a full actor) to handle the
;; Spawn a small actor (TODO: when we revise actor.rkt's implementation style, ;; actual purchase now that we have agreed on a split.
;; this could perhaps be a facet rather than a full actor) to handle the ;;
;; actual purchase now that we have agreed on a split. (actor* (define-values (order-id delivery-date)
;;
(actor (define-values (order-id delivery-date)
(react/suspend (yield) (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))
(stop-when (asserted (order title price $id $date)) (stop-when (asserted (order title price $id $date))
;; We have received order confirmation from the SELLER. ;; We have received order confirmation from the SELLER.
;; ;;
(yield 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
delivery-date)) delivery-date))
;; 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)
(funds remaining-funds)]))))) (funds remaining-funds)]))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

44
racket/syndicate/examples/actor/web-demo.rkt
View File

@ -6,29 +6,27 @@
(require net/url) (require net/url)
(actor #:name 'server (actor #:name 'server
(react (define vh (web-virtual-host "http" ? 9090))
(define vh (web-virtual-host "http" ? 9090))
(assert vh) (assert vh)
(on (web-request-incoming (id req) vh _ ("ws" ())) (on (web-request-incoming (id req) vh _ ("ws" ()))
(actor (actor
(react (assert (web-response-websocket id))
(assert (web-response-websocket id)) (stop-when (websocket-connection-closed id) (log-info "Connection dropped"))
(stop-when (websocket-connection-closed id) (log-info "Connection dropped")) (stop-when (websocket-message-recv id "quit") (log-info "Received quit command"))
(stop-when (websocket-message-recv id "quit") (log-info "Received quit command")) (on (websocket-message-recv id $str)
(on (websocket-message-recv id $str) (log-info "Got ~v" str)
(log-info "Got ~v" str) (websocket-message-send! id str))))
(websocket-message-send! id str)))))
(field [counter 0]) (field [counter 0])
(on (web-request-get (id req) vh ("foo" ,$path)) (on (web-request-get (id req) vh ("foo" ,$path))
(define req-num (counter)) (define req-num (counter))
(counter (+ (counter) 1)) (counter (+ (counter) 1))
(web-respond/xexpr! id (web-respond/xexpr! id
`(html `(html
(body (body
(h1 "Hi there.") (h1 "Hi there.")
(p ,(format "Your path was ~v, and this is request ~a" (p ,(format "Your path was ~v, and this is request ~a"
path path
req-num)))))))) req-num)))))))

135
racket/syndicate/examples/actor/web-sanity-check.rkt
View File

@ -13,74 +13,73 @@
(on-start (send! (set-timer timer-id (* sec 1000.0) 'relative))))) (on-start (send! (set-timer timer-id (* sec 1000.0) 'relative)))))
(actor #:name 'server (actor #:name 'server
(react (field [counter 0])
(field [counter 0]) (assert vh)
(assert vh)
(on (message (web-request $id (on (message (web-request $id
'inbound 'inbound
($ req (web-request-header _ (web-resource vh `("ws" ())) _ _)) ($ req (web-request-header _ (web-resource vh `("ws" ())) _ _))
_)) _))
(actor (react (actor (react
(assert (web-response-websocket id)) (assert (web-response-websocket id))
(stop-when (retracted (observe (websocket-message id 'outbound _))) (stop-when (retracted (observe (websocket-message id 'outbound _)))
(log-info "Connection dropped")) (log-info "Connection dropped"))
(stop-when (message (websocket-message id 'inbound "quit")) (stop-when (message (websocket-message id 'inbound "quit"))
(log-info "Received quit command")) (log-info "Received quit command"))
(on (message (websocket-message id 'inbound $str)) (on (message (websocket-message id 'inbound $str))
(log-info "Got ~v" str) (log-info "Got ~v" str)
(define u (string->url str)) (define u (string->url str))
(when (url-scheme u) (when (url-scheme u)
(let ((r (gensym 'client))) (let ((r (gensym 'client)))
(react (on-start (react (on-start
(send! (web-request r (send! (web-request r
'outbound 'outbound
(web-request-header 'get (web-request-header 'get
(url->resource u) (url->resource u)
'() '()
'()) '())
#""))) #"")))
(stop-when (asserted (web-response-complete r $h $body)) (stop-when (asserted (web-response-complete r $h $body))
(log-info "Got headers back: ~v" h) (log-info "Got headers back: ~v" h)
(log-info "Got body back: ~v" body))))) (log-info "Got body back: ~v" body)))))
(send! (websocket-message id 'outbound str)))))) (send! (websocket-message id 'outbound str))))))
(on (message (web-request $id (on (message (web-request $id
'inbound 'inbound
(web-request-header 'get (web-resource vh `("slow" ())) _ _) (web-request-header 'get (web-resource vh `("slow" ())) _ _)
_)) _))
(react (field [done? #f]) (react (field [done? #f])
(stop-when (rising-edge (done?))) (stop-when (rising-edge (done?)))
(assert (web-response-chunked id (assert (web-response-chunked id
(web-response-header #:message #"Slowly" (web-response-header #:message #"Slowly"
#:mime-type #"text/plain"))) #:mime-type #"text/plain")))
(on (asserted (observe (web-response-chunk id _))) (on (asserted (observe (web-response-chunk id _)))
;; ;;
;; TODO: output-response-body/chunked in web-server's response.rkt ;; TODO: output-response-body/chunked in web-server's response.rkt
;; doesn't flush each chunk as it appears. Should it? ;; doesn't flush each chunk as it appears. Should it?
;; ;;
;; TODO: this kind of protocol pattern appears quite frequently. Perhaps ;; TODO: this kind of protocol pattern appears quite frequently. Perhaps
;; we want a general-purpose *stream* protocol? For use by TCP, ;; we want a general-purpose *stream* protocol? For use by TCP,
;; websockets, etc etc. ;; websockets, etc etc.
;; ;;
(send! (web-response-chunk id #"first\n")) (send! (web-response-chunk id #"first\n"))
(sleep 2) (sleep 2)
(send! (web-response-chunk id #"second\n")) (send! (web-response-chunk id #"second\n"))
(sleep 2) (sleep 2)
(send! (web-response-chunk id #"third\n")) (send! (web-response-chunk id #"third\n"))
(sleep 2) (sleep 2)
(done? #t)))) (done? #t))))
(on (message (web-request $id (on (message (web-request $id
'inbound 'inbound
(web-request-header 'get (web-resource vh `("foo" ,$path)) _ _) (web-request-header 'get (web-resource vh `("foo" ,$path)) _ _)
_)) _))
(define req-num (counter)) (define req-num (counter))
(counter (+ (counter) 1)) (counter (+ (counter) 1))
(send! (web-response-complete (send! (web-response-complete
id id
(web-response-header #:mime-type #"text/plain") (web-response-header #:mime-type #"text/plain")
(string->bytes/utf-8 (string->bytes/utf-8
(format "Hi there. Your path was ~v, and this is request ~a" (format "Hi there. Your path was ~v, and this is request ~a"
path path
req-num))))))) req-num))))))

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

@ -12,34 +12,34 @@
(struct path-exists (from to) #:prefab) ;; Hmm. (struct path-exists (from to) #:prefab) ;; Hmm.
(struct min-cost (from to cost) #:prefab) (struct min-cost (from to cost) #:prefab)
(actor (forever (assert (link 1 3 -2)) (actor (assert (link 1 3 -2))
(assert (link 2 1 4)) (assert (link 2 1 4))
(assert (link 2 3 3)) (assert (link 2 3 3))
(assert (link 3 4 2)) (assert (link 3 4 2))
(assert (link 4 2 -1)))) (assert (link 4 2 -1)))
(actor (forever (during (link $from $to $cost) (actor (during (link $from $to $cost)
(assert (path-exists from to)) (assert (path-exists from to))
(assert (path from to cost))))) (assert (path from to cost))))
(actor (forever (during (link $A $B $link-cost) (actor (during (link $A $B $link-cost)
(during (path B $C $path-cost) (during (path B $C $path-cost)
(assert (path-exists A C)) (assert (path-exists A C))
(assert (path A C (+ link-cost path-cost))))))) (assert (path A C (+ link-cost path-cost))))))
(actor (forever (during (path-exists $from $to) (actor (during (path-exists $from $to)
(field [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))
(costs (set-add (costs) cost)) (costs (set-add (costs) cost))
(least (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))
(costs new-costs) (costs new-costs)
(least (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 (during (path $from $to $cost)
;; (on-start (displayln `(+ ,(path from to cost)))) (on-start (displayln `(+ ,(path from to cost))))
;; (on-stop (displayln `(- ,(path from to cost))))))) (on-stop (displayln `(- ,(path from to cost))))))
(actor (forever (on (asserted (min-cost $from $to $cost)) (actor (on (asserted (min-cost $from $to $cost))
(displayln (min-cost from to cost))))) (displayln (min-cost from to cost))))

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

@ -11,35 +11,35 @@
(struct path-exists (from to) #:prefab) ;; Hmm. (struct path-exists (from to) #:prefab) ;; Hmm.
(struct min-cost (from to cost) #:prefab) (struct min-cost (from to cost) #:prefab)
(actor (forever (assert (link 1 3 -2)) (actor (assert (link 1 3 -2))
(assert (link 2 1 4)) (assert (link 2 1 4))
(assert (link 2 3 3)) (assert (link 2 3 3))
(assert (link 3 4 2)) (assert (link 3 4 2))
(assert (link 4 2 -1)))) (assert (link 4 2 -1)))
(actor (forever (during (link $from $to $cost) (actor (during (link $from $to $cost)
(assert (path-exists from to)) (assert (path-exists from to))
(assert (path from to (set from to) cost))))) (assert (path from to (set from to) cost))))
(actor (forever (during (link $A $B $link-cost) (actor (during (link $A $B $link-cost)
(during (path B $C $seen $path-cost) (during (path B $C $seen $path-cost)
(assert #:when (not (set-member? seen A)) (path-exists A C)) (assert #:when (not (set-member? seen A)) (path-exists A C))
(assert #:when (not (set-member? seen A)) (assert #:when (not (set-member? seen A))
(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 (during (path-exists $from $to)
(field [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))
(costs (set-add (costs) cost)) (costs (set-add (costs) cost))
(least (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))
(costs new-costs) (costs new-costs)
(least (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 (during (path $from $to $seen $cost)
(on-start (displayln `(+ ,(path from to seen cost)))) (on-start (displayln `(+ ,(path from to seen cost))))
(on-stop (displayln `(- ,(path from to seen cost))))))) (on-stop (displayln `(- ,(path from to seen cost))))))
(actor (forever (on (asserted (min-cost $from $to $cost)) (actor (on (asserted (min-cost $from $to $cost))
(displayln (min-cost from to cost))))) (displayln (min-cost from to cost))))

21
racket/syndicate/examples/udp-multicast.rkt
View File

@ -26,15 +26,14 @@
(define (rearm!) (send! (set-timer h 1000 'relative))) (define (rearm!) (send! (set-timer h 1000 'relative)))
(rearm!) (on-start (rearm!))
(forever (assert (udp-multicast-group-member h group-address #f))
(assert (udp-multicast-group-member h group-address #f)) (assert (udp-multicast-loopback h #t))
(assert (udp-multicast-loopback h #t)) (on (message (udp-packet $source h $body))
(on (message (udp-packet $source h $body)) (printf "~a: ~a\n" source body))
(printf "~a: ~a\n" source body)) (on (message (timer-expired h $now))
(on (message (timer-expired h $now)) (rearm!)
(rearm!) (send! (udp-packet h
(send! (udp-packet h (udp-remote-address group-address group-port)
(udp-remote-address group-address group-port) (string->bytes/utf-8 (format "~a ~a" me now))))))
(string->bytes/utf-8 (format "~a ~a" me now)))))))

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

@ -20,14 +20,14 @@
(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 (react (assert (advertise (websocket-message c s _))) (actor (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 (inbound (external-event e (list (? bytes? $bs))))) (on (message (inbound (external-event e (list (? bytes? $bs)))))
(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))
(stop-when (message (inbound (external-event e (list (? eof-object? _))))) (stop-when (message (inbound (external-event e (list (? eof-object? _)))))
(printf "Local EOF. Terminating.\n")) (printf "Local EOF. Terminating.\n"))
(stop-when (retracted (advertise (websocket-message s c _))) (stop-when (retracted (advertise (websocket-message s c _)))
(printf "Server disconnected.\n"))))) (printf "Server disconnected.\n"))))

26
racket/syndicate/examples/ws-echo.rkt
View File

@ -9,18 +9,18 @@
(define ssl-server-id (websocket-local-server 8084 (websocket-ssl-options "server-cert.pem" (define ssl-server-id (websocket-local-server 8084 (websocket-ssl-options "server-cert.pem"
"private-key.pem"))) "private-key.pem")))
(actor (forever (assert (advertise (observe (websocket-message any-client tcp-server-id _)))) (actor (assert (advertise (observe (websocket-message any-client tcp-server-id _))))
(on (asserted (advertise (websocket-message ($ c any-client) tcp-server-id _))) (on (asserted (advertise (websocket-message ($ c any-client) tcp-server-id _)))
(handle-connection tcp-server-id c)))) (handle-connection tcp-server-id c)))
(actor (forever (assert (advertise (observe (websocket-message any-client ssl-server-id _)))) (actor (assert (advertise (observe (websocket-message any-client ssl-server-id _))))
(on (asserted (advertise (websocket-message ($ c any-client) ssl-server-id _))) (on (asserted (advertise (websocket-message ($ c any-client) ssl-server-id _)))
(handle-connection ssl-server-id c)))) (handle-connection ssl-server-id c)))
(define (handle-connection s c) (define (handle-connection s c)
(actor (until (retracted (advertise (websocket-message c s _))) (actor (stop-when (retracted (advertise (websocket-message c s _))))
(on (asserted (websocket-peer-details s c $la _ $ra _)) (on (asserted (websocket-peer-details s c $la _ $ra _))
(log-info "~a: local ~v :: remote ~v" c la ra)) (log-info "~a: local ~v :: remote ~v" c la ra))
(on (message (websocket-message c s $body)) (on (message (websocket-message c s $body))
(log-info "~a: ~v" c body) (log-info "~a: ~v" c body)
(send! (websocket-message s c body)))) (send! (websocket-message s c body)))
(log-info "~a: disconnected" c))) (on-stop (log-info "~a: disconnected" c))))

13
racket/syndicate/threaded.rkt
View File

@ -1,14 +1,15 @@
#lang racket/base #lang racket/base
(provide spawn-threaded-actor (provide spawn-threaded-actor
actor/thread ;; \__ once dataspace is split into mux and relay, these two actor/thread ;; \__ once dataspace is split into mux and relay, these three
dataspace/thread) ;; / will be very thin convenience macros over a common impl. actor*/thread ;; | will be very thin convenience macros over a common impl.
dataspace/thread) ;; /
(require racket/match) (require racket/match)
(require (for-syntax racket/base)) (require (for-syntax racket/base))
(require (except-in syndicate dataspace)) (require (except-in syndicate dataspace))
(require (only-in syndicate/actor actor dataspace schedule-action!)) (require (only-in syndicate/actor actor actor* dataspace schedule-action!))
(require syndicate/hierarchy) (require syndicate/hierarchy)
(require syndicate/store) (require syndicate/store)
@ -73,6 +74,12 @@
(schedule-action! (schedule-action!
(spawn-threaded-actor (lambda () (actor body ...))))])) (spawn-threaded-actor (lambda () (actor body ...))))]))
(define-syntax actor*/thread
(syntax-rules ()
[(_ body ...)
(schedule-action!
(spawn-threaded-actor (lambda () (actor* body ...))))]))
(define-syntax dataspace/thread (define-syntax dataspace/thread
(syntax-rules () (syntax-rules ()
[(_ body ...) [(_ body ...)