-- Under hugs -98 (Feb'00) under linux, loading this file and executing
-- main gives one or another kind of bogus program error,
-- often involving a type-incorrect term.
-- Behavior is repeatable, but form of
-- error one gets is very sensitive to exact form of program,
-- including presence or absence of unused functions.
-- Sometimes the error includes "INTERNAL ERROR: Error in graph" or is
-- "unexpected signal" or "control stack overflow".
import Array
import List
import Trex
type Var = Int
type Value = Int
data Assign = Var := Value deriving (Eq, Ord, Show)
var :: Assign -> Var
var (v := _) = v
value :: Assign -> Value
value (_ := l) = l
nullAssign :: Assign
nullAssign = (0 := 1)
type Relation = Assign -> Assign -> Bool
data CSP = CSP {vars, vals :: Int, rel :: Relation, coster :: Assign -> Int, hcoster
:: State -> Int}
mkCSP :: Int -> Int -> Relation -> (Assign -> Int) -> (State -> Int) -> CSP
mkCSP v d r c h = CSP{vars = v, vals = d, rel = wrap r,coster = c,hcoster = h}
where wrap f x y | x > y = f y x
| x == nullAssign = True
| otherwise = f x y
data State = State [Assign] [Var] deriving Show
assigns :: State -> [Assign]
assigns (State st vs) = st
unused :: State -> [Var]
unused (State st vs) = vs
emptyState :: CSP -> State
emptyState CSP{vars=vars} = State [] [1..vars]
extend :: Assign -> State -> State
extend a (State st vs) = State (a:st) (delete (var a) vs)
complete :: State -> Bool
complete (State _ vs) = null vs
current :: State -> Assign
current (State [] _) = (0 := 1)
current (State (a:_) _) = a
type Adjacency = Array (Var, Var) Bool
graphcoloring :: Adjacency -> Int -> (Int -> Int -> Int) -> CSP
graphcoloring adj colors costs = mkCSP nodes colors ok coster (const 0)
where (_,(nodes,_)) = bounds adj
ok (n1 := c1) (n2 := c2) = c1 /= c2 || not (adj!(n1,n2))
coster (n := c) = costs n c
hcoster state = sum (map (\node -> (foldl min maxBound (map (costs node)
[1..colors]))) (unused state))
data Tree a = Node a [Tree a]
instance Show a => Show (Tree a) where
showsPrec p t r = concat (showTree t) ++ r
showTree (Node label children) = (show label ++ "\n") : (concat (map showTree
children))
type Transform a b = Tree a -> Tree b
label :: Tree a -> a
label (Node a _) = a
mapTree :: (a -> b) -> Transform a b
mapTree f (Node a cs) = Node (f a) (map (mapTree f) cs)
foldTree :: (a -> [b] -> b) -> Tree a -> b
foldTree f (Node a cs) = f a (map (foldTree f) cs)
filterTree :: (a -> Bool) -> Transform a a
filterTree p = foldTree f
where f a cs = Node a (filter (p . label) cs)
prune :: (a -> Bool) -> Transform a a
prune p = filterTree (not . p)
leaves :: Tree a -> [a]
leaves (Node leaf []) = [leaf]
leaves (Node _ cs) = concat (map leaves cs)
initTree :: (a -> [a]) -> a -> Tree a
initTree f a = Node a (map (initTree f) (f a))
inhTree :: (a -> b -> b) -> b -> Tree a -> Tree b
inhTree f z (Node a cs) = Node b (map (inhTree f b) cs)
where b = f a z
mkTree :: CSP -> Tree (Rec (state::State))
mkTree csp@CSP{vals=vals} = initTree next (state = emptyState csp)
where next (state = st) = [ (state = extend (head (unused st) := val) st) | not
(complete st), val <- [1..vals] ]
earliestInconsistency:: CSP -> State -> Maybe Var
earliestInconsistency CSP{rel=rel} st =
case assigns st of
[] -> Nothing
(a:as) -> case filter (not . rel a) (reverse as) of
[] -> Nothing
(b:_) -> Just(var b)
type ConflictSet = [Var]
bt :: (r\state,r\conflicts) => CSP -> Transform (Rec (state::State | r)) (Rec
(state::State,conflicts::ConflictSet | r))
bt csp = mapTree f
where f (state=s | r) = (state=s,conflicts=earliestPair | r)
where earliestPair =
case earliestInconsistency csp s of
Nothing -> []
Just a -> [var (current s),a]
incCostTree :: (Num n,r\state,r\cost) => (Assign -> n) -> Transform
(Rec(state::State|r)) (Rec(state::State,cost::n|r))
incCostTree coster t = inhTree f (cost=fromInt 0 | label t) t
where f a@(state=st|_) (cost=c|_) = (cost=coster(current st) + c |a)
hCostTree :: (Num n,r\state,r\hcost) => (State -> n) -> Transform
(Rec(state::State|r)) (Rec(state::State,hcost::n|r))
hCostTree f = mapTree g
where g a@(state=st|r) = (hcost=f st|a)
lp t = f t maxBound
where f (Node a []) b = Node a []
f (Node a cs) b = Node a cs'
where cs' = g b cs
g b [] = []
g b (c@(Node (cost=cost,hcost=hcost|_) _):cs) | b <=
cost+hcost = g b cs
|
otherwise =
let
c' = f c b
b' = foldTree h c'
b'' = min b b'
cs' = g b'' cs
in
c':cs'
h (a@(cost=cost,state=state |_)) [] | complete state = cost
| otherwise = maxBound
h _ cs = minimum cs
optsearch labeler csp@CSP{coster=coster,hcoster=hcoster} k = ( filter (complete .
#state) . leaves .
lp . hCostTree hcoster .
mapTree (\ (state=state,cost=cost|r) -> (state=state,cost=cost)) .
labeler csp .
incCostTree coster . mkTree) csp
-- Generators based on Dimacs format
type Edgelist = [(Int,Int)]
-- Get (vertex count, edge list) from DIMACS problem format
buildProblem :: String -> (Int,Edgelist)
buildProblem s = (nodes,edgelist)
where nodes = read n
where (_:_:n:_) = problemspec
[problemspec] = filter ((== "p") . head) specs
edgelist = concat (map f edgespecs)
where f (_:v:w:_) = [(v',w'),(w',v')]
where v' = read v
w' = read w
edgespecs = filter ((== "e") . head) specs
specs = map words (lines s)
-- Build adjacency matrix from problem
buildAdj :: (Int,Edgelist) -> Adjacency
buildAdj (nodes,edgelist) = accumArray (||) False ((1,1), (nodes,nodes)) (map (flip
(,) True) edgelist)
foo () = optsearch bt csp 0 where
csp = graphcoloring (buildAdj (buildProblem zcol)) 20 costs
where costs node color = if node == 0 then 0 else if even
(node + color) then 1 else 10
zcol = concat [
"c cutdown version (20 vertices) of mulsol.i.1.col.\nc\nc\np edge 20 165\ne 1
2\ne 1 7\ne 1 17\ne 1 12\ne 1 10\n" ,
"e 1 20\ne 1 19\ne 1 16\ne 1 14\ne 1 11\ne 1 9\ne 1 8\ne 1 6\ne 1 5\ne 1 4\ne 2
7\ne 2 17\ne 2 12\ne 2 10\ne 2 20\n",
"e 2 19\ne 2 16\ne 2 14\ne 2 11\ne 2 9\ne 2 8\ne 2 6\ne 2 5\ne 2 4\ne 7 17\ne 7
12\ne 7 10\ne 7 20\ne 7 19\ne 7 16\n" ,
"e 7 14\ne 7 11\ne 7 9\ne 7 8\ne 6 7\ne 5 7\ne 4 7\ne 12 17\ne 10 17\ne 17
20\ne 17 19\ne 16 17\ne 14 17\ne 11 17\n" ,
"e 9 17\ne 8 17\ne 6 17\ne 5 17\ne 4 17\ne 10 12\ne 12 20\ne 12 19\ne 12 16\ne
12 14\ne 11 12\ne 9 12\ne 8 12\n" ,
"e 6 12\ne 5 12\ne 4 12\ne 10 20\ne 10 19\ne 10 16\ne 10 14\ne 10 11\ne 9 10\ne
8 10\ne 6 10\ne 5 10\ne 4 10\n" ,
"e 3 18\ne 3 15\ne 3 13\ne 3 4\ne 3 5\ne 3 6\ne 3 8\ne 3 9\ne 3 11\ne 3 14\ne 3
16\ne 3 19\ne 3 20\ne 15 18\n" ,
"e 13 18\ne 4 18\ne 5 18\ne 6 18\ne 8 18\ne 9 18\ne 11 18\ne 14 18\ne 16 18\ne
18 19\ne 18 20\ne 13 15\ne 4 15\n" ,
"e 5 15\ne 6 15\ne 8 15\ne 9 15\ne 11 15\ne 14 15\ne 15 16\ne 15 19\ne 15 20\ne
4 13\ne 5 13\ne 6 13\ne 8 13\n" ,
"e 9 13\ne 11 13\ne 13 14\ne 13 16\ne 13 19\ne 13 20\ne 4 20\ne 4 19\ne 4 16\ne
4 14\ne 4 11\ne 4 9\ne 4 8\ne 4 6\n" ,
"e 4 5\ne 5 20\ne 5 19\ne 5 16\ne 5 14\ne 5 11\ne 5 9\ne 5 8\ne 5 6\ne 6 20\ne
6 19\ne 6 16\ne 6 14\ne 6 11\ne 6 9\n" ,
"e 6 8\ne 8 20\ne 8 19\ne 8 16\ne 8 14\ne 8 11\ne 8 9\ne 9 20\ne 9 19\ne 9
16\ne 9 14\ne 9 11\ne 11 20\ne 11 19\n" ,
"e 11 16\ne 11 14\ne 14 20\ne 14 19\ne 14 16\ne 16 20\ne 16 19\ne 19 20\n"]
main = foo()
