Fix Dsatur and add Dcolor

Our Dsatur implementation was incorrect: while the paper defined the
degree of saturation of a vertex as the number of different colors it is
adjacent to, we were using the number of colors, without considering
uniqueness. This effectively implemented a different algorithm, which is
very similar to the previous one, and while it performs slightly worse
on average it still beats Dsatur on some cases.

So we refactor the implementation to effectively support both algorithms
without code duplication, and then we export both the old algorithms as
"Dcolor" and the new one as "Dsatur". Since these are all fast
algorithms in hroller we will still be able to pick the best result.

Note that the new Dsatur implementation uses an IntSet to calculate the
uniqueness. Results with nub + length on a list were significantly
slower.

Signed-off-by: Guido Trotter <ultrotter@google.com>
Reviewed-by: Iustin Pop <iustin@google.com>

htest/Test/Ganeti/HTools/Graph.hs

@@ -133,6 +133,10 @@ prop_colorLFClique = prop_colorClique colorLF
 prop_colorDsaturClique :: TestableClique -> Property
 prop_colorDsaturClique = prop_colorClique colorDsatur
 
+-- | Specific check for the Dcolor algorithm.
+prop_colorDcolorClique :: TestableClique -> Property
+prop_colorDcolorClique = prop_colorClique colorDcolor
+
 -- Check that all nodes are colored.
 prop_colorAllNodes :: (Graph.Graph -> ColorVertMap)
                    -> TestableGraph
@@ -149,6 +153,10 @@ prop_colorLFAllNodes = prop_colorAllNodes colorLF
 prop_colorDsaturAllNodes :: TestableGraph -> Property
 prop_colorDsaturAllNodes = prop_colorAllNodes colorDsatur
 
+-- | Specific check for the Dcolor algorithm.
+prop_colorDcolorAllNodes :: TestableGraph -> Property
+prop_colorDcolorAllNodes = prop_colorAllNodes colorDcolor
+
 -- | List of tests for the Graph module.
 testSuite "HTools/Graph"
             [ 'case_emptyVertColorMapNull
@@ -157,8 +165,10 @@ testSuite "HTools/Graph"
             , 'prop_verticesByDegreeDescDesc
             , 'prop_colorLFClique
             , 'prop_colorDsaturClique
+            , 'prop_colorDcolorClique
             , 'prop_colorLFAllNodes
             , 'prop_colorDsaturAllNodes
+            , 'prop_colorDcolorAllNodes
             , 'prop_isColorableTestableGraph
             , 'prop_isColorableTestableClique
             ]

htools/Ganeti/HTools/Graph.hs

@@ -58,6 +58,7 @@ module Ganeti.HTools.Graph
   , colorInOrder
   , colorLF
   , colorDsatur
+  , colorDcolor
   , isColorable
     -- * Color map transformations
   , colorVertMap
@@ -74,6 +75,7 @@ import Data.Ord
 import Data.List
 
 import qualified Data.IntMap as IntMap
+import qualified Data.IntSet as IntSet
 import qualified Data.Graph as Graph
 import qualified Data.Array as Array
 
@@ -133,12 +135,17 @@ isColorable g = isUndirected g && not (hasLoop g)
 
 -- | Get the colors of a list of vertices.
 -- Any uncolored vertices are ignored.
-listColors :: VertColorMap -> [Graph.Vertex] -> [Color]
-listColors cMap = mapMaybe (`IntMap.lookup` cMap)
+verticesColors :: VertColorMap -> [Graph.Vertex] -> [Color]
+verticesColors cMap = mapMaybe (`IntMap.lookup` cMap)
+
+-- | Get the colors of a list of vertices.
+-- Any uncolored vertices are ignored.
+verticesColorSet :: VertColorMap -> [Graph.Vertex] -> IntSet.IntSet
+verticesColorSet cMap = IntSet.fromList . mapMaybe (`IntMap.lookup` cMap)
 
 -- | Get the colors of the neighbors of a vertex.
 neighColors :: Graph.Graph -> VertColorMap -> Graph.Vertex -> [Color]
-neighColors g cMap v = listColors cMap $ neighbors g v
+neighColors g cMap v = verticesColors cMap $ neighbors g v
 
 -- | Color one node.
 colorNode :: Graph.Graph -> VertColorMap -> Graph.Vertex -> Color
@@ -164,28 +171,56 @@ vertexSaturation :: Graph.Graph
                  -> VertColorMap
                  -> Graph.Vertex
                  -> (Graph.Vertex, (Satur, Int))
-vertexSaturation g cMap v = (v, (length (listColors cMap neigh), length neigh))
+vertexSaturation g cMap v =
+  (v, (IntSet.size (verticesColorSet cMap neigh), length neigh))
     where neigh = neighbors g v
 
--- | Auxiliary recursive function to calculate dsatur.
+-- | (vertex, (colordegree, degree)) for a vertex.
+vertexColorDegree :: Graph.Graph
+                  -> VertColorMap
+                  -> Graph.Vertex
+                  -> (Graph.Vertex, (Int, Int))
+vertexColorDegree g cMap v =
+  (v, (length (verticesColors cMap neigh), length neigh))
+    where neigh = neighbors g v
+
+-- | Color all nodes in a dynamic order.
 -- We have a list of vertices still uncolored, and at each round we
--- choose&delete the maximum saturation vertex among the remaining ones.
--- To do so we need explicit recursion.
-colorDsatur' :: Graph.Graph -> VertColorMap -> [Graph.Vertex] -> VertColorMap
-colorDsatur' _ cMap [] = cMap
-colorDsatur' g cMap l = colorDsatur' g newmap newlist
+-- choose&delete one vertex among the remaining ones. A helper function
+-- is used to induce an order so that the next vertex can be chosen.
+colorDynamicOrder :: Ord a
+                  =>  (Graph.Graph
+                      -> VertColorMap
+                      -> Graph.Vertex
+                      -> (Graph.Vertex, a)) -- ^ Helper to induce the choice
+                  -> Graph.Graph -- ^ Target graph
+                  -> VertColorMap -- ^ Accumulating vertex color map
+                  -> [Graph.Vertex] -- ^ List of remaining vertices
+                  -> VertColorMap -- ^ Output vertex color map
+colorDynamicOrder _ _ cMap [] = cMap
+colorDynamicOrder ordind g cMap l = colorDynamicOrder ordind g newmap newlist
     where newmap = colorNodeInMap g choosen cMap
-          choosen = fst . maximumBy (comparing snd) $ satlist
-          satlist = map (vertexSaturation g cMap) l
+          choosen = fst . maximumBy (comparing snd) $ ordlist
+          ordlist = map (ordind g cMap) l
           newlist = delete choosen l
 
+-- | Color greedily all nodes, highest number of colored neighbors, then
+-- highest degree. This is slower than "colorLF" as we must dynamically
+-- recalculate which node to color next among all remaining ones but
+-- produces better results.
+colorDcolor :: Graph.Graph -> ColorVertMap
+colorDcolor g =
+  colorVertMap . colorDynamicOrder vertexColorDegree g emptyVertColorMap $ vert
+    where vert = Graph.vertices g
+
 -- | Color greedily all nodes, highest saturation, then highest degree.
 -- This is slower than "colorLF" as we must dynamically recalculate
 -- which node to color next among all remaining ones but produces better
 -- results.
 colorDsatur :: Graph.Graph -> ColorVertMap
 colorDsatur g =
-  colorVertMap . colorDsatur' g emptyVertColorMap $ Graph.vertices g
+  colorVertMap . colorDynamicOrder vertexSaturation g emptyVertColorMap $ vert
+    where vert = Graph.vertices g
 
 -- | ColorVertMap from VertColorMap.
 colorVertMap :: VertColorMap -> ColorVertMap