Introduce make-spawn to capture parameterizations. Closes #10.
This commit is contained in:
parent
1fa50e4e6a
commit
4e1bab4b90
|
@ -914,10 +914,9 @@
|
||||||
;; LevelSpawner
|
;; LevelSpawner
|
||||||
|
|
||||||
(define (spawn-standalone-assertions . patches)
|
(define (spawn-standalone-assertions . patches)
|
||||||
(<spawn> (lambda ()
|
(spawn (lambda (e s) #f)
|
||||||
(list (lambda (e s) #f)
|
(void)
|
||||||
(transition (void) (patch-seq* patches))
|
patches))
|
||||||
#f))))
|
|
||||||
|
|
||||||
(define (spawn-background-image level-size scene)
|
(define (spawn-background-image level-size scene)
|
||||||
(match-define (vector level-width level-height) level-size)
|
(match-define (vector level-width level-height) level-size)
|
||||||
|
|
|
@ -269,7 +269,7 @@
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ name:name script ...)
|
[(_ name:name script ...)
|
||||||
(quasisyntax/loc stx
|
(quasisyntax/loc stx
|
||||||
(core:<spawn>
|
(core:make-spawn
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(list actor-behavior
|
(list actor-behavior
|
||||||
(boot-actor (lambda () (begin/void-default script ...)))
|
(boot-actor (lambda () (begin/void-default script ...)))
|
||||||
|
|
|
@ -45,6 +45,7 @@
|
||||||
unsub
|
unsub
|
||||||
|
|
||||||
(rename-out [make-quit quit])
|
(rename-out [make-quit quit])
|
||||||
|
make-spawn
|
||||||
(rename-out [spawn-process spawn])
|
(rename-out [spawn-process spawn])
|
||||||
spawn/stateless
|
spawn/stateless
|
||||||
|
|
||||||
|
@ -162,18 +163,32 @@
|
||||||
(define (make-quit #:exception [exn #f] . actions)
|
(define (make-quit #:exception [exn #f] . actions)
|
||||||
(quit exn actions))
|
(quit exn actions))
|
||||||
|
|
||||||
|
(define (make-spawn spawn-producing-thunk)
|
||||||
|
(spawn (let ((parameterization (current-parameterization)))
|
||||||
|
(lambda ()
|
||||||
|
(call-with-parameterization
|
||||||
|
parameterization
|
||||||
|
(lambda ()
|
||||||
|
(match (spawn-producing-thunk)
|
||||||
|
[(list (? procedure? raw-beh) (? general-transition? txn) name)
|
||||||
|
(list (lambda (e s)
|
||||||
|
(call-with-parameterization parameterization (lambda () (raw-beh e s))))
|
||||||
|
txn
|
||||||
|
name)]
|
||||||
|
[other other]))))))) ;; punt on error checking to dataspace boot code
|
||||||
|
|
||||||
(define-syntax spawn-process
|
(define-syntax spawn-process
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ #:name name-exp behavior-exp initial-state-exp initial-action-tree-exp)
|
[(_ #:name name-exp behavior-exp initial-state-exp initial-action-tree-exp)
|
||||||
(spawn (lambda ()
|
(make-spawn (lambda ()
|
||||||
(list behavior-exp
|
(list behavior-exp
|
||||||
(transition initial-state-exp initial-action-tree-exp)
|
(transition initial-state-exp initial-action-tree-exp)
|
||||||
name-exp)))]
|
name-exp)))]
|
||||||
[(_ behavior-exp initial-state-exp initial-action-tree-exp)
|
[(_ behavior-exp initial-state-exp initial-action-tree-exp)
|
||||||
(spawn (lambda ()
|
(make-spawn (lambda ()
|
||||||
(list behavior-exp
|
(list behavior-exp
|
||||||
(transition initial-state-exp initial-action-tree-exp)
|
(transition initial-state-exp initial-action-tree-exp)
|
||||||
#f)))]))
|
#f)))]))
|
||||||
|
|
||||||
(define-syntax spawn/stateless
|
(define-syntax spawn/stateless
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
|
|
|
@ -0,0 +1,57 @@
|
||||||
|
#lang syndicate/actor
|
||||||
|
;; Demonstrate use of parameters with actors.
|
||||||
|
;;
|
||||||
|
;; Per https://github.com/tonyg/syndicate/issues/10, "Parameters don't
|
||||||
|
;; work well with actors". Output from this program running against
|
||||||
|
;; buggy Syndicate:
|
||||||
|
;;
|
||||||
|
;; spawn-ps: (set)
|
||||||
|
;; start-ps: (set)
|
||||||
|
;; ps: (set)
|
||||||
|
;; start-ps: (set 'unset)
|
||||||
|
;; spawn-ps: (set 'second 'unset 'first)
|
||||||
|
;; ps: (set 'unset)
|
||||||
|
;; Survey-response: 'unset
|
||||||
|
;; Survey-response: 'unset
|
||||||
|
;; Survey-response: 'unset
|
||||||
|
;;
|
||||||
|
;; ... and against a fixed Syndicate:
|
||||||
|
;;
|
||||||
|
;; spawn-ps: (set)
|
||||||
|
;; start-ps: (set)
|
||||||
|
;; ps: (set)
|
||||||
|
;; start-ps: (set 'second 'unset 'first)
|
||||||
|
;; spawn-ps: (set 'second 'unset 'first)
|
||||||
|
;; ps: (set 'second 'unset 'first)
|
||||||
|
;; Survey-response: 'unset
|
||||||
|
;; Survey-response: 'first
|
||||||
|
;; Survey-response: 'second
|
||||||
|
|
||||||
|
(define p (make-parameter 'unset))
|
||||||
|
|
||||||
|
(define (spawn-one)
|
||||||
|
(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)))))))
|
||||||
|
|
||||||
|
(actor
|
||||||
|
(spawn-one)
|
||||||
|
(parameterize ((p 'first)) (spawn-one))
|
||||||
|
(parameterize ((p 'second)) (spawn-one))
|
||||||
|
(flush!)
|
||||||
|
(until (asserted (observe 'survey)))
|
||||||
|
(react (on-start (send! 'survey))
|
||||||
|
(define/query-set spawn-ps `(p-at-spawn-time ,$v) v)
|
||||||
|
(define/query-set start-ps `(p-at-start-time ,$v) v)
|
||||||
|
(define/query-set ps `(p ,$v) v)
|
||||||
|
(begin/dataflow (printf "spawn-ps: ~v\n" (spawn-ps)))
|
||||||
|
(begin/dataflow (printf "start-ps: ~v\n" (start-ps)))
|
||||||
|
(begin/dataflow (printf "ps: ~v\n" (ps)))
|
||||||
|
(on (message `(survey-response ,$v))
|
||||||
|
(printf "Survey-response: ~v\n" v))))
|
|
@ -122,17 +122,17 @@
|
||||||
(define-syntax spawn-monolithic
|
(define-syntax spawn-monolithic
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ #:name name-exp behavior-exp initial-state-exp initial-action-tree-exp)
|
[(_ #:name name-exp behavior-exp initial-state-exp initial-action-tree-exp)
|
||||||
(<spawn> (lambda ()
|
(make-spawn (lambda ()
|
||||||
(list (wrap-monolithic-behaviour behavior-exp)
|
(list (wrap-monolithic-behaviour behavior-exp)
|
||||||
(differentiate-outgoing (wrap-monolithic-state initial-state-exp)
|
(differentiate-outgoing (wrap-monolithic-state initial-state-exp)
|
||||||
(clean-actions initial-action-tree-exp))
|
(clean-actions initial-action-tree-exp))
|
||||||
name-exp)))]
|
name-exp)))]
|
||||||
[(_ behavior-exp initial-state-exp initial-action-tree-exp)
|
[(_ behavior-exp initial-state-exp initial-action-tree-exp)
|
||||||
(<spawn> (lambda ()
|
(make-spawn (lambda ()
|
||||||
(list (wrap-monolithic-behaviour behavior-exp)
|
(list (wrap-monolithic-behaviour behavior-exp)
|
||||||
(differentiate-outgoing (wrap-monolithic-state initial-state-exp)
|
(differentiate-outgoing (wrap-monolithic-state initial-state-exp)
|
||||||
(clean-actions initial-action-tree-exp))
|
(clean-actions initial-action-tree-exp))
|
||||||
#f)))]))
|
#f)))]))
|
||||||
|
|
||||||
(define-syntax spawn-monolithic/stateless
|
(define-syntax spawn-monolithic/stateless
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
|
|
|
@ -90,19 +90,20 @@
|
||||||
inbound-constructor
|
inbound-constructor
|
||||||
inbound-parenthesis
|
inbound-parenthesis
|
||||||
inner-spawn)
|
inner-spawn)
|
||||||
(<spawn> (lambda ()
|
(make-spawn (lambda ()
|
||||||
(define-values (proc initial-transition) (spawn->process+transition inner-spawn))
|
(define-values (proc initial-transition) (spawn->process+transition inner-spawn))
|
||||||
(define initial-relay-state (relay outbound?
|
(define initial-relay-state (relay outbound?
|
||||||
outbound-assertion
|
outbound-assertion
|
||||||
outbound-parenthesis
|
outbound-parenthesis
|
||||||
inbound-constructor
|
inbound-constructor
|
||||||
inbound-parenthesis
|
inbound-parenthesis
|
||||||
proc))
|
proc))
|
||||||
(list relay-handle-event
|
(list relay-handle-event
|
||||||
(relay-transition (transition-bind (inject-relay-subscription initial-relay-state)
|
(relay-transition
|
||||||
initial-transition)
|
(transition-bind (inject-relay-subscription initial-relay-state)
|
||||||
initial-relay-state)
|
initial-transition)
|
||||||
(process-name proc)))))
|
initial-relay-state)
|
||||||
|
(process-name proc)))))
|
||||||
|
|
||||||
(define (pretty-print-relay r p)
|
(define (pretty-print-relay r p)
|
||||||
(fprintf p "RELAY ~a/~a\n"
|
(fprintf p "RELAY ~a/~a\n"
|
||||||
|
|
|
@ -27,17 +27,17 @@
|
||||||
#f]))
|
#f]))
|
||||||
|
|
||||||
(define (spawn-threaded-actor spawn-action-thunk)
|
(define (spawn-threaded-actor spawn-action-thunk)
|
||||||
(<spawn> (lambda ()
|
(make-spawn (lambda ()
|
||||||
(define path (current-actor-path))
|
(define path (current-actor-path))
|
||||||
(define thd (thread (lambda () (run-thread path spawn-action-thunk))))
|
(define thd (thread (lambda () (run-thread path spawn-action-thunk))))
|
||||||
(thread (lambda ()
|
(thread (lambda ()
|
||||||
(sync (thread-dead-evt thd))
|
(sync (thread-dead-evt thd))
|
||||||
(send-ground-message (thread-quit #f '()) #:path path)
|
(send-ground-message (thread-quit #f '()) #:path path)
|
||||||
(signal-background-activity! #f)))
|
(signal-background-activity! #f)))
|
||||||
(signal-background-activity! #t)
|
(signal-background-activity! #t)
|
||||||
(list proxy-behaviour
|
(list proxy-behaviour
|
||||||
(transition (proxy-state thd) '())
|
(transition (proxy-state thd) '())
|
||||||
'threaded-proxy))))
|
'threaded-proxy))))
|
||||||
|
|
||||||
(define (run-thread actor-path spawn-action-thunk)
|
(define (run-thread actor-path spawn-action-thunk)
|
||||||
(define actor-path-rev (reverse actor-path))
|
(define actor-path-rev (reverse actor-path))
|
||||||
|
|
Loading…
Reference in New Issue