"Logic Programming in Lisp" from Luger and Stubblefield

constraint.lisp

;;; 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))))

Elegant Lisp!