Move containers over to their own module.
authorChristopher Allan Webber <cwebber@dustycloud.org>
Sat, 28 Jan 2017 22:40:52 +0000 (16:40 -0600)
committerChristopher Allan Webber <cwebber@dustycloud.org>
Sat, 28 Jan 2017 22:40:52 +0000 (16:40 -0600)
Makefile.am
mudsync/container.scm [new file with mode: 0644]
mudsync/gameobj.scm
worlds/bricabrac.scm

index d6b943c9b48eb3d2373d503a16257d510ed5956c..15f8e8d93b27e7c73361360bf8dfdc36cc51b0de 100644 (file)
@@ -46,6 +46,7 @@ godir=$(libdir)/guile/2.0/ccache
 
 SOURCES =  \
        mudsync/command.scm \
+       mudsync/container.scm \
        mudsync/game-master.scm \
        mudsync/gameobj.scm \
        mudsync/networking.scm \
diff --git a/mudsync/container.scm b/mudsync/container.scm
new file mode 100644 (file)
index 0000000..46a52e5
--- /dev/null
@@ -0,0 +1,169 @@
+;;; Mudsync --- Live hackable MUD
+;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
+;;;
+;;; This file is part of Mudsync.
+;;;
+;;; Mudsync is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Mudsync is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mudsync.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Containers
+
+(define-module (mudsync container)
+  #:use-module (8sync)
+  #:use-module (oop goops)
+  #:use-module (mudsync gameobj)
+  #:use-module (mudsync utils)
+  #:use-module (ice-9 control)
+  #:export (<container>
+            cmd-take-from cmd-put-in))
+
+(define-actor <container> (<gameobj>)
+  ((cmd-take-from cmd-take-from)
+   (cmd-put-in cmd-put-in))
+  ;; Can be a boolean or a procedure accepting
+  ;; (gameobj whos-acting take-what)
+  (take-from-me? #:init-value #t
+                 #:init-keyword #:take-from-me?)
+  ;; Can be a boolean or a procedure accepting
+  ;; (gameobj whos-acting put-what)
+  (put-in-me? #:init-value #t
+              #:init-keyword #:put-in-me?))
+
+;; @@: 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
+                        (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))
+  ;; We need to check if we even have such a thing
+  (define this-thing
+    (call/ec
+     (lambda (return)
+       (for-each (lambda (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)))
+  (define (this-thing-name)
+    (mbody-val (<-wait this-thing 'get-name)))
+  (define (should-take-from-me)
+    (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 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)))))
+  (cond
+   ;; 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 "
+                 ,preposition " " ,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...
+   ((this-thing-objection) =>
+    (lambda (objection)
+      (<- player 'tell
+          #:text objection)))
+   ;; looks like we can take it
+   (else
+    ;; 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
+                     (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))
+  ;; We need to check if we even have such a thing
+  (define this-thing
+    (call/ec
+     (lambda (return)
+       (for-each (lambda (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)))
+  (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)))
+  (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)))))
+  (cond
+   ;; Is it not there, or maybe we won't allow it to be taken?
+   ((not this-thing)
+    (<- player 'tell
+        #:text `("You don't seem to have any such " ,direct-obj " to put "
+                 ,preposition " " ,our-name ".")))
+
+   ((or (not (should-put-in-me)))
+    (<- player 'tell
+        #:text (default-objection)))
+   ;; the thing we wsant to take itself has objected...
+   ((this-thing-objection) =>
+    (lambda (objection)
+      (<- player 'tell
+          #:text objection)))
+   ;; looks like we can take it
+   (else
+    ;; 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))))
index 55b76bbb15dc959139a5b388fd5d6d37a83136e9..64c79f1397b67e34175dd6d6798261401786b49c 100644 (file)
@@ -47,7 +47,7 @@
 
             ;; Some of the more common commands
             cmd-take cmd-drop
-            cmd-take-from cmd-put-in))
+            cmd-take-from-no-op cmd-put-in-no-op))
 
 ;;; Gameobj
 ;;; =======
   ;; (gameobj whos-acting where)
   (drop-me? #:init-value #t
             #:init-keyword #:drop-me?)
-  ;; Can be a boolean or a procedure accepting
-  ;; (gameobj whos-acting take-what)
-  (take-from-me? #:init-value #f
-                 #:init-keyword #:take-from-me?)
-  ;; Can be a boolean or a procedure accepting
-  ;; (gameobj whos-acting put-what)
-  (put-in-me? #:init-value #f
-              #:init-keyword #:put-in-me?)
 
   ;; TODO: Remove this and use actor-alive? instead.
   ;; Set this on self-destruct
 
             ;; Common commands
             (cmd-take cmd-take)
-            (cmd-take-from cmd-take-from)
-            (cmd-put-in cmd-put-in)
-            (cmd-drop cmd-drop))))
+            (cmd-drop cmd-drop)
+            (cmd-take-from cmd-take-from-no-op)
+            (cmd-put-in cmd-put-in-no-op))))
 
 
 ;;; gameobj message handlers
@@ -491,138 +483,18 @@ 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
-                        (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))
-  ;; We need to check if we even have such a thing
-  (define this-thing
-    (call/ec
-     (lambda (return)
-       (for-each (lambda (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)))
-  (define (this-thing-name)
-    (mbody-val (<-wait this-thing 'get-name)))
-  (define (should-take-from-me)
-    (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 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)))))
-  (cond
-   ;; 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...
-   ((this-thing-objection) =>
-    (lambda (objection)
-      (<- player 'tell
-          #:text objection)))
-   ;; looks like we can take it
-   (else
-    ;; 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
-                     (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))
-  ;; We need to check if we even have such a thing
-  (define this-thing
-    (call/ec
-     (lambda (return)
-       (for-each (lambda (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)))
-  (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)))
-  (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)))))
-  (cond
-   ;; Is it not there, or maybe we won't allow it to be taken?
-   ((not this-thing)
-    (<- player 'tell
-        #:text `("You don't seem to have any such " ,direct-obj " to put "
-                 ,preposition " " ,our-name ".")))
-
-   ((or (not (should-put-in-me)))
-    (<- player 'tell
-        #:text (default-objection)))
-   ;; the thing we wsant to take itself has objected...
-   ((this-thing-objection) =>
-    (lambda (objection)
-      (<- player 'tell
-          #:text objection)))
-   ;; looks like we can take it
-   (else
-    ;; 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))))
+(define* (cmd-take-from-no-op gameobj message
+                              #:key direct-obj indir-obj preposition
+                              (player (message-from message)))
+  (<- player 'tell
+      #:text `("It doesn't seem like you can take anything "
+               ,preposition " "
+               ,(slot-ref gameobj 'name) ".")))
+
+(define* (cmd-put-in-no-op gameobj message
+                           #:key direct-obj indir-obj preposition
+                           (player (message-from message)))
+  (<- player 'tell
+      #:text `("It doesn't seem like you can put anything "
+               ,preposition " "
+               ,(slot-ref gameobj 'name) ".")))
index 5676c1004245d9798002d53687bbeedd10cfa8bf..51549873151ea6567620c52fe1c058e454b830fd 100644 (file)
@@ -19,6 +19,7 @@
 ;;; Hotel Bricabrac
 
 (use-modules (mudsync)
+             (mudsync container)
              (8sync actors)
              (8sync agenda)
              (oop goops)
@@ -82,9 +83,9 @@
           (escape)))
       (slot-ref gameobj 'proxy-items))
 
-     (cmd-take-from gameobj message
-                    #:direct-obj direct-obj #:indir-obj indir-obj
-                    #:preposition preposition #:player player))))
+     (<- player 'tell
+        #:text `("You don't see any such " ,direct-obj " to take "
+                 ,preposition " " ,(slot-ref gameobj 'name) ".")))))
 
 
 \f
@@ -525,7 +526,7 @@ if this room is intended for children or child-like adults."
     #:desc "  A warm and fuzzy cuddles plushie!  It's a cuddlefish!")
 
    ('playroom:toy-chest
-    <gameobj> 'playroom
+    <container> 'playroom
     #:name "a toy chest"
     #:goes-by '("toy chest" "chest")
     #:desc (lambda (toy-chest whos-looking)