A CLP style command line interface for Overton's finite-domain contraint solver

Recently, David Overton presented the core of a finite-domain constraint solver written in Haskell. Trying to extend the solver, I soon noticed that the only way to look into the constraint store is to enumerate all solutions by means of the labeling function. Hence I developed some functions to display the constrained variables along with their domains. Before presenting these tools, I want to give an idea of what I am up to. Here is a sample session with the constraint-logic programming (CLP) system SICStus Prolog:

| ?- X in 1..3, Y in 1..3, X #< Y.
X in 1..2,
Y in 2..3 ? ;
no

X in 1..3, Y in 1..3, X #< Y, labeling([leftmost], [X, Y]).
X = 1,
Y = 2 ? ;
X = 1,
Y = 3 ? ;
X = 2,
Y = 3 ? ;
no

In the first place, variables need to be named:

data VarInfo s = VarInfo
    { varName :: String, delayedConstraints :: FD s (), values :: IntSet }

By default, variables are attributed with a name directly derived from their running numbers:

-- Get a new FDVar
newVar :: [Int] -> FD s (FDVar s)
newVar domain = do
    v <- nextVar
    v `isOneOf` domain
    return v
    where
        nextVar :: FD s (FDVar s)
        nextVar = do
            s <- get
            let v = varSupply s
            put $ s { varSupply = FDVar (unFDVar v + 1) }
            return v
        isOneOf :: FDVar s -> [Int] -> FD s ()
        x `isOneOf` domain=
            modify $ \s ->
                let vm = varMap s
                    vi = VarInfo {
                        varName = "_" ++ show (unFDVar x),
                        delayedConstraints = return (),
                        values = IntSet.fromList domain}
                in
                s { varMap = Map.insert x vi vm }

Next is a function for adding a named variable to the constraint store:

newNamedVar :: [Int] -> String -> FD s (FDVar s)
newNamedVar domain name = do
    x <- newVar domain
    nameVar x name
    return x
    where
        nameVar :: FDVar s -> String -> FD s ()
        nameVar x name =
            modify $ \s ->
                let vm = varMap s
                    vi = vm ! x
                in
                s { varMap = Map.insert x (vi {varName = name}) vm }

For displaying variables, we will use Text.PrettyPrint:

import qualified Text.PrettyPrint as PP

prettyDomain produces a document for printing the given variable's domain in set notation:

prettyDomain :: VarInfo s -> PP.Doc
prettyDomain =
    PP.braces . PP.hcat . PP.punctuate PP.comma . map PP.int .
    IntSet.toAscList . values

prettyVars produces a document for printing the given variable's name followed by a colon and its domain:

prettyVar :: VarInfo s -> PP.Doc
prettyVar vi =
    PP.text (varName vi) PP.<> PP.colon PP.<+> prettyDomain vi

prettyStore retrieves the current state of computation by means of get, pretty prints its variables in order of their names, and joins the resulting documents into a single document:

prettyStore :: FD s PP.Doc
prettyStore = do
    s <- get
    (return . PP.vcat . map prettyVar . List.sortBy ord .
     map snd . Map.toList . varMap) s
    where
        ord :: VarInfo s -> VarInfo s -> Ordering
        ord vi1 vi2 = compare (varName vi1) (varName vi2)

printStores executes prettyStore after the given FD monad, and renders the resulting documents to stdout:

printStores :: (forall s . FD s a) -> IO ()
printStores fd =
    (putStrLn . PP.render . PP.vcat . PP.punctuate newline . runFD)
    (do fd; prettyStore)
    where
        newline :: PP.Doc
        newline =  PP.text "\n"

To test printStores, we define setupProblem:

setupProblem :: FD s [FDVar s]
setupP1 = do
    x <- newNamedVar [1..3] "x"
    y <- newNamedVar [1..3] "y"
    ( x .<. y)
    return [x, y]

Without labeling, printStores prints the variables of the computation state produced by setupProblem:

*Main> printStores (do vars <- setupProblem; return ())
x: {0,1,2}
y: {1,2,3}

Note how (.<.) already has reduced the domains of x and y.

When combined with labeling, printStores prints the three solutions to the problem stated by setupProblem:

*Main> printStores (do vars <- setupProblem; labelling vars)
x: {1}
y: {2}

x: {1}
y: {3}

x: {2}
y: {3}

Finally, the function clp implements a CLP style command line interface:

clp :: (forall s . FD s a) -> IO ()
clp fd = do
    present (runFD (do fd; prettyStore))
    where
        present :: [PP.Doc] -> IO ()
        present [] = do
            putStrLn "no"
        present (doc : docs) = do
            putStr (PP.render doc)
            putStr " ? "
            answer <- getLine
            case answer of
                ""  -> putStrLn "yes"
                "y" -> putStrLn "yes"
                ";" -> do present docs
                "n" -> do present docs
                _   -> do help; present (doc : docs)
        help :: IO ()
        help = do
            putStrLn "   RET y     no more choices"
            putStrLn "     ; n     more choices"
            putStrLn "       h     print this information"

Here is a sample session:

*Main> clp (do vars <- setupProblem; return ())
x: {1,2}
y: {2,3} ? h
   RET y     no more choices
     ; n     more choices
       h     print this information
x: {1,2}
y: {2,3} ? ;
no

*Main> clp (do vars <- setupProblem; labelling vars)
x: {1}
y: {2} ? ;
x: {1}
y: {3} ? ;
x: {2}
y: {3} ? ;
no