verbs.lisp

   1 ;;Common Lisp Interactive Fiction Library \r
   2 ;;\r
   3 ;;verb-lib module: defines verbs and their associated actions\r
   4 ;;\r
   5 ;;This file is a part of Lisp Interactive Fiction Project\r
   6 ;;\r
   7 ;;See license.txt for licensing information\r
   8 \r
   9 \r
  10 \r
  11 (in-package :cl-user)\r
  12 \r
  13 (defpackage :verb-lib\r
  14   (:use :common-lisp :if-lib :if-basic-lib)\r
  15   (:export :attack :take :teleport :examine \r
  16            :go-to \r
  17            :take :put-in :put-on :drop :receive\r
  18            :wear :strip :enter :climb)\r
  19   (:shadow :listen)\r
  20   (:shadowing-import-from :if-lib :room))\r
  21 \r
  22 (in-package :verb-lib)\r
  23 \r
  24 (defmacro const-fun (name args value)\r
  25   `(defun ,name ,args\r
  26     (declare (ignore ,@args))\r
  27     ,value))\r
  28 \r
  29 (const-fun noargs-1 (c) nil)\r
  30 \r
  31 (verb "quit" '(:meta -> quit-game noargs-1)) ;;That one you'll use often ;)\r
  32 \r
  33 ;Debug verb\r
  34 (verb "teleport"\r
  35       `((:noun ,(lambda () *allobjects*)) -> teleport))\r
  36 \r
  37 (verb "take"\r
  38       '(:noun -> take)\r
  39       '("off" :held -> strip)\r
  40       '(:held "off" -> strip)) \r
  41 \r
  42 (verb "get"\r
  43       '(:noun -> take))\r
  44    \r
  45 (const-fun const-loc (c) *location*)\r
  46 \r
  47 (verb "look"\r
  48       `(-> look const-loc)\r
  49       '("at" :seen -> examine))\r
  50 \r
  51 (verb "examine" "x"\r
  52       '(:noun -> examine))\r
  53 \r
  54 (verb "attack" "break" "crack" "destroy"\r
  55      "fight" "hit" "kill" "murder" "punch"\r
  56      "smash" "thump" "torture" "wreck"\r
  57     '(:noun -> attack))\r
  58 \r
  59 ;(defmacro const-fun* (name args value)\r
  60 ;  `(defun ,name ,args\r
  61 ;    (declare (ignore ,@args))\r
  62 ;    (list *location* ,value)))\r
  63 \r
  64 (const-fun cdir-n (c) dir-n)\r
  65 (const-fun cdir-ne (c) dir-ne)\r
  66 (const-fun cdir-e (c) dir-e)\r
  67 (const-fun cdir-se (c) dir-se)\r
  68 (const-fun cdir-s (c) dir-s)\r
  69 (const-fun cdir-sw (c) dir-sw)\r
  70 (const-fun cdir-w (c) dir-w)\r
  71 (const-fun cdir-nw (c) dir-nw)\r
  72 (const-fun cdir-u (c) dir-u)\r
  73 (const-fun cdir-d (c) dir-d)\r
  74 (const-fun cdir-in (c) dir-in)\r
  75 (const-fun cdir-out (c) dir-out)\r
  76 \r
  77 (verb "go" "run" "walk" \r
  78       '(:direction -> go-to)\r
  79       '(:noun -> enter)\r
  80       '((:or "into" "in" "inside" "through") :noun -> enter rest))\r
  81 \r
  82 (verb "n" "north" '(-> go-to cdir-n))\r
  83 (verb "ne" "northeast" '(-> go-to cdir-ne))\r
  84 (verb "e" "east" '(-> go-to cdir-e))\r
  85 (verb "se" "southeast" '(-> go-to cdir-se))\r
  86 (verb "s" "south" '(-> go-to cdir-s))\r
  87 (verb "sw" "southwest" '(-> go-to cdir-sw))\r
  88 (verb "w" "west" '(-> go-to cdir-w))\r
  89 (verb "nw" "northwest" '(-> go-to cdir-nw))\r
  90 (verb "u" "up" '(-> go-to cdir-u))\r
  91 (verb "d" "down" '(-> go-to cdir-d))\r
  92 (verb "in" '(-> go-to cdir-in))\r
  93 (verb "out" '(-> go-to cdir-out))\r
  94 \r
  95 (verb "enter" \r
  96       '(:direction -> go-to)\r
  97       '(:noun -> enter))\r
  98 \r
  99 (verb "inventory" "i" '(-> inventory))\r
 100 \r
 101 (verb "take"\r
 102       '(:noun -> take)\r
 103       '("off" :held -> strip)\r
 104       '(:held "off" -> strip))\r
 105 \r
 106 (verb "get"\r
 107       '(:noun -> take)\r
 108       '((:or "in" "into" "on" "onto") :noun -> enter rest))\r
 109 \r
 110 (verb "drop" "discard" "throw"\r
 111       '(:held -> drop)\r
 112       '(:held "in" :noun -> put-in)\r
 113       '(:held "on" :noun -> put-on))\r
 114       \r
 115 (verb "put"\r
 116       '(:held "on" :noun -> put-on)\r
 117       '(:held "in" :noun -> put-in)\r
 118       '(:held "down" -> drop)\r
 119       '("on" :held -> wear)\r
 120       '(:held -> drop))\r
 121 \r
 122 (verb "wear" "don"\r
 123       '(:held -> wear))\r
 124 \r
 125 (verb "remove"\r
 126       '(:held -> strip)\r
 127       '(:noun -> take))\r
 128 \r
 129 (verb "shed" "disrobe" "doff"\r
 130       '(:held -> strip))\r
 131 \r
 132 (verb "sit" "lie"\r
 133       '("on" "top" "of" :noun -> enter)\r
 134       '((:or "on" "in" "inside") :noun -> enter rest))\r
 135 \r
 136 (verb "climb" "scale"\r
 137       '(:noun -> climb)\r
 138       '((:or "up" "over") :noun -> climb))\r
 139 \r
 140 (verb "listen" "hear"\r
 141       '(-> listen const-loc)\r
 142       '(:noun -> listen)\r
 143       '("to" :noun -> listen))\r
 144 \r
 145 (defaction attack (obj) "Violence is not the answer.")\r
 146 \r
 147 (defaction teleport (obj) \r
 148   (go-to-room obj))\r
 149 \r
 150 (defaction examine (obj)\r
 151   (if (provides obj 'description)\r
 152       (read-property obj 'description)\r
 153       (format nil "You see nothing special about ~A.~%" (the-name obj))))  \r
 154 \r
 155 ;;(defun look-around () (run-action 'look *location*))\r
 156 \r
 157 (defaction go-to (dir)\r
 158   (let ((destination (read-property *location* (property dir))))\r
 159     (if destination (go-to-room destination)\r
 160         (if (provides *location* 'cant-go) \r
 161             (read-property *location* 'cant-go)\r
 162             "You can't go here."))))\r
 163 \r
 164 ;; (defaction go-n () (run-action 'go-to dir-n))\r
 165 ;; (defaction go-ne () (run-action 'go-to dir-ne))\r
 166 ;; (defaction go-e () (run-action 'go-to dir-e))\r
 167 ;; (defaction go-se () (run-action 'go-to dir-se))\r
 168 ;; (defaction go-s () (run-action 'go-to dir-s))\r
 169 ;; (defaction go-sw () (run-action 'go-to dir-sw))\r
 170 ;; (defaction go-w () (run-action 'go-to dir-w))\r
 171 ;; (defaction go-nw () (run-action 'go-to dir-nw))\r
 172 ;; (defaction go-u () (run-action 'go-to dir-u))\r
 173 ;; (defaction go-d () (run-action 'go-to dir-d))\r
 174 ;; (defaction go-in () (run-action 'go-to dir-in))\r
 175 ;; (defaction go-out () (run-action 'go-to dir-out))\r
 176 \r
 177 (defun inventory ()\r
 178   (sprint "You are carrying: ~a." (list-contents *player*))\r
 179   (newline))\r
 180 \r
 181 (defaction take (obj)\r
 182   "You can't take that.")\r
 183 \r
 184 (defmethod take((obj item))\r
 185   (if (has obj :item)\r
 186       (if (in obj *player*) \r
 187           (progn (sprint "You already have ~A" (the-name obj)) t) \r
 188           (progn \r
 189             (move obj *player*)\r
 190             (when (run-action-after obj) "Taken.")))\r
 191       (call-next-method)))\r
 192 \r
 193 (defaction drop (obj)\r
 194   (unless (has obj :item) (return-from drop "You can't drop that."))\r
 195   (when (has obj :worn)\r
 196     (sprint "(first removing ~a)~%" (the-name obj))\r
 197     (unless (run-action 'strip obj)\r
 198       (return-from drop "You can't drop it.")))  \r
 199   (move obj (parent *player*))\r
 200   (when (run-action-after obj) "Dropped."))\r
 201 \r
 202 (defaction put-on (item host)\r
 203   "You can't put anything on that.")\r
 204 \r
 205 (defmethod put-on ((item item) (host supporter))\r
 206   ;;(format t "(~a ~a)" (print-name item) (print-name host)) \r
 207   (unless (has item :item) (return-from put-on "You can't get rid of that."))\r
 208   (unless (has host :supporter) (return-from put-on (call-next-method)))\r
 209   (and (run-action 'receive (reverse *args*) :time 0)\r
 210        *after*\r
 211        (run-action-after item) \r
 212        "Done."))\r
 213 \r
 214 (defaction put-in (item host)\r
 215   "You can't put anything in that.")\r
 216 \r
 217 (defmethod put-in ((item item) (host container))\r
 218   (unless (has item :item) (return-from put-in "You can't get rid of that."))\r
 219   (unless (has host :container) (return-from put-in (call-next-method)))\r
 220   (when (has host :closed) \r
 221     (return-from put-in \r
 222       (format nil "~a is closed." (the-name host :capital t))))\r
 223   (and (run-action 'receive (reverse *args*) :time 0)\r
 224        *after*\r
 225        (run-action-after item) \r
 226        "Done."))\r
 227     \r
 228 (defaction receive (host guest)\r
 229   "No method defined for that kind of object movement.")\r
 230 \r
 231 (defmethod receive ((host supporter) (item item))\r
 232   (if (or (zerop (capacity host)) \r
 233           (< (list-length (children host)) (capacity host)))\r
 234     (progn (move item host)\r
 235            (run-action-after host))\r
 236     "Not enough space."))\r
 237 \r
 238 (defmethod receive ((host container) (item item))\r
 239   (if (or (zerop (capacity host)) \r
 240           (< (list-length (children host)) (capacity host)))\r
 241     (progn (move item host)\r
 242            (run-action-after host))\r
 243     "Not enough space."))\r
 244 \r
 245 (defaction wear (what)\r
 246   "You can't wear that.")\r
 247 \r
 248 (defmethod wear ((obj clothing))\r
 249   (if (has obj :clothing)\r
 250       (if (hasnt obj :worn) \r
 251           (progn \r
 252             (give obj :worn) (when (run-action-after obj) "Done."))\r
 253           "You are already wearing it.")\r
 254       "You can't wear that."))\r
 255 \r
 256 (defaction strip (what)\r
 257   "That's one strange thing you want to do.")\r
 258 \r
 259 (defmethod strip ((obj clothing))\r
 260   (if (and (has obj :clothing) (has obj :worn))\r
 261       (progn (give obj :~worn) (when (run-action-after obj) "Done."))\r
 262       "You can't do that."))\r
 263 \r
 264 (defaction enter (what)\r
 265   "You can't enter that.")\r
 266 \r
 267 (defaction climb (what)\r
 268   "You can't climb that.")\r
 269 \r
 270 (defaction listen (what)\r
 271   "You hear nothing unexpected.")