{- | Fairly general forward constraint propagation algorithm for
   constraint satisfaction.
 -}

module ForwardConstraint(forward) where

{- |
A constraint satisfaction problem may be specified as a finite
collection of variables, their finite domains of values, and a binary
predicate constraining the variables pairwise.  When this is the case,
the forward constraint propagation algorithm applies.

This function implements the algorithm. Let @var@ be the type
representing your variables (or variable IDs), and @value@ be the type
of their values; thus @(var,value)@ represents binding a value to a
variable.  You provide:

* The binary predicate. This predicate evaluates to true iff two
  bindings /conflict/ with each other, i.e., /disallowed/ by your
  constraints. There is no need to worry about two bindings mentioning
  the same variable (but see the following paragraph).

* The list of variables and their respective domains. For each
  variable, provide the tuple @(var,[value])@ giving the variable
  and the list of all values in its domain. The variables should
  be distinct.

The function returns the list of solutions. Each solution is a list
of bindings.

As an example, the N-Queen problem is susceptible to this algorithm.
The variables are the queens, and we use @Int@s from 1 to N for their
variable IDs as well as their home columns (so we just need to solve
for their rows).  Each variable's domain is the rows, also @Int@s from
1 to N.

> queen n = forward queenconflict [(q, [1..n]) | q <- [1..n]]

The only source of conflict: if queen q (in column q) chooses row p
and queen q' chooses row p', there is a conflict iff they attack each
other horizontally or diagonally.

> queenconflict (q,p) (q',p') = p==p' || abs(q-q') == abs(p-p')

There is no need to worry about q and q' being the same; it does not
happen.
-}

forward :: ((var,value) -> (var,value) -> Bool) -- ^ binary conflict predicate
        -> [(var, [value])]                 -- ^ list of variables and domains
        -> [[(var,value)]]                  -- ^ list of solutions
forward _ [] = [[]]
{- We now take advantage of the list monad as a monad for nondeterminism
   and backtracking.
 -}
forward conflict ((var,values):domains) =
  do { -- pick a var, bind it to a value in its domain, any value will do
     ; value <- values
       -- use this binding to shrink others' domains by testing for conflicts
       -- then look for solutions recursively
     ; subsolution <- forward conflict (elim (var,value) domains)
     ; return ((var,value):subsolution)
     }
  where
  elim a ds = map elim1 ds
    where elim1 (v,s) = (v, [x | x<-s, not (conflict a (v,x))])