X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=worlds%2Fbricabrac.scm;h=55e9cc2654f476355f2019e379a4a4b9d73cbd2b;hp=ee0ff08806fee83f987274839ce00123df610225;hb=e16f5c202440d4091b54b1b45d7e023b4fcd4a6d;hpb=74f3d0ded31d7622c9fdaea29687850449ffd5e7

diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm
index ee0ff08..55e9cc2 100644
--- a/worlds/bricabrac.scm
+++ b/worlds/bricabrac.scm
@@ -20,8 +20,7 @@
 
 (use-modules (mudsync)
              (mudsync container)
-             (8sync actors)
-             (8sync agenda)
+             (8sync)
              (oop goops)
              (ice-9 control)
              (ice-9 format)
@@ -57,9 +56,9 @@
            #: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
@@ -79,7 +78,7 @@
           (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)))
+          (escape #f)))
       (slot-ref gameobj 'proxy-items))
 
      (<- player 'tell
@@ -132,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))))
@@ -280,15 +280,17 @@ 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
     <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.")
+    #: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
+   ;; TODO: respond to attempts to open the curio cabinet
    ('lobby:cabinet
     <proxy-items> 'lobby
     #:proxy-items '(lobby:porcelain-doll
@@ -412,6 +414,73 @@ this general shape in the 1990s."
 ;;; 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))
+
+
+;;; Grand hallway
+
+(define lobby-map-text
+  "\
+                        |  :       :  |
+  .----------.----------.  :   &   :  .----------.----------.
+  | computer |          |& :YOU ARE: &|  smoking | *UNDER*  |
+  | room     + playroom +  : HERE  :  +  parlor  | *CONS-   |
+  |    >     |          |& :       : &|          | TRUCTION*|
+  '----------'----------'-++-------++-'-------+--'----------'
+                       |    '-----'    |     |   |
+                       :     LOBBY     :     '---'
+                        '.           .'
+                          '---------'")
+
 (define grand-hallway
   (lol
    ('grand-hallway
@@ -435,6 +504,15 @@ room\", while a door to the west is labeled \"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"
@@ -490,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
-    <gameobj> '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..."
+    <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 '("hard disc platter" "disc platter" "disc" "shield" "platter"))))
+    #:goes-by '("hackthena's shield" "shield" "platter" "hard disk platter"))))
 
 
 ;;; Playroom
@@ -506,12 +584,16 @@ platter!  It looks kind of loose..."
    ('playroom
     <room> #f
     #:name "The Playroom"
-    #:desc "  There are toys scattered everywhere here.  It's really unclear
-if this room is intended for children or child-like adults."
+    #:desc '(p ("  There are toys scattered everywhere here.  It's really unclear
+if this room is intended for children or child-like adults.")
+               ("  There are doors to both the east and the west."))
     #:exits
     (list (make <exit>
             #:name "east"
-            #:to 'grand-hallway)))
+            #:to 'grand-hallway)
+          (make <exit>
+            #:name "west"
+            #:to 'computer-room)))
    ('playroom:cubey
     <gameobj> 'playroom
     #:name "Cubey"
@@ -752,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
@@ -871,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)
@@ -925,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 <hard-drive> (<gameobj>)
+  ((cmd-put-in hard-drive-insert)
+   (cmd-push-button hard-drive-push-button)
+   (get-state hard-drive-act-get-state))
+  (commands #:allocation #:each-subclass
+            #:init-thunk (build-commands
+                          ("insert" ((prep-indir-command cmd-put-in
+                                                         '("in" "inside" "into"))))
+                          (("press" "push") ((prep-indir-command cmd-push-button)))))
+  ;; the state moves from: empty -> with-disc -> loading -> ready
+  (state #:init-value 'empty
+         #:accessor .state))
+
+(define (hard-drive-act-get-state hard-drive message)
+  (<-reply message (.state hard-drive)))
+
+(define* (hard-drive-desc hard-drive #:optional whos-looking)
+  `((p "The hard drive is labeled \"RL02.5\".  It's a little under a meter tall.")
+    (p "There is a slot where a disk platter could be inserted, "
+       ,(if (eq? (.state hard-drive) 'empty)
+            "which is currently empty"
+            "which contains a glowing platter")
+       ". There is a LOAD button "
+       ,(if (member (.state hard-drive) '(empty with-disc))
+            "which is glowing"
+            "which is pressed in and unlit")
+       ". There is a READY indicator "
+       ,(if (eq? (.state hard-drive) 'ready)
+            "which is glowing."
+            "which is unlit.")
+       ,(if (member (.state hard-drive) '(loading ready))
+            "  The machine emits a gentle whirring noise."
+            ""))))
+
+(define* (hard-drive-push-button gameobj message
+                                 #:key direct-obj indir-obj preposition
+                                 (player (message-from message)))
+  (define (tell-room text)
+    (<-wait (gameobj-loc gameobj) 'tell-room
+            #:text text))
+  (define (tell-room-excluding-player text)
+    (<-wait (gameobj-loc gameobj) 'tell-room
+            #:text text
+            #:exclude player))
+  (cond
+   ((ci-member direct-obj '("button" "load button" "load"))
+    (tell-room-excluding-player
+     `(,(mbody-val (<-wait player 'get-name))
+       " presses the button on the hard disk."))
+    (<- player 'tell
+        #:text "You press the button on the hard disk.")
+
+    (case (.state gameobj)
+      ((empty)
+       ;; I have no idea what this drive did when you didn't have a platter
+       ;; in it and pressed load, but I know there was a FAULT button.
+       (tell-room "You hear some movement inside the hard drive...")
+       (8sleep 1.5)
+       (tell-room
+        '("... but then the FAULT button blinks a couple times. "
+          "What could be missing?")))
+      ((with-disc)
+       (set! (.state gameobj) 'loading)
+       (tell-room "The hard disk begins to spin up!")
+       (8sleep 2)
+       (set! (.state gameobj) 'ready)
+       (tell-room "The READY light turns on!"))
+      ((loading ready)
+       (<- player 'tell
+           #:text '("Pressing the button does nothing right now, "
+                    "but it does feel satisfying.")))))
+   (else
+    (<- player 'tell
+        #:text '("How could you think of pressing anything else "
+                 "but that tantalizing button right in front of you?")))))
+
+(define* (hard-drive-insert gameobj message
+                            #:key direct-obj indir-obj preposition
+                            (player (message-from message)))
+  (define our-name (slot-ref gameobj 'name))
+  (define this-thing
+    (call/ec
+     (lambda (return)
+       (for-each (lambda (occupant)
+                   (define goes-by (mbody-val (<-wait occupant 'goes-by)))
+                   (when (ci-member direct-obj goes-by)
+                     (return occupant)))
+                 (mbody-val (<-wait player 'get-occupants)))
+       ;; nothing found
+       #f)))
+  (cond
+   ((not this-thing)
+    (<- player 'tell
+        #:text `("You don't seem to have any such " ,direct-obj " to put "
+                 ,preposition " " ,our-name ".")))
+   ((not (mbody-val (<-wait this-thing 'get-prop 'hd-platter?)))
+    (<- player 'tell
+        #:text `("It wouldn't make sense to put "
+                 ,(mbody-val (<-wait this-thing 'get-name))
+                 " " ,preposition " " ,our-name ".")))
+   ((not (eq? (.state gameobj) 'empty))
+    (<- player 'tell
+        #:text "The disk drive already has a platter in it."))
+   (else
+    (set! (.state gameobj) 'with-disc)
+    (<- player 'tell
+        #:text '((p "You insert the glowing disc into the drive.")
+                 (p "The LOAD button begins to glow."))))))
+
+;; The computar
+(define-actor <computer> (<gameobj>)
+  ((cmd-run-program computer-run-program)
+   (cmd-run-what (lambda (gameobj message . _)
+                   (<- (message-from message) 'tell
+                       #:text '("The computer is already running, and a program appears "
+                                "ready to run."
+                                "you mean to \"run the program on the computer\"")))))
+  (commands #:allocation #:each-subclass
+            #:init-thunk (build-commands
+                          ("run" ((prep-indir-command cmd-run-program
+                                                      '("on"))
+                                  (direct-command cmd-run-what))))))
+
+(define* (computer-run-program gameobj message
+                               #:key direct-obj indir-obj preposition
+                               (player (message-from message)))
+  (define (hd-state)
+    (mbody-val (<-wait (dyn-ref gameobj 'computer-room:hard-drive) 'get-state)))
+  (define (tell-room text)
+    (<-wait (gameobj-loc gameobj) 'tell-room
+        #:text text))
+  (define (tell-room-excluding-player text)
+    (<-wait (gameobj-loc gameobj) 'tell-room
+            #:text text
+            #:exclude player))
+  (define (tell-player text)
+    (<-wait player 'tell
+            #:text text))
+  (cond
+   ((ci-member direct-obj '("program"))
+    (tell-room-excluding-player
+     `(,(mbody-val (<-wait player 'get-name))
+       " runs the program loaded on the computer..."))
+    (tell-player "You run the program on the computer...")
+
+    (cond
+     ((not (eq? (hd-state) 'ready))
+      (tell-room '("... but it errors out. "
+                   "It seems to be complaining about a " (b "DISK ERROR!")
+                   ". It looks like it is missing some essential software.")))
+     (else
+      (<- (dyn-ref gameobj 'computer-room:floor-panel) 'open-up))))))
+
+
+;; floor panel
+(define-actor <floor-panel> (<gameobj>)
+  ;; TODO: Add "open" verb, since obviously people will try that
+  ((open? (lambda (panel message)
+            (<-reply message (slot-ref panel 'open))))
+   (open-up floor-panel-open-up))
+  (open #:init-value #f))
+
+(define (floor-panel-open-up panel message)
+  (if (slot-ref panel 'open)
+      (<- (gameobj-loc panel) 'tell-room
+          #:text '("You hear some gears grind around the hinges of the "
+                   "floor panel, but it appears to already be open."))
+      (begin
+        (slot-set! panel 'open #t)
+        (<- (gameobj-loc panel) 'tell-room
+            #:text '("You hear some gears grind, as the metal panel on "
+                     "the ground opens and reveals a stairwell going down!")))))
+
+(define* (floor-panel-desc panel #:optional whos-looking)
+  `("It's a large metal panel on the floor in the middle of the room. "
+    ,(if (slot-ref panel 'open)
+         '("It's currently wide open, revealing a spiraling staircase "
+           "which descends into darkness.")
+         '("It's currently closed shut, but there are clearly hinges, and "
+           "it seems like there is a mechanism which probably opens it via "
+           "some automation.  What could be down there?"))))
+
+(define computer-room
+  (lol
+   ('computer-room
+    <room> #f
+    #:name "Computer Room"
+    #:desc (lambda (gameobj whos-looking)
+             (define panel-open
+               (mbody-val (<-wait (dyn-ref gameobj 'computer-room:floor-panel)
+                                  'open?)))
+             `((p "A sizable computer cabinet covers a good portion of the left
+ wall.  It emits a pleasant hum which covers the room like a warm blanket.
+ Connected to a computer is a large hard drive.")
+               (p "On the floor is a large steel panel.  "
+                  ,(if panel-open
+                       '("It is wide open, exposing a spiral staircase "
+                         "which descends into darkness.")
+                       '("It is closed, but it has hinges which "
+                         "suggest it could be opened.")))))
+    #:exits
+    (list (make <exit>
+            #:name "east"
+            #:to 'playroom)
+          (make <exit>
+            #:name "down"
+            #:to 'underground-lab
+            #:traverse-check
+            (lambda (exit room whos-exiting)
+              (define panel-open
+                (mbody-val (<-wait (dyn-ref room 'computer-room:floor-panel)
+                                   'open?)))
+              (if panel-open
+                  (values #t "You descend the spiral staircase.")
+                  (values #f '("You'd love to go down, but the only way "
+                               "through is through that metal panel, "
+                               "which seems closed.")))))))
+   ('computer-room:hard-drive
+    <hard-drive> 'computer-room
+    #:name "the hard drive"
+    #:desc (wrap-apply hard-drive-desc)
+    #:goes-by '("hard drive" "drive" "hard disk"))
+   ('computer-room:computer
+    <computer> 'computer-room
+    #:name "the computer"
+    #:desc '((p "It's a coat closet sized computer labeled \"PDP-11.5\". ")
+             (p "The computer is itself turned on, and it looks like it is "
+                "all set up for you to run a program on it."))
+    #:goes-by '("computer"))
+   ('computer-room:floor-panel
+    <floor-panel> 'computer-room
+    #:name "a floor panel"
+    #:desc (wrap-apply floor-panel-desc)
+    #:invisible? #t
+    #:goes-by '("floor panel" "panel"))))
+
+
+;;; * 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
+    <room> #f
+    #:name "Underground laboratory"
+    #:desc '("This appears to be some sort of underground laboratory. "
+             )
+    #:exits
+    (list (make <exit>
+            #:name "up"
+            #:to 'computer-room
+            #:traverse-check
+            (lambda (exit room whos-exiting)
+              (values #t "You climb the spiral staircase.")))))
+
+   ;; Test tubes
+   ;; map
+   ('underground-lab:map
+    <readable> 'underground-lab
+    #:name "the underground map"
+    #:desc '("This appears to be a map of the surrounding area. "
+             "You could read it if you want to.")
+    #:read-text `(pre ,underground-map-text)
+    #:goes-by '("map" "underground map" "lab map"))))
+
+
+
+
+
 
 ;;; 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)