(use-modules (mudsync)
(mudsync parser)
- (8sync systems actors)
+ (8sync actors)
(8sync agenda)
(oop goops)
+ (ice-9 control)
(ice-9 format)
+ (ice-9 match)
(rx irregex))
(define readable-commands
(list
(direct-command "read" 'cmd-read)))
-(define readable-actions
- (build-actions
- (cmd-read (wrap-apply readable-cmd-read))))
-(define-class <readable> (<gameobj>)
+(define readable-commands*
+ (append readable-commands
+ thing-commands))
+
+(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 (append gameobj-actions readable-actions))))
+ #:init-value readable-commands*)
+ (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")))
;;; Lobby
;;; -----
-(define-mhandler (npc-chat-randomly actor message)
+(define (npc-chat-randomly actor message . _)
(define text-to-send
(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"
(commands
#:init-value
(list
- (indir-as-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))))
+ (prep-direct-command "sign" 'cmd-sign-form
+ '("as"))))
+ (actions #:allocation #:each-subclass
+ #:init-value (build-actions
+ (cmd-sign-form sign-cmd-sign-in))))
(define name-sre
(and (irregex-match name-sre name)
(not (member name forbidden-words))))
-(define-mhandler (sign-cmd-sign-in actor message direct-obj indir-obj)
+(define* (sign-cmd-sign-in actor message
+ #:key direct-obj indir-obj preposition)
(define old-name
- (message-ref
- (<-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
- "Sorry, that's not a valid name.
+ (<- (message-from message) 'tell
+ #:text "Sorry, that's not a valid name.
Alphanumerics, _ and - only, 2-15 characters, starts with an alphabetic
-character.")))
+character.\n")))
+
+(define summoning-bell-commands
+ (list
+ (direct-command "ring" 'cmd-ring)))
+(define summoning-bell-commands*
+ (append summoning-bell-commands
+ thing-commands*))
+
+(define-class <summoning-bell> (<thing>)
+ (summons #:init-keyword #:summons)
+
+ (commands
+ #:init-value summoning-bell-commands*)
+ (actions #:allocation #:each-subclass
+ #:init-value (build-actions
+ (cmd-ring summoning-bell-cmd-ring))))
+
+(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
+ (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.
+ (<- (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
+ ;; ringing it. Notice here's where we make use of the invoker's
+ ;; 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.
+ (<- (gameobj-loc bell) 'tell-room
+ #:text
+ (format #f "*ring ring!* ~a rings the bell!\n"
+ who-rang)
+ #:exclude (message-from message))
+ ;; 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.)
+ (<- (dyn-ref bell (slot-ref bell 'summons)) 'be-summoned
+ #:who-summoned (message-from message)))
+
+
+(define prefect-quotes
+ '("I'm a frood who really knows where my towel is!"
+ "On no account allow a Vogon to read poetry at you."
+ "Time is an illusion, lunchtime doubly so!"
+ "How can you have money if none of you produces anything?"
+ "On no account allow Arthur to request tea on this ship."))
(define lobby
(lol
#: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
"Chris Webber" ; heh, did you rtfc? or was it so obvious?
"hotel proprietor" "proprietor")
#:catchphrases hotel-owner-grumps)
- ;; NPC: desk clerk (comes when you ring the s)
- ;; impatient teenager, only stays around for a few minutes
- ;; complaining, then leaves.
-
;; Object: Sign
('thing:lobby:sign
<readable> 'room:lobby
"hotel bricabrac sign"
"lobby sign"))
+ ('thing:lobby:bell
+ <summoning-bell> 'room:lobby
+ #:name "a shiny brass bell"
+ #:goes-by '("shiny brass bell" "shiny bell" "brass bell" "bell")
+ #:desc " A shiny brass bell. Inscribed on its wooden base is the text
+\"ring me for service\". You probably could \"ring the bell\" if you
+wanted to."
+ #:summons 'npc:break-room:desk-clerk)
+
;; Object: curio cabinets
('thing:lobby:cabinet
<gameobj> 'room:lobby
clear indication that they have any logical relation to this place.
In the center is a large statue of a bearded man. You wonder what
that's all about?
- To the south is the lobby. All around are various doors, but
-they're all boarded up. One to the east goes to the smoking parlor,
-though."
+ To the south is the lobby. A door to the east is labeled \"smoking
+room\", while a door to the west is labeled \"playroom\"."
#:exits
(list (make <exit>
#:name "south"
#:to 'room:lobby)
+ (make <exit>
+ #:name "west"
+ #:to 'room:playroom)
(make <exit>
#:name "east"
#:to 'room:smoking-parlor)))
#:name "a statue"
#:desc " The statue is of a serious-looking bearded man with long, flowing hair.
The inscription says \"St. Ignucius\".
- It has a large physical halo. It doesn't look like it would be hard to remove."
+ It has a large physical halo. Removing it is tempting, but it looks pretty
+well fastened."
#:goes-by '("statue" "st ignucius" "st. ignucius"))))
\f
;;; Playroom
;;; --------
+(define playroom
+ (lol
+ ('room:playroom
+ <room> #f
+ #:name "The Playroom"
+ #:desc " There are toys scattered everywhere here. It's really unclear
+if this room is intended for children or child-like adults."
+ #:exits
+ (list (make <exit>
+ #:name "east"
+ #:to 'room:grand-hallway)))
+ ('thing:playroom:cubey
+ <thing> 'room:playroom
+ #:name "cubey"
+ #:takeable #t
+ #:desc " It's a little foam cube with googly eyes on it. So cute!")
+ ('thing:cuddles-plushie
+ <thing> 'room:playroom
+ #:name "a cuddles plushie"
+ #:goes-by '("plushie" "cuddles plushie" "cuddles")
+ #:takeable #t
+ #:desc " A warm and fuzzy cuddles plushie! It's a cuddlefish!")))
+
+
\f
;;; Writing room
;;; ------------
#: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-mhandler (furniture-cmd-sit actor message direct-obj)
+(define* (furniture-cmd-sit actor message #:key direct-obj)
(define player-name
- (message-ref
- (<-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)
if you like.
Strangely, you see a large sign saying \"No Smoking\". The owners must
have installed this place and then changed their mind later.
- Nonetheless there are some candy cigarettes and cigars you can pick up
-at the bar. (editor's note: or will be soon :])"
+ There's a door to the west leading back to the grand hallway, and
+a nondescript steel door to the south, leading apparently outside."
#:exits
(list (make <exit>
#:name "west"
- #:to 'room:grand-hallway)))
+ #:to 'room:grand-hallway)
+ (make <exit>
+ #:name "south"
+ #:to 'room:break-room)))
('thing:smoking-room:chair
<furniture> 'room:smoking-parlor
#:name "a comfy leather chair"
<furniture> 'room:smoking-parlor
#:name "a plush leather sofa"
#:desc " That leather chair looks really comfy!"
- #:goes-by '("leather sofa" "plush leather sofa" "chair"
+ #:goes-by '("leather sofa" "plush leather sofa" "sofa"
"leather couch" "plush leather couch" "couch")
#:sit-phrase "sprawl out on"
#:sit-phrase-third-person "sprawls out on into"
#:name "a bar stool"
#:desc " Conveniently located near the bar! Not the most comfortable
seat in the room, though."
- #:goes-by '("stool" "bar stool")
+ #:goes-by '("stool" "bar stool" "seat")
#:sit-phrase "hop on"
#:sit-phrase-third-person "hops onto"
- #:sit-name "the bar stool")))
+ #:sit-name "the bar stool")
+ ('npc:ford-prefect
+ <chatty-npc> 'room:smoking-parlor
+ #:name "Ford Prefect"
+ #:desc "Just some guy, you know?"
+ #:goes-by '("Ford Prefect" "ford prefect"
+ "frood" "prefect" "ford")
+ #:catchphrases prefect-quotes)
+
+ ;; TODO: Cigar dispenser
+
+ ))
+
+\f
+
+;;; Breakroom
+;;; ---------
+
+(define clerk-commands
+ (list
+ (direct-command "talk" 'cmd-chat)
+ (direct-command "chat" 'cmd-chat)
+ (direct-command "ask" 'cmd-ask-incomplete)
+ (prep-direct-command "ask" 'cmd-ask-about)
+ (direct-command "dismiss" 'cmd-dismiss)))
+(define clerk-commands*
+ (append clerk-commands thing-commands*))
+
+(define-class <desk-clerk> (<thing>)
+ ;; The desk clerk has three states:
+ ;; - on-duty: Arrived, and waiting for instructions (and losing patience
+ ;; gradually)
+ ;; - slacking: In the break room, probably smoking a cigarette
+ ;; or checking text messages
+ (state #:init-value 'slacking)
+ (commands #:init-value clerk-commands*)
+ (patience #:init-value 0)
+ (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
+ (<- (actor-id clerk) 'update-loop))
+
+(define clerk-help-topics
+ '(("changing name" .
+ "Changing your name is easy! We have a clipboard here at the desk
+where you can make yourself known to other participants in the hotel
+if you sign it. Try 'sign form as <your-name>', replacing
+<your-name>, obviously!")
+ ("common commands" .
+ "Here are some useful commands you might like to try: chat,
+go, take, drop, say...")
+ ("hotel" .
+ "We hope you enjoy your stay at Hotel Bricabrac. As you may see,
+our hotel emphasizes interesting experiences over rest and lodging.
+The origins of the hotel are... unclear... and it has recently come
+under new... 'management'. But at Hotel Bricabrac we believe these
+aspects make the hotel into a fun and unique experience! Please,
+feel free to walk around and explore.")))
+
+
+(define clerk-knows-about
+ "'ask clerk about changing name', 'ask clerk about common commands', and 'ask clerk about the hotel'")
+
+(define clerk-general-helpful-line
+ (string-append
+ "The clerk says, \"If you need help with anything, feel free to ask me about it.
+For example, 'ask clerk about changing name'. You can ask me about the following:
+" clerk-knows-about ".\"\n"))
+
+(define clerk-slacking-complaints
+ '("The pay here is absolutely lousy."
+ "The owner here has no idea what they're doing."
+ "Some times you just gotta step away, you know?"
+ "You as exhausted as I am?"
+ "Yeah well, this is just temporary. I'm studying to be a high
+energy particle physicist. But ya gotta pay the bills, especially
+with tuition at where it is..."))
+
+(define* (clerk-cmd-chat clerk message #:key direct-obj)
+ (match (slot-ref clerk 'state)
+ ('on-duty
+ (<- (message-from message) 'tell
+ #:text clerk-general-helpful-line))
+ ('slacking
+ (<- (message-from message) 'tell
+ #:text
+ (string-append
+ "The clerk says, \""
+ (random-choice clerk-slacking-complaints)
+ "\"\n")))))
+
+(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 #:key indir-obj
+ #:allow-other-keys)
+ (match (slot-ref clerk 'state)
+ ('on-duty
+ (match (assoc (pk 'indir indir-obj) clerk-help-topics)
+ ((_ . info)
+ (<- (message-from message) 'tell
+ #:text
+ (string-append "The clerk clears her throat and says:\n \""
+ info
+ "\"\n")))
+ (#f
+ (<- (message-from message) 'tell
+ #:text clerk-doesnt-know-text))))
+ ('slacking
+ (<- (message-from message) 'tell
+ #:text "The clerk says, \"Sorry, I'm on my break.\"\n"))))
+
+(define* (clerk-act-be-summoned clerk message #:key who-summoned)
+ (match (slot-ref clerk 'state)
+ ('on-duty
+ (<- 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
+ (<- (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)
+ (<- (gameobj-loc clerk) 'tell-room
+ #:text
+ (string-append
+ " Suddenly, a uniformed woman rushes into the room! She's wearing a
+badge that says \"Desk Clerk\".
+ \"Hello, yes,\" she says between breaths, \"welcome to Hotel Bricabrac!
+We look forward to your stay. If you'd like help getting acclimated,
+feel free to ask me. For example, 'ask clerk about changing name'.
+You can ask me about the following:
+" clerk-knows-about ".\"\n")))))
+
+(define* (clerk-cmd-dismiss clerk message . _)
+ (define player-name
+ (mbody-val (<-wait (message-from message) 'get-name)))
+ (match (slot-ref clerk 'state)
+ ('on-duty
+ (<- (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"
+ player-name)
+ #:exclude (actor-id clerk))
+ (gameobj-set-loc! clerk (dyn-ref clerk 'room:break-room))
+ (slot-set! clerk 'state 'slacking)
+ (<- (gameobj-loc clerk) 'tell-room
+ #:text clerk-return-to-slacking-text
+ #:exclude (actor-id clerk)))
+ ('slacking
+ (<- (message-from message) 'tell
+ #:text "The clerk sternly asks you to not be so dismissive.\n"))))
+
+(define clerk-slacking-texts
+ '("The clerk takes a long drag on her cigarette.\n"
+ "The clerk scrolls through text messages on her phone.\n"
+ "The clerk coughs a few times.\n"
+ "The clerk checks her watch and justifies a few more minutes outside.\n"
+ "The clerk fumbles around for a lighter.\n"
+ "The clerk sighs deeply and exhaustedly.\n"
+ "The clerk fumbles around for a cigarette.\n"))
+
+(define clerk-working-impatience-texts
+ '("The clerk struggles to retain an interested and polite smile.\n"
+ "The clerk checks the time on her phone.\n"
+ "The clerk taps her foot.\n"
+ "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 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
+attend to.\n")
+
+(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)
+ (<- (gameobj-loc clerk) 'tell-room
+ #:text text
+ #:exclude (actor-id clerk)))
+ (define (loop-if-not-destructed)
+ (if (not (slot-ref clerk 'destructed))
+ ;; 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))
+ (8sleep (+ (random 10) 10))
+ (loop-if-not-destructed))
+ ('on-duty
+ (if (> (slot-ref clerk 'patience) 0)
+ ;; Keep working but lose patience gradually
+ (begin
+ (tell-room (random-choice clerk-working-impatience-texts))
+ (slot-set! clerk 'patience (- (slot-ref clerk 'patience)
+ (+ (random 2) 1)))
+ (8sleep (+ (random 25) 20))
+ (loop-if-not-destructed))
+ ;; Back to slacking
+ (begin
+ (tell-room clerk-slack-excuse-text)
+ ;; back bto the break room
+ (gameobj-set-loc! clerk (pk 'break-room (dyn-ref clerk 'room:break-room)))
+ (tell-room clerk-return-to-slacking-text)
+ ;; annnnnd back to slacking
+ (slot-set! clerk 'state 'slacking)
+ (8sleep (+ (random 30) 15))
+ (loop-if-not-destructed))))))
+
+
+(define break-room
+ (lol
+ ('room:break-room
+ <room> #f
+ #:name "Employee Break Room"
+ #:desc " This is less a room and more of an outdoor wire cage. You get
+a bit of a view of the brick exterior of the building, and a crisp wind blows,
+whistling, through the openings of the fenced area. Partly smoked cigarettes
+and various other debris cover the floor.
+ Through the wires you can see... well... hm. It looks oddly like
+the scenery tapers off nothingness. But that can't be right, can it?"
+ #:exits
+ (list (make <exit>
+ #:name "north"
+ #:to 'room:smoking-parlor))
+ )
+ ('npc:break-room:desk-clerk
+ <desk-clerk> 'room:break-room
+ #:name "the hotel desk clerk"
+ #:desc " The hotel clerk is wearing a neatly pressed uniform bearing the
+hotel insignia. She looks like she'd much rather be somewhere else."
+ #:goes-by '("hotel desk clerk" "clerk" "desk clerk"))))
+
\f
;;; Ennpie's Sea Lounge
;;; ----
(define game-spec
- (append lobby grand-hallway smoking-parlor))
+ (append lobby grand-hallway smoking-parlor
+ playroom break-room))
;; TODO: Provide command line args
(define (run-game . args)
projects / mudsync.git / blobdiff