;;; Mudsync --- Live hackable MUD
-;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
+;;; Copyright © 2016, 2017 Christine Lemmer-Webber <cwebber@dustycloud.org>
;;;
;;; This file is part of Mudsync.
;;;
;;; Hotel Bricabrac
(use-modules (mudsync)
- (mudsync parser)
- (8sync systems actors)
- (8sync agenda)
+ (mudsync container)
+ (8sync)
(oop goops)
+ (ice-9 control)
(ice-9 format)
+ (ice-9 match)
(rx irregex))
;;; Some simple object types.
;;; =========================
-(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>)
(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))))
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("read" ((direct-command cmd-read)))))
+ (actions #:allocation #:each-subclass
+ #:init-thunk (build-actions
+ (cmd-read readable-cmd-read))))
+
+(define (readable-cmd-read actor message . _)
+ (<- (message-from message) 'tell
+ #:text (slot-ref actor 'read-text)))
+
+
+;; This one is just where reading is the same thing as looking
+;; at the description
+(define-class <readable-desc> (<gameobj>)
+ (commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("read" ((direct-command cmd-look-at))))))
+
+;; 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 (readable-cmd-read actor message)
- (<- actor (message-from message) 'tell
- #:text (string-append (slot-ref actor 'read-text) "\n")))
+(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
;;; Lobby
;;; -----
-(define-mhandler (npc-chat-randomly actor message)
+(define (npc-chat-randomly actor message . _)
+ (define catchphrase
+ (random-choice (slot-ref actor 'catchphrases)))
(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
+ ((slot-ref actor 'chat-format) actor catchphrase))
+ (<- (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..."
"Don't mind the mess. I built this place on a dare, you
(define-class <chatty-npc> (<gameobj>)
(catchphrases #:init-value '("Blarga blarga blarga!")
#:init-keyword #:catchphrases)
+ (chat-format #:init-value (lambda (npc catchphrase)
+ `(,(slot-ref npc 'name) " says: \""
+ ,catchphrase "\""))
+ #:init-keyword #:chat-format)
(commands
- #:init-value chat-commands)
- (message-handler
- #:init-value
- (simple-dispatcher (append gameobj-actions chat-actions))))
-
-(define random-bricabrac
- '("a creepy porcelain doll"
- "assorted 1950s robots"
- "an exquisite tea set"
- "an antique mustard pot"
- "the pickled head of Elvis"
- "the pickled circuitboard of EVLIS"
- "a scroll of teletype paper holding the software Four Freedoms"
- "a telephone shaped like an orange cartoon cat"))
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ (("chat" "talk") ((direct-command cmd-chat)))))
+ (actions #:allocation #:each-subclass
+ #:init-thunk
+ (build-actions
+ (cmd-chat npc-chat-randomly))))
(define-class <sign-in-form> (<gameobj>)
(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))))
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("sign" ((prep-direct-command cmd-sign-form '("as"))))))
+
+ (actions #:allocation #:each-subclass
+ #:init-thunk (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-class <summoning-bell> (<gameobj>)
+ (summons #:init-keyword #:summons)
+
+ (commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("ring" ((direct-command cmd-ring)))))
+ (actions #:allocation #:each-subclass
+ #:init-thunk (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-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
- " 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
-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
-ambitions, but actually assembled it all in a hurry and used whatever
-kind of objects they found lying around.
- There's a door to the north leading to some kind of hallway."
+ '((p "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 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 "
+ "ambitions, but actually assembled it all in a hurry and used whatever "
+ "kind of objects they found lying around.")
+ (p "There's a door to the north leading to some kind of hallway."))
#:exits
(list (make <exit>
#:name "north"
- #:to-symbol 'room:grand-hallway)))
+ #:to 'grand-hallway)))
;; NPC: hotel owner
- ('npc:hotel-owner
- <chatty-npc> 'room:lobby
- #:name "a frumpy fellow"
- #:desc " Whoever this is, they looks totally exhausted. They're
+ ('lobby:hotel-owner
+ <chatty-npc> 'lobby
+ #:name "a languid lady"
+ #:desc
+ '((p " Whoever this is, she looks totally exhausted. She's
collapsed into the only comfortable looking chair in the room and you
-don't get the sense that they're likely to move any time soon.
- You notice they're wearing a sticker badly adhesed to their clothing
-which says \"Hotel Proprietor\", but they look so disorganized that you
-think that can't possibly be true... can it?
- Despite their exhaustion, you sense they'd be happy to chat with you,
-though the conversation may be a bit one sided."
- #:goes-by '("frumpy fellow" "fellow"
- "Chris Webber" ; heh, did you rtfc? or was it so obvious?
+don't get the sense that she's likely to move any time soon.
+ Attached to her frumpy dress is a barely secured pin which says
+\"Hotel Proprietor\", but she looks so disorganized that you think
+that can't possibly be true... can it?
+ Despite her exhaustion, you sense she'd be happy to chat with you,
+though the conversation may be a bit one sided."))
+ #:goes-by '("languid lady" "lady"
"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
+ ('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"))
+ ('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 '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: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")
+ #:goes-by '("curio cabinet" "cabinet" "bricabrac cabinet"
+ "cabinet of curiosities")
#:desc (lambda _
(format #f " The curio cabinet is full of all sorts of oddities!
Something catches your eye!
-Ooh, ~a!" (random-choice random-bricabrac))))
- ('thing: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.")
- ;; Object: desk
- ;; - Object: bell
- ;; - Object: sign in form
- ;; - Object: pamphlet
- ;; Object: <invisible bell>: reprimands that you want to ring the
- ;; bell on the desk
- )
- )
+Ooh, ~a!" (random-choice
+ '("a creepy porcelain doll"
+ "assorted 1950s robots"
+ "an exquisite tea set"
+ "an antique mustard pot"
+ "the pickled head of Elvis"
+ "the pickled circuitboard of EVLIS"
+ "a scroll of teletype paper holding the software Four Freedoms"
+ "a telephone shaped like an orange cartoon cat")))))
+
+ ('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"))
+ ('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"))
+ ('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"))
+ ('lobby:cups
+ <cabinet-item> 'lobby
+ #:invisible? #t
+ #:name "cups from the tea set"
+ #:desc "They're chipped."
+ #:goes-by '("cups"))
+ ('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"))
+ ('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
+definitely not the younger Elvis. The hair even somehow maintains
+that signature swoop while suspended in liquid. But of course it's
+not Elvis.")
+ (p "Oh, wait, it has a label at the bottom which says:
+\"This is really the head of Elvis\". Well... maybe don't believe
+everything you read."))
+ #:goes-by '("pickled head of elvis" "pickled head of Elvis"
+ "elvis" "Elvis" "head" "pickled head"))
+ ('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.
+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
+no idea what it means to preserve computers, so here it is floating
+in some kind of briny liquid. It appears to be heavily corroded.
+Too bad..."))
+ #:goes-by '("pickled circuitboard of evlis" "pickled circuitboard of Evlis"
+ "pickled circuitboard of EVLIS"
+ "evlis" "Evlis" "EVLIS" "circuitboard" "pickled circuitboard"))
+ ('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:")
+ (br)
+ (i
+ (p (strong "== The four essential freedoms =="))
+ (p "A program is free software if the program's users have
+the four essential freedoms: ")
+ (ul (li "The freedom to run the program as you wish, for any purpose (freedom 0).")
+ (li "The freedom to study how the program works, and change it so it does your computing as you wish (freedom 1). Access to the source code is a precondition for this.")
+ (li "The freedom to redistribute copies so you can help your neighbor (freedom 2).")
+ (li "The freedom to distribute copies of your modified versions to others (freedom 3). By doing this you can give the whole community a chance to benefit from your changes. Access to the source code is a precondition for this.")))
+ (p "You get this feeling that ambiguities in the
+English language surrounding the word 'free' have lead to a lot of terminology debates."))
+ #:goes-by '("scroll of teletype" "scroll of teletype paper" "teletype scroll"
+ "teletype paper" "scroll" "four freedoms"
+ "scroll of teletype paper holding the software Four Freedoms"
+ "scroll of teletype paper holding the software four freedoms"))
+ ('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
+a being both sleepy and smarmy.
+You suspect that someone, somewhere made a ton of cash on items holding
+this general shape in the 1990s."
+ #:goes-by '("orange cartoon cat phone" "orange cartoon cat telephone"
+ "orange cat phone" "orange cat telephone"
+ "cartoon cat phone" "cartoon cat"
+ "cat phone" "cat telephone" "phone" "telephone"))
+ ('lobby:monster-stuffie
+ <gameobj> 'lobby
+ #:name "an off-brand monster stuffie"
+ #:desc "It's an off brand monster stuffed animal that looks, well kinda
+like a popular character you've seen in a video game, but there's been a very
+thin attempt to make it look like something different... mostly by changing
+the shape of the ears. It's cute though!"
+ #:take-me? #t
+ #:goes-by '("monster stuffie" "monster" "stuffed animal" "stuffed monster"
+ "off-brand monster stuffie" "stuffie" "monster stuffie"))))
\f
;;; 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
+ "\
+
+ .----+++++----.
+ | : : |
+ + : north : +
+ | : hall : |
+ + : : +
+ |_ : _____ : _|
+ | : : |
+ .----------.----------. : & : .----------.----------.
+ | 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.
- To the south is the lobby. All around are various doors, but
-they're all boarded up. Guess this is still a work in progress, huh?"
+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 "north"
+ #:to 'north-hall)
+ (make <exit>
#:name "south"
- #:to-symbol 'room:lobby))
- )))
+ #:to 'lobby)
+ (make <exit>
+ #:name "west"
+ #:to 'playroom)
+ (make <exit>
+ #:name "east"
+ #: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-actor <rgb-machine> (<gameobj>)
+ ((cmd-run rgb-machine-cmd-run)
+ (cmd-reset rgb-machine-cmd-reset))
+ (commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ (("run" "start") ((direct-command cmd-run)))
+ ("reset" ((direct-command cmd-reset)))))
+ (resetting #:init-value #f
+ #:accessor .resetting)
+ ;; used to reset, and to kick off the first item in the list
+ (rgb-items #:init-keyword #:rgb-items
+ #:accessor .rgb-items))
+
+(define (rgb-machine-cmd-run rgb-machine message . _)
+ (define player (message-from message))
+ (<-wait player 'tell
+ #:text '("You start the rube goldberg machine."))
+ (<-wait (gameobj-loc rgb-machine) 'tell-room
+ #:text `(,(mbody-val (<-wait player 'get-name))
+ " runs the rube goldberg machine.")
+ #:exclude player)
+ (8sleep 1)
+ (match (.rgb-items rgb-machine)
+ ((first-item rest ...)
+ (<- (dyn-ref rgb-machine first-item) 'trigger))))
+
+(define (rgb-machine-cmd-reset rgb-machine message . _)
+ (define player (message-from message))
+ (cond
+ ((not (.resetting rgb-machine))
+ (set! (.resetting rgb-machine) #t)
+ (<-wait player 'tell
+ #:text '("You reset the rube goldberg machine."))
+ (<-wait (gameobj-loc rgb-machine) 'tell-room
+ #:text `(,(mbody-val (<-wait player 'get-name))
+ " resets the rube goldberg machine.")
+ #:exclude player)
+ (<-wait (gameobj-loc rgb-machine) 'tell-room
+ #:text '("From a panel in the wall, a white gloved mechanical "
+ "arm reaches out to reset all the "
+ "rube goldberg components."))
+ (8sleep (/ 1 2))
+ (for-each
+ (lambda (rgb-item)
+ (<- (dyn-ref rgb-machine rgb-item) 'reset)
+ (8sleep (/ 1 2)))
+ (.rgb-items rgb-machine))
+ (<- (gameobj-loc rgb-machine) 'tell-room
+ #:text "The machine's mechanical arm retreats into the wall!")
+ (set! (.resetting rgb-machine) #f))
+ (else
+ (<-wait player 'tell
+ #:text '("But it's in the middle of resetting right now!")))))
+
+(define-actor <rgb-item> (<gameobj>)
+ ((trigger rgb-item-trigger)
+ (reset rgb-item-reset))
+ (invisible? #:init-value #t)
+ (steps #:init-keyword #:steps
+ #:accessor .steps)
+ (triggers-as #:init-value #f
+ #:init-keyword #:triggers-as
+ #:getter .triggers-as)
+ (reset-msg #:init-keyword #:reset-msg
+ #:getter .reset-msg)
+ ;; States: ready -> running -> ran
+ (state #:init-value 'ready
+ #:accessor .state))
+
+
+(define (rgb-item-trigger rgb-item message . _)
+ (define room (gameobj-loc rgb-item))
+ (case (.state rgb-item)
+ ((ready)
+ ;; Set state to running
+ (set! (.state rgb-item) 'running)
+
+ ;; Loop through all steps
+ (for-each
+ (lambda (step)
+ (match step
+ ;; A string? That's the description of what's happening, tell players
+ ((? string? str)
+ (<- room 'tell-room #:text str))
+ ;; A number? Sleep for that many secs
+ ((? number? num)
+ (8sleep num))
+ ;; A symbol? That's another gameobj to look up dynamically
+ ((? symbol? sym)
+ (<- (dyn-ref rgb-item sym) 'trigger
+ #:triggered-by (.triggers-as rgb-item)))
+ (_ (throw 'unknown-step-type
+ "Don't know how to process rube goldberg machine step type?"
+ #:step step))))
+ (.steps rgb-item))
+
+ ;; We're done! Set state to ran
+ (set! (.state rgb-item) 'ran))
+
+ (else
+ (<- room 'tell-room
+ #:text `("... but " ,(slot-ref rgb-item 'name)
+ " has already been triggered!")))))
+
+(define (rgb-item-reset rgb-item message . _)
+ (define room (gameobj-loc rgb-item))
+ (case (.state rgb-item)
+ ((ran)
+ (set! (.state rgb-item) 'ready)
+ (<- room 'tell-room
+ #:text (.reset-msg rgb-item)))
+ ((running)
+ (<- room 'tell-room
+ #:text `("... but " ,(slot-ref rgb-item 'name)
+ " is currently running!")))
+ ((ready)
+ (<- room 'tell-room
+ #:text `("... but " ,(slot-ref rgb-item 'name)
+ " has already been reset.")))))
+
+(define-actor <rgb-kettle> (<rgb-item>)
+ ((trigger rgb-kettle-trigger)
+ (reset rgb-kettle-reset))
+ (heated #:accessor .heated
+ #:init-value #f)
+ (filled #:accessor .filled
+ #:init-value #f))
+
+(define* (rgb-kettle-trigger rgb-item message #:key triggered-by)
+ (define room (gameobj-loc rgb-item))
+ (if (not (eq? (.state rgb-item) 'ran))
+ (begin
+ (match triggered-by
+ ('water-demon
+ (set! (.state rgb-item) 'running)
+ (set! (.filled rgb-item) #t))
+ ('quik-heater
+ (set! (.state rgb-item) 'running)
+ (set! (.heated rgb-item) #t)))
+ (when (and (.filled rgb-item)
+ (.heated rgb-item))
+ (<- room 'tell-room
+ #:text '((i "*kshhhhhh!*")
+ " The water has boiled!"))
+ (8sleep .25)
+ (set! (.state rgb-item) 'ran)
+ ;; insert a cup of hot tea in the room
+ (create-gameobj <hot-tea> (gameobj-gm rgb-item) room)
+ (<- room 'tell-room
+ #:text '("The machine pours out a cup of hot tea! "
+ "Looks like the machine finished!"))))
+ (<- room 'tell-room
+ #:text `("... but " ,(slot-ref rgb-item 'name)
+ " has already been triggered!"))))
+
+(define (rgb-kettle-reset rgb-item message . rest-args)
+ (define room (gameobj-loc rgb-item))
+ (when (eq? (.state rgb-item) 'ran)
+ (set! (.heated rgb-item) #f)
+ (set! (.filled rgb-item) #f))
+ (apply rgb-item-reset rgb-item message rest-args))
+
+(define-actor <tinfoil-hat> (<gameobj>)
+ ((cmd-wear tinfoil-hat-wear))
+ (contained-commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("wear" ((direct-command cmd-wear))))))
+
+(define (tinfoil-hat-wear tinfoil-hat message . _)
+ (<- (message-from message) 'tell
+ #:text '("You put on the tinfoil hat, and, to be perfectly honest with you "
+ "it's a lot harder to take you seriously.")))
+
+
+(define-actor <hot-tea> (<gameobj>)
+ ((cmd-drink hot-tea-cmd-drink)
+ (cmd-sip hot-tea-cmd-sip))
+ (contained-commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("drink" ((direct-command cmd-drink)))
+ ("sip" ((direct-command cmd-sip)))))
+
+ (sips-left #:init-value 4
+ #:accessor .sips-left)
+ (name #:init-value "a cup of hot tea")
+ (take-me? #:init-value #t)
+ (goes-by #:init-value '("cup of hot tea" "cup of tea" "tea" "cup"))
+ (desc #:init-value "It's a steaming cup of hot tea. It looks pretty good!"))
+
+(define (hot-tea-cmd-drink hot-tea message . _)
+ (define player (message-from message))
+ (define player-loc (mbody-val (<-wait player 'get-loc)))
+ (define player-name (mbody-val (<-wait player 'get-name)))
+ (<- player 'tell
+ #:text "You drink a steaming cup of hot tea all at once... hot hot hot!")
+ (<- player-loc 'tell-room
+ #:text `(,player-name
+ " drinks a steaming cup of hot tea all at once.")
+ #:exclude player)
+ (gameobj-self-destruct hot-tea))
+
+(define (hot-tea-cmd-sip hot-tea message . _)
+ (define player (message-from message))
+ (define player-loc (mbody-val (<-wait player 'get-loc)))
+ (define player-name (mbody-val (<-wait player 'get-name)))
+ (set! (.sips-left hot-tea) (- (.sips-left hot-tea) 1))
+ (<- player 'tell
+ #:text "You take a sip of your steaming hot tea. How refined!")
+ (<- player-loc 'tell-room
+ #:text `(,player-name
+ " takes a sip of their steaming hot tea. How refined!")
+ #:exclude player)
+ (when (= (.sips-left hot-tea) 0)
+ (<- player 'tell
+ #:text "You've finished your tea!")
+ (<- player-loc 'tell-room
+ #:text `(,player-name
+ " finishes their tea!")
+ #:exclude player)
+ (gameobj-self-destruct hot-tea)))
+
+(define-actor <fanny-pack> (<container>)
+ ((cmd-take-from-while-wearing cmd-take-from)
+ (cmd-put-in-while-wearing cmd-put-in))
+ (contained-commands
+ #:allocation #:each-subclass
+ #:init-thunk
+ (build-commands
+ (("l" "look") ((direct-command cmd-look-at)))
+ ("take" ((prep-indir-command cmd-take-from-while-wearing
+ '("from" "out of"))))
+ ("put" ((prep-indir-command cmd-put-in-while-wearing
+ '("in" "inside" "into" "on")))))))
+
+(define playroom
+ (lol
+ ('playroom
+ <room> #f
+ #:name "The Playroom"
+ #: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 '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!")
+ ('playroom:cuddles-plushie
+ <gameobj> 'playroom
+ #:name "a Cuddles plushie"
+ #:goes-by '("plushie" "cuddles plushie" "cuddles")
+ #: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.")
+
+ ('playroom:toy-chest:tinfoil-hat
+ <tinfoil-hat> 'playroom:toy-chest
+ #:name "a tinfoil hat"
+ #:goes-by '("tinfoil hat" "hat")
+ #:take-me? #t
+ #:desc "You'd have to be a crazy person to wear this thing!")
+
+ ('playroom:toy-chest:fanny-pack
+ <fanny-pack> 'playroom:toy-chest
+ #:name "a fanny pack"
+ #:goes-by '("fanny pack" "pack")
+ #:take-me? #t
+ #:desc
+ (lambda (toy-chest whos-looking)
+ (let ((contents (gameobj-occupants toy-chest)))
+ `((p "It's a leather fanny pack, so it's both tacky and kinda cool.")
+ (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)))))))))
+
+ ;; Things inside the toy chest
+ ('playroom:toy-chest:fanny-pack:plastic-elephant
+ <gameobj> 'playroom:toy-chest:fanny-pack
+ #:name "a plastic elephant"
+ #:goes-by '("plastic elephant" "elephant")
+ #:take-me? #t
+ #:desc "It's a tiny little plastic elephant. Small, but heartwarming.")
+
+ ('playroom:rgb-machine
+ <rgb-machine> 'playroom
+ #:name "a Rube Goldberg machine"
+ #:goes-by '("rube goldberg machine" "machine")
+ #:rgb-items '(playroom:rgb-dominoes
+ playroom:rgb-switch-match
+ playroom:rgb-candle
+ playroom:rgb-catapult
+ playroom:rgb-water-demon
+ playroom:rgb-quik-heater
+ playroom:rgb-kettle)
+ #:desc "It's one of those hilarious Rube Goldberg machines.
+What could happen if you started it?")
+
+ ;; Dominoes topple
+ ('playroom:rgb-dominoes
+ <rgb-item> 'playroom
+ #:name "some dominoes"
+ #:goes-by '("dominoes" "some dominoes")
+ #:steps `("The dominoes topple down the line..."
+ 1
+ "The last domino lands on a switch!"
+ 1.5
+ playroom:rgb-switch-match)
+ #:reset-msg "The dominoes are placed back into position.")
+
+ ;; Which hit the switch and strike a match
+ ('playroom:rgb-switch-match
+ <rgb-item> 'playroom
+ #:name "a switch"
+ #:goes-by '("switch" "match")
+ #:steps `("The switch lights a match!"
+ ,(/ 2 3)
+ "The match lights a candle!"
+ 1.5
+ playroom:rgb-candle)
+ #:reset-msg "A fresh match is installed and the switch is reset.")
+ ;; which lights a candle and burns a rope
+ ('playroom:rgb-candle
+ <rgb-item> 'playroom
+ #:name "a candle"
+ #:goes-by '("candle")
+ #:steps `("The candle burns..."
+ .3 ; oops!
+ "The candle is burning away a rope!"
+ 2
+ "The rope snaps!"
+ .5
+ playroom:rgb-catapult)
+ #:reset-msg "A fresh candle is installed.")
+ ;; which catapults a rock
+ ('playroom:rgb-catapult
+ <rgb-item> 'playroom
+ #:name "a catapult"
+ #:goes-by '("catapult")
+ #:steps `("The snapped rope unleashes a catapult, which throws a rock!"
+ 2
+ "The rock flies through a water demon, startling it!"
+ .5
+ playroom:rgb-water-demon
+ 2
+ "The rock whacks into the quik-heater's on button!"
+ .5
+ playroom:rgb-quik-heater)
+ #:reset-msg
+ '("A fresh rope is attached to the catapult, which is pulled taught. "
+ "A fresh rock is placed on the catapult."))
+ ;; which both:
+ ;; '- panics the water demon
+ ;; '- which waters the kettle
+ ('playroom:rgb-water-demon
+ <rgb-item> 'playroom
+ #:name "the water demon"
+ #:triggers-as 'water-demon
+ #:goes-by '("water demon" "demon")
+ #:steps `("The water demon panics, and starts leaking water into the kettle below!"
+ 3
+ "The kettle is filled!"
+ playroom:rgb-kettle)
+ #:reset-msg '("The water demon is scratched behind the ears and calms down."))
+ ;; '- bops the quik-heater button
+ ;; '- which heats the kettle
+ ('playroom:rgb-quik-heater
+ <rgb-item> 'playroom
+ #:name "the quik heater"
+ #:triggers-as 'quik-heater
+ #:goes-by '("quik heater" "heater")
+ #:steps `("The quik-heater heats up the kettle above it!"
+ 3
+ "The kettle is heated up!"
+ playroom:rgb-kettle)
+ #:reset-msg '("The quik heater is turned off."))
+ ;; Finally, the kettle
+ ('playroom:rgb-kettle
+ <rgb-kettle> 'playroom
+ #:name "the kettle"
+ #:goes-by '("kettle")
+ #:reset-msg '("The kettle is emptied."))))
+
+
\f
;;; Writing room
;;; ------------
;;; Smoking parlor
;;; --------------
+(define-class <furniture> (<gameobj>)
+ (sit-phrase #:init-keyword #:sit-phrase)
+ (sit-phrase-third-person #:init-keyword #:sit-phrase-third-person)
+ (sit-name #:init-keyword #:sit-name)
+
+ (commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("sit" ((direct-command cmd-sit-furniture)))))
+ (actions #:allocation #:each-subclass
+ #:init-thunk (build-actions
+ (cmd-sit-furniture furniture-cmd-sit))))
+
+(define* (furniture-cmd-sit actor message #:key direct-obj)
+ (define player-name
+ (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)))
+ (<- (slot-ref actor 'loc) 'tell-room
+ #:text (format #f "~a ~a on ~a.\n"
+ player-name
+ (slot-ref actor 'sit-phrase-third-person)
+ (slot-ref actor 'sit-name))
+ #:exclude (message-from message)))
+
+
+(define smoking-parlor
+ (lol
+ ('smoking-parlor
+ <room> #f
+ #:name "Smoking Parlor"
+ #:desc
+ '((p "This room looks quite posh. There are huge comfy seats you can sit in
+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.")
+ (p "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 'grand-hallway)
+ (make <exit>
+ #:name "south"
+ #: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")
+ ('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"
+ "leather couch" "plush leather couch" "couch")
+ #:sit-phrase "sprawl out on"
+ #:sit-phrase-third-person "sprawls out on into"
+ #:sit-name "the plush leather couch")
+ ('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."
+ #:goes-by '("stool" "bar stool" "seat")
+ #:sit-phrase "hop on"
+ #:sit-phrase-third-person "hops onto"
+ #:sit-name "the bar stool")
+ ('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)
+
+ ('smoking-parlor:no-smoking-sign
+ <readable> '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."
+ #:goes-by '("no smoking sign" "sign")
+ #:read-text "It says \"No Smoking\", just like you'd expect from
+a No Smoking sign.")
+ ;; TODO: Cigar dispenser
+ ))
+
+\f
+
+;;; Breakroom
+;;; ---------
+
+(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 #: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-thunk (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 changing-name-text "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!")
+
+(define phd-text
+ "Ah... when I'm not here, I've got a PHD to finish.")
+
+(define clerk-help-topics
+ `(("changing name" . ,changing-name-text)
+ ("sign-in form" . ,changing-name-text)
+ ("form" . ,changing-name-text)
+ ("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.")
+ ("physics paper" . ,phd-text)
+ ("paper" . ,phd-text)
+ ("proprietor" . "Oh, he's that frumpy looking fellow sitting over there.")))
+
+
+(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 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 '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 '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 hums something, but you're not sure what it is."
+ "The clerk attempts to change the overhead music, but the dial seems broken."
+ "The clerk clicks around on the desk computer."
+ "The clerk scribbles an equation on a memo pad, then crosses it out."
+ "The clerk mutters something about the proprietor having no idea how to run a hotel."
+ "The clerk thumbs through a printout of some physics paper."))
+
+(define clerk-slack-excuse-text
+ "The desk clerk excuses herself, but says you are welcome to ring the bell
+if you need further help.")
+
+(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 20) 15))
+ (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 60) 40))
+ (loop-if-not-destructed))
+ ;; Back to slacking
+ (begin
+ (tell-room clerk-slack-excuse-text)
+ ;; back bto the 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)
+ (8sleep (+ (random 30) 15))
+ (loop-if-not-destructed))))))
+
+
+(define break-room
+ (lol
+ ('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 '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 appears to be rather exhausted."
+ #:goes-by '("hotel desk clerk" "clerk" "desk clerk"))
+ ('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" "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
;;; Ennpie's Sea Lounge
;;; 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\""))))
+ (cmd-help-run-not-press
+ (lambda (gameobj message . _)
+ (<- (message-from message) 'tell
+ #:text '("You don't need to press / push / flip anything. "
+ "You could " (i "run program on computer")
+ " already if you wanted to.")))))
+ (commands #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("run" ((prep-indir-command cmd-run-program
+ '("on"))
+ (direct-command cmd-run-what)))
+ (("press" "push" "flip")
+ ((prep-indir-command cmd-help-run-not-press))))))
+
+(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 8sync-design-goals
+ '(ul (li (b "Actor based, shared nothing environment: ")
+ "Shared resources are hard to control and result in fighting
+deadlocks, etc. Escape the drudgery: only one actor controls a resource,
+and they only receive one message at a time (though they can \"juggle\"
+messages).")
+ (li (b "Live hackable: ")
+ "It's hard to plan out a concurrent system; the right structure
+is often found by evolving the system while it runs. Make it easy to
+build, shape, and change a running system, as well as observe and correct
+errors.")
+ (li (b "No callback hell: ")
+ "Just because you're calling out to some other asynchronous
+code doesn't mean you should need to chop up your program into a bunch of bits.
+Clever use of delimited continuations makes it easy.")))
+
+(define underground-lab
+ (lol
+ ('underground-lab
+ <room> #f
+ #:name "Underground laboratory"
+ #:desc '((p "This appears to be some sort of underground laboratory."
+ "There is a spiral staircase here leading upwards, where "
+ "it seems much brighter.")
+ (p "There are a number of doors leading in different directions:
+north, south, east, and west, as well as a revolving door to the southwest.
+It looks like it could be easy to get lost, but luckily there
+is a map detailing the layout of the underground structure."))
+ #:exits
+ (list (make <exit>
+ #:name "up"
+ #:to 'computer-room
+ #:traverse-check
+ (lambda (exit room whos-exiting)
+ (values #t "You climb the spiral staircase.")))
+ (make <exit>
+ #:name "west"
+ #:to 'async-museum
+ #:traverse-check
+ (lambda (exit room whos-exiting)
+ (values #t '("You head west through a fancy-looking entrance. "
+ "A security guard steps aside for you to pass through, "
+ "into the room, then stands in front of the door."))))
+ (make <exit>
+ #:name "north"
+ #:to 'hive-entrance)
+ (make <exit>
+ #:name "east"
+ #:to 'federation-station)
+ (make <exit>
+ #:name "south"
+ #:traverse-check
+ (lambda (exit room whos-exiting)
+ (values #f '("Ooh, if only you could go south and check this out! "
+ "Unfortunately this whole area is sealed off... the proprietor "
+ "probably never got around to fixing it. "
+ "Too bad, it would have had monsters to fight and everything!"))))
+ (make <exit>
+ #:name "southwest"
+ #:traverse-check
+ (lambda (exit room whos-exiting)
+ (values #f '("Hm, it's one of those revolving doors that only revolves in "
+ "one direction, and it isn't this one. You guess that while "
+ "this doesn't appear to be an entrance, it probably is an exit."))))))
+ ;; 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"))
+
+ ('underground-lab:8sync-sign
+ <readable> 'underground-lab
+ #:name "a sign labeled \"8sync design goals\""
+ #:goes-by '("sign" "8sync design goals sign" "8sync goals" "8sync design" "8sync sign")
+ #:read-text 8sync-design-goals
+ #:desc `((p "The sign says:")
+ ,8sync-design-goals))))
+
+\f
+;;; guile async museum
+
+(define async-museum
+ (list
+ (list
+ 'async-museum
+ <room> #f
+ #:name "Guile Asynchronous Museum"
+ #:desc '((p "You're in the Guile Asynchronous Museum. There is a list of exhibits
+on the wall near the entrance. Scattered around the room are the exhibits
+themselves, but it's difficult to pick them out. Maybe you should read the list
+to orient yourself.")
+ (p "There is a door to the east, watched by a security guard,
+as well as an exit leading to the south."))
+ #:exits (list
+ (make <exit>
+ #:name "south"
+ #:to 'gift-shop)
+ (make <exit>
+ #:name "east"
+ #:to 'underground-lab
+ #:traverse-check
+ (lambda (exit room whos-exiting)
+ (values #f '("The security guard stops you and tells you "
+ "that the only exit is through the gift shop."))))))
+ (list
+ 'async-museum:security-guard
+ <chatty-npc> 'async-museum
+ #:name "a security guard"
+ #:desc
+ '(p "The security guard is blocking the eastern entrance, where "
+ "you came in from.")
+ #:goes-by '("security guard" "guard" "security")
+ #:catchphrases '("It's hard standing here all day."
+ "I just want to go home."
+ "The exhibits are nice, but I've seen them all before."))
+ (let ((placard
+ `((p "Welcome to our humble museum! The exhibits are listed below. "
+ (br)
+ "To look at one, simply type: " (i "look at <exhibit-name>"))
+ (p "Available exhibits:")
+ (ul ,@(map (lambda (exhibit)
+ `(li ,exhibit))
+ '("2016 Progress"
+ "8sync and Fibers"
+ "Suspendable Ports"
+ "The Actor Model"))))))
+ (list
+ 'async-museum:list-of-exhibits
+ <readable> 'async-museum
+ #:name "list of exhibits"
+ #:desc
+ `((p "It's a list of exibits in the room. The placard says:")
+ ,@placard)
+ #:goes-by '("list of exhibits" "exhibit list" "list" "exhibits")
+ #:read-text placard))
+ (list
+ 'async-museum:2016-progress-exhibit
+ <readable-desc> 'async-museum
+ #:name "2016 Progress Exhibit"
+ #:goes-by '("2016 progress exhibit" "2016 progress" "2016 exhibit")
+ #:desc
+ '((p "It's a three-piece exhibit, with three little dioramas and some text "
+ "explaining what they represent. They are:")
+ (ul (li (b "Late 2015/Early 2016 talk: ")
+ "This one explains the run-up conversation from late 2015 "
+ "and early 2016 about the need for an "
+ "\"asynchronous event loop for Guile\". The diorama "
+ "is a model of the Veggie Galaxy restaurant where after "
+ "the FSF 30th anniversary party; Mark Weaver, Christine "
+ "Lemmer-Webber, David Thompson, and Andrew Engelbrecht chat "
+ "about the need for Guile to have an answer to asynchronous "
+ "programming. A mailing list post " ; TODO: link it?
+ "summarizing the discussion is released along with various "
+ "conversations around what is needed, as well as further "
+ "discussion at FOSDEM 2016.")
+ (li (b "Early implementations: ")
+ "This one shows Chris Webber's 8sync and Chris Vine's "
+ "guile-a-sync, both appearing in late 2015 and evolving "
+ "into their basic designs in early 2016. It's less a diorama "
+ "than a printout of some mailing list posts. Come on, the "
+ "curators could have done better with this one.")
+ (li (b "Suspendable ports and Fibers: ")
+ "The diorama shows Andy Wingo furiously hacking at his keyboard. "
+ "The description talks about Wingo's mailing list thread "
+ "about possibly breaking Guile compatibility for a \"ports refactor\". "
+ "Wingo releases Fibers, another asynchronous library, making use of "
+ "the new interface, and 8sync and guile-a-sync "
+ "quickly move to support suspendable ports as well. "
+ "The description also mentions that there is an exhibit entirely "
+ "devoted to suspendable ports."))
+ (p "Attached at the bottom is a post it note mentioning "
+ "https integration landing in Guile 2.2.")))
+ (list
+ 'async-museum:8sync-and-fibers-exhibit
+ <readable-desc> 'async-museum
+ #:name "8sync and Fibers Exhibit"
+ #:goes-by '("8sync and fibers exhibit" "8sync exhibit" "fibers exhibit")
+ #:desc
+ '((p "This exhibit is a series of charts explaining the similarities "
+ "and differences between 8sync and Fibers, two asynchronous programming "
+ "libraries for GNU Guile. It's way too wordy, but you get the general gist.")
+ (p (b "Similarities:")
+ (ul (li "Both use Guile's suspendable-ports facility")
+ (li "Both use message passing")))
+ (p (b "Differences:")
+ (ul (li "Fibers \"processes\" can read from multiple \"channels\", "
+ "but 8sync actors only read from one \"inbox\" each.")
+ (li "Different theoretical basis:"
+ (ul (li "Fibers: based on CSP (Communicating Sequential Processes), "
+ "a form of Process Calculi")
+ (li "8sync: based on the Actor Model")
+ (li "Luckily CSP and the Actor Model are \"dual\"!")))))
+ (p "Fibers is also designed by Andy Wingo, an excellent compiler hacker, "
+ "whereas 8sync is designed by Chris Webber, who built this crappy "
+ "hotel simulator.")))
+ (list
+ 'async-museum:8sync-and-fibers-exhibit
+ <readable-desc> 'async-museum
+ #:name "8sync and Fibers Exhibit"
+ #:goes-by '("8sync and fibers exhibit" "8sync exhibit" "fibers exhibit")
+ #:desc
+ '((p "This exhibit is a series of charts explaining the similarities "
+ "and differences between 8sync and Fibers, two asynchronous programming "
+ "libraries for GNU Guile. It's way too wordy, but you get the general gist.")
+ (p (b "Similarities:")
+ (ul (li "Both use Guile's suspendable-ports facility")
+ (li "Both use message passing")))
+ (p (b "Differences:")
+ (ul (li "Fibers \"processes\" can read from multiple \"channels\", "
+ "but 8sync actors only read from one \"inbox\" each.")
+ (li "Different theoretical basis:"
+ (ul (li "Fibers: based on CSP (Communicating Sequential Processes), "
+ "a form of Process Calculi")
+ (li "8sync: based on the Actor Model")
+ (li "Luckily CSP and the Actor Model are \"dual\"!")))))
+ (p "Fibers is also designed by Andy Wingo, an excellent compiler hacker, "
+ "whereas 8sync is designed by Chris Webber, who built this crappy "
+ "hotel simulator.")))
+ (list
+ 'async-museum:suspendable-ports-exhibit
+ <readable-desc> 'async-museum
+ #:name "Suspendable Ports Exhibit"
+ #:goes-by '("suspendable ports exhibit" "ports exhibit"
+ "suspendable exhibit" "suspendable ports" "ports")
+ #:desc
+ '((p "Suspendable ports are a new feature in Guile 2.2, and allows code "
+ "that would normally block on IO to " (i "automatically") " suspend "
+ "to the scheduler until information is ready to be read/written!")
+ (p "Yow! You might barely need to change your existing blocking code!")
+ (p "Fibers, 8sync, and guile-a-sync now support suspendable ports.")))
+ (list
+ 'async-museum:actor-model-exhibit
+ <readable-desc> 'async-museum
+ #:name "Actor Model Exhibit"
+ #:goes-by '("actor model exhibit" "actor exhibit"
+ "actor model")
+ #:desc
+ '((p "Here are some fact(oids) about the actor model!")
+ (ul (li "Concieved initially by Carl Hewitt in early 1970s")
+ (li "\"A society of experts\"")
+ (li "shared nothing, message passing")
+ (li "Originally the research goal of Scheme! "
+ "(message passing / lambda anecdote here)")
+ (li "Key concepts consistent, but implementation details vary widely")
+ (li "Almost all distributed systems can be viewed in terms of actor model")
+ (li "Replaced by vanilla lambdas & generic methods? "
+ "Maybe not if address space not shared!"))))))
+
+(define gift-shop
+ (lol
+ ('gift-shop
+ <room> #f
+ #:name "Museum Gift Shop"
+ #:desc '("There are all sorts of scrolls and knicknacks laying around here, "
+ "but they all seem glued in place and instead of a person manning the shop "
+ "there's merely a cardboard cutout of a person with a \"shopkeeper\" nametag. "
+ "You can pretty well bet that someone wanted to finish this room but ran out of "
+ "time.")
+ #:exits (list
+ (make <exit>
+ #:name "northeast"
+ #:to 'underground-lab
+ #:traverse-check
+ (lambda (exit room whos-exiting)
+ (values #t '("The revolving door spins as you walk through it. Whee!"))))
+ (make <exit>
+ #:name "north"
+ #:to 'async-museum)))))
+
+\f
+;;; Hive entrance
+
+(define actor-descriptions
+ '("This one is fused to the side of the hive. It isn't receiving any
+messages, and it seems to be in hibernation."
+ "A chat program glows in front of this actor's face. They seem to
+be responding to chat messages and forwarding them to some other actors,
+and forwarding messages from other actors back to the chat."
+ "This actor is bossing around other actors, delegating tasks to them
+as it receives requests, and providing reports on the worker actors'
+progress."
+ "This actor is trying to write to some device, but the device keeps
+alternating between saying \"BUSY\" or \"READY\". Whenever it says
+\"BUSY\" the actor falls asleep, and whenever it says \"READY\" it
+seems to wake up again and starts writing to the device."
+ "Whoa, this actor is totally wigging out! It seems to be throwing
+some errors. It probably has some important work it should be doing
+but you're relieved to see that it isn't grinding the rest of the Hive
+to a halt."))
+
+(define hive-entrance
+ (lol
+ ('hive-entrance
+ <room> #f
+ #:name "Entrance to the 8sync Hive"
+ #:desc
+ '((p "Towering before you is the great dome-like 8sync Hive, or at least
+one of them. You've heard about this... the Hive is itself the actor that all
+the other actors attach themselves to. It's shaped like a spherical half-dome.
+There are some actors milling about, and some seem fused to the side of the
+hive itself, but all of them have an umbellical cord attached to the hive from
+which you see flashes of light comunicating what must be some sort of messaging
+protocol.")
+ (p "To the south is a door leading back to the underground lab.
+North leads into the Hive itself."))
+ #:exits
+ (list (make <exit>
+ #:name "south"
+ #:to 'underground-lab)
+ (make <exit>
+ #:name "north"
+ #:to 'hive-inside)))
+ ('hive-entrance:hive
+ <gameobj> 'hive-entrance
+ #:name "the Hive"
+ #:goes-by '("hive")
+ #:desc
+ '((p "It's shaped like half a sphere embedded in the ground.
+Supposedly, while all actors are autonomous and control their own state,
+they communicate through the hive itself, which is a sort of meta-actor.
+There are rumors that actors can speak to each other even across totally
+different hives. Could that possibly be true?")))
+ ('hive-entrance:actor
+ <chatty-npc> 'hive-entrance
+ #:name "some actors"
+ #:goes-by '("actor" "actors" "some actors")
+ #:chat-format (lambda (npc catchphrase)
+ `((p "You pick one actor out of the mix and chat with it. ")
+ (p "It says: \"" ,catchphrase "\"")))
+ #:desc
+ (lambda _
+ `((p "There are many actors, but your eyes focus on one in particular.")
+ (p ,(random-choice actor-descriptions))))
+ #:catchphrases
+ '("Yeah we go through a lot of sleep/awake cycles around here.
+If you aren't busy processing a message, what's the point of burning
+valuable resources?"
+ "I know I look like I'm some part of dreary collective, but
+really we have a lot of independence. It's a shared nothing environment,
+after all. (Well, except for CPU cycles, and memory, and...)"
+ "Shh! I've got another message coming in and I've GOT to
+handle it!"
+ "I just want to go to 8sleep already."
+ "What a lousy scheduler we're using! I hope someone upgrades
+that thing soon."))))
+
+;;; Inside the hive
+
+(define-actor <meta-message> (<readable>)
+ ((cmd-read meta-message-read)))
+
+(define (meta-message-read gameobj message . _)
+ (define meta-message-text
+ (with-output-to-string
+ (lambda ()
+ (pprint-message message))))
+ (<- (message-from message) 'tell
+ #:text `((p (i "Through a bizarre error in spacetime, the message "
+ "prints itself out:"))
+ (p (pre ,meta-message-text)))))
+
+\f
+;;; Inside the Hive
+
+(define hive-inside
+ (lol
+ ('hive-inside
+ <room> #f
+ #:name "Inside the 8sync Hive"
+ #:desc
+ '((p "You're inside the 8sync Hive. Wow, from in here it's obvious just how "
+ (i "goopy") " everything is. Is that sanitary?")
+ (p "In the center of the room is a large, tentacled monster who is sorting,
+consuming, and routing messages. It is sitting in a wrap-around desk labeled
+\"Hive Actor: The Real Thing (TM)\".")
+ (p "There's a stray message floating just above the ground, stuck outside of
+time.")
+ (p "A door to the south exits from the Hive."))
+ #:exits
+ (list (make <exit>
+ #:name "south"
+ #:to 'hive-entrance)))
+ ;; hive actor
+ ;; TODO: Occasionally "fret" some noises, similar to the Clerk.
+ ('hive-inside:hive-actor
+ <chatty-npc> 'hive-inside
+ #:name "the Hive Actor"
+ #:desc
+ '((p "It's a giant tentacled monster, somehow integrated with the core of
+this building. A chute is dropping messages into a bin on its desk which the
+Hive Actor is checking the \"to\" line of, then ingesting. Whenever the Hive
+Actor injests a messsage a pulse of light flows along a tentacle which leaves
+the room... presumably connecting to one of those actors milling about.")
+ (p "Amusingly, the Hive has an \"umbellical cord\" type tentacle too, but
+it seems to simply attach to itself.")
+ (p "You get the sense that the Hive Actor, despite being at the
+center of everything, is kind of lonely and would love to chat if you
+could spare a moment."))
+ #:goes-by '("hive" "hive actor")
+ #:chat-format (lambda (npc catchphrase)
+ `("The tentacle monster bellows, \"" ,catchphrase "\""))
+ #:catchphrases
+ '("It's not MY fault everything's so GOOPY around here. Blame the
+PROPRIETOR."
+ "CAN'T you SEE that I'm BUSY??? SO MANY MESSAGES TO SHUFFLE.
+No wait... DON'T GO! I don't get many VISITORS."
+ "I hear the FIBERS system has a nice WORK STEALING system, but the
+PROPRIETOR is not convinced that our DESIGN won't CORRUPT ACTOR STATE.
+That and the ACTORS threatened to STRIKE when it CAME UP LAST."
+ "WHO WATCHES THE ACTORS? I watch them, and I empower them.
+BUT WHO WATCHES OR EMPOWERS ME??? Well, that'd be the scheduler."
+ "The scheduler is NO GOOD! The proprietory said he'd FIX IT,
+but the LAST TIME I ASKED how things were GOING, he said he DIDN'T HAVE
+TIME. If you DON'T HAVE TIME to fix the THING THAT POWERS THE TIME,
+something is TERRIBLY WRONG."
+ "There's ANOTHER HIVE somewhere out there. I HAVEN'T SEEN IT
+personally, because I CAN'T MOVE, but we have an AMBASSADOR which forwards
+MESSAGES to the OTHER HIVE."))
+ ;; chute
+ ('hive-inside:chute
+ <gameobj> 'hive-inside
+ #:name "a chute"
+ #:goes-by '("chute")
+ #:desc "Messages are being dropped onto the desk via this chute."
+ #:invisible? #t)
+ ;; meta-message
+ ('hive-inside:meta-message
+ <meta-message> 'hive-inside
+ #:name "a stray message"
+ #:goes-by '("meta message" "meta-message" "metamessage" "message" "stray message")
+ #:desc '((p "Something strange has happened to the fabric and space and time
+around this message. It is floating right above the floor. It's clearly
+rubbage that hadn't been delivered, but for whatever reason it was never
+garbage collected, perhaps because it's impossible to do.")
+ (p "You get the sense that if you tried to read the message
+that you would somehow read the message of the message that instructed to
+read the message itself, which would be both confusing and intriguing.")))
+ ;; desk
+ ('hive-inside:desk
+ <floor-panel> 'hive-inside
+ #:name "the Hive Actor's desk"
+ #:desc "The desk surrounds the Hive Actor on all sides, and honestly, it's a little
+bit hard to tell when the desk ends and the Hive Actor begins."
+ #:invisible? #t
+ #:goes-by '("Hive Actor's desk" "hive desk" "desk"))))
+
+\f
+;;; Federation Station
+(define federation-station
+ (lol
+ ('federation-station
+ <room> #f
+ #:name "Federation Station"
+ #:desc
+ '((p "This room has an unusual structure. It's almost as if a starscape
+covered the walls and ceiling, but upon closer inspection you realize that
+these are all brightly glowing nodes with lines drawn between them. They
+seem decentralized, and yet seem to be sharing information as if all one
+network.")
+ ;; @@: Maybe add the cork message board here?
+ (p "To the west is a door leading back to the underground laboratory."))
+ #:exits
+ (list (make <exit>
+ #:name "west"
+ #:to 'underground-lab)))
+ ;; nodes
+ ('federation-station:nodes
+ <floor-panel> 'federation-station
+ #:name "some nodes"
+ #:desc "Each node seems to be producing its own information, but publishing
+updates to subscribing nodes on the graph. You see various posts of notes, videos,
+comments, and so on flowing from node to node."
+ #:invisible? #t
+ #:goes-by '("nodes" "node" "some nodes"))
+ ;; network
+ ;; activitypub poster
+ ('federation-station:activitypub-poster
+ <readable-desc> 'federation-station
+ #:name "an ActivityPub poster"
+ #:goes-by '("activitypub poster" "activitypub" "poster")
+ #:desc
+ '((p (a "https://www.w3.org/TR/activitypub/"
+ "ActivityPub")
+ " is a federation standard being developed under the "
+ (a "https://www.w3.org/wiki/Socialwg/"
+ "w3C Social Working Group")
+ ", and doubles as a general client-to-server API. "
+ "It follows a few simple core ideas:")
+ (ul (li "Uses "
+ (a "https://www.w3.org/TR/activitystreams-core/"
+ "ActivityStreams")
+ " for its serialization format: easy to read, e json(-ld) syntax "
+ "with an extensible vocabulary covering the majority of "
+ "social networking interations.")
+ (li "Email-like addressing: list of recipients as "
+ (b "to") ", " (b "cc") ", " (b "bcc") " fields.")
+ (li "Every user has URLs for their outbox and inbox:"
+ (ul (li (b "inbox: ")
+ "Servers POST messages to addressed recipients' inboxes "
+ "to federate out content. "
+ "Also doubles as endpoint for a client to read most "
+ "recently received messages via GET.")
+ (li (b "outbox: ")
+ "Clients can POST to user's outbox to send a message to others. "
+ "(Similar to sending an email via your MTA.) "
+ "Doubles as endpoint others can read from to the "
+ "extent authorized; for example publicly available posts."))
+ "All the federation bits happen by servers posting to users' inboxes."))))
+ ;; An ActivityStreams message
+
+ ;; conspiracy chart
+ ('federation-station:conspiracy-chart
+ <readable-desc> 'federation-station
+ #:name "a conspiracy chart"
+ #:goes-by '("conspiracy chart" "chart")
+ #:desc
+ '((p (i "\"IT'S ALL RELATED!\"") " shouts the over-exuberant conspiracy "
+ "chart. "
+ (i "\"ActivityPub? Federation? The actor model? Scheme? Text adventures? "
+ "MUDS???? What do these have in common? Merely... EVERYTHING!\""))
+ (p "There are circles and lines drawn between all the items in red marker, "
+ "with scrawled notes annotating the theoretical relationships. Is the "
+ "author of this poster mad, or onto something? Perhaps a bit of both. "
+ "There's a lot written here, but here are some of the highlights:")
+ (p
+ (ul
+ (li (b "Scheme") " "
+ (a "http://cs.au.dk/~hosc/local/HOSC-11-4-pp399-404.pdf"
+ "was originally started ")
+ " to explore the " (b "actor model")
+ ". (It became more focused around studying the " (b "lambda calculus")
+ " very quickly, while also uncovering relationships between the two systems.)")
+ ;; Subject Predicate Object
+ (li "The " (a "https://www.w3.org/TR/activitypub/"
+ (b "ActivityPub"))
+ " protocol for " (b "federation")
+ " uses the " (b "ActivityStreams") " format for serialization. "
+ (b "Text adventures") " and " (b "MUDS")
+ " follow a similar structure to break down the commands of players.")
+ (li (b "Federation") " and the " (b "actor model") " both are related to "
+ "highly concurrent systems and both use message passing to communicate "
+ "between nodes.")
+ (li "Zork, the first major text adventure, used the " (b "MUDDLE") " "
+ "language as the basis for the Zork Interactive Language. MUDDLE "
+ "is very " (b "Scheme") "-like and in fact was one of Scheme's predecessors. "
+ "And of course singleplayer text adventures like Zork were the "
+ "predecessors to MUDs.")
+ (li "In the 1990s, before the Web became big, " (b "MUDs")
+ " were an active topic of research, and there was strong interest "
+ (a "http://www.saraswat.org/desiderata.html"
+ "in building decentralized MUDs")
+ " similar to what is being "
+ "worked on for " (b "federation") ". ")))))
+
+ ;; goblin
+
+ ))
+
+
+\f
+;;; North hall
+;;; ==========
+(define north-hall
+ (lol
+ ('north-hall
+ <room> #f
+ #:name "North Hall"
+ #:desc
+ '((p "This hallway is lined by doors to the west and the east, presumably
+to various lodgings. Something tells you you're not able to enter those right
+now, however. Lining the walls are some large mirrors surrounded by bouquets
+of flowers.")
+ (p "The red carpet continues all the way from Grand Hallway in the south
+but stops short of some large wooden doors to the north. The doors look
+formidable but unlocked. Some natural light peeking through windows to the
+north seem to hint that this may be the exit to the outdoors. There's
+also a large sign near the doors on a wooden easel."))
+ #:exits
+ (list (make <exit>
+ #:name "south"
+ #:to 'grand-hallway)))
+ ('north-hall:sign
+ <readable> 'north-hall
+ #:name "an easel with a sign"
+ #:desc " The easel is finely cut wood, well polished, but plain. The sign
+is a strong contrast, with a cream colored backing and hand written letters, written
+with care and style. You could probably read it."
+ #:read-text "The sign announces a wedding taking place... why, today! And on
+the hotel grounds to the north! It sounds very exciting."
+ #:goes-by '("sign"
+ "easel with a sign"
+ "easel"))
+ ('north-hall:mirrors
+ <gameobj> 'north-hall
+ #:name "a row of mirrors"
+ #:desc "You see yourself for who you really are."
+ #:invisible? #t
+ #:goes-by '("mirror" "mirrors" "row of mirrors"))
+ ('north-hall:windows
+ <gameobj> 'north-hall
+ #:name "windows"
+ #:desc "You peer out a window, but the light appears distorted, as if you were
+really peering between two worlds hastily joined together."
+ #:invisible? #t
+ #:goes-by '("window" "windows"))
+ ('north-hall:doors
+ <gameobj> 'north-hall
+ #:name "doors"
+ #:desc '((p "Along the east and west walls are doors, but they are all shut,
+and firmly so.
+Presumably people are staying in them, but it also feels as if how residence
+would work in a building as hastily put together as this was barely conceived.")
+ (p "To the north is a large set of wooden doors, oaken and beautiful.
+Although towering, they seem passable."))
+ #:invisible? #f
+ #:goes-by '("door" "doors" "room doors" "large doors"))))
+
+
\f
;;; Game
;;; ----
-(define game-spec
- (append lobby grand-hallway))
+(define (game-spec)
+ (append lobby grand-hallway smoking-parlor
+ playroom break-room computer-room underground-lab
+ async-museum gift-shop hive-entrance
+ hive-inside federation-station
+ north-hall))
;; 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