X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=mudsync%2Fgameobj.scm;h=7abb448db99f608352b70a99b0003539f477e41b;hp=00858522281f2bc5257b6b13e51fe2c14aad469c;hb=566bf50b08106fe68270c79420886a546666e786;hpb=792da4a3c180c3fdb1797e3a5c2d4bca6f40b42d

diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm
index 0085852..7abb448 100644
--- a/mudsync/gameobj.scm
+++ b/mudsync/gameobj.scm
@@ -62,6 +62,7 @@
   ;; game master id
   (gm #:init-keyword #:gm
       #:getter gameobj-gm)
+
   ;; a name to be known by
   (name #:init-keyword #:name
         #:init-value #f)
@@ -73,7 +74,8 @@
 
   ;; Commands we can handle
   (commands #:allocation #:each-subclass
-            #:init-thunk (build-commands))
+            #:init-thunk (build-commands
+                          ("take" ((direct-command cmd-take #:obvious? #f)))))
 
   ;; Commands we can handle by being something's container
   (container-commands #:allocation #:each-subclass
@@ -81,7 +83,9 @@
 
   ;; Commands we can handle by being contained by something else
   (contained-commands #:allocation #:each-subclass
-                      #:init-thunk (build-commands))
+                      #:init-thunk 
+                      (build-commands
+                       ("drop" ((direct-command cmd-drop #:obvious? #f)))))
 
   ;; Most objects are generally visible by default
   (generally-visible #:init-value #t
@@ -91,6 +95,16 @@
   (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)
+
+  ;; TODO: Remove this and use actor-alive? instead.
   ;; Set this on self-destruct
   ;; (checked by some "long running" game routines)
   (destructed #:init-value #f)
@@ -106,6 +120,7 @@
             (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!)
@@ -118,7 +133,12 @@
             (visible-name gameobj-visible-name)
             (self-destruct gameobj-act-self-destruct)
             (tell gameobj-tell-no-op)
-            (assist-replace gameobj-act-assist-replace))))
+            (assist-replace gameobj-act-assist-replace)
+            (ok-to-drop-here? (const #t)) ; ok to drop by default
+
+            ;; Common commands
+            (cmd-take cmd-take)
+            (cmd-drop cmd-drop))))
 
 
 ;;; gameobj message handlers
@@ -352,3 +372,79 @@ By default, this is whether or not the generally-visible flag is set."
     (#f #f)
     ;; otherwise it's probably an address, return it as-is
     (_ special-symbol)))
+
+
+
+;;; Basic actions
+;;; -------------
+
+(define* (cmd-take gameobj message #:key direct-obj)
+  (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))
+  (define self-should-take
+    (slot-ref-maybe-runcheck gameobj 'takeable 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)
+  (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))
+  (define should-drop
+    (slot-ref-maybe-runcheck gameobj 'dropable 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))))