Skip to content

Instantly share code, notes, and snippets.

@honno

honno/expert-system.lisp

Last active Sep 28, 2020
Embed
What would you like to do?
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