;; Here is the famous "zoo" example, initially developed by Patrik Winston
;; and used in many books to illustrate backward chaining.

;; Basic operations on streams.

(defun stream-endp (stream) (eq stream 'empty-stream))

(defun stream-first (stream) (first stream))

(defun stream-rest (stream) (second stream))

(defun stream-cons (object stream) (list object stream))

(defun stream-append (stream1 stream2) 
	(if (stream-endp stream1)
             stream2
	    (stream-cons (stream-first stream1)
                         (stream-append (stream-rest stream1)
                                         stream2))))

(defun stream-concatenate (streams) 
	(if (stream-endp streams)
             'empty-stream
	  (if (stream-endp (stream-first streams))
              (stream-concatenate (stream-rest streams))
             (stream-cons (stream-first (stream-first streams))
                          (stream-concatenate
                             (stream-cons (stream-rest 
                                            (stream-first streams))
                                          (stream-rest streams)))))))

(defun stream-transform (procedure stream) 
	(if (stream-endp stream)
             'empty-stream
	    (stream-cons (funcall procedure (stream-first stream))
                         (stream-transform procedure 
                                           (stream-rest stream)))))
 
(defun stream-member (object stream)
	(cond ((stream-endp stream) nil)
	      ((equal object (stream-first stream)) t)
	      (t (stream-member object (stream-rest stream)))))

;; STREAM-REMEMBER is a macro that inserts new assertions at the end 
;; of the stream *ASSERTIONS*, so that when the steam is processed
;; the assertions will be processed in the order in which they have
;; been enterred.

(defmacro stream-remember (object variable)
	`(unless (stream-member ,object ,variable)
		(setf ,variable
                      (stream-append ,variable
                           (stream-cons ,object 'empty-stream)))
          ,object))

;; To access various parts of individual rules, we need the following
;; procedures.

(defun rule-name (rule) (first rule))

(defun rule-ifs (rule) (butlast (rest rule)))

(defun rule-then (rule) (first (last rule)))

(defun remember-rule (rule)
	(stream-remember rule *rules*))

;; Rule base, encoding knowledge about different animals follow.

(setf *rules* 'empty-stream)

(remember-rule '(identify1
                   ((? animal) has hair)
                   ((? animal) is a mammal)))

(remember-rule '(identify2
                   ((? animal) gives milk)
                   ((? animal) is a mammal)))

(remember-rule '(identify3
                   ((? animal) has feathers)
                   ((? animal) is a bird)))

(remember-rule '(identify4
                   ((? animal) flies)
                   ((? animal) lays eggs)
                   ((? animal) is a bird)))

(remember-rule '(identify5
                   ((? animal) eats meat)
                   ((? animal) is a carnivore)))

(remember-rule '(identify6
                   ((? animal) has pointed teeth)
                   ((? animal) has claws)
                   ((? animal) lays forward eyes)
                   ((? animal) is a carnivore)))

(remember-rule '(identify7
                   ((? animal) is a mammal)
                   ((? animal) has hoofs)
                   ((? animal) is a ungulate)))

(remember-rule '(identify8
                   ((? animal) is a mammal)
                   ((? animal) chews cud)
                   ((? animal) is a ungulate)))

(remember-rule '(identify9
                   ((? animal) is a mammal)
                   ((? animal) is a carnivore)
                   ((? animal) has tawny color)
                   ((? animal) has dark spots)
                   ((? animal) is a cheetah)))

(remember-rule '(identify10
                   ((? animal) is a mammal)
                   ((? animal) is a carnivore)
                   ((? animal) has tawny color)
                   ((? animal) has black stripes)
                   ((? animal) is a tiger)))

(remember-rule '(identify11
                   ((? animal) is a ungulate)
                   ((? animal) has long neck)
                   ((? animal) has long legs)
                   ((? animal) has dark spots)
                   ((? animal) is a giraffe)))

(remember-rule '(identify12
                   ((? animal) is a ungulate)
                   ((? animal) has black stripes)
                   ((? animal) is a zebra)))

(remember-rule '(identify13
                   ((? animal) is a bird)
                   ((? animal) does not fly)
                   ((? animal) has long neck)
                   ((? animal) has long legs)
                   ((? animal) is black and white)
                   ((? animal) is a ostrich)))

(remember-rule '(identify14
                   ((? animal) is a bird)
                   ((? animal) does not fly)
                   ((? animal) swims)
                   ((? animal) is black and white)
                   ((? animal) is a penguin)))

(remember-rule '(identify15
                   ((? animal) is a bird)
                   ((? animal) flies well)
                   ((? animal) is a albatross)))

(remember-rule '(identify16
                   ((? animal) is a (? species))
                   ((? animal) is a parent of (? child))
                   ((? animal) is a  (? species))))

;; REMEMBER-ASSERTION gets new assertions into the assertion stream.

(defun remember-assertion (assertion)
	(stream-remember assertion *assertions*))

;; Assume that the specific data base is composed by the following
;; statements (this is the "description(s)" of the animals that we want
;; to identify.

(setf *assertions* 'empty-stream)

(remember-assertion '(robbie has dark spots))

(remember-assertion '(robbie has tawny color))

(remember-assertion '(robbie has dark spots))

(remember-assertion '(robbie eats meat))

(remember-assertion '(robbie has hair))

(remember-assertion '(suzie has feathers))

(remember-assertion '(suzie flies well))

;; MATCH is a function that checks if each rule premise matches a data
;; assertion in the DB.

(defun match (p d &optional bindings)
	(cond ((elements-p p d) (match-atoms p d bindings))
              ((variable-p p) (match-variable p d bindings))
              ((recursive-p p d) (match-pieces p d bindings))
              (t 'fail)))

(defun match-atoms (p d bindings)
	(if (eql p d) 
            bindings
            'fail))

(defun match-variable (p d bindings)
	(let ((binding (find-binding p bindings)))
           (if binding
               (match (extract-value binding) d bindings)
               (add-binding p d bindings))))

(defun match-pieces (p d bindings)
	(let ((result (match (first p) (first d) bindings)))
           (if (eq 'fail result)
               'fail
               (match (rest p) (rest d) result))))

(defun elements-p (p d)
	(and (atom p) (atom d)))

(defun variable-p (p)
	(and (listp p) (eq '? (first p))))

(defun recursive-p (p d)
	(and (listp p) (listp d)))

;; UNIFY is a function that checks if two patterns match each other.

(defun unify (p1 p2 &optional bindings)
	(cond ((elements-p p1 p2) (unify-atoms p1 p2 bindings))
              ((variable-p p1) (unify-variable p1 p2 bindings))
              ((variable-p p2) (unify-variable p2 p1 bindings))
              ((recursive-p p1 p2) (unify-pieces p1 p2 bindings))
              (t 'fail)))

(defun unify-atoms (p1 p2 bindings)
	(if (eql p1 p2) 
            bindings
            'fail))

(defun unify-variable (p1 p2 bindings)
	(let ((binding (find-binding p1 bindings)))
           (if binding
               (unify (extract-value binding) p2 bindings)
               (if (insidep p1 p2 bindings)
                   'fail
                   (add-binding p1 p2 bindings)))))

(defun insidep (variable expression bindings)
	(if (equal variable expression)
            nil
            (inside-or-equal-p variable expression bindings)))

(defun inside-or-equal-p (variable expression bindings)
	(cond ((equal variable expression) t)
	      ((atom expression) nil)
	      ((eq '? (first expression))
               (let ((binding (find-binding expression bindings)))
		   (when binding
                      (inside-or-equal-p variable 
                                         (extract-value binding)
                                         bindings))))
	      (t (or (inside-or-equal-p variable
                                        (rest expression)
                                        bindings)))))

(defun unify-pieces (p1 p2 bindings)
	(let ((result (unify (first p1) (first p2) bindings)))
           (if (eq 'fail result)
               'fail
               (unify (rest p1) (rest p2) result))))

;; Procedures implementing backward chaining follow.

(defun try-assertion (pattern assertion bindings)
   (let ((result (match pattern assertion bindings)))
       (if (eq 'fail result)
           'empty-stream
           (stream-cons result 'empty-stream))))

(defun match-pattern-to-assertions (pattern bindings)
	(stream-concatenate
            (stream-transform
                #'(lambda (assertion) (try-assertion pattern
                                                     assertion
                                                     bindings))
              *assertions*)))

(defun instantiate-variables (pattern a-list)
	(cond
           ((atom pattern) pattern)
           ((eq '? (first pattern))
            (extract-value (find-binding pattern a-list)))
	   (t (cons (instantiate-variables (first pattern) a-list)
                    (instantiate-variables (rest pattern) a-list)))))

(defun list-variables (tree &optional names)
    (cond ((atom tree) names)
          ((eq '? (first tree))
           (if (member (second tree) names)
               names
               (append names (rest tree))))
          (t (list-variables (rest tree) 
                             (list-variables (first tree)
                                             names)))))

(defun make-variables-unique (rule)
   (let ((variables (list-variables rule)))
      (dolist (variable variables rule)
          (setf rule
                (instantiate-variables
                    rule
                    (list (list variable
                                (list '? (gentemp (string variable))))))))))

(defun try-rule (pattern rule bindings)
   (let* ((rule (make-variables-unique rule))
          (result (unify pattern (rule-then rule) bindings)))
       (if (eq 'fail result)
           'empty-stream
           (apply-filters (rule-ifs rule)
                          (stream-cons result 'empty-stream)))))

(defun match-pattern-to-rules (pattern bindings)
	(stream-concatenate
            (stream-transform
                #'(lambda (rule) (try-rule pattern
                                           rule
                                           bindings))
              *rules*)))

(defun filter-binding-stream (pattern stream)
	(stream-concatenate
            (stream-transform
                #'(lambda (bindings)
                     (stream-concatenate
                        (stream-cons
                          (match-pattern-to-assertions pattern bindings)
                          (stream-cons
                             (match-pattern-to-rules pattern bindings)
                                'empty-stream))))
                stream)))

(defun apply-filters (patterns initial-input-stream)
	(if (endp patterns)
	    initial-input-stream
            (apply-filters (rest patterns)
                           (filter-binding-stream (first patterns)
                                          initial-input-stream))))

(defun extract-value (binding)
	(second binding))

(defun extract-key (binding)
	(first binding))

(defun find-binding (pattern-variable-expression binding)
	(unless (eq '_ (extract-variable pattern-variable-expression))
            (assoc (extract-variable pattern-variable-expression) 
                                                        binding)))

(defun extract-variable (pattern-variable-expression)
	(second pattern-variable-expression))

(defun make-binding (variable datum)
	(list variable datum))

(defun add-binding (pattern-variable-expression datum bindings)
    (if (eq '_ (extract-variable pattern-variable-expression))
        bindings
        (cons (make-binding
                (extract-variable pattern-variable-expression)
                 datum)
              bindings)))

(defun make-answer (variables bindings)
	(instantiate-variables 
	     (mapcar #'(lambda (variable)
                          (list variable (list '? variable)))
                     variables)
             bindings))

(defun display-answer (answers)
	(format t "~&-->")
        (dolist (answer answers)
	      (format t " ~a = ~a" (first answer) (second answer))))

(defun backward-chain (&rest patterns)
   (let ((binding-stream
            (apply-filters patterns
                           (stream-cons nil 'empty-stream)))
         (variables (list-variables patterns))
         (displayed-answers nil))
       (if (endp variables)
           (if (stream-endp binding-stream)
               'no
               'yes)
           (do ((binding-stream binding-stream 
                                (stream-rest binding-stream)))
               ((stream-endp binding-stream) 'no-more)
             (let ((answer
                      (make-answer variables
                                   (stream-first binding-stream))))
                (unless (member answer displayed-answers
                                :test #'equal)
                    (display-answer answer)
                    (setf displayed-answers
                          (cons answer displayed-answers))))))))