: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 :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
\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
(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
\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
'("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
(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
;;(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
(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
"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
(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 container))\r
+ (unless (and (has obj :container) (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))))\r
+\r
+(defaction close (obj)\r
+ "You cannot close this.")\r
+\r
+(defmethod close ((obj container))\r
+ (unless (and (has obj :container) (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
+\r
+(defaction lock (obj key)\r
+ "Not lockable.")\r
+\r
+(defmethod lock ((obj container) (key item))\r
+ (unless (and (has obj :container) \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))\r
+ (if (hasnt obj :closed)\r
+ (format nil "~a is not closed." (the-name obj))\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 container) (key item))\r
+ (unless (and (has obj :container) \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))\r
+ (if (hasnt obj :closed)\r
+ (format nil "~a is not closed." (the-name obj))\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 container) (key item))\r
+ (unless (and (has obj :container) \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