if.lisp

   1 ;;Common Lisp Interactive Fiction Library \r
   2 ;;\r
   3 ;;if-basic-lib module: provides the core functionality - most of the critical\r
   4 ;;macros and functions are defined there.\r
   5 ;;\r
   6 ;;This file is a part of Lisp Interactive Fiction Project\r
   7 ;;\r
   8 ;;See license.txt for licensing information\r
   9 ;;\r
  10 ;; Table of contents: \r
  11 ;;\r
  12 ;;           SECTION 1: General purpose macros\r
  13 ;;           SECTION 2: Global parameters and definitions\r
  14 ;;           SECTION 2a: Cleanup mechanics\r
  15 ;;           SECTION 3: The Pretty Printer \r
  16 ;;           SECTION 4: The Dictionary\r
  17 ;;           SECTION 5: AbstractObject class and it's methods\r
  18 ;;           SECTION 6: read-property bonanza \r
  19 ;;           SECTION 7: IfClass macro and its hairy surroundings\r
  20 ;;           SECTION 8: Object macro and some related functions\r
  21 ;;           SECTION 9: Verb functions\r
  22 ;;           SECTION 10: pattern matching\r
  23 ;;           SECTION 11: Core functionality & commands parsing\r
  24 \r
  25 \r
  26 \r
  27 (in-package :cl-user)\r
  28 \r
  29 (defpackage :if-basic-lib\r
  30   (:use :if-console :common-lisp)\r
  31   (:export :with-gen-syms :once-only :defsyn :ref\r
  32            :*space-chars* :*dictionary* :*dict-index* :*instream*\r
  33            :*outstream* :*verbs* :*tokens* :*allobjects* :*tokenpar*\r
  34            :*action* :*args* :*noun* :*second* :before :after :self\r
  35            :*after* :*debug*\r
  36            :addword :word2dic :addword2dic\r
  37            :split-to-words :sprint\r
  38            :parser :description :article :glance \r
  39            :initnames :addnames \r
  40            :read-property :rp :read-property- \r
  41            :exec :exec*\r
  42            :abstractobject :name :names :parent :children :flags\r
  43            :initflags :add-flags :has :hasnt :-> :give :child\r
  44            :ifclass :object :defaction :*meta*\r
  45            :move :rmv :ofclass :among :below\r
  46            :verb :extend-verb :extend-verb-first\r
  47            :extend-verb-only :extend-verb-only-first\r
  48            :deftoken :string== :matchp :!last!\r
  49            :in :notin :objectloop :provides\r
  50            :wordlist :tokenlist\r
  51            :nosuchword :nosuchword-word\r
  52            :parse-command :unknown-verb :run-action :run-action-after\r
  53            :turn-passing :pretty-string :*textwidth* :*offset* \r
  54            :ignore-newlines :newline :freshline :put-word :outprinc\r
  55            :destroy :supply :defstub :before-hook :after-hook\r
  56            :*rules* :*predicates* :declare-rule :declare-predicate\r
  57            :react-before :react-after :instead\r
  58            :*cleanup* :do-cleanup :register-stub :cleanup-stub \r
  59            :register-generic))\r
  60 \r
  61 (in-package :if-basic-lib)\r
  62 \r
  63 \r
  64 ;;SECTION 1: General purpose macros\r
  65 \r
  66 (defmacro with-gen-syms ((&rest names) &body body)\r
  67   `(let ,(loop for n in names collect `(,n (make-symbol ,(string n))))\r
  68      ,@body))\r
  69 \r
  70 (defmacro once-only ((&rest names) &body body)\r
  71   (let ((gensyms (loop for n in names collect (gensym (string n)))))\r
  72     `(let (,@(loop for g in gensyms collect `(,g (gensym))))\r
  73       `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))\r
  74         ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))\r
  75            ,@body)))))\r
  76 \r
  77 (defun ignore-warning (condition)\r
  78    (declare (ignore condition))\r
  79    (muffle-warning))\r
  80 \r
  81 (defun as-keyword (sym) (intern (string sym) :keyword))\r
  82 \r
  83 (defmacro defsyn (name func)\r
  84   `(defmacro ,name (&rest args) \r
  85     `(,',func ,@args)))\r
  86 \r
  87 (defmacro ref (&rest names)\r
  88   "make defvars for names"\r
  89   `(progn\r
  90      ,@(loop for x in names\r
  91             collect `(defvar ,x nil))))\r
  92 \r
  93 ;;SECTION 2: Global parameters and definitions\r
  94 \r
  95 (defparameter *debug* t\r
  96   "When true, displays all sorts of debug messages")\r
  97 \r
  98 (defparameter *space-chars* #(#\Space #\Newline #\Tab)\r
  99   "Characters considered to be space by split-to-words function")\r
 100 \r
 101 \r
 102 (defparameter *dictionary* (make-hash-table :test #'equal)\r
 103   "The game dictionary - contains mapping from words to integers")\r
 104 (defparameter *dict-index* 0\r
 105   "The index indicating how many integers were used up")\r
 106 \r
 107 ;;Streams\r
 108 \r
 109 (defparameter *outstream* (make-instance 'terminal-out)\r
 110   "The stream where everything is output")\r
 111 (defparameter *instream*  (make-instance 'terminal-in)\r
 112   "The stream which reads commands from user")\r
 113 \r
 114 ;;Uncomment these for the REPL output (don't - deprecated by repl-mode)\r
 115 ;(defparameter *outstream* *standard-output*)\r
 116 ;(defparameter *instream* *standard-input*)\r
 117   \r
 118 \r
 119 ;;Text printer parameters\r
 120 \r
 121 (define-symbol-macro *textwidth* (textwidth *outstream*))\r
 122 (define-symbol-macro *offset* (offset *outstream*))\r
 123 \r
 124 ;(defparameter *textwidth* 72)\r
 125 ;(defparameter *offset* 0)\r
 126 \r
 127 \r
 128 (defparameter *verbs* (make-hash-table :test #'eql)\r
 129   "Contains verb syntax")\r
 130 (defparameter *tokens* (make-hash-table :test #'eql)\r
 131   "Contains parser tokens")\r
 132 (defparameter *allobjects* nil\r
 133   "Contains every object in the game")\r
 134 (defparameter *tokenpar* :unspecified\r
 135   "Used to pass parameters to topics")\r
 136 (defparameter *action* nil\r
 137   "Current action")\r
 138 (defparameter *args* nil\r
 139   "Current arguments to action")\r
 140 (defparameter *noun* nil\r
 141   "First argument to action")\r
 142 (defparameter *second* nil\r
 143   "Second argument to action")\r
 144 (defparameter *after* nil\r
 145   "Whether the run-action-after was called during the last action\r
 146  and wasn't interrupted - this is necessary for indirect action\r
 147  processing (like put-on/in and reverse)")\r
 148 (defvar *rules* nil\r
 149   "List of ifclass parameters that are regarded as `rules', i.e.\r
 150   methods with action autoswitch turned on)")\r
 151 (defvar *predicates* nil\r
 152   "List of ifclass parameters that are regarded as `predicates',\r
 153   i.e. properties that are either lists or functions.")\r
 154 \r
 155 (defvar self) ;;Must be special for being usable in object definitions\r
 156 \r
 157 (defparameter *meta* nil\r
 158   "Indicates a meta-action, which cannot be intercepted by\r
 159   in-game objects")\r
 160 \r
 161 (defparameter *cleanup* nil\r
 162   "The list of elements of type (function . arguments), which\r
 163   describe what is needed to do before reloading the library the\r
 164   second time")\r
 165 \r
 166 ;; SECTION 2a: Cleanup mechanics\r
 167 \r
 168 (defun do-cleanup ()\r
 169   (loop for x in *cleanup*\r
 170         do (apply (car x) (cdr x)))\r
 171   (setf *cleanup* nil))\r
 172        \r
 173 (defun stub-arguments (arglist)\r
 174   "Returns a typical list of arguments for a stub"\r
 175     (loop for x in arglist\r
 176        if (consp x) collect t ;Hmmm... fishy\r
 177        else if (or (keywordp x) \r
 178                    (member x '(&allow-other-keys &key &rest &aux &optional))) \r
 179                collect x\r
 180        else if (symbolp x) collect t))\r
 181 \r
 182 (defun cleanup-stub (fun args)\r
 183   (loop for x in (compute-applicable-methods fun (stub-arguments args))\r
 184         do (remove-method fun x)))\r
 185   \r
 186 (defun register-stub (fun arglist)\r
 187   (push (cons #'cleanup-stub (list fun arglist)) *cleanup*))\r
 188 \r
 189 (defun register-generic (fun)\r
 190   (push (cons #'fmakunbound (list fun)) *cleanup*))\r
 191 \r
 192 \r
 193 ;; SECTION 3: The Pretty Printer (well, not very pretty)\r
 194 \r
 195 (defun newline (&optional (stream *outstream*))\r
 196   "Print a newline with printer"\r
 197   (setf *offset* 0) (terpri stream))\r
 198 \r
 199 (defun freshline (&optional (stream *outstream*))\r
 200   "Print a fresh line with printer"\r
 201   (setf *offset* 0) (fresh-line stream))\r
 202 \r
 203 (defun outprinc (str &optional (stream *outstream*))\r
 204   "Princ to printer"\r
 205   (princ str stream) (incf *offset* (length str)))\r
 206 \r
 207 (defun ignore-newlines (str)\r
 208   "Remove all newlines from a given string (allows us to use Lisp multilines)"\r
 209   (let (spaceflag (countspaces 0))\r
 210     (with-output-to-string (out)\r
 211       (loop for c across str\r
 212             when (char= c #\Space) do (incf countspaces)\r
 213             else when (char= c #\Newline) do (setf spaceflag t countspaces 0)\r
 214                                              (princ #\Space out)\r
 215             else do (unless spaceflag (loop for i from 1 to countspaces\r
 216                                             do (princ #\Space out)))\r
 217                     (princ c out) (setf spaceflag nil countspaces 0))\r
 218       (loop for i from 1 to countspaces do (princ #\Space out)))))\r
 219     \r
 220 (defun put-word (word stream)\r
 221   "Put a word to printer"\r
 222   (let ((wordlen (length word)))\r
 223     (if (<= (+ *offset* wordlen 1) *textwidth*)\r
 224         (progn (princ word stream) (princ #\Space stream)\r
 225                (incf *offset* (1+ wordlen)))\r
 226         (progn (newline stream) (princ word stream) \r
 227                (princ #\Space stream)\r
 228                (incf *offset* (1+ wordlen))))))\r
 229 \r
 230 (defun pretty-string (str stream)\r
 231   "Print a string using pretty printer"\r
 232   (let ((word (make-array 10 :adjustable t \r
 233                           :fill-pointer 0 :element-type 'character))\r
 234         spaceflag)\r
 235     (loop for c across str\r
 236           unless (find c *space-chars*)\r
 237           do (vector-push-extend c word) (setf spaceflag nil)\r
 238           else do (unless spaceflag \r
 239                     (put-word word stream)\r
 240                     (setf spaceflag t)\r
 241                     (when (char= c #\Newline) \r
 242                       (setf spaceflag nil) (newline stream))\r
 243                     (adjust-array word 10 :fill-pointer 0)))\r
 244     (unless (zerop (length word)) (put-word word stream))))\r
 245           \r
 246 (defun sprint (str &rest args)\r
 247   "format-like facility for printing strings with pretty printer"\r
 248   (pretty-string (apply #'format nil (ignore-newlines str) args) *outstream*)\r
 249   nil)\r
 250 \r
 251 ;;SECTION 4: The Dictionary\r
 252 \r
 253 (defun addword (word)\r
 254   "Add a word to dictionary"\r
 255   (let ((word (string-downcase word)))\r
 256     (multiple-value-bind (num ex) (gethash word *dictionary*)\r
 257       (declare (ignore num))\r
 258       (unless ex (setf (gethash word *dictionary*) (incf *dict-index*))))))\r
 259 \r
 260 (define-condition nosuchword (error)\r
 261   ((word :initarg :word :reader nosuchword-word))\r
 262   (:report (lambda (condition stream)\r
 263              (format stream "No such word in dictionary: ~a" \r
 264                      (nosuchword-word condition))))\r
 265   (:documentation "No such word error"))\r
 266 \r
 267 (defun word2dic (word)\r
 268   "Return dictionary index of a given word. Error if there is no\r
 269 such word in dictionary"\r
 270   (let ((word (string-downcase word)))\r
 271     (multiple-value-bind (num ex) (gethash word *dictionary*)\r
 272       (if ex num (error 'nosuchword :word word)))))\r
 273 \r
 274 (defun addword2dic (word)\r
 275   "Return dictionary index of a given word. If there is no such\r
 276 word in dictionary, add it."\r
 277   (let ((word (string-downcase word)))\r
 278     (multiple-value-bind (num ex) (gethash word *dictionary*)\r
 279       (if ex num (setf (gethash word *dictionary*) (incf *dict-index*))))))\r
 280 \r
 281 (defun split-to-words (string) \r
 282   "Returns a list of words in a string"\r
 283   (assert (stringp string))\r
 284   (loop \r
 285    with lst = nil\r
 286    with curword = ""\r
 287    for x across string\r
 288    if (find x *space-chars*) \r
 289    do (unless (zerop (length curword)) (push curword lst))\r
 290    (setf curword "")\r
 291    else do (setf curword (format nil "~a~a" curword x))\r
 292    finally (unless (zerop (length curword)) (push curword lst))\r
 293    (return (reverse lst))))\r
 294 \r
 295 ;;SECTION 5: AbstractObject class and it's methods\r
 296 \r
 297 (defclass abstractobject ()\r
 298   ((name :initarg :name :initform "object" :accessor name\r
 299          :documentation "Name of the object")\r
 300    (names :initform nil :reader names\r
 301           :documentation "List of dict-words for the parser")\r
 302    (parent :initarg :parent :initform nil :reader parent\r
 303            :documentation "Parent of object")\r
 304    (children :initform nil :reader children\r
 305              :documentation "Children of object")\r
 306    (flags :initarg :flags :initform nil :accessor flags\r
 307           :documentation "Flags of object"))\r
 308   (:documentation "The main IF object class, of which all other\r
 309   objects are subclasses"))\r
 310 \r
 311 (defgeneric parser (obj words) \r
 312   (:documentation \r
 313    "Parser for object - returns a number between 0 and 1 indicating\r
 314    how close the guess is."))\r
 315 (register-generic 'parser)\r
 316 \r
 317 (defgeneric initnames (obj names)\r
 318   (:documentation "Init list of names for object"))\r
 319 (register-generic 'initnames)\r
 320 \r
 321 (defgeneric read-property (obj property &rest args)\r
 322   (:documentation "Read property of object"))\r
 323 (register-generic 'read-property)\r
 324 \r
 325 (defgeneric initflags (obj)\r
 326   (:documentation "Adds default flags for object")\r
 327   (:method-combination append :most-specific-last))\r
 328 (register-generic 'initflags)\r
 329 \r
 330 (defsyn rp read-property)\r
 331 \r
 332 (defmethod initialize-instance :after ((this abstractobject) &key)\r
 333   "Used for flag initialisation and adds object to *allobjects*"\r
 334   (setf (slot-value this 'flags) (combine-flags (initflags this)))\r
 335   (push this *allobjects*))\r
 336 \r
 337 (defmethod initflags append ((obj abstractobject))\r
 338    (declare (ignore obj))\r
 339     (list :object))\r
 340 \r
 341 (defun flag-compare (flag1 flag2)\r
 342   "Tests whether flag2 unsets flag1"\r
 343   (let ((fl1 (symbol-name flag1))\r
 344         (fl2 (symbol-name flag2)))\r
 345     (and (char= (aref fl2 0) #\~) (string= fl1 fl2 :start2 1))))\r
 346 \r
 347 (defun combine-flags (flaglist)\r
 348   "Combine a list of flags into a _set_ of flags"\r
 349   (loop for fl in flaglist\r
 350         if (char= (aref (symbol-name fl) 0) #\~) \r
 351            do (setq set (nset-difference set (list fl) :test #'flag-compare))\r
 352         else collect fl into set\r
 353         finally (return set)))\r
 354 \r
 355 (defun add-flags (obj &rest flags)\r
 356   "Add some flags to object"\r
 357   (setf (flags obj) (combine-flags (append (flags obj) flags)))) \r
 358 \r
 359 (defun give (obj &rest flags) \r
 360   "Informish synonim to add-flags." \r
 361   (setf (flags obj) (combine-flags (append (flags obj) flags)))  nil)\r
 362 \r
 363 (defun has (obj &rest flags)\r
 364   "Informish macro has. Unlike Inform, can accept several flags."\r
 365   (subsetp flags (flags obj)))\r
 366 \r
 367 (defun hasnt (obj &rest flags)\r
 368   "Informish macro hasnt. Unlike Inform, can accept several flags."\r
 369   (not (intersection flags (flags obj))))\r
 370   ;(not (subsetp flags (flags obj))))\r
 371 \r
 372 (defun child (obj)\r
 373   "Returns the first child of the object"\r
 374   (car (children obj)))\r
 375 \r
 376 (defmethod parser ((obj abstractobject) words) \r
 377   "Default parser. Really bad one."\r
 378   (when (zerop (length words)) (return-from parser 0))\r
 379   (let ((words1 (remove-duplicates words)))\r
 380     (/ (loop \r
 381         for word in words\r
 382         counting (member word (names obj)))\r
 383        (length words1))))\r
 384 \r
 385 (defmethod initnames ((obj abstractobject) names)\r
 386   "Initialise names for object"\r
 387   (setf (slot-value obj 'names) \r
 388         (remove-duplicates (mapcar #'addword2dic names))))\r
 389 \r
 390 (defun add-names (obj names)\r
 391   "Add new names to object"\r
 392   (initnames obj (remove-duplicates \r
 393                   (append (names obj) (mapcar #'addword2dic names)))))\r
 394 \r
 395 ;;SECTION 6: read-property bonanza \r
 396 ;;\r
 397 ;;This is an ugly, repetitive mass of code dealing with typing and\r
 398 ;;coercion of types. I am very unhappy with this read-property thing\r
 399 ;;which makes other code very un-elegant. However without these type\r
 400 ;;coersions many Inform features would be impossible to reproduce.\r
 401 \r
 402 (defun eval-err (value type)\r
 403   (error "~S cannot be evaluated as ~a." value type))\r
 404 \r
 405 (defun read-property-string (value &rest args)\r
 406   (cond ((stringp value) value)\r
 407         ((not value) "")\r
 408         ((functionp value) \r
 409          (let ((res (apply value args)))\r
 410            (read-property-string res args))) \r
 411         ((numberp value) (format nil "~a" value))\r
 412         ((and (typep value 'abstractobject)\r
 413               (slot-exists-p value 'name)\r
 414               (stringp (name value))) (name value))\r
 415         (t (eval-err value "string"))))\r
 416 \r
 417 (defun read-property-number (value &rest args)\r
 418   (cond ((numberp value) value)\r
 419         ((not value) 0)\r
 420         ((functionp value) \r
 421          (let ((res (apply value args)))\r
 422            (read-property-number res args)))    \r
 423         (t (eval-err value "number"))))\r
 424 \r
 425 (defun read-property-integer (value &rest args)\r
 426   (cond ((integerp value) value)\r
 427         ((not value) 0)\r
 428         ((functionp value) \r
 429          (let ((res (apply value args)))\r
 430            (read-property-integer res args)))   \r
 431         ((stringp value) (parse-integer value :junk-allowed t))\r
 432         (t (eval-err value "integer"))))\r
 433   \r
 434 (defun read-property-object (value &rest args)\r
 435   (cond ((typep value 'abstractobject) value)\r
 436         ((not value) nil) \r
 437         ((functionp value)\r
 438          (let ((res (apply value args)))\r
 439            (read-property-object res args)))\r
 440         ((symbolp value)\r
 441          (let ((res (symbol-value value)))\r
 442            (read-property-object res args)))\r
 443         ((stringp value) (sprint "~a~%" value) (values value t))\r
 444         (t (eval-err value "object"))))\r
 445 \r
 446 (defmacro exec (func (&rest args) &key str)\r
 447   (with-gen-syms (tmp)\r
 448     `(let ((,tmp (apply #',func (list ,@args))))\r
 449       ,(unless str \r
 450                `(when (stringp ,tmp) (sprint ,tmp) (newline *outstream*)))\r
 451       (values ,tmp t))))\r
 452 \r
 453 (defun exec* (func args &key str)\r
 454   (let ((args (if (listp args) args (list args))))\r
 455   (let ((tmp (apply func args)))\r
 456     (unless str (when (stringp tmp) (sprint tmp) (newline *outstream*)))\r
 457     (values tmp t))))\r
 458 \r
 459 (defun read-property-execute (value &rest args)\r
 460   (cond ((functionp value) (exec* value args))\r
 461         ((not value) nil)\r
 462         ((stringp value) (sprint "~a~%" value) (values value t))\r
 463         (t value)))\r
 464 \r
 465 (defun read-property-list (value &rest args)\r
 466   (cond ((listp value) value)\r
 467         ((functionp value)\r
 468          (let ((res (apply value args)))\r
 469            (if (listp res) res (list res))))\r
 470         (t (list value))))\r
 471 \r
 472 (defun read-property-other (value &rest args)\r
 473   (declare (ignore args)) value)\r
 474 \r
 475 (defmethod read-property ((self abstractobject) property &rest args)\r
 476   "default read-property"\r
 477   (case property\r
 478     (name (apply #'read-property-string (slot-value self property) args))\r
 479     (description (apply #'read-property-string (slot-value self property) args))\r
 480     (article (apply #'read-property-string (slot-value self property) args))\r
 481     (glance (apply #'read-property-string (slot-value self property) args))\r
 482     (t (slot-value self property))))\r
 483 \r
 484 (defun read-property- (method self property &rest args)\r
 485   "read-property using specific method. method is one of keywords:\r
 486    :string :number :object :integer :execute :list"\r
 487   (case method\r
 488     (:string (apply #'read-property-string (slot-value self property) args))\r
 489     (:number (apply #'read-property-number (slot-value self property) args))\r
 490     (:integer (apply #'read-property-integer (slot-value self property) args))\r
 491     (:object (apply #'read-property-object (slot-value self property) args))\r
 492     (:execute (apply #'read-property-execute (slot-value self property) args))\r
 493     (:list (apply #'read-property-list (slot-value self property) args))\r
 494     (t (slot-value self property))))\r
 495 \r
 496 ;;SECTION 7: IfClass macro and its hairy surroundings\r
 497 \r
 498 (defun type-keywordp (obj)\r
 499   "Defines a list of type keywords which are used for property declarations"\r
 500   (and (symbolp obj)\r
 501        (cdr (assoc (symbol-name obj) \r
 502                    (mapcar #'(lambda (s) (cons (symbol-name s) s)) \r
 503                            '(string number integer object function))))))      \r
 504 \r
 505 (defun parse-prop (prop)\r
 506   "Parsing individual property"\r
 507   (let* ((p1 (first prop))\r
 508         (p2 (second prop))\r
 509         (p3 (third prop))\r
 510         (p4 (fourth prop))\r
 511         (ggg (type-keywordp p2)))\r
 512     (case (length prop)\r
 513       (1 (list p1 nil nil))\r
 514       (2 (if ggg (list p1 ggg) (list p1 nil p2)))\r
 515       (3 (if ggg (list p1 ggg p3) (list p1 nil p2 p3)))\r
 516       (4 (list p1 p2 p3 p4)))))\r
 517 \r
 518 (defun prop-process1 (name type &optional initform (documentation ""))\r
 519   "Macro helper function"\r
 520   (unless initform \r
 521     (setf initform (case type \r
 522                      (string "")\r
 523                      (number 0)\r
 524                      (integer 0)\r
 525                      (object nil)\r
 526                      (function nil)\r
 527                      (list nil)\r
 528                      (t nil))))\r
 529   `(,name :initarg ,(as-keyword name) :accessor ,name :initform ,initform\r
 530     :documentation ,documentation))\r
 531 \r
 532 (defun prop-process2 (name type &rest stuff)\r
 533   "Macro helper function"\r
 534   (declare (ignore stuff))\r
 535   (unless type (return-from prop-process2 nil))\r
 536   `((,name) (apply \r
 537              ,(case type\r
 538                     (string #'read-property-string)\r
 539                     (number #'read-property-number)\r
 540                     (integer #'read-property-integer)\r
 541                     (object #'read-property-object)\r
 542                     (function #'read-property-execute)\r
 543                     (list #'read-property-list)\r
 544                     (t #'read-property-other))\r
 545              (slot-value self property) args)))\r
 546 \r
 547 (defmacro declare-rule (&rest args)\r
 548   "Declare new rules"\r
 549   `(progn \r
 550      ,@(loop for x in args\r
 551           collect `(pushnew ',x *rules*)\r
 552           collect `(defgeneric ,x (obj)\r
 553                      (:method-combination or)\r
 554                      (:method or (obj) (declare (ignore obj)) nil))\r
 555           collect `(register-generic (quote ,x)))))    \r
 556                        \r
 557 (defmacro declare-predicate (&rest args)\r
 558   "Declare new predicates"\r
 559   `(progn\r
 560      ,@(loop for x in args\r
 561           collect `(pushnew ',x *predicates*)\r
 562           collect `(defgeneric ,x (obj &optional what)\r
 563                      (:method (obj &optional what) \r
 564                        (declare (ignore obj what)) nil))\r
 565           collect `(register-generic (quote ,x)))))\r
 566 \r
 567 (declare-rule before after react-before react-after)\r
 568 \r
 569 (defun generate-rules (name rules)\r
 570   "Generates rules for a class"\r
 571   (let (result)\r
 572     (dolist (r *rules* result)\r
 573       (let ((rul (cdr (assoc r rules))))\r
 574         (when rul (push `(defmethod ,r or ((self ,name))\r
 575                            (declare (ignorable self))\r
 576                            (case *action* ,@rul)) result))))))\r
 577     \r
 578 (defun generate-predicates (name predicates)\r
 579   "Generates predicates for a class"\r
 580   (let (result)\r
 581     (dolist (p *predicates* result)\r
 582       (let ((pred (cdr (assoc p predicates))))\r
 583         (when pred\r
 584           (destructuring-bind (what . stuff) pred\r
 585             (flet ((pfun (pred &key (terminate nil))\r
 586                      (destructuring-bind (what . stuff) pred\r
 587                        (if (listp what)\r
 588                            (let ((w (car what)))\r
 589                              (with-gen-syms (x)\r
 590                                `(defmethod ,p ((self ,name) &optional ,w)\r
 591                                   (declare (ignorable self ,w))\r
 592                                   (unless ,w \r
 593                                     (return-from ,p\r
 594                                       (loop for ,x in *allobjects*\r
 595                                          when (,p self ,x)\r
 596                                          collect ,x)))\r
 597                                   (or (progn ,@stuff) \r
 598                                       ,(unless terminate \r
 599                                                `(call-next-method))))))\r
 600                            (with-gen-syms (x) \r
 601                              `(defmethod ,p ((self ,name) &optional ,x)\r
 602                                 (declare (ignorable self))\r
 603                                 (unless ,x (return-from ,p (list ,@pred)))\r
 604                                 (or (member ,x (list ,@pred)) \r
 605                                     ,(unless terminate \r
 606                                              `(call-next-method)))))))))\r
 607               (push (if (eql what :only) \r
 608                         (pfun stuff :terminate t)\r
 609                         (pfun pred)) result))))))))\r
 610                                    \r
 611                \r
 612 \r
 613 (defmacro ifclass (name (&rest classes) &rest options)\r
 614   "Macro for generating IF classes"\r
 615   (let (rules predicates)\r
 616   (multiple-value-bind (proplist flaglist)\r
 617       (loop for opt in options\r
 618             for word = (car opt)\r
 619             if (eql word 'has) collect opt into fllist\r
 620             else if (member word *rules*) \r
 621                     do (pushnew (cons word (cdr opt)) rules \r
 622                                 :test (lambda (a b) (eql (car a) (car b))))\r
 623             else if (member word *predicates*)\r
 624                     do (pushnew (cons word (cdr opt)) predicates\r
 625                                 :test (lambda (a b) (eql (car a) (car b))))\r
 626             else collect opt into prlist\r
 627             finally (return (values prlist fllist)))\r
 628     `(progn\r
 629       ;;(declare (ignorable self))\r
 630       (defclass ,name ,(or classes '(abstractobject))\r
 631         ,(loop for prop in proplist\r
 632                when (apply #'prop-process1 (parse-prop prop)) collect it))\r
 633       (defmethod read-property ((self ,name) property &rest args)\r
 634         (declare (ignorable args))\r
 635         (case property\r
 636           ,@(loop for prop in proplist \r
 637                   when (apply #'prop-process2 (parse-prop prop)) collect it)\r
 638           (t (call-next-method))))\r
 639       (handler-bind ((warning #'ignore-warning))\r
 640       (defmethod initflags append ((obj ,name))\r
 641         (declare (ignore obj))\r
 642         (list ,@(loop for fl in flaglist appending (cdr fl))))\r
 643       ,@(generate-rules name rules)\r
 644       ,@(generate-predicates name predicates)))))) \r
 645 \r
 646 (defun ofclass (obj class)\r
 647   "Better name for typep"\r
 648   (typep obj class))\r
 649 \r
 650 ;;SECTION 8: Object macro and some related functions\r
 651 \r
 652 (defmacro object (intname (&rest classes) &rest options)\r
 653   "Macro for creating objects"\r
 654   (multiple-value-bind (extname parent namelist proplist flaglist)\r
 655       (loop with extname = ""\r
 656             with parent = nil\r
 657             for word = nil\r
 658             for opt in options\r
 659             if (listp opt) do (setq word (car opt))\r
 660             else if (stringp opt) do (setq extname opt)\r
 661                  else do (setq parent opt)\r
 662             if word\r
 663                if (eql word 'has) collect opt into fllist\r
 664                else if (eql word 'name) collect opt into nmlist\r
 665                else collect opt into prlist\r
 666             finally (return (values extname parent nmlist prlist fllist)))\r
 667     (let (listwords) \r
 668       (unless (or namelist (endp (setq listwords (split-to-words extname))))\r
 669         (setf namelist `((name ,@listwords)))))\r
 670     (with-gen-syms (this) ;other)\r
 671     `(progn \r
 672       (defvar ,intname)\r
 673       (ifclass ,intname ,classes ,@proplist ,@flaglist)\r
 674       (defmethod initialize-instance :after ((,this ,intname) &key)\r
 675         (setf (slot-value ,this 'name) ,extname)\r
 676         (initnames ,this ',(loop for nm in namelist appending (cdr nm)))\r
 677         (move ,this ,parent))\r
 678       ,(when (boundp intname)\r
 679              `(setf *allobjects* (remove ,intname *allobjects*)))\r
 680       (defparameter ,intname (make-instance ',intname))))))\r
 681 \r
 682 (defun move (obj1 obj2)\r
 683   "Move one object inside another"\r
 684   (let (objt)\r
 685     (when (setf objt (parent obj1))\r
 686       (setf (slot-value objt 'children) \r
 687             (remove obj1 (slot-value objt 'children)))\r
 688       (setf (slot-value obj1 'parent) nil))\r
 689     (when obj2\r
 690       (pushnew obj1 (slot-value obj2 'children))\r
 691       (setf (slot-value obj1 'parent) obj2))))\r
 692 \r
 693 (defun rmv (obj1)\r
 694   "Move object to top-level"\r
 695   (move obj1 nil))\r
 696 \r
 697 (defun in (obj1 &rest what)\r
 698   "Tests whether the first object is inside some of the others"\r
 699   (some (lambda (x) (eql (parent obj1) x)) what))\r
 700 \r
 701 (defun destroy (obj)\r
 702   "Destroy the object, like, totally!"\r
 703   (setf *allobjects* (remove obj *allobjects*))\r
 704   (rmv obj))\r
 705 \r
 706 (defmacro defaction (name (&rest args) &body body)\r
 707   "Creates a new action"\r
 708   (let ((doc (car body)) (body2 (cdr body)))\r
 709     (unless (and (stringp doc) body2)  (setf doc "") (setf body2 body))\r
 710     `(progn \r
 711        (defgeneric ,name ,args\r
 712          (:documentation ,doc)\r
 713          (:method ,args (declare (ignorable ,@args)) ,@body2))\r
 714        (register-generic (quote ,name)))))    \r
 715 \r
 716 (defmacro objectloop ((&whole alltest iter &rest test) &body body)\r
 717   "Iterates over objects satisfying test. Use !last! as an indicator\r
 718    that the loop is reaching its end"\r
 719   (with-gen-syms (iterlist lastone)\r
 720     (if test\r
 721         (let ((iterator (first test)))\r
 722           `(let ((,iterlist\r
 723                   (case ',iter\r
 724                     (eql (list ,(second test)))\r
 725                     (in (children ,(second test)))\r
 726                     (member ,(second test))\r
 727                     (t (remove-if \r
 728                         #'(lambda (,iterator) (not ,alltest)) *allobjects*)))))\r
 729             (let ((,lastone (car (last ,iterlist))))\r
 730               (dolist (,iterator ,iterlist) \r
 731                 (let ((!last! (eql ,iterator ,lastone)))\r
 732                   (declare (ignorable !last!))\r
 733                   ,@body)))))\r
 734         `(dolist (,iter *allobjects*) ,@body))))\r
 735 \r
 736 (defun provides (obj slot)\r
 737   "Tests whether an object has a given property"\r
 738   (slot-exists-p obj slot))\r
 739 \r
 740 (defun among (obj &rest what)\r
 741   "Tests whether obj is among other arguments"\r
 742   (member obj what))\r
 743 \r
 744 (defun notin (obj &rest what)\r
 745   "Test whether the object is not in any of other arguments"\r
 746   (notany (lambda (x) (eql (parent obj) x)) what))\r
 747 \r
 748 (defun below (obj1 obj2)\r
 749   "Tests whether obj1 is strictly below obj2 in object structure"\r
 750   (loop for x = obj1 then (parent x)\r
 751         while x\r
 752         when (eql x obj2) do (return t)\r
 753         finally (return nil)))\r
 754 \r
 755 ;;SECTION 9: Verb functions\r
 756 \r
 757 (defstruct patternlist value)\r
 758 \r
 759 (defun add-to-end (plist value)\r
 760   "Add pattern to the end of patternlist"\r
 761   (setf (patternlist-value plist)\r
 762         (append (patternlist-value plist) \r
 763                 (if (listp value) value (list value)))))\r
 764 \r
 765 (defun add-to-start (plist value)\r
 766   "Add pattern to the beginning of patternlist"\r
 767   (setf (patternlist-value plist)\r
 768         (append (if (listp value) value (list value)) \r
 769                 (patternlist-value plist))))\r
 770 \r
 771 (defun add-verb-pattern (verb plist)\r
 772   "Associate verb and patternlist"\r
 773   (setf (gethash verb *verbs*) plist))\r
 774 \r
 775 (defun extend-verb-pattern (verb pattern)\r
 776   "Add pattern to the end of verb's patternlist"\r
 777   (add-to-end (gethash verb *verbs*) pattern))\r
 778 \r
 779 (defun extend-verb-pattern-first (verb pattern)\r
 780   "Add pattern to the beginning of verb's patternlist"\r
 781   (add-to-start (gethash verb *verbs*) pattern))\r
 782 \r
 783 (defun verb (&rest args)\r
 784   "Create new verb"\r
 785   (multiple-value-bind (namelist pattern)\r
 786       (loop for cons on args\r
 787             unless (stringp (car cons)) \r
 788             return (values (ldiff args cons) cons))\r
 789     (let ((newpattern (make-patternlist :value pattern)))\r
 790       (mapcar #'(lambda (name) \r
 791                   (add-verb-pattern (addword2dic name) newpattern))\r
 792               namelist))))\r
 793 \r
 794 (defun extend-verb (name &rest pattern)\r
 795   "Extend already existing verb"\r
 796   (extend-verb-pattern (word2dic name) pattern))\r
 797 \r
 798 (defun extend-verb-first (name &rest pattern)\r
 799   "Extend verb, by adding new pattern to the beginning"\r
 800   (extend-verb-pattern-first (word2dic name) pattern))\r
 801 \r
 802 (defun extend-verb-only (&rest args)\r
 803   "Provide additional patterns only for some synonims"\r
 804   (multiple-value-bind (namelist pattern)\r
 805       (loop for cons on args\r
 806             unless (stringp (car cons)) \r
 807             return (values (ldiff args cons) cons))\r
 808     (let* ((name (car namelist))\r
 809            (dicname (word2dic name))\r
 810            (patt (make-patternlist \r
 811                   :value (patternlist-value (gethash dicname *verbs*)))))\r
 812       (mapcar #'(lambda (name) \r
 813                   (add-verb-pattern (addword2dic name) patt))\r
 814               namelist)\r
 815       (extend-verb-pattern dicname pattern))))\r
 816 \r
 817 (defun extend-verb-only-first (&rest args)\r
 818   "Provide additional patterns for specified synonims to the beginning"\r
 819   (multiple-value-bind (namelist pattern)\r
 820       (loop for cons on args\r
 821             unless (stringp (car cons)) \r
 822             return (values (ldiff args cons) cons))\r
 823     (let* ((name (car namelist))\r
 824            (dicname (word2dic name))\r
 825            (patt (make-patternlist \r
 826                   :value (patternlist-value (gethash dicname *verbs*)))))\r
 827       (mapcar #'(lambda (name) \r
 828                   (add-verb-pattern (addword2dic name) patt))\r
 829               namelist)\r
 830       (extend-verb-pattern-first dicname pattern))))\r
 831 \r
 832 ;;SECTION 10: pattern matching\r
 833 ;;\r
 834 ;;The pattern has the following format:\r
 835 ;;(...list of tokens... -> ACTION ORDER)\r
 836 ;;ACTION - name of action (no action by default)\r
 837 ;;ORDER - function that given a list shuffles it according to required order \r
 838 ;; (id by default)\r
 839 \r
 840   \r
 841 (defun parse-pattern (pattern)\r
 842   "Splits pattern into it's core parts"\r
 843   (loop for p on pattern\r
 844         if (eql (car p) '->) \r
 845            return (values (ldiff pattern p) \r
 846                           (second p) (third p)) \r
 847         finally (return (values pattern nil nil))))   \r
 848 \r
 849 (defmacro deftoken (name &body body)\r
 850   "The body should contain a function that, given wordlist and tokenlist\r
 851    returns state of success, the result and remaining words. Each token \r
 852    consumes one arg but can use every remaining one for additional\r
 853    information (e.g. :multiinside can see the next tokens to determine\r
 854    whether an object is inside another object"\r
 855   `(setf (gethash ,name *tokens*)\r
 856     #'(lambda (wordlist tokenlist)\r
 857         (declare (ignorable wordlist tokenlist))\r
 858         ,@body)))\r
 859 \r
 860 (defun string== (str1 str2)\r
 861   "Case-insensitive string="\r
 862   (string= (string-downcase str1) (string-downcase str2)))\r
 863 \r
 864 (defun shuffle (list order)\r
 865   "Shuffle given list according to the order specified"\r
 866   (if order (funcall order list) list))\r
 867 \r
 868 (defun matchp (words pattern &aux arglist) \r
 869   "Matches string against pattern and returns action and args on success"\r
 870   (multiple-value-bind (tokenlist action order) (parse-pattern pattern)\r
 871     (loop named mainloop\r
 872           for tokens on tokenlist\r
 873           for token = (car tokens)\r
 874           when (stringp token)\r
 875                do (when (loop with spl = (split-to-words token)\r
 876                               while (and words spl \r
 877                                          (string== (car words) (car spl)))\r
 878                               do (pop words) (pop spl)\r
 879                               finally (return spl))\r
 880                     (return-from mainloop nil))\r
 881           else when (listp token) \r
 882                do (let* ((tokenfun (gethash (first token) *tokens*))\r
 883                          (tpar (second token))\r
 884                          (tparall (cdr token))\r
 885                          (*tokenpar* (if (functionp tpar) \r
 886                                          (apply tpar (cdr tparall)) tparall)))\r
 887                     (declare (ignorable *tokenpar*))\r
 888                     (unless tokenfun (return-from mainloop nil))\r
 889                     (multiple-value-bind (success result remwords)\r
 890                         (funcall tokenfun words tokens)\r
 891                       (unless success (return-from mainloop nil))\r
 892                       (when result (push result arglist))\r
 893                       (setf words remwords)))\r
 894           else do (let ((tokenfun (gethash token *tokens*)))\r
 895                     (unless tokenfun (return-from mainloop nil))\r
 896                     (multiple-value-bind (success result remwords)\r
 897                         (funcall tokenfun words tokens)\r
 898                       (unless success (return-from mainloop nil))\r
 899                       (push result arglist)\r
 900                       (setf words remwords)))\r
 901           finally (if (endp words) \r
 902                       (return-from mainloop \r
 903                         (values action \r
 904                                 (shuffle (reverse arglist) order))) \r
 905                       (return-from mainloop nil)))))\r
 906 \r
 907 \r
 908 ;;SECTION 11: Core functionality & commands parsing\r
 909 \r
 910 \r
 911 (defmacro supply (name args &body body)\r
 912   "Supply a method to be used instead of default. Equivalent of\r
 913   Inform's stub functions."\r
 914   `(defmethod ,name :around ,args ,@body))\r
 915 \r
 916 (defmacro defstub (name args &body body)\r
 917   "Make a stub generic function, supply target"  \r
 918   (let ((docstring "") (otherbody body))\r
 919     (when (and (cdr body) (stringp (car body)) \r
 920       (setf docstring (car body))\r
 921       (setf otherbody (cdr body)))\r
 922     `(progn\r
 923        (defgeneric ,name ,args\r
 924          (:documentation ,docstring)\r
 925          (:method ,args ,@otherbody))\r
 926        (register-stub (function ,name) (quote ,args))))))\r
 927 \r
 928 \r
 929 (defstub unknown-verb (word)\r
 930   "Display error message for unknown verb"\r
 931   (format nil "No such verb: \"~a\"" word))\r
 932 \r
 933 ;(defgeneric turn-passing (&optional time)\r
 934 ;  (:documentation "Called at the end of turn")\r
 935 ;  (:method (&optional time) (declare (ignore time))))\r
 936 \r
 937 (defstub turn-passing (&optional time)\r
 938   "Called at the end of turn"\r
 939   (declare (ignore time)) nil)\r
 940 \r
 941 (defstub before-hook ()\r
 942   "Used for special before rules set up by iflib.lisp"\r
 943   nil)\r
 944 \r
 945 (defstub after-hook ()\r
 946   "Used for special after rules set up by if.lisp"\r
 947   nil)\r
 948 \r
 949 (defun run-action-after (obj)\r
 950   "Run after actions, if appropriate"\r
 951   (setf *after* t)\r
 952   (when (exec after-hook nil) \r
 953     (setf *after* nil) \r
 954     (return-from run-action-after nil))\r
 955   (when (and *args* (exec* #'after obj))\r
 956     (setf *after* nil)\r
 957     (return-from run-action-after nil))\r
 958   ;;React after?\r
 959   t)\r
 960 \r
 961 (defun run-action (action args &key (time 0) no-output)\r
 962   "Run an action with a given args"\r
 963   (unless (listp args) (setf args (list args)))\r
 964   (setf *after* nil)\r
 965   (let ((*action* action)\r
 966         (*args* args)\r
 967         (*noun* (first args))\r
 968         (*second* (second args))\r
 969         (*no-output* no-output))\r
 970     (when *debug* \r
 971       (format t "[running action: ~a ~a]~%" *action* *args*))\r
 972     (when *meta* ;;Just do the darn thing!\r
 973       (exec* action args)\r
 974       (setf *meta* nil)\r
 975       (return-from run-action t))\r
 976     ;;Run before?\r
 977     (when (exec before-hook nil) (return-from run-action nil))\r
 978     (when (and args (exec* #'before (car args))) \r
 979       (return-from run-action nil))\r
 980     ;;Normal action\r
 981     (exec* action args)\r
 982     (unless (zerop time) (turn-passing time))\r
 983     t))\r
 984 \r
 985 (defun instead (action args &key (time 0))\r
 986   "same as run-action, but always returns t"\r
 987   (run-action action args :time time) t)\r
 988 \r
 989 (defun parse-command (string)\r
 990   "Parse command and execute appropriate action"\r
 991   (destructuring-bind (verb . words) (split-to-words string)    \r
 992     (handler-bind ((nosuchword \r
 993                     #'(lambda (condition)\r
 994                         (exec unknown-verb \r
 995                               ((nosuchword-word condition))) \r
 996                         (return-from parse-command nil))))\r
 997       (let* ((dverb (word2dic verb))\r
 998              (plist (gethash dverb *verbs*))\r
 999              (patterns (when plist (patternlist-value plist))))\r
1000         (unless plist (signal 'nosuchword :word verb))\r
1001         ;;(print words) (print patterns)\r
1002         (loop for pat in patterns\r
1003               when (multiple-value-bind (action args) (matchp words pat)\r
1004                      (when action (run-action action args :time 1) t))\r
1005               return nil\r
1006               finally (sprint "Sorry, I can't parse that.~%"))))))\r
1007                         \r
1008 \r