CutSet.hs

module GraphColoring.CutSet where

import qualified Math.SetCover.Exact as ESC

import qualified Data.Set as Set
import qualified Data.List as List
import Data.Set (Set)
import Data.Ord.HT (comparing)
import Data.Maybe (catMaybes)
import Text.Printf (printf)


type Label node color = Maybe (node, color)

{- |
Re-implementation of SetCover.Exact functions with an extended state,
that also maintains the already used colors in an efficient 'Set'.
-}
data State node color set =
   State {
      stateSetCover :: ESC.State (Label node color) set,
      stateUsedColors :: Set color
   }

initState :: (Ord color, ESC.Set set) =>
   [ESC.Assign (Label node color) set] -> State node color set
initState asns =
   State {
      stateSetCover = ESC.initState asns,
      stateUsedColors = Set.empty
   }

{-# INLINE updateState #-}
updateState :: (Ord color, ESC.Set set) =>
   ESC.Assign (Label node color) set ->
   State node color set -> State node color set
updateState asn s =
   State {
      stateSetCover = ESC.updateState asn $ stateSetCover s,
      stateUsedColors =
         stateUsedColors s <> foldMap (Set.singleton . snd) (ESC.label asn)
   }

{- |
Without loss of generality, when new colors are choosen,
only try the lowest free color.
This is a bit simplistic, because it only respects colors introduced by nodes,
but not colors or color pairs introduced by edges.
Effectively this only chooses a unique first color
and then all other colors are still fully permuted,
because they are all introduced by edges.
See 'CutEnumSet' for a better solution.
-}
{-# INLINE step #-}
step :: (Ord color, ESC.Set set) =>
   State node color set -> [State node color set]
step s =
   map (flip updateState s) $
   (\(ordinaryAttempts, tryNewColors) ->
      ordinaryAttempts ++ take 1 tryNewColors) $
   List.partition
      (\asn ->
         case ESC.label asn of
            Nothing -> True
            Just (_node,color) -> Set.member color $ stateUsedColors s) $
   let se = stateSetCover s in
   ESC.minimize (ESC.freeElements se) (ESC.availableSubsets se)

{-
This is faster, but excludes possible solutions.
In other words, it is fundamentally broken.
-}
{-# INLINE stepPreFilter #-}
stepPreFilter :: (Ord color, ESC.Set set) =>
   State node color set -> [State node color set]
stepPreFilter s =
   map (flip updateState s) $
   let se = stateSetCover s in
   ESC.minimize (ESC.freeElements se) $
   (\(ordinaryAttempts, tryNewColors) ->
      ordinaryAttempts ++ take 1 tryNewColors) $
   List.partition
      (\asn ->
         case ESC.label asn of
            Nothing -> True
            Just (_node,color) -> Set.member color $ stateUsedColors s)
      (ESC.availableSubsets se)

{-# INLINE search #-}
search :: (Ord color, ESC.Set set) =>
   State node color set -> [[Label node color]]
search s =
   let se = stateSetCover s in
   if ESC.null (ESC.freeElements se)
     then [ESC.usedSubsets se]
     else step s >>= search

run :: (ESC.Set set) => [ESC.Assign (Label Int Char) set] -> IO ()
run asns =
   case search $ initState asns of
      [] -> putStrLn "coloring impossible"
      solution:_ ->
         mapM_ (\(node,color) -> printf "Node %d: %c\n" node color) $
         List.sortBy (comparing fst) $ catMaybes solution