upd advent.lisp so it works

[lifp.git] / verbs.lisp

diff --git a/verbs.lisp b/verbs.lisp
index 406e6e622cd97a8f54944323745ea3541fa5ff42..dae175a5644a93a7833bd3569050444561a78563 100644 (file)
--- a/verbs.lisp
+++ b/verbs.lisp
@@ -13,11 +13,13 @@
 (defpackage :verb-lib\r
   (:use :common-lisp :if-lib :if-basic-lib)\r
   (:export :attack :take :teleport :examine \r
 (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
           :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 :open :close\r
+           :lock :unlock :unlock-open)\r
+  (:shadow :listen :fill :open :close)\r

   (:shadowing-import-from :if-lib :room))\r
 \r
 (in-package :verb-lib)\r
   (:shadowing-import-from :if-lib :room))\r
 \r
 (in-package :verb-lib)\r


@@ -45,7 +47,7 @@
    \r
 (const-fun const-loc (c) *location*)\r
 \r
    \r
 (const-fun const-loc (c) *location*)\r
 \r

-(verb "look"\r
+(verb "look" "l"\r

       `(-> look const-loc)\r
       '("at" :seen -> examine))\r
 \r
       `(-> look const-loc)\r
       '("at" :seen -> examine))\r
 \r


@@ -102,11 +104,15 @@
 (verb "take"\r
       '(:noun -> take)\r
       '("off" :held -> strip)\r
 (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
 \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
 \r
 (verb "drop" "discard" "throw"\r
       '(:held -> drop)\r


@@ -125,7 +131,8 @@
 \r
 (verb "remove"\r
       '(:held -> strip)\r
 \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
 \r
 (verb "shed" "disrobe" "doff"\r
       '(:held -> strip))\r


@@ -164,7 +171,25 @@
       '("on" :noun -> switch-on)\r
       '("off" :noun -> switch-off))\r
 \r
       '("on" :noun -> switch-on)\r
       '("off" :noun -> switch-off))\r
 \r

-\r
+(verb "fill" '(:noun -> fill))\r
+      \r
+(verb "empty" '(:noun -> empty))\r
+\r
+(verb "open" \r
+      '(:noun -> open)\r
+      '(:noun "with" :held -> unlock-open))\r
+\r
+(verb "close" '(:noun -> close))\r
+(verb "shut" \r
+      '(:noun -> close)\r
+      '("off" :noun -> switch-off)\r
+      '(:noun "off" -> switch-off))\r
+\r
+(verb "lock"\r
+      '(:noun "with" :held -> lock))\r
+(verb "unlock"\r
+      '(:noun "with" :held -> unlock))\r
+      \r

 \r
 (defaction attack (obj) "Violence is not the answer.")\r
 \r
 \r
 (defaction attack (obj) "Violence is not the answer.")\r
 \r


@@ -180,23 +205,29 @@
 \r
 (defaction go-to (dir)\r
   (let ((destination (read-property *location* (property dir))))\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
        (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
 \r
 (defun inventory ()\r
   (sprint "You are carrying: ~a." (list-contents *player*))\r


@@ -209,9 +240,17 @@
   (if (has obj :item)\r
       (if (in obj *player*) \r
          (progn (sprint "You already have ~A" (the-name obj)) t) \r
   (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
       (call-next-method)))\r
 \r
 (defaction drop (obj)\r


@@ -230,6 +269,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
   ;;(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
   (and (run-action 'receive (reverse *args*) :time 0)\r
        *after*\r
        (run-action-after item) \r


@@ -244,6 +287,10 @@
   (when (has host :closed) \r
     (return-from put-in \r
       (format nil "~a is closed." (the-name host :capital t))))\r
   (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
   (and (run-action 'receive (reverse *args*) :time 0)\r
        *after*\r
        (run-action-after item) \r


@@ -288,6 +335,9 @@
 (defaction enter (what)\r
   "You can't enter that.")\r
 \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
 (defaction climb (what)\r
   "You can't climb that.")\r
 \r


@@ -312,7 +362,7 @@
   "This action achieves nothing.")\r
 \r
 (defaction turn (what)\r
   "This action achieves nothing.")\r
 \r
 (defaction turn (what)\r

-  "That's fixed in place")\r
+  "That's fixed in place.")\r

 \r
 (defmethod turn ((item item))\r
   (if (has item :item)\r
 \r
 (defmethod turn ((item item))\r
   (if (has item :item)\r


@@ -329,7 +379,7 @@
   (if (has obj :switchable)\r
       (progn\r
         (if (has obj :on)\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
             (progn (give obj :on)\r
                    (when (run-action-after obj) "Done."))))\r
       (call-next-method)))\r


@@ -338,8 +388,134 @@
   (if (has obj :switchable)\r
       (progn\r
         (if (hasnt obj :on)\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
                      \r
             (progn (give obj :~on)\r
                    (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
+\r
+(defaction open (obj)\r
+  "You cannot open this.")\r
+\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
+            (give obj :~closed)\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 :capital t))))\r
+\r
+(defaction close (obj)\r
+  "You cannot close this.")\r
+\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 :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