;;; Hotel Bricabrac
(use-modules (mudsync)
- (mudsync parser)
- (8sync actors)
- (8sync agenda)
+ (mudsync container)
+ (8sync)
(oop goops)
(ice-9 control)
(ice-9 format)
;;; Some simple object types.
;;; =========================
-(define readable-commands
- (list
- (direct-command "read" 'cmd-read)))
-
-(define readable-commands*
- (append readable-commands
- thing-commands))
-
-(define-class <readable> (<thing>)
+(define-class <readable> (<gameobj>)
(read-text #:init-value "All it says is: \"Blah blah blah.\""
#:init-keyword #:read-text)
(commands
- #:init-value readable-commands*)
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("read" ((direct-command cmd-read)))))
(actions #:allocation #:each-subclass
- #:init-value (build-actions
+ #:init-thunk (build-actions
(cmd-read readable-cmd-read))))
-(define (readable-cmd-read actor message)
+(define (readable-cmd-read actor message . _)
(<- (message-from message) 'tell
- #:text (string-append (slot-ref actor 'read-text) "\n")))
+ #:text (slot-ref actor 'read-text)))
+
+
+;; This one allows you to take from items that are proxied by it
+(define-actor <proxy-items> (<gameobj>)
+ ((cmd-take-from take-from-proxy))
+ (proxy-items #:init-keyword #:proxy-items))
+
+(define* (take-from-proxy gameobj message
+ #:key direct-obj indir-obj preposition
+ (player (message-from message)))
+ (call/ec
+ (lambda (escape)
+ (for-each
+ (lambda (obj-sym)
+ (define obj-id (dyn-ref gameobj obj-sym))
+ (define goes-by
+ (mbody-val (<-wait obj-id 'goes-by)))
+ (when (ci-member direct-obj goes-by)
+ (<- obj-id 'cmd-take #:direct-obj direct-obj #:player player)
+ (escape #f)))
+ (slot-ref gameobj 'proxy-items))
+
+ (<- player 'tell
+ #:text `("You don't see any such " ,direct-obj " to take "
+ ,preposition " " ,(slot-ref gameobj 'name) ".")))))
\f
(<- (message-from message) 'tell
#:text text-to-send))
-(define chat-commands
- (list
- (direct-command "chat" 'cmd-chat)
- (direct-command "talk" 'cmd-chat)))
-
(define hotel-owner-grumps
'("Eight sinks! Eight sinks! And I couldn't unwind them..."
"Don't mind the mess. I built this place on a dare, you
(catchphrases #:init-value '("Blarga blarga blarga!")
#:init-keyword #:catchphrases)
(commands
- #:init-value chat-commands)
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ (("chat" "talk") ((direct-command cmd-chat)))))
(actions #:allocation #:each-subclass
- #:init-value
+ #:init-thunk
(build-actions
(cmd-chat npc-chat-randomly))))
(define-class <sign-in-form> (<gameobj>)
(commands
- #:init-value
- (list
- (prep-direct-command "sign" 'cmd-sign-form
- '("as"))))
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("sign" ((prep-direct-command cmd-sign-form '("as"))))))
+
(actions #:allocation #:each-subclass
- #:init-value (build-actions
+ #:init-thunk (build-actions
(cmd-sign-form sign-cmd-sign-in))))
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>)
+(define-class <summoning-bell> (<gameobj>)
(summons #:init-keyword #:summons)
(commands
- #:init-value summoning-bell-commands*)
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("ring" ((direct-command cmd-ring)))))
(actions #:allocation #:each-subclass
- #:init-value (build-actions
+ #:init-thunk (build-actions
(cmd-ring summoning-bell-cmd-ring))))
(define* (summoning-bell-cmd-ring bell message . _)
"How can you have money if none of you produces anything?"
"On no account allow Arthur to request tea on this ship."))
+(define-class <cabinet-item> (<gameobj>)
+ (take-me? #:init-value
+ (lambda _
+ (values #f #:why-not
+ `("Hm, well... the cabinet is locked and the properitor "
+ "is right over there.")))))
+
(define lobby
(lol
- ('room:lobby
+ ('lobby
<room> #f
#:name "Hotel Lobby"
#:desc
#:exits
(list (make <exit>
#:name "north"
- #:to 'room:grand-hallway)))
+ #:to 'grand-hallway)))
;; NPC: hotel owner
- ('npc:lobby:hotel-owner
- <chatty-npc> 'room:lobby
+ ('lobby:hotel-owner
+ <chatty-npc> 'lobby
#:name "a frumpy fellow"
#:desc
'((p " Whoever this is, they looks totally exhausted. They're
"hotel proprietor" "proprietor")
#:catchphrases hotel-owner-grumps)
;; Object: Sign
- ('thing:lobby:sign
- <readable> 'room:lobby
+ ('lobby:sign
+ <readable> 'lobby
#:name "the Hotel Bricabrac sign"
#:desc " It strikes you that there's something funny going on with this sign.
Sure enough, if you look at it hard enough, you can tell that someone
"hotel bricabrac sign"
"lobby sign"))
- ('thing:lobby:bell
- <summoning-bell> 'room:lobby
+ ('lobby:bell
+ <summoning-bell> '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)
+ #:summons 'break-room:desk-clerk)
+
+ ('lobby:sign-in-form
+ <sign-in-form> 'lobby
+ #:name "sign-in form"
+ #:goes-by '("sign-in form" "form" "signin form")
+ #:desc '("It looks like you could sign this form and set your name like so: "
+ (i "sign form as <my-name-here>")))
;; Object: curio cabinets
- ('thing:lobby:cabinet
- <gameobj> 'room:lobby
+ ;; TODO: respond to attempts to open the curio cabinet
+ ('lobby:cabinet
+ <proxy-items> 'lobby
+ #:proxy-items '(lobby:porcelain-doll
+ lobby:1950s-robots
+ lobby:tea-set lobby:mustard-pot
+ lobby:head-of-elvis lobby:circuitboard-of-evlis
+ lobby:teletype-scroll lobby:orange-cat-phone)
#:name "a curio cabinet"
#:goes-by '("curio cabinet" "cabinet" "bricabrac cabinet"
"cabinet of curiosities")
"the pickled circuitboard of EVLIS"
"a scroll of teletype paper holding the software Four Freedoms"
"a telephone shaped like an orange cartoon cat")))))
- ('thing:lobby:sign-in-form
- <sign-in-form> 'room:lobby
- #:name "sign-in form"
- #:goes-by '("sign-in form" "form" "signin form")
- #:desc "It looks like you could sign this form and set your name.")
- ('thing:lobby:porcelain-doll
- <thing> 'room:lobby
- #:generally-visible #f
+ ('lobby:porcelain-doll
+ <cabinet-item> 'lobby
+ #:invisible? #t
#:name "a creepy porcelain doll"
#:desc "It strikes you that while the doll is technically well crafted,
it's also the stuff of nightmares."
#:goes-by '("porcelain doll" "doll"))
- ('thing:lobby:1950s-robots
- <thing> 'room:lobby
- #:generally-visible #f
+ ('lobby:1950s-robots
+ <cabinet-item> 'lobby
+ #:invisible? #t
#:name "a set of 1950s robots"
#:desc "There's a whole set of these 1950s style robots.
They seem to be stamped out of tin, and have various decorations of levers
and buttons and springs. Some of them have wind-up knobs on them."
#:goes-by '("robot" "robots" "1950s robot" "1950s robots"))
- ('thing:lobby:tea-set
- <thing> 'room:lobby
- #:generally-visible #f
+ ('lobby:tea-set
+ <cabinet-item> 'lobby
+ #:invisible? #t
#:name "a tea set"
#:desc "A complete tea set. Some of the cups are chipped.
You can imagine yourself joining a tea party using this set, around a
nice table with some doilies, drinking some Earl Grey tea, hot. Mmmm."
#:goes-by '("tea set" "tea"))
- ('thing:lobby:mustard-pot
- <thing> 'room:lobby
- #:generally-visible #f
+ ('lobby:mustard-pot
+ <cabinet-item> 'lobby
+ #:invisible? #t
#:name "a mustard pot"
#:desc '((p "It's a mustard pot. I mean, it's kind of cool, it has a
nice design, and it's an antique, but you can't imagine putting something
like this in a museum.")
(p "Ha... imagine that... a mustard museum."))
#:goes-by '("mustard pot" "antique mustard pot" "mustard"))
- ('thing:lobby:head-of-elvis
- <thing> 'room:lobby
- #:generally-visible #f
+ ('lobby:head-of-elvis
+ <cabinet-item> 'lobby
+ #:invisible? #t
#:name "the pickled head of Elvis"
#:desc '((p "It's a jar full of some briny-looking liquid and...
a free floating head. The head looks an awful lot like Elvis, and
everything you read."))
#:goes-by '("pickled head of elvis" "pickled head of Elvis"
"elvis" "Elvis" "head" "pickled head"))
- ('thing:lobby:circuitboard-of-evlis
- <thing> 'room:lobby
- #:generally-visible #f
+ ('lobby:circuitboard-of-evlis
+ <cabinet-item> 'lobby
+ #:invisible? #t
#:name "the pickled circuitboard of Evlis"
- #:desc '((p "It's a circuitboard from a Lisp Machine called Evlis.
+ #:desc '((p "It's a circuitboard from a Lisp Machine called EVLIS.
This is quite the find, and you bet just about anyone interested in
preserving computer history would love to get their hands on this.")
(p "Unfortunately, whatever moron did acquire this has
#:goes-by '("pickled circuitboard of evlis" "pickled circuitboard of Evlis"
"pickled circuitboard of EVLIS"
"evlis" "Evlis" "EVLIS" "circuitboard" "pickled circuitboard"))
- ('thing:lobby:teletype-scroll
- <thing> 'room:lobby
- #:generally-visible #f
+ ('lobby:teletype-scroll
+ <cabinet-item> 'lobby
+ #:invisible? #t
#:name "a scroll of teletype"
#:desc '((p "This is a scroll of teletype paper. It's a bit old
and yellowed but the type is very legible. It says:")
"teletype paper" "scroll" "four freedoms"
"scroll of teletype paper holding the software Four Freedoms"
"scroll of teletype paper holding the software four freedoms"))
- ('thing:lobby:orange-cat-phone
- <thing> 'room:lobby
- #:generally-visible #f
+ ('lobby:orange-cat-phone
+ <cabinet-item> 'lobby
+ #:invisible? #t
#:name "a telephone shaped like an orange cartoon cat"
#:desc "It's made out of a cheap plastic, and it's very orange.
It resembles a striped tabby, and it's eyes hold the emotion of
;;; Grand hallway
;;; -------------
+(define-actor <disc-shield> (<gameobj>)
+ ((cmd-take disc-shield-take)))
+
+(define* (disc-shield-take gameobj message
+ #:key direct-obj
+ (player (message-from message)))
+ (create-gameobj <glowing-disc> (gameobj-gm gameobj)
+ player) ;; set loc to player to put in player's inventory
+ (<- player 'tell
+ #:text '((p "As you attempt to pull the shield / disk platter
+from the statue a shining outline appears around it... and a
+completely separate, glowing copy of the disc materializes into your
+hands!")))
+ (<- (gameobj-loc gameobj) 'tell-room
+ #:text `(,(mbody-val (<-wait player 'get-name))
+ " pulls on the shield of the statue, and a glowing "
+ "copy of it materializes into their hands!")
+ #:exclude player)
+ (<- (gameobj-loc gameobj) 'tell-room
+ #:text
+ '(p "You hear a voice whisper: "
+ (i "\"Share the software... and you'll be free...\""))))
+
+;;; This is the disc that gets put in the player's inventory
+(define-actor <glowing-disc> (<gameobj>)
+ ((cmd-drop glowing-disc-drop-cmd))
+ (initial-props
+ #:allocation #:each-subclass
+ #:init-thunk (build-props
+ '((hd-platter? . #t))))
+ (name #:allocation #:each-subclass
+ #:init-value "a glowing disc")
+ (desc #:allocation #:each-subclass
+ #:init-value "A brightly glowing disc. It's shaped like a hard
+drive platter, not unlike the one from the statue it came from. It's
+labeled \"RL02.5\".")
+ (goes-by #:init-value '("glowing disc" "glowing platter"
+ "glowing disc platter" "glowing disk platter"
+ "platter" "disc" "disk" "glowing shield")))
+
+(define* (glowing-disc-drop-cmd gameobj message
+ #:key direct-obj
+ (player (message-from message)))
+ (<- player 'tell
+ #:text "You drop the glowing disc, and it shatters into a million pieces!")
+ (<- (mbody-val (<-wait player 'get-loc)) 'tell-room
+ #:text `(,(mbody-val (<-wait player 'get-name))
+ " drops a glowing disc, and it shatters into a million pieces!")
+ #:exclude player)
+ (gameobj-self-destruct gameobj))
+
+\f
+;;; Grand hallway
+
+(define lobby-map-text
+ "\
+ | : : |
+ .----------.----------. : & : .----------.----------.
+ | computer | |& :YOU ARE: &| smoking | *UNDER* |
+ | room + playroom + : HERE : + parlor | *CONS- |
+ | > | |& : : &| | TRUCTION*|
+ '----------'----------'-++-------++-'-------+--'----------'
+ | '-----' | | |
+ : LOBBY : '---'
+ '. .'
+ '---------'")
+
(define grand-hallway
(lol
- ('room:grand-hallway
+ ('grand-hallway
<room> #f
#:name "Grand Hallway"
- #:desc " A majestic red carpet runs down the center of the room.
+ #:desc '((p " A majestic red carpet runs down the center of the room.
Busts of serious looking people line the walls, but there's no
-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. A door to the east is labeled \"smoking
-room\", while a door to the west is labeled \"playroom\"."
+clear indication that they have any logical relation to this place.")
+ (p "In the center is a large statue of a woman in a warrior's
+pose, but something is strange about her weapon and shield. You wonder what
+that's all about?")
+ (p "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)
+ #:to 'lobby)
(make <exit>
#:name "west"
- #:to 'room:playroom)
+ #:to 'playroom)
(make <exit>
#:name "east"
- #:to 'room:smoking-parlor)))
- ('thing:ignucius-statue
- <gameobj> 'room:grand-hallway
- #:name "a statue"
- #:desc " The statue is of a serious-looking bearded man with long, flowing hair.
- It has a large physical halo. Removing it is tempting, but it looks pretty
-well fastened."
- #:goes-by '("statue" "st ignucius" "st. ignucius"))))
+ #:to 'smoking-parlor)))
+ ('grand-hallway:map
+ <readable> 'grand-hallway
+ #:name "the hotel map"
+ #:desc '("This appears to be a map of the hotel. "
+ "Like the hotel itself, it seems to be "
+ "incomplete."
+ "You could read it if you want to.")
+ #:read-text `(pre ,lobby-map-text)
+ #:goes-by '("map" "hotel map"))
+ ('grand-hallway:carpet
+ <gameobj> 'grand-hallway
+ #:name "the Grand Hallway carpet"
+ #:desc "It's very red, except in the places where it's very worn."
+ #:invisible? #t
+ #:goes-by '("red carpet" "carpet"))
+ ('grand-hallway:busts
+ <gameobj> 'grand-hallway
+ #:name "the busts of serious people"
+ #:desc "There are about 6 of them in total. They look distinguished
+but there's no indication of who they are."
+ #:invisible? #t
+ #:goes-by '("busts" "bust" "busts of serious people" "bust of serious person"))
+ ('grand-hallway:hackthena-statue
+ <proxy-items> 'grand-hallway
+ #:name "the statue of Hackthena"
+ #:desc '((p "The base of the statue says \"Hackthena, guardian of the hacker
+spirit\". You've heard of Hackthena... not a goddess, but spiritual protector of
+all good hacks, and legendary hacker herself.")
+ (p "Hackthena holds the form of a human woman. She wears flowing
+robes, has a pear of curly bovine-esque horns protruding from the sides of her
+head, wears a pair of horn-rimmed glasses, and appears posed as if for battle.
+But instead of a weapon, she seems to hold some sort of keyboard. And her
+shield... well it's round like a shield, but something seems off about it.
+You'd better take a closer look to be sure."))
+ #:goes-by '("hackthena statue" "hackthena" "statue" "statue of hackthena")
+ #:proxy-items '(grand-hallway:keyboard
+ grand-hallway:disc-platter
+ grand-hallway:hackthena-horns))
+ ('grand-hallway:keyboard
+ <gameobj> 'grand-hallway
+ #:name "a Knight Keyboard"
+ #:desc "Whoa, this isn't just any old keyboard, this is a Knight Keyboard!
+Any space cadet can see that with that kind of layout a hack-and-slayer could
+thrash out some serious key-chords like there's no tomorrow. You guess
+Hackthena must be an emacs user."
+ #:invisible? #t
+ #:take-me? (lambda _
+ (values #f
+ #:why-not
+ `("Are you kidding? Do you know how hard it is to find "
+ "a Knight Keyboard? There's no way she's going "
+ "to give that up.")))
+ #:goes-by '("knight keyboard" "keyboard"))
+ ('grand-hallway:hackthena-horns
+ <gameobj> 'grand-hallway
+ #:name "Hackthena's horns"
+ #:desc "They're not unlike a Gnu's horns."
+ #:invisible? #t
+ #:take-me? (lambda _
+ (values #f
+ #:why-not
+ `("Are you seriously considering desecrating a statue?")))
+ #:goes-by '("hackthena's horns" "horns" "horns of hacktena"))
+ ('grand-hallway:disc-platter
+ <disc-shield> 'grand-hallway
+ #:name "Hackthena's shield"
+ #:desc "No wonder the \"shield\" looks unusual... it seems to be a hard disk
+platter! It has \"RL02.5\" written on it. It looks kind of loose."
+ #:invisible? #t
+ #:goes-by '("hackthena's shield" "shield" "platter" "hard disk platter"))))
\f
;;; Playroom
(define playroom
(lol
- ('room:playroom
+ ('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."
+ #:desc '(p (" There are toys scattered everywhere here. It's really unclear
+if this room is intended for children or child-like adults.")
+ (" There are doors to both the east and the west."))
#:exits
(list (make <exit>
#:name "east"
- #:to 'room:grand-hallway)))
- ('thing:playroom:cubey
- <thing> 'room:playroom
- #:name "cubey"
- #:takeable #t
+ #:to 'grand-hallway)
+ (make <exit>
+ #:name "west"
+ #:to 'computer-room)))
+ ('playroom:cubey
+ <gameobj> 'playroom
+ #:name "Cubey"
+ #:take-me? #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"
+ ('playroom:cuddles-plushie
+ <gameobj> 'playroom
+ #:name "a Cuddles plushie"
#:goes-by '("plushie" "cuddles plushie" "cuddles")
- #:takeable #t
- #:desc " A warm and fuzzy cuddles plushie! It's a cuddlefish!")))
+ #:take-me? #t
+ #:desc " A warm and fuzzy cuddles plushie! It's a cuddlefish!")
+
+ ('playroom:toy-chest
+ <container> 'playroom
+ #:name "a toy chest"
+ #:goes-by '("toy chest" "chest")
+ #:desc (lambda (toy-chest whos-looking)
+ (let ((contents (gameobj-occupants toy-chest)))
+ `((p "A brightly painted wooden chest. The word \"TOYS\" is "
+ "engraved on it.")
+ (p "Inside you see:"
+ ,(if (eq? contents '())
+ " nothing! It's empty!"
+ `(ul ,(map (lambda (occupant)
+ `(li ,(mbody-val
+ (<-wait occupant 'get-name))))
+ (gameobj-occupants toy-chest))))))))
+ #:take-from-me? #t
+ #:put-in-me? #t)
+
+ ;; Things inside the toy chest
+ ('playroom:toy-chest:rubber-duck
+ <gameobj> 'playroom:toy-chest
+ #:name "a rubber duck"
+ #:goes-by '("rubber duck" "duck")
+ #:take-me? #t
+ #:desc "It's a yellow rubber duck with a bright orange beak.")))
\f
(sit-name #:init-keyword #:sit-name)
(commands
- #:init-value
- (list
- (direct-command "sit" 'cmd-sit-furniture)))
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("sit" ((direct-command cmd-sit-furniture)))))
(actions #:allocation #:each-subclass
- #:init-value (build-actions
+ #:init-thunk (build-actions
(cmd-sit-furniture furniture-cmd-sit))))
(define* (furniture-cmd-sit actor message #:key direct-obj)
(define smoking-parlor
(lol
- ('room:smoking-parlor
+ ('smoking-parlor
<room> #f
#:name "Smoking Parlor"
#:desc
#:exits
(list (make <exit>
#:name "west"
- #:to 'room:grand-hallway)
+ #:to 'grand-hallway)
(make <exit>
#:name "south"
- #:to 'room:break-room)))
- ('thing:smoking-parlor:chair
- <furniture> 'room:smoking-parlor
+ #:to 'break-room)))
+ ('smoking-parlor:chair
+ <furniture> 'smoking-parlor
#:name "a comfy leather chair"
#:desc " That leather chair looks really comfy!"
#:goes-by '("leather chair" "comfy leather chair" "chair")
#:sit-phrase "sink into"
#:sit-phrase-third-person "sinks into"
#:sit-name "the comfy leather chair")
- ('thing:smoking-parlor:sofa
- <furniture> 'room:smoking-parlor
+ ('smoking-parlor:sofa
+ <furniture> 'smoking-parlor
#:name "a plush leather sofa"
#:desc " That leather chair looks really comfy!"
#:goes-by '("leather sofa" "plush leather sofa" "sofa"
#:sit-phrase "sprawl out on"
#:sit-phrase-third-person "sprawls out on into"
#:sit-name "the plush leather couch")
- ('thing:smoking-parlor:bar-stool
- <furniture> 'room:smoking-parlor
+ ('smoking-parlor:bar-stool
+ <furniture> 'smoking-parlor
#:name "a bar stool"
#:desc " Conveniently located near the bar! Not the most comfortable
seat in the room, though."
#:sit-phrase "hop on"
#:sit-phrase-third-person "hops onto"
#:sit-name "the bar stool")
- ('npc:ford-prefect
- <chatty-npc> 'room:smoking-parlor
+ ('ford-prefect
+ <chatty-npc> 'smoking-parlor
#:name "Ford Prefect"
#:desc "Just some guy, you know?"
#:goes-by '("Ford Prefect" "ford prefect"
"frood" "prefect" "ford")
#:catchphrases prefect-quotes)
- ('thing:smoking-parlor:no-smoking-sign
- <thing> 'room:smoking-parlor
- #:generally-visible #f
+ ('smoking-parlor:no-smoking-sign
+ <gameobj> 'smoking-parlor
+ #:invisible? #t
#:name "No Smoking Sign"
#:desc "This sign says \"No Smoking\" in big, red letters.
It has some bits of bubble gum stuck to it... yuck."
;;; 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>)
+(define-class <desk-clerk> (<gameobj>)
;; 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*)
+ (commands #:allocation #:each-subclass
+ #:init-thunk
+ (build-commands
+ (("talk" "chat") ((direct-command cmd-chat)))
+ ("ask" ((direct-command cmd-ask-incomplete)
+ (prep-direct-command cmd-ask-about)))
+ ("dismiss" ((direct-command cmd-dismiss)))))
(patience #:init-value 0)
(actions #:allocation #:each-subclass
- #:init-value (build-actions
+ #:init-thunk (build-actions
(init clerk-act-init)
(cmd-chat clerk-cmd-chat)
(cmd-ask-incomplete clerk-cmd-ask-incomplete)
#:allow-other-keys)
(match (slot-ref clerk 'state)
('on-duty
- (match (assoc (pk 'indir indir-obj) clerk-help-topics)
+ (match (assoc indir-obj clerk-help-topics)
((_ . info)
(<- (message-from message) 'tell
#:text
#: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))
+ (gameobj-set-loc! clerk (dyn-ref clerk 'lobby))
(slot-set! clerk 'patience 8)
(slot-set! clerk 'state 'on-duty)
(<- (gameobj-loc clerk) 'tell-room
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))
+ (gameobj-set-loc! clerk (dyn-ref clerk 'break-room))
(slot-set! clerk 'state 'slacking)
(<- (gameobj-loc clerk) 'tell-room
#:text clerk-return-to-slacking-text
(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)))
+ (gameobj-set-loc! clerk (dyn-ref clerk 'break-room))
(tell-room clerk-return-to-slacking-text)
;; annnnnd back to slacking
(slot-set! clerk 'state 'slacking)
(define break-room
(lol
- ('room:break-room
+ ('break-room
<room> #f
#:name "Employee Break Room"
#:desc " This is less a room and more of an outdoor wire cage. You get
#:exits
(list (make <exit>
#:name "north"
- #:to 'room:smoking-parlor))
- )
- ('npc:break-room:desk-clerk
- <desk-clerk> 'room:break-room
+ #:to 'smoking-parlor)))
+ ('break-room:desk-clerk
+ <desk-clerk> '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."
+hotel insignia. She appears to be rather exhausted."
#:goes-by '("hotel desk clerk" "clerk" "desk clerk"))
- ('thing:break-room:void
- <thing> 'room:break-room
- #:generally-visible #f
+ ('break-room:void
+ <gameobj> 'break-room
+ #:invisible? #t
#:name "The Void"
#:desc "As you stare into the void, the void stares back into you."
- #:goes-by '("void" "abyss" "nothingness"))))
+ #:goes-by '("void" "abyss" "nothingness" "scenery"))
+ ('break-room:fence
+ <gameobj> 'break-room
+ #:invisible? #t
+ #:name "break room cage"
+ #:desc "It's a mostly-cubical wire mesh surrounding the break area.
+You can see through the gaps, but they're too small to put more than a
+couple of fingers through. There appears to be some wear and tear to
+the paint, but the wires themselves seem to be unusually sturdy."
+ #:goes-by '("fence" "cage" "wire cage"))))
\f
;;; Computer room
;;; -------------
+;; Our computer and hard drive are based off the PDP-11 and the RL01 /
+;; RL02 disk drives. However we increment both by .5 (a true heresy)
+;; to distinguish both from the real thing.
+
+(define-actor <hard-drive> (<gameobj>)
+ ((cmd-put-in hard-drive-insert)
+ (cmd-push-button hard-drive-push-button)
+ (get-state hard-drive-act-get-state))
+ (commands #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("insert" ((prep-indir-command cmd-put-in
+ '("in" "inside" "into"))))
+ (("press" "push") ((prep-indir-command cmd-push-button)))))
+ ;; the state moves from: empty -> with-disc -> loading -> ready
+ (state #:init-value 'empty
+ #:accessor .state))
+
+(define (hard-drive-act-get-state hard-drive message)
+ (<-reply message (.state hard-drive)))
+
+(define* (hard-drive-desc hard-drive #:optional whos-looking)
+ `((p "The hard drive is labeled \"RL02.5\". It's a little under a meter tall.")
+ (p "There is a slot where a disk platter could be inserted, "
+ ,(if (eq? (.state hard-drive) 'empty)
+ "which is currently empty"
+ "which contains a glowing platter")
+ ". There is a LOAD button "
+ ,(if (member (.state hard-drive) '(empty with-disc))
+ "which is glowing"
+ "which is pressed in and unlit")
+ ". There is a READY indicator "
+ ,(if (eq? (.state hard-drive) 'ready)
+ "which is glowing."
+ "which is unlit.")
+ ,(if (member (.state hard-drive) '(loading ready))
+ " The machine emits a gentle whirring noise."
+ ""))))
+
+(define* (hard-drive-push-button gameobj message
+ #:key direct-obj indir-obj preposition
+ (player (message-from message)))
+ (define (tell-room text)
+ (<-wait (gameobj-loc gameobj) 'tell-room
+ #:text text))
+ (define (tell-room-excluding-player text)
+ (<-wait (gameobj-loc gameobj) 'tell-room
+ #:text text
+ #:exclude player))
+ (cond
+ ((ci-member direct-obj '("button" "load button" "load"))
+ (tell-room-excluding-player
+ `(,(mbody-val (<-wait player 'get-name))
+ " presses the button on the hard disk."))
+ (<- player 'tell
+ #:text "You press the button on the hard disk.")
+
+ (case (.state gameobj)
+ ((empty)
+ ;; I have no idea what this drive did when you didn't have a platter
+ ;; in it and pressed load, but I know there was a FAULT button.
+ (tell-room "You hear some movement inside the hard drive...")
+ (8sleep 1.5)
+ (tell-room
+ '("... but then the FAULT button blinks a couple times. "
+ "What could be missing?")))
+ ((with-disc)
+ (set! (.state gameobj) 'loading)
+ (tell-room "The hard disk begins to spin up!")
+ (8sleep 2)
+ (set! (.state gameobj) 'ready)
+ (tell-room "The READY light turns on!"))
+ ((loading ready)
+ (<- player 'tell
+ #:text '("Pressing the button does nothing right now, "
+ "but it does feel satisfying.")))))
+ (else
+ (<- player 'tell
+ #:text '("How could you think of pressing anything else "
+ "but that tantalizing button right in front of you?")))))
+
+(define* (hard-drive-insert gameobj message
+ #:key direct-obj indir-obj preposition
+ (player (message-from message)))
+ (define our-name (slot-ref gameobj 'name))
+ (define this-thing
+ (call/ec
+ (lambda (return)
+ (for-each (lambda (occupant)
+ (define goes-by (mbody-val (<-wait occupant 'goes-by)))
+ (when (ci-member direct-obj goes-by)
+ (return occupant)))
+ (mbody-val (<-wait player 'get-occupants)))
+ ;; nothing found
+ #f)))
+ (cond
+ ((not this-thing)
+ (<- player 'tell
+ #:text `("You don't seem to have any such " ,direct-obj " to put "
+ ,preposition " " ,our-name ".")))
+ ((not (mbody-val (<-wait this-thing 'get-prop 'hd-platter?)))
+ (<- player 'tell
+ #:text `("It wouldn't make sense to put "
+ ,(mbody-val (<-wait this-thing 'get-name))
+ " " ,preposition " " ,our-name ".")))
+ ((not (eq? (.state gameobj) 'empty))
+ (<- player 'tell
+ #:text "The disk drive already has a platter in it."))
+ (else
+ (set! (.state gameobj) 'with-disc)
+ (<- player 'tell
+ #:text '((p "You insert the glowing disc into the drive.")
+ (p "The LOAD button begins to glow."))))))
+
+;; The computar
+(define-actor <computer> (<gameobj>)
+ ((cmd-run-program computer-run-program)
+ (cmd-run-what (lambda (gameobj message . _)
+ (<- (message-from message) 'tell
+ #:text '("The computer is already running, and a program appears "
+ "ready to run."
+ "you mean to \"run the program on the computer\"")))))
+ (commands #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("run" ((prep-indir-command cmd-run-program
+ '("on"))
+ (direct-command cmd-run-what))))))
+
+(define* (computer-run-program gameobj message
+ #:key direct-obj indir-obj preposition
+ (player (message-from message)))
+ (define (hd-state)
+ (mbody-val (<-wait (dyn-ref gameobj 'computer-room:hard-drive) 'get-state)))
+ (define (tell-room text)
+ (<-wait (gameobj-loc gameobj) 'tell-room
+ #:text text))
+ (define (tell-room-excluding-player text)
+ (<-wait (gameobj-loc gameobj) 'tell-room
+ #:text text
+ #:exclude player))
+ (define (tell-player text)
+ (<-wait player 'tell
+ #:text text))
+ (cond
+ ((ci-member direct-obj '("program"))
+ (tell-room-excluding-player
+ `(,(mbody-val (<-wait player 'get-name))
+ " runs the program loaded on the computer..."))
+ (tell-player "You run the program on the computer...")
+
+ (cond
+ ((not (eq? (hd-state) 'ready))
+ (tell-room '("... but it errors out. "
+ "It seems to be complaining about a " (b "DISK ERROR!")
+ ". It looks like it is missing some essential software.")))
+ (else
+ (<- (dyn-ref gameobj 'computer-room:floor-panel) 'open-up))))))
+
+
+;; floor panel
+(define-actor <floor-panel> (<gameobj>)
+ ;; TODO: Add "open" verb, since obviously people will try that
+ ((open? (lambda (panel message)
+ (<-reply message (slot-ref panel 'open))))
+ (open-up floor-panel-open-up))
+ (open #:init-value #f))
+
+(define (floor-panel-open-up panel message)
+ (if (slot-ref panel 'open)
+ (<- (gameobj-loc panel) 'tell-room
+ #:text '("You hear some gears grind around the hinges of the "
+ "floor panel, but it appears to already be open."))
+ (begin
+ (slot-set! panel 'open #t)
+ (<- (gameobj-loc panel) 'tell-room
+ #:text '("You hear some gears grind, as the metal panel on "
+ "the ground opens and reveals a stairwell going down!")))))
+
+(define* (floor-panel-desc panel #:optional whos-looking)
+ `("It's a large metal panel on the floor in the middle of the room. "
+ ,(if (slot-ref panel 'open)
+ '("It's currently wide open, revealing a spiraling staircase "
+ "which descends into darkness.")
+ '("It's currently closed shut, but there are clearly hinges, and "
+ "it seems like there is a mechanism which probably opens it via "
+ "some automation. What could be down there?"))))
+
+(define computer-room
+ (lol
+ ('computer-room
+ <room> #f
+ #:name "Computer Room"
+ #:desc (lambda (gameobj whos-looking)
+ (define panel-open
+ (mbody-val (<-wait (dyn-ref gameobj 'computer-room:floor-panel)
+ 'open?)))
+ `((p "A sizable computer cabinet covers a good portion of the left
+ wall. It emits a pleasant hum which covers the room like a warm blanket.
+ Connected to a computer is a large hard drive.")
+ (p "On the floor is a large steel panel. "
+ ,(if panel-open
+ '("It is wide open, exposing a spiral staircase "
+ "which descends into darkness.")
+ '("It is closed, but it has hinges which "
+ "suggest it could be opened.")))))
+ #:exits
+ (list (make <exit>
+ #:name "east"
+ #:to 'playroom)
+ (make <exit>
+ #:name "down"
+ #:to 'underground-lab
+ #:traverse-check
+ (lambda (exit room whos-exiting)
+ (define panel-open
+ (mbody-val (<-wait (dyn-ref room 'computer-room:floor-panel)
+ 'open?)))
+ (if panel-open
+ (values #t "You descend the spiral staircase.")
+ (values #f '("You'd love to go down, but the only way "
+ "through is through that metal panel, "
+ "which seems closed.")))))))
+ ('computer-room:hard-drive
+ <hard-drive> 'computer-room
+ #:name "the hard drive"
+ #:desc (wrap-apply hard-drive-desc)
+ #:goes-by '("hard drive" "drive" "hard disk"))
+ ('computer-room:computer
+ <computer> 'computer-room
+ #:name "the computer"
+ #:desc '((p "It's a coat closet sized computer labeled \"PDP-11.5\". ")
+ (p "The computer is itself turned on, and it looks like it is "
+ "all set up for you to run a program on it."))
+ #:goes-by '("computer"))
+ ('computer-room:floor-panel
+ <floor-panel> 'computer-room
+ #:name "a floor panel"
+ #:desc (wrap-apply floor-panel-desc)
+ #:invisible? #t
+ #:goes-by '("floor panel" "panel"))))
+
+\f
+;;; * UNDERGROUND SECTION OF THE GAME! *
+
+\f
+;;; The lab
+
+(define underground-map-text
+ "\
+ _______ |
+ .-' @ '-. \\ ?????
+ .' '. .\\
+ | [8sync Hive] |======' '-_____
+ ', M ,'
+ '. @ .'
+ \\ @ /
+ '-__+__-'
+ '. @ .'
+ .--------------. \\ /
+ | [Guile Async | .-------+------.
+ | Museum] | | [Lab] #!#| .-------------.
+ | @| | MM | |[Federation |
+ | & ^ +##+@ || < +##| Station]|
+ | | | @ | | |
+ | & # | |*You-Are-Here*| '-------------'
+ | # ^ | #+-------+------'
+ '-------+------' # #
+ # # #
+ # # .-----------.
+ .-+----. # |# F |
+ |@?+%? +#### | ^ f## |
+ '------' | f f %|
+ |F [Mudsync |
+ | $ Swamp] |
+ '-----------'")
+
+(define underground-lab
+ (lol
+ ('underground-lab
+ <room> #f
+ #:name "Underground laboratory"
+ #:desc '("This appears to be some sort of underground laboratory. "
+ )
+ #:exits
+ (list (make <exit>
+ #:name "up"
+ #:to 'computer-room
+ #:traverse-check
+ (lambda (exit room whos-exiting)
+ (values #t "You climb the spiral staircase.")))))
+
+ ;; Test tubes
+ ;; map
+ ('underground-lab:map
+ <readable> 'underground-lab
+ #:name "the underground map"
+ #:desc '("This appears to be a map of the surrounding area. "
+ "You could read it if you want to.")
+ #:read-text `(pre ,underground-map-text)
+ #:goes-by '("map" "underground map" "lab map"))))
+
+
+
+
+
\f
;;; Game
;;; ----
(define (game-spec)
(append lobby grand-hallway smoking-parlor
- playroom break-room))
+ playroom break-room computer-room underground-lab))
;; TODO: Provide command line args
(define (run-game . args)
- (run-demo (game-spec) 'room:lobby #:repl-server #t))
+ (run-demo (game-spec) 'lobby #:repl-server #t))
projects / mudsync.git / blobdiff