commit 9f6500b9dda1260bd27817f30eb03f3f8ce91345 Author: Samuel W. Flint Date: Sun Dec 27 22:29:06 2015 -0500 Initial commit, bringing stuff over diff --git a/forward-chain.org b/forward-chain.org new file mode 100644 index 0000000000000000000000000000000000000000..7d708c288d5a847fcf9a6718593751ad53acdb2a --- /dev/null +++ b/forward-chain.org @@ -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 () ()) + + (defvar *knowledge-classes* (list)) + + (defmacro defknowledge (name (&rest slots)) + `(progn + (defclass ,name () + (,@slots)) + (push ',name *knowledge-classes*))) +#+END_SRC + +#+RESULTS: defknowledge +: defknowledge + +* The =defrule= Macro + + Foo + +#+Name: defrule +#+BEGIN_SRC lisp + (defclass () + ((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 (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) + (type 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 diff --git a/forward-chainer.org b/forward-chainer.org new file mode 100644 index 0000000000000000000000000000000000000000..77fb30835e0570ddfcef300dc2467ccc06bdcf4a --- /dev/null +++ b/forward-chainer.org @@ -0,0 +1,150 @@ +#+Title: Forward Chaining Inference with 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'm going to build a forward chaining inference system +using Common Lisp. This is going to be a challenge, but I'd like to +do it in part to expand my knowledge, and also to build a +free-software knowledge representation system that works well and is +adaptable for various purposes. +#+END_abstract + +#+TOC: headlines 3 +#+TOC: listings + +* Requirements and Package Definition + :PROPERTIES: + :ID: 2873e421-71c4-45fb-997c-0759918b72ea + :END: + + This system requires very little in the way of outside packages, + only one, in fact, ~optima~, a very high-power pattern matching + library, used to implement the matching portion of the system. + +#+Caption: Requirements and Package Definition +#+Name: package-definition +#+BEGIN_SRC lisp + (defpackage #:forward-chainer + (:use #:cl + #:optima + #:fare-quasiquote-optima + #:fare-quasiquote-readtable) + (:export #:assert-knowledge + #:assert-rule + #:query-knowledge)) + + (in-package #:forward-chainer) + (named-readtables:in-readtable :fare-quasiquote) +#+END_SRC + +* Knowledge Database + :PROPERTIES: + :ID: 5ce85cf4-4d51-4cae-a179-22cfd10fefcb + :END: + + Two of the most important parts of the forward-chainer are the + knowledge and rules database. Both of these are lists of lists, + used to provide knowledge management. + +#+Caption: Knowledge Database +#+Name: knowledge-database +#+BEGIN_SRC lisp + (defvar *knowledge-database* '() + "Knowledge Database, a list of lists.") + + (defvar *rules* '() + "Rules list, each rule is a cons of a name and a rule object.") +#+END_SRC + +* The ~assert-knowledge~ Macro + :PROPERTIES: + :ID: 93803225-516c-4162-a7b8-2ee5c8c0c28e + :END: + +#+Caption: The Assert Knowledge Macro +#+Name: assert-knowledge +#+BEGIN_SRC lisp + (defmacro assert-knowledge ((name &rest arguments)) + (let ((knowledge `'(,name ,@arguments))) + `(pushnew ,knowledge *knowledge-database* :test #'equalp))) +#+END_SRC + +* The ~remove-knowledge~ Macro + :PROPERTIES: + :ID: a5f67bbb-5639-4e6e-8260-bd84840acd76 + :END: + +#+Caption: The Remove Knowledge Macro +#+Name: remove-knowledge +#+BEGIN_SRC lisp + (defmacro remove-knowledge ((name &rest arguments)) + (let ((knowledge `'(,name ,@arguments))) + `(delete ,knowledge *knowledge-database* :test #'equalp))) +#+END_SRC + +* The ~assert-rule~ Macro + :PROPERTIES: + :ID: 13715783-de22-4fb5-be95-a2bd106fb2b3 + :END: + +#+Caption: The Assert Rule macro +#+Name: assert-rule +#+BEGIN_SRC lisp + (defmacro assert-rule ((name &rest arguments) matcher &rest actions) + (declare (ignorable name arguments matcher actions)) + ) +#+END_SRC + +* The ~query-knowledge~ Macro + :PROPERTIES: + :ID: 8172a253-0115-4bc1-9ec8-fff8873c29b5 + :END: + +#+Caption: The Query Knowledge Macro +#+Name: query-knowledge +#+BEGIN_SRC lisp + (defmacro query-knowledge ((name &rest arguments)) + (let* ((match-variables (remove-if (lambda (var) + (not (and (typep var 'symbol) (string= "?" (subseq (format nil "~a" var) 0 1))))) + arguments)) + (matcher `'(,name ,@arguments))) + `(map 'list #'(lambda (knowledge) + (match knowledge ',matcher)) + ,*knowledge-database*))) +#+END_SRC + +* Putting it together + +#+Caption: Putting things together +#+Name: put-together +#+BEGIN_SRC lisp :tangle "forward-chainer.lisp" + ;;; forward-chainer.lisp + + <> + + ;; Begin main forward-chainer + + <> + + <> + + <> + + <> + + <> + + ;;; End of "forward-chainer.lisp" +#+END_SRC + +#+RESULTS: put-together +: *RULES*