implement doors
Thu Jul 27 10:48:12 PDT 2006 grue@mail.ru
* implement doors
diff -rN -u old-lifp/EXAMPLES/advent.lisp new-lifp/EXAMPLES/advent.lisp
--- old-lifp/EXAMPLES/advent.lisp 2014-07-28 03:22:58.000000000 -0700
+++ new-lifp/EXAMPLES/advent.lisp 2014-07-28 03:22:58.000000000 -0700
@@ -345,9 +345,9 @@
(description "It just looks like an ordinary grate
mounted in concrete.")
(key 'set-of-keys)
- (door-dir
+ (direction
(lambda () (if (eql *location* below-the-grate) 'u-to 'd-to)))
- (door-to
+ (destination
(lambda () (if (eql *location* below-the-grate)
outside-grate below-the-grate)))
(glance
diff -rN -u old-lifp/iflib.lisp new-lifp/iflib.lisp
--- old-lifp/iflib.lisp 2014-07-28 03:22:58.000000000 -0700
+++ new-lifp/iflib.lisp 2014-07-28 03:22:58.000000000 -0700
@@ -22,9 +22,9 @@
(defpackage :if-lib
(:use :common-lisp :if-basic-lib :if-console)
(:export :container :room :item :clothing :capacity
- :food :switchable
+ :food :switchable :door :predoor
:n-to :ne-to :e-to :se-to :s-to :sw-to :w-to :nw-to :in-to :out-to
- :u-to :d-to :cant-go
+ :u-to :d-to :cant-go :destination
:*intscope* :*outscope* :*location* :*trace-light* :*vowels*
:*score* :*gamestate* :*turns* :*dark*
:add-to-scope :add-to-outscope :found-in :seen-from :with-keys
@@ -91,7 +91,9 @@
;;SECTION 2: Library-defined classes and objects
-(ifclass container () (capacity integer) (has :container))
+(ifclass predoor ()) ;;Can potentially be locked...
+
+(ifclass container (predoor) (capacity integer) (has :container))
(ifclass supporter () (capacity integer) (has :supporter))
(ifclass room () (description string)
@@ -118,6 +120,10 @@
(look (look self)))
(has :~light))
+(ifclass door (predoor scenery) (destination object) (has :door :closed))
+
+
+
;;Compass directions
(object compass ())
(object dir-n () "north" (name "north" "n") compass (property 'n-to))
diff -rN -u old-lifp/verbs.lisp new-lifp/verbs.lisp
--- old-lifp/verbs.lisp 2014-07-28 03:22:58.000000000 -0700
+++ new-lifp/verbs.lisp 2014-07-28 03:22:58.000000000 -0700
@@ -13,7 +13,7 @@
(defpackage :verb-lib
(:use :common-lisp :if-lib :if-basic-lib)
(:export :attack :take :teleport :examine
- :go-to
+ :go-to :pass
:take :put-in :put-on :drop :receive
:wear :strip :enter :climb :drink :eat
:rub :turn :switch-on :switch-off
@@ -205,23 +205,28 @@
(defaction go-to (dir)
(let ((destination (read-property *location* (property dir))))
- (if destination (go-to-room destination)
+ (if destination (exec go-to-dispatch (destination))
(if (provides *location* 'cant-go)
(read-property *location* 'cant-go)
"You can't go here."))))
-;; (defaction go-n () (run-action 'go-to dir-n))
-;; (defaction go-ne () (run-action 'go-to dir-ne))
-;; (defaction go-e () (run-action 'go-to dir-e))
-;; (defaction go-se () (run-action 'go-to dir-se))
-;; (defaction go-s () (run-action 'go-to dir-s))
-;; (defaction go-sw () (run-action 'go-to dir-sw))
-;; (defaction go-w () (run-action 'go-to dir-w))
-;; (defaction go-nw () (run-action 'go-to dir-nw))
-;; (defaction go-u () (run-action 'go-to dir-u))
-;; (defaction go-d () (run-action 'go-to dir-d))
-;; (defaction go-in () (run-action 'go-to dir-in))
-;; (defaction go-out () (run-action 'go-to dir-out))
+(defgeneric go-to-dispatch (dest)
+ (:documentation "Dispatches between different kinds of goable objects"))
+
+(defmethod go-to-dispatch ((dest room))
+ (go-to-room dest))
+
+(defmethod go-to-dispatch ((dest door))
+ (unless (has dest :door) (return-from go-to-dispatch (call-next-method)))
+ (if (has dest :closed) (format nil "~a is closed." (the-name dest))
+ (run-action 'pass *args*)))
+
+(defaction pass (obj)
+ "Something's wrong happened.")
+
+(defmethod pass ((obj door))
+ (go-to-dispatch (read-property obj 'destination))
+ (run-action-after obj))
(defun inventory ()
(sprint "You are carrying: ~a." (list-contents *player*))
@@ -436,8 +441,8 @@
(defaction open (obj)
"You cannot open this.")
-(defmethod open ((obj container))
- (unless (and (has obj :container) (has obj :openable))
+(defmethod open ((obj predoor))
+ (unless (and (or (has obj :container) (has obj :door)) (has obj :openable))
(return-from open (call-next-method)))
(if (has obj :closed)
(if (hasnt obj :locked)
@@ -451,8 +456,8 @@
(defaction close (obj)
"You cannot close this.")
-(defmethod close ((obj container))
- (unless (and (has obj :container) (has obj :openable))
+(defmethod close ((obj predoor))
+ (unless (and (or (has obj :container) (has obj :door)) (has obj :openable))
(return-from close (call-next-method)))
(if (hasnt obj :closed)
(progn
@@ -464,8 +469,8 @@
(defaction lock (obj key)
"Not lockable.")
-(defmethod lock ((obj container) (key item))
- (unless (and (has obj :container)
+(defmethod lock ((obj predoor) (key item))
+ (unless (and (or (has obj :container) (has obj :door))
(has obj :openable)
(has obj :lockable))
(return-from lock (call-next-method)))
@@ -484,8 +489,8 @@
(defaction unlock (obj key)
"There is nothing to unlock.")
-(defmethod unlock ((obj container) (key item))
- (unless (and (has obj :container)
+(defmethod unlock ((obj predoor) (key item))
+ (unless (and (or (has obj :container) (has obj :door))
(has obj :openable)
(has obj :lockable))
(return-from unlock (call-next-method)))
@@ -504,8 +509,8 @@
(defaction unlock-open (obj key)
"You cannot open this.")
-(defmethod unlock-open ((obj container) (key item))
- (unless (and (has obj :container)
+(defmethod unlock-open ((obj predoor) (key item))
+ (unless (and (or (has obj :container) (has obj :door))
(has obj :openable))
(return-from unlock-open (call-next-method)))
(and (run-action 'unlock *args*)