Browse Source

Initial commit, bringing stuff over

Samuel W. Flint 8 years ago
commit
9f6500b9dd
2 changed files with 343 additions and 0 deletions
  1. 193 0
      forward-chain.org
  2. 150 0
      forward-chainer.org

+ 193 - 0
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 <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

+ 150 - 0
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
+
+  <<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*