First commit moving from (actor (react ...)) to (actor ...)
This commit is contained in:
Tony Garnock-Jones
parent
56e893fac4
commit
0bc775a89f
|
|
@ -6,7 +6,6 @@
|
|||
|
||||
(define (spawn-background)
|
||||
(actor
|
||||
(react
|
||||
(during (inbound (window $width $height))
|
||||
(assert (outbound
|
||||
(scene (seal `((push-matrix (scale ,width ,(* height 2))
|
||||
|
|
@ -18,14 +17,13 @@
|
|||
;; (rotate -30)
|
||||
;; (scale 5 5)
|
||||
))
|
||||
(seal `()))))))))
|
||||
(seal `())))))))
|
||||
|
||||
(define (spawn-player-avatar)
|
||||
(local-require 2htdp/planetcute)
|
||||
(define CC character-cat-girl)
|
||||
|
||||
(actor (react
|
||||
(field [x 100] [y 100])
|
||||
(actor (field [x 100] [y 100])
|
||||
(assert (outbound (simple-sprite -0.5 (x) (y) (image-width CC) (image-height CC) CC)))
|
||||
|
||||
(field [keys-down (set)])
|
||||
|
|
@ -40,24 +38,24 @@
|
|||
(define ny (+ old-y (key->delta 'down distance) (key->delta 'up (- distance))))
|
||||
(when (not (and (= nx old-x) (= ny old-y)))
|
||||
(x nx)
|
||||
(y ny))))))
|
||||
(y ny)))))
|
||||
|
||||
(define (spawn-frame-counter)
|
||||
(actor (react (field [i empty-image])
|
||||
(actor (field [i empty-image])
|
||||
(assert (outbound
|
||||
(simple-sprite -10 300 10 (image-width (i)) (image-height (i)) (i))))
|
||||
(on (message (inbound (frame-event $counter $sim-time-ms _ _)))
|
||||
(when (> sim-time-ms 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-background)
|
||||
;; (spawn-frame-counter)
|
||||
(spawn-player-avatar)
|
||||
(actor (react (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"))))))
|
||||
(actor (until (message (inbound (key-event #\q #t _))))
|
||||
(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")))))
|
||||
(actor* (until (message (inbound (key-event #\q #t _))))
|
||||
(assert! (outbound 'stop)))
|
||||
|
||||
(module+ main (current-ground-dataspace (2d-dataspace)))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide actor
|
||||
actor*
|
||||
dataspace
|
||||
|
||||
react
|
||||
|
|
@ -277,6 +278,15 @@
|
|||
name.N))))]))
|
||||
|
||||
(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
|
||||
[(_ name:name script ...)
|
||||
(quasisyntax/loc stx
|
||||
|
|
@ -433,8 +443,8 @@
|
|||
(on #,E-stx
|
||||
(let ((p #,instantiated))
|
||||
(w.wrapper #:name name.N
|
||||
(react (stop-when (retracted p))
|
||||
O ...)))))]))
|
||||
(stop-when (retracted p))
|
||||
O ...))))]))
|
||||
|
||||
(define-syntax (begin/dataflow stx)
|
||||
(syntax-parse stx
|
||||
|
|
|
|||
|
|
@ -51,10 +51,10 @@
|
|||
(define (send-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)
|
||||
(until (retracted (inbound (advertise (websocket-message c server-id _))))
|
||||
(stop-when (retracted (inbound (advertise (websocket-message c server-id _)))))
|
||||
(assert (outbound (advertise (websocket-message server-id c _))))
|
||||
|
||||
(on (asserted (inbound
|
||||
|
|
@ -75,8 +75,9 @@
|
|||
(on-event
|
||||
[(? patch? p) (send-event (log-packet c 'outbound 'patch (unwrap-patch scope p)))]
|
||||
[(message (broker-data (== scope) body))
|
||||
(send-event (message (log-packet c 'outbound 'message body)))]))
|
||||
(log-syndicate-broker-info "Ending broker connection from ~v" c)))
|
||||
(send-event (message (log-packet c 'outbound 'message body)))])
|
||||
|
||||
(on-stop (log-syndicate-broker-info "Ending broker connection from ~v" c))))
|
||||
|
||||
(define (log-packet c direction kind value)
|
||||
(log-syndicate-broker-debug "Broker: ~v: ~a ~a\n~v" c direction kind value)
|
||||
|
|
|
|||
|
|
@ -14,9 +14,7 @@
|
|||
[(eqv? (bytes-ref bs i) b) i]
|
||||
[else (loop (+ i 1))])))
|
||||
|
||||
(actor
|
||||
(react
|
||||
(during/actor (observe (tcp-channel-line $src $dst _))
|
||||
(actor (during/actor (observe (tcp-channel-line $src $dst _))
|
||||
(field [buffer #""])
|
||||
(on (message (tcp-channel src dst $bs))
|
||||
(buffer (bytes-append (buffer) bs)))
|
||||
|
|
@ -25,4 +23,4 @@
|
|||
(when newline-pos
|
||||
(define line (subbytes (buffer) 0 newline-pos))
|
||||
(buffer (subbytes (buffer) (+ newline-pos 1)))
|
||||
(send! (tcp-channel-line src dst line)))))))
|
||||
(send! (tcp-channel-line src dst line))))))
|
||||
|
|
|
|||
|
|
@ -143,18 +143,16 @@
|
|||
|
||||
(define (spawn-web-driver)
|
||||
(actor #:name 'web-server-manager
|
||||
(react
|
||||
(during/actor (web-virtual-host "http" _ $port)
|
||||
#:name (list 'web-server port)
|
||||
(setup-web-server "http"
|
||||
(or (web-server-connection-manager)
|
||||
(start-connection-manager))
|
||||
port))))
|
||||
port)))
|
||||
(actor #:name 'web-client-manager
|
||||
(react
|
||||
(on (message (web-request $id 'outbound $req $body))
|
||||
(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 listener (tcp-listen port (web-server-max-waiting) #t))
|
||||
|
|
@ -184,7 +182,7 @@
|
|||
(url-query (request-uri lowlevel-req)))
|
||||
(request-post-data/raw lowlevel-req)))
|
||||
(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))
|
||||
(stop-when (message (timer-expired (list 'web-req id) _))
|
||||
(do-response-complete control-ch
|
||||
|
|
@ -198,7 +196,7 @@
|
|||
(stop-when (asserted (web-response-chunked id $rh))
|
||||
(do-response-chunked control-ch id rh))
|
||||
(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)
|
||||
(match-define (web-response-header code resp-message last-modified-seconds mime-type headers) rh)
|
||||
|
|
|
|||
|
|
@ -4,14 +4,14 @@
|
|||
(struct account (balance) #:prefab)
|
||||
(struct deposit (amount) #:prefab)
|
||||
|
||||
(actor (react (field [balance 0])
|
||||
(actor (field [balance 0])
|
||||
(assert (account (balance)))
|
||||
(on (message (deposit $amount))
|
||||
(balance (+ (balance) amount)))))
|
||||
(balance (+ (balance) amount))))
|
||||
|
||||
(actor (react (on (asserted (account $balance))
|
||||
(printf "Balance changed to ~a\n" balance))))
|
||||
(actor (on (asserted (account $balance))
|
||||
(printf "Balance changed to ~a\n" balance)))
|
||||
|
||||
(actor (until (asserted (observe (deposit _))))
|
||||
(actor* (until (asserted (observe (deposit _))))
|
||||
(send! (deposit +100))
|
||||
(send! (deposit -30)))
|
||||
|
|
|
|||
|
|
@ -8,8 +8,7 @@
|
|||
#:font-size [font-size 22]
|
||||
name x y label callback)
|
||||
(define label-image (text label font-size foreground))
|
||||
(actor (forever
|
||||
(on (message (inbound (mouse-event _ _ name "button-down"))) (callback))
|
||||
(actor (on (message (inbound (mouse-event _ _ name "button-down"))) (callback))
|
||||
(assert (outbound
|
||||
(window name x y 0
|
||||
(seal
|
||||
|
|
@ -17,7 +16,7 @@
|
|||
(rectangle (+ (image-width label-image) 20)
|
||||
(+ (image-height label-image) 20)
|
||||
"solid"
|
||||
background)))))))))
|
||||
background))))))))
|
||||
|
||||
(define (draggable-shape name orig-x orig-y image)
|
||||
(define (window-at x y) (window name x y 10 (seal image)))
|
||||
|
|
@ -38,12 +37,11 @@
|
|||
(my nmy))
|
||||
(stop-when (message (inbound (mouse-event $mx $my _ (? mouse-left-event-type? $t))))
|
||||
(idle 0 (- mx dx) (- my dy)))))
|
||||
(actor (idle 0 orig-x orig-y)))
|
||||
(actor* (idle 0 orig-x orig-y)))
|
||||
|
||||
(actor (forever
|
||||
(during (inbound (active-window $id))
|
||||
(actor (during (inbound (active-window $id))
|
||||
(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"
|
||||
(lambda () (assert! (outbound 'stop))))
|
||||
(draggable-shape 'c1 50 50 (circle 30 "solid" "orange"))
|
||||
|
|
|
|||
|
|
@ -4,16 +4,16 @@
|
|||
(struct set-box (new-value) #:transparent)
|
||||
(struct box-state (value) #:transparent)
|
||||
|
||||
(actor (react (field [current-value 0])
|
||||
(actor (field [current-value 0])
|
||||
(assert (box-state (current-value)))
|
||||
(stop-when (rising-edge (= (current-value) 10))
|
||||
(log-info "box: terminating"))
|
||||
(on (message (set-box $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"))
|
||||
(on (asserted (box-state $v))
|
||||
(log-info "client: learned that box's value is now ~v" v)
|
||||
(send! (set-box (+ v 1))))))
|
||||
(send! (set-box (+ v 1)))))
|
||||
|
|
|
|||
|
|
@ -3,13 +3,13 @@
|
|||
|
||||
(struct envelope (destination message) #:prefab)
|
||||
|
||||
(actor (react (on (message (envelope 'alice $message))
|
||||
(log-info "Alice received ~v" message))))
|
||||
(actor (on (message (envelope 'alice $message))
|
||||
(log-info "Alice received ~v" message)))
|
||||
|
||||
(actor (react (on (message (envelope 'bob $message))
|
||||
(log-info "Bob received ~v" message))))
|
||||
(actor (on (message (envelope 'bob $message))
|
||||
(log-info "Bob received ~v" message)))
|
||||
|
||||
(actor
|
||||
(actor*
|
||||
(log-info "Waiting for Alice and Bob.")
|
||||
(until (asserted (observe (envelope 'alice _))))
|
||||
(until (asserted (observe (envelope 'bob _))))
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@
|
|||
|
||||
(define (chain-step n)
|
||||
(printf "chain-step ~v\n" n)
|
||||
(actor (sleep 1)
|
||||
(actor* (sleep 1)
|
||||
(if (< n 5)
|
||||
(chain-step (+ n 1))
|
||||
(printf "done.\n"))))
|
||||
|
|
|
|||
|
|
@ -8,15 +8,13 @@
|
|||
(define remote-handle (tcp-address "localhost" 5999))
|
||||
(define stdin-evt (read-bytes-line-evt (current-input-port) 'any))
|
||||
|
||||
(actor
|
||||
(react/suspend (quit)
|
||||
(on (message (inbound (external-event stdin-evt (list $line))))
|
||||
(if (eof-object? line)
|
||||
(quit)
|
||||
(send! (tcp-channel local-handle remote-handle line))))
|
||||
|
||||
(actor (stop-when (message (inbound (external-event stdin-evt (list (? eof-object? _))))))
|
||||
(stop-when (retracted (advertise (tcp-channel remote-handle local-handle _))))
|
||||
(assert (advertise (tcp-channel local-handle remote-handle _)))
|
||||
(on (retracted (advertise (tcp-channel remote-handle local-handle _))) (quit))
|
||||
|
||||
(on (message (inbound (external-event stdin-evt (list (? bytes? $line)))))
|
||||
(send! (tcp-channel local-handle remote-handle line)))
|
||||
|
||||
(on (message (tcp-channel remote-handle local-handle $bs))
|
||||
(write-bytes bs)
|
||||
(flush-output))))
|
||||
(flush-output)))
|
||||
|
|
|
|||
|
|
@ -16,9 +16,10 @@
|
|||
(send-to-remote "~a ~a\n" who (apply format fmt vs))))
|
||||
|
||||
(define user (gensym 'user))
|
||||
(send-to-remote "Welcome, ~a.\n" user)
|
||||
(on-start (send-to-remote "Welcome, ~a.\n" user))
|
||||
|
||||
(stop-when (retracted (advertise (tcp-channel them us _))))
|
||||
|
||||
(until (retracted (advertise (tcp-channel them us _)))
|
||||
(assert (present user))
|
||||
(on (asserted (present $who)) (say who "arrived."))
|
||||
(on (retracted (present $who)) (say who "departed."))
|
||||
|
|
@ -27,10 +28,9 @@
|
|||
|
||||
(assert (advertise (tcp-channel us them _)))
|
||||
(on (message (tcp-channel them us $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))
|
||||
(actor
|
||||
(forever (assert (advertise (observe (tcp-channel _ us _))))
|
||||
(actor (assert (advertise (observe (tcp-channel _ us _))))
|
||||
(on (asserted (advertise (tcp-channel $them us _)))
|
||||
(spawn-session them us))))
|
||||
(spawn-session them us)))
|
||||
|
|
|
|||
|
|
@ -16,9 +16,10 @@
|
|||
(send-to-remote "~a ~a\n" who (apply format fmt vs))))
|
||||
|
||||
(define user (gensym 'user))
|
||||
(send-to-remote "Welcome, ~a.\n" user)
|
||||
(on-start (send-to-remote "Welcome, ~a.\n" user))
|
||||
|
||||
(stop-when (retracted (inbound (advertise (tcp-channel them us _)))))
|
||||
|
||||
(until (retracted (inbound (advertise (tcp-channel them us _))))
|
||||
(assert (present user))
|
||||
(on (asserted (present $who)) (say who "arrived."))
|
||||
(on (retracted (present $who)) (say who "departed."))
|
||||
|
|
@ -27,7 +28,7 @@
|
|||
|
||||
(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))))))))
|
||||
(send! (says user (string-trim (bytes->string/utf-8 bs)))))))
|
||||
|
||||
(dataspace (define us (tcp-listener 5999))
|
||||
(forever (assert (outbound (advertise (observe (tcp-channel _ us _)))))
|
||||
|
|
|
|||
|
|
@ -21,9 +21,9 @@
|
|||
(send-to-remote "~a ~a\n" who (apply format fmt vs))))
|
||||
|
||||
(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 (present user))
|
||||
|
||||
|
|
@ -32,19 +32,19 @@
|
|||
(on (message (says $who $what)) (say who "says: ~a" what))
|
||||
|
||||
(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))
|
||||
(actor (forever (assert (advertise (observe (tcp-channel _ us _))))
|
||||
(actor (assert (advertise (observe (tcp-channel _ us _))))
|
||||
(on (asserted (advertise (tcp-channel $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)))
|
||||
(assert (tcp-remote-open id))
|
||||
(on (message (tcp-channel them us $bs))
|
||||
(send! (tcp-incoming-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))
|
||||
(spawn-session id))))
|
||||
(actor (on (asserted (tcp-remote-open $id))
|
||||
(spawn-session id)))
|
||||
|
|
|
|||
|
|
@ -17,9 +17,10 @@
|
|||
(send-to-remote "~a ~a\n" who (apply format fmt vs))))
|
||||
|
||||
(define user (gensym 'user))
|
||||
(send-to-remote "Welcome, ~a.\n" user)
|
||||
(on-start (send-to-remote "Welcome, ~a.\n" user))
|
||||
|
||||
(stop-when (retracted (inbound (advertise (tcp-channel them us _)))))
|
||||
|
||||
(until (retracted (inbound (advertise (tcp-channel them us _))))
|
||||
(assert (present user))
|
||||
(on (asserted (present $who)) (say who "arrived."))
|
||||
(on (retracted (present $who)) (say who "departed."))
|
||||
|
|
@ -31,7 +32,7 @@
|
|||
(define input-string (string-trim (bytes->string/utf-8 bs)))
|
||||
(if (equal? input-string "quit-dataspace")
|
||||
(send! (shutdown))
|
||||
(send! (says user input-string)))))))
|
||||
(send! (says user input-string))))))
|
||||
|
||||
(dataspace (define us (tcp-listener 5999))
|
||||
(until (message (shutdown))
|
||||
|
|
|
|||
|
|
@ -4,11 +4,10 @@
|
|||
(require/activate syndicate/drivers/tcp)
|
||||
|
||||
(define server-id (tcp-listener 5999))
|
||||
(actor
|
||||
(forever (assert (advertise (observe (tcp-channel _ server-id _))))
|
||||
(actor (assert (advertise (observe (tcp-channel _ server-id _))))
|
||||
(during/actor (advertise (tcp-channel $c server-id _))
|
||||
(on-start (printf "Accepted connection from ~v\n" c))
|
||||
(assert (advertise (tcp-channel server-id c _)))
|
||||
(on (message (tcp-channel c server-id $bs))
|
||||
(send! (tcp-channel server-id c bs)))
|
||||
(on-stop (printf "Closed connection ~v\n" c)))))
|
||||
(on-stop (printf "Closed connection ~v\n" c))))
|
||||
|
|
|
|||
|
|
@ -16,11 +16,10 @@
|
|||
|
||||
(struct x (v) #:prefab)
|
||||
|
||||
(actor (forever (on (message (x 'ping))
|
||||
(send! (x 'pong)))))
|
||||
(actor (on (message (x 'ping))
|
||||
(send! (x 'pong))))
|
||||
|
||||
(actor (react
|
||||
(field [flag 'clear])
|
||||
(actor (field [flag 'clear])
|
||||
(begin/dataflow
|
||||
(printf "flag: ~v\n" (flag)))
|
||||
|
||||
|
|
@ -33,7 +32,7 @@
|
|||
|
||||
(on-start (send! (x 'first)))
|
||||
(on (message (x 'first))
|
||||
(spec 'ping))))
|
||||
(spec 'ping)))
|
||||
|
||||
(actor (forever (on (message (x $v))
|
||||
(printf "- ~v\n" v))))
|
||||
(actor (on (message (x $v))
|
||||
(printf "- ~v\n" v)))
|
||||
|
|
|
|||
|
|
@ -17,10 +17,9 @@
|
|||
(struct foo (x y) #:prefab)
|
||||
|
||||
(actor (field [x 123])
|
||||
(react
|
||||
(assert (foo (x) 999))
|
||||
(during (foo (x) $v)
|
||||
(log-info "x=~a v=~a" (x) v)
|
||||
(when (= (x) 123) (x 124))
|
||||
(on-stop
|
||||
(log-info "finally for x=~a v=~a" (x) v)))))
|
||||
(log-info "finally for x=~a v=~a" (x) v))))
|
||||
|
|
|
|||
|
|
@ -5,8 +5,7 @@
|
|||
(struct ready (what) #:prefab)
|
||||
(struct entry (key val) #:prefab)
|
||||
|
||||
(actor (react
|
||||
(assert (ready 'listener))
|
||||
(actor (assert (ready 'listener))
|
||||
(on (asserted (entry $key _))
|
||||
(log-info "key ~v asserted" key)
|
||||
(until (retracted (entry key _))
|
||||
|
|
@ -14,16 +13,15 @@
|
|||
(log-info "add binding: ~v -> ~v" key value))
|
||||
(on (retracted (entry key $value))
|
||||
(log-info "del binding: ~v -> ~v" key value)))
|
||||
(log-info "key ~v retracted" key))))
|
||||
(log-info "key ~v retracted" key)))
|
||||
|
||||
(actor (react
|
||||
(assert (ready 'other-listener))
|
||||
(actor (assert (ready 'other-listener))
|
||||
(during (entry $key _)
|
||||
(log-info "(other-listener) key ~v asserted" key)
|
||||
(on-stop (log-info "(other-listener) key ~v retracted" key))
|
||||
(during (entry 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)
|
||||
(log-info "pause")
|
||||
|
|
@ -31,7 +29,7 @@
|
|||
(until (asserted (ready token))
|
||||
(assert (ready token))))
|
||||
|
||||
(actor (until (asserted (ready 'listener)))
|
||||
(actor* (until (asserted (ready 'listener)))
|
||||
(until (asserted (ready 'other-listener)))
|
||||
(assert! (entry 'a 1))
|
||||
(assert! (entry 'a 2))
|
||||
|
|
|
|||
|
|
@ -24,13 +24,13 @@
|
|||
(struct outer (v) #:prefab)
|
||||
(struct show () #:prefab)
|
||||
|
||||
(actor (react (field [v "first"])
|
||||
(actor (field [v "first"])
|
||||
(assert (outer (v)))
|
||||
(assert (show))
|
||||
(on (message 2)
|
||||
(v "second"))))
|
||||
(v "second")))
|
||||
|
||||
(actor (react (on-start (send! 1))
|
||||
(actor (on-start (send! 1))
|
||||
(during (outer $v)
|
||||
(on-start (log-info "+outer ~v" v))
|
||||
(on-stop (log-info "-outer ~v" v))
|
||||
|
|
@ -38,4 +38,4 @@
|
|||
(on-start (log-info "+show"))
|
||||
(on-stop (log-info "-show"))))
|
||||
(on (message 1)
|
||||
(send! 2))))
|
||||
(send! 2)))
|
||||
|
|
|
|||
|
|
@ -4,7 +4,6 @@
|
|||
(require/activate syndicate/drivers/timer)
|
||||
|
||||
(actor
|
||||
(react
|
||||
(during/actor (observe `(fib ,$n ,_))
|
||||
#:actor actor/thread
|
||||
(on-start (log-info "Computing fib ~a..." n))
|
||||
|
|
@ -22,7 +21,7 @@
|
|||
(f (- n 2)))))))
|
||||
(if (= n 36)
|
||||
(error 'fib "Deliberate, hardcoded failure for n=36")
|
||||
answer)))))))))
|
||||
answer))))))))
|
||||
|
||||
(dataspace/thread
|
||||
(actor
|
||||
|
|
@ -30,10 +29,10 @@
|
|||
(define (arm!)
|
||||
(log-info "Tick ~v!" (tick-count))
|
||||
(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))
|
||||
(arm!))
|
||||
(on-start (arm!))))
|
||||
(on-start (arm!)))
|
||||
|
||||
(field [counter 0])
|
||||
(react
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
(require/activate "fs-shell.rkt")
|
||||
(require/activate "fs-protocol.rkt")
|
||||
|
||||
(actor (react (field [files (hash)])
|
||||
(actor (field [files (hash)])
|
||||
(during (observe (file $name _))
|
||||
(on-start (printf "At least one reader exists for ~v\n" name))
|
||||
(on-stop (printf "No remaining readers exist for ~v\n" name))
|
||||
|
|
@ -14,4 +14,4 @@
|
|||
(on (message (save (file name $new-content))) (content new-content))
|
||||
(on (message (delete name)) (content #f)))
|
||||
(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))))
|
||||
|
|
|
|||
|
|
@ -5,10 +5,10 @@
|
|||
(require/activate "fs-shell.rkt")
|
||||
(require/activate "fs-protocol.rkt")
|
||||
|
||||
(actor (react (field [files (hash)])
|
||||
(actor (field [files (hash)])
|
||||
(during (observe (file $name _))
|
||||
(on-start (printf "At least one reader exists for ~v\n" name))
|
||||
(assert (file name (hash-ref (files) name #f)))
|
||||
(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 (delete $name)) (files (hash-remove (files) name)))))
|
||||
(on (message (delete $name)) (files (hash-remove (files) name))))
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
(require/activate "fs-shell.rkt")
|
||||
(require/activate "fs-protocol.rkt")
|
||||
|
||||
(actor (react (field [files (hash)])
|
||||
(actor (field [files (hash)])
|
||||
(on (asserted (observe (file $name _)))
|
||||
(printf "At least one reader exists for ~v\n" name)
|
||||
(until (retracted (observe (file name _)))
|
||||
|
|
@ -15,4 +15,4 @@
|
|||
(on (message (delete name)) (content #f)))
|
||||
(printf "No remaining readers exist for ~v\n" name))
|
||||
(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))))
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
(require/activate "fs-protocol.rkt")
|
||||
(require racket/set)
|
||||
|
||||
(actor (react (field [files (hash)] [monitored (set)])
|
||||
(actor (field [files (hash)] [monitored (set)])
|
||||
(on (asserted (observe (file $name _)))
|
||||
(printf "At least one reader exists for ~v\n" name)
|
||||
(assert! (file name (hash-ref (files) name #f)))
|
||||
|
|
@ -24,4 +24,4 @@
|
|||
(when (set-member? (monitored) name)
|
||||
(retract! (file name (hash-ref (files) name #f)))
|
||||
(assert! (file name #f)))
|
||||
(files (hash-remove (files) name)))))
|
||||
(files (hash-remove (files) name))))
|
||||
|
|
|
|||
|
|
@ -1,17 +1,17 @@
|
|||
#lang syndicate/actor
|
||||
;; Minimal syndicate/actor variation on examples/forward-chaining.rkt.
|
||||
|
||||
(actor (react (assert `(parent john douglas))))
|
||||
(actor (react (assert `(parent bob john))))
|
||||
(actor (react (assert `(parent ebbon bob))))
|
||||
(actor (assert `(parent john douglas)))
|
||||
(actor (assert `(parent bob john)))
|
||||
(actor (assert `(parent ebbon bob)))
|
||||
|
||||
;; This looks like an implication:
|
||||
;; (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))
|
||||
(during `(ancestor ,C ,$B)
|
||||
(assert `(ancestor ,A ,B))))))
|
||||
(assert `(ancestor ,A ,B)))))
|
||||
|
||||
(actor (react (on (asserted `(ancestor ,$A ,$B))
|
||||
(log-info "~a is an ancestor of ~a" A B))))
|
||||
(actor (on (asserted `(ancestor ,$A ,$B))
|
||||
(log-info "~a is an ancestor of ~a" A B)))
|
||||
|
|
|
|||
|
|
@ -18,21 +18,21 @@
|
|||
(printf "> ")
|
||||
(flush-output))
|
||||
(actor (field [reader-count 0])
|
||||
(print-prompt)
|
||||
(until (message (inbound (external-event e (list (? eof-object? _)))))
|
||||
(on-start (print-prompt))
|
||||
(stop-when (message (inbound (external-event e (list (? eof-object? _))))))
|
||||
(on (message (inbound (external-event e (list (? bytes? $bs)))))
|
||||
(match (string-split (string-trim (bytes->string/utf-8 bs)))
|
||||
[(list "open" name)
|
||||
(define reader-id (reader-count))
|
||||
(reader-count (+ (reader-count) 1))
|
||||
(actor (printf "Reader ~a opening file ~v.\n" reader-id name)
|
||||
(until (message `(stop-watching ,name))
|
||||
(actor (on-start (printf "Reader ~a opening file ~v.\n" reader-id name))
|
||||
(stop-when (message `(stop-watching ,name)))
|
||||
(on (asserted (file name $contents))
|
||||
(printf "Reader ~a sees that ~v contains: ~v\n"
|
||||
reader-id
|
||||
name
|
||||
contents)))
|
||||
(printf "Reader ~a closing file ~v.\n" reader-id name))]
|
||||
contents))
|
||||
(on-stop (printf "Reader ~a closing file ~v.\n" reader-id name)))]
|
||||
[(list "close" name)
|
||||
(send! `(stop-watching ,name))]
|
||||
[(list* "write" name words)
|
||||
|
|
@ -46,4 +46,4 @@
|
|||
(printf " write filename some text goes here\n")
|
||||
(printf " delete filename\n")])
|
||||
(sleep 0.1)
|
||||
(print-prompt)))))
|
||||
(print-prompt))))
|
||||
|
|
|
|||
|
|
@ -3,15 +3,15 @@
|
|||
(struct echo-req (body) #:prefab)
|
||||
(struct echo-resp (body) #:prefab)
|
||||
|
||||
(actor (react (field [count 0])
|
||||
(actor (field [count 0])
|
||||
(on (message (echo-req $body))
|
||||
(send! (echo-resp body))
|
||||
(count (+ (count) 1)))))
|
||||
(count (+ (count) 1))))
|
||||
|
||||
(actor (react (on (message (echo-resp $body))
|
||||
(printf "Received: ~v\n" body))))
|
||||
(actor (on (message (echo-resp $body))
|
||||
(printf "Received: ~v\n" body)))
|
||||
|
||||
(actor (until (asserted (observe (echo-req _))))
|
||||
(actor* (until (asserted (observe (echo-req _))))
|
||||
(until (asserted (observe (echo-resp _))))
|
||||
(send! (echo-req 0))
|
||||
(send! (echo-req 1))
|
||||
|
|
|
|||
|
|
@ -9,8 +9,7 @@
|
|||
(struct resource-status (resource-id waiter-count) #:prefab)
|
||||
|
||||
(define (spawn-resource resource-id total-available-leases)
|
||||
(actor
|
||||
(react (field [waiters (make-queue)]
|
||||
(actor (field [waiters (make-queue)]
|
||||
[free-lease-count total-available-leases])
|
||||
|
||||
(begin/dataflow (log-info "~as available: ~a" resource-id (free-lease-count)))
|
||||
|
|
@ -39,7 +38,7 @@
|
|||
[else
|
||||
(define-values (w remainder) (dequeue (waiters)))
|
||||
(assert! (lease-assignment resource-id w))
|
||||
(waiters remainder)])))))
|
||||
(waiters remainder)]))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -47,14 +46,13 @@
|
|||
|
||||
(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
|
||||
(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)
|
||||
(actor
|
||||
(react (field [status 'starting])
|
||||
(actor (field [status 'starting])
|
||||
(assert (philosopher-status name (status)))
|
||||
|
||||
(stop-when (rising-edge (eq? (status) 'inspired)))
|
||||
|
|
@ -82,7 +80,7 @@
|
|||
(send! (set-timer name (* eating-duration 1000.0) 'relative)))
|
||||
(stop-when (message (timer-expired name _))
|
||||
(log-info "~a finishes eating and puts down the fork" name)
|
||||
(loop))))))))))
|
||||
(loop)))))))))
|
||||
|
||||
(spawn-resource 'fork 2)
|
||||
(philosopher 'Socrates)
|
||||
|
|
|
|||
|
|
@ -33,14 +33,13 @@
|
|||
(define p-at-spawn-time (p))
|
||||
(actor #:name (list 'spawn-one p-at-spawn-time)
|
||||
(define p-at-start-time (p))
|
||||
(react
|
||||
(assert `(p-at-spawn-time ,p-at-spawn-time))
|
||||
(assert `(p-at-start-time ,p-at-start-time))
|
||||
(assert `(p ,(p)))
|
||||
(on (message 'survey)
|
||||
(send! `(survey-response ,(p)))))))
|
||||
(send! `(survey-response ,(p))))))
|
||||
|
||||
(actor
|
||||
(actor*
|
||||
(spawn-one)
|
||||
(parameterize ((p 'first)) (spawn-one))
|
||||
(parameterize ((p 'second)) (spawn-one))
|
||||
|
|
|
|||
|
|
@ -3,7 +3,6 @@
|
|||
(require racket/set)
|
||||
|
||||
(actor #:name 'queryer
|
||||
(forever
|
||||
(define/query-value as-value 'absent `(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)
|
||||
|
|
@ -41,9 +40,9 @@
|
|||
(for [((k vs) (in-hash (as-hash-set)))]
|
||||
(printf " ~v -> ~v\n" k vs))
|
||||
(printf "----------------------------------------\n")
|
||||
(flush-output))))
|
||||
(flush-output)))
|
||||
|
||||
(actor #:name 'mutator
|
||||
(actor* #:name 'mutator
|
||||
(until (asserted 'observer-in-ds-ready))
|
||||
(assert! `(item a 1))
|
||||
(assert! `(item b 2))
|
||||
|
|
@ -62,10 +61,9 @@
|
|||
(log-info "Inner level anchor: ~a" (level-anchor))
|
||||
(log-info "Computed meta-level: ~v" LEVEL)
|
||||
(actor #:name 'observer-in-ds
|
||||
(forever
|
||||
(assert (outbound* LEVEL 'observer-in-ds-ready))
|
||||
(on-start (log-info "observer-in-ds: STARTING"))
|
||||
(define/query-set items (inbound* LEVEL `(item ,$a ,$b)) (list a b))
|
||||
(on (message (inbound* LEVEL 'dump))
|
||||
(log-info "observer-in-ds: ~v" (items)))))
|
||||
(log-info "observer-in-ds: ~v" (items))))
|
||||
(forever)))
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@
|
|||
;; EFFECT: Spawn a queue process named `queue-id`.
|
||||
(define (spawn-queue queue-id)
|
||||
(actor #:name (list 'queue queue-id)
|
||||
(react (field [waiters (make-queue)])
|
||||
(field [waiters (make-queue)])
|
||||
(field [messages (make-queue)])
|
||||
|
||||
(define/query-set subscribers (subscription queue-id $who) who
|
||||
|
|
@ -76,29 +76,29 @@
|
|||
`((has-waiters? ,has-waiters?)
|
||||
(has-messages? ,has-messages?)
|
||||
(waiters ,(queue->list (waiters)))
|
||||
(messages ,(queue->list (messages))))))))))
|
||||
(messages ,(queue->list (messages)))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Example
|
||||
|
||||
(define (spawn-consumer consumer-id #:variant [variant 'normal])
|
||||
(actor #:name (list 'consumer consumer-id)
|
||||
(react (assert (subscription 'q consumer-id))
|
||||
(assert (subscription 'q consumer-id))
|
||||
(on (message (delivery 'q consumer-id $body))
|
||||
(log-info "Consumer ~a got: ~a" consumer-id body)
|
||||
(when (eq? variant 'crashy)
|
||||
(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)
|
||||
(begin/dataflow (log-info " ~a" (hash->list (metrics))))))
|
||||
(actor (define/query-hash metrics (metric $k $v) k v)
|
||||
(begin/dataflow (log-info " ~a" (hash->list (metrics)))))
|
||||
|
||||
(spawn-queue 'q)
|
||||
(spawn-consumer 'c1)
|
||||
(spawn-consumer 'c2 #:variant 'crashy)
|
||||
(spawn-consumer 'c3)
|
||||
|
||||
(actor (until (asserted (observe (delivery _ 'q _))))
|
||||
(actor* (until (asserted (observe (delivery _ 'q _))))
|
||||
(for ((n (in-range 10)))
|
||||
(send! (delivery #f 'q n))
|
||||
;; (flush!)
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@
|
|||
;; EFFECT: Spawn a queue process named `queue-id`.
|
||||
(define (spawn-queue queue-id)
|
||||
(actor #:name (list 'queue queue-id)
|
||||
(react (field [waiters (make-queue)])
|
||||
(field [waiters (make-queue)])
|
||||
(field [messages (make-queue)])
|
||||
|
||||
(on (asserted (subscription queue-id $who)) (enq! waiters who))
|
||||
|
|
@ -74,29 +74,29 @@
|
|||
`((has-waiters? ,has-waiters?)
|
||||
(has-messages? ,has-messages?)
|
||||
(waiters ,(queue->list (waiters)))
|
||||
(messages ,(queue->list (messages))))))))))
|
||||
(messages ,(queue->list (messages)))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Example
|
||||
|
||||
(define (spawn-consumer consumer-id #:variant [variant 'normal])
|
||||
(actor #:name (list 'consumer consumer-id)
|
||||
(react (assert (subscription 'q consumer-id))
|
||||
(assert (subscription 'q consumer-id))
|
||||
(on (message (delivery 'q consumer-id $body))
|
||||
(log-info "Consumer ~a got: ~a" consumer-id body)
|
||||
(when (eq? variant 'crashy)
|
||||
(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)
|
||||
(begin/dataflow (log-info " ~a" (hash->list (metrics))))))
|
||||
(actor (define/query-hash metrics (metric $k $v) k v)
|
||||
(begin/dataflow (log-info " ~a" (hash->list (metrics)))))
|
||||
|
||||
(spawn-queue 'q)
|
||||
(spawn-consumer 'c1)
|
||||
(spawn-consumer 'c2 #:variant 'crashy)
|
||||
(spawn-consumer 'c3)
|
||||
|
||||
(actor (until (asserted (observe (delivery _ 'q _))))
|
||||
(actor* (until (asserted (observe (delivery _ 'q _))))
|
||||
(for ((n (in-range 10)))
|
||||
(send! (delivery #f 'q n))
|
||||
(when (odd? n) (flush!))
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@
|
|||
;; EFFECT: Spawn a queue process named `queue-id`.
|
||||
(define (spawn-queue queue-id)
|
||||
(actor #:name (list 'queue queue-id)
|
||||
(react (field [waiters (make-queue)])
|
||||
(field [waiters (make-queue)])
|
||||
(field [messages (make-queue)])
|
||||
|
||||
(define/query-hash credits (subscription queue-id $who) who 0) ;; Start with no credit
|
||||
|
|
@ -94,14 +94,14 @@
|
|||
(total-credits ,total-credits)
|
||||
(waiters ,(queue->list (waiters)))
|
||||
(messages ,(queue->list (messages)))
|
||||
(credits ,(hash->list (credits))))))))))
|
||||
(credits ,(hash->list (credits)))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Example
|
||||
|
||||
(define (spawn-consumer consumer-id initial-credit #:variant [variant 'normal])
|
||||
(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 (message (delivery 'q consumer-id $body))
|
||||
(log-info "Consumer ~a got: ~a" consumer-id body)
|
||||
|
|
@ -112,17 +112,17 @@
|
|||
(error consumer-id
|
||||
"Hark, canst thou hear me? I will play the swan / and die in music.")]
|
||||
[(overloaded) ;; don't issue credit
|
||||
(void)])))))
|
||||
(void)]))))
|
||||
|
||||
(actor (react (define/query-hash metrics (metric $k $v) k v)
|
||||
(begin/dataflow (log-info " ~a" (hash->list (metrics))))))
|
||||
(actor (define/query-hash metrics (metric $k $v) k v)
|
||||
(begin/dataflow (log-info " ~a" (hash->list (metrics)))))
|
||||
|
||||
(spawn-queue 'q)
|
||||
(spawn-consumer 'c1 2)
|
||||
(spawn-consumer 'c2 2 #:variant 'crashy)
|
||||
(spawn-consumer 'c3 3 #:variant 'overloaded)
|
||||
|
||||
(actor (until (asserted (observe (delivery _ 'q _))))
|
||||
(actor* (until (asserted (observe (delivery _ 'q _))))
|
||||
(for ((n (in-range 10)))
|
||||
(send! (delivery #f 'q n))
|
||||
;; (flush!)
|
||||
|
|
|
|||
|
|
@ -2,14 +2,13 @@
|
|||
;; Demonstrates that fields may not be passed between actors.
|
||||
|
||||
(actor #:name 'reading-actor
|
||||
(react
|
||||
(on (message `(read-from ,$this-field))
|
||||
(log-info "Trying to read from ~a" this-field)
|
||||
(log-info "Read: ~a" (this-field))
|
||||
(send! `(read-successfully ,this-field)))))
|
||||
(send! `(read-successfully ,this-field))))
|
||||
|
||||
(actor #:name 'requesting-actor
|
||||
(field [a 123])
|
||||
(send! `(read-from ,a))
|
||||
(until (message `(read-successfully ,a)))
|
||||
(log-info "Done."))
|
||||
(on-start (send! `(read-from ,a)))
|
||||
(stop-when (message `(read-successfully ,a)))
|
||||
(on-stop (log-info "Done.")))
|
||||
|
|
|
|||
|
|
@ -3,7 +3,6 @@
|
|||
;; facet, but not the other way around.
|
||||
|
||||
(actor #:name 'reading-actor
|
||||
(react
|
||||
(field [top 123])
|
||||
(on (message `(read-from ,$this-field))
|
||||
(log-info "Trying to read from ~a" this-field)
|
||||
|
|
@ -18,4 +17,4 @@
|
|||
(until (message `(read-successfully ,top)))
|
||||
(send! `(read-from ,inner)) ;; Will cause a failure.
|
||||
(until (message `(read-successfully ,inner))) ;; Will never happen.
|
||||
(log-info "Done."))))))
|
||||
(log-info "Done.")))))
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
#lang syndicate/actor
|
||||
;; Demonstrates that fields may not be passed between sibling facets.
|
||||
|
||||
(actor (react
|
||||
(on (message `(read-from ,$this-field))
|
||||
(actor (on (message `(read-from ,$this-field))
|
||||
(log-info "Trying to read from ~a" this-field)
|
||||
(log-info "Read: ~a" (this-field))
|
||||
(send! `(read-successfully ,this-field))))
|
||||
(send! `(read-successfully ,this-field)))
|
||||
(on-start
|
||||
(react
|
||||
(field [a 123])
|
||||
(on-start
|
||||
(send! `(read-from ,a))
|
||||
(until (message `(read-successfully ,a)))
|
||||
(log-info "Done."))))
|
||||
(log-info "Done.")))))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#lang syndicate/actor
|
||||
;; Demonstrates that fields at actor scope are visible to facets.
|
||||
|
||||
(actor (field [x 123])
|
||||
(actor* (field [x 123])
|
||||
(react
|
||||
(on (message `(read-from ,$this-field))
|
||||
(log-info "Trying to read from ~a" this-field)
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@
|
|||
|
||||
(define (cell-expr->actor-expr name 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)]))
|
||||
(assert #:when (andmap non-void-field? (list ,@bindings))
|
||||
(cell ',name
|
||||
|
|
@ -34,25 +34,25 @@
|
|||
,expr)))
|
||||
,@(for/list [(b bindings)]
|
||||
`(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))
|
||||
;; (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)
|
||||
(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 ()
|
||||
(define cell-name (read))
|
||||
(if (eof-object? cell-name)
|
||||
(send-ground-message 'quit)
|
||||
(let ((new-expr (read)))
|
||||
(send-ground-message (set-cell cell-name new-expr))
|
||||
(loop)))))))
|
||||
(until (message (inbound 'quit))
|
||||
(on (message (inbound (set-cell $name $expr)))
|
||||
(send! (set-cell name expr)))))
|
||||
(loop))))))))
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@
|
|||
(define-syntax while-relevant-assert
|
||||
(syntax-rules ()
|
||||
[(_ P)
|
||||
(until (retracted (observe P))
|
||||
(begin (stop-when (retracted (observe P)))
|
||||
(assert P))]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -83,7 +83,7 @@
|
|||
;; 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
|
||||
"Candide" 34.95)]
|
||||
[next-order-id 10001483])
|
||||
|
|
@ -103,7 +103,7 @@
|
|||
;; We cannot sell a book we do not have, and we will not sell for less
|
||||
;; than our asking price.
|
||||
;;
|
||||
(while-relevant-assert (order title offer-price #f #f))]
|
||||
(react (while-relevant-assert (order title offer-price #f #f)))]
|
||||
|
||||
[else
|
||||
;; Allocate an order ID.
|
||||
|
|
@ -119,7 +119,7 @@
|
|||
;;
|
||||
(actor
|
||||
(while-relevant-assert
|
||||
(order title offer-price order-id "March 9th")))])))))
|
||||
(order title offer-price order-id "March 9th")))]))))
|
||||
|
||||
;; Serial SPLIT-PROPOSER
|
||||
;;
|
||||
|
|
@ -175,7 +175,7 @@
|
|||
(log-info "A learns that the split-proposal for ~v was rejected" title)
|
||||
(try-to-split (+ contribution (/ (- price contribution) 2)))))]))])]))
|
||||
|
||||
(actor (try-to-buy (list "Catch 22"
|
||||
(actor* (try-to-buy (list "Catch 22"
|
||||
"Encyclopaedia Brittannica"
|
||||
"Candide"
|
||||
"The Wind in the Willows")
|
||||
|
|
@ -184,9 +184,7 @@
|
|||
;; Serial SPLIT-DISPOSER
|
||||
;;
|
||||
(define (buyer-b)
|
||||
(actor (react
|
||||
|
||||
;; This actor maintains a record of the amount of money it has to spend.
|
||||
(actor ;; This actor maintains a record of the amount of money it has to spend.
|
||||
;;
|
||||
(field [funds 5.00])
|
||||
|
||||
|
|
@ -201,7 +199,7 @@
|
|||
(cond
|
||||
[(> my-contribution (funds))
|
||||
(log-info "B hasn't enough funds (~a remaining)" (funds))
|
||||
(while-relevant-assert (split-proposal title price their-contribution #f))]
|
||||
(react (while-relevant-assert (split-proposal title price their-contribution #f)))]
|
||||
|
||||
[else
|
||||
|
||||
|
|
@ -209,7 +207,7 @@
|
|||
;; 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)
|
||||
;; While we are in this state, waiting for order confirmation, take
|
||||
;; the opportunity to signal to our SPLIT-PROPOSER that we accepted
|
||||
|
|
@ -232,7 +230,7 @@
|
|||
(define remaining-funds (- (funds) my-contribution))
|
||||
(log-info "B accepts the offer, leaving them with ~a remaining funds"
|
||||
remaining-funds)
|
||||
(funds remaining-funds)])))))
|
||||
(funds remaining-funds)]))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,20 +6,18 @@
|
|||
(require net/url)
|
||||
|
||||
(actor #:name 'server
|
||||
(react
|
||||
(define vh (web-virtual-host "http" ? 9090))
|
||||
|
||||
(assert vh)
|
||||
|
||||
(on (web-request-incoming (id req) vh _ ("ws" ()))
|
||||
(actor
|
||||
(react
|
||||
(assert (web-response-websocket id))
|
||||
(stop-when (websocket-connection-closed id) (log-info "Connection dropped"))
|
||||
(stop-when (websocket-message-recv id "quit") (log-info "Received quit command"))
|
||||
(on (websocket-message-recv id $str)
|
||||
(log-info "Got ~v" str)
|
||||
(websocket-message-send! id str)))))
|
||||
(websocket-message-send! id str))))
|
||||
|
||||
(field [counter 0])
|
||||
(on (web-request-get (id req) vh ("foo" ,$path))
|
||||
|
|
@ -31,4 +29,4 @@
|
|||
(h1 "Hi there.")
|
||||
(p ,(format "Your path was ~v, and this is request ~a"
|
||||
path
|
||||
req-num))))))))
|
||||
req-num)))))))
|
||||
|
|
|
|||
|
|
@ -13,7 +13,6 @@
|
|||
(on-start (send! (set-timer timer-id (* sec 1000.0) 'relative)))))
|
||||
|
||||
(actor #:name 'server
|
||||
(react
|
||||
(field [counter 0])
|
||||
(assert vh)
|
||||
|
||||
|
|
@ -83,4 +82,4 @@
|
|||
(string->bytes/utf-8
|
||||
(format "Hi there. Your path was ~v, and this is request ~a"
|
||||
path
|
||||
req-num)))))))
|
||||
req-num))))))
|
||||
|
|
|
|||
|
|
@ -12,22 +12,22 @@
|
|||
(struct path-exists (from to) #:prefab) ;; Hmm.
|
||||
(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 3 3))
|
||||
(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 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)
|
||||
(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])
|
||||
(assert (min-cost from to (least)))
|
||||
(on (asserted (path from to $cost))
|
||||
|
|
@ -36,10 +36,10 @@
|
|||
(on (retracted (path from to $cost))
|
||||
(define new-costs (set-remove (costs) cost))
|
||||
(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)
|
||||
;; (on-start (displayln `(+ ,(path from to cost))))
|
||||
;; (on-stop (displayln `(- ,(path from to cost)))))))
|
||||
(actor (forever (on (asserted (min-cost $from $to $cost))
|
||||
(displayln (min-cost from to cost)))))
|
||||
(actor (during (path $from $to $cost)
|
||||
(on-start (displayln `(+ ,(path from to cost))))
|
||||
(on-stop (displayln `(- ,(path from to cost))))))
|
||||
(actor (on (asserted (min-cost $from $to $cost))
|
||||
(displayln (min-cost from to cost))))
|
||||
|
|
|
|||
|
|
@ -11,23 +11,23 @@
|
|||
(struct path-exists (from to) #:prefab) ;; Hmm.
|
||||
(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 3 3))
|
||||
(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 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)
|
||||
(assert #:when (not (set-member? seen A)) (path-exists A C))
|
||||
(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])
|
||||
(assert (min-cost from to (least)))
|
||||
(on (asserted (path from to _ $cost))
|
||||
|
|
@ -36,10 +36,10 @@
|
|||
(on (retracted (path from to _ $cost))
|
||||
(define new-costs (set-remove (costs) cost))
|
||||
(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-stop (displayln `(- ,(path from to seen cost)))))))
|
||||
(actor (forever (on (asserted (min-cost $from $to $cost))
|
||||
(displayln (min-cost from to cost)))))
|
||||
(on-stop (displayln `(- ,(path from to seen cost))))))
|
||||
(actor (on (asserted (min-cost $from $to $cost))
|
||||
(displayln (min-cost from to cost))))
|
||||
|
|
|
|||
|
|
@ -26,9 +26,8 @@
|
|||
|
||||
(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-loopback h #t))
|
||||
(on (message (udp-packet $source h $body))
|
||||
|
|
@ -37,4 +36,4 @@
|
|||
(rearm!)
|
||||
(send! (udp-packet h
|
||||
(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))))))
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@
|
|||
(define (generate-reader-id)
|
||||
(begin0 reader-count
|
||||
(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 _))
|
||||
(log-info "~a: local ~v :: remote ~v" c la ra))
|
||||
(on (message (inbound (external-event e (list (? bytes? $bs)))))
|
||||
|
|
@ -30,4 +30,4 @@
|
|||
(stop-when (message (inbound (external-event e (list (? eof-object? _)))))
|
||||
(printf "Local EOF. Terminating.\n"))
|
||||
(stop-when (retracted (advertise (websocket-message s c _)))
|
||||
(printf "Server disconnected.\n")))))
|
||||
(printf "Server disconnected.\n"))))
|
||||
|
|
|
|||
|
|
@ -9,18 +9,18 @@
|
|||
(define ssl-server-id (websocket-local-server 8084 (websocket-ssl-options "server-cert.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 _)))
|
||||
(handle-connection tcp-server-id c))))
|
||||
(actor (forever (assert (advertise (observe (websocket-message any-client ssl-server-id _))))
|
||||
(handle-connection tcp-server-id c)))
|
||||
(actor (assert (advertise (observe (websocket-message 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)
|
||||
(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 _))
|
||||
(log-info "~a: local ~v :: remote ~v" c la ra))
|
||||
(on (message (websocket-message c s $body))
|
||||
(log-info "~a: ~v" c body)
|
||||
(send! (websocket-message s c body))))
|
||||
(log-info "~a: disconnected" c)))
|
||||
(send! (websocket-message s c body)))
|
||||
(on-stop (log-info "~a: disconnected" c))))
|
||||
|
|
|
|||
|
|
@ -1,14 +1,15 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide spawn-threaded-actor
|
||||
actor/thread ;; \__ once dataspace is split into mux and relay, these two
|
||||
dataspace/thread) ;; / will be very thin convenience macros over a common impl.
|
||||
actor/thread ;; \__ once dataspace is split into mux and relay, these three
|
||||
actor*/thread ;; | will be very thin convenience macros over a common impl.
|
||||
dataspace/thread) ;; /
|
||||
|
||||
(require racket/match)
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(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/store)
|
||||
|
||||
|
|
@ -73,6 +74,12 @@
|
|||
(schedule-action!
|
||||
(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
|
||||
(syntax-rules ()
|
||||
[(_ body ...)
|
||||
|
|
|
|||
Loading…
Reference in New Issue