;;; 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)
(<- (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 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"))
-
(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))))
(define* (sign-cmd-sign-in actor message
#:key direct-obj indir-obj preposition)
(define old-name
- (msg-val (<-wait (message-from message) 'get-name)))
+ (mbody-val (<-wait (message-from message) 'get-name)))
(define name indir-obj)
(if (valid-name? indir-obj)
(begin
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 . _)
;; handler... meanwhile, this procedure suspends until we get
;; their response.
(define who-rang
- (msg-val (<-wait (message-from message) 'get-name)))
+ (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.
<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"
('npc:lobby:hotel-owner
<chatty-npc> 'room:lobby
#:name "a frumpy fellow"
- #:desc " Whoever this is, they looks totally exhausted. They're
+ #:desc
+ '((p " Whoever this is, they looks totally exhausted. They're
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."
+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?
"hotel proprietor" "proprietor")
('thing:lobby:cabinet
<gameobj> 'room:lobby
#: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))))
+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")))))
('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.")
- ;; Object: desk
- ;; - Object: bell
- ;; - Object: sign in form
- ;; - Object: pamphlet
- ;; Object: <invisible bell>: reprimands that you want to ring the
- ;; bell on the desk
- )
- )
+
+ ('thing:lobby:porcelain-doll
+ <gameobj> 'room: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
+ <gameobj> 'room: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
+ <gameobj> 'room: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
+ <gameobj> 'room: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
+ <gameobj> 'room: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"))
+ ('thing:lobby:circuitboard-of-evlis
+ <gameobj> 'room: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"))
+ ('thing:lobby:teletype-scroll
+ <gameobj> 'room: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"))
+ ('thing:lobby:orange-cat-phone
+ <gameobj> 'room: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"))))
\f
<gameobj> 'room:grand-hallway
#:name "a statue"
#:desc " The statue is of a serious-looking bearded man with long, flowing hair.
-The inscription says \"St. Ignucius\".
It has a large physical halo. Removing it is tempting, but it looks pretty
well fastened."
#:goes-by '("statue" "st ignucius" "st. ignucius"))))
#:name "east"
#:to 'room:grand-hallway)))
('thing:playroom:cubey
- <thing> 'room:playroom
+ <gameobj> 'room:playroom
#:name "cubey"
- #:takeable #t
+ #:take-me? #t
#:desc " It's a little foam cube with googly eyes on it. So cute!")
- ('thing:cuddles-plushie
- <thing> 'room:playroom
+ ('thing:playroom:cuddles-plushie
+ <gameobj> 'room:playroom
#:name "a cuddles plushie"
#:goes-by '("plushie" "cuddles plushie" "cuddles")
- #:takeable #t
- #:desc " A warm and fuzzy cuddles plushie! It's a cuddlefish!")))
+ #:take-me? #t
+ #:desc " A warm and fuzzy cuddles plushie! It's a cuddlefish!")
+
+ ('thing:playroom:toy-chest
+ <gameobj> 'room: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? (pk 'contents 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
+ ('thing:playroom:toy-chest:rubber-duck
+ <gameobj> 'thing: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 player-name
- (msg-val (<-wait (message-from message) 'get-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)
('room:smoking-parlor
<room> #f
#:name "Smoking Parlor"
- #:desc " 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.
- There's a door to the west leading back to the grand hallway, and
-a nondescript steel door to the south, leading apparently outside."
+ #: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"
(make <exit>
#:name "south"
#:to 'room:break-room)))
- ('thing:smoking-room:chair
+ ('thing:smoking-parlor:chair
<furniture> 'room:smoking-parlor
#:name "a comfy leather chair"
#:desc " That leather chair looks really comfy!"
#:sit-phrase "sink into"
#:sit-phrase-third-person "sinks into"
#:sit-name "the comfy leather chair")
- ('thing:smoking-room:sofa
+ ('thing:smoking-parlor:sofa
<furniture> 'room:smoking-parlor
#:name "a plush leather sofa"
#:desc " That leather chair looks really comfy!"
#:sit-phrase "sprawl out on"
#:sit-phrase-third-person "sprawls out on into"
#:sit-name "the plush leather couch")
- ('thing:smoking-room:bar-stool
+ ('thing:smoking-parlor:bar-stool
<furniture> 'room:smoking-parlor
#:name "a bar stool"
#:desc " Conveniently located near the bar! Not the most comfortable
"frood" "prefect" "ford")
#:catchphrases prefect-quotes)
- ;; TODO: Cigar dispenser
+ ('thing:smoking-parlor:no-smoking-sign
+ <gameobj> 'room: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"))
+ ;; TODO: Cigar dispenser
))
\f
;;; Breakroom
;;; ---------
-(define clerk-commands
- (list
- (direct-command "talk" 'cmd-chat)
- (direct-command "chat" 'cmd-chat)
- (direct-command "ask" 'cmd-ask-incomplete)
- (prep-direct-command "ask" 'cmd-ask-about)
- (direct-command "dismiss" 'cmd-dismiss)))
-(define clerk-commands*
- (append clerk-commands thing-commands*))
-
-(define-class <desk-clerk> (<thing>)
+(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)
(update-loop clerk-act-update-loop)
(be-summoned clerk-act-be-summoned))))
-(define (clerk-act-init clerk message)
+(define (clerk-act-init clerk message . _)
;; call the gameobj main init method
(gameobj-act-init clerk message)
;; start our main loop
(define clerk-knows-about
- "'changing name', 'common commands', and 'about the hotel'")
+ "'ask clerk about changing name', 'ask clerk about common commands', and 'ask clerk about the hotel'")
(define clerk-general-helpful-line
(string-append
(random-choice clerk-slacking-complaints)
"\"\n")))))
-(define (clerk-cmd-ask-incomplete clerk message)
+(define (clerk-cmd-ask-incomplete clerk message . _)
(<- (message-from message) 'tell
#:text "The clerk says, \"Ask about what?\"\n"))
(define* (clerk-cmd-dismiss clerk message . _)
(define player-name
- (msg-val (<-wait (message-from message) 'get-name)))
+ (mbody-val (<-wait (message-from message) 'get-name)))
(match (slot-ref clerk 'state)
('on-duty
(<- (gameobj-loc clerk) 'tell-room
"The clerk fumbles around for a cigarette.\n"))
(define clerk-working-impatience-texts
- '("The clerk struggles to retain an interested and polite smile.\n"
- "The clerk checks the time on her phone.\n"
- "The clerk taps her foot.\n"
- "The clerk takes a deep breath.\n"
- "The clerk yawns.\n"
- "The clerk drums her nails on the counter.\n"
- "The clerk clicks around on the desk computer.\n"))
+ '("The clerk 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, claiming she has important things to
-attend to.\n")
+ "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")
(match (slot-ref clerk 'state)
('slacking
(tell-room (random-choice clerk-slacking-texts))
- (8sleep (+ (random 10) 10))
+ (8sleep (+ (random 20) 15))
(loop-if-not-destructed))
('on-duty
(if (> (slot-ref clerk 'patience) 0)
(tell-room (random-choice clerk-working-impatience-texts))
(slot-set! clerk 'patience (- (slot-ref clerk 'patience)
(+ (random 2) 1)))
- (8sleep (+ (random 25) 20))
+ (8sleep (+ (random 60) 40))
(loop-if-not-destructed))
;; Back to slacking
(begin
<desk-clerk> 'room:break-room
#:name "the hotel desk clerk"
#:desc " The hotel clerk is wearing a neatly pressed uniform bearing the
-hotel insignia. She looks like she'd much rather be somewhere else."
- #:goes-by '("hotel desk clerk" "clerk" "desk clerk"))))
+hotel insignia. She appears to be rather exhausted."
+ #:goes-by '("hotel desk clerk" "clerk" "desk clerk"))
+ ('thing:break-room:void
+ <gameobj> 'room: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"))
+ ('thing:break-room:fence
+ <gameobj> 'room: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
;;; Game
;;; ----
-(define game-spec
+(define (game-spec)
(append lobby grand-hallway smoking-parlor
playroom break-room))
;; TODO: Provide command line args
(define (run-game . args)
- (run-demo game-spec 'room:lobby #:repl-server #t))
+ (run-demo (game-spec) 'room:lobby #:repl-server #t))
projects / mudsync.git / blobdiff