From: Christopher Allan Webber <cwebber@dustycloud.org>
Date: Mon, 30 Jan 2017 03:42:32 +0000 (-0600)
Subject: Moving looking to be primarily a gameobj action.
X-Git-Tag: fosdem-2017~40
X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=0817a105f789bd12bd0ced0b80df8b671391f338;p=mudsync.git

Moving looking to be primarily a gameobj action.
---

diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm
index 21c6559..0ce19b6 100644
--- a/mudsync/gameobj.scm
+++ b/mudsync/gameobj.scm
@@ -35,6 +35,7 @@
             create-gameobj
             gameobj-loc
             gameobj-gm
+            gameobj-desc
 
             gameobj-act-init
             gameobj-set-loc!
@@ -48,6 +49,7 @@
             dyn-ref
 
             ;; Some of the more common commands
+            cmd-look-at
             cmd-take cmd-drop
             cmd-take-from-no-op cmd-put-in-no-op))
 
@@ -85,6 +87,7 @@
   ;; Commands we can handle
   (commands #:allocation #:each-subclass
             #:init-thunk (build-commands
+                          (("l" "look") ((direct-command cmd-look-at)))
                           ("take" ((direct-command cmd-take)
                                    (prep-indir-command cmd-take-from
                                                        '("from" "out of"))))
@@ -103,6 +106,7 @@
   (contained-commands #:allocation #:each-subclass
                       #:init-thunk 
                       (build-commands
+                       (("l" "look") ((direct-command cmd-look-at)))
                        ("drop" ((direct-command cmd-drop #:obvious? #f)))))
 
   ;; The extremely squishy concept of "props"... properties!
@@ -179,6 +183,7 @@
             (ok-to-be-put-in? gameobj-ok-to-be-put-in)
 
             ;; Common commands
+            (cmd-look-at cmd-look-at)
             (cmd-take cmd-take)
             (cmd-drop cmd-drop)
             (cmd-take-from cmd-take-from-no-op)
@@ -387,10 +392,10 @@ and whos-asking, and see if we should just return it or run it."
 (define* (gameobj-act-set-name! actor message val)
   (slot-set! actor 'name val))
 
-(define* (gameobj-desc actor #:key whos-looking)
-  (match (slot-ref actor 'desc)
+(define* (gameobj-desc gameobj #:key whos-looking)
+  (match (slot-ref gameobj 'desc)
     ((? procedure? desc-proc)
-     (desc-proc actor whos-looking))
+     (desc-proc gameobj whos-looking))
     (desc desc)))
 
 (define* (gameobj-get-desc actor message #:key whos-looking)
@@ -491,6 +496,17 @@ By default, this is whether or not the generally-visible flag is set."
 ;;; Basic actions
 ;;; -------------
 
+(define %formless-desc
+  "You don't see anything special.")
+
+(define* (cmd-look-at gameobj message
+                      #:key direct-obj
+                      (player (message-from message)))
+  (let ((desc
+         (or (gameobj-desc gameobj #:whos-looking player)
+             %formless-desc)))
+    (<- player 'tell #:text desc)))
+
 (define* (cmd-take gameobj message
                    #:key direct-obj
                    (player (message-from message)))
diff --git a/mudsync/room.scm b/mudsync/room.scm
index 0379d3d..69385f6 100644
--- a/mudsync/room.scm
+++ b/mudsync/room.scm
@@ -71,13 +71,18 @@
    #:allocation #:each-subclass
    #:init-thunk
    (build-commands
-    (("l" "look") ((loose-direct-command cmd-look-at)
-             (empty-command cmd-look-room)))
+    (("l" "look") ((empty-command cmd-look-room)))
     ("go" ((empty-command cmd-go-where)
            (loose-direct-command cmd-go)))
     (("say" "\"" "'") ((greedy-command cmd-say)))
     (("emote" "/me") ((greedy-command cmd-emote)))))
 
+  (container-sub-commands
+   #:allocation #:each-subclass
+   #:init-thunk
+   (build-commands
+    (("l" "look") ((loose-direct-command cmd-look-at-from-room)))))
+
   (actions #:allocation #:each-subclass
            #:init-thunk
            (build-actions
@@ -89,7 +94,7 @@
             ;; in this case the command is the same version as the normal
             ;; look-room version
             (cmd-look-room room-look-room)
-            (cmd-look-at room-look-at)
+            (cmd-look-at-from-room room-look-dont-see-it)
             (cmd-say room-cmd-say)
             (cmd-emote room-cmd-emote))))
 
@@ -193,25 +198,10 @@
                       (slot-ref room 'occupants)))
      #f)))
 
-(define %formless-desc
-  "You don't see anything special.")
-
-(define* (room-look-at room message #:key direct-obj)
-  "Look at a specific object in the room."
-  (define matching-object
-    (room-find-thing-called room direct-obj))
-
-  (cond
-   (matching-object
-    (let ((obj-desc
-           (mbody-val (<-wait matching-object 'get-desc
-                            #:whos-looking (message-from message)))))
-      (if obj-desc
-          (<- (message-from message) 'tell #:text obj-desc)
-          (<- (message-from message) 'tell #:text %formless-desc))))
-   (else
-    (<- (message-from message) 'tell
-        #:text "You don't see that here, so you can't look at it.\n"))))
+(define* (room-look-dont-see-it room message #:key direct-obj)
+  "In general, if we get to this point, we didn't find something to look at."
+  (<- (message-from message) 'tell
+      #:text "You don't see that here, so you can't look at it.\n"))
 
 
 (define* (room-tell-room room text #:key exclude wait)