(use-modules (mudsync)
(mudsync parser)
- (8sync systems actors)
+ (8sync actors)
(8sync agenda)
(oop goops)
(ice-9 control)
(append readable-commands
thing-commands))
-(define readable-actions
- (build-actions
- (cmd-read (wrap-apply readable-cmd-read))))
-
-(define readable-actions*
- (append readable-actions
- thing-actions*))
-
(define-class <readable> (<thing>)
(read-text #:init-value "All it says is: \"Blah blah blah.\""
#:init-keyword #:read-text)
(commands
#:init-value readable-commands*)
- (message-handler
- #:init-value
- (simple-dispatcher readable-actions*)))
+ (actions #:allocation #:each-subclass
+ #:init-value (build-actions
+ (cmd-read readable-cmd-read))))
(define (readable-cmd-read actor message)
- (<- actor (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text (string-append (slot-ref actor 'read-text) "\n")))
(format #f "~a says: \"~a\"\n"
(slot-ref actor 'name)
(random-choice (slot-ref actor 'catchphrases))))
- (<- actor (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text text-to-send))
(define chat-commands
(list
(direct-command "chat" 'cmd-chat)
(direct-command "talk" 'cmd-chat)))
-(define chat-actions
- (build-actions
- (cmd-chat (wrap-apply npc-chat-randomly))))
(define hotel-owner-grumps
'("Eight sinks! Eight sinks! And I couldn't unwind them..."
#:init-keyword #:catchphrases)
(commands
#:init-value chat-commands)
- (message-handler
- #:init-value
- (simple-dispatcher (append gameobj-actions chat-actions))))
+ (actions #:allocation #:each-subclass
+ #:init-value
+ (build-actions
+ (cmd-chat npc-chat-randomly))))
(define random-bricabrac
'("a creepy porcelain doll"
#:init-value
(list
(prep-direct-command "sign" 'cmd-sign-form
- '("as"))))
- (message-handler
- #:init-value
- (simple-dispatcher
- (append
- (build-actions
- (cmd-sign-form (wrap-apply sign-cmd-sign-in)))
- gameobj-actions))))
+ '("as"))))
+ (actions #:allocation #:each-subclass
+ #:init-value (build-actions
+ (cmd-sign-form sign-cmd-sign-in))))
(define name-sre
(define* (sign-cmd-sign-in actor message
#:key direct-obj indir-obj preposition)
(define old-name
- (msg-receive (_ #:key val)
- (<-wait actor (message-from message) 'get-name)
- val))
+ (mbody-val (<-wait (message-from message) 'get-name)))
(define name indir-obj)
(if (valid-name? indir-obj)
(begin
- (<-wait actor (message-from message) 'set-name!
- #:val name)
- (<- actor (slot-ref actor 'loc) 'tell-room
+ (<-wait (message-from message) 'set-name! name)
+ (<- (slot-ref actor 'loc) 'tell-room
#:text (format #f "~a signs the form!\n~a is now known as ~a\n"
old-name old-name name)))
- (<- actor (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text "Sorry, that's not a valid name.
Alphanumerics, _ and - only, 2-15 characters, starts with an alphabetic
character.\n")))
(append summoning-bell-commands
thing-commands*))
-(define summoning-bell-actions
- (build-actions
- (cmd-ring (wrap-apply summoning-bell-cmd-ring))))
-(define summoning-bell-actions*
- (append summoning-bell-actions
- thing-actions*))
-
(define-class <summoning-bell> (<thing>)
(summons #:init-keyword #:summons)
(commands
#:init-value summoning-bell-commands*)
- (message-handler
- #:init-value
- (simple-dispatcher summoning-bell-actions*)))
+ (actions #:allocation #:each-subclass
+ #:init-value (build-actions
+ (cmd-ring summoning-bell-cmd-ring))))
-(define (summoning-bell-cmd-ring bell message)
+(define* (summoning-bell-cmd-ring bell message . _)
;; Call back to actor who invoked this message handler
;; and find out their name. We'll call *their* get-name message
;; handler... meanwhile, this procedure suspends until we get
;; their response.
(define who-rang
- (msg-receive (_ #:key val)
- (<-wait bell (message-from message) 'get-name)
- val))
+ (mbody-val (<-wait (message-from message) 'get-name)))
+
;; Now we'll invoke the "tell" message handler on the player
;; who rang us, displaying this text on their screen.
;; This one just uses <- instead of <-wait, since we don't
;; care when it's delivered; we're not following up on it.
- (<- bell (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text "*ring ring!* You ring the bell!\n")
;; We also want everyone else in the room to "hear" the bell,
;; but they get a different message since they aren't the ones
;; name as extracted and assigned to the who-rang variable.
;; Notice how we send this message to our "location", which
;; forwards it to the rest of the occupants in the room.
- (<- bell (gameobj-loc bell) 'tell-room
+ (<- (gameobj-loc bell) 'tell-room
#:text
(format #f "*ring ring!* ~a rings the bell!\n"
who-rang)
;; Now we perform the primary task of the bell, which is to summon
;; the "clerk" character to the room. (This is configurable,
;; so we dynamically look up their address.)
- (<- bell (dyn-ref bell (slot-ref bell 'summons)) 'be-summoned
+ (<- (dyn-ref bell (slot-ref bell 'summons)) 'be-summoned
#:who-summoned (message-from message)))
#:desc
" You're in some sort of hotel lobby. You see a large sign hanging
over the desk that says \"Hotel Bricabrac\". On the desk is a bell
-that says \"ring for service\". Terrible music plays from a speaker
+that says \"'ring bell' for service\". Terrible music plays from a speaker
somewhere overhead.
The room is lined with various curio cabinets, filled with all sorts
of kitschy junk. It looks like whoever decorated this place had great
#:init-value
(list
(direct-command "sit" 'cmd-sit-furniture)))
- (message-handler
- #:init-value
- (simple-dispatcher
- (append
- (build-actions
- (cmd-sit-furniture (wrap-apply furniture-cmd-sit)))
- gameobj-actions))))
+ (actions #:allocation #:each-subclass
+ #:init-value (build-actions
+ (cmd-sit-furniture furniture-cmd-sit))))
(define* (furniture-cmd-sit actor message #:key direct-obj)
(define player-name
- (msg-receive (_ #:key val)
- (<-wait actor (message-from message) 'get-name)
- val))
- (<- actor (message-from message) 'tell
+ (mbody-val (<-wait (message-from message) 'get-name)))
+ (<- (message-from message) 'tell
#:text (format #f "You ~a ~a.\n"
(slot-ref actor 'sit-phrase)
(slot-ref actor 'sit-name)))
- (<- actor (slot-ref actor 'loc) 'tell-room
+ (<- (slot-ref actor 'loc) 'tell-room
#:text (format #f "~a ~a on ~a.\n"
player-name
(slot-ref actor 'sit-phrase-third-person)
(define clerk-commands*
(append clerk-commands thing-commands*))
-(define clerk-actions
- (build-actions
- (init (wrap-apply clerk-act-init))
- (cmd-chat (wrap-apply clerk-cmd-chat))
- (cmd-ask-incomplete (wrap-apply clerk-cmd-ask-incomplete))
- (cmd-ask-about (wrap-apply clerk-cmd-ask))
- (cmd-dismiss (wrap-apply clerk-cmd-dismiss))
- (update-loop (wrap-apply clerk-act-update-loop))
- (be-summoned (wrap-apply clerk-act-be-summoned))))
-(define clerk-actions* (append clerk-actions
- thing-actions*))
-
(define-class <desk-clerk> (<thing>)
;; The desk clerk has three states:
;; - on-duty: Arrived, and waiting for instructions (and losing patience
(state #:init-value 'slacking)
(commands #:init-value clerk-commands*)
(patience #:init-value 0)
- (message-handler
- #:init-value
- (simple-dispatcher clerk-actions*)))
+ (actions #:allocation #:each-subclass
+ #:init-value (build-actions
+ (init clerk-act-init)
+ (cmd-chat clerk-cmd-chat)
+ (cmd-ask-incomplete clerk-cmd-ask-incomplete)
+ (cmd-ask-about clerk-cmd-ask)
+ (cmd-dismiss clerk-cmd-dismiss)
+ (update-loop clerk-act-update-loop)
+ (be-summoned clerk-act-be-summoned))))
(define (clerk-act-init clerk message)
;; call the gameobj main init method
(gameobj-act-init clerk message)
;; start our main loop
- (<- clerk (actor-id clerk) 'update-loop))
+ (<- (actor-id clerk) 'update-loop))
(define clerk-help-topics
'(("changing name" .
(define clerk-knows-about
- "'changing name', 'common commands', and 'about the hotel'")
+ "'ask clerk about changing name', 'ask clerk about common commands', and 'ask clerk about the hotel'")
(define clerk-general-helpful-line
(string-append
(define* (clerk-cmd-chat clerk message #:key direct-obj)
(match (slot-ref clerk 'state)
('on-duty
- (<- clerk (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text clerk-general-helpful-line))
('slacking
- (<- clerk (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text
(string-append
"The clerk says, \""
(random-choice clerk-slacking-complaints)
"\"\n")))))
-(define (clerk-cmd-ask-incomplete clerk message)
- (<- clerk (message-from message) 'tell
+(define (clerk-cmd-ask-incomplete clerk message . _)
+ (<- (message-from message) 'tell
#:text "The clerk says, \"Ask about what?\"\n"))
(define clerk-doesnt-know-text
"The clerk apologizes and says she doesn't know about that topic.\n")
-(define (clerk-cmd-ask clerk message indir-obj)
+(define* (clerk-cmd-ask clerk message #:key indir-obj
+ #:allow-other-keys)
(match (slot-ref clerk 'state)
('on-duty
(match (assoc (pk 'indir indir-obj) clerk-help-topics)
((_ . info)
- (<- clerk (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text
(string-append "The clerk clears her throat and says:\n \""
info
"\"\n")))
(#f
- (<- clerk (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text clerk-doesnt-know-text))))
('slacking
- (<- clerk (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text "The clerk says, \"Sorry, I'm on my break.\"\n"))))
-(define (clerk-act-be-summoned clerk message who-summoned)
+(define* (clerk-act-be-summoned clerk message #:key who-summoned)
(match (slot-ref clerk 'state)
('on-duty
- (<- clerk who-summoned 'tell
+ (<- who-summoned 'tell
#:text
"The clerk tells you as politely as she can that she's already here,
so there's no need to ring the bell.\n"))
('slacking
- (<- clerk (gameobj-loc clerk) 'tell-room
+ (<- (gameobj-loc clerk) 'tell-room
#:text
"The clerk's ears perk up, she stamps out a cigarette, and she
runs out of the room!\n")
(gameobj-set-loc! clerk (dyn-ref clerk 'room:lobby))
(slot-set! clerk 'patience 8)
(slot-set! clerk 'state 'on-duty)
- (<- clerk (gameobj-loc clerk) 'tell-room
+ (<- (gameobj-loc clerk) 'tell-room
#:text
(string-append
" Suddenly, a uniformed woman rushes into the room! She's wearing a
You can ask me about the following:
" clerk-knows-about ".\"\n")))))
-(define (clerk-cmd-dismiss clerk message)
+(define* (clerk-cmd-dismiss clerk message . _)
(define player-name
- (msg-receive (_ #:key val)
- (<-wait clerk (message-from message) 'get-name)
- val))
+ (mbody-val (<-wait (message-from message) 'get-name)))
(match (slot-ref clerk 'state)
('on-duty
- (<- clerk (gameobj-loc clerk) 'tell-room
+ (<- (gameobj-loc clerk) 'tell-room
#:text
(format #f "\"Thanks ~a!\" says the clerk. \"I have somewhere I need to be.\"
The clerk leaves the room in a hurry.\n"
#:exclude (actor-id clerk))
(gameobj-set-loc! clerk (dyn-ref clerk 'room:break-room))
(slot-set! clerk 'state 'slacking)
- (<- clerk (gameobj-loc clerk) 'tell-room
+ (<- (gameobj-loc clerk) 'tell-room
#:text clerk-return-to-slacking-text
#:exclude (actor-id clerk)))
('slacking
- (<- clerk (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text "The clerk sternly asks you to not be so dismissive.\n"))))
(define clerk-slacking-texts
"The clerk takes a deep breath.\n"
"The clerk yawns.\n"
"The clerk drums her nails on the counter.\n"
- "The clerk clicks around on the desk computer.\n"))
+ "The clerk clicks around on the desk computer.\n"
+ "The clerk thumbs through a printout of some physics paper.\n"
+ "The clerk mutters that her dissertation isn't going to write itself.\n"))
(define clerk-slack-excuse-text
"The desk clerk excuses herself, claiming she has important things to
(define clerk-return-to-slacking-text
"The desk clerk enters and slams the door behind her.\n")
+
(define (clerk-act-update-loop clerk message)
(define (tell-room text)
- (<- clerk (gameobj-loc clerk) 'tell-room
+ (<- (gameobj-loc clerk) 'tell-room
#:text text
#:exclude (actor-id clerk)))
(define (loop-if-not-destructed)
(if (not (slot-ref clerk 'destructed))
- (<- clerk (actor-id clerk) 'update-loop)))
+ ;; This iterates by "recursing" on itself by calling itself
+ ;; (as the message handler) again. It used to be that we had to do
+ ;; this, because there was a bug where a loop which yielded like this
+ ;; would keep growing the stack due to some parameter goofiness.
+ ;; That's no longer true, but there's an added advantage to this
+ ;; route: it's much more live hackable. If we change the definition
+ ;; of this method, the character will act differently on the next
+ ;; "tick" of the loop.
+ (<- (actor-id clerk) 'update-loop)))
(match (slot-ref clerk 'state)
('slacking
(tell-room (random-choice clerk-slacking-texts))
projects / mudsync.git / blobdiff