From: grue <grue@mail.ru>
Date: Mon, 13 Feb 2006 20:52:17 +0000 (+0000)
Subject: new actions
X-Git-Url: https://jxself.org/git/?p=lifp.git;a=commitdiff_plain;h=d6621d9c4fedfc95669395bc7c40e43c70e62069

new actions

darcs-hash:afe75ac3fbe27ca370896cf5dd50f8440e589e7b
---

diff --git a/iflib.lisp b/iflib.lisp
index e9145fb..1a1059d 100644
--- a/iflib.lisp
+++ b/iflib.lisp
@@ -674,7 +674,7 @@
   `(defpackage ,name
     (:use :common-lisp :if-basic-lib :if-lib :verb-lib ,@other-packages)
     (:shadowing-import-from :if-lib :room)
-    (:shadowing-import-from :verb-lib :listen)))
+    (:shadowing-import-from :verb-lib :listen :fill)))
 
 (defmacro free-symbol (id)
   "Frees a symbol from current package using shadow"
diff --git a/verbs.lisp b/verbs.lisp
index 74979be..0adf53c 100644
--- a/verbs.lisp
+++ b/verbs.lisp
@@ -16,8 +16,9 @@
 	   :go-to 
 	   :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)
+  (:shadow :listen :fill)
   (:shadowing-import-from :if-lib :room))
 
 (in-package :verb-lib)
@@ -102,11 +103,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 +130,8 @@
 
 (verb "remove"
       '(:held -> strip)
-      '(:noun -> take))
+      '(:noun -> take)
+      '(:noun "from" :noun -> extract))
 
 (verb "shed" "disrobe" "doff"
       '(:held -> strip))
@@ -164,6 +170,10 @@
       '("on" :noun -> switch-on)
       '("off" :noun -> switch-off))
 
+(verb "fill" '(:noun -> fill))
+      
+(verb "empty" '(:noun -> empty))
+
 
 
 (defaction attack (obj) "Violence is not the answer.")
@@ -209,9 +219,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 +248,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 +266,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) 
@@ -343,3 +369,51 @@
                    (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))