+;;Common Lisp Interactive Fiction Library \r
+;;\r
+;;if-basic-lib module: provides the core functionality - most of the critical\r
+;;macros and functions are defined there.\r
+;;\r
+;;This file is a part of Lisp Interactive Fiction Project\r
+;;\r
+;;See license.txt for licensing information\r
+;;\r
+;; Table of contents: \r
+;;\r
+;; SECTION 1: General purpose macros\r
+;; SECTION 2: Global parameters and definitions\r
+;; SECTION 2a: Cleanup mechanics\r
+;; SECTION 3: The Pretty Printer \r
+;; SECTION 4: The Dictionary\r
+;; SECTION 5: AbstractObject class and it's methods\r
+;; SECTION 6: read-property bonanza \r
+;; SECTION 7: IfClass macro and its hairy surroundings\r
+;; SECTION 8: Object macro and some related functions\r
+;; SECTION 9: Verb functions\r
+;; SECTION 10: pattern matching\r
+;; SECTION 11: Core functionality & commands parsing\r
+\r
+\r
+\r
+(in-package :cl-user)\r
+\r
+(defpackage :if-basic-lib\r
+ (:use :if-console :common-lisp)\r
+ (:export :with-gen-syms :once-only :defsyn :ref\r
+ :*space-chars* :*dictionary* :*dict-index* :*instream*\r
+ :*outstream* :*verbs* :*tokens* :*allobjects* :*tokenpar*\r
+ :*action* :*args* :*noun* :*second* :before :after :self\r
+ :*after* :*debug*\r
+ :addword :word2dic :addword2dic\r
+ :split-to-words :sprint\r
+ :parser :description :article :glance \r
+ :initnames :addnames\r
+ :read-property :read-property-string :read-property-number\r
+ :read-property-integer :read-property-object :read-property-execute\r
+ :read-property-other :read-property-list :exec :exec*\r
+ :abstractobject :name :names :parent :children :flags\r
+ :initflags :add-flags :has :hasnt :-> :give\r
+ :ifclass :object :defaction :*meta*\r
+ :move :rmv :ofclass :among\r
+ :verb :extend-verb :extend-verb-first\r
+ :extend-verb-only :extend-verb-only-first\r
+ :deftoken :string== :matchp :!last!\r
+ :in :objectloop :provides\r
+ :wordlist :tokenlist\r
+ :nosuchword :nosuchword-word\r
+ :parse-command :unknown-verb :run-action :run-action-after\r
+ :turn-passing :pretty-string :*textwidth* :*offset* \r
+ :ignore-newlines :newline :freshline :put-word :outprinc\r
+ :destroy :supply :defstub :before-hook :after-hook\r
+ :*rules* :*predicates* :declare-rule :declare-predicate\r
+ :react-before :react-after :instead\r
+ :*cleanup* :do-cleanup :register-stub :cleanup-stub \r
+ :register-generic))\r
+\r
+(in-package :if-basic-lib)\r
+\r
+\r
+;;SECTION 1: General purpose macros\r
+\r
+(defmacro with-gen-syms ((&rest names) &body body)\r
+ `(let ,(loop for n in names collect `(,n (make-symbol ,(string n))))\r
+ ,@body))\r
+\r
+(defmacro once-only ((&rest names) &body body)\r
+ (let ((gensyms (loop for n in names collect (gensym (string n)))))\r
+ `(let (,@(loop for g in gensyms collect `(,g (gensym))))\r
+ `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))\r
+ ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))\r
+ ,@body)))))\r
+\r
+(defun ignore-warning (condition)\r
+ (declare (ignore condition))\r
+ (muffle-warning))\r
+\r
+(defun as-keyword (sym) (intern (string sym) :keyword))\r
+\r
+(defmacro defsyn (name func)\r
+ `(defmacro ,name (&rest args) \r
+ `(,',func ,@args)))\r
+\r
+(defmacro ref (&rest names)\r
+ "make defvars for names"\r
+ `(progn\r
+ ,@(loop for x in names\r
+ collect `(defvar ,x))))\r
+\r
+;;SECTION 2: Global parameters and definitions\r
+\r
+(defparameter *debug* t\r
+ "When true, displays all sorts of debug messages")\r
+\r
+(defparameter *space-chars* #(#\Space #\Newline #\Tab)\r
+ "Characters considered to be space by split-to-words function")\r
+\r
+\r
+(defparameter *dictionary* (make-hash-table :test #'equal)\r
+ "The game dictionary - contains mapping from words to integers")\r
+(defparameter *dict-index* 0\r
+ "The index indicating how many integers were used up")\r
+\r
+;;Streams\r
+\r
+(defparameter *outstream* (make-instance 'terminal-out)\r
+ "The stream where everything is output")\r
+(defparameter *instream* (make-instance 'terminal-in)\r
+ "The stream which reads commands from user")\r
+\r
+;;Uncomment these for the REPL output (don't - deprecated by repl-mode)\r
+;(defparameter *outstream* *standard-output*)\r
+;(defparameter *instream* *standard-input*)\r
+ \r
+\r
+;;Text printer parameters\r
+\r
+(define-symbol-macro *textwidth* (textwidth *outstream*))\r
+(define-symbol-macro *offset* (offset *outstream*))\r
+\r
+;(defparameter *textwidth* 72)\r
+;(defparameter *offset* 0)\r
+\r
+\r
+(defparameter *verbs* (make-hash-table :test #'eql)\r
+ "Contains verb syntax")\r
+(defparameter *tokens* (make-hash-table :test #'eql)\r
+ "Contains parser tokens")\r
+(defparameter *allobjects* nil\r
+ "Contains every object in the game")\r
+(defparameter *tokenpar* :unspecified\r
+ "Used to pass parameters to topics")\r
+(defparameter *action* nil\r
+ "Current action")\r
+(defparameter *args* nil\r
+ "Current arguments to action")\r
+(defparameter *noun* nil\r
+ "First argument to action")\r
+(defparameter *second* nil\r
+ "Second argument to action")\r
+(defparameter *after* nil\r
+ "Whether the run-action-after was called during the last action\r
+ and wasn't interrupted - this is necessary for indirect action\r
+ processing (like put-on/in and reverse)")\r
+(defvar *rules* nil\r
+ "List of ifclass parameters that are regarded as `rules', i.e.\r
+ methods with action autoswitch turned on)")\r
+(defvar *predicates* nil\r
+ "List of ifclass parameters that are regarded as `predicates',\r
+ i.e. properties that are either lists or functions.")\r
+\r
+(defvar self) ;;Must be special for being usable in object definitions\r
+\r
+(defparameter *meta* nil\r
+ "Indicates a meta-action, which cannot be intercepted by\r
+ in-game objects")\r
+\r
+(defparameter *cleanup* nil\r
+ "The list of elements of type (function . arguments), which\r
+ describe what is needed to do before reloading the library the\r
+ second time")\r
+\r
+;; SECTION 2a: Cleanup mechanics\r
+\r
+(defun do-cleanup ()\r
+ (loop for x in *cleanup*\r
+ do (apply (car x) (cdr x)))\r
+ (setf *cleanup* nil))\r
+ \r
+(defun stub-arguments (arglist)\r
+ "Returns a typical list of arguments for a stub"\r
+ (loop for x in arglist\r
+ if (consp x) collect t ;Hmmm... fishy\r
+ else if (or (keywordp x) \r
+ (member x '(&allow-other-keys &key &rest &aux &optional))) \r
+ collect x\r
+ else if (symbolp x) collect t))\r
+\r
+(defun cleanup-stub (fun args)\r
+ (loop for x in (compute-applicable-methods fun (stub-arguments args))\r
+ do (remove-method fun x)))\r
+ \r
+(defun register-stub (fun arglist)\r
+ (push (cons #'cleanup-stub (list fun arglist)) *cleanup*))\r
+\r
+(defun register-generic (fun)\r
+ (push (cons #'fmakunbound (list fun)) *cleanup*))\r
+\r
+\r
+;; SECTION 3: The Pretty Printer (well, not very pretty)\r
+\r
+(defun newline (&optional (stream *outstream*))\r
+ "Print a newline with printer"\r
+ (setf *offset* 0) (terpri stream))\r
+\r
+(defun freshline (&optional (stream *outstream*))\r
+ "Print a fresh line with printer"\r
+ (setf *offset* 0) (fresh-line stream))\r
+\r
+(defun outprinc (str &optional (stream *outstream*))\r
+ "Princ to printer"\r
+ (princ str stream) (incf *offset* (length str)))\r
+\r
+(defun ignore-newlines (str)\r
+ "Remove all newlines from a given string (allows us to use Lisp multilines)"\r
+ (let (spaceflag (countspaces 0))\r
+ (with-output-to-string (out)\r
+ (loop for c across str\r
+ when (char= c #\Space) do (incf countspaces)\r
+ else when (char= c #\Newline) do (setf spaceflag t countspaces 0)\r
+ (princ #\Space out)\r
+ else do (unless spaceflag (loop for i from 1 to countspaces\r
+ do (princ #\Space out)))\r
+ (princ c out) (setf spaceflag nil countspaces 0))\r
+ (loop for i from 1 to countspaces do (princ #\Space out)))))\r
+ \r
+(defun put-word (word stream)\r
+ "Put a word to printer"\r
+ (let ((wordlen (length word)))\r
+ (if (<= (+ *offset* wordlen 1) *textwidth*)\r
+ (progn (princ word stream) (princ #\Space stream)\r
+ (incf *offset* (1+ wordlen)))\r
+ (progn (newline stream) (princ word stream) \r
+ (princ #\Space stream)\r
+ (incf *offset* (1+ wordlen))))))\r
+\r
+(defun pretty-string (str stream)\r
+ "Print a string using pretty printer"\r
+ (let ((word (make-array 10 :adjustable t \r
+ :fill-pointer 0 :element-type 'character))\r
+ spaceflag)\r
+ (loop for c across str\r
+ unless (find c *space-chars*)\r
+ do (vector-push-extend c word) (setf spaceflag nil)\r
+ else do (unless spaceflag \r
+ (put-word word stream)\r
+ (setf spaceflag t)\r
+ (when (char= c #\Newline) \r
+ (setf spaceflag nil) (newline stream))\r
+ (adjust-array word 10 :fill-pointer 0)))\r
+ (unless (zerop (length word)) (put-word word stream))))\r
+ \r
+(defun sprint (str &rest args)\r
+ "format-like facility for printing strings with pretty printer"\r
+ (pretty-string (apply #'format nil (ignore-newlines str) args) *outstream*)\r
+ nil)\r
+\r
+;;SECTION 4: The Dictionary\r
+\r
+(defun addword (word)\r
+ "Add a word to dictionary"\r
+ (let ((word (string-downcase word)))\r
+ (multiple-value-bind (num ex) (gethash word *dictionary*)\r
+ (declare (ignore num))\r
+ (unless ex (setf (gethash word *dictionary*) (incf *dict-index*))))))\r
+\r
+(define-condition nosuchword (error)\r
+ ((word :initarg :word :reader nosuchword-word))\r
+ (:report (lambda (condition stream)\r
+ (format stream "No such word in dictionary: ~a" \r
+ (nosuchword-word condition))))\r
+ (:documentation "No such word error"))\r
+\r
+(defun word2dic (word)\r
+ "Return dictionary index of a given word. Error if there is no\r
+such word in dictionary"\r
+ (let ((word (string-downcase word)))\r
+ (multiple-value-bind (num ex) (gethash word *dictionary*)\r
+ (if ex num (error 'nosuchword :word word)))))\r
+\r
+(defun addword2dic (word)\r
+ "Return dictionary index of a given word. If there is no such\r
+word in dictionary, add it."\r
+ (let ((word (string-downcase word)))\r
+ (multiple-value-bind (num ex) (gethash word *dictionary*)\r
+ (if ex num (setf (gethash word *dictionary*) (incf *dict-index*))))))\r
+\r
+(defun split-to-words (string) \r
+ "Returns a list of words in a string"\r
+ (assert (stringp string))\r
+ (loop \r
+ with lst = nil\r
+ with curword = ""\r
+ for x across string\r
+ if (find x *space-chars*) \r
+ do (unless (zerop (length curword)) (push curword lst))\r
+ (setf curword "")\r
+ else do (setf curword (format nil "~a~a" curword x))\r
+ finally (unless (zerop (length curword)) (push curword lst))\r
+ (return (reverse lst))))\r
+\r
+;;SECTION 5: AbstractObject class and it's methods\r
+\r
+(defclass abstractobject ()\r
+ ((name :initarg :name :initform "object" :accessor name\r
+ :documentation "Name of the object")\r
+ (names :initform nil :reader names\r
+ :documentation "List of dict-words for the parser")\r
+ (parent :initarg :parent :initform nil :reader parent\r
+ :documentation "Parent of object")\r
+ (children :initform nil :reader children\r
+ :documentation "Children of object")\r
+ (flags :initarg :flags :initform nil :accessor flags\r
+ :documentation "Flags of object"))\r
+ (:documentation "The main IF object class, of which all other\r
+ objects are subclasses"))\r
+\r
+(defgeneric parser (obj words) \r
+ (:documentation \r
+ "Parser for object - returns a number between 0 and 1 indicating\r
+ how close the guess is."))\r
+(register-generic 'parser)\r
+\r
+(defgeneric initnames (obj names)\r
+ (:documentation "Init list of names for object"))\r
+(register-generic 'initnames)\r
+\r
+(defgeneric read-property (obj property &rest args)\r
+ (:documentation "Read property of object"))\r
+(register-generic 'read-property)\r
+\r
+(defgeneric initflags (obj)\r
+ (:documentation "Adds default flags for object")\r
+ (:method-combination append :most-specific-last))\r
+(register-generic 'initflags)\r
+\r
+(defsyn rp read-property)\r
+\r
+(defmethod initialize-instance :after ((this abstractobject) &key)\r
+ "Used for flag initialisation and adds object to *allobjects*"\r
+ (setf (slot-value this 'flags) (combine-flags (initflags this)))\r
+ (push this *allobjects*))\r
+\r
+(defmethod initflags append ((obj abstractobject))\r
+ (declare (ignore obj))\r
+ (list :object))\r
+\r
+(defun flag-compare (flag1 flag2)\r
+ "Tests whether flag2 unsets flag1"\r
+ (let ((fl1 (symbol-name flag1))\r
+ (fl2 (symbol-name flag2)))\r
+ (and (char= (aref fl2 0) #\~) (string= fl1 (subseq fl2 1)))))\r
+\r
+(defun combine-flags (flaglist)\r
+ "Combine a list of flags into a _set_ of flags"\r
+ (loop for fl in flaglist\r
+ if (char= (aref (symbol-name fl) 0) #\~) \r
+ do (setq set (nset-difference set (list fl) :test #'flag-compare))\r
+ else collect fl into set\r
+ finally (return set)))\r
+\r
+(defun add-flags (obj &rest flags)\r
+ "Add some flags to object"\r
+ (setf (flags obj) (combine-flags (append (flags obj) flags)))) \r
+\r
+(defun give (obj &rest flags) \r
+ "Informish synonim to add-flags." \r
+ (setf (flags obj) (combine-flags (append (flags obj) flags))))\r
+\r
+(defun has (obj &rest flags)\r
+ "Informish macro has. Unlike Inform, can accept several flags."\r
+ (subsetp flags (flags obj)))\r
+\r
+(defun hasnt (obj &rest flags)\r
+ "Informish macro hasnt. Unlike Inform, can accept several flags."\r
+ (not (intersection flags (flags obj))))\r
+ ;(not (subsetp flags (flags obj))))\r
+\r
+(defmethod parser ((obj abstractobject) words) \r
+ "Default parser. Really bad one."\r
+ (when (zerop (length words)) (return-from parser 0))\r
+ (let ((words1 (remove-duplicates words)))\r
+ (/ (loop \r
+ for word in words\r
+ counting (member word (names obj)))\r
+ (length words1))))\r
+\r
+(defmethod initnames ((obj abstractobject) names)\r
+ "Initialise names for object"\r
+ (setf (slot-value obj 'names) \r
+ (remove-duplicates (mapcar #'addword2dic names))))\r
+\r
+(defun add-names (obj names)\r
+ "Add new names to object"\r
+ (initnames obj (remove-duplicates \r
+ (append (names obj) (mapcar #'addword2dic names)))))\r
+\r
+;;SECTION 6: read-property bonanza \r
+;;\r
+;;This is an ugly, repetitive mass of code dealing with typing and\r
+;;coercion of types. I am very unhappy with this read-property thing\r
+;;which makes other code very un-elegant. However without these type\r
+;;coersions many Inform features would be impossible to reproduce.\r
+\r
+(defun eval-err (value type)\r
+ (error "~S cannot be evaluated as ~a." value type))\r
+\r
+(defun read-property-string (value &rest args)\r
+ (cond ((stringp value) value)\r
+ ((not value) "")\r
+ ((functionp value) \r
+ (let ((res (apply value args)))\r
+ (read-property-string res args))) \r
+ ((numberp value) (format nil "~a" value))\r
+ ((and (typep value 'abstractobject)\r
+ (slot-exists-p value 'name)\r
+ (stringp (name value))) (name value))\r
+ (t (eval-err value "string"))))\r
+\r
+(defun read-property-number (value &rest args)\r
+ (cond ((numberp value) value)\r
+ ((not value) 0)\r
+ ((functionp value) \r
+ (let ((res (apply value args)))\r
+ (read-property-number res args))) \r
+ (t (eval-err value "number"))))\r
+\r
+(defun read-property-integer (value &rest args)\r
+ (cond ((integerp value) value)\r
+ ((not value) 0)\r
+ ((functionp value) \r
+ (let ((res (apply value args)))\r
+ (read-property-integer res args))) \r
+ ((stringp value) (parse-integer value :junk-allowed t))\r
+ (t (eval-err value "integer"))))\r
+ \r
+(defun read-property-object (value &rest args)\r
+ (cond ((typep value 'abstractobject) value)\r
+ ((not value) nil) \r
+ ((functionp value)\r
+ (let ((res (apply value args)))\r
+ (read-property-object res args)))\r
+ ((symbolp value)\r
+ (let ((res (symbol-value value)))\r
+ (read-property-object res args)))\r
+ ((stringp value) (sprint "~a~%" value) (values value t))\r
+ (t (eval-err value "object"))))\r
+\r
+(defmacro exec (func (&rest args) &key str)\r
+ (with-gen-syms (tmp)\r
+ `(let ((,tmp (apply #',func (list ,@args))))\r
+ ,(unless str \r
+ `(when (stringp ,tmp) (sprint ,tmp) (newline *outstream*)))\r
+ (values ,tmp t))))\r
+\r
+(defun exec* (func args &key str)\r
+ (let ((args (if (listp args) args (list args))))\r
+ (let ((tmp (apply func args)))\r
+ (unless str (when (stringp tmp) (sprint tmp) (newline *outstream*)))\r
+ (values tmp t))))\r
+\r
+(defun read-property-execute (value &rest args)\r
+ (cond ((functionp value) (exec* value args))\r
+ ((not value) nil)\r
+ ((stringp value) (sprint "~a~%" value) (values value t))\r
+ (t value)))\r
+\r
+(defun read-property-list (value &rest args)\r
+ (cond ((listp value) value)\r
+ ((functionp value)\r
+ (let ((res (apply value args)))\r
+ (if (listp res) res (list res))))\r
+ (t (list value))))\r
+\r
+(defun read-property-other (value &rest args)\r
+ (declare (ignore args)) value)\r
+\r
+(defmethod read-property ((self abstractobject) property &rest args)\r
+ "default read-property"\r
+ (case property\r
+ (name (apply #'read-property-string (slot-value self property) args))\r
+ (description (apply #'read-property-string (slot-value self property) args))\r
+ (article (apply #'read-property-string (slot-value self property) args))\r
+ (glance (apply #'read-property-string (slot-value self property) args))\r
+ (t (slot-value self property))))\r
+\r
+\r
+;;SECTION 7: IfClass macro and its hairy surroundings\r
+\r
+(defun type-keywordp (obj)\r
+ "Defines a list of type keywords which are used for property declarations"\r
+ (and (symbolp obj)\r
+ (cdr (assoc (symbol-name obj) \r
+ (mapcar #'(lambda (s) (cons (symbol-name s) s)) \r
+ '(string number integer object function)))))) \r
+\r
+(defun parse-prop (prop)\r
+ "Parsing individual property"\r
+ (let* ((p1 (first prop))\r
+ (p2 (second prop))\r
+ (p3 (third prop))\r
+ (p4 (fourth prop))\r
+ (ggg (type-keywordp p2)))\r
+ (case (length prop)\r
+ (1 (list p1 nil nil))\r
+ (2 (if ggg (list p1 ggg) (list p1 nil p2)))\r
+ (3 (if ggg (list p1 ggg p3) (list p1 nil p2 p3)))\r
+ (4 (list p1 p2 p3 p4)))))\r
+\r
+(defun prop-process1 (name type &optional initform (documentation ""))\r
+ "Macro helper function"\r
+ (unless initform \r
+ (setf initform (case type \r
+ (string "")\r
+ (number 0)\r
+ (integer 0)\r
+ (object nil)\r
+ (function nil)\r
+ (list nil)\r
+ (t nil))))\r
+ `(,name :initarg ,(as-keyword name) :accessor ,name :initform ,initform\r
+ :documentation ,documentation))\r
+\r
+(defun prop-process2 (name type &rest stuff)\r
+ "Macro helper function"\r
+ (declare (ignore stuff))\r
+ (unless type (return-from prop-process2 nil))\r
+ `((,name) (apply \r
+ ,(case type\r
+ (string #'read-property-string)\r
+ (number #'read-property-number)\r
+ (integer #'read-property-integer)\r
+ (object #'read-property-object)\r
+ (function #'read-property-execute)\r
+ (list #'read-property-list)\r
+ (t #'read-property-other))\r
+ (slot-value obj property) args)))\r
+\r
+(defmacro declare-rule (&rest args)\r
+ "Declare new rules"\r
+ `(progn \r
+ ,@(loop for x in args\r
+ collect `(pushnew ',x *rules*)\r
+ collect `(defgeneric ,x (obj)\r
+ (:method-combination or)\r
+ (:method or (obj) (declare (ignore obj)) nil))\r
+ collect `(register-generic (quote ,x))))) \r
+ \r
+(defmacro declare-predicate (&rest args)\r
+ "Declare new predicates"\r
+ `(progn\r
+ ,@(loop for x in args\r
+ collect `(pushnew ',x *predicates*)\r
+ collect `(defgeneric ,x (obj &optional what)\r
+ (:method (obj &optional what) \r
+ (declare (ignore obj what)) nil))\r
+ collect `(register-generic (quote ,x)))))\r
+\r
+(declare-rule before after react-before react-after)\r
+\r
+(defun generate-rules (name rules)\r
+ "Generates rules for a class"\r
+ (let (result)\r
+ (dolist (r *rules* result)\r
+ (let ((rul (cdr (assoc r rules))))\r
+ (when rul (push `(defmethod ,r or ((self ,name))\r
+ (declare (ignorable self))\r
+ (case *action* ,@rul)) result))))))\r
+ \r
+(defun generate-predicates (name predicates)\r
+ "Generates predicates for a class"\r
+ (let (result)\r
+ (dolist (p *predicates* result)\r
+ (let ((pred (cdr (assoc p predicates))))\r
+ (when pred\r
+ (destructuring-bind (what . stuff) pred\r
+ (flet ((pfun (pred &key (terminate nil))\r
+ (destructuring-bind (what . stuff) pred\r
+ (if (listp what)\r
+ (let ((w (car what)))\r
+ (with-gen-syms (x)\r
+ `(defmethod ,p ((self ,name) &optional ,w)\r
+ (declare (ignorable self ,w))\r
+ (unless ,w \r
+ (return-from ,p\r
+ (loop for ,x in *allobjects*\r
+ when (,p self ,x)\r
+ collect ,x)))\r
+ (or (progn ,@stuff) \r
+ ,(unless terminate \r
+ `(call-next-method))))))\r
+ (with-gen-syms (x) \r
+ `(defmethod ,p ((self ,name) &optional ,x)\r
+ (declare (ignorable self))\r
+ (unless ,x (return-from ,p (list ,@pred)))\r
+ (or (member ,x (list ,@pred)) \r
+ ,(unless terminate \r
+ `(call-next-method)))))))))\r
+ (push (if (eql what :only) \r
+ (pfun stuff :terminate t)\r
+ (pfun pred)) result))))))))\r
+ \r
+ \r
+\r
+(defmacro ifclass (name (&rest classes) &rest options)\r
+ "Macro for generating IF classes"\r
+ (let (rules predicates)\r
+ (multiple-value-bind (proplist flaglist)\r
+ (loop for opt in options\r
+ for word = (car opt)\r
+ if (eql word 'has) collect opt into fllist\r
+ else if (member word *rules*) \r
+ do (pushnew (cons word (cdr opt)) rules \r
+ :test (lambda (a b) (eql (car a) (car b))))\r
+ else if (member word *predicates*)\r
+ do (pushnew (cons word (cdr opt)) predicates\r
+ :test (lambda (a b) (eql (car a) (car b))))\r
+ else collect opt into prlist\r
+ finally (return (values prlist fllist)))\r
+ `(progn\r
+ ;;(declare (ignorable self))\r
+ (defclass ,name ,(or classes '(abstractobject))\r
+ ,(loop for prop in proplist\r
+ when (apply #'prop-process1 (parse-prop prop)) collect it))\r
+ (defmethod read-property ((self ,name) property &rest args)\r
+ (declare (ignorable args))\r
+ (case property\r
+ ,@(loop for prop in proplist \r
+ when (apply #'prop-process2 (parse-prop prop)) collect it)\r
+ (t (call-next-method))))\r
+ (handler-bind ((warning #'ignore-warning))\r
+ (defmethod initflags append ((obj ,name))\r
+ (declare (ignore obj))\r
+ (list ,@(loop for fl in flaglist appending (cdr fl))))\r
+ ,@(generate-rules name rules)\r
+ ,@(generate-predicates name predicates)))))) \r
+\r
+(defun ofclass (obj class)\r
+ "Better name for typep"\r
+ (typep obj class))\r
+\r
+;;SECTION 8: Object macro and some related functions\r
+\r
+(defmacro object (intname (&rest classes) &rest options)\r
+ "Macro for creating objects"\r
+ (multiple-value-bind (extname parent namelist proplist flaglist)\r
+ (loop with extname = ""\r
+ with parent = nil\r
+ for word = nil\r
+ for opt in options\r
+ if (listp opt) do (setq word (car opt))\r
+ else if (stringp opt) do (setq extname opt)\r
+ else do (setq parent opt)\r
+ if word\r
+ if (eql word 'has) collect opt into fllist\r
+ else if (eql word 'name) collect opt into nmlist\r
+ else collect opt into prlist\r
+ finally (return (values extname parent nmlist prlist fllist)))\r
+ (let (listwords) \r
+ (unless (or namelist (endp (setq listwords (split-to-words extname))))\r
+ (setf namelist `((name ,@listwords)))))\r
+ (with-gen-syms (this) ;other)\r
+ `(progn \r
+ (defvar ,intname)\r
+ (ifclass ,intname ,classes ,@proplist ,@flaglist)\r
+ (defmethod initialize-instance :after ((,this ,intname) &key)\r
+ (setf (slot-value ,this 'name) ,extname)\r
+ (initnames ,this ',(loop for nm in namelist appending (cdr nm)))\r
+ (move ,this ,parent))\r
+ ,(when (boundp intname)\r
+ `(setf *allobjects* (remove ,intname *allobjects*)))\r
+ (defparameter ,intname (make-instance ',intname))))))\r
+\r
+(defun move (obj1 obj2)\r
+ "Move one object inside another"\r
+ (let (objt)\r
+ (when (setf objt (parent obj1))\r
+ (setf (slot-value objt 'children) \r
+ (remove obj1 (slot-value objt 'children)))\r
+ (setf (slot-value obj1 'parent) nil))\r
+ (when obj2\r
+ (pushnew obj1 (slot-value obj2 'children))\r
+ (setf (slot-value obj1 'parent) obj2))))\r
+\r
+(defun rmv (obj1)\r
+ "Move object to top-level"\r
+ (move obj1 nil))\r
+\r
+(defun in (obj1 &rest what)\r
+ "Tests whether the first object is inside some of the others"\r
+ (some (lambda (x) (eql (parent obj) x)) what))\r
+\r
+(defun destroy (obj)\r
+ "Destroy the object, like, totally!"\r
+ (setf *allobjects* (remove obj *allobjects*))\r
+ (rmv obj))\r
+\r
+(defmacro defaction (name (&rest args) &body body)\r
+ "Creates a new action"\r
+ (let ((doc (car body)) (body2 (cdr body)))\r
+ (unless (and (stringp doc) body2) (setf doc "") (setf body2 body))\r
+ `(progn \r
+ (defgeneric ,name ,args\r
+ (:documentation ,doc)\r
+ (:method ,args (declare (ignorable ,@args)) ,@body2))\r
+ (register-generic (quote ,name))))) \r
+\r
+(defmacro objectloop ((&whole alltest iter &rest test) &body body)\r
+ "Iterates over objects satisfying test. Use !last! as an indicator\r
+ that the loop is reaching its end"\r
+ (with-gen-syms (iterlist lastone)\r
+ (if test\r
+ (let ((iterator (first test)))\r
+ `(let ((,iterlist\r
+ (case ',iter\r
+ (eql (list ,(second test)))\r
+ (in (children ,(second test)))\r
+ (member ,(second test))\r
+ (t (remove-if \r
+ #'(lambda (,iterator) (not ,alltest)) *allobjects*)))))\r
+ (let ((,lastone (car (last ,iterlist))))\r
+ (dolist (,iterator ,iterlist) \r
+ (let ((!last! (eql ,iterator ,lastone)))\r
+ (declare (ignorable !last!))\r
+ ,@body)))))\r
+ `(dolist (,iter *allobjects*) ,@body))))\r
+\r
+(defun provides (obj slot)\r
+ "Tests whether an object has a given property"\r
+ (slot-exists-p obj slot))\r
+\r
+(defun among (obj &rest what)\r
+ "Tests whether obj is among other arguments"\r
+ (member obj what))\r
+\r
+(defun notin (obj &rest what)\r
+ "Test whether the object is not in any of other arguments"\r
+ (notany (lambda (x) (eql (parent obj) x)) what))\r
+ \r
+;;SECTION 9: Verb functions\r
+\r
+(defstruct patternlist value)\r
+\r
+(defun add-to-end (plist value)\r
+ "Add pattern to the end of patternlist"\r
+ (setf (patternlist-value plist)\r
+ (append (patternlist-value plist) \r
+ (if (listp value) value (list value)))))\r
+\r
+(defun add-to-start (plist value)\r
+ "Add pattern to the beginning of patternlist"\r
+ (setf (patternlist-value plist)\r
+ (append (if (listp value) value (list value)) \r
+ (patternlist-value plist))))\r
+\r
+(defun add-verb-pattern (verb plist)\r
+ "Associate verb and patternlist"\r
+ (setf (gethash verb *verbs*) plist))\r
+\r
+(defun extend-verb-pattern (verb pattern)\r
+ "Add pattern to the end of verb's patternlist"\r
+ (add-to-end (gethash verb *verbs*) pattern))\r
+\r
+(defun extend-verb-pattern-first (verb pattern)\r
+ "Add pattern to the beginning of verb's patternlist"\r
+ (add-to-start (gethash verb *verbs*) pattern))\r
+\r
+(defun verb (&rest args)\r
+ "Create new verb"\r
+ (multiple-value-bind (namelist pattern)\r
+ (loop for cons on args\r
+ unless (stringp (car cons)) \r
+ return (values (ldiff args cons) cons))\r
+ (let ((newpattern (make-patternlist :value pattern)))\r
+ (mapcar #'(lambda (name) \r
+ (add-verb-pattern (addword2dic name) newpattern))\r
+ namelist))))\r
+\r
+(defun extend-verb (name &rest pattern)\r
+ "Extend already existing verb"\r
+ (extend-verb-pattern (word2dic name) pattern))\r
+\r
+(defun extend-verb-first (name &rest pattern)\r
+ "Extend verb, by adding new pattern to the beginning"\r
+ (extend-verb-pattern-first (word2dic name) pattern))\r
+\r
+(defun extend-verb-only (&rest args)\r
+ "Provide additional patterns only for some synonims"\r
+ (multiple-value-bind (namelist pattern)\r
+ (loop for cons on args\r
+ unless (stringp (car cons)) \r
+ return (values (ldiff args cons) cons))\r
+ (let* ((name (car namelist))\r
+ (dicname (word2dic name))\r
+ (patt (make-patternlist \r
+ :value (patternlist-value (gethash dicname *verbs*)))))\r
+ (mapcar #'(lambda (name) \r
+ (add-verb-pattern (addword2dic name) patt))\r
+ namelist)\r
+ (extend-verb-pattern dicname pattern))))\r
+\r
+(defun extend-verb-only-first (&rest args)\r
+ "Provide additional patterns for specified synonims to the beginning"\r
+ (multiple-value-bind (namelist pattern)\r
+ (loop for cons on args\r
+ unless (stringp (car cons)) \r
+ return (values (ldiff args cons) cons))\r
+ (let* ((name (car namelist))\r
+ (dicname (word2dic name))\r
+ (patt (make-patternlist \r
+ :value (patternlist-value (gethash dicname *verbs*)))))\r
+ (mapcar #'(lambda (name) \r
+ (add-verb-pattern (addword2dic name) patt))\r
+ namelist)\r
+ (extend-verb-pattern-first dicname pattern))))\r
+\r
+;;SECTION 10: pattern matching\r
+;;\r
+;;The pattern has the following format:\r
+;;(...list of tokens... -> ACTION ORDER)\r
+;;ACTION - name of action (no action by default)\r
+;;ORDER - function that given a list shuffles it according to required order \r
+;; (id by default)\r
+\r
+ \r
+(defun parse-pattern (pattern)\r
+ "Splits pattern into it's core parts"\r
+ (loop for p on pattern\r
+ if (eql (car p) '->) \r
+ return (values (ldiff pattern p) \r
+ (second p) (third p)) \r
+ finally (return (values pattern nil nil)))) \r
+\r
+(defmacro deftoken (name &body body)\r
+ "The body should contain a function that, given wordlist and tokenlist\r
+ returns state of success, the result and remaining words. Each token \r
+ consumes one arg but can use every remaining one for additional\r
+ information (e.g. :multiinside can see the next tokens to determine\r
+ whether an object is inside another object"\r
+ `(setf (gethash ,name *tokens*)\r
+ #'(lambda (wordlist tokenlist)\r
+ (declare (ignorable wordlist tokenlist))\r
+ ,@body)))\r
+\r
+(defun string== (str1 str2)\r
+ "Case-insensitive string="\r
+ (string= (string-downcase str1) (string-downcase str2)))\r
+\r
+(defun shuffle (list order)\r
+ "Shuffle given list according to the order specified"\r
+ (if order (funcall order list) list))\r
+\r
+(defun matchp (words pattern &aux arglist) \r
+ "Matches string against pattern and returns action and args on success"\r
+ (multiple-value-bind (tokenlist action order) (parse-pattern pattern)\r
+ (loop named mainloop\r
+ for tokens on tokenlist\r
+ for token = (car tokens)\r
+ when (stringp token)\r
+ do (when (loop with spl = (split-to-words token)\r
+ while (and words spl \r
+ (string== (car words) (car spl)))\r
+ do (pop words) (pop spl)\r
+ finally (return spl))\r
+ (return-from mainloop nil))\r
+ else when (listp token) \r
+ do (let* ((tokenfun (gethash (first token) *tokens*))\r
+ (tpar (second token))\r
+ (tparall (cdr token))\r
+ (*tokenpar* (if (functionp tpar) \r
+ (apply tpar (cdr tparall)) tparall)))\r
+ (declare (ignorable *tokenpar*))\r
+ (unless tokenfun (return-from mainloop nil))\r
+ (multiple-value-bind (success result remwords)\r
+ (funcall tokenfun words tokens)\r
+ (unless success (return-from mainloop nil))\r
+ (when result (push result arglist))\r
+ (setf words remwords)))\r
+ else do (let ((tokenfun (gethash token *tokens*)))\r
+ (unless tokenfun (return-from mainloop nil))\r
+ (multiple-value-bind (success result remwords)\r
+ (funcall tokenfun words tokens)\r
+ (unless success (return-from mainloop nil))\r
+ (push result arglist)\r
+ (setf words remwords)))\r
+ finally (if (endp words) \r
+ (return-from mainloop \r
+ (values action \r
+ (shuffle (reverse arglist) order))) \r
+ (return-from mainloop nil)))))\r
+\r
+\r
+;;SECTION 11: Core functionality & commands parsing\r
+\r
+\r
+(defmacro supply (name args &body body)\r
+ "Supply a method to be used instead of default. Equivalent of\r
+ Inform's stub functions."\r
+ `(defmethod ,name :around ,args ,@body))\r
+\r
+(defmacro defstub (name args &body body)\r
+ "Make a stub generic function, supply target" \r
+ (let ((docstring "") (otherbody body))\r
+ (when (and (cdr body) (stringp (car body)) \r
+ (setf docstring (car body))\r
+ (setf otherbody (cdr body)))\r
+ `(progn\r
+ (defgeneric ,name ,args\r
+ (:documentation ,docstring)\r
+ (:method ,args ,@otherbody))\r
+ (register-stub (function ,name) (quote ,args))))))\r
+\r
+\r
+(defstub unknown-verb (word)\r
+ "Display error message for unknown verb"\r
+ (format nil "No such verb: \"~a\"" word))\r
+\r
+;(defgeneric turn-passing (&optional time)\r
+; (:documentation "Called at the end of turn")\r
+; (:method (&optional time) (declare (ignore time))))\r
+\r
+(defstub turn-passing (&optional time)\r
+ "Called at the end of turn"\r
+ (declare (ignore time)) nil)\r
+\r
+(defstub before-hook ()\r
+ "Used for special before rules set up by iflib.lisp"\r
+ nil)\r
+\r
+(defstub after-hook ()\r
+ "Used for special after rules set up by if.lisp"\r
+ nil)\r
+\r
+(defun run-action-after (obj)\r
+ "Run after actions, if appropriate"\r
+ (setf *after* t)\r
+ (when (exec after-hook nil) \r
+ (setf *after* nil) \r
+ (return-from run-action-after nil))\r
+ (when (and *args* (exec* #'after obj))\r
+ (setf *after* nil)\r
+ (return-from run-action-after nil))\r
+ ;;React after?\r
+ t)\r
+\r
+(defun run-action (action args &key (time 0))\r
+ "Run an action with a given args"\r
+ (unless (listp args) (setf args (list args)))\r
+ (setf *after* nil)\r
+ (let ((*action* action)\r
+ (*args* args)\r
+ (*noun* (first args))\r
+ (*second* (second args)))\r
+ (when *debug* \r
+ (format t "[running action: ~a ~a]~%" *action* *args*))\r
+ (when *meta* ;;Just do the darn thing!\r
+ (exec* action args)\r
+ (setf *meta* nil)\r
+ (return-from run-action t))\r
+ ;;Run before?\r
+ (when (exec before-hook nil) (return-from run-action nil))\r
+ (when (and args (exec* #'before (car args))) \r
+ (return-from run-action nil))\r
+ ;;Normal action\r
+ (exec* action args)\r
+ (unless (zerop time) (turn-passing time))\r
+ t))\r
+\r
+(defun instead (action args &key (time 0))\r
+ "same as run-action, but always returns t"\r
+ (run-action action args :time time) t)\r
+\r
+(defun parse-command (string)\r
+ "Parse command and execute appropriate action"\r
+ (destructuring-bind (verb . words) (split-to-words string) \r
+ (handler-bind ((nosuchword \r
+ #'(lambda (condition)\r
+ (exec unknown-verb \r
+ ((nosuchword-word condition))) \r
+ (return-from parse-command nil))))\r
+ (let* ((dverb (word2dic verb))\r
+ (plist (gethash dverb *verbs*))\r
+ (patterns (when plist (patternlist-value plist))))\r
+ (unless plist (signal 'nosuchword :word verb))\r
+ ;;(print words) (print patterns)\r
+ (loop for pat in patterns\r
+ when (multiple-value-bind (action args) (matchp words pat)\r
+ (when action (run-action action args :time 1) t))\r
+ return nil\r
+ finally (sprint "Sorry, I can't parse that.~%"))))))\r
+ \r
+\r