new actions

darcs-hash:afe75ac3fbe27ca370896cf5dd50f8440e589e7b

diff --git a/iflib.lisp b/iflib.lisp
index e9145fb1f725180bb27cc9573bfbfa2b94f81aa0..1a1059d427b4ecf4b0ecea96e5de3da7251f9e6d 100644 (file)
--- a/iflib.lisp
+++ b/iflib.lisp
@@ -674,7 +674,7 @@
   `(defpackage ,name\r
     (:use :common-lisp :if-basic-lib :if-lib :verb-lib ,@other-packages)\r
     (:shadowing-import-from :if-lib :room)\r
-    (:shadowing-import-from :verb-lib :listen)))\r
+    (:shadowing-import-from :verb-lib :listen :fill)))\r
 \r
 (defmacro free-symbol (id)\r
   "Frees a symbol from current package using shadow"\r

diff --git a/verbs.lisp b/verbs.lisp
index 74979be0a564674a7003f12697854f29cab2bcaf..0adf53ce8cbdbf161bf1afa261b94a0fbaf08e13 100644 (file)
--- a/verbs.lisp
+++ b/verbs.lisp
@@ -16,8 +16,9 @@
           :go-to \r
           :take :put-in :put-on :drop :receive\r
           :wear :strip :enter :climb :drink :eat\r
-           :rub :turn :switch-on :switch-off)\r
-  (:shadow :listen)\r
+           :rub :turn :switch-on :switch-off\r
+           :fill :empty :extract :let-go)\r
+  (:shadow :listen :fill)\r
   (:shadowing-import-from :if-lib :room))\r
 \r
 (in-package :verb-lib)\r
@@ -102,11 +103,15 @@
 (verb "take"\r
       '(:noun -> take)\r
       '("off" :held -> strip)\r
-      '(:held "off" -> strip))\r
+      '(:held "off" -> strip)\r
+      '(:noun "from" :noun -> extract)\r
+      '(:noun "from" :noun -> extract))\r
 \r
 (verb "get"\r
       '(:noun -> take)\r
-      '((:or "in" "into" "on" "onto") :noun -> enter rest))\r
+      '((:or "out" "off" "up") -> go-to cdir-out)\r
+      '((:or "in" "into" "on" "onto") :noun -> enter rest)\r
+      '(:noun "from" :noun -> extract))\r
 \r
 (verb "drop" "discard" "throw"\r
       '(:held -> drop)\r
@@ -125,7 +130,8 @@
 \r
 (verb "remove"\r
       '(:held -> strip)\r
-      '(:noun -> take))\r
+      '(:noun -> take)\r
+      '(:noun "from" :noun -> extract))\r
 \r
 (verb "shed" "disrobe" "doff"\r
       '(:held -> strip))\r
@@ -164,6 +170,10 @@
       '("on" :noun -> switch-on)\r
       '("off" :noun -> switch-off))\r
 \r
+(verb "fill" '(:noun -> fill))\r
+      \r
+(verb "empty" '(:noun -> empty))\r
+\r
 \r
 \r
 (defaction attack (obj) "Violence is not the answer.")\r
@@ -209,9 +219,17 @@
   (if (has obj :item)\r
       (if (in obj *player*) \r
          (progn (sprint "You already have ~A" (the-name obj)) t) \r
-         (progn \r
-           (move obj *player*)\r
-           (when (run-action-after obj) "Taken.")))\r
+         (if (below obj (parent *player*))\r
+              (let ((loc (parent *player*)))\r
+                (and\r
+                 (loop for x = (parent obj)\r
+                    until (eql x loc)\r
+                    always (run-action 'extract-silent (list obj x))\r
+                    finally (return t))\r
+                 (move obj *player*)\r
+                 (run-action-after obj)\r
+                 "Taken."))\r
+              (sprint "You cannot take ~a from here." (the-name obj))))\r
       (call-next-method)))\r
 \r
 (defaction drop (obj)\r
@@ -230,6 +248,10 @@
   ;;(format t "(~a ~a)" (print-name item) (print-name host)) \r
   (unless (has item :item) (return-from put-on "You can't get rid of that."))\r
   (unless (has host :supporter) (return-from put-on (call-next-method)))\r
+  (when (has item :worn)\r
+    (sprint "(first removing ~a)~%" (the-name item))\r
+    (unless (run-action 'strip item)\r
+      (return-from put-on "You can't drop it.")))\r
   (and (run-action 'receive (reverse *args*) :time 0)\r
        *after*\r
        (run-action-after item) \r
@@ -244,6 +266,10 @@
   (when (has host :closed) \r
     (return-from put-in \r
       (format nil "~a is closed." (the-name host :capital t))))\r
+  (when (has item :worn)\r
+    (sprint "(first removing ~a)~%" (the-name item))\r
+    (unless (run-action 'strip item)\r
+      (return-from put-in "You can't drop it.")))\r
   (and (run-action 'receive (reverse *args*) :time 0)\r
        *after*\r
        (run-action-after item) \r
@@ -343,3 +369,51 @@
                    (when (run-action-after obj) "Done."))))\r
       (call-next-method)))        \r
                      \r
+(defaction fill (what) "You can't fill that.")\r
+\r
+(defaction empty (what) "That doesn't make sense.")\r
+\r
+(defmethod empty ((obj container))\r
+  (unless (has obj :container) (return-from empty (call-next-method)))\r
+  (if (has obj :closed)\r
+      "But it is closed!"\r
+      (if (children obj)\r
+          (objectloop (in x obj)\r
+                      (sprint "~a: " (print-name x))\r
+                      (run-action 'extract (list x obj)))\r
+          "It is already empty.")))\r
+\r
+(defaction extract (obj1 obj2 &key silent) "You can't do that.")\r
+\r
+(defmethod extract ((item item) (host container) &key silent)\r
+  (unless (has item :item) (return-from extract (call-next-method)))\r
+  (unless (has host :container) (return-from extract (call-next-method)))\r
+  (when (has host :closed) \r
+    (return-from extract \r
+      (format nil "~a is closed." (the-name host :capital t))))\r
+  (and (run-action 'let-go (reverse *args*))\r
+       *after*\r
+       (run-action-after item) \r
+       (if silent t "Done.")))  \r
+\r
+(defmethod extract ((item item) (host supporter) &key silent)\r
+  (unless (has item :item) (return-from extract (call-next-method)))\r
+  (unless (has host :supporter) (return-from extract (call-next-method)))\r
+  (and (run-action 'let-go (reverse *args*))\r
+       *after*\r
+       (run-action-after item)\r
+       (if silent t "Done.")))\r
+\r
+(defaction extract-silent (obj1 obj2)\r
+  (extract obj1 obj2 :silent t))\r
+\r
+(defaction let-go (host thing)\r
+  "Something's wrong happened.")\r
+\r
+(defmethod let-go ((host supporter) (item item))\r
+  (move item (parent host))\r
+  (run-action-after host))\r
+\r
+(defmethod let-go ((host container) (item item))\r
+  (move item (parent host))\r
+  (run-action-after host))\r