#+Title: A Forward Chaining Inference Engine in Common Lisp
#+AUTHOR: Sam Flint
#+EMAIL: swflint@flintfam.org
#+DATE: \today
#+INFOJS_OPT: view:info toc:nil path:http://flintfam.org/org-info.js
#+OPTIONS: toc:nil H:5 ':t *:t
#+PROPERTY: noweb no-export
#+PROPERTY: comments noweb
#+LATEX_HEADER: \usepackage[color]{showkeys}
#+LATEX_HEADER: \parskip=5pt
#+LATEX_HEADER: \lstset{texcl=true,breaklines=true,columns=fullflexible,frame=lines,literate={lambda}{$\lambda$}{1} {set}{$\gets$}1 {setq}{$\gets$}1 {setf}{$\gets$}1 {<=}{$\leq$}1 {>=}{$\geq$}1}

#+BEGIN_abstract
Just for kicks, I've decided to develop a forward chaining inference
engine in Common Lisp.  This will be a challenge, but I'd like to
build a free-software knowledge representation system, one that will
work well, and be able to be used for various things.
#+END_abstract

#+TOC: headlines 3
#+TOC: listings

* The =defknowledge= Macro

  Foo

#+Name: defknowledge
#+BEGIN_SRC lisp
  (defclass <knowledge> () ())

  (defvar *knowledge-classes* (list))

  (defmacro defknowledge (name (&rest slots))
    `(progn
       (defclass ,name (<knowledge>)
         (,@slots))
       (push ',name *knowledge-classes*)))
#+END_SRC

#+RESULTS: defknowledge
: defknowledge

* The =defrule= Macro

  Foo

#+Name: defrule
#+BEGIN_SRC lisp
  (defclass <rule> ()
    ((rule :initarg :rule
           :reader rule-of)
     (action-type :initarg :action-type
                  :reader action-type)
     (action :initarg :action-type
             :reader rule-action)
     (test-list :initarg :test-list
                :reader rule-tests-list)
     (on-types :initarg :on-type
              :reader rule-type)))

  (defvar *rules-base* (list))
  (defvar *rule-names* (list))

  (defun create-test-expressions-list (list)
    (iter (for element in list)
          (let ((slot-name (car element))
                (test-clause (cadr element)))
            (if (equal slot-name 'type)
                (collect `(typep object ',test-clause))
                (if (listp test-clause)
                    (let ((test (car test-clause))
                          (value (cadr test-clause)))
                      (collect `(,test (slot-value object ',slot-name) ,value)))
                    (typecase test-clause
                      (string (collect `(string= (slot-value object ',slot-name) ,test-clause)))
                      (number (collect `(= (slot-value object ',slot-name) ,test-clause)))
                      (t (collect `(eq (slot-value object ',slot-name) ,test-clause)))))))))

  (defmacro defrule (name (&rest on-types) (&rest rule) &optional (action :new-knowledge) mapping)
    (declare (ignorable action mapping))
    (let* ((tests (create-test-expressions-list rule))
           (rule-object-name (intern (concatenate 'string "RULE-" (string-upcase name))))
           (test-list (map 'list #'(lambda (x) `',x) rule))
           (type-statement `(or ,@on-types))
           (type-list (map 'list #'(lambda (x) `',x) on-types)))
      `(progn
         (defvar ,rule-object-name
           (make-instance '<rule>
                          :rule (lambda (object)
                                  (declare (type ,type-statement object))
                                  (and ,@tests))
                          :test-list (list ,@test-list)
                          :on-type (list ,@type-list)
                          :action-type ,(if (eq action :new-knowledge)
                                            `',mapping
                                            action)))
         (push ,rule-object-name *rules-base*)
         (push ',rule-object-name *rule-names*))))

#+END_SRC

#+RESULTS: defrule
: defrule

* The =check-against-rule= Function

  Foo

#+Name: check-against-rule
#+BEGIN_SRC lisp
  (defun check-against-rule (rule knowledge)
    (declare (type <rule> rule)
             (type <knowledge> knowledge))
    (let ((test (rule-of rule)))
      (funcall test knowledge)))
#+END_SRC

* The =run-rule-action= Function

  Foo

#+Name: run-rule-action
#+BEGIN_SRC lisp
  (defun run-rule-action (rule k-object)
    (let ((action (rule-action rule)))
      (cond
        ((listp action))
        (:identity)
        )))
#+END_SRC

* The =apply-rules= Function

  Foo

#+Name: apply-rules
#+BEGIN_SRC lisp
  (defun apply-rules (knowledge-object)
    (let* ((type (type-of knowledge-object))
           (possible-rules (remove-if #'(lambda (rule)
                                          (not (member type (rule-type rule))))
                                      ,*rules-base*)))
      (iter (for rule in possible-rules)
            (when (check-against-rule rule knowledge-object)
              (collect (run-rule-action rule knowledge-object) at beginning)))))
#+END_SRC

* The =assert-knowledge= Macro

  Foo

#+Name: assert-knowledge
#+BEGIN_SRC lisp
  (defvar *knowledge-base* (list))

  (defun make-knowledge-object (type slots)
    (let ((knowledge-object (make-instance type)))
      (iter (for (name value) in slots)
            (setf (slot-value knowledge-object name) value))
      knowledge-object))

  (defmacro assertion (&rest knowledge))
#+END_SRC

* The =query= Macro

  Foo

#+Name: query
#+BEGIN_SRC lisp
  (defun make-equality-check (list)
    (iter (for element in list)
          (let ((slot-name (car element))
                (test-clause (cadr element)))
            (if (equal slot-name 'type)
                (collect `(typep k-obj ',test-clause))
                (if (listp test-clause)
                    (let ((test (car test-clause))
                          (value (cadr test-clause)))
                      (collect `(,test (slot-value object ',slot-name) ,value)))
                    (typecase test-clause
                      (string (collect `(string= (slot-value k-obj ',slot-name) ,test-clause)))
                      (number (collect `(= (slot-value k-obj ',slot-name) ,test-clause)))
                      (t (collect `(eq (slot-value k-obj ',slot-name) ,test-clause)))))))))

  (defmacro query (&rest query)
    (let* ((equality-check (make-equality-check query))
           ;;(knowledge-object (make-knowledge-object class data))
           )
      `(iter (for k-obj in *knowledge-base*)
             (if (and ,@equality-check)
                 (collect k-obj)))))
#+END_SRC