;;; file: search/algorithms/csp.lisp

;;;; Definitions generic to all CSPs (Constraint Satisfaction Problems).

;;; All CSPs use integers as names for both variables and their values.
;;; Constraints on variables var1, var2 are represented by a table,
;;; indexed by var1, var2, with each entry a list of all allowable pairs
;;; of values for var1, var2.

(defstruct (CSP-state (:print-function print-CSP-state))
  unassigned                   ;;; variables that have not been given values
  assigned                     ;;; variables with known values
  constraint-fn                ;;; checks allowed pairwise assignments
  modified                     ;;; variable modified to make this state
  )

(defstruct (CSP-var (:type list))
  name domain value conflicts)

(defun CSP-problem (domain initial-state
			   &optional (successor-fn #'CSP-successors)
			   (h-cost-fn nil))
  "Define a Constraint Satisfaction Problem"
  (make-problem
   :initial-state      initial-state
   :successor-fn       successor-fn
   :goal-test          #'CSP-goalp
   :h-cost-fn          h-cost-fn
   :edge-cost-fn       #'one
   :hash-key           #'CSP-state-assigned
   :domain             domain
   ))

;;;; Algorithms for Solving Constraint Satisfaction Problems

(defun csp-backtracking-search (problem &optional
					(queuing-fn #'enqueue-at-front))
  ;; There are two ways to implement a basic backtracking CSP search.
  ;; The first is to use the current DEPTH-FIRST-SEARCH function with
  ;; a successor function CSP-LEGAL-SUCCESSORS that generates only
  ;; legal successors. The second is to insert a consistency check,
  ;; CSP-LEGAL-STATEP, before the goal check, and avoid expanding
  ;; inconsistent states.  This second approach is implemented by this
  ;; function.
  (let ((nodes (make-initial-queue problem queuing-fn))
	node)
    (loop (if (empty-queue? nodes) (RETURN nil))
	  (setq node (remove-front nodes))
	  (when (CSP-legal-statep (node-state node))
	    (if (solved? problem node) (RETURN node))
	    (funcall queuing-fn nodes (expand node problem))))))


(defun csp-forward-checking-search (problem &optional
					    (queuing-fn #'enqueue-at-front))
  ;; Forward checking search adds a test to make sure the assignments
  ;; so far have not eliminated all the possible values for one of the
  ;; unassigned variables. Assumes that the problem definition uses
  ;; CSP-forward-checking-successors, which removes conflicting values from
  ;; the domains of the unassigned variables each time a variable is assigned.
  ;; Forward checking could also be implemented using depth-first search
  ;; and a successor function that drops any successor that has an empty
  ;; domain for some unassigned variable.
  (let ((nodes (make-initial-queue problem queuing-fn))
	node)
    (loop (if (empty-queue? nodes) (RETURN nil))
	  (setq node (remove-front nodes))
	  (when (and (CSP-legal-statep (node-state node))
		     (not (CSP-empty-domainp (node-state node))))
	    (if (solved? problem node) (RETURN node))
	    (funcall queuing-fn nodes (expand node problem))))))

;;;; Auxiliary Functions

(defun print-CSP-state (state stream depth)
  (declare (ignore depth))
  (print-unreadable-object (state stream)
    (format stream "CSP ~A" (CSP-state-assigned state))))

(defun copy-CSP-var (var) (copy-list var))

(defun CSP-goalp (s)
  (and (CSP-complete-statep s)
       (CSP-legal-statep s)))

(defun CSP-complete-statep (s)
  (null (CSP-state-unassigned s)))

(defun CSP-legal-statep (s)
  (every #'(lambda (var1)
	     (every #'(lambda (var2)
			(funcall (CSP-state-constraint-fn s)
				 (CSP-var-name var1) (CSP-var-value var1)
				 (CSP-var-name var2) (CSP-var-value var2)))
		    (cdr (member var1 (CSP-state-assigned s) :test #'eq))))
	 (CSP-state-assigned s)))

(defun CSP-successors  (s &optional (variable-selector-fn #'first)
			  (forward-checking? nil) (legality-checking? nil))
  (let ((unassigned (CSP-state-unassigned s))
	(assigned (CSP-state-assigned s))
	(constraint-fn (CSP-state-constraint-fn s)))
    (if unassigned
	(let* ((var (funcall variable-selector-fn unassigned))
	       (name (CSP-var-name var))
	       (values (CSP-var-domain var)))
	  (mapcar
	   #'(lambda (value)
	       (cons (cons name value)
		     (make-CSP-state
		      :unassigned
		      (if forward-checking?
			  (filter-domains name value 
					  (remove var unassigned :test #'eq)
					  constraint-fn)
			(remove var unassigned :test #'eq))
		      :assigned (let ((new (copy-CSP-var var)))
				  (setf (CSP-var-value new) value)
				  (cons new assigned))
		      :constraint-fn constraint-fn)))
	   (if legality-checking?
	       (CSP-legal-values var values assigned constraint-fn)
	     values)))
      nil)))

(defun CSP-legal-successors (s &optional (variable-selector-fn #'first)
			       (forward-checking? nil))
  (CSP-successors s variable-selector-fn forward-checking? t))

(defun filter-domains (name value unassigned constraint-fn)
  (mapcar #'(lambda (var)
	      (let ((name2 (CSP-var-name var))
		    (domain (CSP-var-domain var)))
		(make-CSP-var :name name2
			      :domain (remove-if-not
				       #'(lambda (val2)
					   (funcall constraint-fn
						    name value name2 val2))
				       domain))))
	  unassigned))


;;; CSP-modifications is a successor function that assumes
;;; the state is already complete but inconsistent, as in e.g.
;;; min-conflicts-hill-climbing-search.
(defun CSP-modifications
  (s &optional (variable-selector-fn #'random-conflicted-variable)
     &aux (assigned (CSP-state-assigned s))
	  (constraint-fn (CSP-state-constraint-fn s)))
  (let ((var (funcall variable-selector-fn assigned)))
    (if var
	(let ((name (CSP-var-name var))
	      (values (CSP-var-domain var)))
	  (mapcar #'(lambda (value)
		      (let ((s2 (copy-CSP-state s)))
			(modify-assignment s2 var name value 
					   assigned constraint-fn)
			(cons (cons name value) s2)))
		  values))
      nil)))



;;; modify-assignment produces a new assignment in which var changes
;;; its value to new. Need to update all the conflict counts.
(defun modify-assignment (s var name new assigned constraint-fn
			  &aux (old (CSP-var-value var))
			       (var-copy (copy-CSP-var var)))
  (setf (CSP-state-assigned s)
    (mapcar #'(lambda (var2)
	     (cond 
	      ((eq var var2)
	       (setf (CSP-var-value var-copy) new)
	       (setf (CSP-state-modified s) var-copy))
	      (t (let ((val2 (CSP-var-value var2))
		      (name2 (CSP-var-name var2))
		      (var2-copy (copy-CSP-var var2)))
		  (unless (funcall constraint-fn name old name2 val2)
			  (decf (CSP-var-conflicts var-copy))
			  (decf (CSP-var-conflicts var2-copy)))
		  (unless (funcall constraint-fn name new name2 val2)
			  (incf (CSP-var-conflicts var-copy))
			  (incf (CSP-var-conflicts var2-copy)))
		  var2-copy))))
	    assigned)))

(defun CSP-forward-checking-successors (s)
  (CSP-successors s #'first t))

(defun CSP-MCV-successors (s)
  (CSP-successors s #'most-constrained-variable t nil))

(defun most-constrained-variable (vars)
  (the-smallest #'(lambda (var) (length (CSP-var-domain var))) vars))

(defun random-conflicted-variable (vars)
  (let ((conflicted (remove-if-not #'plusp vars :key #'CSP-var-conflicts)))
    (if conflicted (random-element conflicted) nil)))

(defun min-conflicts-value (s &aux (v (CSP-state-modified s)))
  (if v (CSP-var-conflicts v) infinity))

(defun CSP-empty-domainp (s)
  (some #'(lambda (var) (null (CSP-var-domain var))) (CSP-state-unassigned s)))

(defun CSP-legal-values (name values assigned constraint-fn)
  (remove-if-not #'(lambda (value) 
		     (CSP-legal-assignmentp name value assigned constraint-fn))
		 values))

(defun CSP-legal-assignmentp (name value assigned constraint-fn)
  (every #'(lambda (var)
	     (funcall constraint-fn name value 
		                    (CSP-var-name var) (CSP-var-value var)))
	 assigned))

(defun CSP-explicit-check (name1 value1 name2 value2 constraints)
  (member (cons value1 value2) (aref constraints name1 name2) :test #'equal))

(defun CSP-random-completion (s)
  (dolist (var (CSP-state-unassigned s))
    (setf (CSP-var-value var) (random-element (CSP-var-domain var)))
    (push var (CSP-state-assigned s)))
  (setf (CSP-state-unassigned s) nil)
  (dolist (var (CSP-state-assigned s))
    (setf (CSP-var-conflicts var)
	  (CSP-conflicts var (CSP-state-assigned s) 
			 (CSP-state-constraint-fn s))))
  s)

(defun CSP-conflicts (var vars constraint-fn 
			  &aux (sum 0) (name (CSP-var-name var))
			               (value (CSP-var-value var)))
  (dolist (var2 vars sum)
    (unless (or (eq var var2)
		(funcall constraint-fn 
			 name value
			 (CSP-var-name var2) (CSP-var-value var2)))
      (incf sum))))