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

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

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

;; Sky-Blue Entry Points

(defun add-constraint (cn)
  (let ()
    (setf (CN-selected-method cn) nil)
    (setf (CN-mark cn) nil)
    (loop for v in (CN-variables cn) do
      (push cn (VAR-constraints v)))
    (enforce-constraint-list (list cn) nil)
    cn))

(defun remove-constraint (cn)
  (loop for v in (CN-variables cn) do
        (setf (VAR-constraints v)
              (remove cn (VAR-constraints v))))
  (cond ((enforced cn)
	 (let* ((out-vars (selected-method-output-vars cn))
		unenforced)
	   (un-determine-unmarked-vars out-vars nil)
	   (setf (CN-selected-method cn) nil)
	   (propagate-vars-walkstrength out-vars)
	   (setq unenforced (collect-unenforced out-vars))
	   (enforce-constraint-list unenforced out-vars)
	   ))
	)
  cn)

;; enforce-constraint-list tries to enforce each of a list of cns.  each
;; time a cn is enforced, other unenforced cns that might be enforcable may
;; be found, so these are added to the list.  As a heuristic, the strongest
;; cn in the list is always enforced first.  The cn list is always kept in
;; order from strongest to weakest cn, and new candidate cns are merged
;; into this list in order.  This fn collects eval-roots, a list of the cns
;; that were sucessfully enforced, which are the roots of the trees of cns
;; that need to be evaluated to satisfy the cns, as well as any
;; newly-unbound vars that should now be validated.  The arg
;; old-unbound-vars should contain any other unbound variables that should
;; be examined.
(defun enforce-constraint-list (cns old-unbound-vars)
  (let ((eval-roots nil)
	(eval-unbound-vars old-unbound-vars)
	(sorted-cns
         (sort-cns-by-strength (delete-duplicates (copy-list cns))))
        cn unenforced unbound-vars)
    (loop until (null sorted-cns) do
      (setq cn (pop sorted-cns))
      (multiple-value-setq
       (unenforced unbound-vars)
       (enforce-constraint-return-unenforced-unbound cn))
      ;; save 
      (when (enforced cn)
	    (push cn eval-roots)
	    (setq eval-unbound-vars (append unbound-vars eval-unbound-vars)))
      (setq sorted-cns
                (merge-cns-by-strength
                 (sort-cns-by-strength
                  (delete-duplicates unenforced))
                 sorted-cns))
      )
    ;; now, try to enforce the cns by evaluating cn methods.  This will
    ;; invalidate any vars that cannot be validated.
    (eval-from-roots eval-roots eval-unbound-vars)
    nil))

(defun sort-cns-by-strength (cns)
  (sort cns #'(lambda (a b) (weaker b a)) :key #'(lambda (cn) (CN-strength cn))))

(defun merge-cns-by-strength (cns1 cns2)
  (merge 'list cns1 cns2
         #'(lambda (a b) (weaker b a)) :key #'(lambda (cn) (CN-strength cn))))

;; this fn finds a ptree rooted with the specified constraint (if
;; possible), and returns a list of the cns that may now be enforcable,
;; along with a list of variables that may not be unbound.
(defun enforce-constraint-return-unenforced-unbound (cn)
  (let* ((mark (new-mark))
	 ok unenforced unbound-vars)
    (multiple-value-setq
     (ok unbound-vars)
     (build-ptree (list cn) (CN-strength cn) mark))
    (cond (ok
	   ;; we found a ptree!
	   ;; handle newly-unbound vars
	   (un-determine-unmarked-vars unbound-vars mark)
	   ;; prop walkstrengths down ptree
	   (propagate-cns-walkstrength (list cn))
	   ;; prop walkstrengths from newly unbound vars
           (propagate-vars-walkstrength unbound-vars)
	   ;; collect any cns that may now be enforcible
	   (setq unenforced (collect-unenforced unbound-vars))
	   ;; return unenforced cns and unbound vars
	   (values unenforced unbound-vars)
	   )
	  (t
	   ;; no ptree found
	   (values nil nil)))
    ))

;; reset determined-by and other slots to specify that variables vars
;; are not determined by any constraints.  If mark is non-nil, any vars
;; with this mark should not be changed.
(defun un-determine-unmarked-vars (vars mark)
  (loop for var in vars 
        unless (and mark (equal mark (VAR-mark var)))
        do
        (setf (VAR-determined-by var) nil)
        (setf (VAR-walk-strength var) *weakest-strength*)))

(defun propagate-vars-walkstrength (vars)
  (propagate-cns-walkstrength
   (loop for var in vars append (consuming-constraints var))))

;; propagate walkstrengths downstream from the given cns.  Cycles are
;; broken by inserting the most conservative walkstrength (weakest).
(defun propagate-cns-walkstrength (cns)
  (let* ((prop-mark (new-mark))
         (done-mark (new-mark))
         (todo cns)
	 wait cn)
    ;; mark all cns we will be processing without invalidating their outputs
    (mark-invalidate-downstream cns prop-mark nil)
    (loop
     (setq wait (propagate-cns-walkstrengths-collecting-waits
		     todo prop-mark done-mark))
     (setq todo (loop for cn in wait
		     when (equal prop-mark (CN-mark cn))
		     collect cn))
     ;; no more cns to process: return
     (when (null todo) (return))
     ;; we have non-processed cns: there must be a cycle.
     ;; try to break cycle by processing the first cn
     (setq cn (pop todo))
     ;; set any upstream vars determined by unprocessed
     ;; cns to have :weakest walkabout strength.
     ;; (most conservative choice)
     (loop for var in (CN-variables cn)
	   when (let ((upstream-cn (VAR-determined-by var)))
		  (and upstream-cn
		       (not (eql cn upstream-cn))
		       (equal prop-mark (CN-mark upstream-cn))))
	   do (setf (VAR-walk-strength var) *weakest-strength*))
     ;; compute walkstrengths for cycle-breaking cn, and mark it done
     (loop for var in (selected-method-output-vars cn) do
	   (setf (VAR-walk-strength var) (compute-walkabout cn var)))
     (setf (CN-mark cn) done-mark)
     ;; add cns below cycle-breaking cn to list of cns to prop from
     (loop for var in (selected-method-output-vars cn)
	   do (setq todo (append (consuming-constraints var) todo)))
     )))

;; propagate walkstrengths to all cns with the mark prop-mark.  Any cn
;; found whose immediate upstream cns with mark prop-mark is put on the
;; "wait" list, that is returned.  If there are cycles, some cns in
;; this list will still have mark prop-mark.
(defun propagate-cns-walkstrengths-collecting-waits (cns prop-mark done-mark)
  (let* ((todo cns)
         (wait nil)
	 cn)
    (loop
     (when (null todo) (return))
     (setq cn (pop todo))
     (cond ((not (equal prop-mark (CN-mark cn)))
	    ;; this cn has already been processed: ignore
	    nil)
	   ((upstream-cns-unmarked cn prop-mark)
	    ;; we have a cn we can process: calc walkstrengths, and mark it done
	    (loop for var in (selected-method-output-vars cn) do
		  (setf (VAR-walk-strength var) (compute-walkabout cn var)))
	    (setf (CN-mark cn) done-mark)
	    ;; look at its downstream cns
	    (loop for var in (selected-method-output-vars cn)
		  do (setq todo (append (consuming-constraints var) todo)))
	    )
	   (t
	    ;; can't process this cn, so save on wait list
	    (push cn wait)))
     )
    wait))

;; returns t iff none of the cns determining the inputs of cn are marked
(defun upstream-cns-unmarked (cn mark)
  (loop for var in (CN-variables cn)
	never (let ((upstream-cn (VAR-determined-by var)))
		(and upstream-cn
		     (not (eql cn upstream-cn))
		     (equal mark (CN-mark upstream-cn))))))

;; takes a list of enforced cns, and marks all downstream enforced cns,
;; stopping at cns that are already marked with the mark.  All vars that
;; are outputs of these cns are marked invalid.
(defun mark-invalidate-downstream (cns mark invalidate-p)
  (let* ((todo cns)
         cn)
    (loop until (null todo) do
      (setq cn (pop todo))
      (when (not (equal mark (CN-mark cn)))
        (setf (CN-mark cn) mark)
        (loop for var in (selected-method-output-vars cn)
              do
	      (when invalidate-p (setf (VAR-valid var) nil))
	      (setq todo (append (consuming-constraints var) todo)))
        ))
    ))

;; collects and returns all unenforced cns downstream of the specified vars
;; that could possibly output to these vars or downstream vars.
(defun collect-unenforced (vars)
  (let ((unenforced nil)
	(todo vars)
	(mark (new-mark))
	var)
    (loop
     (when (null todo) (return))
     (setq var (pop todo))
     (loop for cn in (VAR-constraints var) do
	   (cond ((eql cn (VAR-determined-by var))
		  ;; cn determines var: ignore
		  nil)
		 ((equal mark (CN-mark cn))
		  ;; we've already collected this cn (if it is unenforced)
		  ;; or propagated through it (if it is enforced): ignore
		  nil)
		 ((enforced cn)
		  ;; enforced cn that consumes var: mark, and prop to output vars
		  (setf (CN-mark cn) mark)
		  (setq todo (append (selected-method-output-vars cn) todo)))
		 ((possible-output cn var)
		  ;; unenforced cn that could output to var: mark and collect
		  (setf (CN-mark cn) mark)
		  (push cn unenforced))
		 ))
     )
    unenforced))

(defun possible-output (cn var)
  (loop for mt in (CN-methods cn)
	thereis (find var (method-output-vars cn mt))))

;; build-ptree is one of a set of mutually-recursive fns that perform a
;; backtracking search for a mutually-consistant method assignments
;; for the specified constraint.  The "ptree" that is being built is
;; a propagation tree rooted at the cn originially used to start this
;; process, which had strength enforced-strength.  The leaves of the
;; ptree are cns weaker than this strength, that are left unenforced
;; (with no method selected).  It is also possible that a leaf may loop
;; back to a lower part of the ptree: this is acceptable.
;; These functions perform the search by marking cns and vars with the
;; specified mark: only when a complete ptree is found are the selected
;; methods changed to reflect this.
;;  These functions all return two values:
;;   ok -  t iff a way was found to enforce the cn
;;   unbound-vars - a list of variables that are (possibly) now unbound

(defun build-ptree (cns enforced-strength mark)
  (let* ((cn (car cns))
         (other-cns (cdr cns)))
    (cond ((null cns)
	   ;; no more cns, we have found a complete prop path!
           (values t nil))
          ((equal mark (CN-mark cn))
	   ;; this cn has already been marked: there must be a loop in the path.
	   ;; continue with other cns
           (build-ptree other-cns enforced-strength mark))
          ((weaker (CN-strength cn) enforced-strength)
	   ;; this cn is weaker: we can terminate branch by leaving this
	   ;; cn unsatisfied.
	   (when (not (enforced cn))
		 (cerror "cont" "shouldn't happen: found weaker unenforced cn"))
	   (build-ptree-leaf cn other-cns enforced-strength mark))
	  (t
	   ;; try to find a method for this cn
	   (build-ptree-branch cn other-cns enforced-strength mark))
	  )))

(defun build-ptree-leaf (cn other-cns enforced-strength mark)
  (let* ((old-mt (CN-selected-method cn))
	 (old-mt-outputs (if old-mt (method-output-vars cn old-mt) nil))
	 ok unbound-vars)
    ;; mark this cn.  we know how we will satisfy it (namely with no mt).
    (setf (CN-mark cn) mark)
    ;; try building rest of ptree
    (multiple-value-setq (ok unbound-vars)
			 (build-ptree other-cns enforced-strength mark))
    (cond (ok
	   ;; we found entire ptree!
	   ;; set selected-method for this cn
	   (setf (CN-selected-method cn) nil)
	   ;; add former mt outputs to returned list
	   (values t (append old-mt-outputs unbound-vars)))
	  (t
	   ;; no ptree found: we are backtracking.
	   ;; there is no other choice for this cn, so just un-mark cn
	   ;; and continue backtracking.
	   (setf (CN-mark cn) (new-mark))
	   (values nil nil)))
    ))

(defun build-ptree-branch (cn other-cns enforced-strength mark)
  (let* ((mts (get-possible-methods cn mark))
	 (old-mt (CN-selected-method cn))
	 (old-mt-outputs (if old-mt (method-output-vars cn old-mt) nil))
	 ok unbound-vars)
    ;; try each possible method: returning if one is found that allows
    ;; ptree to be built
    (loop for mt in mts do
	  (let* ((mt-outputs (method-output-vars cn mt))
		 (new-outputs (set-difference mt-outputs old-mt-outputs))
		 (new-output-cns (loop for v in new-outputs
				       when (VAR-determined-by v)
				       collect (VAR-determined-by v)))
		 (new-unbound-vars (set-difference old-mt-outputs mt-outputs)))
	    ;; let's try to build the ptree with this cn/mt.
	    ;; mark this cn and the output vars of the method
	    (set-method-output-marks cn mt mark)
	    (setf (CN-mark cn) mark)
	    ;; try building rest of ptree, extended to include cns that will
	    ;; have to be redirected/revoked for this cn/mt to be used.
	    (multiple-value-setq (ok unbound-vars)
				 (build-ptree (append new-output-cns other-cns)
					      enforced-strength mark))
	    (cond (ok
		   ;; we found entire ptree!
		   ;; set selected method for this cn, and ptrs in new outputs
		   (setf (CN-selected-method cn) mt)
		   (loop for var in mt-outputs do
			 (setf (VAR-determined-by var) cn))
		   ;; add newly-unbound vars to returned list
		   (return (values t (append new-unbound-vars unbound-vars)))
		   )
		  (t
		   ;; no ptree found: we will backtrack by trying next method
		   ;; "undo" current method choice.
		   (signal-backtracking cn mt)
		   (setf (CN-mark cn) (new-mark))
		   (set-method-output-marks cn mt (new-mark))
		   ))
	    )
	  finally
	  ;; no more methods to try: backtrack to a previous cn
	  (return (values nil nil)))
    ))

(defvar *sky-blue-backtracking-warning* nil)

;; this is called when the built-ptree fns backtrack because (cn mt) is not
;; a legitamite choice, to print a warning message.  This message can be
;; prevented by setting *sky-blue-backtracking-warning* to nil.
(defun signal-backtracking (cn mt)
  (when *sky-blue-backtracking-warning*
	(format t "~&Sky-blue: backtracking -- undoing ~S,~S~%" cn mt)))

(defun set-method-output-marks (cn mt mark)
  (loop for var in (method-output-vars cn mt) do
	(setf (VAR-mark var) mark)))

(defun get-possible-methods (cn mark)
  (let* ((current-mt (CN-selected-method cn))
	 (current-outputs (if current-mt (method-output-vars cn current-mt) nil))
	 (possible-mts (loop for mt in (CN-methods cn)
			when (possible-method cn mt mark current-outputs)
			collect mt)))
    ;; heuristic: sort possible methods so first ones tried set
    ;; the weakest possible output variables.
    (sort-mts-ignoring-vars cn possible-mts current-outputs)))

;; returns t if mt is a possible method to be used by cn as a branch in the
;; ptree.  This is true iff all of the outputs of the method are unmarked,
;; and the max walkstrength of the method outputs (ignoring current-outputs),
;; is weaker than the constraint's strength.
(defun possible-method (cn mt mark current-outputs)
  (and (unmarked-method cn mt mark)
       (weaker (max-out-ignoring-vars cn mt current-outputs)
	       (CN-strength cn))))

(defun unmarked-method (cn mt mark)
  (loop for out-var in (method-output-vars cn mt)
        never (equal mark (VAR-mark out-var))))

(defun max-out-ignoring-vars (cn mt ignore-vars)
   (let ((out-strength *weakest-strength*))
     (loop for out-var in (method-output-vars cn mt)
      when (and (not (find out-var ignore-vars))
		(weaker out-strength (VAR-walk-strength out-var)))
      do (setf out-strength (VAR-walk-strength out-var)))
     out-strength))

(defun sort-mts-ignoring-vars (cn mts ignore-vars)
  (sort mts
	#'(lambda (a b)
	    (loop for strength in *strength-list*
		  do (let ((counta (count strength a))
			   (countb (count strength b)))
		       (cond ((< counta countb) (return t))
			     ((> counta countb) (return nil))))
		  finally (return nil)))
        :key #'(lambda (mt)
                 (loop for var in (method-output-vars cn mt)
                       unless (find var ignore-vars)
                       collect (VAR-walk-strength var)))))

;; change from bnfb alg:  _must_ not look at strengths of any of the output
;; vars of the selected method.
;; also: handle case where one method's output's are a subset of another
;; (useless (?), but might as well).
;; also: let's try walkstrength for individual vars  ;; seems to make sense
(defun compute-walkabout (cn var)
  (let* ((min-strength (CN-strength cn))
         (selected-out-vars (selected-method-output-vars cn)))
    (loop for mt in (CN-methods cn) do
          (let ((mt-outputs (method-output-vars cn mt))
                (max-strength nil))
            (when (not (member var mt-outputs))
              (loop for out in mt-outputs
                    when (not (member out selected-out-vars))
                    do (when (or (null max-strength)
                                 (weaker max-strength (VAR-walk-strength out)))
                         (setf max-strength (VAR-walk-strength out))))
              (cond ((null max-strength)
                     ;; max-strength=nil if output vars of m
                     ;;are subset of selected-out-vars
                     nil)
                    ((weaker max-strength min-strength)
                     (setf min-strength max-strength))
                    )
              )))
    min-strength))

;; marks

(defvar *mark-counter* 0)

(defun new-mark ()
  (incf *mark-counter* 1)
  *mark-counter*)

;; executing methods

(defun execute-selected-method (cn)
  (funcall (MT-code (CN-selected-method cn)) cn))

;; a plan is just a list of constraints, to be executed in order
(defun execute-plan (plan)
  (let ((valid-cns (getf plan :valid-cns))
	(invalid-cns (getf plan :invalid-cns)))
    (loop for cn in valid-cns do
	  (let ((inputs-valid (inputs-always (var cn) (VAR-valid var))))
	    (when inputs-valid
		  (execute-selected-method cn))
	    (loop for var in (selected-method-output-vars cn) do
		  (setf (VAR-valid var) inputs-valid))
	    ))
    (loop for cn in invalid-cns do
	  (loop for var in (selected-method-output-vars cn) do
		(setf (VAR-valid var) nil)))
    ))

(defun extract-plan-from-variables (variables)
  (extract-plan-from-source-cns
   (loop for var in variables
       append (consuming-constraints var))))

(defun extract-plan-from-constraints (constraints)
  (extract-plan-from-source-cns
   (loop for cn in constraints
       when (enforced cn)
       collect cn)))

(defun extract-plan-from-source-cns (sources)
  (let ((plan nil)
	(bad nil)
        (mark (new-mark))
	(done (new-mark))
        (todo sources)
	(wait nil)
	cn)
    ;; mark all cns we will include in the plan
    (mark-invalidate-downstream todo mark nil)
    ;; try gathering all of the cns we can without handling cycles
    (loop
     (when (null todo) (return))
     (setq cn (pop todo))
     (cond ((not (equal mark (CN-mark cn)))
	    ;; this cn has already been processed: ignore
	    nil)
	   ((inputs-always (var cn)
			   (or (null (VAR-determined-by var))
			       (not (equal mark (CN-mark (VAR-determined-by var))))))
	    ;; all the upstream cns have been processed, so mark this one
	    (setf (CN-mark cn) done)
	    ;; add cn to beginning of plan
	    ;; (will reverse plan before returning)
	    (push cn plan)
	    ;; look at its downstream cns
	    (loop for var in (selected-method-output-vars cn)
		  do (setq todo (append (consuming-constraints var) todo)))
	    )
	   (t
	    ;; can't process this cn, so save on wait list
	    (push cn wait)))
     )
    ;; find all of the cns we haven't processed, and add them to
    ;; the list of bad cns that should have their outputs invalidated.
    (setq todo wait)
    (loop
     (when (null todo) (return))
     (setq cn (pop todo))
     (cond ((not (equal mark (CN-mark cn)))
	    ;; this cn has already been processed: ignore
	    nil)
	   (t
	    (setf (CN-mark cn) done)
	    ;; add cn to beginning of plan
	    ;; (will reverse plan before returning)
	    (push cn bad)
	    ;; look at its downstream cns
	    (loop for var in (selected-method-output-vars cn)
		  do (setq todo (append (consuming-constraints var) todo)))
	    ))
     )
    (list :valid-cns (nreverse plan) :invalid-cns bad)))

;; *** evaluating cns

;; this fn takes a list of newly-enforced cns, invalidates all of their
;; downstream vars, and then tries to execute methods to make the vars
;; valid.  if there are no cycles, this will validate all of the vars.
(defun eval-from-roots (cns unbound-vars)
  (let* ((prop-mark (new-mark))
         (done-mark (new-mark))
         (todo cns)
	 (wait nil))
    ;; for all newly-unbound variables that are marked invalid, validate
    ;; them, and add their consuming constraints to the eval-roots cns
    (loop for var in unbound-vars
	  when (and (null (VAR-determined-by var))
		    (not (VAR-valid var)))
	  do
	  (setf (VAR-valid var) t)
	  (setq todo (append (consuming-constraints var) todo)))
#||
    ;; we only want to consider cns whose inputs are valid
    (setq todo (loop for cn in todo
			 when (inputs-always (var cn) (VAR-valid var))
			 collect cn))
||#
    ;; mark all cns we will be processing, and invalidate their outputs
    (mark-invalidate-downstream todo prop-mark t)
    ;; try validating all vars we can without handling cycles
    (setq wait (eval-from-roots-collecting-waits todo prop-mark done-mark))
    (setq todo (loop for cn in wait
			 when (equal prop-mark (CN-mark cn))
			 collect cn))
    (when todo
	  (eval-from-cycle (remove-duplicates todo) prop-mark done-mark))
    ))

(defun eval-from-roots-collecting-waits (cns prop-mark done-mark)
  (let* ((todo cns)
         (wait nil)
	 cn)
    (loop
     (when (null todo) (return))
     (setq cn (pop todo))
     (cond ((not (equal prop-mark (CN-mark cn)))
	    ;; this cn has already been processed: ignore
	    nil)
	   ((inputs-always (var cn) (VAR-valid var))
	    ;; input vars are all valid, so  we can calculate this cn
	    (execute-selected-method cn)
	    (loop for var in (selected-method-output-vars cn) do
		  (setf (VAR-valid var) t))
	    (setf (CN-mark cn) done-mark)
	    ;; look at its downstream cns
	    (loop for var in (selected-method-output-vars cn)
		  do (setq todo (append (consuming-constraints var) todo)))
	    )
	   (t
	    ;; can't process this cn, so save on wait list
	    (push cn wait)))
     )
    wait))

(defvar *sky-blue-cycle-warning* nil)

(defun eval-from-cycle (cns prop-mark done-mark)
  (declare (ignore prop-mark done-mark))
  (when *sky-blue-cycle-warning*
    (format t "~&Sky-blue: cycle -- can't eval cns including: ~S~%" cns))
  )
