lisp-prolog/forward-chain.org

A Forward Chaining Inference Engine in Common Lisp

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.

The defknowledge Macro

Foo

  (defclass <knowledge> () ())

  (defvar *knowledge-classes* (list))

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

defknowledge

The defrule Macro

Foo

  (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*))))

defrule

The check-against-rule Function

Foo

  (defun check-against-rule (rule knowledge)
    (declare (type <rule> rule)
             (type <knowledge> knowledge))
    (let ((test (rule-of rule)))
      (funcall test knowledge)))

The run-rule-action Function

Foo

  (defun run-rule-action (rule k-object)
    (let ((action (rule-action rule)))
      (cond
        ((listp action))
        (:identity)
        )))

The apply-rules Function

Foo

  (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)))))

The assert-knowledge Macro

Foo

  (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))

The query Macro

Foo

  (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)))))