From dc2155083a90de90e24f5341b837d4d96ce2898c Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Mon, 2 Jan 2017 19:20:58 -0600 Subject: [PATCH] actors: Implicit from-actor argument <-foo methods, and add rest of <-foo*. * 8sync/actors.scm (<-, <-wait, <-reply, <-reply-wait): from-actor is now implicitly supplied via %current-actor parameter. (<-*, <-reply*): New procedures. (<-wait*, <-reply-wait*): Now pull from-actor from #:actor. * 8sync/actors.scm: * 8sync/systems/irc.scm: * demos/actors/botherbotherbother.scm: * demos/actors/robotscanner.scm: * demos/actors/simplest-possible.scm: * demos/ircbot.scm: * tests/test-actors.scm: Update all callers of <-foo procedures to drop from-actor argument. * doc/8sync-new-manual.org: Update documentation of <-foo procedures to drop from-actor argument. --- 8sync/actors.scm | 87 +++++++++++++++++++---------- 8sync/systems/irc.scm | 4 +- demos/actors/botherbotherbother.scm | 6 +- demos/actors/robotscanner.scm | 39 +++++++------ demos/actors/simplest-possible.scm | 2 +- demos/ircbot.scm | 6 +- doc/8sync-new-manual.org | 28 +++++----- tests/test-actors.scm | 8 +-- 8 files changed, 101 insertions(+), 79 deletions(-) diff --git a/8sync/actors.scm b/8sync/actors.scm index 37f321b..6e772c6 100644 --- a/8sync/actors.scm +++ b/8sync/actors.scm @@ -71,7 +71,7 @@ message-auto-reply? - <- <-wait <-wait* <-reply <-reply-wait <-reply-wait* + <- <-* <-wait <-wait* <-reply <-reply* <-reply-wait <-reply-wait* call-with-message msg-receive msg-val @@ -196,51 +196,78 @@ ;; confusing. (8sync (hive-process-message hive new-message))))) - -(define (<- from-actor to-id action . message-body-args) +(define (<- to-id action . message-body-args) "Send a message from an actor to another actor" - (send-message '() from-actor to-id action + (send-message '() (%current-actor) to-id action #f #f message-body-args)) -(define (<-wait* send-options from-actor to-id action . message-body-args) - "Like <-wait, but allows extra parameters, for example whether to -#:accept-errors" - (apply wait-maybe-handle-errors - (send-message send-options from-actor to-id action - #f #t message-body-args) - send-options)) +(define (<-* send-options to-id action . message-body-args) + "Like <-*, but allows extra parameters via send-options" + (define* (really-send #:key (actor (%current-actor)) + #:allow-other-keys) + (send-message send-options actor to-id action + #f #f message-body-args)) + (apply really-send send-options)) -(define (<-wait from-actor to-id action . message-body-args) +(define (<-wait to-id action . message-body-args) "Send a message from an actor to another, but wait until we get a response" - (apply <-wait* '() from-actor to-id action message-body-args)) + (wait-maybe-handle-errors + (send-message '() (%current-actor) to-id action + #f #t message-body-args))) + +(define (<-wait* send-options to-id action . message-body-args) + "Like <-wait, but allows extra parameters, for example whether to +#:accept-errors" + (define* (really-send #:key (actor (%current-actor)) + #:allow-other-keys) + (apply wait-maybe-handle-errors + (send-message send-options actor to-id action + #f #t message-body-args) + send-options)) + (apply really-send send-options)) ;; TODO: Intelligently ~propagate(ish) errors on -wait functions. ;; We might have `send-message-wait-brazen' to allow callers to ;; not have an exception thrown and instead just have a message with ;; the appropriate '*error* message returned. -(define (<-reply from-actor original-message . message-body-args) +(define (<-reply original-message . message-body-args) "Reply to a message" - (send-message '() from-actor (message-from original-message) '*reply* + (send-message '() (%current-actor) (message-from original-message) '*reply* original-message #f message-body-args)) -(define (<-auto-reply from-actor original-message) +(define (<-reply* send-options original-message . message-body-args) + "Like <-reply, but allows extra parameters via send-options" + (define* (really-send #:key (actor (%current-actor)) + #:allow-other-keys) + (send-message send-options actor + (message-from original-message) '*reply* + original-message #f message-body-args)) + (apply really-send send-options)) + +(define (<-auto-reply actor original-message) "Auto-reply to a message. Internal use only!" - (send-message '() from-actor (message-from original-message) '*auto-reply* + (send-message '() actor (message-from original-message) '*auto-reply* original-message #f '())) -(define (<-reply-wait* send-options from-actor original-message - . message-body-args) +(define (<-reply-wait original-message . message-body-args) "Reply to a messsage, but wait until we get a response" - (apply wait-maybe-handle-errors - (send-message send-options from-actor - (message-from original-message) '*reply* - original-message #t message-body-args) - send-options)) + (wait-maybe-handle-errors + (send-message '() (%current-actor) + (message-from original-message) '*reply* + original-message #t message-body-args))) -(define (<-reply-wait from-actor original-message . message-body-args) - "Reply to a messsage, but wait until we get a response" - (apply <-reply-wait* '() from-actor original-message message-body-args)) +(define (<-reply-wait* send-options original-message + . message-body-args) + "Like <-reply-wait, but allows extra parameters via send-options" + (define* (really-send #:key (actor (%current-actor)) + #:allow-other-keys) + (apply wait-maybe-handle-errors + (send-message send-options actor + (message-from original-message) '*reply* + original-message #t message-body-args) + send-options)) + (apply really-send send-options)) (define* (wait-maybe-handle-errors message #:key accept-errors @@ -421,7 +448,7 @@ to come after class definition." (hash-map->list (lambda (actor-id actor) actor-id) (hive-actor-registry hive))) (for-each (lambda (actor-id) - (<- hive actor-id '*cleanup*)) + (<- actor-id '*cleanup*)) actor-ids)) (define* (make-hive #:key hive-id) @@ -713,7 +740,7 @@ Like create-actor, but permits supplying an id-cookie." Unless #:cleanup is set to #f, this will first have the actor handle its '*cleanup* action handler." (when cleanup - (<-wait actor (actor-id actor) '*cleanup*)) + (<-wait (actor-id actor) '*cleanup*)) (hash-remove! (hive-actor-registry (actor-hive actor)) (actor-id actor))) @@ -745,7 +772,7 @@ its '*cleanup* action handler." (define (bootstrap-message hive to-id action . message-body-args) (wrap - (apply <- hive to-id action message-body-args))) + (apply <-* `(#:actor ,hive) to-id action message-body-args))) diff --git a/8sync/systems/irc.scm b/8sync/systems/irc.scm index aad138d..40d02eb 100755 --- a/8sync/systems/irc.scm +++ b/8sync/systems/irc.scm @@ -189,7 +189,7 @@ (format socket "JOIN ~a~a" channel irc-eol)) (irc-bot-channels irc-bot)) - (<- irc-bot (actor-id irc-bot) 'main-loop)) + (<- (actor-id irc-bot) 'main-loop)) (define (irc-bot-main-loop irc-bot message) (define socket (irc-bot-socket irc-bot)) @@ -212,7 +212,7 @@ ;; 'done) ;; Otherwise, let's read till the next line! (else - (<- irc-bot (actor-id irc-bot) 'main-loop)))) + (<- (actor-id irc-bot) 'main-loop)))) (define* (irc-bot-send-line-action irc-bot message channel line #:key emote?) diff --git a/demos/actors/botherbotherbother.scm b/demos/actors/botherbotherbother.scm index 4911afa..2e72b2d 100755 --- a/demos/actors/botherbotherbother.scm +++ b/demos/actors/botherbotherbother.scm @@ -59,8 +59,7 @@ (while (not (student-dead actor)) (format #t "~a: Bother bother bother!\n" (actor-id-actor actor)) - (<- actor target - 'be-bothered + (<- target 'be-bothered #:noise "Bother bother bother!\n")))) (be-lambda-consvardraed @@ -89,8 +88,7 @@ (actor-id actor)) (hash-for-each (lambda (student _) - (<- actor student - 'be-lambda-consvardraed) + (<- student 'be-lambda-consvardraed) ;; Remove student from bothering list (hash-remove! whos-bothering student)) whos-bothering)) diff --git a/demos/actors/robotscanner.scm b/demos/actors/robotscanner.scm index f620ba8..d2c919c 100644 --- a/demos/actors/robotscanner.scm +++ b/demos/actors/robotscanner.scm @@ -64,15 +64,15 @@ (define droid (create-actor* actor "droid" #:infected infected #:room room)) - (<-wait actor droid 'register-with-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 - (<- actor previous-room 'set-next-room + (<- previous-room 'set-next-room #:id room) - (<- actor room 'set-previous-room + (<- room 'set-previous-room #:id previous-room)) ;; Set up clean droids in the room @@ -95,7 +95,7 @@ ;; Add security robot (let ((security-robot (create-actor actor ))) - (<- actor security-robot 'begin-mission + (<- security-robot 'begin-mission #:starting-room first-room #:overseer (actor-id actor))))) @@ -128,17 +128,17 @@ (get-next-room (lambda (actor message) "Return a reference to the link following this" - (<-reply actor message (slot-ref actor 'next-room)))) + (<-reply message (slot-ref actor 'next-room)))) (get-previous-room (lambda (actor message) "Return a reference to the link preceding this" - (<-reply actor message (slot-ref actor 'previous-room)))) + (<-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 actor message + (<-reply message #:droid-ids (slot-ref actor 'droids)))) (register-droid @@ -164,8 +164,7 @@ (lambda (actor message) "Register ourselves as being in a room" (let ((room-id (slot-ref actor 'room))) - (<-wait actor room-id - 'register-droid + (<-wait room-id 'register-droid #:droid-id (actor-id actor)) (format #t "Droid ~a registered with room ~a\n" (actor-id-actor actor) @@ -174,7 +173,7 @@ (infection-expose (lambda (actor message) "Leak whether or not we're infected to a security droid" - (<-reply actor message (slot-ref actor 'infected)))) + (<-reply message (slot-ref actor 'infected)))) (get-shot (lambda (actor message) @@ -184,7 +183,7 @@ (alive (> new-hp 0))) ;; Set our health to the new value (slot-set! actor 'hp new-hp) - (<-reply actor message + (<-reply message #:hp-left new-hp #:damage-taken damage #:alive alive) @@ -219,20 +218,20 @@ ;; Continue this whil there's still another room to investigate. (define response) (while room - (<- actor overseer 'transmission + (<- overseer 'transmission #:text (format #f "Entering room ~a..." (address-actor-id room))) ;; Find all droids in this room and exterminate the infected ones. (msg-receive (_ #:key list-droids droid-ids #:allow-other-keys) - (<-wait actor room 'list-droids) + (<-wait room 'list-droids) (for-each (lambda (droid-id) (cond ;; Looks like it's infected - ((msg-val (<-wait actor droid-id 'infection-expose)) + ((msg-val (<-wait droid-id 'infection-expose)) ;; Inform that it's infected - (<- actor overseer 'transmission + (<- overseer 'transmission #:text (format #f "~a found to be infected... taking out" (address-actor-id droid-id))) @@ -240,24 +239,24 @@ (let ((still-alive #t)) (while still-alive (msg-receive (response #:key alive #:allow-other-keys) - (<-wait actor droid-id 'get-shot) - (<- actor overseer 'transmission + (<-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 - (<- actor overseer 'transmission + (<- 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 (msg-val (<-wait actor room 'get-next-room)))) + (set! room (msg-val (<-wait room 'get-next-room)))) ;; Good job everyone! Shut down the operation. - (<- actor overseer 'transmission + (<- overseer 'transmission #:text "Mission accomplished.")) (define (main . args) diff --git a/demos/actors/simplest-possible.scm b/demos/actors/simplest-possible.scm index e9aaac7..4e03782 100644 --- a/demos/actors/simplest-possible.scm +++ b/demos/actors/simplest-possible.scm @@ -23,7 +23,7 @@ (greet-proog (lambda (actor message target) (display "emo> What's next, Proog?\n") - (<- actor target 'greet-emo)))) + (<- target 'greet-emo)))) (define-simple-actor (greet-emo diff --git a/demos/ircbot.scm b/demos/ircbot.scm index b962ad7..1c4ae74 100755 --- a/demos/ircbot.scm +++ b/demos/ircbot.scm @@ -41,19 +41,19 @@ (match action ;; The classic botsnack! ("botsnack" - (<- irc-bot (actor-id irc-bot) 'send-line channel + (<- (actor-id irc-bot) 'send-line channel "Yippie! *does a dance!*")) ;; Return greeting ((or "hello" "hello!" "hello." "greetings" "greetings." "greetings!" "hei" "hei." "hei!" "hi" "hi!") - (<- irc-bot (actor-id irc-bot) 'send-line channel + (<- (actor-id irc-bot) 'send-line channel (format #f "Oh hi ~a!" speaker))) ;; ---> Add yours here <--- ;; Default (_ - (<- irc-bot (actor-id irc-bot) 'send-line channel + (<- (actor-id irc-bot) 'send-line channel "*stupid puppy look*")))) ;; Otherwise... just spit the output to current-output-port or whatever (_ diff --git a/doc/8sync-new-manual.org b/doc/8sync-new-manual.org index d0a9967..3e17cbf 100644 --- a/doc/8sync-new-manual.org +++ b/doc/8sync-new-manual.org @@ -205,7 +205,7 @@ Change handle-line to this: #+BEGIN_SRC scheme (define-method (handle-line (irc-bot ) speaker channel line emote?) - (<- irc-bot (actor-id irc-bot) 'send-line channel + (<- (actor-id irc-bot) 'send-line channel (format #f "Bawwwwk! ~a says: ~a" speaker line))) #+END_SRC @@ -295,7 +295,7 @@ Luckily this is an easy adjustment to make. (or (equal? str my-name) (equal? str (string-concatenate (list my-name ":"))))) (when (looks-like-me?) - (<- irc-bot (actor-id irc-bot) 'send-line channel + (<- (actor-id irc-bot) 'send-line channel (format #f "Bawwwwk! ~a says: ~a" speaker line)))) #+END_SRC @@ -327,22 +327,22 @@ To implement it, we're going to pull out Guile's pattern matcher. (match action ;; The classic botsnack! ("botsnack" - (<- irc-bot (actor-id irc-bot) 'send-line channel + (<- (actor-id irc-bot) 'send-line channel "Yippie! *does a dance!*")) ;; Return greeting ((or "hello" "hello!" "hello." "greetings" "greetings." "greetings!" "hei" "hei." "hei!" "hi" "hi!") - (<- irc-bot (actor-id irc-bot) 'send-line channel + (<- (actor-id irc-bot) 'send-line channel (format #f "Oh hi ~a!" speaker))) ("echo" - (<- irc-bot (actor-id irc-bot) 'send-line channel + (<- (actor-id irc-bot) 'send-line channel (string-join action-args " "))) ;; ---> Add yours here <--- ;; Default (_ - (<- irc-bot (actor-id irc-bot) 'send-line channel + (<- (actor-id irc-bot) 'send-line channel "*stupid puppy look*")))))) #+END_SRC @@ -360,7 +360,7 @@ you're right: (or (equal? str my-name) (equal? str (string-concatenate (list my-name ":"))))) (define (respond respond-line) - (<- irc-bot (actor-id irc-bot) 'send-line channel + (<- (actor-id irc-bot) 'send-line channel respond-line)) (match (string-split line #\space) (((? looks-like-me? _) action action-args ...) @@ -503,7 +503,7 @@ things to: line emote?) ;; [... snip ...] (define (respond respond-line) - (<- irc-bot (actor-id irc-bot) 'send-line (pk 'channel channel) + (<- (actor-id irc-bot) 'send-line (pk 'channel channel) respond-line)) ;; [... snip ...] ) @@ -533,7 +533,7 @@ to looks like our own username that we respond back to the sender. line emote?) ;; [... snip ...] (define (respond respond-line) - (<- irc-bot (actor-id irc-bot) 'send-line + (<- (actor-id irc-bot) 'send-line (if (looks-like-me? channel) speaker ; PM session channel) ; normal IRC channel @@ -615,7 +615,7 @@ Time to get back to work! (define (manager-assign-task manager message difficulty) "Delegate a task to our direct report" (display "manager> Work on this task for me!\n") - (<- manager (manager-direct-report manager) + (<- (manager-direct-report manager) 'work-on-this difficulty)) #+END_SRC @@ -698,7 +698,7 @@ into a micromanager. (define (manager-assign-task manager message difficulty) "Delegate a task to our direct report" (display "manager> Work on this task for me!\n") - (<- manager (manager-direct-report manager) + (<- (manager-direct-report manager) 'work-on-this difficulty) ;; call the micromanagement loop @@ -710,7 +710,7 @@ into a micromanager. "Pester direct report until they're done with their task." (display "manager> Are you done yet???\n") (let ((still-working - (msg-val (<-wait manager (manager-direct-report manager) + (msg-val (<-wait (manager-direct-report manager) 'done-yet?)))) (if still-working (begin (display "manager> Harumph!\n") @@ -718,7 +718,7 @@ into a micromanager. (when (actor-alive? manager) (manager-micromanage-loop manager))) (begin (display "manager> Oh! I guess you can go home then.\n") - (<- manager (manager-direct-report manager) 'go-home))))) + (<- (manager-direct-report manager) 'go-home))))) #+END_SRC We've appended a micromanagement loop here... but what's going on? @@ -746,7 +746,7 @@ Of course, we need to update our worker accordingly as well. ;;; New procedures: (define (worker-done-yet? worker message) "Reply with whether or not we're done yet." - (<-reply worker message + (<-reply message (= (worker-task-left worker) 0))) (define (worker-go-home worker message) diff --git a/tests/test-actors.scm b/tests/test-actors.scm index ea0324c..54d8dbb 100644 --- a/tests/test-actors.scm +++ b/tests/test-actors.scm @@ -80,13 +80,13 @@ (define* (antsy-caller-pester-rep actor message #:key who-to-call) (~display "customer> I'm calling customer service about this!\n") (msg-receive (first-reply #:key msg) - (<-wait actor who-to-call 'field-call) + (<-wait who-to-call 'field-call) (if (message-auto-reply? first-reply) (~display "customer> Whaaaaat? I can't believe I got voice mail!\n") (begin (~format "*customer hears*: ~a\n" msg) (msg-receive (second-reply #:key *auto-reply*) - (<-reply-wait actor first-reply + (<-reply-wait first-reply #:msg "Yes, it didn't work, I'm VERY ANGRY!") (if (message-auto-reply? second-reply) (~display "customer> Well then! Harumph.\n") @@ -98,9 +98,7 @@ (define (rep-field-call actor message) (~display "good-rep> Hm, another call from a customer...\n") (msg-receive (reply #:key msg) - (<-reply-wait - actor message - #:msg "Have you tried turning it off and on?") + (<-reply-wait message #:msg "Have you tried turning it off and on?") (~format "*rep hears*: ~a\n" msg) (~display "good-rep> I'm sorry, that's all I can do for you.\n"))) -- 2.31.1