;;Common Lisp Interactive Fiction Library 
;;
;;if-basic-lib module: provides the core functionality - most of the critical
;;macros and functions are defined there.
;;
;;This file is a part of Lisp Interactive Fiction Project
;;
;;See license.txt for licensing information
;;
;; Table of contents: 
;;
;;           SECTION 1: General purpose macros
;;           SECTION 2: Global parameters and definitions
;;           SECTION 2a: Cleanup mechanics
;;           SECTION 3: The Pretty Printer 
;;           SECTION 4: The Dictionary
;;           SECTION 5: AbstractObject class and it's methods
;;           SECTION 6: read-property bonanza 
;;           SECTION 7: IfClass macro and its hairy surroundings
;;           SECTION 8: Object macro and some related functions
;;           SECTION 9: Verb functions
;;           SECTION 10: pattern matching
;;           SECTION 11: Core functionality & commands parsing



(in-package :cl-user)

(defpackage :if-basic-lib
  (:use :if-console :common-lisp)
  (:export :with-gen-syms :once-only :defsyn :ref
           :*space-chars* :*dictionary* :*dict-index* :*instream*
           :*outstream* :*verbs* :*tokens* :*allobjects* :*tokenpar*
           :*action* :*args* :*noun* :*second* :before :after :self
           :*after* :*debug*
           :addword :word2dic :addword2dic
           :split-to-words :sprint
           :parser :description :article :glance 
           :initnames :addnames 
           :read-property :rp :read-property- 
           :exec :exec*
           :abstractobject :name :names :parent :children :flags
           :initflags :add-flags :has :hasnt :-> :give :child
           :ifclass :object :defaction :*meta*
           :move :rmv :ofclass :among :below
           :verb :extend-verb :extend-verb-first
           :extend-verb-only :extend-verb-only-first
           :deftoken :string== :matchp :!last!
           :in :notin :objectloop :provides
           :wordlist :tokenlist
           :nosuchword :nosuchword-word
           :parse-command :unknown-verb :run-action :run-action-after
           :turn-passing :pretty-string :*textwidth* :*offset* 
           :ignore-newlines :newline :freshline :put-word :outprinc
           :destroy :supply :defstub :before-hook :after-hook
           :*rules* :*predicates* :declare-rule :declare-predicate
           :react-before :react-after :instead
	   :*cleanup* :do-cleanup :register-stub :cleanup-stub 
	   :register-generic))

(in-package :if-basic-lib)


;;SECTION 1: General purpose macros

(defmacro with-gen-syms ((&rest names) &body body)
  `(let ,(loop for n in names collect `(,n (make-symbol ,(string n))))
     ,@body))

(defmacro once-only ((&rest names) &body body)
  (let ((gensyms (loop for n in names collect (gensym (string n)))))
    `(let (,@(loop for g in gensyms collect `(,g (gensym))))
      `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
        ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
           ,@body)))))

(defun ignore-warning (condition)
   (declare (ignore condition))
   (muffle-warning))

(defun as-keyword (sym) (intern (string sym) :keyword))

(defmacro defsyn (name func)
  `(defmacro ,name (&rest args) 
    `(,',func ,@args)))

(defmacro ref (&rest names)
  "make defvars for names"
  `(progn
     ,@(loop for x in names
	    collect `(defvar ,x nil))))

;;SECTION 2: Global parameters and definitions

(defparameter *debug* t
  "When true, displays all sorts of debug messages")

(defparameter *space-chars* #(#\Space #\Newline #\Tab)
  "Characters considered to be space by split-to-words function")


(defparameter *dictionary* (make-hash-table :test #'equal)
  "The game dictionary - contains mapping from words to integers")
(defparameter *dict-index* 0
  "The index indicating how many integers were used up")

;;Streams

(defparameter *outstream* (make-instance 'terminal-out)
  "The stream where everything is output")
(defparameter *instream*  (make-instance 'terminal-in)
  "The stream which reads commands from user")

;;Uncomment these for the REPL output (don't - deprecated by repl-mode)
;(defparameter *outstream* *standard-output*)
;(defparameter *instream* *standard-input*)
  

;;Text printer parameters

(define-symbol-macro *textwidth* (textwidth *outstream*))
(define-symbol-macro *offset* (offset *outstream*))

;(defparameter *textwidth* 72)
;(defparameter *offset* 0)


(defparameter *verbs* (make-hash-table :test #'eql)
  "Contains verb syntax")
(defparameter *tokens* (make-hash-table :test #'eql)
  "Contains parser tokens")
(defparameter *allobjects* nil
  "Contains every object in the game")
(defparameter *tokenpar* :unspecified
  "Used to pass parameters to topics")
(defparameter *action* nil
  "Current action")
(defparameter *args* nil
  "Current arguments to action")
(defparameter *noun* nil
  "First argument to action")
(defparameter *second* nil
  "Second argument to action")
(defparameter *after* nil
  "Whether the run-action-after was called during the last action
 and wasn't interrupted - this is necessary for indirect action
 processing (like put-on/in and reverse)")
(defvar *rules* nil
  "List of ifclass parameters that are regarded as `rules', i.e.
  methods with action autoswitch turned on)")
(defvar *predicates* nil
  "List of ifclass parameters that are regarded as `predicates',
  i.e. properties that are either lists or functions.")

(defvar self) ;;Must be special for being usable in object definitions

(defparameter *meta* nil
  "Indicates a meta-action, which cannot be intercepted by
  in-game objects")

(defparameter *cleanup* nil
  "The list of elements of type (function . arguments), which
  describe what is needed to do before reloading the library the
  second time")

;; SECTION 2a: Cleanup mechanics

(defun do-cleanup ()
  (loop for x in *cleanup*
        do (apply (car x) (cdr x)))
  (setf *cleanup* nil))
       
(defun stub-arguments (arglist)
  "Returns a typical list of arguments for a stub"
    (loop for x in arglist
       if (consp x) collect t ;Hmmm... fishy
       else if (or (keywordp x) 
		   (member x '(&allow-other-keys &key &rest &aux &optional))) 
               collect x
       else if (symbolp x) collect t))

(defun cleanup-stub (fun args)
  (loop for x in (compute-applicable-methods fun (stub-arguments args))
        do (remove-method fun x)))
  
(defun register-stub (fun arglist)
  (push (cons #'cleanup-stub (list fun arglist)) *cleanup*))

(defun register-generic (fun)
  (push (cons #'fmakunbound (list fun)) *cleanup*))


;; SECTION 3: The Pretty Printer (well, not very pretty)

(defun newline (&optional (stream *outstream*))
  "Print a newline with printer"
  (setf *offset* 0) (terpri stream))

(defun freshline (&optional (stream *outstream*))
  "Print a fresh line with printer"
  (setf *offset* 0) (fresh-line stream))

(defun outprinc (str &optional (stream *outstream*))
  "Princ to printer"
  (princ str stream) (incf *offset* (length str)))

(defun ignore-newlines (str)
  "Remove all newlines from a given string (allows us to use Lisp multilines)"
  (let (spaceflag (countspaces 0))
    (with-output-to-string (out)
      (loop for c across str
            when (char= c #\Space) do (incf countspaces)
            else when (char= c #\Newline) do (setf spaceflag t countspaces 0)
                                             (princ #\Space out)
            else do (unless spaceflag (loop for i from 1 to countspaces
                                            do (princ #\Space out)))
                    (princ c out) (setf spaceflag nil countspaces 0))
      (loop for i from 1 to countspaces do (princ #\Space out)))))
    
(defun put-word (word stream)
  "Put a word to printer"
  (let ((wordlen (length word)))
    (if (<= (+ *offset* wordlen 1) *textwidth*)
        (progn (princ word stream) (princ #\Space stream)
               (incf *offset* (1+ wordlen)))
        (progn (newline stream) (princ word stream) 
               (princ #\Space stream)
               (incf *offset* (1+ wordlen))))))

(defun pretty-string (str stream)
  "Print a string using pretty printer"
  (let ((word (make-array 10 :adjustable t 
                          :fill-pointer 0 :element-type 'character))
        spaceflag)
    (loop for c across str
          unless (find c *space-chars*)
          do (vector-push-extend c word) (setf spaceflag nil)
          else do (unless spaceflag 
                    (put-word word stream)
                    (setf spaceflag t)
                    (when (char= c #\Newline) 
                      (setf spaceflag nil) (newline stream))
                    (adjust-array word 10 :fill-pointer 0)))
    (unless (zerop (length word)) (put-word word stream))))
          
(defun sprint (str &rest args)
  "format-like facility for printing strings with pretty printer"
  (pretty-string (apply #'format nil (ignore-newlines str) args) *outstream*)
  nil)

;;SECTION 4: The Dictionary

(defun addword (word)
  "Add a word to dictionary"
  (let ((word (string-downcase word)))
    (multiple-value-bind (num ex) (gethash word *dictionary*)
      (declare (ignore num))
      (unless ex (setf (gethash word *dictionary*) (incf *dict-index*))))))

(define-condition nosuchword (error)
  ((word :initarg :word :reader nosuchword-word))
  (:report (lambda (condition stream)
             (format stream "No such word in dictionary: ~a" 
                     (nosuchword-word condition))))
  (:documentation "No such word error"))

(defun word2dic (word)
  "Return dictionary index of a given word. Error if there is no
such word in dictionary"
  (let ((word (string-downcase word)))
    (multiple-value-bind (num ex) (gethash word *dictionary*)
      (if ex num (error 'nosuchword :word word)))))

(defun addword2dic (word)
  "Return dictionary index of a given word. If there is no such
word in dictionary, add it."
  (let ((word (string-downcase word)))
    (multiple-value-bind (num ex) (gethash word *dictionary*)
      (if ex num (setf (gethash word *dictionary*) (incf *dict-index*))))))

(defun split-to-words (string) 
  "Returns a list of words in a string"
  (assert (stringp string))
  (loop 
   with lst = nil
   with curword = ""
   for x across string
   if (find x *space-chars*) 
   do (unless (zerop (length curword)) (push curword lst))
   (setf curword "")
   else do (setf curword (format nil "~a~a" curword x))
   finally (unless (zerop (length curword)) (push curword lst))
   (return (reverse lst))))

;;SECTION 5: AbstractObject class and it's methods

(defclass abstractobject ()
  ((name :initarg :name :initform "object" :accessor name
         :documentation "Name of the object")
   (names :initform nil :reader names
          :documentation "List of dict-words for the parser")
   (parent :initarg :parent :initform nil :reader parent
           :documentation "Parent of object")
   (children :initform nil :reader children
             :documentation "Children of object")
   (flags :initarg :flags :initform nil :accessor flags
          :documentation "Flags of object"))
  (:documentation "The main IF object class, of which all other
  objects are subclasses"))

(defgeneric parser (obj words) 
  (:documentation 
   "Parser for object - returns a number between 0 and 1 indicating
   how close the guess is."))
(register-generic 'parser)

(defgeneric initnames (obj names)
  (:documentation "Init list of names for object"))
(register-generic 'initnames)

(defgeneric read-property (obj property &rest args)
  (:documentation "Read property of object"))
(register-generic 'read-property)

(defgeneric initflags (obj)
  (:documentation "Adds default flags for object")
  (:method-combination append :most-specific-last))
(register-generic 'initflags)

(defsyn rp read-property)

(defmethod initialize-instance :after ((this abstractobject) &key)
  "Used for flag initialisation and adds object to *allobjects*"
  (setf (slot-value this 'flags) (combine-flags (initflags this)))
  (push this *allobjects*))

(defmethod initflags append ((obj abstractobject))
   (declare (ignore obj))
    (list :object))

(defun flag-compare (flag1 flag2)
  "Tests whether flag2 unsets flag1"
  (let ((fl1 (symbol-name flag1))
        (fl2 (symbol-name flag2)))
    (and (char= (aref fl2 0) #\~) (string= fl1 fl2 :start2 1))))

(defun combine-flags (flaglist)
  "Combine a list of flags into a _set_ of flags"
  (loop for fl in flaglist
        if (char= (aref (symbol-name fl) 0) #\~) 
           do (setq set (nset-difference set (list fl) :test #'flag-compare))
        else collect fl into set
        finally (return set)))

(defun add-flags (obj &rest flags)
  "Add some flags to object"
  (setf (flags obj) (combine-flags (append (flags obj) flags)))) 

(defun give (obj &rest flags) 
  "Informish synonim to add-flags." 
  (setf (flags obj) (combine-flags (append (flags obj) flags)))  nil)

(defun has (obj &rest flags)
  "Informish macro has. Unlike Inform, can accept several flags."
  (subsetp flags (flags obj)))

(defun hasnt (obj &rest flags)
  "Informish macro hasnt. Unlike Inform, can accept several flags."
  (not (intersection flags (flags obj))))
  ;(not (subsetp flags (flags obj))))

(defun child (obj)
  "Returns the first child of the object"
  (car (children obj)))

(defmethod parser ((obj abstractobject) words) 
  "Default parser. Really bad one."
  (when (zerop (length words)) (return-from parser 0))
  (let ((words1 (remove-duplicates words)))
    (/ (loop 
        for word in words
        counting (member word (names obj)))
       (length words1))))

(defmethod initnames ((obj abstractobject) names)
  "Initialise names for object"
  (setf (slot-value obj 'names) 
        (remove-duplicates (mapcar #'addword2dic names))))

(defun add-names (obj names)
  "Add new names to object"
  (initnames obj (remove-duplicates 
                  (append (names obj) (mapcar #'addword2dic names)))))

;;SECTION 6: read-property bonanza 
;;
;;This is an ugly, repetitive mass of code dealing with typing and
;;coercion of types. I am very unhappy with this read-property thing
;;which makes other code very un-elegant. However without these type
;;coersions many Inform features would be impossible to reproduce.

(defun eval-err (value type)
  (error "~S cannot be evaluated as ~a." value type))

(defun read-property-string (value &rest args)
  (cond ((stringp value) value)
        ((not value) "")
        ((functionp value) 
         (let ((res (apply value args)))
           (read-property-string res args))) 
        ((numberp value) (format nil "~a" value))
        ((and (typep value 'abstractobject)
              (slot-exists-p value 'name)
              (stringp (name value))) (name value))
        (t (eval-err value "string"))))

(defun read-property-number (value &rest args)
  (cond ((numberp value) value)
        ((not value) 0)
        ((functionp value) 
         (let ((res (apply value args)))
           (read-property-number res args)))    
        (t (eval-err value "number"))))

(defun read-property-integer (value &rest args)
  (cond ((integerp value) value)
        ((not value) 0)
        ((functionp value) 
         (let ((res (apply value args)))
           (read-property-integer res args)))   
        ((stringp value) (parse-integer value :junk-allowed t))
        (t (eval-err value "integer"))))
  
(defun read-property-object (value &rest args)
  (cond ((typep value 'abstractobject) value)
        ((not value) nil) 
        ((functionp value)
         (let ((res (apply value args)))
           (read-property-object res args)))
        ((symbolp value)
         (let ((res (symbol-value value)))
           (read-property-object res args)))
        ((stringp value) (sprint "~a~%" value) (values value t))
        (t (eval-err value "object"))))

(defmacro exec (func (&rest args) &key str)
  (with-gen-syms (tmp)
    `(let ((,tmp (apply #',func (list ,@args))))
      ,(unless str 
               `(when (stringp ,tmp) (sprint ,tmp) (newline *outstream*)))
      (values ,tmp t))))

(defun exec* (func args &key str)
  (let ((args (if (listp args) args (list args))))
  (let ((tmp (apply func args)))
    (unless str (when (stringp tmp) (sprint tmp) (newline *outstream*)))
    (values tmp t))))

(defun read-property-execute (value &rest args)
  (cond ((functionp value) (exec* value args))
        ((not value) nil)
        ((stringp value) (sprint "~a~%" value) (values value t))
        (t value)))

(defun read-property-list (value &rest args)
  (cond ((listp value) value)
        ((functionp value)
         (let ((res (apply value args)))
           (if (listp res) res (list res))))
        (t (list value))))

(defun read-property-other (value &rest args)
  (declare (ignore args)) value)

(defmethod read-property ((self abstractobject) property &rest args)
  "default read-property"
  (case property
    (name (apply #'read-property-string (slot-value self property) args))
    (description (apply #'read-property-string (slot-value self property) args))
    (article (apply #'read-property-string (slot-value self property) args))
    (glance (apply #'read-property-string (slot-value self property) args))
    (t (slot-value self property))))

(defun read-property- (method self property &rest args)
  "read-property using specific method. method is one of keywords:
   :string :number :object :integer :execute :list"
  (case method
    (:string (apply #'read-property-string (slot-value self property) args))
    (:number (apply #'read-property-number (slot-value self property) args))
    (:integer (apply #'read-property-integer (slot-value self property) args))
    (:object (apply #'read-property-object (slot-value self property) args))
    (:execute (apply #'read-property-execute (slot-value self property) args))
    (:list (apply #'read-property-list (slot-value self property) args))
    (t (slot-value self property))))

;;SECTION 7: IfClass macro and its hairy surroundings

(defun type-keywordp (obj)
  "Defines a list of type keywords which are used for property declarations"
  (and (symbolp obj)
       (cdr (assoc (symbol-name obj) 
                   (mapcar #'(lambda (s) (cons (symbol-name s) s)) 
                           '(string number integer object function))))))      

(defun parse-prop (prop)
  "Parsing individual property"
  (let* ((p1 (first prop))
        (p2 (second prop))
        (p3 (third prop))
        (p4 (fourth prop))
        (ggg (type-keywordp p2)))
    (case (length prop)
      (1 (list p1 nil nil))
      (2 (if ggg (list p1 ggg) (list p1 nil p2)))
      (3 (if ggg (list p1 ggg p3) (list p1 nil p2 p3)))
      (4 (list p1 p2 p3 p4)))))

(defun prop-process1 (name type &optional initform (documentation ""))
  "Macro helper function"
  (unless initform 
    (setf initform (case type 
                     (string "")
                     (number 0)
                     (integer 0)
                     (object nil)
                     (function nil)
                     (list nil)
                     (t nil))))
  `(,name :initarg ,(as-keyword name) :accessor ,name :initform ,initform
    :documentation ,documentation))

(defun prop-process2 (name type &rest stuff)
  "Macro helper function"
  (declare (ignore stuff))
  (unless type (return-from prop-process2 nil))
  `((,name) (apply 
             ,(case type
                    (string #'read-property-string)
                    (number #'read-property-number)
                    (integer #'read-property-integer)
                    (object #'read-property-object)
                    (function #'read-property-execute)
                    (list #'read-property-list)
                    (t #'read-property-other))
             (slot-value self property) args)))

(defmacro declare-rule (&rest args)
  "Declare new rules"
  `(progn 
     ,@(loop for x in args
          collect `(pushnew ',x *rules*)
          collect `(defgeneric ,x (obj)
                     (:method-combination or)
                     (:method or (obj) (declare (ignore obj)) nil))
	  collect `(register-generic (quote ,x)))))    
                       
(defmacro declare-predicate (&rest args)
  "Declare new predicates"
  `(progn
     ,@(loop for x in args
          collect `(pushnew ',x *predicates*)
          collect `(defgeneric ,x (obj &optional what)
                     (:method (obj &optional what) 
		       (declare (ignore obj what)) nil))
	  collect `(register-generic (quote ,x)))))

(declare-rule before after react-before react-after)

(defun generate-rules (name rules)
  "Generates rules for a class"
  (let (result)
    (dolist (r *rules* result)
      (let ((rul (cdr (assoc r rules))))
        (when rul (push `(defmethod ,r or ((self ,name))
                           (declare (ignorable self))
                           (case *action* ,@rul)) result))))))
    
(defun generate-predicates (name predicates)
  "Generates predicates for a class"
  (let (result)
    (dolist (p *predicates* result)
      (let ((pred (cdr (assoc p predicates))))
        (when pred
          (destructuring-bind (what . stuff) pred
            (flet ((pfun (pred &key (terminate nil))
                     (destructuring-bind (what . stuff) pred
                       (if (listp what)
			   (let ((w (car what)))
			     (with-gen-syms (x)
			       `(defmethod ,p ((self ,name) &optional ,w)
				  (declare (ignorable self ,w))
				  (unless ,w 
				    (return-from ,p
				      (loop for ,x in *allobjects*
					 when (,p self ,x)
					 collect ,x)))
				  (or (progn ,@stuff) 
				      ,(unless terminate 
					       `(call-next-method))))))
                           (with-gen-syms (x) 
                             `(defmethod ,p ((self ,name) &optional ,x)
                                (declare (ignorable self))
				(unless ,x (return-from ,p (list ,@pred)))
                                (or (member ,x (list ,@pred)) 
                                    ,(unless terminate 
                                             `(call-next-method)))))))))
	      (push (if (eql what :only) 
			(pfun stuff :terminate t)
			(pfun pred)) result))))))))
                                   
               

(defmacro ifclass (name (&rest classes) &rest options)
  "Macro for generating IF classes"
  (let (rules predicates)
  (multiple-value-bind (proplist flaglist)
      (loop for opt in options
            for word = (car opt)
            if (eql word 'has) collect opt into fllist
            else if (member word *rules*) 
                    do (pushnew (cons word (cdr opt)) rules 
                                :test (lambda (a b) (eql (car a) (car b))))
            else if (member word *predicates*)
                    do (pushnew (cons word (cdr opt)) predicates
                                :test (lambda (a b) (eql (car a) (car b))))
            else collect opt into prlist
            finally (return (values prlist fllist)))
    `(progn
      ;;(declare (ignorable self))
      (defclass ,name ,(or classes '(abstractobject))
        ,(loop for prop in proplist
               when (apply #'prop-process1 (parse-prop prop)) collect it))
      (defmethod read-property ((self ,name) property &rest args)
        (declare (ignorable args))
        (case property
          ,@(loop for prop in proplist 
                  when (apply #'prop-process2 (parse-prop prop)) collect it)
          (t (call-next-method))))
      (handler-bind ((warning #'ignore-warning))
      (defmethod initflags append ((obj ,name))
        (declare (ignore obj))
        (list ,@(loop for fl in flaglist appending (cdr fl))))
      ,@(generate-rules name rules)
      ,@(generate-predicates name predicates)))))) 

(defun ofclass (obj class)
  "Better name for typep"
  (typep obj class))

;;SECTION 8: Object macro and some related functions

(defmacro object (intname (&rest classes) &rest options)
  "Macro for creating objects"
  (multiple-value-bind (extname parent namelist proplist flaglist)
      (loop with extname = ""
            with parent = nil
            for word = nil
            for opt in options
            if (listp opt) do (setq word (car opt))
            else if (stringp opt) do (setq extname opt)
                 else do (setq parent opt)
            if word
               if (eql word 'has) collect opt into fllist
               else if (eql word 'name) collect opt into nmlist
               else collect opt into prlist
            finally (return (values extname parent nmlist prlist fllist)))
    (let (listwords) 
      (unless (or namelist (endp (setq listwords (split-to-words extname))))
        (setf namelist `((name ,@listwords)))))
    (with-gen-syms (this) ;other)
    `(progn 
      (defvar ,intname)
      (ifclass ,intname ,classes ,@proplist ,@flaglist)
      (defmethod initialize-instance :after ((,this ,intname) &key)
        (setf (slot-value ,this 'name) ,extname)
        (initnames ,this ',(loop for nm in namelist appending (cdr nm)))
        (move ,this ,parent))
      ,(when (boundp intname)
             `(setf *allobjects* (remove ,intname *allobjects*)))
      (defparameter ,intname (make-instance ',intname))))))

(defun move (obj1 obj2)
  "Move one object inside another"
  (let (objt)
    (when (setf objt (parent obj1))
      (setf (slot-value objt 'children) 
            (remove obj1 (slot-value objt 'children)))
      (setf (slot-value obj1 'parent) nil))
    (when obj2
      (pushnew obj1 (slot-value obj2 'children))
      (setf (slot-value obj1 'parent) obj2))))

(defun rmv (obj1)
  "Move object to top-level"
  (move obj1 nil))

(defun in (obj1 &rest what)
  "Tests whether the first object is inside some of the others"
  (some (lambda (x) (eql (parent obj1) x)) what))

(defun destroy (obj)
  "Destroy the object, like, totally!"
  (setf *allobjects* (remove obj *allobjects*))
  (rmv obj))

(defmacro defaction (name (&rest args) &body body)
  "Creates a new action"
  (let ((doc (car body)) (body2 (cdr body)))
    (unless (and (stringp doc) body2)  (setf doc "") (setf body2 body))
    `(progn 
       (defgeneric ,name ,args
	 (:documentation ,doc)
	 (:method ,args (declare (ignorable ,@args)) ,@body2))
       (register-generic (quote ,name)))))    

(defmacro objectloop ((&whole alltest iter &rest test) &body body)
  "Iterates over objects satisfying test. Use !last! as an indicator
   that the loop is reaching its end"
  (with-gen-syms (iterlist lastone)
    (if test
        (let ((iterator (first test)))
          `(let ((,iterlist
                  (case ',iter
                    (eql (list ,(second test)))
                    (in (children ,(second test)))
                    (member ,(second test))
                    (t (remove-if 
                        #'(lambda (,iterator) (not ,alltest)) *allobjects*)))))
            (let ((,lastone (car (last ,iterlist))))
              (dolist (,iterator ,iterlist) 
                (let ((!last! (eql ,iterator ,lastone)))
                  (declare (ignorable !last!))
                  ,@body)))))
        `(dolist (,iter *allobjects*) ,@body))))

(defun provides (obj slot)
  "Tests whether an object has a given property"
  (slot-exists-p obj slot))

(defun among (obj &rest what)
  "Tests whether obj is among other arguments"
  (member obj what))

(defun notin (obj &rest what)
  "Test whether the object is not in any of other arguments"
  (notany (lambda (x) (eql (parent obj) x)) what))

(defun below (obj1 obj2)
  "Tests whether obj1 is strictly below obj2 in object structure"
  (loop for x = obj1 then (parent x)
        while x
        when (eql x obj2) do (return t)
        finally (return nil)))

;;SECTION 9: Verb functions

(defstruct patternlist value)

(defun add-to-end (plist value)
  "Add pattern to the end of patternlist"
  (setf (patternlist-value plist)
        (append (patternlist-value plist) 
                (if (listp value) value (list value)))))

(defun add-to-start (plist value)
  "Add pattern to the beginning of patternlist"
  (setf (patternlist-value plist)
        (append (if (listp value) value (list value)) 
                (patternlist-value plist))))

(defun add-verb-pattern (verb plist)
  "Associate verb and patternlist"
  (setf (gethash verb *verbs*) plist))

(defun extend-verb-pattern (verb pattern)
  "Add pattern to the end of verb's patternlist"
  (add-to-end (gethash verb *verbs*) pattern))

(defun extend-verb-pattern-first (verb pattern)
  "Add pattern to the beginning of verb's patternlist"
  (add-to-start (gethash verb *verbs*) pattern))

(defun verb (&rest args)
  "Create new verb"
  (multiple-value-bind (namelist pattern)
      (loop for cons on args
            unless (stringp (car cons)) 
            return (values (ldiff args cons) cons))
    (let ((newpattern (make-patternlist :value pattern)))
      (mapcar #'(lambda (name) 
                  (add-verb-pattern (addword2dic name) newpattern))
              namelist))))

(defun extend-verb (name &rest pattern)
  "Extend already existing verb"
  (extend-verb-pattern (word2dic name) pattern))

(defun extend-verb-first (name &rest pattern)
  "Extend verb, by adding new pattern to the beginning"
  (extend-verb-pattern-first (word2dic name) pattern))

(defun extend-verb-only (&rest args)
  "Provide additional patterns only for some synonims"
  (multiple-value-bind (namelist pattern)
      (loop for cons on args
            unless (stringp (car cons)) 
            return (values (ldiff args cons) cons))
    (let* ((name (car namelist))
           (dicname (word2dic name))
           (patt (make-patternlist 
                  :value (patternlist-value (gethash dicname *verbs*)))))
      (mapcar #'(lambda (name) 
                  (add-verb-pattern (addword2dic name) patt))
              namelist)
      (extend-verb-pattern dicname pattern))))

(defun extend-verb-only-first (&rest args)
  "Provide additional patterns for specified synonims to the beginning"
  (multiple-value-bind (namelist pattern)
      (loop for cons on args
            unless (stringp (car cons)) 
            return (values (ldiff args cons) cons))
    (let* ((name (car namelist))
           (dicname (word2dic name))
           (patt (make-patternlist 
                  :value (patternlist-value (gethash dicname *verbs*)))))
      (mapcar #'(lambda (name) 
                  (add-verb-pattern (addword2dic name) patt))
              namelist)
      (extend-verb-pattern-first dicname pattern))))

;;SECTION 10: pattern matching
;;
;;The pattern has the following format:
;;(...list of tokens... -> ACTION ORDER)
;;ACTION - name of action (no action by default)
;;ORDER - function that given a list shuffles it according to required order 
;; (id by default)

  
(defun parse-pattern (pattern)
  "Splits pattern into it's core parts"
  (loop for p on pattern
        if (eql (car p) '->) 
           return (values (ldiff pattern p) 
                          (second p) (third p)) 
        finally (return (values pattern nil nil))))   

(defmacro deftoken (name &body body)
  "The body should contain a function that, given wordlist and tokenlist
   returns state of success, the result and remaining words. Each token 
   consumes one arg but can use every remaining one for additional
   information (e.g. :multiinside can see the next tokens to determine
   whether an object is inside another object"
  `(setf (gethash ,name *tokens*)
    #'(lambda (wordlist tokenlist)
        (declare (ignorable wordlist tokenlist))
        ,@body)))

(defun string== (str1 str2)
  "Case-insensitive string="
  (string= (string-downcase str1) (string-downcase str2)))

(defun shuffle (list order)
  "Shuffle given list according to the order specified"
  (if order (funcall order list) list))

(defun matchp (words pattern &aux arglist) 
  "Matches string against pattern and returns action and args on success"
  (multiple-value-bind (tokenlist action order) (parse-pattern pattern)
    (loop named mainloop
          for tokens on tokenlist
          for token = (car tokens)
          when (stringp token)
               do (when (loop with spl = (split-to-words token)
                              while (and words spl 
                                         (string== (car words) (car spl)))
                              do (pop words) (pop spl)
                              finally (return spl))
                    (return-from mainloop nil))
          else when (listp token) 
               do (let* ((tokenfun (gethash (first token) *tokens*))
                         (tpar (second token))
			 (tparall (cdr token))
                         (*tokenpar* (if (functionp tpar) 
                                         (apply tpar (cdr tparall)) tparall)))
                    (declare (ignorable *tokenpar*))
                    (unless tokenfun (return-from mainloop nil))
                    (multiple-value-bind (success result remwords)
                        (funcall tokenfun words tokens)
                      (unless success (return-from mainloop nil))
                      (when result (push result arglist))
                      (setf words remwords)))
          else do (let ((tokenfun (gethash token *tokens*)))
                    (unless tokenfun (return-from mainloop nil))
                    (multiple-value-bind (success result remwords)
                        (funcall tokenfun words tokens)
                      (unless success (return-from mainloop nil))
                      (push result arglist)
                      (setf words remwords)))
          finally (if (endp words) 
                      (return-from mainloop 
                        (values action 
                                (shuffle (reverse arglist) order))) 
                      (return-from mainloop nil)))))


;;SECTION 11: Core functionality & commands parsing


(defmacro supply (name args &body body)
  "Supply a method to be used instead of default. Equivalent of
  Inform's stub functions."
  `(defmethod ,name :around ,args ,@body))

(defmacro defstub (name args &body body)
  "Make a stub generic function, supply target"  
  (let ((docstring "") (otherbody body))
    (when (and (cdr body) (stringp (car body)) 
      (setf docstring (car body))
      (setf otherbody (cdr body)))
    `(progn
       (defgeneric ,name ,args
	 (:documentation ,docstring)
	 (:method ,args ,@otherbody))
       (register-stub (function ,name) (quote ,args))))))


(defstub unknown-verb (word)
  "Display error message for unknown verb"
  (format nil "No such verb: \"~a\"" word))

;(defgeneric turn-passing (&optional time)
;  (:documentation "Called at the end of turn")
;  (:method (&optional time) (declare (ignore time))))

(defstub turn-passing (&optional time)
  "Called at the end of turn"
  (declare (ignore time)) nil)

(defstub before-hook ()
  "Used for special before rules set up by iflib.lisp"
  nil)

(defstub after-hook ()
  "Used for special after rules set up by if.lisp"
  nil)

(defun run-action-after (obj)
  "Run after actions, if appropriate"
  (setf *after* t)
  (when (exec after-hook nil) 
    (setf *after* nil) 
    (return-from run-action-after nil))
  (when (and *args* (exec* #'after obj))
    (setf *after* nil)
    (return-from run-action-after nil))
  ;;React after?
  t)

(defun run-action (action args &key (time 0) no-output)
  "Run an action with a given args"
  (unless (listp args) (setf args (list args)))
  (setf *after* nil)
  (let ((*action* action)
        (*args* args)
        (*noun* (first args))
        (*second* (second args))
        (*no-output* no-output))
    (when *debug* 
      (format t "[running action: ~a ~a]~%" *action* *args*))
    (when *meta* ;;Just do the darn thing!
      (exec* action args)
      (setf *meta* nil)
      (return-from run-action t))
    ;;Run before?
    (when (exec before-hook nil) (return-from run-action nil))
    (when (and args (exec* #'before (car args))) 
      (return-from run-action nil))
    ;;Normal action
    (exec* action args)
    (unless (zerop time) (turn-passing time))
    t))

(defun instead (action args &key (time 0))
  "same as run-action, but always returns t"
  (run-action action args :time time) t)

(defun parse-command (string)
  "Parse command and execute appropriate action"
  (destructuring-bind (verb . words) (split-to-words string)    
    (handler-bind ((nosuchword 
                    #'(lambda (condition)
                        (exec unknown-verb 
                              ((nosuchword-word condition))) 
                        (return-from parse-command nil))))
      (let* ((dverb (word2dic verb))
             (plist (gethash dverb *verbs*))
             (patterns (when plist (patternlist-value plist))))
        (unless plist (signal 'nosuchword :word verb))
        ;;(print words) (print patterns)
        (loop for pat in patterns
              when (multiple-value-bind (action args) (matchp words pat)
                     (when action (run-action action args :time 1) t))
              return nil
              finally (sprint "Sorry, I can't parse that.~%"))))))