|
@@ -0,0 +1,193 @@
|
|
|
+#+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
|