;;; -*- Mode: LISP; Package: KR; Base: 10; Syntax: Common-Lisp -*-


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



(in-package "KR")


(defvar *in-link-constant* nil
  "If non-nil, a slot is considered constant if it is constant OR if it
  is a link-constant")



;;; --------------------------------------------------

;;; Fixed-path code.


(defun fixed-path-accessor (schema slots path-number)
  (let* ((current (a-formula-path *current-formula*))
	 (length (length current)))
    (or (and (< path-number length)
	     (elt current path-number))
	(progn
	  (dolist (slot slots)
	    (setf schema (g-value schema slot))
	    (if (listp schema)
		;; This handles relation slots, which are ALWAYS stored as
		;; a list.
		(setf schema (first schema))))
	  (unless (> length path-number)
	    ;; create more storage
	    (setf current
		  (setf (a-formula-path *current-formula*)
			(append current
				(make-list (- path-number length -1))))))
	  (setf (elt current path-number) schema)
	  schema))))



(defmacro kr-path (path-number &rest slots)
  `(fixed-path-accessor *schema-self* ',slots ,path-number))



;;; -------------------------------------------------- FORMULAS


;;; Reuses one of the destroyed formulas, or allocates one if none exist.
;;;
(defun make-new-formula ()
  (let ((l (1- (length *reuse-formulas*)))
	f)
    (if (< l 0)
	;; No formulas to reuse
	(setf f (make-a-formula))
	;; Reuse the last formula in the array.
	(progn
	  (setf f (aref *reuse-formulas* l))
	  (setf (a-formula-depends-on f) nil)
	  (setf (a-formula-cached-value f) nil)
	  (setf (a-formula-path f) nil)
	  (setf (a-formula-is-a f) nil)
	  (setf (a-formula-function f) nil)
	  (setf (a-formula-lambda f) nil)
	  (setf (a-formula-is-a-inv f) nil)
	  (decf (fill-pointer *reuse-formulas*))))
    (set-formula-number f 0)
    f))



;;; This version stores the formula as an INTERPRETED lambda.
;;; If <initial-value> is supplied, it is stored as the cached value for the
;;; formula; the formula, however, is still marked invalid.
;;; 
(defun formula (form &optional (initial-value nil))
  "Creates an interpreted formula.  The <form> can be either a Lisp expression
  (which is used as the body of the formula), or another formula.  In the
  latter case, the other formula is made the parent, and this function
  creates an inherited formula.  The <initial-value>, which defaults to nil,
  is used as the initial cached value before the formula is evaluated."
  (let ((formula (make-new-formula)))
    (setf (schema-name formula) (incf *schema-counter*))
    (setf (cached-value formula) initial-value)
    #+EAGER
    (setf (a-formula-bits formula) 0)
    #+EAGER
    (setf (a-formula-priority formula) *min-priority*)
    (if (formula-p form)
	;; We were passed an object which is already a formula.  Link to it.
	(progn
	  (setf (a-formula-is-a formula) form)
	  (setf (a-formula-function formula) (a-formula-function form))
	  (setf (a-formula-lambda formula) (a-formula-lambda form))
	  (push-one-or-list formula (a-formula-is-a-inv form)))
	;; Normal case: we were given a Lisp expression
      (progn
	(setf (a-formula-function formula)
	      ;; This version does not work with CL version 2.  It is,
	      ;; however, much more efficient than calling the compiler.
	      #-CMU `(lambda () ,form)
	      ;; This version works with CL version 2.
	      #+CMU (compile nil `(lambda () ,form)))
	(setf (a-formula-lambda formula) form)))
    formula))



(defun prepare-formula (initial-value)
  (let ((formula (make-new-formula)))
    (setf (schema-name formula) (incf *schema-counter*))
    (setf (cached-value formula) initial-value)
    #+EAGER
    (setf (a-formula-bits formula) 0)
    #+EAGER
    (setf (a-formula-priority formula) *min-priority*)
    formula))



(defun o-formula-fn (function lambda initial-value)
  (let ((formula (prepare-formula initial-value)))
    (setf (a-formula-function formula) function)
    (setf (a-formula-lambda formula) lambda)
    formula))


;;; This version creates compilable formulas (but does not, by itself, actually
;;; compile them).
;;; 
(defmacro o-formula (form &optional (initial-value nil))
  (if (listp form)
      `(o-formula-fn (function (lambda () ,form))
		     ,(if *store-lambdas* `(quote ,form) nil)
		     ,initial-value)
      `(if (formula-p ',form)
	   ;; Just create an inherited formula
	   (formula ',form ,initial-value)
	   ;; This is a real o-formula
	   (let ((formula (prepare-formula ,initial-value)))
	     (setf (a-formula-function formula)
		   (function (lambda () ,form)))
	     (setf (a-formula-lambda formula) ',form)
	     formula))))



;;;; CHANGE-FORMULA
;;; 
;;; Modify the function associated with a formula.  Several possible
;;; combinations exist:
;;; - If the function is local and there are no children, just go ahead and
;;;   invalidate the formula.
;;; - if the function is local and there are children, invalidate all the
;;;   children formulas as well.
;;; - if the function used to be inherited, replace it and eliminate the
;;;   link with the parent formula.
;;; 
(defun change-formula (schema slot form)
  "Modifies the formula at position 0 in the <slot> of the <schema> to have
  <form> as its new function.  Inherited formulas are treated appropriately."
  (let ((formula (get-value schema slot)))
    (when (formula-p formula)
      (when (a-formula-is-a formula)
	;; This function was inherited.  Cut the IS-A link.
	(let* ((parent (a-formula-is-a formula))
	       (inv (a-formula-is-a-inv parent)))
	  (setf (a-formula-is-a-inv parent)
		(if (listp inv)
		  (delete formula inv)
		  (if (eq inv formula) NIL inv))))
	(setf (a-formula-is-a formula) NIL))

      ;; If this formula has children, we need to invalidate them as well.
      (do-one-or-list (f-child (a-formula-is-a-inv formula))
	#-EAGER
	(set-cache-is-valid f-child nil)
	#-EAGER
	(mark-as-changed (on-schema f-child) (on-slot f-child))
	#+EAGER
	;; If this formula has children, we need to place them on the
	;; evaluation queue
	(setf *eval-queue* (insert-pq f-child *eval-queue*)))
      #-EAGER
      ;; Invalidate the formula itself.
      (set-cache-is-valid formula nil)
      #-EAGER
      (mark-as-changed schema slot)
      #+EAGER
      ;; Add the formula itself to the evaluation queue
      (setf *eval-queue* (insert-pq formula *eval-queue*))

      ;; Record the new function.
      (setf (a-formula-function formula) `(lambda () ,form))
      ;; store the new form in the lambda slot of the formula
      (setf (a-formula-lambda formula) form))))



;;;; MOVE-FORMULA
;;; 
;;; This function is used to move a formula from a slot to another.  It is
;;; not safe to simply do (s-value new :slot (get-value old :slot)),
;;; because this creates a formula which sits on two slots, and this is
;;; definitely a no-no.
;;; Any formula in to-schema.to-slot is destroyed, even if
;;; from-schema.from-slot contains a regular value (as opposed to a formula).
;;; 
(defun move-formula (from-schema from-slot to-schema to-slot)
  (let ((formula (get-value from-schema from-slot)))
    (if (formula-p formula)
	(let ((value (g-value-formula-value from-schema
					    from-slot formula)))
	  (eliminate-formula-dependencies formula NIL)
	  ;; Invalidate the formula.
	  (set-cache-is-valid formula nil)
	  (setf (a-formula-schema formula) NIL)
	  (setf (a-formula-slot formula) NIL)
	  (setf (a-formula-depends-on formula) NIL)
	  (set-slot-accessor from-schema from-slot value *local-mask*)
	  (s-value to-schema to-slot formula))
	;; This is just a regular value, not a formula.
	(let ((value (slot-accessor to-schema to-slot)))
	  (when (formula-p value)
	    (destroy-constraint to-schema to-slot))
	  (s-value to-schema to-slot formula)))))



;;;; COPY-FORMULA
;;; Makes a copy of a formula, keeping the same initial value and the same
;;; parent (if any)
;;; 
(defun copy-formula (formula)
  (let ((parent (a-formula-is-a formula))
	(value (a-formula-cached-value formula)))
    (if parent
	(formula parent value)
	(let ((new (formula nil value)))
	  (setf (a-formula-function new) (a-formula-function formula))
	  (setf (a-formula-lambda new) (a-formula-lambda formula))
	  new))))



;;; --------------------------------------------------


	
#+EAGER
;;; a dependency is valid if:
;;;   1) the dependency points to a valid formula
;;;   2) the dependency's count is greater than the formula's count
;;; 
(defun valid-dependency-p (dependency)
  (let ((v-formula (get-dependent-formula dependency)))
    (and (a-formula-name v-formula)
	 (status-is-valid dependency v-formula))))



#+EAGER

;;; this function finds the portion of the dependency graph whose priorities
;;; are out of order and fixes them so that they are in order. Reorder
;;; is only called when a new dependency is added to the graph, so reorder
;;; also determines whether this new dependency has caused a cycle. If
;;; reorder finds a cycle, it returns t; otherwise it returns nil. reorder
;;; also returns the minimum priority of a formula's successors, so that
;;; it can renumber this formula correctly. If the formula is part of a
;;; pre-existing cycle, then reorder returns the minimum priority of this
;;; formula's successors and the minimum priority of the successors of
;;; any other formula that has been visited in this cycle. If the new dependency
;;; has caused a cycle, reorder can return anything, since the formulas in
;;; the new cycle will all be given the priority that the source formula
;;; in the new dependency has

(defvar *count* 1)
(defvar *reorder-stack* nil)

#+EAGER
(defun reorder-formulas (formula priority)
  (setf *count* 1)
  (setf *reorder-stack* nil)
  (reorder formula priority))



#+EAGER
(defun reorder (formula priority)
  (set-visited-bit formula t)
  (setf (a-formula-dfnumber formula) *count*)
  (setf (a-formula-lowlink formula) *count*)
  (push formula *reorder-stack*)
  (incf *count*)

  (let ((ceiling *max-priority*))

    ;; reorder all successors and then assign the correct priority to this
    ;; formula
    (dolist-test (dependent (get-formula-dependents formula)
			  (valid-dependency-p dependent))
      (let* ((dependent-formula (get-dependent-formula dependent))
	     (dependent-priority (priority dependent-formula))
	     reorder-priority)
	(if (priority-<=-p dependent-priority priority)
	    (progn
	      (cond ((not (visited-p dependent-formula))
		     (setf reorder-priority 
			   (reorder dependent-formula priority))
		     (setf ceiling (min-priority ceiling reorder-priority))
		     (setf (a-formula-lowlink formula)
			   (min (a-formula-lowlink dependent-formula)
				(a-formula-lowlink formula)))
		     (if (= (a-formula-lowlink formula)
			    (a-formula-lowlink dependent-formula))
			 (set-cycle-edge-bit dependent t)
		         (set-cycle-edge-bit dependent nil)))
		    (t
		     (setf (a-formula-lowlink formula)
			   (min (a-formula-lowlink formula)
				(a-formula-dfnumber dependent-formula)))
		     (set-cycle-edge-bit dependent t))))
	    (setf ceiling (min-priority ceiling dependent-priority)))))

    (when (= (a-formula-lowlink formula) (a-formula-dfnumber formula))
	  (let* ((stack-formula (pop *reorder-stack*))
		 (cycle-flag (not (eq stack-formula formula)))
		 (initial-cycle-p (and cycle-flag
				       (= (a-formula-dfnumber formula) 1)))
		 (new-priority (if initial-cycle-p 
				   priority
				   (priority-between priority ceiling)))
		 (valid-flag (not (and initial-cycle-p 
				    (priority-<=-p new-priority 
						   (eval-q-priority))))))


	    (loop
	     (set-cycle-bit stack-formula cycle-flag)
	     (set-valid-bit stack-formula valid-flag)
	     (setf (priority stack-formula) new-priority)
	     (set-visited-bit stack-formula nil)
	     (if (eq stack-formula formula)
		 (return)
	         (setf stack-formula (pop *reorder-stack*))))

	    (setf ceiling new-priority)))
    ceiling))



;;; determine if the priorities of the formula being evaluated and the
;;; formula whose value it requested are in the proper order. This function
;;; is called only if the dependency is a new one (old dependencies are
;;; guaranteed to have the correct order). The priority
;;; of the requested formula (called the predecessor formula or predecessor
;;; for short) should be less than the formula being evaluated (called the
;;; current formula). If the priorities are out of order, renumber the
;;; current formula and its successors so that the priorities are once
;;; again correct. Once the current formula has been renumbered, check
;;; its new priority against the minimum priority in the evaluation queue,
;;; and terminate evaluation of the current formula if its new priority
;;; is greater than this minimum priority. This is done since the current
;;; formula is being evaluated out of order.
;;; 
#+EAGER
(defun check-priority (dependency pred-formula *current-formula* eval-type)
  (let ((cf-priority (priority *current-formula*))
	(pf-priority (priority pred-formula)))
	   ; if the priorities are out of order, renumber the current
	   ; formula and its successors. reorder returns t if the new
    ; dependency has caused a cycle, nil otherwise.
    (when (priority->=-p pf-priority cf-priority)
	  (reorder-formulas *current-formula* pf-priority)
	  ;; if the reordering detected a cycle (this new dependency
	  ;; completed a cycle in the dependency graph),
	  ;; WE ARE IN THE MIDDLE OF A CIRCULARITY
	  (cond ((cycle-edge-p dependency) 
	       (if *warning-on-circularity*
		  (format t "Warning - circularity detected on ~S, slot ~S, position ~S~%"
			  (on-schema *current-formula*)
			  (on-slot *current-formula*)))
	
	     ;; get out of here. we now need to do cycle evaluation so place
	     ;; the formula back on the evaluation queue and do a throw
	       (setf *eval-queue* (insert-pq *current-formula* *eval-queue*))
	       (throw 'out-of-order 'wrong-order))

	      ;; if the current formula's new priority is greater than the
	      ;; priority of the first element in the evaluation queue,
	      ;; reinsert the formula into the evaluation queue and terminate
	      ;; evaluation
		((priority-<-p (eval-q-priority) (priority *current-formula*))
		 (setf *eval-queue* (insert-pq *current-formula* *eval-queue*))
		 (throw 'out-of-order 'wrong-order))))))


#+EAGER
;;; Record a dependency.  If the dependency already exists, set the
;;; dependency's count to be one greater than the formula's count; otherwise
;;; create a new dependency.  A dependency is a cons cell with a formula and
;;; a bits field for count and cycle-edge.  Return T if the dependency is
;;; new, nil if it already exists.  Also return the dependency.
;;; 
(defun record-dependency (schema slot formula)
  (let ((position (find-dependents schema slot)))
    (unless position
      (format t "****** null position in record-dependency ~s ~s ~S~%"
	      schema slot formula)
      (return-from record-dependency NIL))
    (let* ((slots (schema-slots schema))
	   (dependency (assoc formula (aref slots position)))
	   (new-dependency-p nil))
      (unless dependency
	;; Create a new dependency, add to list.
	(setf dependency (cons formula (ash (1+ (formula-count formula))
					    *status-bit*)))
	(push dependency (dependent-formulas slots (1- position)))
	(setf new-dependency-p t))
      (set-dependency-count dependency (1+ (formula-count formula)))
      (values dependency new-dependency-p))))



;;; --------------------------------------------------


(defun broken-link-throw (schema slot)
  (declare (ignore schema))
  (when *current-formula*
    ;; 1. eliminate the dependencies from the formula, since they are no
    ;; longer accurate
    #+TEST (setf (a-formula-depends-on *current-formula*) nil)
    (setf *last-formula* *current-formula*)
    ;; 2. give warning if so desired.
    (if *warning-on-null-link*
	(format
	 t
	 "Warning: broken link in schema ~S (last slot ~S);~%~:
	 reusing stale value in formula ~S.~%"
	 *schema-self* slot *current-formula*))
    ;; 3. throw to the top level
    (throw 'no-link (a-formula-cached-value *current-formula*)))

  ;; We get here if a GV expression was used outside a formula
  (format
   t
   "*** Current formula seems to be missing.   You may have used GV or~%~:
   ~4TGVL in an expression outside a formula.  Last slot was ~s.~%"
   slot))



(defun debug-gv (schema)
  (unless (schema-p schema)
     (format t "*** Non-schema value ~S in schema ~S, slot ~S (formula ~S)~%"
	     schema
	     (a-formula-schema *current-formula*)
	     (a-formula-slot *current-formula*)
	     *current-formula*)
     (if (a-formula-lambda *current-formula*)
	 (format t "  (formula expression is  ~S).~%"
		 (a-formula-lambda *current-formula*)))))



;;; This is similar to g-value-fn, but does a few things needed for constant
;;; formula checking before it does anything else.  Also, sets up
;;; dependencies at the end.
;;;
(defun gv-value-fn (schema slot position)
  (if (null (schema-slots schema))
    ;; Schema was destroyed
    (broken-link-throw schema slot))
  (let* ((slots (schema-slots schema))
	 (value (aref slots position))
	 (setup T))
    (if (eq value *no-value*)
      (setf value (g-value-inherit-values schema slot T position)))
    (if (a-formula-p value)
      ;; we are working with a formula
      #-EAGER
      (setf value (g-value-formula-value schema slot value))
      #+EAGER
      (progn
	(when (and *eval-queue* *not-within-propagate*)
	  (propagate))
	(setf value
	      (if (valid-p value)
		(cached-value value)
		;; even if a formula is marked invalid, do not evaluate 
		;; the formula if its value is fixed on this iteration of
		;; the constraint solver
		(if (fixed-p value)
		  (progn
		    (set-valid-bit value t)
		    (cached-value value))
		  (g-value-formula-value
		   (on-schema value) (on-slot value) value))))))    
    (when *check-constants*
      (if *is-constant*			; don't check if already known!
	(if (slot-is-not-constant schema slot)
	  ;; Not constant
	  (setf *is-constant* NIL)
	  ;; Constant, so do NOT set up dependencies.
	  (setf setup NIL)))
      (setf *accessed-slots* T))
    ;; Now set up the dependencies.
    (if (eq value *no-value*)
      (setf value (slot-accessor schema slot)))
    (if setup				; do we need to set up dependencies?
      (setup-dependency schema slot value position))
    (if (not (eq value *no-value*)) value)))



;;; This macro generates the body of gv-fn gv-local-fn.  The only difference
;;; is what accessor function to use.
;;;
(defmacro gv-fn-body (accessor-function)
  `(progn
    (if (eq schema :self)
      (setf schema *schema-self*))
    ;; Handle special relation slots which return a list of values.  In this
    ;; case, use the first value.  This code is for backward compatibility.
    (if (listp schema)
      (setf schema (car schema)))
    (if (and schema (schema-slots schema))
      ;; Normal case
      (let ((value (,accessor-function schema slot))
	    (setup T))
	(setf *accessed-slots* T)	; indicate we have done something
	(if *check-constants*
	  (if (slot-is-not-constant schema slot)
	    (setf *is-constant* NIL)
	    ;; If slot is constant, never set up a dependency.
	    (setf setup NIL)))
	;; Record the link dependency for this parent and formula
	(if setup
	  (multiple-value-bind (the-value position)
	      (slot-accessor schema slot)
	    (setup-dependency schema slot (if (eq the-value *no-value*)
					    the-value value)
			      position)))
	value)
      ;; A link is broken.  Get out of here!
      (broken-link-throw schema slot))))



;;; This function is for use in formulas.  It represents a direct (i.e.,
;;; no-link) dependency.  If the <slot> of the <schema> changes, the formula
;;; will be re-evaluated. 
;;; 
(defun gv-fn (schema slot)
  (gv-fn-body g-value))

#|
;;; This version has correct EAGER switches in it!
(defun gv-fn (schema slot)
  (if (eq schema :self)
      (setf schema *schema-self*))
  ;; Handle special relation slots which return a list of values.  In this
  ;; case, use the first value.  This code is for backwards compatibility.
  (if (listp schema)
      (setf schema (car schema)))
  (when-debug
   (unless (schema-p schema)
     (format t "*** Non-schema value ~S in schema ~S, slot ~S (formula ~S)~%"
	     schema
	     (a-formula-schema *current-formula*)
	     (a-formula-slot *current-formula*)
	     *current-formula*)
     (if (a-formula-lambda *current-formula*)
	 (format t "  (formula expression is  ~S).~%"
		 (a-formula-lambda *current-formula*)))
     (break)))
  ;; Record the link dependency for this parent and formula
  (unless schema
    ;; A link is broken.  Get out of here!
    (broken-link-throw schema slot)
    ;; Safety net - maybe formula was missing, instead of broken link
    (return-from gv-fn NIL))
  (multiple-value-bind (value bits position)
		       (slot-accessor schema slot)
    (let ((slots (schema-slots schema)))
      (unless bits
	;; This value was not present at all.  Get it (through inheritance,
	;; typically) and then mark it as depended on by someone.
	;; EAGER: This
	;; value must be an atom because formulas are immediately copied 
	;; from prototypes to all instances who have not overridden the
	;; value in this slot
	(g-value schema slot)
	(multiple-value-setq (value bits position)
	  (slot-accessor schema slot))
	(unless bits
	  ;; Value is definitely not available.  Mark it as inherited.
	  (set-slot-accessor schema slot NIL *inherited-mask* -1)
	  (multiple-value-setq (value bits position)
	    (slot-accessor schema slot)))
	
	#+EAGER
	;; store the dependency
	(record-dependency schema slot *current-formula*)
	#-EAGER
	(push *current-formula* (dependent-formulas slots position))

	(return-from gv-fn (g-value schema slot)))
      
      #-EAGER
      (let ((dependent (dependent-formulas slots position)))
	(unless (member *current-formula* dependent)
	  (push *current-formula* (dependent-formulas slots position))
	  ;; Check this only here - if the current formula was already in the
	  ;; list, then the reverse pointer would be already in place.
	  (unless (member schema (a-formula-depends-on *current-formula*))
	    ;; this is apparently a lot faster than PUSHNEW
	    (push schema (a-formula-depends-on *current-formula*)))))
      #+EAGER
      (let (dependency new-dependency-p slot-value)
	;; record the dependency
	(multiple-value-setq (dependency new-dependency-p)
	  (record-dependency schema slot *current-formula*))
    
	;; Now call G-VALUE to get the value from the slot. This will 
	;; also validate the slot if it was invalid
	(setf value (g-value schema slot))

	; determine if the priority of this slot is less than the
	; priority of the formula that has demanded the slot's value.
	; this can only happen if the dependency is a new one and
	; the value of a formula is being requested
	(when (and new-dependency-p
		   (formula-p (setf slot-value 
				    (get-value schema slot))))
	  (check-priority
	   dependency slot-value *current-formula* *eval-type*)))))
  ;; Now call G-VALUE to get the value from the slot.
  (g-value schema slot))
|#



#-EAGER
;;; This is the core of GV-FN, without the G-VALUE at the end.  It returns
;;; the schema itself (converting :SELF if necessary).
;;; 
(defun setup-dependency (schema slot value position)
  (unless (formula-p *current-formula*)
    (cerror "Return NIL"
	    " (in setup-dependency) ~S is not a formula!~%"
	    *current-formula*)
    (return-from setup-dependency NIL))
  (unless schema
    ;; A link is broken.  Get out of here!
    (broken-link-throw schema slot))
  ;; Record the link dependency for this parent and formula
  (let ((slots (schema-slots schema)))
    (when (eq value *no-value*)
      ;; make sure we have a place on which to hang the dependency!
      (set-slot-accessor schema slot NIL 0)
      (multiple-value-bind (v p)
	  (slot-accessor schema slot)
	(declare (ignore v))
	(setf position p))
      #+COMMENT
      (multiple-value-setq (value position)
	(slot-accessor schema slot)))
    (let ((dependents (last-slot-dependents slots position)))
      (unless (if (listp dependents)
		  (member *current-formula* dependents)
		  (eq *current-formula* dependents))
	;; add dependency
	(cond ((null dependents)
	       ;; Install dependency as a single value
	       (setf (aref slots (+ position 2)) *current-formula*))
	      ((listp dependents)
	       (push *current-formula* (aref slots (+ position 2))))
	      (t
	       ;; Was a single value, becomes list
	       (setf (aref slots (+ position 2))
		     (list *current-formula* dependents))))
	;; Check this only here - if the current formula was already in the
	;; list, then the reverse pointer would be already in place.
	(let ((depended (a-formula-depends-on *current-formula*)))
	  (cond ((null depended)
		 (setf (a-formula-depends-on *current-formula*) schema))
		((listp depended)
		 (unless (member schema depended)
		   (push schema (a-formula-depends-on *current-formula*))))
		(t
		 (unless (eq schema depended)
		   (setf (a-formula-depends-on *current-formula*)
			 (list schema depended)))))))))
  schema)



;;; RETURNS:
;;; T if the slot is not constant, i.e., it was not declared constant and we
;;; are not in the middle of a gv chain where the slot is declared a link
;;; constant.
;;;
(defun slot-is-not-constant (schema slot)
  (multiple-value-bind (value position)
      (slot-accessor schema slot)
    (let ((slots (schema-slots schema)))
      (or (and (eq value *no-value*)
	       ;;;;;;  ********* DOES THIS EVER HAPPEN?
	       (if position
		 ;; Slot may have been declared constant
		 (not (is-constant (last-slot-bits slots position)))
		 ;; We know nothing about the slot.  Is it inheritable?
		 T))
	  (let ((bits (last-slot-bits slots position)))
	    (not (or (is-constant bits)
		     (if *in-link-constant* (is-link-constant bits)))))))))



;;; in-link-constant???
;;;
(defun slot-is-constant (schema slot)
  (multiple-value-bind (value position)
      (slot-accessor schema slot)
    (declare (ignore value))
    (is-constant (last-slot-bits (schema-slots schema) position))))



;;; This is used for chains of slots (i.e., links) in GV/GVL.  It keeps
;;; accessing slots until the end of the link.  It is used when ALL the
;;; slot names are special slots.
;;;
(defun gv-chain (schema slot-descriptors)
  (do* ((s slot-descriptors (cdr s))
	(*in-link-constant* (cdr s) (cdr s)))	; null for last slot descr.
      ((null s))
    (if (null (setf schema (gv-value-fn schema (caar s) (cdar s))))
      (if (cdr s)
	(return (broken-link-throw schema (caar s))))))
  schema)


;;; There are non-special slots in the chain.
;;;
(defun gv-chain-nospecial (schema &rest slots)
  (do* ((s slots (cdr s))
	(*in-link-constant* (cdr s) (cdr s)))	; null for last slot descr.
       ((null s))
    (if (null (setf schema (gv-fn schema (car s))))
      (if (cdr s)
	(return (broken-link-throw schema (car s))))))
  schema)



(defun process-special-slots (slots)
  (mapcar #'(lambda (slot)
	      (cons slot (get slot :KR-FAST-ACCESSOR)))
	  slots))


(defun has-nonspecial-slot (slots)
  (find-if-not #'(lambda (slot)
		   (if (keywordp slot)
		       (get slot :KR-FAST-ACCESSOR)))
	       slots))


;;;; GV
;;; To be used in formulas.
;;; This macro expands into a chain of nested calls to gv-fn, which creates
;;; a dependency point in a formula.
;;;
(defmacro gv (schema &rest slots)
  (cond (slots
	 (when (and (keywordp schema)
		    (not (eq schema :SELF)))
	   (format
	    t "The first argument to GV must be an object: (gv ~S~{ ~S~})~%"
	    schema slots)
	   (break))
	 (let (slot)
	   (if (and (null (cdr slots))
		    (find (setf slot (car slots)) *schema-slots*))
	       ;; This is a GV with a single slot.  If this is one of the
	       ;; special slots, save a lot of time by using the macro for
	       ;; g-value
	     #-EAGER
	     `(gv-value-fn ,(if (eq schema :self)
				(setf schema '*schema-self*)
			      schema)
			   ,slot ,(get slot :KR-FAST-ACCESSOR))
	     #+EAGER
	     `(multiple-value-bind
	       (dependency new-dependency-p)
	       (record-dependency
		,(if (eq schema :self) (setf schema '*schema-self*) schema)
		,slot
		*current-formula*)
	       ;; enabling causes infinite loop  (g-value ,schema ,slot)
	       (let (slot-value)
		 (when (and new-dependency-p
			    (formula-p (setf slot-value
					     (get-value ,schema ,slot))))
		       (check-priority
			dependency slot-value *current-formula* *eval-type*)))
	       (g-value ,schema ,slot))
	     ;; this is the more general case
	     (if (has-nonspecial-slot slots)
	       ;; Some non-special slots
	       (if (cdr slots)
		 ;; Several slots.
		 `(gv-chain-nospecial ,schema ,@slots)
		 ;; One slot.
		 `(gv-fn ,schema ,@slots))
	       #+COMMENT
	       `(expand-accessor gv-fn ,schema ,@slots)
	       ;; All special slots
	       `(gv-chain ,(if (eq schema :self) '*schema-self* schema)
			  ',(process-special-slots slots))))))
	((eq schema :self)
	 `(progn *schema-self*))
	(t
	 `(progn ,schema))))




;;; Similar to GV-FN, but only gets local values.
;;; 
(defun gv-local-fn (schema slot)
  (gv-fn-body g-local-value))



;;;; GV-LOCAL
;;; To be used in formulas.
;;; This macro expands into a chain of nested calls to gv-local-fn, which
;;; creates a dependency point in a formula.
;;;
(defmacro gv-local (schema &rest slots)
  (cond (slots
	 `(expand-accessor gv-local-fn ,schema ,@slots))
	((eq schema :self)
	 `(progn *schema-self*))
	(t
	 `(progn ,schema))))



;;;; GVL
;;; To be used in formulas.
;;; This is equivalent to a call to GV with a :SELF added as the first
;;; parameter.
;;; 
(defmacro gvl (name &rest names)
  `(gv *schema-self* ,name ,@names))


;;; --------------------------------------------------



;;; This is the default invalidate demon.
;;; 
(defun invalidate-demon (schema slot save)
  (kr-send schema :UPDATE-DEMON schema slot save))




;;;; DESTROY-CONSTRAINT
;;; Replaces the formula in the <slot> with its value, physically eliminating
;;; the constraint.  If there is no formula, <schema> is unchanged.
;;; 
(defun destroy-constraint (schema slot)
  "If the value in the <slot> of the <schema> is a formula, replace it with
  the current value of the formula and eliminate the formula.  This
  effectively eliminates the constraint on the value."
  (multiple-value-bind (value position)
      (slot-accessor schema slot)
    (let ((formula (or value (g-value-inherit-values schema slot T position))))
      (when (and formula (formula-p formula)
		 (a-formula-slots formula))	; not already deleted
	(let ((value (g-cached-value schema slot)))
	  ;; All children formulas are eliminated as well.
	  (do-one-or-list (child (a-formula-is-a-inv formula))
	    (when (a-formula-slots child) ; do nothing if already deleted.
	      (g-value (on-schema child) (on-slot child))	; get value
	      (destroy-constraint (on-schema child) (on-slot child))))
	  ;; Inform dependents, even if value does not change.  This is
	  ;; for applications (such as C32) which need to know whether a
	  ;; formula is present.
	  (mark-as-changed schema slot)
	  (delete-formula formula)
	  #+EAGER
	  ;; set all dependency edges to be non-cycle edges since this
	  ;; position can no longer be part of a cycle
	  (dolist-test (dependent (get-formula-dependents formula)
				  (and (cycle-edge-p dependent)
				       (valid-dependency-p dependent)))
		       (set-cycle-edge-bit dependent nil))
	  ;; Replace formula with its cached value.
	  (set-slot-accessor schema slot value *local-mask*)
	  NIL)))))



;;; ---------------------------------------------- INITIALIZE THE WHOLE THING


;;;; INITIALIZE-KR
;;; 
;;; Call once at the beginning.
;;; 
(defun initialize-kr ()
  (setf *relations* nil)
  (setf *inheritance-relations* nil)
  #+EAGER
  ;; set up the priority list
  (init-priority-list)

  ;; Create the IS-A relation, which should come first in the list.
  (create-relation :IS-A T :IS-A-INV)
  ;; Create the default schema which controls the behavior of PS
  ;; 
  (create-schema 'PRINT-SCHEMA-CONTROL
    ;; Names of slots which should be printed out first, in the right order.
    (:sorted-slots :left :top :width :height)
    ;; A list of slots and maximum numbers.  If the number of values in a slot
    ;; exceed the limit, ellipsis will be printed.
    (:limit-values '(:IS-A-INV 5) '(:COMPONENTS 20))
    ;; Maximum limit for number of values (global).
    (:global-limit-values 10)))


(initialize-kr)




;;; --------------------------------------------------

;;; moved here because of a strange loading problem.

;;;; IS-A-P
;;; 
;;; Test whether <schema> IS-A <type>, either directly or indirectly.
;;; 
(defun is-a-p (schema type)
  "Tests whether the <schema> is linked via :IS-A to schema <type>, either
  directly or through several links.  Note that (is-a-p <schema> T) returns
  true if <schema> is a schema."

  (if (null schema)
    (return-from is-a-p (or (null type) (eq type T))))

  (if (formula-p schema)
    ;; A formula.
    (if (or (eq type T)
	    (eq schema type)
	    (eq (a-formula-is-a schema) type))
      T
      (is-a-p (a-formula-is-a schema) type))
    ;; A schema.
    (when (schema-p schema)
      (or (eq type T)			; (is-a-p any-schema T) is true
	  (eq schema type)		; (is-a-p foo foo) is true
	  (dolist (parent (g-value schema :IS-A))
	    (if (eq parent type)
	      (return-from is-a-p T)))
	  ;; Not directly in the list: how about the parents?
	  (dolist (parent (g-value schema :IS-A))
	    (if (is-a-p parent type)
	      (return-from is-a-p t)))))))



;;; Proclaim that the system was loaded successfully
;;;
(setf (get :garnet-modules :KR) t)
