An inference engine for an expert system.
;; Forward & Backward Chaining | |
;; | |
;; Use (run *rules *goals) in CLISP to try it out. | |
;; | |
;; Written by Matthew Barber <quitesimplymatt@gmail.com> under MIT | |
;; | |
;; The MIT License (MIT) | |
;; | |
;; Copyright (c) 2019 Matthew Barber | |
;; | |
;; Permission is hereby granted, free of charge, to any person obtaining a copy | |
;; of this software and associated documentation files (the "Software"), to deal | |
;; in the Software without restriction, including without limitation the rights | |
;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell | |
;; copies of the Software, and to permit persons to whom the Software is | |
;; furnished to do so, subject to the following conditions: | |
;; The above copyright notice and this permission notice shall be included in | |
;; all copies or substantial portions of the Software. | |
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR | |
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, | |
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE | |
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER | |
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, | |
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN | |
;; THE SOFTWARE. | |
;; Reloading function for debugging. | |
(defun expert () (load "expert-system.lisp")) | |
;;; knowledge base | |
;; known rules | |
;; Only an example. Replace this block with reference to your own knowledge base or engine. | |
(setf *rules ` | |
((mammal ((hair y)(give-milk y))) | |
(bird ((feathers y)(lay-eggs y))) | |
(carnivore ((mammal y) (eats-meat y)(pointed-teeth y) (forward-eyes y))) | |
(carnivore ((mammal y)(eats-meat y)(claws y))) | |
(ungulate ((mammal y)(hoofs y))) | |
(ungulate ((mammal y) (chew-cud y))) | |
(cheetah ((mammal y) (carnivore y) (tawney y) (dark-spots y))) | |
(tiger ((mammal y) (carnivore y) (tawney y) (black-stripes y))) | |
(giraffe ((ungulate y) (long-neck y) (long-legs y) (dark-spots y))) | |
(zebra ((ungulate y)(black-stripes y))) | |
(ostrich ((bird y) (fly n) (long-neck y) (long-legs y) | |
(black-and-white-colour y))) | |
(penguin ((bird y) (fly n) (swim y) (black-and-white-colour y))) | |
(albatross ((bird y) (fly-well y))))) | |
;; known goals | |
(setf *goals `(cheetah tiger giraffe zebra ostrich penguin albatross)) | |
;; working memory | |
;; initially stores users known facts | |
;; Example below. | |
(setf *facts `((black-stripes y) (hair y) (give-milk y) (hoofs y))) | |
;;; main mehods | |
(defun run (rules goals) | |
(forward-chain rules goals)) | |
;; forward chaining reasoning | |
;; inferred facts kept on being added to working memory until either: | |
;; - a goal is found | |
;; - no untriggered rules exist | |
(defun forward-chain (rules goals) | |
(let ((goal (goal-known *facts))) | |
(if goal | |
goal | |
(let ((triggered-rules (get-triggered-rules rules *facts))) | |
(when triggered-rules | |
(progn | |
(fire-rules triggered-rules *goals *facts) | |
(forward-chain rules *goals))))))) | |
;; backward-chain | |
(defun backward-chain (rule-chain rules) | |
(dolist (condition (get-conditions (first rule-chain)) rule-chain) | |
(let ((rule (assoc (first condition) rules))) | |
(if rule | |
(progn | |
(setf rule-chain (cons rule rule-chain)) | |
(setf rule-chain (backward-chain rule-chain rules))))))) | |
(defun explain (rule-chain) | |
(dolist (rule rule-chain `finish) | |
(format t "~%from rule: ~a~%" rule))) | |
;;; main helper methods | |
;; add conclusions of triggered rules to working memory | |
(defun fire-rules (triggered-rules goals facts) | |
(goal-known | |
(dolist (rule triggered-rules facts) | |
(setf facts (add-fact (list (get-conclusion rule) `y) facts))))) | |
;; returns all rules that are triggered | |
(defun get-triggered-rules (rules facts) | |
(let ((triggered-rules nil)) | |
(dolist (rule rules triggered-rules) | |
(unless (assoc (get-conclusion rule) triggered-rules) | |
(when (triggered-rule rule facts) | |
(setf triggered-rules (cons rule triggered-rules))))))) | |
;; a triggered rule: | |
;; - is not known by working memory | |
;; - shares conditions with working memory | |
;; i.e. given rule contains related information (found by inference) | |
(defun triggered-rule (rule facts) | |
(unless (conclusion-known rule facts) | |
(dolist (condition (get-conditions rule) rule) | |
(unless (condition-true condition facts) | |
(setf rule nil))))) | |
;; check if goal is known in working memory | |
(defun goal-known (facts) | |
(let ((found-goal nil)) | |
;; check working memory with all known goals | |
(dolist (goal *goals found-goal) | |
(when (assoc goal facts) | |
(setf found-goal goal))))) | |
;;; rule methods | |
(defun get-conclusion (rule) | |
(first rule)) | |
(defun get-conditions (rule) | |
(second rule)) | |
(defun get-yes-conditions (rule) | |
(let ((conditions nil)) | |
(dolist (condition (get-conditions rule) conditions) | |
(when (eql (second condition) `y) | |
(setf conditions (cons condition conditions)))))) | |
(defun get-no-conditions (rule) | |
(let ((conditions nil)) | |
(dolist (condition (get-conditions rule) conditions) | |
(when (eql (second condition) `n) | |
(setf conditions (cons condition conditions)))))) | |
(defun conclusion-known (rule facts) | |
(assoc (get-conclusion rule) facts)) | |
(defun condition-known (condition facts) | |
(assoc (first condition) facts)) | |
(defun condition-true (condition facts) | |
(equal condition (condition-known condition facts))) | |
(defun add-fact (fact facts) | |
(unless (assoc (first fact) facts) | |
(setf *facts (cons fact facts)))) | |
(defun get-rule (conclusion rules) | |
(assoc conclusion rules)) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment