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

diff --git a/mudsync.scm b/mudsync.scm
index 810f6d45040042b63d6ddd16f789bfb08b8a14ec..1b024f9394a41f2df8bab473bda6a05b96d22310 100644 (file)
--- a/mudsync.scm
+++ b/mudsync.scm
@@ -35,7 +35,9 @@
         command
         player
         room
-        run-game))
+        run-game
+        utils
+        parser))
 
     (for-each (let ((i (module-public-interface (current-module))))
                 (lambda (m)

diff --git a/mudsync/command.scm b/mudsync/command.scm
index 6314c70fbcdc88e162b55af1c62d0e9373989aab..c8cf3624e3b24c5d9e63d5401551cd1b70e0b2b4 100644 (file)
--- a/mudsync/command.scm
+++ b/mudsync/command.scm
@@ -18,6 +18,7 @@
 
 (define-module (mudsync command)
   #:use-module (mudsync parser)
+  #:use-module (mudsync utils)
   #:use-module (8sync actors)
   #:use-module (8sync rmeta-slot)
   #:use-module (srfi srfi-1)
@@ -100,7 +101,7 @@
                 ;; @@: Should we allow fancier matching than this?
                 ;;   Let the actor itself pass along this whole method?
                 (lambda* (goes-by #:key direct-obj)
-                  (member direct-obj goes-by))
+                  (ci-member direct-obj goes-by))
                 action
                 %default-priority
                 obvious?))
@@ -123,9 +124,9 @@
                 (lambda* (goes-by #:key direct-obj indir-obj preposition)
                   (if prepositions
                       (and
-                       (member indir-obj goes-by)
-                       (member preposition prepositions))
-                      (member indir-obj goes-by)))
+                       (ci-member indir-obj goes-by)
+                       (ci-member preposition prepositions))
+                      (ci-member indir-obj goes-by)))
                 action
                 %high-priority
                 obvious?))
@@ -137,9 +138,9 @@
                 (lambda* (goes-by #:key direct-obj indir-obj preposition)
                   (if prepositions
                       (and
-                       (member  direct-obj goes-by)
-                       (member preposition prepositions))
-                      (member direct-obj goes-by)))
+                       (ci-member  direct-obj goes-by)
+                       (ci-member preposition prepositions))
+                      (ci-member direct-obj goes-by)))
                 action
                 %high-priority
                 obvious?))
@@ -178,7 +179,7 @@
   (make-command verbs
                 cmatch-direct-obj-greedy
                 (lambda* (goes-by #:key direct-obj rest)
-                  (member direct-obj goes-by))
+                  (ci-member direct-obj goes-by))
                 action
                 %low-priority
                 obvious?))

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

diff --git a/mudsync/room.scm b/mudsync/room.scm
index 1e0f354ec0cc01a74f51235f3b9de953a92a80bb..3d860496e2fc4113e410f9c45483bb06f999057c 100644 (file)
--- a/mudsync/room.scm
+++ b/mudsync/room.scm
@@ -19,6 +19,7 @@
 (define-module (mudsync room)
   #:use-module (mudsync command)
   #:use-module (mudsync gameobj)
+  #:use-module (mudsync utils)
   #:use-module (8sync actors)
   #:use-module (8sync agenda)
   #:use-module (oop goops)
@@ -185,10 +186,9 @@
    (lambda (return)
      (for-each
       (lambda (occupant)
-        (mbody-receive (_ #:key goes-by)
-            (<-wait occupant 'goes-by)
-          (if (member called-this goes-by)
-              (return occupant))))
+        (define goes-by (mbody-val (<-wait occupant 'goes-by)))
+        (if (ci-member called-this goes-by)
+            (return occupant)))
       (hash-map->list (lambda (key val) key)
                       (slot-ref room 'occupants)))
      #f)))