Add container ability to gameobjs

diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm
index 7abb448db99f608352b70a99b0003539f477e41b..7f2f4e202defc63db99f4cf1de60b1bb95a21420 100644 (file)
--- a/mudsync/gameobj.scm
+++ b/mudsync/gameobj.scm
@@ -25,6 +25,7 @@
   #:use-module (8sync agenda)
   #:use-module (8sync rmeta-slot)
   #:use-module (srfi srfi-1)
   #:use-module (8sync agenda)
   #:use-module (8sync rmeta-slot)
   #:use-module (srfi srfi-1)

+  #:use-module (ice-9 control)

   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (oop goops)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (oop goops)


@@ -75,7 +76,11 @@
   ;; Commands we can handle
   (commands #:allocation #:each-subclass
             #:init-thunk (build-commands
   ;; Commands we can handle
   (commands #:allocation #:each-subclass
             #:init-thunk (build-commands

-                          ("take" ((direct-command cmd-take #:obvious? #f)))))
+                          ("take" ((direct-command cmd-take)
+                                   (prep-indir-command cmd-take-from
+                                                       '("from" "out of"))))
+                          ("put" ((prep-indir-command cmd-put-in
+                                                      '("in" "inside" "on"))))))

 
   ;; Commands we can handle by being something's container
   (container-commands #:allocation #:each-subclass
 
   ;; Commands we can handle by being something's container
   (container-commands #:allocation #:each-subclass


@@ -95,14 +100,22 @@
   (visible-to-player?
    #:init-value (wrap-apply gameobj-visible-to-player?))
 
   (visible-to-player?
    #:init-value (wrap-apply gameobj-visible-to-player?))
 

-  ;; Can be a boolean or a procedure accepting two arguments
-  ;; (thing-actor whos-acting)
-  (takeable #:init-value #f
-            #:init-keyword #:takeable)
-  ;; Can be a boolean or a procedure accepting two arguments
-  ;; (thing-actor whos-dropping)
-  (dropable #:init-value #t
-            #:init-keyword #:dropable)
+  ;; Can be a boolean or a procedure accepting
+  ;; (gameobj whos-acting #:key from)
+  (take-me? #:init-value #f
+            #:init-keyword #:take-me?)
+  ;; Can be a boolean or a procedure accepting
+  ;; (gameobj whos-acting where)
+  (drop-me? #:init-value #t
+            #:init-keyword #:drop-me?)
+  ;; Can be a boolean or a procedure accepting
+  ;; (gameobj whos-acting take-what)
+  (take-from-me? #:init-value #f
+                 #:init-keyword #:take-from-me?)
+  ;; Can be a boolean or a procedure accepting
+  ;; (gameobj whos-acting put-what)
+  (put-in-me? #:init-value #f
+              #:init-keyword #:put-in-me?)

 
   ;; TODO: Remove this and use actor-alive? instead.
   ;; Set this on self-destruct
 
   ;; TODO: Remove this and use actor-alive? instead.
   ;; Set this on self-destruct


@@ -134,10 +147,15 @@
             (self-destruct gameobj-act-self-destruct)
             (tell gameobj-tell-no-op)
             (assist-replace gameobj-act-assist-replace)
             (self-destruct gameobj-act-self-destruct)
             (tell gameobj-tell-no-op)
             (assist-replace gameobj-act-assist-replace)

-            (ok-to-drop-here? (const #t)) ; ok to drop by default
+            (ok-to-drop-here? (lambda (gameobj message . _)
+                                (<-reply message #t))) ; ok to drop by default
+            (ok-to-be-taken-from? gameobj-ok-to-be-taken-from)
+            (ok-to-be-put-in? gameobj-ok-to-be-put-in)

 
             ;; Common commands
             (cmd-take cmd-take)
 
             ;; Common commands
             (cmd-take cmd-take)

+            (cmd-take-from cmd-take-from)
+            (cmd-put-in cmd-put-in)

             (cmd-drop cmd-drop))))
 
 
             (cmd-drop cmd-drop))))
 
 


@@ -256,8 +274,7 @@ Assists in its replacement of occupants if necessary and nothing else."
   "Get all present occupants of the room."
   (define occupants
     (gameobj-occupants actor #:exclude exclude))
   "Get all present occupants of the room."
   (define occupants
     (gameobj-occupants actor #:exclude exclude))

-
-  (<-reply message #:occupants occupants))
+  (<-reply message occupants))

 
 (define (gameobj-act-get-loc actor message)
   (<-reply message (slot-ref actor 'loc)))
 
 (define (gameobj-act-get-loc actor message)
   (<-reply message (slot-ref actor 'loc)))


@@ -281,12 +298,12 @@ Assists in its replacement of occupants if necessary and nothing else."
   "Action routine to set the location."
   (gameobj-set-loc! actor loc))
 
   "Action routine to set the location."
   (gameobj-set-loc! actor loc))
 

-(define (slot-ref-maybe-runcheck gameobj slot whos-asking)
+(define (slot-ref-maybe-runcheck gameobj slot whos-asking . other-args)

   "Do a slot-ref on gameobj, evaluating it including ourselves
 and whos-asking, and see if we should just return it or run it."
   (match (slot-ref gameobj slot)
     ((? procedure? slot-val-proc)
   "Do a slot-ref on gameobj, evaluating it including ourselves
 and whos-asking, and see if we should just return it or run it."
   (match (slot-ref gameobj slot)
     ((? procedure? slot-val-proc)

-     (slot-val-proc gameobj whos-asking))
+     (apply slot-val-proc gameobj whos-asking other-args))

     (anything-else anything-else)))
 
 (define gameobj-get-name (simple-slot-getter 'name))
     (anything-else anything-else)))
 
 (define gameobj-get-name (simple-slot-getter 'name))


@@ -340,22 +357,30 @@ By default, this is whether or not the generally-visible flag is set."
 (define gameobj-tell-no-op
   (const 'no-op))
 
 (define gameobj-tell-no-op
   (const 'no-op))
 

-(define (gameobj-replace-data-occupants actor)
+(define (gameobj-replace-data-occupants gameobj)

   "The general purpose list of replacement data"
   (list #:occupants (hash-map->list (lambda (occupant _) occupant)
   "The general purpose list of replacement data"
   (list #:occupants (hash-map->list (lambda (occupant _) occupant)

-                                    (slot-ref actor 'occupants))))
+                                    (slot-ref gameobj 'occupants))))

 
 

-(define (gameobj-replace-data* actor)
+(define (gameobj-replace-data* gameobj)

   ;; For now, just call gameobj-replace-data-occupants.
   ;; But there may be more in the future!
   ;; For now, just call gameobj-replace-data-occupants.
   ;; But there may be more in the future!

-  (gameobj-replace-data-occupants actor))
+  (gameobj-replace-data-occupants gameobj))

 
 ;; So sad that objects must assist in their replacement ;_;
 ;; But that's life in a live hacked game!
 
 ;; So sad that objects must assist in their replacement ;_;
 ;; But that's life in a live hacked game!

-(define (gameobj-act-assist-replace actor message)
+(define (gameobj-act-assist-replace gameobj message)

   "Vanilla method for assisting in self-replacement for live hacking"
   (apply <-reply message
   "Vanilla method for assisting in self-replacement for live hacking"
   (apply <-reply message

-         (gameobj-replace-data* actor)))
+         (gameobj-replace-data* gameobj)))
+
+(define (gameobj-ok-to-be-taken-from gameobj message whos-acting)
+  (<-reply message (slot-ref-maybe-runcheck gameobj 'take-me?
+                                            whos-acting #:from #t)))
+
+(define (gameobj-ok-to-be-put-in gameobj message whos-acting where)
+  (<-reply message (slot-ref-maybe-runcheck gameobj 'drop-me?
+                                            whos-acting where)))

 
 \f
 ;;; Utilities every gameobj has
 
 \f
 ;;; Utilities every gameobj has


@@ -386,7 +411,7 @@ By default, this is whether or not the generally-visible flag is set."
     (mbody-val (<-wait player 'get-loc)))
   (define our-name (slot-ref gameobj 'name))
   (define self-should-take
     (mbody-val (<-wait player 'get-loc)))
   (define our-name (slot-ref gameobj 'name))
   (define self-should-take

-    (slot-ref-maybe-runcheck gameobj 'takeable player))
+    (slot-ref-maybe-runcheck gameobj 'take-me? player))

   ;; @@: Is there any reason to allow the room to object in the way
   ;;   that there is for dropping?  It doesn't seem like it.
   ;; TODO: Allow gameobj to customize
   ;; @@: Is there any reason to allow the room to object in the way
   ;;   that there is for dropping?  It doesn't seem like it.
   ;; TODO: Allow gameobj to customize


@@ -414,9 +439,9 @@ By default, this is whether or not the generally-visible flag is set."
     (mbody-val (<-wait player 'get-loc)))
   (define our-name (slot-ref gameobj 'name))
   (define should-drop
     (mbody-val (<-wait player 'get-loc)))
   (define our-name (slot-ref gameobj 'name))
   (define should-drop

-    (slot-ref-maybe-runcheck gameobj 'dropable player))
+    (slot-ref-maybe-runcheck gameobj 'drop-me? player))

   (define (room-objection-to-drop)
   (define (room-objection-to-drop)

-    (mbody-receive (drop-ok? #:key why-not) ; does the room object to dropping?
+    (mbody-receive (_ drop-ok? #:key why-not) ; does the room object to dropping?

         (<-wait player-loc 'ok-to-drop-here? player (actor-id gameobj))
       (and (not drop-ok?)
            ;; Either give the specified reason, or give a boilerplate one
         (<-wait player-loc 'ok-to-drop-here? player (actor-id gameobj))
       (and (not drop-ok?)
            ;; Either give the specified reason, or give a boilerplate one


@@ -448,3 +473,127 @@ By default, this is whether or not the generally-visible flag is set."
                        player-name
                        our-name)
         #:exclude player))))
                        player-name
                        our-name)
         #:exclude player))))

+
+(define* (cmd-take-from gameobj message
+                        #:key direct-obj indir-obj preposition)
+  (define player (message-from message))
+  (define player-name
+    (mbody-val (<-wait player 'get-name)))
+  (define player-loc
+    (mbody-val (<-wait player 'get-loc)))
+  (define our-name (slot-ref gameobj 'name))
+  ;; We need to check if we even have such a thing
+  (define thing-to-take
+    (call/ec
+     (lambda (return)
+       (for-each (lambda (occupant)
+                   (mbody-receive (_ #:key goes-by)
+                       (<-wait occupant 'goes-by)
+                     (when (member direct-obj goes-by)
+                       (return occupant))))
+                 (gameobj-occupants gameobj))
+       ;; nothing found
+       #f)))
+  (define (should-take-from-me)
+    (and thing-to-take
+         (slot-ref-maybe-runcheck gameobj 'take-from-me? player thing-to-take)))
+  ;; @@: Right now we give the same response to both something not being
+  ;;   an occupant and to not being permitted to be removed.  This isn't
+  ;;   very rich and maybe not as helpful as it could be.  Right now I'm
+  ;;   trying to avoid "leaking" information about if an object isn't there.
+  ;;   However maybe by making the different responses as slots which can be
+  ;;   set, this wouldn't be a problem. 
+ (define default-objection
+    "As much as you'd like to take it, it doesn't seem like you can.")
+  (define (thing-to-take-objection)
+    (mbody-receive (_ taken-ok? #:key why-not) ; does the object object to being removed?
+        (<-wait thing-to-take 'ok-to-be-taken-from? player) ; @@ no need to supply from where
+      (and (not taken-ok?)
+           ;; Either give the specified reason, or give a boilerplate one
+           (or why-not default-objection))))
+  (cond
+   ;; Is it not there, or maybe we won't allow it to be taken?
+   ((or (not thing-to-take) (not (should-take-from-me)))
+    (<- (message-from message) 'tell
+        #:text default-objection))
+   ;; the thing we wsant to take itself has objected...
+   ((thing-to-take-objection) =>
+    (lambda (objection)
+      (<- (message-from message) 'tell
+          #:text objection)))
+   ;; looks like we can take it
+   (else
+    (let ((thing-to-take-name
+           (mbody-val (<-wait thing-to-take 'get-name))))
+      ;; Wait to announce to the player just in case settting the location
+      ;; errors out or something.  Maybe it's overthinking things, I dunno.
+      (<-wait thing-to-take 'set-loc! #:loc player)
+      (<- player 'tell
+          #:text `("You take " ,thing-to-take-name " from "
+                   ,our-name "."))
+      (<- player-loc 'tell-room
+          #:text `(,player-name " takes " ,thing-to-take-name " from "
+                                ,our-name "."))))))
+
+(define* (cmd-put-in gameobj message
+                     #:key direct-obj indir-obj preposition)
+  (define player (message-from message))
+  (define player-name
+    (mbody-val (<-wait player 'get-name)))
+  (define player-loc
+    (mbody-val (<-wait player 'get-loc)))
+  (define our-name (slot-ref gameobj 'name))
+  ;; We need to check if we even have such a thing
+  (define this-thing
+    (call/ec
+     (lambda (return)
+       (for-each (lambda (occupant)
+                   (mbody-receive (_ #:key goes-by)
+                       (<-wait occupant 'goes-by)
+                     (when (member direct-obj goes-by)
+                       (return occupant))))
+                 (pk 'here (mbody-val (<-wait player 'get-occupants))))
+       ;; nothing found
+       #f)))
+  (define (should-put-in-me)
+    (and this-thing
+         (slot-ref-maybe-runcheck gameobj 'put-in-me? player this-thing)))
+  ;; @@: Right now we give the same response to both something not being
+  ;;   an occupant and to not being permitted to be removed.  This isn't
+  ;;   very rich and maybe not as helpful as it could be.  Right now I'm
+  ;;   trying to avoid "leaking" information about if an object isn't there.
+  ;;   However maybe by making the different responses as slots which can be
+  ;;   set, this wouldn't be a problem. 
+  (define default-objection
+    "As much as you'd like to, it doesn't seem like you can put that in there.")
+  (define (this-thing-objection)
+    (mbody-receive (_ put-in-ok? #:key why-not) ; does the object object to being moved?
+        (<-wait this-thing 'ok-to-be-put-in? player (actor-id gameobj))
+      (and (not put-in-ok?)
+           ;; Either give the specified reason, or give a boilerplate one
+           (or why-not default-objection))))
+  (cond
+   ;; Is it not there, or maybe we won't allow it to be taken?
+   ((pk '1st (or (not this-thing) (not (should-put-in-me))))
+    (<- (message-from message) 'tell
+        #:text default-objection))
+   ;; the thing we wsant to take itself has objected...
+   ((pk 'objection (this-thing-objection)) =>
+    (lambda (objection)
+      (<- (message-from message) 'tell
+          #:text objection)))
+   ;; looks like we can take it
+   (else
+    (let ((this-thing-name
+           (mbody-val (<-wait this-thing 'get-name))))
+      
+
+      ;; Wait to announce to the player just in case settting the location
+      ;; errors out or something.  Maybe it's overthinking things, I dunno.
+      (<-wait this-thing 'set-loc! #:loc (actor-id gameobj))
+      (<- player 'tell
+          #:text (pk 'txt `("You put " ,this-thing-name " in "
+                            ,our-name ".")))
+      (<- player-loc 'tell-room
+          #:text `(,player-name " puts " ,this-thing-name " in "
+                                ,our-name "."))))))

diff --git a/mudsync/player.scm b/mudsync/player.scm
index bbd14030dc416a90d92478cbf83e9feda6c6fbc1..0879300e34177e9d2187b3faa0a32cd436c57fba 100644 (file)
--- a/mudsync/player.scm
+++ b/mudsync/player.scm
@@ -160,9 +160,7 @@
   (define co-occupants
     (remove
      (lambda (x) (equal? x (actor-id player)))
   (define co-occupants
     (remove
      (lambda (x) (equal? x (actor-id player)))

-     (mbody-receive (_ #:key occupants)
-         (<-wait player-loc 'get-occupants)
-       occupants)))
+     (mbody-val (<-wait player-loc 'get-occupants))))

 
   ;; @@: There's a race condition here if someone leaves the room
   ;;   during this, heh...
 
   ;; @@: There's a race condition here if someone leaves the room
   ;;   during this, heh...

diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm
index 26b479634df4ffa63fe74ce7011c43b10e53c8e7..4a9240689cb7ab8f9159010f0dde37414a15732b 100644 (file)
--- a/worlds/bricabrac.scm
+++ b/worlds/bricabrac.scm
@@ -422,14 +422,31 @@ if this room is intended for children or child-like adults."
    ('thing:playroom:cubey
     <gameobj> 'room:playroom
     #:name "cubey"
    ('thing:playroom:cubey
     <gameobj> 'room:playroom
     #:name "cubey"

-    #:takeable #t
+    #:take-me? #t

     #:desc "  It's a little foam cube with googly eyes on it.  So cute!")
     #:desc "  It's a little foam cube with googly eyes on it.  So cute!")

-   ('thing:cuddles-plushie
+   ('thing:playroom:cuddles-plushie

     <gameobj> 'room:playroom
     #:name "a cuddles plushie"
     #:goes-by '("plushie" "cuddles plushie" "cuddles")
     <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 "A brightly painted wooden chest.  The word \"TOYS\" is engraved
+on it.  What could be inside?"
+    #: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
 
 
 \f