(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
- :fill :empty :extract :let-go :open :close)\r
+ :fill :empty :extract :let-go :open :close\r
+ :lock :unlock :unlock-open)\r
(:shadow :listen :fill :open :close)\r
(:shadowing-import-from :if-lib :room))\r
\r
\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) :str t)\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
+ ;(format t "go-to-dispatch: ~a~%" dest)\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 :capital t))\r
+ (run-action 'pass (list dest))))\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
(defaction enter (what)\r
"You can't enter that.")\r
\r
+(defmethod enter ((door door))\r
+ (go-to-dispatch door))\r
+\r
(defaction climb (what)\r
"You can't climb that.")\r
\r
(if (has obj :switchable)\r
(progn\r
(if (has obj :on)\r
- (format nil "~a is already on." (the-name obj))\r
+ (format nil "~a is already on." (the-name obj :capital t))\r
(progn (give obj :on)\r
(when (run-action-after obj) "Done."))))\r
(call-next-method)))\r
(if (has obj :switchable)\r
(progn\r
(if (hasnt obj :on)\r
- (format nil "~a is already off." (the-name obj))\r
+ (format nil "~a is already off." (the-name obj :capital t))\r
(progn (give obj :~on)\r
(when (run-action-after obj) "Done."))))\r
(call-next-method))) \r
(run-action-after host))\r
\r
(defaction open (obj)\r
- "You cannot open this")\r
+ "You cannot open this.")\r
\r
-(defmethod open ((obj container))\r
- (unless (has obj :container) (return-from open (call-next-method)))\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
(progn \r
(when (run-action-after obj)\r
(format nil "You open ~a." (the-name obj))))\r
"It's locked.")\r
- (format nil "~a is already open." (the-name obj))))\r
+ (format nil "~a is already open." (the-name obj :capital t))))\r
+\r
+(defaction close (obj)\r
+ "You cannot close this.")\r
\r
-(defmethod close ((obj container))\r
- (unless (has obj :container) (return-from closed (call-next-method)))\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
(give obj :closed)\r
(when (run-action-after obj)\r
(format nil "You close ~a." (the-name obj))))\r
- (format nil "~a is already closed." (the-name obj))))\r
+ (format nil "~a is already closed." (the-name obj :capital t))))\r
+\r
+(defaction lock (obj key)\r
+ "Not lockable.")\r
+\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
+ (if (has obj :locked) \r
+ (format nil "~a is already locked." (the-name obj :capital t))\r
+ (if (hasnt obj :closed)\r
+ (format nil "~a is not closed." (the-name obj :capital t))\r
+ (if (with-keys obj key)\r
+ (progn\r
+ (give obj :locked)\r
+ (when (run-action-after obj)\r
+ (format nil "You lock ~a." (the-name obj))))\r
+ (format nil "You cannot lock ~a with ~a."\r
+ (the-name obj) (the-name key))))))\r
+\r
+(defaction unlock (obj key)\r
+ "There is nothing to unlock.")\r
+\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
+ (if (hasnt obj :locked) \r
+ (format nil "~a is already unlocked." (the-name obj :capital t))\r
+ (if (hasnt obj :closed)\r
+ (format nil "~a is not closed." (the-name obj :capital t))\r
+ (if (with-keys obj key)\r
+ (progn\r
+ (give obj :~locked)\r
+ (when (run-action-after obj)\r
+ (format nil "You unlock ~a." (the-name obj))))\r
+ (format nil "You cannot unlock ~a with ~a."\r
+ (the-name obj) (the-name key))))))\r
+\r
+(defaction unlock-open (obj key)\r
+ "You cannot open this.")\r
+\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
+ (run-action 'open obj)))\r
projects / lifp.git / blobdiff