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 :pass\r
  17            :take :put-in :put-on :drop :receive\r
  18            :wear :strip :enter :climb :drink :eat\r
  19            :rub :turn :switch-on :switch-off\r
  20            :fill :empty :extract :let-go :open :close\r
  21            :lock :unlock :unlock-open)\r
  22   (:shadow :listen :fill :open :close)\r
  23   (:shadowing-import-from :if-lib :room))\r
  24 \r
  25 (in-package :verb-lib)\r
  26 \r
  27 (defmacro const-fun (name args value)\r
  28   `(defun ,name ,args\r
  29     (declare (ignore ,@args))\r
  30     ,value))\r
  31 \r
  32 (const-fun noargs-1 (c) nil)\r
  33 \r
  34 (verb "quit" '(:meta -> quit-game noargs-1)) ;;That one you'll use often ;)\r
  35 \r
  36 ;Debug verb\r
  37 (verb "teleport"\r
  38       `((:noun ,(lambda () *allobjects*)) -> teleport))\r
  39 \r
  40 (verb "take"\r
  41       '(:noun -> take)\r
  42       '("off" :held -> strip)\r
  43       '(:held "off" -> strip)) \r
  44 \r
  45 (verb "get"\r
  46       '(:noun -> take))\r
  47    \r
  48 (const-fun const-loc (c) *location*)\r
  49 \r
  50 (verb "look" "l"\r
  51       `(-> look const-loc)\r
  52       '("at" :seen -> examine))\r
  53 \r
  54 (verb "examine" "x"\r
  55       '(:noun -> examine))\r
  56 \r
  57 (verb "attack" "break" "crack" "destroy"\r
  58      "fight" "hit" "kill" "murder" "punch"\r
  59      "smash" "thump" "torture" "wreck"\r
  60     '(:noun -> attack))\r
  61 \r
  62 ;(defmacro const-fun* (name args value)\r
  63 ;  `(defun ,name ,args\r
  64 ;    (declare (ignore ,@args))\r
  65 ;    (list *location* ,value)))\r
  66 \r
  67 (const-fun cdir-n (c) dir-n)\r
  68 (const-fun cdir-ne (c) dir-ne)\r
  69 (const-fun cdir-e (c) dir-e)\r
  70 (const-fun cdir-se (c) dir-se)\r
  71 (const-fun cdir-s (c) dir-s)\r
  72 (const-fun cdir-sw (c) dir-sw)\r
  73 (const-fun cdir-w (c) dir-w)\r
  74 (const-fun cdir-nw (c) dir-nw)\r
  75 (const-fun cdir-u (c) dir-u)\r
  76 (const-fun cdir-d (c) dir-d)\r
  77 (const-fun cdir-in (c) dir-in)\r
  78 (const-fun cdir-out (c) dir-out)\r
  79 \r
  80 (verb "go" "run" "walk" \r
  81       '(:direction -> go-to)\r
  82       '(:noun -> enter)\r
  83       '((:or "into" "in" "inside" "through") :noun -> enter rest))\r
  84 \r
  85 (verb "n" "north" '(-> go-to cdir-n))\r
  86 (verb "ne" "northeast" '(-> go-to cdir-ne))\r
  87 (verb "e" "east" '(-> go-to cdir-e))\r
  88 (verb "se" "southeast" '(-> go-to cdir-se))\r
  89 (verb "s" "south" '(-> go-to cdir-s))\r
  90 (verb "sw" "southwest" '(-> go-to cdir-sw))\r
  91 (verb "w" "west" '(-> go-to cdir-w))\r
  92 (verb "nw" "northwest" '(-> go-to cdir-nw))\r
  93 (verb "u" "up" '(-> go-to cdir-u))\r
  94 (verb "d" "down" '(-> go-to cdir-d))\r
  95 (verb "in" '(-> go-to cdir-in))\r
  96 (verb "out" '(-> go-to cdir-out))\r
  97 \r
  98 (verb "enter" \r
  99       '(:direction -> go-to)\r
 100       '(:noun -> enter))\r
 101 \r
 102 (verb "inventory" "i" '(-> inventory))\r
 103 \r
 104 (verb "take"\r
 105       '(:noun -> take)\r
 106       '("off" :held -> strip)\r
 107       '(:held "off" -> strip)\r
 108       '(:noun "from" :noun -> extract)\r
 109       '(:noun "from" :noun -> extract))\r
 110 \r
 111 (verb "get"\r
 112       '(:noun -> take)\r
 113       '((:or "out" "off" "up") -> go-to cdir-out)\r
 114       '((:or "in" "into" "on" "onto") :noun -> enter rest)\r
 115       '(:noun "from" :noun -> extract))\r
 116 \r
 117 (verb "drop" "discard" "throw"\r
 118       '(:held -> drop)\r
 119       '(:held "in" :noun -> put-in)\r
 120       '(:held "on" :noun -> put-on))\r
 121       \r
 122 (verb "put"\r
 123       '(:held "on" :noun -> put-on)\r
 124       '(:held "in" :noun -> put-in)\r
 125       '(:held "down" -> drop)\r
 126       '("on" :held -> wear)\r
 127       '(:held -> drop))\r
 128 \r
 129 (verb "wear" "don"\r
 130       '(:held -> wear))\r
 131 \r
 132 (verb "remove"\r
 133       '(:held -> strip)\r
 134       '(:noun -> take)\r
 135       '(:noun "from" :noun -> extract))\r
 136 \r
 137 (verb "shed" "disrobe" "doff"\r
 138       '(:held -> strip))\r
 139 \r
 140 (verb "sit" "lie"\r
 141       '("on" "top" "of" :noun -> enter)\r
 142       '((:or "on" "in" "inside") :noun -> enter rest))\r
 143 \r
 144 (verb "climb" "scale"\r
 145       '(:noun -> climb)\r
 146       '((:or "up" "over") :noun -> climb))\r
 147 \r
 148 (verb "listen" "hear"\r
 149       '(-> listen const-loc)\r
 150       '(:noun -> listen)\r
 151       '("to" :noun -> listen))\r
 152 \r
 153 (verb "drink" "sip" "swallow" '(:noun -> drink))\r
 154 \r
 155 (verb "eat" "consume" '(:held -> eat))\r
 156 \r
 157 (verb "rub" "clean" "dust" "polish" "scrub" "shine"\r
 158       "sweep" "wipe" '(:noun -> rub))\r
 159 \r
 160 (verb "switch"\r
 161       '(:noun -> switch-on)\r
 162       '(:noun "on" -> switch-on)\r
 163       '(:noun "off" -> switch-off)\r
 164       '("on" :noun -> switch-on)\r
 165       '("off" :noun -> switch-off))\r
 166 \r
 167 (verb "turn"\r
 168       '(:noun -> turn)\r
 169       '(:noun "on" -> switch-on)\r
 170       '(:noun "off" -> switch-off)\r
 171       '("on" :noun -> switch-on)\r
 172       '("off" :noun -> switch-off))\r
 173 \r
 174 (verb "fill" '(:noun -> fill))\r
 175       \r
 176 (verb "empty" '(:noun -> empty))\r
 177 \r
 178 (verb "open" \r
 179       '(:noun -> open)\r
 180       '(:noun "with" :held -> unlock-open))\r
 181 \r
 182 (verb "close" '(:noun -> close))\r
 183 (verb "shut" \r
 184       '(:noun -> close)\r
 185       '("off" :noun -> switch-off)\r
 186       '(:noun "off" -> switch-off))\r
 187 \r
 188 (verb "lock"\r
 189       '(:noun "with" :held -> lock))\r
 190 (verb "unlock"\r
 191       '(:noun "with" :held -> unlock))\r
 192       \r
 193 \r
 194 (defaction attack (obj) "Violence is not the answer.")\r
 195 \r
 196 (defaction teleport (obj) \r
 197   (go-to-room obj))\r
 198 \r
 199 (defaction examine (obj)\r
 200   (if (provides obj 'description)\r
 201       (read-property obj 'description)\r
 202       (format nil "You see nothing special about ~A.~%" (the-name obj))))  \r
 203 \r
 204 ;;(defun look-around () (run-action 'look *location*))\r
 205 \r
 206 (defaction go-to (dir)\r
 207   (let ((destination (read-property *location* (property dir))))\r
 208     (if destination (exec go-to-dispatch (destination) :str t)\r
 209         (if (provides *location* 'cant-go) \r
 210             (read-property *location* 'cant-go)\r
 211             "You can't go here."))))\r
 212 \r
 213 (defgeneric go-to-dispatch (dest)\r
 214   (:documentation "Dispatches between different kinds of goable objects"))\r
 215 \r
 216 (defmethod go-to-dispatch ((dest room))\r
 217   (go-to-room dest))\r
 218 \r
 219 (defmethod go-to-dispatch ((dest door))\r
 220   ;(format t "go-to-dispatch: ~a~%" dest)\r
 221   (unless (has dest :door) (return-from go-to-dispatch (call-next-method)))\r
 222   (if (has dest :closed) (format nil "~a is closed." (the-name dest :capital t))\r
 223       (run-action 'pass (list dest))))\r
 224 \r
 225 (defaction pass (obj)\r
 226   "Something's wrong happened.")\r
 227 \r
 228 (defmethod pass ((obj door))\r
 229   (go-to-dispatch (read-property obj 'destination))\r
 230   (run-action-after obj))\r
 231 \r
 232 (defun inventory ()\r
 233   (sprint "You are carrying: ~a." (list-contents *player*))\r
 234   (newline))\r
 235 \r
 236 (defaction take (obj)\r
 237   "You can't take that.")\r
 238 \r
 239 (defmethod take ((obj item))\r
 240   (if (has obj :item)\r
 241       (if (in obj *player*) \r
 242           (progn (sprint "You already have ~A" (the-name obj)) t) \r
 243           (if (below obj (parent *player*))\r
 244               (let ((loc (parent *player*)))\r
 245                 (and\r
 246                  (loop for x = (parent obj)\r
 247                     until (eql x loc)\r
 248                     always (run-action 'extract-silent (list obj x))\r
 249                     finally (return t))\r
 250                  (move obj *player*)\r
 251                  (run-action-after obj)\r
 252                  "Taken."))\r
 253               (sprint "You cannot take ~a from here." (the-name obj))))\r
 254       (call-next-method)))\r
 255 \r
 256 (defaction drop (obj)\r
 257   (unless (has obj :item) (return-from drop "You can't drop that."))\r
 258   (when (has obj :worn)\r
 259     (sprint "(first removing ~a)~%" (the-name obj))\r
 260     (unless (run-action 'strip obj)\r
 261       (return-from drop "You can't drop it.")))  \r
 262   (move obj (parent *player*))\r
 263   (when (run-action-after obj) "Dropped."))\r
 264 \r
 265 (defaction put-on (item host)\r
 266   "You can't put anything on that.")\r
 267 \r
 268 (defmethod put-on ((item item) (host supporter))\r
 269   ;;(format t "(~a ~a)" (print-name item) (print-name host)) \r
 270   (unless (has item :item) (return-from put-on "You can't get rid of that."))\r
 271   (unless (has host :supporter) (return-from put-on (call-next-method)))\r
 272   (when (has item :worn)\r
 273     (sprint "(first removing ~a)~%" (the-name item))\r
 274     (unless (run-action 'strip item)\r
 275       (return-from put-on "You can't drop it.")))\r
 276   (and (run-action 'receive (reverse *args*) :time 0)\r
 277        *after*\r
 278        (run-action-after item) \r
 279        "Done."))\r
 280 \r
 281 (defaction put-in (item host)\r
 282   "You can't put anything in that.")\r
 283 \r
 284 (defmethod put-in ((item item) (host container))\r
 285   (unless (has item :item) (return-from put-in "You can't get rid of that."))\r
 286   (unless (has host :container) (return-from put-in (call-next-method)))\r
 287   (when (has host :closed) \r
 288     (return-from put-in \r
 289       (format nil "~a is closed." (the-name host :capital t))))\r
 290   (when (has item :worn)\r
 291     (sprint "(first removing ~a)~%" (the-name item))\r
 292     (unless (run-action 'strip item)\r
 293       (return-from put-in "You can't drop it.")))\r
 294   (and (run-action 'receive (reverse *args*) :time 0)\r
 295        *after*\r
 296        (run-action-after item) \r
 297        "Done."))\r
 298     \r
 299 (defaction receive (host guest)\r
 300   "No method defined for that kind of object movement.")\r
 301 \r
 302 (defmethod receive ((host supporter) (item item))\r
 303   (if (or (zerop (capacity host)) \r
 304           (< (list-length (children host)) (capacity host)))\r
 305     (progn (move item host)\r
 306            (run-action-after host))\r
 307     "Not enough space."))\r
 308 \r
 309 (defmethod receive ((host container) (item item))\r
 310   (if (or (zerop (capacity host)) \r
 311           (< (list-length (children host)) (capacity host)))\r
 312     (progn (move item host)\r
 313            (run-action-after host))\r
 314     "Not enough space."))\r
 315 \r
 316 (defaction wear (what)\r
 317   "You can't wear that.")\r
 318 \r
 319 (defmethod wear ((obj clothing))\r
 320   (if (has obj :clothing)\r
 321       (if (hasnt obj :worn) \r
 322           (progn \r
 323             (give obj :worn) (when (run-action-after obj) "Done."))\r
 324           "You are already wearing it.")\r
 325       "You can't wear that."))\r
 326 \r
 327 (defaction strip (what)\r
 328   "That's one strange thing you want to do.")\r
 329 \r
 330 (defmethod strip ((obj clothing))\r
 331   (if (and (has obj :clothing) (has obj :worn))\r
 332       (progn (give obj :~worn) (when (run-action-after obj) "Done."))\r
 333       "You can't do that."))\r
 334 \r
 335 (defaction enter (what)\r
 336   "You can't enter that.")\r
 337 \r
 338 (defmethod enter ((door door))\r
 339   (go-to-dispatch door))\r
 340 \r
 341 (defaction climb (what)\r
 342   "You can't climb that.")\r
 343 \r
 344 (defaction listen (what)\r
 345   "You hear nothing unexpected.")\r
 346 \r
 347 (defaction drink (what)\r
 348   "You can't drink that.")\r
 349 \r
 350 (defaction eat (what)\r
 351   "You can't eat that.")\r
 352 \r
 353 (defmethod eat ((obj food))\r
 354   (if (has obj :edible)\r
 355       (progn \r
 356         (rmv obj)\r
 357         (when (run-action-after obj)\r
 358           (format nil "You eat ~a." (the-name obj))))\r
 359       (call-next-method)))\r
 360 \r
 361 (defaction rub (what)\r
 362   "This action achieves nothing.")\r
 363 \r
 364 (defaction turn (what)\r
 365   "That's fixed in place.")\r
 366 \r
 367 (defmethod turn ((item item))\r
 368   (if (has item :item)\r
 369       "This action achieves nothing."\r
 370       (call-next-method)))\r
 371 \r
 372 (defaction switch-on (what)\r
 373   "You can't switch this on")\r
 374 \r
 375 (defaction switch-off (what)\r
 376   "You can't switch this off")\r
 377 \r
 378 (defmethod switch-on ((obj switchable))\r
 379   (if (has obj :switchable)\r
 380       (progn\r
 381         (if (has obj :on)\r
 382             (format nil "~a is already on." (the-name obj :capital t))\r
 383             (progn (give obj :on)\r
 384                    (when (run-action-after obj) "Done."))))\r
 385       (call-next-method)))\r
 386 \r
 387 (defmethod switch-off ((obj switchable))\r
 388   (if (has obj :switchable)\r
 389       (progn\r
 390         (if (hasnt obj :on)\r
 391             (format nil "~a is already off." (the-name obj :capital t))\r
 392             (progn (give obj :~on)\r
 393                    (when (run-action-after obj) "Done."))))\r
 394       (call-next-method)))        \r
 395                      \r
 396 (defaction fill (what) "You can't fill that.")\r
 397 \r
 398 (defaction empty (what) "That doesn't make sense.")\r
 399 \r
 400 (defmethod empty ((obj container))\r
 401   (unless (has obj :container) (return-from empty (call-next-method)))\r
 402   (if (has obj :closed)\r
 403       "But it is closed!"\r
 404       (if (children obj)\r
 405           (objectloop (in x obj)\r
 406                       (sprint "~a: " (print-name x))\r
 407                       (run-action 'extract (list x obj)))\r
 408           "It is already empty.")))\r
 409 \r
 410 (defaction extract (obj1 obj2 &key silent) "You can't do that.")\r
 411 \r
 412 (defmethod extract ((item item) (host container) &key silent)\r
 413   (unless (has item :item) (return-from extract (call-next-method)))\r
 414   (unless (has host :container) (return-from extract (call-next-method)))\r
 415   (when (has host :closed) \r
 416     (return-from extract \r
 417       (format nil "~a is closed." (the-name host :capital t))))\r
 418   (and (run-action 'let-go (reverse *args*))\r
 419        *after*\r
 420        (run-action-after item) \r
 421        (if silent t "Done.")))  \r
 422 \r
 423 (defmethod extract ((item item) (host supporter) &key silent)\r
 424   (unless (has item :item) (return-from extract (call-next-method)))\r
 425   (unless (has host :supporter) (return-from extract (call-next-method)))\r
 426   (and (run-action 'let-go (reverse *args*))\r
 427        *after*\r
 428        (run-action-after item)\r
 429        (if silent t "Done.")))\r
 430 \r
 431 (defaction extract-silent (obj1 obj2)\r
 432   (extract obj1 obj2 :silent t))\r
 433 \r
 434 (defaction let-go (host thing)\r
 435   "Something's wrong happened.")\r
 436 \r
 437 (defmethod let-go ((host supporter) (item item))\r
 438   (move item (parent host))\r
 439   (run-action-after host))\r
 440 \r
 441 (defmethod let-go ((host container) (item item))\r
 442   (move item (parent host))\r
 443   (run-action-after host))\r
 444 \r
 445 (defaction open (obj)\r
 446   "You cannot open this.")\r
 447 \r
 448 (defmethod open ((obj predoor))\r
 449   (unless (and (or (has obj :container) (has obj :door)) (has obj :openable))\r
 450     (return-from open (call-next-method)))  \r
 451   (if (has obj :closed)\r
 452       (if (hasnt obj :locked)\r
 453           (progn \r
 454             (give obj :~closed)\r
 455             (when (run-action-after obj)\r
 456               (format nil "You open ~a." (the-name obj))))\r
 457           "It's locked.")\r
 458       (format nil "~a is already open." (the-name obj :capital t))))\r
 459 \r
 460 (defaction close (obj)\r
 461   "You cannot close this.")\r
 462 \r
 463 (defmethod close ((obj predoor))\r
 464   (unless (and (or (has obj :container) (has obj :door)) (has obj :openable))\r
 465     (return-from close (call-next-method)))\r
 466   (if (hasnt obj :closed)\r
 467       (progn \r
 468         (give obj :closed)\r
 469         (when (run-action-after obj)\r
 470           (format nil "You close ~a." (the-name obj))))\r
 471       (format nil "~a is already closed." (the-name obj :capital t))))\r
 472 \r
 473 (defaction lock (obj key)\r
 474   "Not lockable.")\r
 475 \r
 476 (defmethod lock ((obj predoor) (key item))\r
 477   (unless (and (or (has obj :container) (has obj :door)) \r
 478                (has obj :openable)\r
 479                (has obj :lockable))\r
 480     (return-from lock (call-next-method)))\r
 481   (if (has obj :locked) \r
 482       (format nil "~a is already locked." (the-name obj :capital t))\r
 483       (if (hasnt obj :closed)\r
 484           (format nil "~a is not closed." (the-name obj :capital t))\r
 485           (if (with-keys obj key)\r
 486               (progn\r
 487                 (give obj :locked)\r
 488                 (when (run-action-after obj)\r
 489                   (format nil "You lock ~a." (the-name obj))))\r
 490               (format nil "You cannot lock ~a with ~a."\r
 491                       (the-name obj) (the-name key))))))\r
 492 \r
 493 (defaction unlock (obj key)\r
 494   "There is nothing to unlock.")\r
 495 \r
 496 (defmethod unlock ((obj predoor) (key item))\r
 497   (unless (and (or (has obj :container) (has obj :door)) \r
 498                (has obj :openable)\r
 499                (has obj :lockable))\r
 500     (return-from unlock (call-next-method)))\r
 501   (if (hasnt obj :locked) \r
 502       (format nil "~a is already unlocked." (the-name obj :capital t))\r
 503       (if (hasnt obj :closed)\r
 504           (format nil "~a is not closed." (the-name obj :capital t))\r
 505           (if (with-keys obj key)\r
 506               (progn\r
 507                 (give obj :~locked)\r
 508                 (when (run-action-after obj)\r
 509                   (format nil "You unlock ~a." (the-name obj))))\r
 510               (format nil "You cannot unlock ~a with ~a."\r
 511                       (the-name obj) (the-name key))))))\r
 512 \r
 513 (defaction unlock-open (obj key)\r
 514   "You cannot open this.")\r
 515 \r
 516 (defmethod unlock-open ((obj predoor) (key item))\r
 517   (unless (and (or (has obj :container) (has obj :door)) \r
 518                (has obj :openable))\r
 519     (return-from unlock-open (call-next-method)))\r
 520   (and (run-action 'unlock *args*)\r
 521        (run-action 'open obj)))\r