Skip to content

Instantly share code, notes, and snippets.

@mrb
Created January 8, 2014 03:53
Show Gist options
  • Save mrb/8311524 to your computer and use it in GitHub Desktop.
Save mrb/8311524 to your computer and use it in GitHub Desktop.
"Logic Programming in Lisp" from Luger and Stubblefield
;;; This is one of the example programs from the textbook:
;;;
;;; Artificial Intelligence:
;;; Structures and strategies for complex problem solving
;;;
;;; by George F. Luger and William A. Stubblefield
;;;
;;; These programs are copyrighted by Benjamin/Cummings Publishers.
;;;
;;; We offer them for use, free of charge, for educational purposes only.
;;;
;;; Disclaimer: These programs are provided with no warranty whatsoever as to
;;; their correctness, reliability, or any other property. We have written
;;; them for specific educational purposes, and have made no effort
;;; to produce commercial quality computer programs. Please do not expect
;;; more of them then we have intended.
;;;
(defmacro delay (exp) `(function (lambda () ,exp)))
(defun force (function-closure) (funcall function-closure))
;;; Cons-stream adds a new first element to a stream
(defmacro cons-stream (exp stream)
`(cons ,exp (delay ,stream)))
;;; Head-stream returns the first element of the stream
(defun head-stream (stream)
(car stream))
;;; Tail-stream returns the stream with its first element deleted.
(defun tail-stream (stream)
(force (cdr stream)))
;;; Empty-stream-p is true if the stream is empty.
(defun empty-stream-p (stream)
(null stream))
;;; Make-empty-stream creates an empty stream.
(defun make-empty-stream ()
nil)
;;; Combine-streams appends two streams.
(defun combine-streams (stream1 stream2)
(cond ((empty-stream-p stream1) stream2)
(t (cons-stream (head-stream stream1)
(combine-streams (tail-stream stream1) stream2)))))
;;; Filter-stream
(defun filter-stream (stream test)
(cond ((empty-stream-p stream) (make-empty-stream))
((funcall test (head-stream stream))
(cons-stream (head-stream stream)
(filter-stream (tail-stream stream)test)))
(t (filter-stream (tail-stream stream)test))))
;;; map stream
(defun map-stream (stream func)
(cond ((empty-stream-p stream) (make-empty-stream))
(t (cons-stream (funcall func (head-stream stream))
(map-stream (tail-stream stream) func)))))
(defun unify (pattern1 pattern2 substitution-list)
(cond ((equal substitution-list 'failed) 'failed)
((varp pattern1)
(match-var pattern1 pattern2 substitution-list))
((varp pattern2)
(match-var pattern2 pattern1 substitution-list))
((is-constant-p pattern1)
(cond ((equal pattern1 pattern2) substitution-list)
(t 'failed)))
((is-constant-p pattern2) 'failed)
(t (unify (cdr pattern1) (cdr pattern2)
(unify (car pattern1) (car pattern2)
substitution-list)))))
;;; will attempt to match a variable to a pattern, first
;;; checking for existing bindings on the variable, then
;;; performing an occurs check.
(defun match-var (var pattern substitution-list)
(cond ((equal var pattern) substitution-list)
(t (let ((binding (get-binding var substitution-list)))
(cond (binding
(unify (get-binding-value binding)
pattern substitution-list))
((occursp var pattern) 'failed)
(t (acons var pattern substitution-list)))))))
;;; occursp will check if a variable occurs in a pattern.
(defun occursp (var pattern)
(cond ((equal var pattern) t)
((or (varp pattern) (is-constant-p pattern))
nil)
(t (or (occursp var (car pattern))
(occursp var (cdr pattern))))))
;;; is-constant-p determines if an item is a constant. In this simple
;;; program, we are assuming that all constants are atoms.
(defun is-constant-p (item)
(atom item))
(defun varp (item)
(and (listp item)
(equal (length item) 2)
(equal (car item) 'var)))
;;; get-binding takes a variable and a substitution list, and returns
;;; a (variable . binding-value) pair
(defun get-binding (var substitution-list)
(assoc var substitution-list :test #'equal))
;;; get-binding-value returns the binding value from
;;; a (variable . binding-value) pair
(defun get-binding-value (binding) (cdr binding))
;;; add-substitution adds a variable and a binding-value to a
;;; substitution-list
(defun add-substitution (var pattern substitution-list)
(acons var pattern substitution-list))
(defun logic-shell ()
(print '? )
(let ((goal (read)))
(cond ((equal goal 'quit) 'bye)
(t (print-solutions goal (solve goal nil))
(terpri)
(logic-shell)))))
;;; solve will take a single goal and a set of substitutions and return a
;;; stream of augmented substitutions that satisfy the goal.
(defun solve (goal substitutions)
(declare (special *assertions*))
(if (conjunctive-goal-p goal)
(filter-through-conj-goals (body goal)
(cons-stream substitutions (make-empty-stream)))
(infer goal substitutions *assertions*)))
;;; filter-through-conj-goals will take a list of goals and a stream of
;;; substitutions and filter them through the goals one at a time,
;;; eliminating failures.
(defun filter-through-conj-goals (goals substitution-stream)
(if (null goals)
substitution-stream
(filter-through-conj-goals
(cdr goals)
(filter-through-goal (car goals) substitution-stream))))
;;; filter-through-goal takes a goal (a pattern) and uses that goal as a
;;; filter to a stream of substitutions.
(defun filter-through-goal (goal substitution-stream)
(if (empty-stream-p substitution-stream)
(make-empty-stream)
(combine-streams
(solve goal (head-stream substitution-stream))
(filter-through-goal goal (tail-stream substitution-stream)))))
;;; infer will take a goal, a set of substitutions and a knowledge base
;;; and attempt to infer the goal from the kb
(defun infer (goal substitutions kb)
(if (null kb)
(make-empty-stream)
(let* ((assertion (rename-variables (car kb)))
(match (if (rulep assertion)
(unify goal (conclusion assertion) substitutions)
(unify goal assertion substitutions))))
(if (equal match 'failed)
(infer goal substitutions (cdr kb))
(if (rulep assertion)
(combine-streams
(solve (premise assertion) match)
(infer goal substitutions (cdr kb)))
(cons-stream match (infer goal substitutions (cdr kb))))))))
;;; apply-substitutions will return the result of applying a
;;; set of substitutions to a pattern.
(defun apply-substitutions (pattern substitution-list)
(cond ((is-constant-p pattern) pattern)
((varp pattern)
(let ((binding (get-binding pattern substitution-list)))
(cond (binding (apply-substitutions
(get-binding-value binding)
substitution-list))
(t pattern))))
(t (cons (apply-substitutions (car pattern) substitution-list)
(apply-substitutions (cdr pattern) substitution-list)))))
;;; print solutions will take a goal and a stream of substitutions and
;;; print that goal with each substitution in the stream
(defun print-solutions (goal substitution-stream)
(cond ((empty-stream-p substitution-stream) nil)
(t (print (apply-substitutions goal
(head-stream substitution-stream)))
(terpri)
(print-solutions goal (tail-stream substitution-stream)))))
;;; rule format is
;;; (rule if then )
(defun premise (rule) (nth 2 rule))
(defun conclusion (rule) (nth 4 rule))
(defun rulep (pattern)
(and (listp pattern)
(equal (nth 0 pattern) 'rule)))
;;; conjunctive goals are goals of the form
;;; (and ... )
(defun conjunctive-goal-p (goal)
(and (listp goal)
(equal (car goal) 'and)))
(defun body (goal) (cdr goal))
;;; rename variables will take an assertion and rename all its
;;; variables using gensym
(defun rename-variables (assertion)
(declare (special *name-list*))
;(declare special *name-list*)
(setq *name-list* ())
(rename-rec assertion))
(defun rename-rec (exp)
(cond ((is-constant-p exp) exp)
((varp exp) (rename exp))
(t (cons (rename-rec (car exp))
(rename-rec (cdr exp))))))
(defun rename (var)
(declare (special *name-list*))
(list 'var (or (cdr (assoc var *name-list* :test #'equal))
(let ((name (gensym)))
(setq *name-list* (acons var name *name-list*))
name))))
@dancingpixels
Copy link

Elegant Lisp!

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment