Add Ganeti.HTools.Graph

This module implements some algorithms on Data.Graph data structures.
At the moment its main functionality is an LF-color implementation
(greedy coloring in descending order of degree). There are also a few
extra functions to calculate the degree order, and convert the node to
color mapping to color to nodes.

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

diff --git a/Makefile.am b/Makefile.am
index 5f56892..dfd8370 100644 (file)
--- a/Makefile.am
+++ b/Makefile.am
@@ -460,6 +460,7 @@ HS_LIB_SRCS = \
        htools/Ganeti/HTools/Cluster.hs \
        htools/Ganeti/HTools/Container.hs \
        htools/Ganeti/HTools/ExtLoader.hs \
+       htools/Ganeti/HTools/Graph.hs \
        htools/Ganeti/HTools/Group.hs \
        htools/Ganeti/HTools/Instance.hs \
        htools/Ganeti/HTools/Loader.hs \
@@ -511,6 +512,7 @@ HS_TEST_SRCS = \
        htest/Test/Ganeti/HTools/CLI.hs \
        htest/Test/Ganeti/HTools/Cluster.hs \
        htest/Test/Ganeti/HTools/Container.hs \
+       htest/Test/Ganeti/HTools/Graph.hs \
        htest/Test/Ganeti/HTools/Instance.hs \
        htest/Test/Ganeti/HTools/Loader.hs \
        htest/Test/Ganeti/HTools/Node.hs \

diff --git a/htest/Test/Ganeti/HTools/Graph.hs b/htest/Test/Ganeti/HTools/Graph.hs
new file mode 100644 (file)
index 0000000..03b2fda
--- /dev/null
+++ b/htest/Test/Ganeti/HTools/Graph.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-| Unittests for Ganeti.Htools.Graph
+
+-}
+
+{-
+
+Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.
+
+-}
+
+module Test.Ganeti.HTools.Graph (testHTools_Graph) where
+
+import Test.QuickCheck
+import Test.HUnit
+
+import Test.Ganeti.TestHelper
+import Test.Ganeti.TestCommon
+
+import Ganeti.HTools.Graph
+
+import qualified Data.Graph as Graph
+import qualified Data.IntMap as IntMap
+
+{-# ANN module "HLint: ignore Use camelCase" #-}
+
+data TestableGraph = TestableGraph Graph.Graph deriving (Show)
+data TestableClique = TestableClique Graph.Graph deriving (Show)
+
+-- | Generate node bounds and edges for an undirected graph.
+-- A graph is undirected if for every (a, b) edge there is a
+-- corresponding (b, a) one.
+undirEdges :: Gen (Graph.Bounds, [Graph.Edge])
+undirEdges = sized undirEdges'
+  where
+    undirEdges' 0 = return ((0, 0), [])
+    undirEdges' n = do
+      maxv <- choose (1, n)
+      edges <- listOf1 $ do
+        i <- choose (0, maxv)
+        j <- choose (0, maxv) `suchThat` (/= i)
+        return [(i, j), (j, i)]
+      return ((0, maxv), concat edges)
+
+-- | Generate node bounds and edges for a clique.
+-- In a clique all nodes are directly connected to each other.
+cliqueEdges :: Gen (Graph.Bounds, [Graph.Edge])
+cliqueEdges = sized cliqueEdges'
+  where
+    cliqueEdges' 0 = return ((0, 0), [])
+    cliqueEdges' n = do
+      maxv <- choose (0, n)
+      let edges = [(x, y) | x <- [0..maxv], y <- [0..maxv], x /= y]
+      return ((0, maxv), edges)
+
+instance Arbitrary TestableGraph where
+  arbitrary = do
+    (mybounds, myedges) <- undirEdges
+    return . TestableGraph $ Graph.buildG mybounds myedges
+
+instance Arbitrary TestableClique where
+  arbitrary = do
+    (mybounds, myedges) <- cliqueEdges
+    return . TestableClique $ Graph.buildG mybounds myedges
+
+-- | Check that the empty vertex color map is empty.
+case_emptyVertColorMapNull :: Assertion
+case_emptyVertColorMapNull = assertBool "" $ IntMap.null emptyVertColorMap
+
+-- | Check that the empty vertex color map is zero in size.
+case_emptyVertColorMapEmpty :: Assertion
+case_emptyVertColorMapEmpty =
+  assertEqual "" 0 $ IntMap.size emptyVertColorMap
+
+-- | Check that the given algorithm colors a clique with the same number of
+-- colors as the vertices number.
+prop_colorClique :: (Graph.Graph -> ColorVertMap) -> TestableClique -> Property
+prop_colorClique alg (TestableClique g) = numvertices ==? numcolors
+    where numcolors = IntMap.size (alg g)
+          numvertices = length (Graph.vertices g)
+
+-- | Specific check for the LF algorithm.
+prop_colorLFClique :: TestableClique -> Property
+prop_colorLFClique = prop_colorClique colorLF
+
+-- Check that all nodes are colored.
+prop_colorAllNodes :: (Graph.Graph -> ColorVertMap)
+                   -> TestableGraph
+                   -> Property
+prop_colorAllNodes alg (TestableGraph g) = numvertices ==? numcolored
+    where numcolored = IntMap.fold (\v l -> length v + l) 0 $ alg g
+          numvertices = length (Graph.vertices g)
+
+-- | Specific check for the LF algorithm.
+prop_colorLFAllNodes :: TestableGraph -> Property
+prop_colorLFAllNodes = prop_colorAllNodes colorLF
+
+-- | List of tests for the Graph module.
+testSuite "HTools/Graph"
+            [ 'case_emptyVertColorMapNull
+            , 'case_emptyVertColorMapEmpty
+            , 'prop_colorLFClique
+            , 'prop_colorLFAllNodes
+            ]

diff --git a/htest/test.hs b/htest/test.hs
index b4aa2ab..486b0a9 100644 (file)
--- a/htest/test.hs
+++ b/htest/test.hs
@@ -43,6 +43,7 @@ import Test.Ganeti.HTools.Backend.Text
 import Test.Ganeti.HTools.CLI
 import Test.Ganeti.HTools.Cluster
 import Test.Ganeti.HTools.Container
+import Test.Ganeti.HTools.Graph
 import Test.Ganeti.HTools.Instance
 import Test.Ganeti.HTools.Loader
 import Test.Ganeti.HTools.Node
@@ -90,6 +91,7 @@ allTests =
   , testHTools_CLI
   , testHTools_Cluster
   , testHTools_Container
+  , testHTools_Graph
   , testHTools_Instance
   , testHTools_Loader
   , testHTools_Node

diff --git a/htools/Ganeti/HTools/Graph.hs b/htools/Ganeti/HTools/Graph.hs
new file mode 100644 (file)
index 0000000..8d3e372
--- /dev/null
+++ b/htools/Ganeti/HTools/Graph.hs
@@ -0,0 +1,124 @@
+{-| Algorithms on Graphs.
+
+This module contains a few graph algorithms and the transoformations
+needed for them to be used on nodes.
+
+For more information about Graph Coloring see:
+<http://en.wikipedia.org/wiki/Graph_coloring>
+<http://en.wikipedia.org/wiki/Greedy_coloring>
+
+LF-coloring is described in:
+Welsh, D. J. A.; Powell, M. B. (1967), "An upper bound for the chromatic number
+of a graph and its application to timetabling problems", The Computer Journal
+10 (1): 85-86, doi:10.1093/comjnl/10.1.85
+<http://comjnl.oxfordjournals.org/content/10/1/85>
+
+-}
+
+{-
+
+Copyright (C) 2012, Google Inc.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.
+
+-}
+
+module Ganeti.HTools.Graph
+  ( -- * Types
+    Color
+  , VertColorMap
+  , ColorVertMap
+    -- * Creation
+  , emptyVertColorMap
+    -- * Coloring
+  , colorInOrder
+  , colorLF
+    -- * Color map transformations
+  , colorVertMap
+    -- * Vertex sorting
+  , verticesByDegreeDesc
+  , verticesByDegreeAsc
+  ) where
+
+import Data.Maybe
+import Data.Ord
+import Data.List
+
+import qualified Data.IntMap as IntMap
+import qualified Data.Graph as Graph
+import qualified Data.Array as Array
+
+-- * Type declarations
+
+-- | Node colors.
+type Color = Int
+
+-- | Vertex to Color association.
+type VertColorMap = IntMap.IntMap Color
+
+-- | Color to Vertex association.
+type ColorVertMap = IntMap.IntMap [Int]
+
+-- * Sorting of vertices
+
+-- | (vertex, degree) tuples on a graph.
+verticesDegree :: Graph.Graph -> [(Graph.Vertex, Int)]
+verticesDegree g = Array.assocs $ Graph.outdegree g
+
+-- | vertices of a graph, sorted by ascending degree.
+verticesByDegreeDesc :: Graph.Graph -> [Graph.Vertex]
+verticesByDegreeDesc g =
+  map fst . sortBy (flip (comparing snd)) $ verticesDegree g
+
+-- | vertices of a graph, sorted by descending degree.
+verticesByDegreeAsc :: Graph.Graph -> [Graph.Vertex]
+verticesByDegreeAsc g = map fst . sortBy (comparing snd) $ verticesDegree g
+
+-- * Coloring
+
+-- | Empty color map.
+emptyVertColorMap :: VertColorMap
+emptyVertColorMap = IntMap.empty
+
+-- | Get the colors of the neighbors of a vertex.
+neighColors :: Graph.Graph -> VertColorMap -> Graph.Vertex -> [Color]
+neighColors g cMap v = mapMaybe (`IntMap.lookup` cMap) neighbors
+    where neighbors = g Array.! v
+
+-- | Color one node.
+colorNode :: Graph.Graph -> VertColorMap -> Graph.Vertex -> Color
+-- use of "head" is A-ok as the source is an infinite list
+colorNode g cMap v = head $ filter notNeighColor [0..]
+    where notNeighColor = (`notElem` neighColors g cMap v)
+
+-- | Color a node returning the updated color map.
+colorNodeInMap :: Graph.Graph -> Graph.Vertex -> VertColorMap -> VertColorMap
+colorNodeInMap g v cMap = IntMap.insert v newcolor cMap
+    where newcolor = colorNode g cMap v
+
+-- | Color greedily all nodes in the given order.
+colorInOrder :: Graph.Graph -> [Graph.Vertex] -> VertColorMap
+colorInOrder g = foldr (colorNodeInMap g) emptyVertColorMap
+
+-- | Color greedily all nodes, larger first.
+colorLF :: Graph.Graph -> ColorVertMap
+colorLF g = colorVertMap . colorInOrder g $ verticesByDegreeAsc g
+
+-- | ColorVertMap from VertColorMap.
+colorVertMap :: VertColorMap -> ColorVertMap
+colorVertMap = IntMap.foldWithKey
+                 (flip (IntMap.insertWith ((:) . head)) . replicate 1)
+                 IntMap.empty