iflib.lisp

   1 ;;Common Lisp Interactive Fiction Library \r
   2 ;;\r
   3 ;;if-lib module: contains various things that IF library should contain.\r
   4 ;;\r
   5 ;;See license.txt for licensing information\r
   6 ;;\r
   7 ;; Table of contents:\r
   8 ;;\r
   9 ;;           SECTION 1: Global parameters and definitions\r
  10 ;;           SECTION 2: Library-defined classes and objects\r
  11 ;;           SECTION 3: Scope rules\r
  12 ;;           SECTION 4: Printing objects\r
  13 ;;           SECTION 5: Default parser\r
  14 ;;           SECTION 6: Tokens\r
  15 ;;           SECTION 7: Action helpers\r
  16 ;;           SECTION 8: Main loop\r
  17 ;;           SECTION 9: Other stuff\r
  18 \r
  19 \r
  20 (in-package :cl-user)\r
  21 \r
  22 (defpackage :if-lib\r
  23   (:use :common-lisp :if-basic-lib :if-console)\r
  24   (:export :container :room :item :clothing :capacity\r
  25            :food :switchable\r
  26            :n-to :ne-to :e-to :se-to :s-to :sw-to :w-to :nw-to :in-to :out-to\r
  27            :u-to :d-to :cant-go\r
  28            :*intscope*  :*outscope* :*location* :*trace-light* :*vowels*\r
  29            :*score* :*gamestate* :*turns* :*dark*\r
  30            :add-to-scope :add-to-outscope :found-in :seen-from\r
  31            :compass :dir-n :dir-ne :dir-e :dir-se :dir-s\r
  32            :dir-sw :dir-w :dir-nw :dir-u :dir-d :dir-in :dir-out\r
  33            :darkness :lit :transparent :passable\r
  34            :reachp :seep :global-reachp :global-seep :seep1 :reachp1\r
  35            :darkness :actor :selfobj :*player* :find-location\r
  36            :deduce-article :print-property :print-name :list-contents\r
  37            :reset-scope :look :words2dic-first :disambig :normal-token-scope\r
  38            :input-quit-loop :quit-game :prompt :prompt-read :input-loop-step\r
  39            :go-to-room :property :init :test-seq\r
  40            :heldp :the-name :each-turn :daemon :time-left :time-out\r
  41            :start-daemon :stop-daemon :start-timer :stop-timer           \r
  42            :supporter :animate :scenery\r
  43            :afterlife :print-gamestate :end-game\r
  44            :repl-mode :compile-lib :free-symbol \r
  45            )\r
  46   (:shadow :room))\r
  47 \r
  48 (in-package :if-lib)\r
  49 \r
  50 ;;Access to shadowed room function\r
  51 \r
  52 (defun room (&optional (arg :default))\r
  53   (cl:room arg))\r
  54 \r
  55 (define-compiler-macro room (&whole whole &optional arg)\r
  56   (declare (ignore arg))\r
  57   `(cl:room ,@(cdr whole)))\r
  58 \r
  59 ;;---------------\r
  60 \r
  61 ;;SECTION 1: Global parameters and definitions\r
  62 \r
  63 (defparameter *vowels* "aeiouy"\r
  64   "A string containing all English vowels")\r
  65 \r
  66 (defparameter *intscope* nil\r
  67   "`Internal' scope, i.e. reachable by hand")\r
  68 (defparameter *outscope* nil\r
  69   "`Outside' scope, i.e. everything that is visible")\r
  70 (defparameter *location* nil\r
  71   "Current location of the player")\r
  72 (defparameter *dark* nil\r
  73   "Whether it is dark in the current location")\r
  74 (defparameter *score* 0\r
  75   "Current score of the player")\r
  76 (defparameter *gamestate* 0\r
  77   "Current gamestate: if not zero at the end of turn game ends")\r
  78 (defparameter *turns* 0\r
  79   "Turns passed since beginning of the game")\r
  80 \r
  81 (defparameter *player* nil\r
  82   "Current player object (will be initialised later")\r
  83 \r
  84 (declare-predicate add-to-scope add-to-outscope found-in seen-from)\r
  85 \r
  86 ;;SECTION 2: Library-defined classes and objects\r
  87 \r
  88 (ifclass container () (capacity integer) (has :container))\r
  89 (ifclass supporter () (capacity integer) (has :supporter))\r
  90 \r
  91 (ifclass room () (description string)\r
  92          (n-to object) (ne-to object) (e-to object) (se-to object)\r
  93          (s-to object) (sw-to object) (w-to object) (nw-to object)\r
  94          (u-to object) (d-to object) (in-to object) (out-to object)\r
  95          (cant-go string)\r
  96          (has :light :enterable))\r
  97 \r
  98 (ifclass item () (description string) (article string)\r
  99          (has :item))\r
 100 \r
 101 (ifclass clothing (item) (has :clothing))\r
 102 \r
 103 (ifclass scenery () (has :scenery))\r
 104 \r
 105 (ifclass food (item) (has :edible))\r
 106 \r
 107 (ifclass switchable () (has :switchable))\r
 108 \r
 109 (object darkness (room) "Darkness"\r
 110         (description "It's pitch black. You can't see a thing.")\r
 111         (before\r
 112          (look (look self)))\r
 113         (has :~light))\r
 114 \r
 115 ;;Compass directions\r
 116 (object compass ())\r
 117 (object dir-n () "north" (name "north" "n") compass (property 'n-to))\r
 118 (object dir-ne () "northeast" (name "northeast" "ne") compass \r
 119         (property 'ne-to))\r
 120 (object dir-e () "east" (name "east" "e") compass (property 'e-to))\r
 121 (object dir-se () "southeast" (name "southeast" "se") compass \r
 122         (property 'se-to))\r
 123 (object dir-s () "south" (name "south" "s") compass (property 's-to))\r
 124 (object dir-sw () "southwest" (name "southwest" "sw") compass \r
 125         (property 'sw-to))\r
 126 (object dir-w () "west" (name "west" "w") compass (property 'w-to))\r
 127 (object dir-nw () "northwest" (name "northwest" "nw") compass \r
 128         (property 'nw-to))\r
 129 (object dir-u () "up" (name "up" "u") compass (property 'u-to))\r
 130 (object dir-d () "down" (name "down" "d") compass (property 'd-to))\r
 131 (object dir-in () "in"  compass (property 'in-to))\r
 132 (object dir-out () "out" compass (property 'out-to))\r
 133 \r
 134 (ifclass actor () (reachp function nil) (seep function nil))\r
 135 (ifclass animate () (has :animate))\r
 136 \r
 137 (object selfobj (actor animate) "me" \r
 138         (article "")\r
 139         (has :scenery))\r
 140 \r
 141 (defparameter *player* selfobj\r
 142   "This time it's initialised properly")\r
 143 \r
 144 ;;SECTION 3: Scope rules\r
 145 \r
 146 (defun find-location (obj)\r
 147   "Find a top-level object that contains obj"\r
 148   (loop for o = obj then (parent o) while (parent o) finally (return o))) \r
 149 \r
 150 (defun transparent (obj)\r
 151   "Whether the object is transparent"\r
 152   (or (has obj :container :open) \r
 153       (has obj :supporter)\r
 154       (has obj :transparent)\r
 155       (eql obj *player*)))\r
 156 \r
 157 (defun lit-down (obj)\r
 158   "Lighting recursion down the object tree"\r
 159   (if (has obj :light) t\r
 160       (some #'(lambda (x) (or (has x :light) \r
 161                               (and (transparent x) (lit-down x))))\r
 162             (children obj))))\r
 163 \r
 164 (defun lit (obj)\r
 165   "Whether an object is lit"\r
 166   (or (lit-down obj) \r
 167       (when (parent obj) \r
 168         (or (has (parent obj) :light) \r
 169             (lit (parent obj))))))\r
 170 \r
 171 \r
 172 (defun seep-down (actor obj)\r
 173   "Looking recursion down the object tree"\r
 174   (if (eql obj actor) t\r
 175       (some #'(lambda (x) (or (eql x actor) \r
 176                               (and (transparent x) (seep-down actor x))))\r
 177             (children obj))))\r
 178  \r
 179 \r
 180 (defun seep2 (actor obj)\r
 181   "First approximation of looking function"\r
 182   (or (seep-down actor obj) \r
 183       (when (parent obj) \r
 184         (or (eql actor (parent obj))  (seep2 actor (parent obj))))))\r
 185 \r
 186 (defun seep1 (actor obj)\r
 187   "Second approximation of looking function"\r
 188   (and (lit actor) (lit obj) (or (in obj compass) (seep2 actor obj))))\r
 189 \r
 190 (defun global-seep (actor obj)\r
 191   "Tests whether an object is seen by actor"\r
 192   (if (and (typep actor 'actor) (seep actor))\r
 193       (read-property actor 'seep obj)\r
 194       (seep1 actor obj)))\r
 195 \r
 196 (defun passable (obj)\r
 197   (or (has obj :container :open)\r
 198       (has obj :supporter)\r
 199       (eql obj *player*)))\r
 200 \r
 201 \r
 202 (defun reachp-down (actor obj)\r
 203   "Reaching recursion down the object tree"\r
 204   (if (eql obj actor) t\r
 205       (some #'(lambda (x) (or (eql x actor) \r
 206                               (and (passable x) (reachp-down actor x))))\r
 207             (children obj))))\r
 208  \r
 209 \r
 210 (defun reachp2 (actor obj)\r
 211   "First approximation of reaching function"\r
 212   (or (reachp-down actor obj) \r
 213       (when (parent obj) \r
 214         (or (eql (parent obj) actor) \r
 215             (reachp2 actor (parent obj))))))\r
 216 \r
 217 \r
 218 (defun reachp1 (actor obj)\r
 219   "Second approximation of reaching function"\r
 220   (and (lit obj) (lit actor) (reachp2 actor obj)))\r
 221   \r
 222 (defun global-reachp (actor obj)\r
 223   "Tests whether an object is reachable by actor"\r
 224   (if (and (typep actor 'actor) (reachp actor))\r
 225       (read-property actor 'reachp obj)\r
 226       (reachp1 actor obj)))\r
 227 \r
 228 (defun reset-scope (&aux location)\r
 229   "Update scope for the new location"\r
 230   (setf location *location*)\r
 231   (unless location (setf *intscope* nil *outscope* nil) \r
 232           (return-from reset-scope))\r
 233   (setf *dark* (not (and (lit *player*) (lit *location*))))\r
 234   (setf *outscope* (loop for x in *allobjects* ;unless (eql x location)\r
 235                       when (global-seep *player* x) collect x))\r
 236   (setf *intscope* (loop for x in *allobjects* ;unless (eql x location)\r
 237                       when (global-reachp *player* x) collect x))\r
 238   (let ((int (loop for x in *intscope* \r
 239                    append (add-to-scope x)))\r
 240         (out (loop for x in *outscope* \r
 241                    append (add-to-scope x)\r
 242                    append (add-to-outscope x))))\r
 243     (setf *outscope* (nconc *outscope* out))\r
 244     (setf *intscope* (nconc *intscope* int)))\r
 245   (objectloop (x) (when (and (seen-from x *location*) (hasnt x :absent))\r
 246                     (push x *outscope*))))\r
 247 \r
 248 ;;SECTION 4: Printing objects\r
 249 \r
 250 (defun deduce-article (name)\r
 251   "Tries to guess an article for the object"\r
 252   (let ((firstchar (aref name 0)))\r
 253     (cond ((char= firstchar (char-upcase firstchar)) "the")\r
 254           ((find firstchar *vowels* :test #'char=) "an")\r
 255           (t "a")))) \r
 256 \r
 257 (defun print-property (obj property)\r
 258   "Print a property of object"\r
 259   (multiple-value-bind (value printp) (read-property obj property)\r
 260     (if (and (stringp value) (not printp)) (progn (sprint value) t) printp)))\r
 261 \r
 262 (defgeneric print-name (obj &key article capital)\r
 263   (:documentation "Returns a string containing the name of object"))\r
 264 (register-generic 'print-name)    \r
 265 \r
 266 \r
 267 (defgeneric the-name (obj &key article capital)\r
 268   (:documentation "Returns a string containing _the_ name of\r
 269   object (with definite article, and fluff stripped off)"))\r
 270 (register-generic 'the-name)\r
 271 \r
 272 (defmethod print-name ((obj abstractobject) &key (article nil) (capital nil))\r
 273   (let ((outstr\r
 274   (with-output-to-string (out)\r
 275     (let ((*standard-output* out)\r
 276           (name (read-property obj 'name)))\r
 277       (if article\r
 278           (unless (zerop (length article)) (format t "~a " article))\r
 279       (if (provides obj 'article) \r
 280           (print-property obj 'article)\r
 281           (progn (princ (deduce-article name)) (princ " "))))\r
 282       (princ name)))))\r
 283     (when capital (setf (aref outstr 0) (char-upcase (aref outstr 0))))\r
 284     outstr))\r
 285 \r
 286 (defmethod print-name ((obj clothing) &key &allow-other-keys)\r
 287   (if (has obj :worn) (concatenate 'string (call-next-method) " (worn)")\r
 288       (call-next-method)))\r
 289 \r
 290 (defmethod print-name ((obj item) &key &allow-other-keys)\r
 291   (if (has obj :light) (concatenate 'string (call-next-method) \r
 292                                     " (providing light)")\r
 293       (call-next-method)))\r
 294 \r
 295 (defmethod print-name ((obj animate) &key (article nil) (capital nil))  \r
 296   (call-next-method obj :article (or article "") :capital capital))\r
 297 \r
 298 (defmethod the-name ((obj abstractobject) &key (article nil) (capital nil))\r
 299   (let ((outstr\r
 300   (with-output-to-string (out)\r
 301     (let ((*standard-output* out)\r
 302           (name (read-property obj 'name)))\r
 303       (if article\r
 304           (unless (zerop (length article)) (format t "~a " article))\r
 305       (if (provides obj 'article) \r
 306           (print-property obj 'article)\r
 307           (progn (princ "the "))))\r
 308       (princ name)))))\r
 309     (when capital (setf (aref outstr 0) (char-upcase (aref outstr 0))))\r
 310     outstr))\r
 311         \r
 312 (defmethod the-name ((obj animate) &key (article nil) (capital nil))  \r
 313   (call-next-method obj :article (or article "") :capital capital))\r
 314 \r
 315 (defun print-inside (obj stream)\r
 316   "Return the string containing the status of contents of the object"\r
 317   (when (has obj :container)\r
 318     (if (or (has obj :open) (has obj :transparent))\r
 319         (if (children obj)\r
 320           (progn (princ " (containing " stream) \r
 321                  (princ (list-contents obj) stream) \r
 322                  (princ ")" stream))\r
 323           (princ " (empty)" stream))\r
 324         (princ " (closed)" stream)))\r
 325   (when (has obj :supporter)\r
 326     (when (children obj)\r
 327       (progn (princ " (on top of which are " stream) \r
 328              (princ (list-contents obj) stream) \r
 329              (princ ")" stream)))))\r
 330 \r
 331 (defun list-contents (obj)\r
 332   "Return the string containing the contents of the object"\r
 333   (with-output-to-string (out)\r
 334   (let (commaflag)\r
 335     (when (children obj) \r
 336       (objectloop (in x obj)\r
 337                   (if (and !last! commaflag) (princ " and " out)\r
 338                       (when commaflag (princ ", " out)))\r
 339                   (setf commaflag t)\r
 340                   (princ (print-name x) out)\r
 341                   (print-inside x out))))))\r
 342         \r
 343 \r
 344 (defun default-glance (obj)\r
 345   "Default initial description of object"\r
 346   (format t "[Default glance for ~a]~%" obj)\r
 347   (sprint "~a~%" \r
 348           (with-output-to-string (out)\r
 349             (princ "There is " out) (princ (print-name obj) out) \r
 350             (print-inside obj out)\r
 351             (princ "." out))))\r
 352 \r
 353 \r
 354 ;;SECTION 5: Default parser\r
 355 \r
 356 (defun greedy-match-noun (obj words)\r
 357   "Finds how many words obj matches"\r
 358   (loop for w in words\r
 359         collecting w into ww\r
 360         when (< (parser obj ww) 1) return (length (butlast ww))\r
 361         finally (return (length words))))\r
 362         \r
 363 \r
 364 (defun find-best-match (words scope)\r
 365   "Returns a list of objects that match words the best"\r
 366   (loop with bestvalue = 0\r
 367         with bestnouns = nil\r
 368         for x in scope\r
 369         for y = (greedy-match-noun x words)\r
 370         when (> y bestvalue) do (setf bestvalue y) (setf bestnouns (list x))\r
 371         else when (and (= y bestvalue) (> bestvalue 0)) do (push x bestnouns)\r
 372         finally (return (values bestnouns bestvalue))))\r
 373 \r
 374 (defun words2dic-first (words)\r
 375   "Returns a list of words while they are in the dictionary"\r
 376   (loop for w in words\r
 377         for n = (handler-case (word2dic w) (nosuchword () nil))\r
 378         while n collect n))\r
 379 \r
 380 (defgeneric parser-score (obj)\r
 381   (:documentation "Should return the score used when sorting\r
 382   through ambiguous input")\r
 383   (:method (obj) (declare (ignore obj)) 100))\r
 384 \r
 385 (defmethod parser-score ((room room))\r
 386   (declare (ignore room)) 10)\r
 387 \r
 388 (define-condition disambig ()\r
 389   ((what :initarg :what :initform nil :reader disambig-what)\r
 390    (words :initarg :words :initform nil :reader disambig-words))\r
 391   (:report (lambda (condition stream) \r
 392              (format stream "Cannot decide between the objects: ~A" \r
 393                      (disambig-what condition)))))  \r
 394 \r
 395 (defun handle-disambig (c)\r
 396   "Disambiguation handle"\r
 397   (let*((dlist (disambig-what c))\r
 398         (bestvalue (loop for x in dlist\r
 399                       maximizing (parser-score x)))\r
 400         (list (delete-if (lambda (item) (< (parser-score item) bestvalue))\r
 401                          dlist)))\r
 402     (unless (cdr list)\r
 403       (return-from handle-disambig (first list)))\r
 404     (sprint "I can't understand what do you mean by:~{ ~a~}." \r
 405             (disambig-words c))\r
 406     (newline)\r
 407     (sprint "Choose one:~%")\r
 408     (let ((i 0))\r
 409       (dolist (l list)\r
 410         (sprint "~a: ~a~%" (incf i) (print-name l)))\r
 411       (sprint ">>")\r
 412       (force-output *outstream*)\r
 413       (nth (loop for x = (parse-integer \r
 414                           (get-input *instream* *outstream*)\r
 415                           :junk-allowed t)\r
 416               until (and (numberp x) (<= 1 x (length list)))\r
 417               finally (return (1- x)))\r
 418            list))))\r
 419 \r
 420 ;;SECTION 6: Tokens\r
 421 \r
 422 \r
 423 (defun normal-token-scope (wordlist scope)\r
 424   "The main token function"\r
 425   (multiple-value-bind (bnouns bvalue) \r
 426           (find-best-match (words2dic-first wordlist) scope)\r
 427         (case (length bnouns)\r
 428           (1 (values t (car bnouns) \r
 429                      (last wordlist (- (length wordlist) bvalue))))\r
 430           (0 nil)\r
 431           (t (let ((choosewhat (handler-case \r
 432                                    (signal 'disambig :what bnouns\r
 433                                            :words (butlast wordlist\r
 434                                               (- (length wordlist) bvalue)))\r
 435                                  (disambig (condition)\r
 436                                    (handle-disambig condition)))))\r
 437                (when choosewhat \r
 438                  (values t choosewhat\r
 439                          (last wordlist (- (length wordlist) bvalue)))))))))\r
 440 \r
 441 ;;Token definitions\r
 442 \r
 443 (deftoken :noun ;matches the given scope (intscope by default)\r
 444     (let ((scope (if (eql *tokenpar* :unspecified) *intscope* *tokenpar*))) \r
 445       (normal-token-scope wordlist scope)))\r
 446 \r
 447 (deftoken :seen ;matches outscope\r
 448     (normal-token-scope wordlist *outscope*))\r
 449                                          \r
 450 (deftoken :or  ;An ugly hack - matches either of supported words\r
 451     (let ((word (car (member (car wordlist) *tokenpar* :test #'string==))))\r
 452       (if word (values t word (cdr wordlist)) nil)))\r
 453 \r
 454 (deftoken :has ;has flag, in outscope\r
 455     (normal-token-scope wordlist \r
 456         (remove-if #'(lambda (x) (hasnt x *tokenpar*)) *outscope*)))\r
 457 \r
 458 (deftoken :direction ;compass direction\r
 459     (normal-token-scope wordlist (children compass)))\r
 460 \r
 461 (defun heldp (obj)\r
 462   (if (eql obj *player*) t\r
 463       (and (parent obj) (transparent (parent obj)) (heldp (parent obj)))))\r
 464 \r
 465 (deftoken :held\r
 466     (normal-token-scope wordlist\r
 467         (remove-if (complement #'heldp) *outscope*)))          \r
 468 \r
 469 (deftoken :meta\r
 470     (setf *meta* t) (values t t wordlist))\r
 471   \r
 472   \r
 473 ;;SECTION 7: Action helpers\r
 474 ;;\r
 475 ;;Most of the actions are defined in verbs module.\r
 476 \r
 477       \r
 478 (defgeneric look (obj) \r
 479   (:documentation "Used for looking in rooms and containers"))\r
 480 (register-generic 'look)\r
 481 \r
 482 (defmethod look ((room room))\r
 483   (sprint "~a~%~%" (read-property room 'name))\r
 484   (when (provides room 'description) (print-property room 'description))\r
 485   (freshline)\r
 486   (objectloop (in x room)\r
 487               (when (hasnt x :scenery :hidden)\r
 488               (freshline)\r
 489               (if (provides x 'glance)\r
 490                   (unless (print-property x 'glance) (default-glance x))\r
 491                   (default-glance x))))\r
 492   t)\r
 493 \r
 494 (defun go-to-room (room)\r
 495   "Player moves into room"\r
 496   (when (typep room 'abstractobject)\r
 497     (setf *location* room)\r
 498     (move *player* *location*)\r
 499     (give *location* :visited)\r
 500     (objectloop (x) (when (and (found-in x *location*) (hasnt x :absent))\r
 501                       (move x *location*)))\r
 502     (reset-scope)\r
 503     (run-action 'look *location* :time 0)))\r
 504 \r
 505 \r
 506 ;;SECTION 8: Main loop \r
 507 \r
 508 (supply turn-passing (&optional time)   \r
 509         (reset-scope)\r
 510         (incf *turns* time)\r
 511         (loop for x in *allobjects*\r
 512               if (and (has x :daemon) (provides x 'daemon))\r
 513               do (read-property- :execute x 'daemon)\r
 514               if (and (has x :timer) (provides x 'time-left) \r
 515                       (provides x 'time-out))\r
 516               do (if (zerop (slot-value x 'time-left))\r
 517                      (read-property- :execute x 'time-out)\r
 518                      (decf (slot-value x 'time-left))))\r
 519         (loop for x in *outscope*\r
 520               if (provides x 'each-turn)\r
 521               do (read-property- :execute x 'each-turn))           \r
 522         (call-next-method))          \r
 523 \r
 524 (defun start-daemon (obj)\r
 525   (give obj :daemon))\r
 526 \r
 527 (defun stop-daemon (obj)\r
 528   (give obj :~daemon))\r
 529 \r
 530 (defun start-timer (obj time)\r
 531   (assert (provides obj 'time-left))\r
 532   (setf (slot-value obj 'time-left) time)\r
 533   (give obj :timer))\r
 534 \r
 535 (defun stop-timer (obj)\r
 536   (give obj :~timer))\r
 537 \r
 538 (defgeneric before-special-rule (location)\r
 539   (:documentation "Runs on location before other before effects are runned")\r
 540   (:method (location) (declare (ignore location)) nil))\r
 541 (register-generic 'before-special-rule)\r
 542 \r
 543 (defmethod before-special-rule ((location room))\r
 544    (or (and *dark* (before darkness)) \r
 545        (unless (eql *noun* *location*) (before location))))\r
 546 \r
 547 (defgeneric after-special-rule (location)\r
 548   (:documentation "Runs on location before other after effects are runned")\r
 549   (:method (location) (declare (ignore location)) nil))\r
 550 (register-generic 'after-special-rule)\r
 551 \r
 552 (defmethod after-special-rule ((location room))\r
 553   (or (and *dark* (after darkness))\r
 554       (unless (eql *noun* *location*) (after location))))\r
 555 \r
 556 (supply before-hook ()\r
 557   "Allows for react-before and location interventions"\r
 558   (or (loop for x in *outscope*\r
 559             thereis (react-before x))\r
 560         (before-special-rule *location*)))\r
 561 \r
 562 (supply after-hook ()\r
 563   "Allows for react-after and location interventions"\r
 564   (or (loop for x in *outscope*\r
 565             thereis (react-after x))\r
 566         (after-special-rule *location*)))\r
 567 \r
 568 (define-condition input-quit-loop () ()) \r
 569 \r
 570 (defun quit-game ()\r
 571   "Guess what it does?"  \r
 572   (signal 'input-quit-loop))\r
 573 \r
 574 (defstub prompt ()\r
 575   "Display the prompt for input"\r
 576   (princ "> " *outstream*)) \r
 577 \r
 578 (defun prompt-read ()\r
 579   "Read input from user"\r
 580   (newline *outstream*) (prompt)\r
 581   (force-output *outstream*)\r
 582   (get-input *instream* *outstream*)\r
 583   (let ((result (read-line *instream*)))\r
 584     (newline *outstream*) result))\r
 585 \r
 586 ;(defun input-loop ()\r
 587 ;  (handler-case \r
 588 ;      (loop (unless (zerop *gamestate*) (end-game))\r
 589 ;           (parse-command (prompt-read)))\r
 590 ;      (input-quit-loop () nil)))\r
 591 \r
 592 (defun input-loop-step ()\r
 593   "One step of the input loop"\r
 594   (handler-case\r
 595       (progn\r
 596         (unless (zerop *gamestate*) (end-game))\r
 597         (let ((input (prompt-read)))\r
 598           (when (equal input "!quit") (signal 'input-quit-loop))\r
 599           (parse-command input))\r
 600         (ltk-after 500 #'input-loop-step))\r
 601     (input-quit-loop () (close-console) nil)))\r
 602 \r
 603 (defstub init ()\r
 604   "Called at the beginning of the game"\r
 605   "Warning: no init routine detected!")\r
 606 \r
 607 (defstub afterlife ()\r
 608   "Called when the player dies" t)\r
 609 \r
 610 (defstub print-gamestate ()\r
 611   "Called when gamestate is >2"\r
 612   "The End")\r
 613 \r
 614 (defun print-gamestate-default ()\r
 615   "Prints default end game messages"\r
 616   (case *gamestate*\r
 617     (1 "You have died")\r
 618     (2 "You have won")\r
 619     (t (print-gamestate))))\r
 620 \r
 621 (defun end-game ()\r
 622   "Called when the game ends"\r
 623   (when (afterlife)\r
 624     (sprint "~%~%~%***~a***~%~%~%" (print-gamestate-default))\r
 625     (sprint "Score:~a Turns:~a" *score* *turns*)\r
 626     (quit-game)))\r
 627 \r
 628 \r
 629 (defun seq ()\r
 630   "Load game sequence"\r
 631      (exec init ()) (go-to-room *location*)\r
 632      (input-loop-step))\r
 633 \r
 634 (defun lib (file dir)\r
 635   "Reloads the IF library" \r
 636   (format t "[DIRECTORY: ~a]~%" dir)\r
 637   (print-message "Loading if.fas...")\r
 638   (load (merge-pathnames dir "if.fas"))\r
 639   (print-message "Loading iflib.fas...") \r
 640   (load (merge-pathnames dir "iflib.fas"))\r
 641   (print-message "Loading verbs.fas...") \r
 642   (load (merge-pathnames dir "verbs.fas"))\r
 643   (print-message "Loading game module...") \r
 644   (load file)\r
 645   (print-message "Module is successfully loaded."))\r
 646 \r
 647 (defun test-seq (&optional (rm *repl-mode*))\r
 648   "Test sequence emulating interactive fiction interpreter"\r
 649   ;;(load-cfg "iflib.cfg")\r
 650   (setf *score* 0 \r
 651         *turns* 0\r
 652         *gamestate* 0)\r
 653   (repl-mode rm)\r
 654   (run-console #'seq #'lib))\r
 655 \r
 656 (defun load-cfg (file)\r
 657   (when (probe-file file)\r
 658     (format t "Loading config file...~%")\r
 659     (with-open-file (s file)\r
 660       (loop for x in (read s)\r
 661             do (setf (symbol-value (car x)) (cdr x))))))\r
 662 \r
 663 (defun interactive-start ()\r
 664   "Function intended to be used by user"\r
 665   (load-cfg "iflib.cfg")\r
 666   (unless *repl-mode*\r
 667     (run-console #'seq #'lib :interactive t)\r
 668     (when *hard-quit* (quit-lisp))))\r
 669 \r
 670 ;;SECTION 9: Other stuff\r
 671 \r
 672 ;;Simpler defpackage for easy using\r
 673 \r
 674 (defmacro load-libs (name &rest other-packages)\r
 675   `(defpackage ,name\r
 676     (:use :common-lisp :if-basic-lib :if-lib :verb-lib ,@other-packages)\r
 677     (:shadowing-import-from :if-lib :room)\r
 678     (:shadowing-import-from :verb-lib :listen :fill)))\r
 679 \r
 680 (defmacro free-symbol (id)\r
 681   "Frees a symbol from current package using shadow"\r
 682   `(eval-when (:compile-toplevel :load-toplevel :execute)\r
 683      (shadow ,id)))\r
 684 \r
 685    \r
 686 (defun repl-mode (&optional (mode :unspecified))\r
 687   "Flip the using of REPL for input and output (as opposed to\r
 688 graphical interface)"\r
 689   (setf *repl-mode* (if (eql mode :unspecified) (not *repl-mode*) mode)))\r
 690 \r
 691 (defun compile-lib ()\r
 692   "Recompile the library. Useful to refresh old fasls."\r
 693   (compile-file "if.lisp")\r
 694   (compile-file "iflib.lisp")\r
 695   (compile-file "verbs.lisp"))\r
 696 \r
 697 #+clisp\r
 698 (defun deliver-me ()\r
 699   (ext:saveinitmem "lifp.exe" :quiet t :norc t \r
 700                    :init-function #'interactive-start \r
 701                    :start-package :if-lib \r
 702                    :executable t))