;;;-*- Package: :multi-garnet; Syntax: Common-Lisp; Mode: Lisp -*-; 

(in-package :multi-garnet :nicknames '(:mg) :use '(:lisp :kr))

(export '(
	  m-constraint
	  m-stay-constraint
	  with-stays
	  with-slots-set
	  s-value-strength
	  propagate-plan-from-cn
	  create-plan
	  valid-plan-p
	  run-plan
	  enable-multi-garnet
	  disable-multi-garnet
	  multi-garnet-enabled
	  constraint-p
	  constraint-state
	  variable-state
	  clone-constraint
	  *default-input-strength*
	  *max-path-updates*
	  *max-path-updates-warning*
	  *sky-blue-backtracking-warning*
	  *sky-blue-cycle-warning*
	  *unsatisfied-required-constraint-warning*
	  *multi-garnet-version*
	  ))

(defvar *multi-garnet-version* "2.1")

(eval-when (load eval compile) (require :loop))

;; ***** "hook" (advise) facility *****

(eval-when (load eval compile)
  (defun get-save-fn-symbol-name (sym)
    (cond ((symbolp sym)
	   (intern (concatenate 'string (symbol-name sym) "-SAVE-FN-SYMBOL")
		   (find-package :multi-garnet)))
	  ((and (consp sym)
		(eq :quote (first sym))
		(symbolp (second sym)))
	   (get-save-fn-symbol-name (second sym)))
	  (t (cerror "cont" "get-save-fn-symbol-name: bad symbol ~S" sym))
	  ))
  )

(defun install-hook (fn hook)
  (let ((save-fn (get-save-fn-symbol-name fn)))
    (unless (fboundp save-fn)
      (setf (symbol-function save-fn)
	(symbol-function fn)))
    (setf (symbol-function fn)
      (symbol-function hook))))

(defun uninstall-hook (fn)
  (let ((save-fn (get-save-fn-symbol-name fn)))
    (if (fboundp save-fn)
	(setf (symbol-function fn) (symbol-function save-fn))
      (format t "~&warning: uninstall-hook: ~S fn never saved~%" fn))))

(defmacro call-hook-save-fn (fn &rest args)
  (let ((save-fn (get-save-fn-symbol-name fn)))
    `(,save-fn ,@args)))

;; ***** m-constraint macro used to construct constraint given method forms *****

;; examples:
;;  (m-constraint :strong ((yy (gvl :a)) (xx (gvl :a :b))) (setf yy xx))

(defmacro m-constraint (strength-spec var-specs &rest method-specs)
  (let* ((strength
	  (cond ((find strength-spec *strength-list*)
		 strength-spec)
		(t (error "bad strength in m-constraint: ~S" strength-spec))))
	 (var-names (loop for spec in var-specs collect
			  (if (symbolp spec) spec (first spec))))
	 (var-paths (loop for spec in var-specs collect
			  (cond ((symbolp spec)
				 (list
				  (intern (symbol-name spec)
					  (find-package :keyword))))
				((and (listp spec)
				      (listp (second spec))
				      (eql 'gvl (first (second spec))))
				 (cdr (second spec)))
				(t (error "bad var-specs in m-constraint")))))
         (method-output-var-name-lists
          (loop for spec in method-specs collect
                (let ((names (if (listp spec)
                               (if (listp (second spec))
                                 (second spec)
                                 (list (second spec))))))
                  (cond ((or (not (listp spec))
                             (not (eql 'setf (first spec))))
                         (error "bad method form in m-constraint: ~S" spec))
                        ((loop for varname in names
                               thereis (not (member varname var-names)))
                         (error "unknown var name in method form: ~S" spec)))
                  names)))
         (method-output-index-lists
	  (loop for var-name-list in method-output-var-name-lists collect
                (loop for varname in var-name-list collect
                      (position varname var-names))))
	 (method-forms
	  (loop for spec in method-specs
	      as output-var-names in method-output-var-name-lists
	      collect
		(if (null (cddr spec))
		    ;; if form is nil, this is a stay cn
		    nil
		  `(progn
		     ;; include output vars, to avoid "var never used" warnings
		     ,@output-var-names
		     ,@(cddr spec))
		  )))
	 (method-list-form
	  `(list ,@(loop for indices in method-output-index-lists
			 as form in method-forms
			 collect
			 `(create-method
			   :output-indices (quote ,indices)
			   :code ,(if form
				     `(function (lambda (cn)
						  (execute-m-constraint-method
						   cn (quote ,indices)
						   (function (lambda ,var-names ,form)))))
				    ;; if form is nil, this method is a stay.
				    '(function (lambda (cn) cn)))
			   ))))
	 (constraint-form
	  `(create-constraint
	    :strength ,strength
	    :methods ,method-list-form
	    :variable-paths (quote ,var-paths)))
	 )
    constraint-form))

;; handles stay specified as (m-stay-constraint :required box (gvl :a) (gvl :b :c))

(defmacro m-stay-constraint (strength-spec &rest var-specs)
  (let* ((var-names (loop for spec in var-specs collect
			  (if (symbolp spec) spec (gentemp))))
	 (full-var-specs (loop for name in var-names as spec in var-specs collect
			       (if (symbolp spec) spec (list name spec)))))
    `(let ((cn (m-constraint ,strength-spec ,full-var-specs (setf ,var-names))))
       (set-constraint-stay cn t)
       cn)))

(defun execute-m-constraint-method (cn output-var-indices method-code)
  (let* ((vars (CN-variables cn))
	 (var-values (loop for v in vars
		      collect (get-variable-value v)))
	 (output-values (multiple-value-list (apply method-code var-values))))
    (unless (= (length output-values) (length output-var-indices))
      (cerror "cont"
              "bad return vals from m-constraint ~S: ~S <- ~S"
              cn (selected-method-output-vars cn) output-values))
    (loop for index in output-var-indices
          as val in output-values
          do (set-variable-value (cn-index-to-var cn index)
                                 val))
    ))

;; ***** set-slot-basic macro *****

(defvar *invalidated-path-constraints* nil)

(defun constraint-in-obj-slot (cn obj slot)
  (let* ((os (cn-os cn)))
    (and os
	 (eql (os-object os) obj)
	 (eql (os-slot os) slot))))

(defmacro set-slot-basic (obj slot value
			   &key
			   (prohibit-constraints nil)
			   (auto-activate-constraints t)
			   (invalidate-paths t)
			   (s-value-fn-position-arg nil)
			   )
  (unless (and (member auto-activate-constraints '(nil t))
	       (member invalidate-paths '(nil t))
	       (member prohibit-constraints '(nil t)))
    (cerror "cont" "set-slot-basic: key vals should be t or nil"))
  (when (and prohibit-constraints auto-activate-constraints)
    (cerror "cont" "set-slot-basic: prohibit-constraints and auto-activate-constraints are both t"))
  `(let ((obj ,obj)
	 (slot ,slot)
	 (value ,value)
	 (position-arg ,s-value-fn-position-arg))
     ;; before checks
     
     ;; if prohibit-constraints=t, check that new and old values of slot are not constraints
     ,@(if prohibit-constraints
	   '(
	     (if (or (constraint-p value)
		     (constraint-p (get-local-value obj slot)))
		 (cerror "cont"
			 "can't set <~S,~S> to constraint" obj slot))
	     )
	 )

     ;; remove old constraint previously stored in slot
     ,@(if auto-activate-constraints
	   '(
	     ;; get old value using get-local-value, so we won't eval formula if one is stored in slot
	     (let ((old-value (get-local-value obj slot)))
	       (when (and (constraint-p old-value)
		      ;; only de-activate if this cn was activated for _this_ obj,slot
		      (constraint-in-obj-slot old-value obj slot))
		 (remove-constraint-from-slot obj slot old-value)))
	     )
	 )
	 
     ;; actually set object slot
     (call-hook-save-fn kr::s-value-fn obj slot value position-arg)
     
     ;; after checks
     
     ;; add new constraint in slot
     ,@(if auto-activate-constraints
	   '(
	     (when (and (constraint-p value)
			;; only auto-activate if os=nil
			(null (cn-os value)))
	       (add-constraint-to-slot obj slot value))
	     )
	 )
     ;; invalidate constraints whose paths use this slot
     ,@(if invalidate-paths
	   '(
	     (save-invalidated-path-constraints obj slot)
	     )
	 )
     
     value))

;; fn that sets slot only, by calling saved s-value-fn
(defun set-slot-no-checks (obj slot value)
  (set-slot-basic obj slot value
		  :prohibit-constraints nil
		  :auto-activate-constraints nil
		  :invalidate-paths nil
		  :s-value-fn-position-arg nil
		  ))


(defun add-constraint-to-slot (obj slot cn)
  (cond ((null (CN-variable-paths cn))
         ;; constraint is not a multi-garnet constraint, so don't auto-connect
         nil)
        ((CN-os cn)
         (error "shouldn't happen: can't add constraint ~S to <~S,~S>, already stored in <~S,~S>"
		cn obj slot (os-object (CN-os cn)) (os-slot (CN-os cn))))
        (t
         ;; set up constraint fields
         (setf (CN-os cn) (os obj slot))
         ;; activate new constraint
         (connect-add-constraint cn))
        ))

(defun remove-constraint-from-slot (obj slot cn)
  (declare (ignore obj slot))
  (cond ((null (CN-variable-paths cn))
         ;; constraint is not a multi-garnet constraint, so don't auto-connect
         nil)
        (t
         ;; remove old constraint
         (remove-disconnect-constraint cn)
         ;; clear constraint fields
         (setf (CN-os cn) nil))
        ))

(defun save-invalidated-path-constraints (obj slot)
  (setf *invalidated-path-constraints*
	(append (get-object-slot-prop obj slot :sb-path-constraints)
		*invalidated-path-constraints*)))

;; ***** hook into kr:s-value-n *****

;; This hook is used to cause (s-value obj <slot-with-sb-var> val) to
;; add&remove an edit constraint.  This also auto-activates a
;; constraint when it is stored in a slot.

;; default strength used when setting object slots using s-value
(defvar *default-input-strength* :strong)

(defun s-value-fn-hook (schema slot value position)
  (multi-garnet-s-value-fn schema slot value position *default-input-strength*))

(defun s-value-strength (obj slot value strength)
  (multi-garnet-s-value-fn obj slot value nil strength))

(defun multi-garnet-s-value-fn (schema slot value position input-strength)
  (if (eq slot :is-a)
      ;; don't trap KR inheritance manipulation.
      ;; do simple set, without worrying about cns or paths
      (set-slot-basic schema slot value
		      :auto-activate-constraints nil
		      :invalidate-paths nil
		      :s-value-fn-position-arg position)
    (let ((slot-var (get-object-slot-prop schema slot :sb-variable)))
      (cond ((and (constraint-p value)
		  ;; have to use inheritence to find if slot currently has formula
                  (formula-p (get-value schema slot)))
             (cerror "noop" "can't put sb constraint ~S in slot <~S,~S> with formula"
                     value schema slot))
	    ((and (formula-p value) slot-var)
	     (cerror "noop" "can't put formula ~S in sb variable slot <~S,~S>"
                     value schema slot))
	    ((and (formula-p value)
		  ;; use get-local-value: cn must be copied down explicitly
                  (constraint-p (get-local-value schema slot)))
	     (cerror "noop" "can't put formula ~S in sb constraint slot <~S,~S>"
                     value schema slot))
	    ((and (formula-p value)
		  (get-object-slot-prop schema slot :sb-path-constraints))
	     (cerror "noop" "can't put formula ~S in sb constraint path slot <~S,~S>"
                     value schema slot))
	    (slot-var
	     ;; set the value of a sb-variable by adding and removing a strong constraint
	     ;; (note that this implies that the set may not happen if the var's walkabout
	     ;; strength is strong enough)
	     (set-input-variable slot-var value input-strength)
	     )
	    (t
	     ;; slot not an sb slot, so do normal set
	     (set-slot-basic schema slot value
			     :auto-activate-constraints t
			     :invalidate-paths t
			     :s-value-fn-position-arg position)
	     ))
      (update-invalidated-paths-and-formulas)
      ))
  value)

;; note: we purposely don't trap calls to set slots when objects are
;; created (in fns kr::internal-s-value and kr::internal-add-value) because
;; the constraints are activated when activate-new-instance-cns is called
;; after the object is created.  This also ensures that any slots that are
;; set in a call to create-instance are set before any of the cns for that
;; object are added.

;; ***** hook into inheritence mechanism to inherit constraints *****

;; want to copy down constraints after all other initialization is done.
;; (note: if CLOS-style :after methods were supported, I'd put this as an
;;        after method of the top object initialization method)

(defun kr-call-initialize-method-hook (schema slot)
  (call-hook-save-fn kr::kr-call-initialize-method schema slot)
  (when (eql slot :initialize)
    (copy-down-and-activate-constraints schema)))

(defun kr-init-method-hook (schema the-function)
  (call-hook-save-fn kr::kr-init-method schema the-function)
  (copy-down-and-activate-constraints schema))

(defun copy-down-and-activate-constraints (schema)
  (copy-down-mg-constraints schema)
  (activate-new-instance-cns schema)
  (update-invalidated-paths-and-formulas)
  )

;; copies down cns from parent, _without_ activating them
(defun copy-down-mg-constraints (schema)
  (let ((parent (car (get-value schema :is-a))))
    (when parent
      (let ((local-only-slots (get-values parent :LOCAL-ONLY-SLOTS)))
	(doslots (slot parent)
		 (when (and (not (eq slot :is-a))
			    (not (member slot local-only-slots))
			    (not (has-slot-p schema slot))
			    (constraint-p (get-local-value parent slot))
			    (constraint-in-obj-slot (get-local-value parent slot) parent slot))
		   (set-slot-basic schema slot
				   (clone-constraint (get-local-value parent slot))
				   :auto-activate-constraints nil
				   :invalidate-paths t)
		   ))
	))))

;; activates all cns in new instance (which all should be unconnected)
(defun activate-new-instance-cns (schema)
  (doslots
   (slot schema)
   (let ((value (get-local-value schema slot)))
     (cond ((not (constraint-p value))
	    nil)
	   ((not (null (CN-os value)))
	    ;; inherited cn that belongs to another os
	    nil)
	   ((cn-connection-p value :unconnected)
	    (add-constraint-to-slot schema slot value))
	   (t
	    (cerror "don't activate cn" "initializing <~S,~S>: found connected cn ~S with os ~S"
		    schema slot value (CN-os value)))
	   ))))

;; ***** hook into move-grow-interacter and two-point-interactor to set :box or :points slot *****

;; hook to force move-grow-interacter and two-point-interactor to set :box or :points slot
;; (hence calling constraint solver) rather than destructively changing the list.
(defun set-obj-list4-slot-no-db-hook (obj slot new-list4)
  (let* ((var (get-object-slot-prop obj slot :sb-variable))
	 (strength *default-input-strength*))
    (cond ((null var)
	   ;; no var for slot: just change value
	   (call-hook-save-fn inter::set-obj-list4-slot-no-db obj slot new-list4))
	  (t
	   ;; _may_ be able to set slot.  Try setting to copy of new list.
	   (set-input-variable var (copy-list new-list4) strength))
	  )
    new-list4))


;; ***** fns to destroy slots and schemas (experimental) *****

(defun destroy-slot-hook (schema slot)
  (let ((invalid-cns nil)
	(invalid-vars nil)
	(val (get-local-value schema slot))
	(var (get-object-slot-prop schema slot :sb-variable)))
      ;; remove constraint in slot
    (when (and (constraint-p val)
	       (constraint-in-obj-slot val schema slot))
      (remove-constraint-from-slot schema slot val))
    ;; find all constraints that use this slot
    (setq invalid-cns (get-object-slot-prop schema slot :sb-path-constraints))
    ;; find any var in this slot
    (when var
      (setq invalid-cns (append (VAR-constraints var) invalid-cns))
      (push var invalid-vars))
    ;; remove invalid constraints
    (loop for cn in invalid-cns do (remove-disconnect-constraint cn))
    ;; flush invalid vars
    (loop for var in invalid-vars do
	  (setf (CN-os var) nil))
    ;; actually destroy the slot
    (call-hook-save-fn kr::destroy-slot schema slot)
    ;; try reconnecting the invalid constraints
    (loop for cn in invalid-cns do (connect-add-constraint cn))
    ))

(defun destroy-schema-hook (schema &optional (send-destroy-message NIL) recursive-p)
  (let ((invalid-cns nil)
	(invalid-vars nil))
    (when (schema-p schema)
      ;; remove constraints in slots in this obj
      (doslots
       (slot schema)
       (let ((val (get-local-value schema slot)))
	 (when (and (constraint-p val)
		    (constraint-in-obj-slot val schema slot))
	   (remove-constraint-from-slot schema slot val))
	 ))
      ;; find all constraints that use slots in this object
      (doslots
       (slot schema)
       (let* ((var (get-object-slot-prop schema slot :sb-variable))
	      (cns (get-object-slot-prop schema slot :sb-path-constraints)))
	 (setq invalid-cns (append cns invalid-cns))
	 (when var
	   (setq invalid-cns (append (VAR-constraints var) invalid-cns))
	   (push var invalid-vars))
	 ))
      ;; remove invalid constraints
      (loop for cn in invalid-cns do (remove-disconnect-constraint cn))
      ;; flush invalid vars
      (loop for var in invalid-vars do
	    (setf (CN-os var) nil))
      ;; actually destroy the schema
      (call-hook-save-fn kr::destroy-schema schema send-destroy-message recursive-p)
      ;; try reconnecting the invalid constraints
      (loop for cn in invalid-cns do (connect-add-constraint cn))
      )))

;; *** connecting and disconnecting constraints utilities *****

(defun connect-add-constraint (cn)
  (when (and (os-p (cn-os cn))
	     (cn-connection-p cn :unconnected))
    (connect-constraint cn))
  (when (cn-connection-p cn :connected)
    (mg-add-constraint cn))
  )

(defun remove-disconnect-constraint (cn)
  (when (cn-connection-p cn :graph)
    (mg-remove-constraint cn))
  (when (and (os-p (cn-os cn))
	     (or (cn-connection-p cn :connected)
		 (cn-connection-p cn :broken-path)))
    ;; if cn is not stored in an object slot
    ;; (like input cns, with-stays cns),
    ;; no need to disconnect.
    (disconnect-constraint cn))
  )

(defun connect-constraint (cn)
  (let* ((cn-os (CN-os cn))
	 (cn-var-paths (CN-variable-paths cn)))
    (cond ((not (cn-connection-p cn :unconnected))
	   (cerror "noop" "trying to connect constraint ~S with connection ~S"
		   cn (CN-connection cn))
	   nil)
	  (t
	   (let* ((root-obj (os-object cn-os))
		  (cn-path-links nil)
		  (paths-broken nil)
		  var-os-list)
	     ;; follow paths to get os-list for vars,
	     ;; while setting up dependency links
	     (setf var-os-list
	       (loop for path in cn-var-paths collect
		 (let ((obj root-obj))
		   (loop for (slot next-slot) on path do
		     ;; if at end of path, return os to final slot
		     (when (null next-slot)
		       (return (os obj slot)))
		     ;; at link slot: set up dependency and back ptrs
		     (set-object-slot-prop obj slot :sb-path-constraints
					   (adjoin cn (get-object-slot-prop
						       obj slot :sb-path-constraints)))
		     (push (os obj slot) cn-path-links)
		     ;; check that path slot doesn't contain local formula
		     ;; (doesn't matter if inherited slot contains formula,
		     ;; since we copy down value.)
		     ;;  << formula check removed >>
		     ;; make sure that value is copied down, so we detect changes
		     (copy-down-slot-value obj slot)
		     ;; ...and continue to next step on path
		     (setf obj (g-value obj slot))
		     ;; if next obj is not a schema, path is broken
		     (when (not (schema-p obj))
		       (setf paths-broken t)
		       (return nil))
		     ))))
	     ;; update ptrs from constraint to links
	     (setf (CN-path-slot-list cn) cn-path-links)
	     ;; iff no paths are broken, find/alloc vars
	     (cond (paths-broken
		    ;; some paths are broken.
		    ;; don't alloc vars.
		    (setf (CN-variables cn) nil)
		    (setf (CN-connection cn) :broken-path))
		   (t
		    ;; all paths unbroken, find/alloc vars
		    (setf (CN-variables cn)
		      (loop for var-os in var-os-list
		       collect (get-os-var var-os)))
		    (setf (CN-connection cn) :connected)))
	     )))
    ))

(defun disconnect-constraint (cn)
  (let* ()
    (when (cn-connection-p cn :graph)
      (cerror "cont" "trying to disconnect constraint ~S with connection ~S"
              cn (CN-connection cn)))
    (loop for path-os in (CN-path-slot-list cn) do
      (set-os-prop path-os :sb-path-constraints
		   (remove cn (get-os-prop path-os :sb-path-constraints))))
    (setf (CN-path-slot-list cn) nil)
    (setf (CN-variables cn) nil)
    (setf (CN-connection cn) :unconnected)
    ))

;; ***** marking invalid formulas *****

(defvar *invalidated-formulas* nil)

(in-package :kr)

;; this hook is essentially a complete copy of kr::propagate-change,
;; because we need to make changes in the middle, to stop propagation when
;; we reach a constrained variable.  We define it in package :kr, since it
;; calls so many kr-internal fns and macros.

(defun mg::propagate-change-hook (schema slot)
  ;; (declare (optimize (speed 3)))
  (multiple-value-bind (value position)
      (slot-accessor schema slot)	; set accessors
    (declare (ignore value))
    ;; access the dependent formulas.
    (let ((slots (kr::schema-slots schema)))
      (do-one-or-list (formula (last-slot-dependents slots position))
	;; Stop propagating if this dependent formula was already marked dirty.
	(block stop-propagation
	  (when (cache-is-valid formula)
	    (let* ((new-schema (on-schema formula))
		   (new-slot (on-slot formula))
		   (schema-ok (schema-p new-schema)))
	      (unless (and new-schema new-slot)
		(when *warning-on-disconnected-formula*
		  (format
		   t
		   "Warning - disconnected formula ~S in propagate-change ~S ~S~%"
		   formula schema slot))
		(return-from stop-propagation NIL))
	      (cond ((and schema-ok
			  (or (mg::get-object-slot-prop new-schema new-slot :sb-variable)
			      (mg::get-object-slot-prop new-schema new-slot :sb-path-constraints)))
		     ;; we want to invalidate a formula that sets a constrained slot or a path slot.
		     ;; do not invalidate or propagate further: save ptr to formula to eval later
		     (push formula mg::*invalidated-formulas*)
		     (return-from stop-propagation NIL))
		    (schema-ok
		     (run-invalidate-demons new-schema new-slot))
		    (t
		     #+COMMENT		; #+GARNET-DEBUG
		     (progn
		       (format
			t
			"propagate-change: formula ~S on destroyed object ~S ~S~%    ~
	from change in schema ~S, slot ~S.~%"
			formula new-schema new-slot schema slot))))
	      ;; The formula gets invalidated here.
	      (set-cache-is-valid formula nil)
	      ;; Notify all children who used to inherit the old value of the
	      ;; fmla.
	      (if schema-ok
		  (multiple-value-bind (new-value position)
		      (slot-accessor new-schema new-slot)
		    (unless (eq new-value *no-value*)
		      (let* ((slots (schema-slots new-schema)) 
			     (new-bits (last-slot-bits slots position))
			     (dependents (last-slot-dependents slots position)))
			#+TEST
			(if (is-inherited new-bits)
			    (update-inherited-internal new-schema new-slot
						       new-value new-bits))
			(if (is-parent new-bits)
			    (let ((value (slot-accessor schema slot)))
			      (if (not (eq value *no-value*))
				  (update-inherited-values
				   new-schema new-slot new-value T))))
			;; Now recurse, following the slot in the schema on which
			;; the formula sits.
			(if dependents
			    (propagate-change new-schema new-slot)))))))))))))

(in-package :multi-garnet)

;; ***** updating invalidated paths and formulas *****

(defvar *max-path-updates* 10)

(defvar *save-invalidated-path-constraints* nil)
(defvar *save-invalidated-formulas* nil)

(defvar *max-path-updates-warning* t)

(defvar *path-update-loop-warning* nil)

(defun update-invalidated-paths-and-formulas ()
  (let () 
    ;;  Repeatedly update any constraints whose paths may have been
    ;; invalidated, and invalidated formulas on constrained variables.
    ;; This process may cause other paths or formulas to be invalidated, so
    ;; repeat until no other paths are invalidated.  If this is repeated
    ;; more than *max-path-updates* times, this indicates that there may
    ;; be a cycle: break, and optionally continue.
    (loop for invalidation-count from 1 to *max-path-updates*
	while (or *invalidated-path-constraints*
		  *invalidated-formulas*)
	do (when (or (eql *path-update-loop-warning* t)
		     (and (numberp *path-update-loop-warning*)
			  (>= invalidation-count *path-update-loop-warning*)))
	     (format t "~&update loop ~S: invalid paths= ~S, invalid formulas= ~S~%"
		     invalidation-count *invalidated-path-constraints* *invalidated-formulas*))
	   (update-invalidated-path-constraints)
	   (update-invalidated-formulas))
    (when (or *invalidated-path-constraints*
	      *invalidated-formulas*)
      ;; we have looped too many times: assume that there is an infinite loop.
      ;; Print warning, and save remaining unresolved cns and formulas
      (cond ((eql *max-path-updates-warning* :error)
	     (cerror
	      "clear lists of invalidated constraints and formulas"
	      "updated paths and formulas ~S times without resolving invalidated constraints ~S and formulas ~S"
	      *max-path-updates* *invalidated-path-constraints* *invalidated-formulas*)
	     )
	    (*max-path-updates-warning*
	     (format
	      t
	      "~&updated paths and formulas ~S times without resolving invalidated constraints ~S and formulas ~S:  clearing lists~%"
	      *max-path-updates* *invalidated-path-constraints* *invalidated-formulas*)
	     )
	    )
      (setf *save-invalidated-path-constraints* *invalidated-path-constraints*)
      (setf *invalidated-path-constraints* nil)
      (setf *save-invalidated-formulas* *invalidated-formulas*)
      (setf *invalidated-formulas* nil))
    ))

(defun update-invalidated-path-constraints ()
  (let* ((path-constraints
	  (remove-duplicates *invalidated-path-constraints*)))
    ;; may invalidate other paths during this process -- record
    (setf *invalidated-path-constraints* nil)
    (when path-constraints
      (loop for cn in path-constraints do
	    (remove-disconnect-constraint cn)
	    (connect-add-constraint cn)
	    ))
    ))

;; The function update-invalidated-formulas updates all of the invalid
;; formulas in *invalidated-formulas*, as well as any formulas on
;; constrained slots that are invalidated when these formulas are updated,
;; etc.  This is done recursively here, rather than waiting for the loop in
;; update-invalidated-paths-and-formulas to call this repeatedly, because
;; of the possibility that there might be a ligitimate long chain of
;; formulas on constrained slots.  One difficulty is that we have to take
;; care of possible cycles of formulas.  We don't want to go into an
;; infinite loop.  This is handled by keeping a list of updated formulas,
;; and not updating a formula if it was already updated "upstream" of this
;; formula.  Since there are only a finite number of formulas, this will
;; terminate.  Another difficulty is that it is possible that we may update
;; particular formulas more than once.  For example, if formula A is a root
;; formula, and A->B and A->C and B->D and C->D, we may update formula D
;; twice, when going down each of the paths.  It isn't possible to do
;; clever planning to figure out the right order so that there is no
;; duplication, since we don't necessarily know whether each formula
;; updating will actually "take", updating the slot value, or whether other
;; constraints will override the formula input constraint.

(defun update-invalidated-formulas ()
  (let* ((root-formulas *invalidated-formulas*))
    (setf *invalidated-formulas* nil)
    (loop for (formula . more-roots) on root-formulas
	do (recursively-update-formulas formula more-roots))
    ))

(defun recursively-update-formulas (formula done) 
  ;; break recursion if this formula is a member of done, which includes all
  ;; formulas we have updated (in which case there is a loop), as well as
  ;; formulas we know that we are going to update later.
  (unless (member formula done)
    (update-invalidated-formula formula)
    (let ((new-invalid-formulas *invalidated-formulas*)
	  (new-done (cons formula done)))
      (setf *invalidated-formulas* nil)
      (loop for child-formula in new-invalid-formulas
	  do (recursively-update-formulas child-formula new-done))
      )
    ))

(defun update-invalidated-formula (formula)
  (let* ((new-schema (kr::on-schema formula))
	 (new-slot (kr::on-slot formula))
	 (schema-ok (schema-p new-schema)))
    (when schema-ok
      (let* ((var (get-object-slot-prop new-schema new-slot :sb-variable)))
	(if var
	    (add-remove-formula-recomputing-constraint var)
	  (recompute-formula-saving-paths new-schema new-slot))))
    ))

(defun recompute-formula-saving-paths (schema slot)
  ;; increment sweep-mark, so formula doesn't erronously detect circularities
  (incf kr::*sweep-mark* 2)
  (kr::recompute-formula schema slot)
  (save-invalidated-path-constraints schema slot)
  )

(defvar *formula-set-strength* :strong)

(defun add-remove-formula-recomputing-constraint (var)
  (when (weaker (VAR-walk-strength var)
		(get-strength *formula-set-strength*))
    ;; we _may_ be able to set variable, because the the var walkstrength
    ;; is low.  however, still may not be able to set, because of interactions
    ;; of multi-output cns.  Just add&remove cn to set value.
    (let* ((cn (create-formula-recomputing-constraint var *formula-set-strength*)))
      (mg-add-constraint cn)
      (mg-remove-constraint cn)
      (dispose-formula-recomputing-constraint cn))
    ))

(defvar *formula-recomputing-constraint-reserve* nil)

;; dummy for input var os

(defun create-formula-recomputing-constraint (var strength)
  (let* ((cn (if *formula-recomputing-constraint-reserve*
		 (pop *formula-recomputing-constraint-reserve*)
	       (create-constraint
		:methods (list (create-method
				:code #'(lambda (cn)
					  (let* ((var (cn-index-to-var cn 0))
						 (os (VAR-os var))
						 (obj (OS-object os))
						 (slot (OS-slot os)))
					    (recompute-formula-saving-paths obj slot)
					    ))
				:output-indices '(0))
			       )
		;; create dummy os, so we won't accidently activate
		;; this cn by storing it in an object slot.
		:os (os nil nil)
		))))
    (setf (CN-variables cn) (list var))
    (setf (CN-strength cn) (get-strength strength))
    (setf (CN-connection cn) :connected)
    cn))

(defun dispose-formula-recomputing-constraint (cn)
  (push cn *formula-recomputing-constraint-reserve*))


;; ***** OS manipulation *****

(defun get-os-prop (os prop)
  (get-object-slot-prop
   (os-object os) (os-slot os) prop))

(defun get-object-slot-prop (obj slot prop)
  (getf (getf (g-local-value obj :sb-os-props)
	      slot nil)
	prop nil))

;; version of get-object-slot-prop for use in formulas,
;; that calls kr::gv-gn to tell kr that  it is
;; accessing :sb-os-props
(defun gv-object-slot-prop (obj slot prop)
  (kr::gv-fn obj :sb-os-props)
  (get-object-slot-prop obj slot prop))

(defun set-os-prop (os prop val)
  (set-object-slot-prop
   (os-object os) (os-slot os) prop val))

(defun set-object-slot-prop (obj slot prop val)
  ;; let's catch constraints on the innards of sb-objects.
  ;; eventually, may want to allow such meta-constraints,
  ;; but not now
  (when (sb-object-p obj)
    (cerror "cont" "trying to set os-prop of ~S, slot ~S, prop ~S"
            obj slot prop))
  (set-object-slot-prop-basic obj slot prop val)
  val)

(defun set-object-slot-prop-basic (obj slot prop val)
  (let* ((os-props (g-local-value obj :sb-os-props))
	 (slot-props (getf os-props slot nil)))
    (setf (getf slot-props prop) val)
    (setf (getf os-props slot) slot-props)
    (set-slot-no-checks obj :sb-os-props os-props)
    ;; mark props slot as changed, so debugger can
    ;; make (slow) displays depend on os props
    (mark-as-changed obj :sb-os-props)
    val))

(defun get-os-val (os)
  (g-value (os-object os) (os-slot os)))

(defun get-os-var (os)
  (get-object-slot-var (os-object os) (os-slot os)))

(defun get-object-slot-var (obj slot)
  (let ((var (get-object-slot-prop obj slot :sb-variable)))
    (when (null var)
      (setq var (create-object-slot-var obj slot)))
    var))

(defun create-object-slot-var (obj slot)
  (cond ;; << formula check removed >>
   ((sb-object-p obj)
    (error "can't put variable on slot in sky-blue object: <~S,~S>"
	    obj slot))
   (t
    (let ((var (create-variable :os (os obj slot))))
      (set-object-slot-prop obj slot :sb-variable var)
      (copy-down-slot-value obj slot)
      var))))

;; this fn is called when a sb-var is created, or a slot is used
;; on a constraint path, to copy down the slot value, if it is
;; inherited.  This allows us to detect when the value is changed.
(defun copy-down-slot-value (obj slot)
  (unless (has-slot-p obj slot)
    (with-constants-disabled
	(set-slot-basic
	 obj slot (g-value obj slot)
	 :prohibit-constraints t
	 :auto-activate-constraints nil
	 :invalidate-paths nil))))

(defun has-object-slot-var (obj slot)
  (get-object-slot-prop obj slot :sb-variable))

;; entries for accessing a variable value

(defun get-variable-value (var)
  (get-os-val (VAR-os var)))

(defun set-variable-value (var val)
  (let* ((os (VAR-os var))
	 (obj (os-object os))
	 (slot (os-slot os)))
    (with-constants-disabled
	(set-slot-basic
	 obj slot val
	 :prohibit-constraints t
	 :auto-activate-constraints nil
	 :invalidate-paths t))))

;; ***** entries for setting a variable by adding/removing a stay constraint *****

(defun set-input-variable (v val strength)
  (when (weaker (VAR-walk-strength v)
		(get-strength strength))
    ;; we _may_ be able to set variable, because the the var walkstrength
    ;; is low.  however, still may not be able to set, because of interactions
    ;; of multi-output cns.  Just add&remove cn to set value.
    (let* ((cn (create-variable-input v val strength)))
      (mg-add-constraint cn)
      (mg-remove-constraint cn)
      (dispose-variable-input cn)
      (update-invalidated-paths-and-formulas)))
  val)

;; ***** fns for managing reserves of simple input and stay constraints *****

(defvar *variable-input-reserve* nil)

(defun create-variable-input (v val strength)
  (let* ((cn (if *variable-input-reserve*
		 (pop *variable-input-reserve*)
	       (create-constraint
		:methods (list (create-method
				:code #'(lambda (cn)
					  (set-variable-value
					   (cn-index-to-var cn 0)
					   #+:mg-structure-rep (CN-input-value cn)
					   #-:mg-structure-rep (g-value cn :variable-input-value)
					   ))
				:output-indices '(0))
			       )
		;; create dummy os, so we won't accidently activate
		;; this cn by storing it in an object slot.
		:os (os nil nil)
		))))
    #+:mg-structure-rep (setf (CN-input-value cn) val)
    #-:mg-structure-rep (set-sb-slot cn :variable-input-value val)
    (setf (CN-variables cn) (list v))
    (setf (CN-strength cn) (get-strength strength))
    (setf (CN-connection cn) :connected)
    cn))

(defun dispose-variable-input (cn)
  (push cn *variable-input-reserve*))

(defvar *variable-stay-reserve* nil)

(defun create-variable-stay (v strength)
  (let* ((stay (if *variable-stay-reserve*
		   (pop *variable-stay-reserve*)
		 (create-stay-constraint
		  :methods (list (create-method
				  :code #'(lambda (cn) cn)
				  :output-indices '(0))
				 )
		  ;; create dummy os, so we won't accidently activate
		  ;; this cn by storing it in an object slot.
		  :os (os nil nil)
		  ))))
    (setf (CN-variables stay) (list v))
    (setf (CN-strength stay) (get-strength strength))
    (setf (CN-connection stay) :connected)
    stay))

(defun dispose-variable-stay (stay)
  (push stay *variable-stay-reserve*))

;; ***** entry for enforcing stays during the executing of a form *****

(defmacro with-stays (obj-stay-list &rest forms)
  (let* ((cns-var (gentemp))
	 (val-var (gentemp)))
    `(let* ((,cns-var ,`(stay-spec-to-cns (list ,@(loop for lst in obj-stay-list
						      collect `(list ,@lst)))))
	    (,val-var nil))
       (unwind-protect
	   (progn
	     (add-variable-stays ,cns-var)
	     (setf ,val-var (progn ,@forms)))
	 (remove-dispose-variable-stays ,cns-var))
       ,val-var)))

(defun add-variable-stays (cns)
  (loop for cn in cns do
    (mg-add-constraint cn)))

(defun remove-dispose-variable-stays (cns)
  (loop for cn in cns do
	(mg-remove-constraint cn)
	(dispose-variable-stay cn)))

(defun stay-spec-to-cns (stay-spec-list)
  (loop for (obj slot strength) in stay-spec-list
   collect (create-variable-stay
	    (get-object-slot-var obj slot)
	    (if strength strength *default-input-strength*))))

;; ***** entry for setting slots with specified strengths during the executing of a form *****

(defmacro with-slots-set (obj-set-list &rest forms)
  (let* ((cns-var (gentemp))
	 (val-var (gentemp)))
    `(let* ((,cns-var ,`(with-set-spec-to-cns (list ,@(loop for lst in obj-set-list
							  collect `(list ,@lst)))))
	    (,val-var nil))
       (unwind-protect
	   (progn
	     (add-with-set-cns ,cns-var)
	     (setf ,val-var (progn ,@forms)))
	 (remove-dispose-with-set-cns ,cns-var))
       ,val-var)))

(defun add-with-set-cns (cns)
  (loop for cn in cns do
    (mg-add-constraint cn)))

(defun remove-dispose-with-set-cns (cns)
  (loop for cn in cns do
	(mg-remove-constraint cn)
	(dispose-variable-input cn)))

(defun with-set-spec-to-cns (spec-list)
  (loop for (obj slot value strength) in spec-list
   collect (create-variable-input
	    (get-object-slot-var obj slot)
	    value
	    (if strength strength *default-input-strength*))))

;; ***** interface to sky-blue add-constraint and remove-constraint *****

(defvar *unsatisfied-required-constraint-warning* t)

(defun mg-add-constraint (cn)
  (when (not (cn-connection-p cn :connected))
    (cerror "cont" "trying to add constraint ~S with connection ~S"
            cn (CN-connection cn)))
  (add-constraint cn)
  (cond ((and (not (enforced cn))
              (eq *required-strength* (CN-strength cn)))
         ;; We couldn't enforce a newly-added required constraint.
	 ;; There must be a req-req conflict.  Print msg.
	 ;; note: we don't remove the cn, so it may become satisfied later
	 ;; when another required cn is removed.
         (when *unsatisfied-required-constraint-warning*
	     (format t "~&Warning: Can't enforce required constraint ~S on object ~S, slot ~S~%"
		     cn (OS-object (g-value cn :os)) (OS-slot (g-value cn :os))))
	 ))
  ;; note that cn is in graph, even if it is an unsat req cn
  (setf (CN-connection cn) :graph)
  cn)

(defun mg-remove-constraint (cn)
  (when (not (cn-connection-p cn :graph))
    (cerror "cont" "trying to remove constraint ~S with connection ~S"
            cn (CN-connection cn)))
  (remove-constraint cn)
  (setf (CN-connection cn) :connected)
  cn)

;; ***** experimental fn to access plans *****

(defun invalidate-plans-on-setting-method (cn old-mt new-mt)
  (declare (ignore old-mt))
  (let ((plans (copy-list (get-sb-slot cn :valid-plans))))
    (when new-mt
      (let ((out-vars (method-output-vars cn new-mt)))
	(loop for var in (CN-variables cn)
	    unless (member var out-vars)
	    do (let ((input-cn (VAR-determined-by var)))
		 (when input-cn
		   (setq plans (append (get-sb-slot input-cn :valid-plans)
				       plans))))
	       )
	))
    (loop for plan in plans do
	  (invalidate-plan plan))
    ))

(defun validate-plan (plan)
  (let* ()
    (setf (getf plan :valid-plan nil) t)
    (loop for cn in (append (getf plan :invalid-cns nil)
			    (getf plan :root-cns nil)
			    (getf plan :valid-cns nil))
	do (set-sb-slot cn :valid-plans
			(cons plan (get-sb-slot cn :valid-plans))))
    plan))

(defun invalidate-plan (plan)
  (let* ()
    (setf (getf plan :valid-plan nil) nil)
    (loop for cn in (append (getf plan :invalid-cns nil)
			    (getf plan :root-cns nil)
			    (getf plan :valid-cns nil))
	do (set-sb-slot cn :valid-plans
			(remove plan (get-sb-slot cn :valid-plans))))
    plan))

(defun create-plan (cns)
  (let* ((plan (extract-plan-from-constraints cns)))
    (setf (getf plan :root-cns nil) cns)
    (setq plan (validate-plan plan))
    plan))

(defun valid-plan-p (plan)
  (getf plan :valid-plan nil))

(defun run-plan (plan)
  (cond ((valid-plan-p plan)
	 (execute-plan plan)
	 (update-invalidated-paths-and-formulas))
	(t
	 (cerror "noop" "can't run invalidated plan: ~S" plan))))

(defun propagate-plan-from-cn (cn)
  (let* ((plan (g-value cn :cached-plan)))
    (unless (valid-plan-p plan)
      ;; we have to create the plan
      (setq plan (create-plan (list cn)))
      (s-value cn :cached-plan plan))
    (run-plan plan)
    cn))

;; ***** fns to access state of constraints and variables *****

(defun constraint-state (cn)
  (if (constraint-p cn)
    (values (CN-connection cn)
	    (not (null (enforced cn)))
	    (OS-object (CN-os cn))
	    (OS-slot (CN-os cn)))))

(defun variable-state (obj slot)
  (let* ((var (get-object-slot-prop obj slot :sb-variable))
	 (var-p (variable-p var))
	 (valid-p (if var-p (VAR-valid var) nil))
	 (path-slot-p (not (null (get-object-slot-prop obj slot :sb-path-constraints)))))
    (values var-p valid-p path-slot-p)))

;; ***** fns used to access internal slots of sb objects represented by kr objects *****

(defun get-sb-slot (obj slot)
  (g-value obj slot))

(defun set-sb-slot (obj slot val)
  ;; when selected method of constraint is set, may need to invalidate plans
  (when (and (eql slot :selected-method)
	     (constraint-p obj))
    (invalidate-plans-on-setting-method obj (g-value obj :selected-method) val))
  ;; Set slot, _without_ activating constraints or invalidating paths.
  ;; This means that constraints shouldn't reference internal SkyBlue slots.
  (set-slot-no-checks obj slot val)
  val)

;; ***** fns to enable and disable multi-garnet hooks into garnet fns *****

(defvar *fn-to-hook-plist* '(kr::s-value-fn                   s-value-fn-hook
			     kr::kr-call-initialize-method    kr-call-initialize-method-hook
			     kr::kr-init-method               kr-init-method-hook
			     inter::set-obj-list4-slot-no-db  set-obj-list4-slot-no-db-hook
			     kr::destroy-schema               destroy-schema-hook
			     kr::destroy-slot                 destroy-slot-hook
			     kr::propagate-change             propagate-change-hook))

(defun enable-multi-garnet ()
  (loop for (fn hook-fn) on *fn-to-hook-plist* by #'CDDR do
	(install-hook fn hook-fn)))

(defun disable-multi-garnet ()
  (loop for (fn hook-fn) on *fn-to-hook-plist* by #'CDDR do
	(uninstall-hook fn)))

(defun multi-garnet-enabled ()
  (loop for (fn hook-fn) on *fn-to-hook-plist* by #'CDDR
      always (eql (symbol-function fn) (symbol-function hook-fn))))

