quit-world action
This commit is contained in:
parent
f5d331b0d8
commit
d7095c9995
|
@ -3,6 +3,7 @@
|
||||||
|
|
||||||
(provide (struct-out message)
|
(provide (struct-out message)
|
||||||
(except-out (struct-out quit) quit)
|
(except-out (struct-out quit) quit)
|
||||||
|
(struct-out quit-world)
|
||||||
(rename-out [quit <quit>])
|
(rename-out [quit <quit>])
|
||||||
(except-out (struct-out spawn) spawn)
|
(except-out (struct-out spawn) spawn)
|
||||||
(rename-out [spawn <spawn>])
|
(rename-out [spawn <spawn>])
|
||||||
|
@ -73,6 +74,7 @@
|
||||||
|
|
||||||
;; Actions ⊃ Events
|
;; Actions ⊃ Events
|
||||||
(struct spawn (boot) #:prefab)
|
(struct spawn (boot) #:prefab)
|
||||||
|
(struct quit-world () #:prefab) ;; NB. An action. Compare (quit), a Transition.
|
||||||
|
|
||||||
;; A Behavior is a ((Option Event) Any -> Transition): a function
|
;; A Behavior is a ((Option Event) Any -> Transition): a function
|
||||||
;; mapping an Event (or, in the #f case, a poll signal) and a
|
;; mapping an Event (or, in the #f case, a poll signal) and a
|
||||||
|
@ -115,7 +117,7 @@
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define (event? x) (or (patch? x) (message? x)))
|
(define (event? x) (or (patch? x) (message? x)))
|
||||||
(define (action? x) (or (event? x) (spawn? x)))
|
(define (action? x) (or (event? x) (spawn? x) (quit-world? x)))
|
||||||
|
|
||||||
(define (prepend-at-meta pattern level)
|
(define (prepend-at-meta pattern level)
|
||||||
(if (zero? level)
|
(if (zero? level)
|
||||||
|
@ -333,6 +335,8 @@
|
||||||
;; ^ behavior & state already removed by disable-process
|
;; ^ behavior & state already removed by disable-process
|
||||||
patches
|
patches
|
||||||
meta-action)]
|
meta-action)]
|
||||||
|
[(quit-world)
|
||||||
|
(make-quit)]
|
||||||
[(? patch? delta-orig)
|
[(? patch? delta-orig)
|
||||||
(define-values (new-mux _label patches meta-action)
|
(define-values (new-mux _label patches meta-action)
|
||||||
(mux-update-stream (world-mux w) label delta-orig))
|
(mux-update-stream (world-mux w) label delta-orig))
|
||||||
|
|
|
@ -0,0 +1,36 @@
|
||||||
|
#lang prospect
|
||||||
|
;; Demonstrates quit-world.
|
||||||
|
|
||||||
|
(require (only-in racket/port read-bytes-line-evt))
|
||||||
|
|
||||||
|
(define (spawn-command-listener)
|
||||||
|
(spawn (lambda (e s)
|
||||||
|
(match e
|
||||||
|
[(message (at-meta (at-meta (external-event _ (list #"quit")))))
|
||||||
|
(printf "Quitting just the leaf actor.\n")
|
||||||
|
(quit)]
|
||||||
|
[(message (at-meta (at-meta (external-event _ (list #"quit-world")))))
|
||||||
|
(printf "Terminating the whole network.\n")
|
||||||
|
(transition s (quit-world))]
|
||||||
|
[_ #f]))
|
||||||
|
(void)
|
||||||
|
(sub (external-event (read-bytes-line-evt (current-input-port) 'any) ?)
|
||||||
|
#:meta-level 2)))
|
||||||
|
|
||||||
|
(define (spawn-ticker)
|
||||||
|
(define (sub-to-alarm)
|
||||||
|
(sub (external-event (alarm-evt (+ (current-inexact-milliseconds) 1000)) ?) #:meta-level 2))
|
||||||
|
(spawn (lambda (e s)
|
||||||
|
(match e
|
||||||
|
[(message (at-meta (at-meta (external-event _ _))))
|
||||||
|
(printf "Tick!\n")
|
||||||
|
(transition s
|
||||||
|
(list (retract ?)
|
||||||
|
(sub-to-alarm)))]
|
||||||
|
[_ #f]))
|
||||||
|
(void)
|
||||||
|
(sub-to-alarm)))
|
||||||
|
|
||||||
|
(printf "Type 'quit' or 'quit-world'.\n")
|
||||||
|
(spawn-world (spawn-command-listener)
|
||||||
|
(spawn-ticker))
|
|
@ -171,6 +171,9 @@
|
||||||
(unless (matcher-empty? interests)
|
(unless (matcher-empty? interests)
|
||||||
(output "~a's final interests:\n" pidstr)
|
(output "~a's final interests:\n" pidstr)
|
||||||
(pretty-print-matcher interests (current-error-port))))]
|
(pretty-print-matcher interests (current-error-port))))]
|
||||||
|
[(quit-world)
|
||||||
|
(with-color BRIGHT-RED
|
||||||
|
(output "Process ~a performed a quit-world.\n" pidstr))]
|
||||||
[(? patch? p)
|
[(? patch? p)
|
||||||
(when (or show-actions? show-patch-actions?)
|
(when (or show-actions? show-patch-actions?)
|
||||||
(output "~a performing a patch:\n" pidstr)
|
(output "~a performing a patch:\n" pidstr)
|
||||||
|
@ -180,7 +183,7 @@
|
||||||
(output "~a sending a message:\n" pidstr)
|
(output "~a sending a message:\n" pidstr)
|
||||||
(pretty-write body (current-error-port)))])]
|
(pretty-write body (current-error-port)))])]
|
||||||
[('internal-action-result (list pids a old-w t))
|
[('internal-action-result (list pids a old-w t))
|
||||||
(when t
|
(when (transition? t)
|
||||||
(define new-w (transition-state t))
|
(define new-w (transition-state t))
|
||||||
(define pidstr (format-pids pids))
|
(define pidstr (format-pids pids))
|
||||||
(define newcount (hash-count (world-behaviors new-w)))
|
(define newcount (hash-count (world-behaviors new-w)))
|
||||||
|
|
Loading…
Reference in New Issue