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

;;; These functions are the complete definition of the OOPS object 
;;; oriented programming shell discussed in chapter 15, 2nd edition.  This is
;;; a simple tutorial system intended to give the student an understanding of
;;; the internal structure of object oriented languages.  It is not 
;;; intended as a replacement for CLOS.
;;;

;;;
;;; Def-object defines a new object given its parent and optional list of
;;; instance variables and bindings.

(defun def-object (obj parent &optional vars)
   (setf (get obj 'isa) parent)
   (setf (get obj 'variables) (evaluate-bindings vars)))



;;; Evaluates the bindings on a list of variables and bindings.

(defun evaluate-bindings (vars)
   (mapcar #'(lambda (x) (list (car x) (eval (cadr x)))) vars))



;;; Attaches a method to an object

(defun def-method (obj name definition)
   (setf (get obj 'methods) 
	 (replace-method name definition (get obj 'methods))))



;;; Adds a new method to a list of methods if it does
;;; not already exist; replaces its definition if it does.

(defun replace-method (name definition list-of-methods)
   (cond ((null list-of-methods) 
	      (acons name definition nil))
	 ((equal name (caar list-of-methods))
	      (acons name definition (cdr list-of-methods)))
	 (t (cons (car list-of-methods)
		  (replace-method name definition 
                               (cdr list-of-methods))))))



;;; Searches the inheritance hierarchy for a method.

(defun inherit-method (object method)
   (cond ((null object) nil)
	 ((atom object)
	     (or (get-method object method)
		 (inherit-method (get object 'isa) method)))
	 (t (or (inherit-method (car object) method)
		(inherit-method (cdr object) method)))))



;;; Retrieves a named method for a given object.

(defun get-method (object name)
   (cdr (assoc name (get object 'methods))))


;;; Evaluates a message to an object.  The environment for the
;;; evaluation is constructed dynamically from the inheritance hierarchy.

(defun message (object method &rest method-parameters)
   (let ((meth (inherit-method object method)) env)
      (cond (meth 
	      (setq env (build-env object))
	      (progv (cons 'self (mapcar 'car env))
		     (cons object (mapcar 'cadr env))
		 (apply meth method-parameters)))
            (t (print "unknown method")
	       (print method)))))



;;; Walks the inheritance hierarchy in a depth first order, constructing 
;;; a list of all variable-binding pairs inherited by an object.  Used to 
;;; construct the environment for evaluating a method.

(defun build-env (obj)
   (cond ((null obj) nil)
	 ((listp obj) (append (build-env (cdr obj))
			      (build-env (car obj))))
	 (t (append (build-env (get obj 'isa))
		    (get obj 'variables)))))



;;; The following definitions of the root object 
;;; complete the implementation of OOPS.

(def-object 'object nil)

(def-method 'object 'show 
   #'(lambda ()
       (terpri)
       (prin1 self) (prin1 "has parents ") (terpri)
       (pprint (get self 'isa))
       (terpri)
       (prin1 self) (prin1 "has attached variables ") (terpri)
       (pprint (get self 'variables))
       (terpri)
       (prin1 self) (prin1 "has attached methods")
       (pprint (get self 'methods))
       (terpri)))

(def-method 'object 'show-parents #'(lambda () (get self 'isa)))

(def-method 'object 'show-value
   #'(lambda (name)
       (eval name)))

(def-method 'object 'show-env 
   #'(lambda ()
       (build-env self)))

(def-method 'object 'set-value
   #'(lambda (variable value)
       (let ((pair (assoc variable (get self 'variables))))
	  (cond (pair (rplacd pair (list value)))
		(t (setf (get self 'variables)
			 (cons (list variable value)
			       (get self 'variables))))))))