Allow to specify what the player is on take-from / put-in / etc as keyword

[mudsync.git] / mudsync / gameobj.scm

diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm
index 20fc291340198c25e12ad2c718c985e55ad35c42..6f2ddf071747d72118fb4c1b2057705955356dfe 100644 (file)
--- a/mudsync/gameobj.scm
+++ b/mudsync/gameobj.scm
@@ -21,9 +21,11 @@
 
 (define-module (mudsync gameobj)
   #:use-module (mudsync command)
 
 (define-module (mudsync gameobj)
   #:use-module (mudsync command)

-  #:use-module (8sync systems actors)
+  #:use-module (8sync actors)

   #:use-module (8sync agenda)
   #:use-module (8sync agenda)

+  #:use-module (8sync rmeta-slot)

   #:use-module (srfi srfi-1)
   #: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)


@@ -35,42 +37,21 @@
             gameobj-act-init
             gameobj-set-loc!
             gameobj-occupants
             gameobj-act-init
             gameobj-set-loc!
             gameobj-occupants

-            gameobj-actions

             gameobj-self-destruct
 
             slot-ref-maybe-runcheck
             val-or-run
 
             gameobj-self-destruct
 
             slot-ref-maybe-runcheck
             val-or-run
 

-            dyn-ref))
+            dyn-ref
+
+            ;; Some of the more common commands
+            cmd-take cmd-drop
+            cmd-take-from cmd-put-in))

 
 ;;; Gameobj
 ;;; =======
 
 
 
 ;;; Gameobj
 ;;; =======
 
 

-;;; Actions supported by all gameobj
-(define gameobj-actions
-  (build-actions
-   (init (wrap-apply gameobj-act-init))
-   ;; Commands for co-occupants
-   (get-commands (wrap-apply gameobj-get-commands))
-   ;; Commands for participants in a room
-   (get-container-commands (wrap-apply gameobj-get-container-commands))
-   ;; Commands for inventory items, etc (occupants of the gameobj commanding)
-   (get-contained-commands (wrap-apply gameobj-get-contained-commands))
-   (get-occupants (wrap-apply gameobj-get-occupants))
-   (add-occupant! (wrap-apply gameobj-add-occupant!))
-   (remove-occupant! (wrap-apply gameobj-remove-occupant!))
-   (get-loc (wrap-apply gameobj-act-get-loc))
-   (set-loc! (wrap-apply gameobj-act-set-loc!))
-   (get-name (wrap-apply gameobj-get-name))
-   (set-name! (wrap-apply gameobj-act-set-name!))
-   (get-desc (wrap-apply gameobj-get-desc))
-   (goes-by (wrap-apply gameobj-act-goes-by))
-   (visible-name (wrap-apply gameobj-visible-name))
-   (self-destruct (wrap-apply gameobj-act-self-destruct))
-   (tell (wrap-apply gameobj-tell-no-op))
-   (assist-replace (wrap-apply gameobj-act-assist-replace))))
-

 ;;; *all* game components that talk to players should somehow
 ;;; derive from this class.
 ;;; And all of them need a GM!
 ;;; *all* game components that talk to players should somehow
 ;;; derive from this class.
 ;;; And all of them need a GM!


@@ -86,6 +67,7 @@
   ;; game master id
   (gm #:init-keyword #:gm
       #:getter gameobj-gm)
   ;; game master id
   (gm #:init-keyword #:gm
       #:getter gameobj-gm)

+

   ;; a name to be known by
   (name #:init-keyword #:name
         #:init-value #f)
   ;; a name to be known by
   (name #:init-keyword #:name
         #:init-value #f)


@@ -96,29 +78,89 @@
         #:init-keyword #:desc)
 
   ;; Commands we can handle
         #:init-keyword #:desc)
 
   ;; Commands we can handle

-  (commands #:init-value '())
+  (commands #:allocation #:each-subclass
+            #:init-thunk (build-commands
+                          ("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
 
   ;; Commands we can handle by being something's container

-  (container-commands #:init-value '())
+  (container-commands #:allocation #:each-subclass
+                      #:init-thunk (build-commands))

 
   ;; Commands we can handle by being contained by something else
 
   ;; Commands we can handle by being contained by something else

-  (contained-commands #:init-value '())
-
-  (message-handler
-   #:init-value
-   (simple-dispatcher gameobj-actions))
+  (contained-commands #:allocation #:each-subclass
+                      #:init-thunk 
+                      (build-commands
+                       ("drop" ((direct-command cmd-drop #:obvious? #f)))))

 
   ;; Most objects are generally visible by default
 
   ;; Most objects are generally visible by default

-  (generally-visible #:init-value #t
-                     #:init-keyword #:generally-visible)
-  ;; @@: Would be preferable to be using generic methods for this...
-  ;;   Hopefully we can port this to Guile 2.2 soon...
+  (invisible? #:init-value #f
+              #:init-keyword #:invisible?)
+  ;; TODO: Fold this into a procedure in invisible? similar
+  ;;   to take-me? and etc

   (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
+  ;; (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
   ;; (checked by some "long running" game routines)
   ;; Set this on self-destruct
   ;; (checked by some "long running" game routines)

-  (destructed #:init-value #f))
+  (destructed #:init-value #f)
+
+  (actions #:allocation #:each-subclass
+           ;;; Actions supported by all gameobj
+           #:init-thunk
+           (build-actions
+            (init gameobj-act-init)
+            ;; Commands for co-occupants
+            (get-commands gameobj-get-commands)
+            ;; Commands for participants in a room
+            (get-container-commands gameobj-get-container-commands)
+            ;; Commands for inventory items, etc (occupants of the gameobj commanding)
+            (get-contained-commands gameobj-get-contained-commands)
+
+            (get-occupants gameobj-get-occupants)
+            (add-occupant! gameobj-add-occupant!)
+            (remove-occupant! gameobj-remove-occupant!)
+            (get-loc gameobj-act-get-loc)
+            (set-loc! gameobj-act-set-loc!)
+            (get-name gameobj-get-name)
+            (set-name! gameobj-act-set-name!)
+            (get-desc gameobj-get-desc)
+            (goes-by gameobj-act-goes-by)
+            (visible-name gameobj-visible-name)
+            (self-destruct gameobj-act-self-destruct)
+            (tell gameobj-tell-no-op)
+            (assist-replace gameobj-act-assist-replace)
+            (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)
+            (cmd-take-from cmd-take-from)
+            (cmd-put-in cmd-put-in)
+            (cmd-drop cmd-drop))))

 
 
 ;;; gameobj message handlers
 
 
 ;;; gameobj message handlers


@@ -127,40 +169,36 @@
 ;; Kind of a useful utility, maybe?
 (define (simple-slot-getter slot)
   (lambda (actor message)
 ;; Kind of a useful utility, maybe?
 (define (simple-slot-getter slot)
   (lambda (actor message)

-    (reply-message actor message
-                   #:val (slot-ref actor slot))))
+    (<-reply message (slot-ref actor slot))))

 
 

-(define (gameobj-replace-step-occupants actor replace-reply)
-  (define occupants
-    (message-ref replace-reply 'occupants #f))
+(define (gameobj-replace-step-occupants actor occupants)

   ;; Snarf all the occupants!
   (display "replacing occupant\n")
   (when occupants
     (for-each
      (lambda (occupant)
   ;; Snarf all the occupants!
   (display "replacing occupant\n")
   (when occupants
     (for-each
      (lambda (occupant)

-       (<-wait actor occupant 'set-loc!
+       (<-wait occupant 'set-loc!

                #:loc (actor-id actor)))
      occupants)))
 
 (define gameobj-replace-steps*
   (list gameobj-replace-step-occupants))
 
                #:loc (actor-id actor)))
      occupants)))
 
 (define gameobj-replace-steps*
   (list gameobj-replace-step-occupants))
 

-(define (run-replacement actor message replace-steps)
-  (define replaces (message-ref message 'replace #f))
+(define (run-replacement actor replaces replace-steps)

   (when replaces
   (when replaces

-    (let ((replace-reply
-           (<-wait actor replaces 'assist-replace)))
+    (mbody-receive (_ #:key occupants)
+        (<-wait replaces 'assist-replace)

       (for-each
        (lambda (replace-step)
       (for-each
        (lambda (replace-step)

-         (replace-step actor replace-reply))
+         (replace-step actor occupants))

        replace-steps))))
 
 ;; @@: This could be kind of a messy way of doing gameobj-act-init
 ;;   stuff.  If only we had generic methods :(
        replace-steps))))
 
 ;; @@: This could be kind of a messy way of doing gameobj-act-init
 ;;   stuff.  If only we had generic methods :(

-(define-mhandler (gameobj-act-init actor message)
+(define* (gameobj-act-init actor message #:key replace)

   "Your most basic game object init procedure.
 Assists in its replacement of occupants if necessary and nothing else."
   "Your most basic game object init procedure.
 Assists in its replacement of occupants if necessary and nothing else."

-  (run-replacement actor message gameobj-replace-steps*))
+  (run-replacement actor replace gameobj-replace-steps*))

 
 (define (gameobj-goes-by gameobj)
   "Find the name we go by.  Defaults to #:name if nothing else provided."
 
 (define (gameobj-goes-by gameobj)
   "Find the name we go by.  Defaults to #:name if nothing else provided."


@@ -173,8 +211,7 @@ Assists in its replacement of occupants if necessary and nothing else."
 
 (define (gameobj-act-goes-by actor message)
   "Reply to a message requesting what we go by."
 
 (define (gameobj-act-goes-by actor message)
   "Reply to a message requesting what we go by."

-  (<-reply actor message
-           #:goes-by (gameobj-goes-by actor)))
+  (<-reply message #:goes-by (gameobj-goes-by actor)))

 
 (define (val-or-run val-or-proc)
   "Evaluate if a procedure, or just return otherwise"
 
 (define (val-or-run val-or-proc)
   "Evaluate if a procedure, or just return otherwise"


@@ -182,44 +219,38 @@ Assists in its replacement of occupants if necessary and nothing else."
       (val-or-proc)
       val-or-proc))
 
       (val-or-proc)
       val-or-proc))
 

-(define (filter-commands commands verb)
-  (filter
-   (lambda (cmd)
-     (equal? (command-verbs cmd)
-             verb))
-   commands))
+(define (get-candidate-commands actor rmeta-sym verb)
+  (class-rmeta-ref (class-of actor) rmeta-sym verb
+                   #:dflt '()))

 
 

-(define-mhandler (gameobj-get-commands actor message verb)
+(define* (gameobj-get-commands actor message #:key verb)

   "Get commands a co-occupant of the room might execute for VERB"
   "Get commands a co-occupant of the room might execute for VERB"

-  (define filtered-commands
-    (filter-commands (val-or-run (slot-ref actor 'commands))
-                     verb))
-  (<-reply actor message
-           #:commands filtered-commands
+  (define candidate-commands
+    (get-candidate-commands actor 'commands verb))
+  (<-reply message
+           #:commands candidate-commands

            #:goes-by (gameobj-goes-by actor)))
 
            #:goes-by (gameobj-goes-by actor)))
 

-(define-mhandler (gameobj-get-container-commands actor message verb)
+(define* (gameobj-get-container-commands actor message #:key verb)

   "Get commands as the container / room of message's sender"
   "Get commands as the container / room of message's sender"

-  (define filtered-commands
-    (filter-commands (val-or-run (slot-ref actor 'container-commands))
-                     verb))
-  (<-reply actor message #:commands filtered-commands))
+  (define candidate-commands
+    (get-candidate-commands actor 'container-commands verb))
+  (<-reply message #:commands candidate-commands))

 
 

-(define-mhandler (gameobj-get-contained-commands actor message verb)
+(define* (gameobj-get-contained-commands actor message #:key verb)

   "Get commands as being contained (eg inventory) of commanding gameobj"
   "Get commands as being contained (eg inventory) of commanding gameobj"

-  (define filtered-commands
-    (filter-commands (val-or-run (slot-ref actor 'contained-commands))
-                     verb))
-  (<-reply actor message
-           #:commands filtered-commands
+  (define candidate-commands
+    (get-candidate-commands actor 'contained-commands verb))
+  (<-reply message
+           #:commands candidate-commands

            #:goes-by (gameobj-goes-by actor)))
 
            #:goes-by (gameobj-goes-by actor)))
 

-(define-mhandler (gameobj-add-occupant! actor message who)
+(define* (gameobj-add-occupant! actor message #:key who)

   "Add an actor to our list of present occupants"
   (hash-set! (slot-ref actor 'occupants)
              who #t))
 
   "Add an actor to our list of present occupants"
   (hash-set! (slot-ref actor 'occupants)
              who #t))
 

-(define-mhandler (gameobj-remove-occupant! actor message who)
+(define* (gameobj-remove-occupant! actor message #:key who)

   "Remove an occupant from the room."
   (hash-remove! (slot-ref actor 'occupants) who))
 
   "Remove an occupant from the room."
   (hash-remove! (slot-ref actor 'occupants) who))
 


@@ -234,7 +265,7 @@ Assists in its replacement of occupants if necessary and nothing else."
          ;; A list of addresses... since our address object is (annoyingly)
          ;; currently a simple cons cell...
          ((exclude-1 ... exclude-rest)
          ;; A list of addresses... since our address object is (annoyingly)
          ;; currently a simple cons cell...
          ((exclude-1 ... exclude-rest)

-          (pk 'failboat (member occupant (pk 'exclude-lst exclude))))
+          (member occupant exclude))

          ;; Must be an individual address!
          (_ (equal? occupant exclude))))
      (if exclude-it?
          ;; Must be an individual address!
          (_ (equal? occupant exclude))))
      (if exclude-it?


@@ -243,18 +274,14 @@ Assists in its replacement of occupants if necessary and nothing else."
    '()
    (slot-ref gameobj 'occupants)))
 
    '()
    (slot-ref gameobj 'occupants)))
 

-(define-mhandler (gameobj-get-occupants actor message)
+(define* (gameobj-get-occupants actor message #:key exclude)

   "Get all present occupants of the room."
   "Get all present occupants of the room."

-  (define exclude (message-ref message 'exclude #f))

   (define occupants
     (gameobj-occupants actor #:exclude exclude))
   (define occupants
     (gameobj-occupants actor #:exclude exclude))

+  (<-reply message occupants))

 
 

-  (<-reply actor message
-           #:occupants occupants))
-
-(define-mhandler (gameobj-act-get-loc actor message)
-  (<-reply actor message
-           #:val (slot-ref actor 'loc)))
+(define (gameobj-act-get-loc actor message)
+  (<-reply message (slot-ref actor 'loc)))

 
 (define (gameobj-set-loc! gameobj loc)
   "Set the location of this object."
 
 (define (gameobj-set-loc! gameobj loc)
   "Set the location of this object."


@@ -266,42 +293,42 @@ Assists in its replacement of occupants if necessary and nothing else."
     (slot-set! gameobj 'loc loc)
     ;; Change registation of where we currently are
     (if old-loc
     (slot-set! gameobj 'loc loc)
     ;; Change registation of where we currently are
     (if old-loc

-        (<-wait gameobj old-loc 'remove-occupant! #:who (actor-id gameobj)))
+        (<-wait old-loc 'remove-occupant! #:who (actor-id gameobj)))

     (if loc
     (if loc

-        (<-wait gameobj loc 'add-occupant! #:who (actor-id gameobj)))))
+        (<-wait loc 'add-occupant! #:who (actor-id gameobj)))))

 
 ;; @@: Should it really be #:id ?  Maybe #:loc-id or #:loc?
 
 ;; @@: Should it really be #:id ?  Maybe #:loc-id or #:loc?

-(define-mhandler (gameobj-act-set-loc! actor message loc)
+(define* (gameobj-act-set-loc! actor message #:key loc)

   "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))
 

-(define-mhandler (gameobj-act-set-name! actor message val)
+(define* (gameobj-act-set-name! actor message val)

   (slot-set! actor 'name val))
 
   (slot-set! actor 'name val))
 

-(define-mhandler (gameobj-get-desc actor message whos-looking)
+(define* (gameobj-get-desc actor message #:key whos-looking)

   (define desc-text
     (match (slot-ref actor 'desc)
       ((? procedure? desc-proc)
        (desc-proc actor whos-looking))
       (desc desc)))
   (define desc-text
     (match (slot-ref actor 'desc)
       ((? procedure? desc-proc)
        (desc-proc actor whos-looking))
       (desc desc)))

-  (<-reply actor message #:val desc-text))
+  (<-reply message desc-text))

 
 (define (gameobj-visible-to-player? gameobj whos-looking)
   "Check to see whether we're visible to the player or not.
 By default, this is whether or not the generally-visible flag is set."
 
 (define (gameobj-visible-to-player? gameobj whos-looking)
   "Check to see whether we're visible to the player or not.
 By default, this is whether or not the generally-visible flag is set."

-  (slot-ref gameobj 'generally-visible))
+  (not (slot-ref gameobj 'invisible?)))

 
 

-(define-mhandler (gameobj-visible-name actor message whos-looking)
+(define* (gameobj-visible-name actor message #:key whos-looking)

   ;; Are we visible?
   (define we-are-visible
     ((slot-ref actor 'visible-to-player?) actor whos-looking))
   ;; Are we visible?
   (define we-are-visible
     ((slot-ref actor 'visible-to-player?) actor whos-looking))


@@ -316,7 +343,7 @@ By default, this is whether or not the generally-visible flag is set."
            name)
           (#f #f))
         #f))
            name)
           (#f #f))
         #f))

-  (<-reply actor message #:text name-to-return))
+  (<-reply message #:text name-to-return))

 
 (define (gameobj-self-destruct gameobj)
   "General gameobj self destruction routine"
 
 (define (gameobj-self-destruct gameobj)
   "General gameobj self destruction routine"


@@ -326,7 +353,7 @@ By default, this is whether or not the generally-visible flag is set."
   ;; Boom!
   (self-destruct gameobj))
 
   ;; Boom!
   (self-destruct gameobj))
 

-(define-mhandler (gameobj-act-self-destruct gameobj message)
+(define* (gameobj-act-self-destruct gameobj message #:key why)

   "Action routine for self destruction"
   (gameobj-self-destruct gameobj))
 
   "Action routine for self destruction"
   (gameobj-self-destruct gameobj))
 


@@ -334,22 +361,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"
   "Vanilla method for assisting in self-replacement for live hacking"

-  (apply <-reply actor message
-         (gameobj-replace-data* actor)))
+  (apply <-reply message
+         (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


@@ -360,11 +395,226 @@ By default, this is whether or not the generally-visible flag is set."
   (match special-symbol
     ;; if it's a symbol, look it up dynamically
     ((? symbol? _)
   (match special-symbol
     ;; if it's a symbol, look it up dynamically
     ((? symbol? _)

-     (message-ref
-      (<-wait gameobj (slot-ref gameobj 'gm) 'lookup-special
-              #:symbol special-symbol)
-      'val))
+     (mbody-val (<-wait (slot-ref gameobj 'gm) 'lookup-special
+                        #:symbol special-symbol)))

     ;; if it's false, return nothing
     (#f #f)
     ;; otherwise it's probably an address, return it as-is
     (_ special-symbol)))
     ;; if it's false, return nothing
     (#f #f)
     ;; otherwise it's probably an address, return it as-is
     (_ special-symbol)))

+
+
+\f
+;;; Basic actions
+;;; -------------
+
+(define* (cmd-take gameobj message
+                   #:key direct-obj
+                   (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))
+  (define self-should-take
+    (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
+  (if self-should-take
+      ;; Set the location to whoever's picking us up
+      (begin
+        (gameobj-set-loc! gameobj player)
+        (<- player 'tell
+            #:text (format #f "You pick up ~a.\n"
+                           our-name))
+        (<- player-loc 'tell-room
+            #:text (format #f "~a picks up ~a.\n"
+                           player-name
+                           our-name)
+            #:exclude player))
+      (<- player 'tell
+          #:text (format #f "It doesn't seem like you can take ~a.\n"
+                         our-name))))
+
+(define* (cmd-drop gameobj message
+                   #:key direct-obj
+                   (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))
+  (define should-drop
+    (slot-ref-maybe-runcheck gameobj 'drop-me? player))
+  (define (room-objection-to-drop)
+    (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
+           (or why-not
+               `("You'd love to drop " ,our-name
+                 " but for some reason it doesn't seem like you can"
+                 " do that here.")))))
+  (cond
+   ((not player-loc)
+    (<- player 'tell
+        #:text `("It doesn't seem like you can drop " ,our-name 
+                " here, because you don't seem to be anywhere?!?")))
+   ;; TODO: Let ourselves supply a reason why not.
+   ((not should-drop)
+    (<- player 'tell
+        #:text (format #f "It doesn't seem like you can drop ~a.\n"
+                       our-name)))
+   ((room-objection-to-drop)
+    (<- player 'tell
+        #:text room-objection-to-drop))
+   (else
+    (gameobj-set-loc! gameobj player-loc)
+    ;; TODO: Allow more flavortext here.
+    (<- player 'tell
+        #:text (format #f "You drop ~a.\n"
+                       our-name))
+    (<- player-loc 'tell-room
+        #:text (format #f "~a drops ~a.\n"
+                       player-name
+                       our-name)
+        #:exclude player))))
+
+;; @@: Moving this to a container subclass/mixin could allow a lot more
+;;   customization of take out / put in phrases
+(define* (cmd-take-from gameobj message
+                        #:key direct-obj indir-obj preposition
+                        (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))))
+                 (gameobj-occupants gameobj))
+       ;; nothing found
+       #f)))
+  (define (this-thing-name)
+    (mbody-val (<-wait this-thing 'get-name)))
+  (define (should-take-from-me)
+    (and this-thing
+         (slot-ref-maybe-runcheck gameobj 'take-from-me? player this-thing)))
+  (define (default-objection)
+    `("Unfortunately, it doesn't seem like you can take "
+      (this-thing-name) " " preposition " " our-name "."))
+
+  (define (this-thing-objection)
+    (mbody-receive (_ taken-ok? #:key why-not) ; does the object object to being removed?
+        (<-wait this-thing '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
+   ;; Wait, aren't we going to check (should-take-from-me) later?
+   ;; Well yes, but this checks if there's a #f as the value, which
+   ;; is a much clearer indication that this doesn't take *anything*.
+   ((not (slot-ref gameobj 'take-from-me?))
+    (<- player 'tell
+        #:text `("It's not really clear how to take something " ,preposition
+                 " " ,our-name ".")))
+
+   ;; Unfortunately this does leak information about what is contained
+   ;; by us.  Maybe not what's wanted in all circumstances.
+   ((not this-thing)
+    (<- player 'tell
+        #:text `("You don't see any such " ,direct-obj " to take from "
+                 ,our-name ".")))
+   ;; A particular objection to taking this thing.
+   ;; We should allow customizing the reason here, which could be
+   ;; provided by the 'ok-to-be-taken-from? slot.
+   ((not (should-take-from-me))
+    (<- player 'tell
+        #:text (default-objection)))
+   ;; the thing we wsant to take itself has objected...
+   ((this-thing-objection) =>
+    (lambda (objection)
+      (<- player 'tell
+          #:text objection)))
+   ;; looks like we can take it
+   (else
+    ;; 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 player)
+    (<- player 'tell
+        #:text `("You take " ,(this-thing-name) " from "
+                 ,our-name "."))
+    (<- player-loc 'tell-room
+        #:text `(,player-name " takes " ,(this-thing-name) " from "
+                              ,our-name ".")
+        #:exclude player))))
+
+(define* (cmd-put-in gameobj message
+                     #:key direct-obj indir-obj preposition
+                     (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))))
+                 (mbody-val (<-wait player 'get-occupants)))
+       ;; nothing found
+       #f)))
+  (define (this-thing-name)
+    (mbody-val (<-wait this-thing 'get-name)))
+  (define (should-put-in-me)
+    (and this-thing
+         (slot-ref-maybe-runcheck gameobj 'put-in-me? player this-thing)))
+  (define (default-objection)
+    `("As much as you'd like to, it doesn't seem like you can put "
+      ,(this-thing-name) " " ,preposition " " ,our-name "."))
+  (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?
+   ((not this-thing)
+    (<- player 'tell
+        #:text `("You don't seem to have any such " ,direct-obj " to put "
+                 ,preposition " " ,our-name ".")))
+
+   ((or (not (should-put-in-me)))
+    (<- player 'tell
+        #:text (default-objection)))
+   ;; the thing we wsant to take itself has objected...
+   ((this-thing-objection) =>
+    (lambda (objection)
+      (<- player 'tell
+          #:text objection)))
+   ;; looks like we can take it
+   (else
+    ;; 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 `("You put " ,(this-thing-name) " " ,preposition " "
+                 ,our-name "."))
+    (<- player-loc 'tell-room
+        #:text `(,player-name " puts " ,(this-thing-name) " " ,preposition " "
+                              ,our-name ".")
+        #:exclude player))))