diff --git a/Data/Graph/Wrapper.hs b/Data/Graph/Wrapper.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Wrapper.hs @@ -0,0 +1,245 @@ +-- | A wrapper around the types and functions from "Data.Graph" to make programming with them less painful. Also +-- implements some extra useful goodies such as 'successors' and 'sccGraph', and improves the documentation of +-- the behaviour of some functions. +-- +-- As it wraps "Data.Graph", this module only supports directed graphs with unlabelled edges. +-- +-- Incorporates code from the 'containers' package which is (c) The University of Glasgow 2002 and based +-- on code described in: +-- +-- /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/, +-- by David King and John Launchbury +module Data.Graph.Wrapper ( + Edge, Graph, + + vertex, + + fromListSimple, fromList, fromListBy, fromVerticesEdges, + + vertices, edges, successors, + + outdegree, indegree, + + transpose, + + reachableVertices, hasPath, + + topologicalSort, + + SCC(..), stronglyConnectedComponents, sccGraph + ) where + +import Control.Arrow (second) + +import Data.Array +import qualified Data.Graph as G +import Data.List (sortBy, mapAccumL) +import Data.Maybe (fromMaybe, fromJust) +import qualified Data.Map as M +import Data.Ord +import qualified Data.Set as S + +import qualified Data.Foldable as Foldable +import qualified Data.Traversable as Traversable + + +fst3 :: (a, b, c) -> a +fst3 (a, _, _) = a + +snd3 :: (a, b, c) -> b +snd3 (_, b, _) = b + +thd3 :: (a, b, c) -> c +thd3 (_, _, c) = c + + +-- | An edge from the first vertex to the second +type Edge i = (i, i) + +-- | A directed graph +data Graph i v = G { + graph :: G.Graph, + indexGVertexArray :: Array G.Vertex i, + gVertexVertexArray :: Array G.Vertex v + } + +instance (Ord i, Show i, Show v) => Show (Graph i v) where + show g = "fromVerticesEdges " ++ show ([(i, vertex g i) | i <- vertices g]) ++ " " ++ show (edges g) + +instance Functor (Graph i) where + fmap f g = g { gVertexVertexArray = fmap f (gVertexVertexArray g) } + +instance Foldable.Foldable (Graph i) where + foldMap f g = Foldable.foldMap f (gVertexVertexArray g) + +instance Traversable.Traversable (Graph i) where + traverse f g = fmap (\gvva -> g { gVertexVertexArray = gvva }) (Traversable.traverse f (gVertexVertexArray g)) + + +indexGVertex :: Ord i => Graph i v -> i -> G.Vertex +indexGVertex g i = indexGVertex' (indexGVertexArray g) i + +gVertexIndex :: Graph i v -> G.Vertex -> i +gVertexIndex g gv = indexGVertexArray g ! gv + +gVertexVertex :: Graph i v -> G.Vertex -> v +gVertexVertex g gv = gVertexVertexArray g ! gv + +-- | Retrieve data associated with the vertex +vertex :: Ord i => Graph i v -> i -> v +vertex g = gVertexVertex g . indexGVertex g + + +-- | Construct a 'Graph' where the vertex data double up as the indices. +-- +-- Unlike 'Data.Graph.graphFromEdges', vertex data that is listed as edges that are not actually themselves +-- present in the input list are reported as an error. +fromListSimple :: Ord v => [(v, [v])] -> Graph v v +fromListSimple = fromListBy id + +-- | Construct a 'Graph' that contains the given vertex data, linked up according to the supplied key extraction +-- function and edge list. +-- +-- Unlike 'Data.Graph.graphFromEdges', indexes in the edge list that do not correspond to the index of some item in the +-- input list are reported as an error. +fromListBy :: Ord i => (v -> i) -> [(v, [i])] -> Graph i v +fromListBy f vertices = fromList [(f v, v, is) | (v, is) <- vertices] + +-- | Construct a 'Graph' directly from a list of vertices (and vertex data). +-- +-- If either end of an 'Edge' does not correspond to a supplied vertex, an error will be raised. +fromVerticesEdges :: Ord i => [(i, v)] -> [Edge i] -> Graph i v +fromVerticesEdges vertices edges | M.null final_edges_map = fromList done_vertices + | otherwise = error "fromVerticesEdges: some edges originated from non-existant vertices" + where + (final_edges_map, done_vertices) = mapAccumL accum (M.fromListWith (++) (map (second return) edges)) vertices + accum edges_map (i, v) = case M.updateLookupWithKey (\_ _ -> Nothing) i edges_map of (mb_is, edges_map) -> (edges_map, (i, v, fromMaybe [] mb_is)) + +-- | Construct a 'Graph' that contains the given vertex data, linked up according to the supplied index and edge list. +-- +-- Unlike 'Data.Graph.graphFromEdges', indexes in the edge list that do not correspond to the index of some item in the +-- input list are reported as an error. +fromList :: Ord i => [(i, v, [i])] -> Graph i v +fromList vertices = G graph key_map vertex_map + where + max_v = length vertices - 1 + bounds0 = (0, max_v) :: (G.Vertex, G.Vertex) + sorted_vertices = sortBy (comparing fst3) vertices + + graph = array bounds0 $ [0..] `zip` map (map (indexGVertex' key_map) . thd3) sorted_vertices + key_map = array bounds0 $ [0..] `zip` map fst3 sorted_vertices + vertex_map = array bounds0 $ [0..] `zip` map snd3 sorted_vertices + +indexGVertex' :: Ord i => Array G.Vertex i -> i -> G.Vertex +indexGVertex' key_map k = go 0 (snd (bounds key_map)) + where + go a b | a > b = error "Data.Graph.Wrapper.fromList: one of the edges of a vertex pointed to a vertex that was not supplied in the input" + | otherwise = case compare k (key_map ! mid) of + LT -> go a (mid - 1) + EQ -> mid + GT -> go (mid + 1) b + where mid = (a + b) `div` 2 + +-- | Exhaustive list of vertices in the graph +vertices :: Graph i v -> [i] +vertices g = map (gVertexIndex g) $ G.vertices (graph g) + +-- | Exhaustive list of edges in the graph +edges :: Graph i v -> [Edge i] +edges g = map (\(x, y) -> (gVertexIndex g x, gVertexIndex g y)) $ G.edges (graph g) + +-- | Find the vertices we can reach from a vertex with the given indentity +successors :: Ord i => Graph i v -> i -> [i] +successors g i = map (gVertexIndex g) (graph g ! indexGVertex g i) + +-- | Number of edges going out of the vertex. +-- +-- It is worth sharing a partial application of 'outdegree' to the 'Graph' argument if you intend to query +-- for the outdegrees of a number of vertices. +outdegree :: Ord i => Graph i v -> i -> Int +outdegree g = \i -> outdegrees ! indexGVertex g i + where outdegrees = G.outdegree (graph g) + +-- | Number of edges going in to the vertex. +-- +-- It is worth sharing a partial application of 'indegree' to the 'Graph' argument if you intend to query +-- for the indegrees of a number of vertices. +indegree :: Ord i => Graph i v -> i -> Int +indegree g = \i -> indegrees ! indexGVertex g i + where indegrees = G.indegree (graph g) + +-- | The graph formed by flipping all the edges, so edges from i to j now go from j to i +transpose :: Graph i v -> Graph i v +transpose g = g { graph = G.transposeG (graph g) } + +-- | Topological sort of of the graph (). If the graph is acyclic, +-- vertices will only appear in the list once all of those vertices with arrows to them have already appeared. +-- +-- Vertex i precedes j in the output whenever j is reachable from i but not vice versa. +topologicalSort :: Graph i v -> [i] +topologicalSort g = map (gVertexIndex g) $ G.topSort (graph g) + +-- | List all of the vertices reachable from the given starting point +reachableVertices :: Ord i => Graph i v -> i -> [i] +reachableVertices g = map (gVertexIndex g) . G.reachable (graph g) . indexGVertex g + +-- | Is the second vertex reachable by following edges from the first vertex? +hasPath :: Ord i => Graph i v -> Edge i -> Bool +hasPath g (i1, i2) = G.path (graph g) (indexGVertex g i1) (indexGVertex g i2) + + +data SCC i = AcyclicSCC i + | CyclicSCC [i] + deriving (Show) + +instance Functor SCC where + fmap f (AcyclicSCC v) = AcyclicSCC (f v) + fmap f (CyclicSCC vs) = CyclicSCC (map f vs) + +instance Foldable.Foldable SCC where + foldMap f (AcyclicSCC v) = f v + foldMap f (CyclicSCC vs) = Foldable.foldMap f vs + +instance Traversable.Traversable SCC where + traverse f (AcyclicSCC v) = fmap AcyclicSCC (f v) + traverse f (CyclicSCC vs) = fmap CyclicSCC (Traversable.traverse f vs) + +-- | Strongly connected components (). +-- +-- The SCCs are listed in a *reverse topological order*. That is to say, any edges *to* a node in the SCC +-- originate either *from*: +-- +-- 1) Within the SCC itself (in the case of a 'CyclicSCC' only) +-- 2) Or from a node in a SCC later on in the list +-- +-- Vertex i strictly precedes j in the output whenever i is reachable from j but not vice versa. +-- Vertex i occurs in the same SCC as j whenever both i is reachable from j and j is reachable from i. +stronglyConnectedComponents :: Graph i v -> [SCC i] +stronglyConnectedComponents g = map decode forest + where + forest = G.scc (graph g) + decode (G.Node v []) | mentions_itself v = CyclicSCC [gVertexIndex g v] + | otherwise = AcyclicSCC (gVertexIndex g v) + decode other = CyclicSCC (dec other []) + where dec (G.Node v ts) vs = gVertexIndex g v : foldr dec vs ts + + mentions_itself v = v `elem` (graph g ! v) + +-- | The graph formed by the strongly connected components of the input graph. Each node in the resulting +-- graph is indexed by the set of vertex indices from the input graph that it contains. +sccGraph :: Ord i => Graph i v -> Graph (S.Set i) (M.Map i v) +sccGraph g = fromList nodes' + where + -- As we consume the SCCs, we accumulate a Map i (S.Set i) that tells us which SCC any given index belongs to. + -- When we do a lookup, it is sufficient to look in the map accumulated so far because nodes that are successors + -- of a SCC must occur to the *left* of it in the list. + (_final_i2scc_i, nodes') = mapAccumL go M.empty (stronglyConnectedComponents g) + + --go :: M.Map i (S.Set i) -> SCC i -> (M.Map i (S.Set i), (S.Set i, M.Map i v, [S.Set i])) + go i2scc_i scc = (i2scc_i', (scc_i, + Foldable.foldMap (\i -> M.singleton i (vertex g i)) scc, + Foldable.foldMap (\i -> map (fromJust . (`M.lookup` i2scc_i')) (successors g i)) scc)) + where + -- The mechanism by which we index the new graph -- the set of indexes of its components + scc_i = Foldable.foldMap S.singleton scc + i2scc_i' = i2scc_i `M.union` Foldable.foldMap (\i -> M.singleton i scc_i) scc diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Max Bolingbroke 2006-2007. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Max Bolingbroke nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/graph-wrapper.cabal b/graph-wrapper.cabal new file mode 100644 --- /dev/null +++ b/graph-wrapper.cabal @@ -0,0 +1,18 @@ +Cabal-Version: >= 1.2 +Build-Type: Simple +Name: graph-wrapper +Version: 0.1 +Maintainer: Max Bolingbroke +Homepage: http://www.github.com/batterseapower/graph-wrapper +License: BSD3 +License-File: LICENSE +Author: Max Bolingbroke +Synopsis: A wrapper around the standard Data.Graph with a less awkward interface +Category: Data Structures + +Library + Exposed-Modules: Data.Graph.Wrapper + + Build-Depends: base >= 3.0 && < 5.0, + array >= 0.3 && < 0.4, + containers >= 0.3 && < 0.4