X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=demos%2Factors%2Frobotscanner.scm;h=7ed6dd2f23c0c5dd9eabecc7d87a5cd6222aef6c;hp=89088c61f1220975ad8aec1e3cc6ce2688d315c0;hb=4998e7a9fe3b303923d918cd6087633d5302274f;hpb=c55d6d2f064f298152b43564df61150e27a2a1c7 diff --git a/demos/actors/robotscanner.scm b/demos/actors/robotscanner.scm index 89088c6..7ed6dd2 100644 --- a/demos/actors/robotscanner.scm +++ b/demos/actors/robotscanner.scm @@ -1,5 +1,5 @@ ;;; 8sync --- Asynchronous programming for Guile -;;; Copyright (C) 2016 Christopher Allan Webber +;;; Copyright © 2016, 2017 Christopher Allan Webber ;;; ;;; This file is part of 8sync. ;;; @@ -33,7 +33,7 @@ ;;; reporting info back to the user.) ;;; ===================================================================== -(use-modules (8sync systems actors) +(use-modules (8sync actors) (oop goops) (ice-9 match)) @@ -47,66 +47,62 @@ (5 0) (2 1))) -(define-simple-actor - (init-world - (lambda (actor message) - ;; Porting mostly straight up from super-imperative XUDD code. - (define previous-room #f) - (define first-room #f) - - ;; Set up all rooms - (for-each - (match-lambda - ((clean-droids infected-droids) - ;; Create this room - (define room (create-actor* actor "room")) - (define* (init-droid #:key infected) - (define droid (create-actor* actor "droid" - #:infected infected - #:room room)) - (send-message-wait actor droid - 'register-with-room)) - - ;; Link rooms. - ;; Couldn't this just be folded into the warehouse room init? - ;; I guess it stress tests more the message sending process - (when previous-room - (send-message actor previous-room - 'set-next-room - #:id room) - (send-message actor room - 'set-previous-room - #:id previous-room)) - - ;; Set up clean droids in the room - (for-each - (lambda _ - (init-droid #:infected #f)) - (iota clean-droids)) - - ;; Set up infected droids in the room - (for-each - (lambda _ - (init-droid #:infected #t)) - (iota clean-droids)) - - (set! previous-room room) - (if (not first-room) - (set! first-room room)))) - room-structure) - - ;; Add security robot - (let ((security-robot - (create-actor actor ))) - (send-message actor security-robot - 'begin-mission - #:starting-room first-room - #:overseer (actor-id actor))))) - - (transmission - (lambda (actor message) - (display (message-ref message 'message)) - (newline)))) +(define-actor () + ((init-world + (lambda (actor message) + ;; Porting mostly straight up from super-imperative XUDD code. + (define previous-room #f) + (define first-room #f) + + ;; Set up all rooms + (for-each + (match-lambda + ((clean-droids infected-droids) + ;; Create this room + (define room (create-actor* actor "room")) + (define* (init-droid #:key infected) + (define droid (create-actor* actor "droid" + #:infected infected + #:room room)) + (<-wait droid 'register-with-room)) + + ;; Link rooms. + ;; Couldn't this just be folded into the warehouse room init? + ;; I guess it stress tests more the message sending process + (when previous-room + (<- previous-room 'set-next-room + #:id room) + (<- room 'set-previous-room + #:id previous-room)) + + ;; Set up clean droids in the room + (for-each + (lambda _ + (init-droid #:infected #f)) + (iota clean-droids)) + + ;; Set up infected droids in the room + (for-each + (lambda _ + (init-droid #:infected #t)) + (iota clean-droids)) + + (set! previous-room room) + (if (not first-room) + (set! first-room room)))) + room-structure) + + ;; Add security robot + (let ((security-robot + (create-actor actor ))) + (<- security-robot 'begin-mission + #:starting-room first-room + #:overseer (actor-id actor))))) + + (transmission + (lambda* (actor message #:key text) + (display text) + (newline))))) ;;; A room full of robots. @@ -115,39 +111,42 @@ (next-room #:init-value #f) (previous-room #:init-value #f) - (message-handler + (actions + #:allocation #:each-subclass #:init-value - (make-action-dispatch - ((set-next-room actor message) - "Set the room following this" - (slot-set! actor 'next-room - (message-ref message 'id))) - - ((set-previous-room actor message) - "Set the room previous to this" - (slot-set! actor 'previous-room - (message-ref message 'id))) - - ((get-next-room actor message) - "Return a reference to the link following this" - (reply-message actor message - #:id (slot-ref actor 'next-room))) - - ((get-previous-room actor message) - "Return a reference to the link preceding this" - (reply-message actor message - #:id (slot-ref actor 'previous-room))) - - ((list-droids actor message) - "Return a list of all the droid ids we know of in this room" - (reply-message actor message - #:droid-ids (slot-ref actor 'droids))) - - ((register-droid actor message) - "Register a droid as being in this room" - (slot-set! actor 'droids - (cons (message-ref message 'droid-id) - (slot-ref actor 'droids))))))) + (build-actions + (set-next-room + (lambda* (actor message #:key id) + "Set the room following this" + (slot-set! actor 'next-room id))) + + (set-previous-room + (lambda* (actor message #:key id) + "Set the room previous to this" + (slot-set! actor 'previous-room id))) + + (get-next-room + (lambda (actor message) + "Return a reference to the link following this" + (<-reply message (slot-ref actor 'next-room)))) + + (get-previous-room + (lambda (actor message) + "Return a reference to the link preceding this" + (<-reply message (slot-ref actor 'previous-room)))) + + (list-droids + (lambda (actor message) + "Return a list of all the droid ids we know of in this room" + (<-reply message + #:droid-ids (slot-ref actor 'droids)))) + + (register-droid + (lambda* (actor message #:key droid-id) + "Register a droid as being in this room" + (slot-set! actor 'droids + (cons droid-id + (slot-ref actor 'droids)))))))) ;;; A droid that may or may not be infected! @@ -157,113 +156,112 @@ (room #:init-keyword #:room) (hp #:init-value 50) - (message-handler + (actions + #:allocation #:each-subclass #:init-value - (make-action-dispatch - ((register-with-room actor message) - "Register ourselves as being in a room" - (let ((room-id (slot-ref actor 'room))) - (send-message-wait actor room-id - 'register-droid - #:droid-id (actor-id actor)) - (format #t "Droid ~a registered with room ~a\n" - (actor-id-actor actor) - (address-actor-id room-id)))) - - ((infection-expose actor message) - "Leak whether or not we're infected to a security droid" - (reply-message actor message - #:is-infected #t)) - - ((get-shot actor message) - "Get shot by bullets" - (let* ((damage (random 60)) - (new-hp (- (slot-ref actor 'hp) damage)) - (alive (> new-hp 0))) - ;; Set our health to the new value - (slot-set! actor 'hp new-hp) - (reply-message actor message - #:hp-left new-hp - #:damage-taken damage - #:alive alive) - (when (not alive) - (format #t "~a: *Kaboom!*\n" (actor-id-actor actor)) - (self-destruct actor))))))) + (build-actions + (register-with-room + (lambda (actor message) + "Register ourselves as being in a room" + (let ((room-id (slot-ref actor 'room))) + (<-wait room-id 'register-droid + #:droid-id (actor-id actor)) + (format #t "Droid ~a registered with room ~a\n" + (actor-id-actor actor) + (address-actor-id room-id))))) + + (infection-expose + (lambda (actor message) + "Leak whether or not we're infected to a security droid" + (<-reply message (slot-ref actor 'infected)))) + + (get-shot + (lambda (actor message) + "Get shot by bullets" + (let* ((damage (random 60)) + (new-hp (- (slot-ref actor 'hp) damage)) + (alive (> new-hp 0))) + ;; Set our health to the new value + (slot-set! actor 'hp new-hp) + (<-reply message + #:hp-left new-hp + #:damage-taken damage + #:alive alive) + (when (not alive) + (format #t "~a: *Kaboom!*\n" (actor-id-actor actor)) + (self-destruct actor)))))))) (define (droid-status-format shot-response) - (if (message-ref shot-response 'alive) - (format #f "Droid ~a shot; taken ~a damage. Still alive... ~a hp left." - (address-actor-id (message-from shot-response)) - (message-ref shot-response 'damage-taken) - (message-ref shot-response 'hp-left)) - (format #f "Droid ~a shot; taken ~a damage. Terminated." - (address-actor-id (message-from shot-response)) - (message-ref shot-response 'damage-taken)))) + (call-with-message + shot-response + (lambda* (_ #:key alive damage-taken hp-left) + (if alive + (format #f "Droid ~a shot; taken ~a damage. Still alive... ~a hp left." + (address-actor-id (message-from shot-response)) + damage-taken hp-left) + (format #f "Droid ~a shot; taken ~a damage. Terminated." + (address-actor-id (message-from shot-response)) + damage-taken))))) ;;; Security robot... designed to seek out and destroy infected droids. -(define-simple-actor - ((begin-mission actor message) - ;; used to track the current room / if any rooms are remaining - (define room (message-ref message 'starting-room)) - (define overseer (message-ref message 'overseer)) - - ;; Walk through all rooms, clearing out infected droids - ;; Continue this whil there's still another room to investigate. - (define response) - (while room - (send-message actor overseer - 'transmission - #:message (format #f "Entering room ~a..." - (address-actor-id room))) - - ;; Find all droids in this room and exterminate the infected ones. - (set! response (send-message-wait actor room 'list-droids)) - (for-each - (lambda (droid-id) - (cond - ;; Looks like it's infected - ((message-ref - (send-message-wait actor droid-id - 'infection-expose) - 'is-infected) - ;; Inform that it's infected - (send-message actor overseer - 'transmission - #:message - (format #f "~a found to be infected... taking out" - (address-actor-id droid-id))) - - ;; Keep firing till it's dead. - (let ((still-alive #t)) - (while still-alive - (let ((response - (send-message-wait actor droid-id 'get-shot))) - (send-message actor overseer 'transmission - #:message (droid-status-format response)) - (set! still-alive (message-ref response 'alive)))))) - - ;; Not infected... inform and go to the next one - (else - (send-message actor overseer 'transmission - #:message - (format #f "~a is clean... moving on." - (address-actor-id droid-id)))))) - (message-ref response 'droid-ids)) - - ;; Switch to next room, if there is one. - (set! room (message-ref - (send-message-wait actor room 'get-next-room) - 'id))) - - ;; Good job everyone! Shut down the operation. - (send-message actor overseer 'transmission - #:message "Mission accomplished."))) +(define-actor () + ((begin-mission security-robot-begin-mission))) + +(define* (security-robot-begin-mission actor message + #:key starting-room overseer) + ;; used to track the current room / if any rooms are remaining + (define room starting-room) + + ;; Walk through all rooms, clearing out infected droids + ;; Continue this whil there's still another room to investigate. + (define response) + (while room + (<- overseer 'transmission + #:text (format #f "Entering room ~a..." + (address-actor-id room))) + + ;; Find all droids in this room and exterminate the infected ones. + (mbody-receive (_ #:key list-droids droid-ids #:allow-other-keys) + (<-wait room 'list-droids) + (for-each + (lambda (droid-id) + (cond + ;; Looks like it's infected + ((mbody-val (<-wait droid-id 'infection-expose)) + ;; Inform that it's infected + (<- overseer 'transmission + #:text (format #f "~a found to be infected... taking out" + (address-actor-id droid-id))) + + ;; Keep firing till it's dead. + (let ((still-alive #t)) + (while still-alive + (mbody-receive (response #:key alive #:allow-other-keys) + (<-wait droid-id 'get-shot) + (<- overseer 'transmission + #:text (droid-status-format response)) + (set! still-alive alive))))) + + ;; Not infected... inform and go to the next one + (else + (<- overseer 'transmission + #:text + (format #f "~a is clean... moving on." + (address-actor-id droid-id)))))) + droid-ids)) + + ;; Switch to next room, if there is one. + (set! room (mbody-val (<-wait room 'get-next-room)))) + + ;; Good job everyone! Shut down the operation. + (<- overseer 'transmission + #:text "Mission accomplished.")) (define (main . args) (define hive (make-hive)) - (define overseer (hive-create-actor hive )) + (define overseer (bootstrap-actor hive )) (define initial-messages - (list (hive-bootstrap-message hive overseer 'init-world))) - (ez-run-hive hive initial-messages)) + (list (bootstrap-message hive overseer 'init-world))) + (run-hive hive initial-messages))