X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=mudsync%2Fgameobj.scm;h=7abb448db99f608352b70a99b0003539f477e41b;hp=370ba47d2d67ecb104a9d37d0950a85dd6b81fa2;hb=566bf50b08106fe68270c79420886a546666e786;hpb=5b9d1025df991e96148eeefe5fb9653e033e7f82

diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm
index 370ba47..7abb448 100644
--- a/mudsync/gameobj.scm
+++ b/mudsync/gameobj.scm
@@ -23,6 +23,7 @@
   #:use-module (mudsync command)
   #:use-module (8sync actors)
   #:use-module (8sync agenda)
+  #:use-module (8sync rmeta-slot)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
@@ -61,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)
@@ -71,13 +73,19 @@
         #:init-keyword #:desc)
 
   ;; Commands we can handle
-  (commands #:init-value '())
+  (commands #:allocation #:each-subclass
+            #:init-thunk (build-commands
+                          ("take" ((direct-command cmd-take #:obvious? #f)))))
 
   ;; 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
-  (contained-commands #:init-value '())
+  (contained-commands #:allocation #:each-subclass
+                      #:init-thunk 
+                      (build-commands
+                       ("drop" ((direct-command cmd-drop #:obvious? #f)))))
 
   ;; Most objects are generally visible by default
   (generally-visible #:init-value #t
@@ -87,13 +95,23 @@
   (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)
 
   (actions #:allocation #:each-subclass
            ;;; Actions supported by all gameobj
-           #:init-value
+           #:init-thunk
            (build-actions
             (init gameobj-act-init)
             ;; Commands for co-occupants
@@ -102,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!)
@@ -114,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
@@ -173,36 +197,30 @@ Assists in its replacement of occupants if necessary and nothing else."
       (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* (gameobj-get-commands actor message #:key 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))
+  (define candidate-commands
+    (get-candidate-commands actor 'commands verb))
   (<-reply message
-           #:commands filtered-commands
+           #:commands candidate-commands
            #:goes-by (gameobj-goes-by actor)))
 
 (define* (gameobj-get-container-commands actor message #:key verb)
   "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 message #:commands filtered-commands))
+  (define candidate-commands
+    (get-candidate-commands actor 'container-commands verb))
+  (<-reply message #:commands candidate-commands))
 
 (define* (gameobj-get-contained-commands actor message #:key verb)
   "Get commands as being contained (eg inventory) of commanding gameobj"
-  (define filtered-commands
-    (filter-commands (val-or-run (slot-ref actor 'contained-commands))
-                     verb))
+  (define candidate-commands
+    (get-candidate-commands actor 'contained-commands verb))
   (<-reply message
-           #:commands filtered-commands
+           #:commands candidate-commands
            #:goes-by (gameobj-goes-by actor)))
 
 (define* (gameobj-add-occupant! actor message #:key who)
@@ -314,7 +332,7 @@ By default, this is whether or not the generally-visible flag is set."
   ;; Boom!
   (self-destruct gameobj))
 
-(define (gameobj-act-self-destruct gameobj message)
+(define* (gameobj-act-self-destruct gameobj message #:key why)
   "Action routine for self destruction"
   (gameobj-self-destruct gameobj))
 
@@ -354,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))))