use ci-member, allow specifying why not to being taken / put down

[mudsync.git] / mudsync / gameobj.scm

diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm
index 6f2ddf071747d72118fb4c1b2057705955356dfe..6c739123d63e862b4537cb2206e004d82d3866b2 100644 (file)
--- a/mudsync/gameobj.scm
+++ b/mudsync/gameobj.scm
@@ -21,6 +21,7 @@
 
 (define-module (mudsync gameobj)
   #:use-module (mudsync command)
+  #:use-module (mudsync utils)
   #:use-module (8sync actors)
   #:use-module (8sync agenda)
   #:use-module (8sync rmeta-slot)
@@ -211,7 +212,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."
-  (<-reply message #:goes-by (gameobj-goes-by actor)))
+  (<-reply message (gameobj-goes-by actor)))
 
 (define (val-or-run val-or-proc)
   "Evaluate if a procedure, or just return otherwise"
@@ -379,12 +380,20 @@ By default, this is whether or not the generally-visible flag is set."
          (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)))
+  (call-with-values (lambda ()
+                      (slot-ref-maybe-runcheck gameobj 'take-me?
+                                               whos-acting #:from #t))
+    ;; This allows this to reply with #:why-not if appropriate
+    (lambda args
+      (apply <-reply message args))))
 
 (define (gameobj-ok-to-be-put-in gameobj message whos-acting where)
-  (<-reply message (slot-ref-maybe-runcheck gameobj 'drop-me?
-                                            whos-acting where)))
+  (call-with-values (lambda ()
+                      (slot-ref-maybe-runcheck gameobj 'drop-me?
+                                               whos-acting where))
+    ;; This allows this to reply with #:why-not if appropriate
+    (lambda args
+      (apply <-reply message args))))
 
 \f
 ;;; Utilities every gameobj has
@@ -419,22 +428,24 @@ By default, this is whether or not the generally-visible flag is set."
     (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))))
+  (call-with-values (lambda ()
+                      (slot-ref-maybe-runcheck gameobj 'take-me? player))
+    (lambda* (self-should-take #:key (why-not
+                                      `("It doesn't seem like you can take "
+                                        ,our-name ".")))
+      (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 why-not)))))
 
 (define* (cmd-drop gameobj message
                    #:key direct-obj
@@ -495,10 +506,9 @@ By default, this is whether or not the generally-visible flag is set."
     (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))))
+                   (define goes-by (mbody-val (<-wait occupant 'goes-by)))
+                   (when (ci-member direct-obj goes-by)
+                     (return occupant)))
                  (gameobj-occupants gameobj))
        ;; nothing found
        #f)))
@@ -570,10 +580,9 @@ By default, this is whether or not the generally-visible flag is set."
     (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))))
+                   (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)))