X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=worlds%2Fbricabrac.scm;h=55e9cc2654f476355f2019e379a4a4b9d73cbd2b;hp=442e87d225ebd996641f1d91fe3ebd71099a1044;hb=e16f5c202440d4091b54b1b45d7e023b4fcd4a6d;hpb=2dd0c84bef35a7aeda0cf0ec8a034b8714a58557 diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index 442e87d..55e9cc2 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -19,8 +19,8 @@ ;;; Hotel Bricabrac (use-modules (mudsync) - (8sync actors) - (8sync agenda) + (mudsync container) + (8sync) (oop goops) (ice-9 control) (ice-9 format) @@ -56,9 +56,34 @@ #:init-thunk (build-actions (cmd-read readable-cmd-read)))) -(define (readable-cmd-read actor message) +(define (readable-cmd-read actor message . _) (<- (message-from message) 'tell - #:text (string-append (slot-ref actor 'read-text) "\n"))) + #:text (slot-ref actor 'read-text))) + + +;; This one allows you to take from items that are proxied by it +(define-actor () + ((cmd-take-from take-from-proxy)) + (proxy-items #:init-keyword #:proxy-items)) + +(define* (take-from-proxy gameobj message + #:key direct-obj indir-obj preposition + (player (message-from message))) + (call/ec + (lambda (escape) + (for-each + (lambda (obj-sym) + (define obj-id (dyn-ref gameobj obj-sym)) + (define goes-by + (mbody-val (<-wait obj-id 'goes-by))) + (when (ci-member direct-obj goes-by) + (<- obj-id 'cmd-take #:direct-obj direct-obj #:player player) + (escape #f))) + (slot-ref gameobj 'proxy-items)) + + (<- player 'tell + #:text `("You don't see any such " ,direct-obj " to take " + ,preposition " " ,(slot-ref gameobj 'name) "."))))) @@ -106,6 +131,7 @@ or 'skribe'? Now *that's* composition!")) #: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)))) @@ -189,6 +215,13 @@ character.\n"))) "How can you have money if none of you produces anything?" "On no account allow Arthur to request tea on this ship.")) +(define-class () + (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 ('lobby @@ -247,11 +280,24 @@ Classy!" #: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-desk-clerk) + #:summons 'break-room:desk-clerk) + + ('lobby: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 "))) ;; Object: curio cabinets + ;; TODO: respond to attempts to open the curio cabinet ('lobby:cabinet - 'lobby + 'lobby + #:proxy-items '(lobby:porcelain-doll + lobby:1950s-robots + lobby:tea-set lobby:mustard-pot + lobby:head-of-elvis lobby:circuitboard-of-evlis + lobby:teletype-scroll lobby:orange-cat-phone) #:name "a curio cabinet" #:goes-by '("curio cabinet" "cabinet" "bricabrac cabinet" "cabinet of curiosities") @@ -267,21 +313,16 @@ Ooh, ~a!" (random-choice "the pickled circuitboard of EVLIS" "a scroll of teletype paper holding the software Four Freedoms" "a telephone shaped like an orange cartoon cat"))))) - ('lobby: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.") ('lobby:porcelain-doll - 'lobby + '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 - 'lobby + 'lobby #:invisible? #t #:name "a set of 1950s robots" #:desc "There's a whole set of these 1950s style robots. @@ -289,7 +330,7 @@ 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 - 'lobby + 'lobby #:invisible? #t #:name "a tea set" #:desc "A complete tea set. Some of the cups are chipped. @@ -297,7 +338,7 @@ 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:mustard-pot - 'lobby + 'lobby #:invisible? #t #:name "a mustard pot" #:desc '((p "It's a mustard pot. I mean, it's kind of cool, it has a @@ -306,7 +347,7 @@ like this in a museum.") (p "Ha... imagine that... a mustard museum.")) #:goes-by '("mustard pot" "antique mustard pot" "mustard")) ('lobby:head-of-elvis - 'lobby + 'lobby #:invisible? #t #:name "the pickled head of Elvis" #:desc '((p "It's a jar full of some briny-looking liquid and... @@ -320,7 +361,7 @@ everything you read.")) #:goes-by '("pickled head of elvis" "pickled head of Elvis" "elvis" "Elvis" "head" "pickled head")) ('lobby:circuitboard-of-evlis - 'lobby + 'lobby #:invisible? #t #:name "the pickled circuitboard of Evlis" #:desc '((p "It's a circuitboard from a Lisp Machine called EVLIS. @@ -334,7 +375,7 @@ Too bad...")) "pickled circuitboard of EVLIS" "evlis" "Evlis" "EVLIS" "circuitboard" "pickled circuitboard")) ('lobby:teletype-scroll - 'lobby + 'lobby #:invisible? #t #:name "a scroll of teletype" #:desc '((p "This is a scroll of teletype paper. It's a bit old @@ -355,7 +396,7 @@ English language surrounding the word 'free' have lead to a lot of terminology d "scroll of teletype paper holding the software Four Freedoms" "scroll of teletype paper holding the software four freedoms")) ('lobby:orange-cat-phone - 'lobby + '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. @@ -373,28 +414,72 @@ this general shape in the 1990s." ;;; Grand hallway ;;; ------------- -(define-actor () - ((cmd-take-from hackthena-take-from-proxy))) +(define-actor () + ((cmd-take disc-shield-take))) + +(define* (disc-shield-take gameobj message + #:key direct-obj + (player (message-from message))) + (create-gameobj (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...\"")))) -(define* (hackthena-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))) - '(grand-hallway:keyboard - grand-hallway:disc-platter grand-hallway:hackthena-horns)) +;;; This is the disc that gets put in the player's inventory +(define-actor () + ((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)) - (<- player 'tell - #:text - `("Hackthena doesn't appear to be holding " ,direct-obj "."))))) + +;;; Grand hallway + +(define lobby-map-text + "\ + | : : | + .----------.----------. : & : .----------.----------. + | computer | |& :YOU ARE: &| smoking | *UNDER* | + | room + playroom + : HERE : + parlor | *CONS- | + | > | |& : : &| | TRUCTION*| + '----------'----------'-++-------++-'-------+--'----------' + | '-----' | | | + : LOBBY : '---' + '. .' + '---------'") (define grand-hallway (lol @@ -419,6 +504,15 @@ room\", while a door to the west is labeled \"playroom\".")) (make #:name "east" #:to 'smoking-parlor))) + ('grand-hallway:map + '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 'grand-hallway #:name "the Grand Hallway carpet" @@ -433,7 +527,7 @@ 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 - 'grand-hallway + '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 @@ -444,7 +538,10 @@ 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")) + #: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 'grand-hallway #:name "a Knight Keyboard" @@ -471,12 +568,12 @@ Hackthena must be an emacs user." `("Are you seriously considering desecrating a statue?"))) #:goes-by '("hackthena's horns" "horns" "horns of hacktena")) ('grand-hallway:disc-platter - 'grand-hallway - #:name "a hard disc platter" - #:desc "This isn't a shield after all, it seems to be a hard disc -platter! It looks kind of loose..." + '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 '("hard disc platter" "disc platter" "disc" "shield" "platter")))) + #:goes-by '("hackthena's shield" "shield" "platter" "hard disk platter")))) ;;; Playroom @@ -487,12 +584,16 @@ platter! It looks kind of loose..." ('playroom #f #:name "The Playroom" - #:desc " There are toys scattered everywhere here. It's really unclear -if this room is intended for children or child-like adults." + #:desc '(p (" There are toys scattered everywhere here. It's really unclear +if this room is intended for children or child-like adults.") + (" There are doors to both the east and the west.")) #:exits (list (make #:name "east" - #:to 'grand-hallway))) + #:to 'grand-hallway) + (make + #:name "west" + #:to 'computer-room))) ('playroom:cubey 'playroom #:name "Cubey" @@ -506,7 +607,7 @@ if this room is intended for children or child-like adults." #:desc " A warm and fuzzy cuddles plushie! It's a cuddlefish!") ('playroom:toy-chest - 'playroom + 'playroom #:name "a toy chest" #:goes-by '("toy chest" "chest") #:desc (lambda (toy-chest whos-looking) @@ -733,7 +834,7 @@ with tuition at where it is...")) #:allow-other-keys) (match (slot-ref clerk 'state) ('on-duty - (match (assoc (pk 'indir indir-obj) clerk-help-topics) + (match (assoc indir-obj clerk-help-topics) ((_ . info) (<- (message-from message) 'tell #:text @@ -852,7 +953,7 @@ if you need further help.") (begin (tell-room clerk-slack-excuse-text) ;; back bto the break room - (gameobj-set-loc! clerk (pk 'break-room (dyn-ref clerk '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) @@ -906,13 +1007,317 @@ the paint, but the wires themselves seem to be unusually sturdy." ;;; 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 () + ((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 () + ((cmd-run-program computer-run-program) + (cmd-run-what (lambda (gameobj message . _) + (<- (message-from message) 'tell + #:text '("The computer is already running, and a program appears " + "ready to run." + "you mean to \"run the program on the computer\""))))) + (commands #:allocation #:each-subclass + #:init-thunk (build-commands + ("run" ((prep-indir-command cmd-run-program + '("on")) + (direct-command cmd-run-what)))))) + +(define* (computer-run-program gameobj message + #:key direct-obj indir-obj preposition + (player (message-from message))) + (define (hd-state) + (mbody-val (<-wait (dyn-ref gameobj 'computer-room:hard-drive) 'get-state))) + (define (tell-room text) + (<-wait (gameobj-loc gameobj) 'tell-room + #:text text)) + (define (tell-room-excluding-player text) + (<-wait (gameobj-loc gameobj) 'tell-room + #:text text + #:exclude player)) + (define (tell-player text) + (<-wait player 'tell + #:text text)) + (cond + ((ci-member direct-obj '("program")) + (tell-room-excluding-player + `(,(mbody-val (<-wait player 'get-name)) + " runs the program loaded on the computer...")) + (tell-player "You run the program on the computer...") + + (cond + ((not (eq? (hd-state) 'ready)) + (tell-room '("... but it errors out. " + "It seems to be complaining about a " (b "DISK ERROR!") + ". It looks like it is missing some essential software."))) + (else + (<- (dyn-ref gameobj 'computer-room:floor-panel) 'open-up)))))) + + +;; floor panel +(define-actor () + ;; 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 + #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 + #:name "east" + #:to 'playroom) + (make + #: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 + 'computer-room + #:name "the hard drive" + #:desc (wrap-apply hard-drive-desc) + #:goes-by '("hard drive" "drive" "hard disk")) + ('computer-room: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 + 'computer-room + #:name "a floor panel" + #:desc (wrap-apply floor-panel-desc) + #:invisible? #t + #:goes-by '("floor panel" "panel")))) + + +;;; * UNDERGROUND SECTION OF THE GAME! * + + +;;; The lab + +(define underground-map-text + "\ + _______ | + .-' @ '-. \\ ????? + .' '. .\\ + | [8sync Hive] |======' '-_____ + ', M ,' + '. @ .' + \\ @ / + '-__+__-' + '. @ .' + .--------------. \\ / + | [Guile Async | .-------+------. + | Museum] | | [Lab] #!#| .-------------. + | @| | MM | |[Federation | + | & ^ +##+@ || < +##| Station]| + | | | @ | | | + | & # | |*You-Are-Here*| '-------------' + | # ^ | #+-------+------' + '-------+------' # # + # # # + # # .-----------. + .-+----. # |# F | + |@?+%? +#### | ^ f## | + '------' | f f %| + |F [Mudsync | + | $ Swamp] | + '-----------'") + +(define underground-lab + (lol + ('underground-lab + #f + #:name "Underground laboratory" + #:desc '("This appears to be some sort of underground laboratory. " + ) + #:exits + (list (make + #:name "up" + #:to 'computer-room + #:traverse-check + (lambda (exit room whos-exiting) + (values #t "You climb the spiral staircase."))))) + + ;; Test tubes + ;; map + ('underground-lab:map + '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")))) + + + + + ;;; Game ;;; ---- (define (game-spec) (append lobby grand-hallway smoking-parlor - playroom break-room)) + playroom break-room computer-room underground-lab)) ;; TODO: Provide command line args (define (run-game . args)