better take/drop
authorChristopher Allan Webber <cwebber@dustycloud.org>
Sat, 28 Jan 2017 18:42:17 +0000 (12:42 -0600)
committerChristopher Allan Webber <cwebber@dustycloud.org>
Sat, 28 Jan 2017 18:42:17 +0000 (12:42 -0600)
mudsync/gameobj.scm

index 66f617f9db2e70f915b18bb09ca96873286266bd..65ddc296262c7d2a767e53db858330170d4aed3d 100644 (file)
             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
 ;;; =======
@@ -474,6 +478,8 @@ By default, this is whether or not the generally-visible flag is set."
                        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)
   (define player (message-from message))
@@ -483,7 +489,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))
   ;; We need to check if we even have such a thing
-  (define thing-to-take
+  (define this-thing
     (call/ec
      (lambda (return)
        (for-each (lambda (occupant)
@@ -494,47 +500,60 @@ By default, this is whether or not the generally-visible flag is set."
                  (gameobj-occupants gameobj))
        ;; nothing found
        #f)))
+  (define (this-thing-name)
+    (mbody-val (<-wait this-thing 'get-name)))
   (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)
+    (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 thing-to-take 'ok-to-be-taken-from? player) ; @@ no need to supply from where
+        (<-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))))
+           (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))
+   ;; 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...
-   ((thing-to-take-objection) =>
+   ((this-thing-objection) =>
     (lambda (objection)
-      (<- (message-from message) 'tell
+      (<- player '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 ".")
-          #:exclude player)))))
+    ;; 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)
@@ -556,28 +575,30 @@ By default, this is whether or not the generally-visible flag is set."
                  (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)))
-  ;; @@: 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 (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))))
+           (or why-not (default-objection)))))
   (cond
    ;; Is it not there, or maybe we won't allow it to be taken?
-   ((or (not this-thing) (not (should-put-in-me)))
+   ((not this-thing)
     (<- (message-from message) 'tell
-        #:text default-objection))
+        #:text `("You don't seem to have any such " ,direct-obj " to put "
+                 ,preposition " " ,our-name ".")))
+
+   ((or (not (should-put-in-me)))
+    (<- (message-from message) 'tell
+        #:text (default-objection)))
    ;; the thing we wsant to take itself has objected...
    ((this-thing-objection) =>
     (lambda (objection)
@@ -585,15 +606,13 @@ By default, this is whether or not the generally-visible flag is set."
           #: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 `("You put " ,this-thing-name " in "
-                   ,our-name "."))
-      (<- player-loc 'tell-room
-          #:text `(,player-name " puts " ,this-thing-name " in "
-                                ,our-name ".")
-          #:exclude player)))))
+    ;; 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))))