Ability to move up / down into laboratory
[mudsync.git] / worlds / bricabrac.scm
index dbb32b79ec3004b5fbdbb6d8edd4eb7f078fbbdb..8d3e03a9f8018d67843f7dcb7bd9036cd6b38981 100644 (file)
@@ -419,15 +419,22 @@ this general shape in the 1990s."
 (define* (disc-shield-take gameobj message
                            #:key direct-obj
                            (player (message-from message)))
-  (pk 'hi)
   (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, there is a bright glow...  and a completely separate,
-glowing copy of the disc materializes into your hands!")
-               (p "You hear a voice whispering in your ear: "
-                  (i "\"Share the software... and you'll be free...\"")))))
+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>)
@@ -450,8 +457,11 @@ labeled \"RL02.5\".")
                    #:key direct-obj
                    (player (message-from message)))
   (<- player 'tell
-      #:text "You drop the glowing disc, and it shatters into a million
-pieces!")
+      #: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))
 
 (define grand-hallway
@@ -533,13 +543,11 @@ Hackthena must be an emacs user."
     #:goes-by '("hackthena's horns" "horns" "horns of hacktena"))
    ('grand-hallway:disc-platter
     <disc-shield> '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..."
+    #: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"
-                "hard disk platter" "disk platter"
-                "shield" "platter"))))
+    #:goes-by '("hackthena's shield" "shield" "platter" "hard disk platter"))))
 
 \f
 ;;; Playroom
@@ -800,7 +808,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
@@ -919,7 +927,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)
@@ -978,11 +986,21 @@ the paint, but the wires themselves seem to be unusually sturdy."
 ;; 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, "
@@ -995,8 +1013,159 @@ the paint, but the wires themselves seem to be unusually sturdy."
             "which is pressed in and unlit")
        ". There is a READY indicator "
        ,(if (eq? (.state hard-drive) 'ready)
-            "which is glowing.  The machine emits a gentle whirring noise."
-            "which is unlit."))))
+            "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
@@ -1011,12 +1180,51 @@ hinges which suggest it could be opened."))
     #:exits
     (list (make <exit>
             #:name "east"
-            #:to 'playroom)))
+            #: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 "a hard drive"
+    #:name "the hard drive"
     #:desc (wrap-apply hard-drive-desc)
-    #:goes-by '("hard drive" "drive" "hard disk"))))
+    #: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"))))
+
+
+(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)))))
 
 
 \f
@@ -1025,7 +1233,7 @@ hinges which suggest it could be opened."))
 
 (define (game-spec)
   (append lobby grand-hallway smoking-parlor
-          playroom break-room computer-room))
+          playroom break-room computer-room underground-lab))
 
 ;; TODO: Provide command line args
 (define (run-game . args)