;;; Definition of CSPs (Constraint Satisfaction Problems).
;;;
;;; Changed from Russell/Norvig version to support N-ary constraints.
;;;
;;; Key changes:
;;;
;;; - instead of one constraint function, a problem holds a list
;;; of zero or more constraint objects
;;;
;;; - a constraint object has a list of variable names and a function
;;;
;;; - a constraint object is OK (not violated) if any of its variables
;;; are unassigned, or if the function returns true when applied to
;;; the values of the variables, in the order they're listed
;;;
;;; - (CREATE-CSP-CONSTRAINT :VARS var-list :FUNCTION function)
;;; constructs a constraint object, e.g., to say C = A + B,
;;;
;;; (CREATE-CSP-CONSTRAINT
;;; :VARS '(A B C)
;;; :FUNCTION #'(LAMBDA (A B C) (EQL C (+ A B))))
;;;
;;;
;;; Some convenience functions:
;;;
;;; - (MAKE-CSP-CONSTRAINT var-list lisp-form) is shorthand
;;; for
;;;
;;; (CREATE-CSP-CONSTRAINT :VARS var-list
;;; :FUNCTION #'(LAMBDA var-list lisp-form))
;;;
;;; For example,
;;;
;;; (MAKE-CSP-CONSTRAINT'(A B C) '(EQL C (+ A B)))
;;;
;;; - if *CSP-COMPILE* is true, MAKE-CONSTRAINT compiles the closure
;;; constructed; in some Lisp's, compiled constraints will run
;;; faster, but uncompiled will be easier to debug; default
;;; value is false
;;;
;;; - (MAKE-DIFF-CONSTRAINT var1 var2) constructs a constraint object
;;; that is true if var1 and var2 have different values
;;;
;;; - (MAKE-ALL-DIFF-CONSTRAINTS var-list) constructs a list of
;;; diff-constraints for all pairs of variables in var-list
;;;
;;;
;;; Known Deficiencies:
;;;
;;;
;;; - MAKE-CSP-CONSTRAINT only works with legal Lisp variable names,
;;; i.e., symbols that are not constants like T or NIL
;;;
;;; - evaluating a constraint conses a list of values;
;;; this is a MAJOR cost in large searches
;;;
;;; - "min-conflicts" code not implemented
;;;
;;;
;;; Many ways to improve this code:
;;;
;;; - track how many variables in a constraint are still unassigned to
;;; avoid calling constraints before they're ready
;;;
;;; - add the variable selection heuristic "prefer variables in constraints
;;; with the fewest variables left unassigned"
;;;
;;; - index constraints by their variables so that only those constraints
;;; affected by a variable assignment are checked
;;;
;;; - re-implement the "min-conflicts, modify-assignments" code using
;;; constraint objects
(defvar *csp-compile* nil)
(defvar *csp-verbose* t)
(defstructure (CSP-problem (:include problem))
"A Constraint Satisfaction Problem involves filling in values for variables.
We will use a CSP-state structure to represent this."
(constraints nil)
(forward-checking? nil) ; should we filter domains?
(legality-checking? nil) ; should we check for legal values early?
(variable-selector #'most-constrained-variable) ; what variable should we work on next?
)
;;; 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.
(defstructure CSP-state
unassigned ;; variables that have not been given values
assigned ;; variables with known values
constraints ;; a list of all constraint objects
modified ;; variable modified to make this state
)
(defstruct (CSP-var (:type list))
name domain value conflicts)
(defstruct (CSP-constraint
(:constructor create-csp-constraint))
vars function)
(defun make-csp-constraint (vars form)
(create-csp-constraint
:vars vars
:function (let ((fn `(lambda ,vars ,form)))
(if *csp-compile*
(compile nil fn)
(coerce fn 'function)))))
(defun make-diff-constraint (var1 var2)
(make-csp-constraint `(,var1 ,var2)
`(not (eql ,var1 ,var2))))
(defun make-all-diff-constraints (vars)
(mapcon #'(lambda (vars)
(mapcar #'(lambda (var)
(make-diff-constraint (car vars) var))
(cdr vars)))
vars))
;;;; Generic Functions for CSP Problems
(defmethod goal-test ((problem csp-problem) node-or-state)
"STATE is a goal if all variables are assigned legally."
(let ((state (if (node-p node-or-state) (node-state node-or-state)
node-or-state)))
(and (null (CSP-state-unassigned state));; The state is legal
(CSP-legal-statep state))))
(defmethod successors ((problem CSP-problem) s)
(let ((unassigned (CSP-state-unassigned s))
(assigned (CSP-state-assigned s))
(constraints (CSP-state-constraints s)))
(if unassigned
(let* ((var (funcall (CSP-problem-variable-selector problem)
unassigned))
(name (CSP-var-name var))
(values (CSP-var-domain var)))
(mapcar
#'(lambda (value)
(let ((new-assigned (cons (assign-var var value) assigned))
(new-unassigned (remove var unassigned :test #'eq)))
(cons (cons name value)
(make-CSP-state
:unassigned
(if (CSP-problem-forward-checking? problem)
(filter-domains new-unassigned new-assigned constraints)
new-unassigned)
:assigned new-assigned
:constraints constraints))))
(if (CSP-problem-legality-checking? problem)
(CSP-legal-values var values assigned constraints)
values)))
nil)))
(defmethod assign-var (var value)
(let ((new (copy-CSP-var var)))
(setf (CSP-var-value new) value)
new))
;;; Generic functions for CSP constraints
(defun CSP-legal-statep (state &optional name value)
(constraints-ok-p (CSP-state-constraints state)
(CSP-state-assigned state)
name value))
(defun constraints-ok-p (constraints assigned &optional name value)
(every #'(lambda (constraint)
(constraint-ok-p constraint assigned name value))
constraints))
;;; Applies the constraint function to the variable values. If
;;; any variable unbound, returns true immediately. A variable
;;; name and value can be specified for testing potential bindings.
(defmethod constraint-ok-p ((constraint CSP-constraint) (assigned list)
&optional name value)
(apply (CSP-constraint-function constraint)
(mapcar #'(lambda (var)
(if (eql var name) value
(CSP-var-value
(or (find var assigned :key #'CSP-var-name)
(return-from constraint-ok-p t)))))
(CSP-constraint-vars constraint))))
(defmethod complete-p ((constraint CSP-constraint) state)
(every #'(lambda (var) (assigned-p var state))
(CSP-constraint-vars constraint)))
(defmethod satisfied-p ((constraint CSP-constraint) state)
(apply (CSP-constraint-function constraint)
(constraint-values constraint state)))
(defmethod constraint-values ((constraint CSP-constraint) state)
(mapcar #'(lambda (var) (assigned-value var state))
(CSP-constraint-vars constraint)))
(defun assigned-p (var state)
(member var (CSP-state-assigned state) :key #'CSP-var-name))
(defun assigned-value (var state)
(CSP-var-value
(find var (CSP-state-assigned state) :key #'CSP-var-name)))
;;;; 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 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 (goal-test 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.
(setf (csp-problem-forward-checking? problem) t)
(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 (goal-test problem node) (RETURN node))
(funcall queuing-fn nodes (expand node problem))))))
;;;; Auxiliary Functions
(defmethod print-structure ((state CSP-state) stream)
(format stream "#"
(if *csp-verbose* (CSP-state-assigned state)
(length (CSP-state-assigned state)))))
(defun filter-domains (unassigned assigned constraints)
(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)
(constraints-ok-p constraints assigned name2 val2))
domain))))
unassigned))
;;(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 constraints)
(remove-if-not #'(lambda (value)
(constraints-ok-p constraints assigned name value))
values))
(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-constraints s))))
s)