X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=verbs.lisp;h=dae175a5644a93a7833bd3569050444561a78563;hb=HEAD;hp=406e6e622cd97a8f54944323745ea3541fa5ff42;hpb=4b3d4fbf3031334896e98a3da1dbc8820abb0c17;p=lifp.git

diff --git a/verbs.lisp b/verbs.lisp
index 406e6e6..dae175a 100644
--- a/verbs.lisp
+++ b/verbs.lisp
@@ -13,11 +13,13 @@
 (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)
-  (:shadow :listen)
+           :rub :turn :switch-on :switch-off
+           :fill :empty :extract :let-go :open :close
+           :lock :unlock :unlock-open)
+  (:shadow :listen :fill :open :close)
   (:shadowing-import-from :if-lib :room))
 
 (in-package :verb-lib)
@@ -45,7 +47,7 @@
    
 (const-fun const-loc (c) *location*)
 
-(verb "look"
+(verb "look" "l"
       `(-> look const-loc)
       '("at" :seen -> examine))
 
@@ -102,11 +104,15 @@
 (verb "take"
       '(:noun -> take)
       '("off" :held -> strip)
-      '(:held "off" -> strip))
+      '(:held "off" -> strip)
+      '(:noun "from" :noun -> extract)
+      '(:noun "from" :noun -> extract))
 
 (verb "get"
       '(:noun -> take)
-      '((:or "in" "into" "on" "onto") :noun -> enter rest))
+      '((:or "out" "off" "up") -> go-to cdir-out)
+      '((:or "in" "into" "on" "onto") :noun -> enter rest)
+      '(:noun "from" :noun -> extract))
 
 (verb "drop" "discard" "throw"
       '(:held -> drop)
@@ -125,7 +131,8 @@
 
 (verb "remove"
       '(:held -> strip)
-      '(:noun -> take))
+      '(:noun -> take)
+      '(:noun "from" :noun -> extract))
 
 (verb "shed" "disrobe" "doff"
       '(:held -> strip))
@@ -164,7 +171,25 @@
       '("on" :noun -> switch-on)
       '("off" :noun -> switch-off))
 
-
+(verb "fill" '(:noun -> fill))
+      
+(verb "empty" '(:noun -> empty))
+
+(verb "open" 
+      '(:noun -> open)
+      '(:noun "with" :held -> unlock-open))
+
+(verb "close" '(:noun -> close))
+(verb "shut" 
+      '(:noun -> close)
+      '("off" :noun -> switch-off)
+      '(:noun "off" -> switch-off))
+
+(verb "lock"
+      '(:noun "with" :held -> lock))
+(verb "unlock"
+      '(:noun "with" :held -> unlock))
+      
 
 (defaction attack (obj) "Violence is not the answer.")
 
@@ -180,23 +205,29 @@
 
 (defaction go-to (dir)
   (let ((destination (read-property *location* (property dir))))
-    (if destination (go-to-room destination)
+    (if destination (exec go-to-dispatch (destination) :str t)
 	(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))
+  ;(format t "go-to-dispatch: ~a~%" dest)
+  (unless (has dest :door) (return-from go-to-dispatch (call-next-method)))
+  (if (has dest :closed) (format nil "~a is closed." (the-name dest :capital t))
+      (run-action 'pass (list dest))))
+
+(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*))
@@ -209,9 +240,17 @@
   (if (has obj :item)
       (if (in obj *player*) 
 	  (progn (sprint "You already have ~A" (the-name obj)) t) 
-	  (progn 
-	    (move obj *player*)
-	    (when (run-action-after obj) "Taken.")))
+	  (if (below obj (parent *player*))
+              (let ((loc (parent *player*)))
+                (and
+                 (loop for x = (parent obj)
+                    until (eql x loc)
+                    always (run-action 'extract-silent (list obj x))
+                    finally (return t))
+                 (move obj *player*)
+                 (run-action-after obj)
+                 "Taken."))
+              (sprint "You cannot take ~a from here." (the-name obj))))
       (call-next-method)))
 
 (defaction drop (obj)
@@ -230,6 +269,10 @@
   ;;(format t "(~a ~a)" (print-name item) (print-name host)) 
   (unless (has item :item) (return-from put-on "You can't get rid of that."))
   (unless (has host :supporter) (return-from put-on (call-next-method)))
+  (when (has item :worn)
+    (sprint "(first removing ~a)~%" (the-name item))
+    (unless (run-action 'strip item)
+      (return-from put-on "You can't drop it.")))
   (and (run-action 'receive (reverse *args*) :time 0)
        *after*
        (run-action-after item) 
@@ -244,6 +287,10 @@
   (when (has host :closed) 
     (return-from put-in 
       (format nil "~a is closed." (the-name host :capital t))))
+  (when (has item :worn)
+    (sprint "(first removing ~a)~%" (the-name item))
+    (unless (run-action 'strip item)
+      (return-from put-in "You can't drop it.")))
   (and (run-action 'receive (reverse *args*) :time 0)
        *after*
        (run-action-after item) 
@@ -288,6 +335,9 @@
 (defaction enter (what)
   "You can't enter that.")
 
+(defmethod enter ((door door))
+  (go-to-dispatch door))
+
 (defaction climb (what)
   "You can't climb that.")
 
@@ -312,7 +362,7 @@
   "This action achieves nothing.")
 
 (defaction turn (what)
-  "That's fixed in place")
+  "That's fixed in place.")
 
 (defmethod turn ((item item))
   (if (has item :item)
@@ -329,7 +379,7 @@
   (if (has obj :switchable)
       (progn
         (if (has obj :on)
-            (format nil "~a is already on." (the-name obj))
+            (format nil "~a is already on." (the-name obj :capital t))
             (progn (give obj :on)
                    (when (run-action-after obj) "Done."))))
       (call-next-method)))
@@ -338,8 +388,134 @@
   (if (has obj :switchable)
       (progn
         (if (hasnt obj :on)
-            (format nil "~a is already off." (the-name obj))
+            (format nil "~a is already off." (the-name obj :capital t))
             (progn (give obj :~on)
                    (when (run-action-after obj) "Done."))))
       (call-next-method)))        
                      
+(defaction fill (what) "You can't fill that.")
+
+(defaction empty (what) "That doesn't make sense.")
+
+(defmethod empty ((obj container))
+  (unless (has obj :container) (return-from empty (call-next-method)))
+  (if (has obj :closed)
+      "But it is closed!"
+      (if (children obj)
+          (objectloop (in x obj)
+                      (sprint "~a: " (print-name x))
+                      (run-action 'extract (list x obj)))
+          "It is already empty.")))
+
+(defaction extract (obj1 obj2 &key silent) "You can't do that.")
+
+(defmethod extract ((item item) (host container) &key silent)
+  (unless (has item :item) (return-from extract (call-next-method)))
+  (unless (has host :container) (return-from extract (call-next-method)))
+  (when (has host :closed) 
+    (return-from extract 
+      (format nil "~a is closed." (the-name host :capital t))))
+  (and (run-action 'let-go (reverse *args*))
+       *after*
+       (run-action-after item) 
+       (if silent t "Done.")))  
+
+(defmethod extract ((item item) (host supporter) &key silent)
+  (unless (has item :item) (return-from extract (call-next-method)))
+  (unless (has host :supporter) (return-from extract (call-next-method)))
+  (and (run-action 'let-go (reverse *args*))
+       *after*
+       (run-action-after item)
+       (if silent t "Done.")))
+
+(defaction extract-silent (obj1 obj2)
+  (extract obj1 obj2 :silent t))
+
+(defaction let-go (host thing)
+  "Something's wrong happened.")
+
+(defmethod let-go ((host supporter) (item item))
+  (move item (parent host))
+  (run-action-after host))
+
+(defmethod let-go ((host container) (item item))
+  (move item (parent host))
+  (run-action-after host))
+
+(defaction open (obj)
+  "You cannot open this.")
+
+(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)
+          (progn 
+            (give obj :~closed)
+            (when (run-action-after obj)
+              (format nil "You open ~a." (the-name obj))))
+          "It's locked.")
+      (format nil "~a is already open." (the-name obj :capital t))))
+
+(defaction close (obj)
+  "You cannot close this.")
+
+(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 
+        (give obj :closed)
+        (when (run-action-after obj)
+          (format nil "You close ~a." (the-name obj))))
+      (format nil "~a is already closed." (the-name obj :capital t))))
+
+(defaction lock (obj key)
+  "Not lockable.")
+
+(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)))
+  (if (has obj :locked) 
+      (format nil "~a is already locked." (the-name obj :capital t))
+      (if (hasnt obj :closed)
+          (format nil "~a is not closed." (the-name obj :capital t))
+          (if (with-keys obj key)
+              (progn
+                (give obj :locked)
+                (when (run-action-after obj)
+                  (format nil "You lock ~a." (the-name obj))))
+              (format nil "You cannot lock ~a with ~a."
+                      (the-name obj) (the-name key))))))
+
+(defaction unlock (obj key)
+  "There is nothing to unlock.")
+
+(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)))
+  (if (hasnt obj :locked) 
+      (format nil "~a is already unlocked." (the-name obj :capital t))
+      (if (hasnt obj :closed)
+          (format nil "~a is not closed." (the-name obj :capital t))
+          (if (with-keys obj key)
+              (progn
+                (give obj :~locked)
+                (when (run-action-after obj)
+                  (format nil "You unlock ~a." (the-name obj))))
+              (format nil "You cannot unlock ~a with ~a."
+                      (the-name obj) (the-name key))))))
+
+(defaction unlock-open (obj key)
+  "You cannot open this.")
+
+(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*)
+       (run-action 'open obj)))