implement doors

darcs-hash:615125721aa5edfcd8b326f063b1899f4bb72af6

diff --git a/EXAMPLES/advent.lisp b/EXAMPLES/advent.lisp
index e768c049568a651e90ba0740037cc7aaf9d85232..fd86b045e9da4b58db936140e147544a49fc1ed6 100644 (file)
--- a/EXAMPLES/advent.lisp
+++ b/EXAMPLES/advent.lisp
@@ -345,9 +345,9 @@
         (description "It just looks like an ordinary grate\r
                       mounted in concrete.")\r
         (key 'set-of-keys)\r
-        (door-dir\r
+        (direction\r
          (lambda () (if (eql *location* below-the-grate) 'u-to 'd-to)))\r
-        (door-to\r
+        (destination\r
          (lambda () (if (eql *location* below-the-grate)\r
                         outside-grate below-the-grate)))\r
         (glance\r

diff --git a/iflib.lisp b/iflib.lisp
index cfa4d1e358467ee3334024ef4b4ec904a57b4260..dad57f5465c3eeb760326a8cb8d63145820563df 100644 (file)
--- a/iflib.lisp
+++ b/iflib.lisp
@@ -22,9 +22,9 @@
 (defpackage :if-lib\r
   (:use :common-lisp :if-basic-lib :if-console)\r
   (:export :container :room :item :clothing :capacity\r
-           :food :switchable\r
+           :food :switchable :door :predoor\r
           :n-to :ne-to :e-to :se-to :s-to :sw-to :w-to :nw-to :in-to :out-to\r
-          :u-to :d-to :cant-go\r
+          :u-to :d-to :cant-go :destination\r
           :*intscope*  :*outscope* :*location* :*trace-light* :*vowels*\r
           :*score* :*gamestate* :*turns* :*dark*\r
            :add-to-scope :add-to-outscope :found-in :seen-from :with-keys\r
@@ -91,7 +91,9 @@
 \r
 ;;SECTION 2: Library-defined classes and objects\r
 \r
-(ifclass container () (capacity integer) (has :container))\r
+(ifclass predoor ()) ;;Can potentially be locked... \r
+\r
+(ifclass container (predoor) (capacity integer) (has :container))\r
 (ifclass supporter () (capacity integer) (has :supporter))\r
 \r
 (ifclass room () (description string)\r
@@ -118,6 +120,10 @@
          (look (look self)))\r
        (has :~light))\r
 \r
+(ifclass door (predoor scenery) (destination object) (has :door :closed))\r
+\r
+\r
+\r
 ;;Compass directions\r
 (object compass ())\r
 (object dir-n () "north" (name "north" "n") compass (property 'n-to))\r

diff --git a/verbs.lisp b/verbs.lisp
index 7704ce39d994d9c8d6b0484e83927e91a35eb0da..39c66af586b1db27c8ec5d8e37c6706183476cc9 100644 (file)
--- a/verbs.lisp
+++ b/verbs.lisp
@@ -13,7 +13,7 @@
 (defpackage :verb-lib\r
   (:use :common-lisp :if-lib :if-basic-lib)\r
   (:export :attack :take :teleport :examine \r
-          :go-to \r
+          :go-to :pass\r
           :take :put-in :put-on :drop :receive\r
           :wear :strip :enter :climb :drink :eat\r
            :rub :turn :switch-on :switch-off\r
@@ -205,23 +205,28 @@
 \r
 (defaction go-to (dir)\r
   (let ((destination (read-property *location* (property dir))))\r
-    (if destination (go-to-room destination)\r
+    (if destination (exec go-to-dispatch (destination))\r
        (if (provides *location* 'cant-go) \r
            (read-property *location* 'cant-go)\r
            "You can't go here."))))\r
 \r
-;; (defaction go-n () (run-action 'go-to dir-n))\r
-;; (defaction go-ne () (run-action 'go-to dir-ne))\r
-;; (defaction go-e () (run-action 'go-to dir-e))\r
-;; (defaction go-se () (run-action 'go-to dir-se))\r
-;; (defaction go-s () (run-action 'go-to dir-s))\r
-;; (defaction go-sw () (run-action 'go-to dir-sw))\r
-;; (defaction go-w () (run-action 'go-to dir-w))\r
-;; (defaction go-nw () (run-action 'go-to dir-nw))\r
-;; (defaction go-u () (run-action 'go-to dir-u))\r
-;; (defaction go-d () (run-action 'go-to dir-d))\r
-;; (defaction go-in () (run-action 'go-to dir-in))\r
-;; (defaction go-out () (run-action 'go-to dir-out))\r
+(defgeneric go-to-dispatch (dest)\r
+  (:documentation "Dispatches between different kinds of goable objects"))\r
+\r
+(defmethod go-to-dispatch ((dest room))\r
+  (go-to-room dest))\r
+\r
+(defmethod go-to-dispatch ((dest door))\r
+  (unless (has dest :door) (return-from go-to-dispatch (call-next-method)))\r
+  (if (has dest :closed) (format nil "~a is closed." (the-name dest))\r
+      (run-action 'pass *args*)))\r
+\r
+(defaction pass (obj)\r
+  "Something's wrong happened.")\r
+\r
+(defmethod pass ((obj door))\r
+  (go-to-dispatch (read-property obj 'destination))\r
+  (run-action-after obj))\r
 \r
 (defun inventory ()\r
   (sprint "You are carrying: ~a." (list-contents *player*))\r
@@ -436,8 +441,8 @@
 (defaction open (obj)\r
   "You cannot open this.")\r
 \r
-(defmethod open ((obj container))\r
-  (unless (and (has obj :container) (has obj :openable))\r
+(defmethod open ((obj predoor))\r
+  (unless (and (or (has obj :container) (has obj :door)) (has obj :openable))\r
     (return-from open (call-next-method)))  \r
   (if (has obj :closed)\r
       (if (hasnt obj :locked)\r
@@ -451,8 +456,8 @@
 (defaction close (obj)\r
   "You cannot close this.")\r
 \r
-(defmethod close ((obj container))\r
-  (unless (and (has obj :container) (has obj :openable))\r
+(defmethod close ((obj predoor))\r
+  (unless (and (or (has obj :container) (has obj :door)) (has obj :openable))\r
     (return-from close (call-next-method)))\r
   (if (hasnt obj :closed)\r
       (progn \r
@@ -464,8 +469,8 @@
 (defaction lock (obj key)\r
   "Not lockable.")\r
 \r
-(defmethod lock ((obj container) (key item))\r
-  (unless (and (has obj :container) \r
+(defmethod lock ((obj predoor) (key item))\r
+  (unless (and (or (has obj :container) (has obj :door)) \r
                (has obj :openable)\r
                (has obj :lockable))\r
     (return-from lock (call-next-method)))\r
@@ -484,8 +489,8 @@
 (defaction unlock (obj key)\r
   "There is nothing to unlock.")\r
 \r
-(defmethod unlock ((obj container) (key item))\r
-  (unless (and (has obj :container) \r
+(defmethod unlock ((obj predoor) (key item))\r
+  (unless (and (or (has obj :container) (has obj :door)) \r
                (has obj :openable)\r
                (has obj :lockable))\r
     (return-from unlock (call-next-method)))\r
@@ -504,8 +509,8 @@
 (defaction unlock-open (obj key)\r
   "You cannot open this.")\r
 \r
-(defmethod unlock-open ((obj container) (key item))\r
-  (unless (and (has obj :container) \r
+(defmethod unlock-open ((obj predoor) (key item))\r
+  (unless (and (or (has obj :container) (has obj :door)) \r
                (has obj :openable))\r
     (return-from unlock-open (call-next-method)))\r
   (and (run-action 'unlock *args*)\r