Commit 9f6500b9 by Samuel W. Flint

Initial commit, bringing stuff over

parents
#+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
#+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
<<package-definition>>
;; Begin main forward-chainer
<<assert-knowledge>>
<<remove-knowledge>>
<<assert-rule>>
<<query-knowledge>>
<<knowledge-database>>
;;; End of "forward-chainer.lisp"
#+END_SRC
#+RESULTS: put-together
: *RULES*
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment