Skip to content

Instantly share code, notes, and snippets.

@Honno Honno/expert-system.lisp
Last active Aug 5, 2019

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
You can’t perform that action at this time.