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.
defknowledge
Macro
Foo
(defclass <knowledge> () ()) (defvar *knowledge-classes* (list)) (defmacro defknowledge (name (&rest slots)) `(progn (defclass ,name (<knowledge>) (,@slots)) (push ',name *knowledge-classes*)))
defknowledge
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
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)))
run-rule-action
Function
Foo
(defun run-rule-action (rule k-object) (let ((action (rule-action rule))) (cond ((listp action)) (:identity) )))
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)))))
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))
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)))))