diff --git a/Data/LabeledGraph.hs b/Data/LabeledGraph.hs new file mode 100644 --- /dev/null +++ b/Data/LabeledGraph.hs @@ -0,0 +1,511 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.LabeledGraph +-- Copyright : (c) The University of Glasgow 2002, Jean-Philippe Bernardy 2012 +-- License : BSD-style +-- +-- Maintainer : JP Bernardy +-- Stability : experimental +-- Portability : GHC +-- +-- A version of the graph algorithms described in: +-- +-- /Structuring Depth-First Search Algorithms in Haskell/, +-- by David King and John Launchbury. +-- +-- Adapted to labeled graphs by JP Bernardy. +-- +----------------------------------------------------------------------------- + +module Data.Graph{-( + + -- * External interface + + -- At present the only one with a "nice" external interface + stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs, + + -- * Graphs + + Graph, Table, Bounds, Edge, Vertex, + + -- ** Building graphs + + graphFromEdges, graphFromEdges', buildG, transposeG, + -- reverseE, + + -- ** Graph properties + + vertices, edges, + outdegree, indegree, + + -- * Algorithms + + dfs, dff, + topSort, + components, + scc, + bcc, + -- tree, back, cross, forward, + reachable, path, + + module Data.LabeledTree + + ) -} where + +import Control.Monad.ST +import Data.Array.ST (STArray, newArray, readArray, writeArray) +import Data.LabeledTree (Tree(Node), Forest, (::>)((::>)) ) + +import Data.STRef + +import Control.DeepSeq (NFData(rnf)) +import Data.Maybe +import Data.Array +import Data.List +import qualified Data.Map as M + + +------------------------------------------------------------------------- +-- - +-- External interface +-- - +------------------------------------------------------------------------- +{- +-- | Strongly connected component. +data SCC vertex = AcyclicSCC vertex -- ^ A single vertex that is not + -- in any cycle. + | CyclicSCC [vertex] -- ^ A maximal set of mutually + -- reachable vertices. + +instance NFData a => NFData (SCC a) where + rnf (AcyclicSCC v) = rnf v + rnf (CyclicSCC vs) = rnf vs + +-- | The vertices of a list of strongly connected components. +flattenSCCs :: [SCC a] -> [a] +flattenSCCs = concatMap flattenSCC + +-- | The vertices of a strongly connected component. +flattenSCC :: SCC vertex -> [vertex] +flattenSCC (AcyclicSCC v) = [v] +flattenSCC (CyclicSCC vs) = vs + +-- | The strongly connected components of a directed graph, topologically +-- sorted. +stronglyConnComp + :: Ord key + => [(node, key, [key])] + -- ^ The graph: a list of nodes uniquely identified by keys, + -- with a list of keys of nodes this node has edges to. + -- The out-list may contain keys that don't correspond to + -- nodes of the graph; such edges are ignored. + -> [SCC node] + +stronglyConnComp edges0 + = map get_node (stronglyConnCompR edges0) + where + get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n + get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples] + +-- | The strongly connected components of a directed graph, topologically +-- sorted. The function is the same as 'stronglyConnComp', except that +-- all the information about each node retained. +-- This interface is used when you expect to apply 'SCC' to +-- (some of) the result of 'SCC', so you don't want to lose the +-- dependency information. +stronglyConnCompR + :: Ord key + => [(node, key, [key])] + -- ^ The graph: a list of nodes uniquely identified by keys, + -- with a list of keys of nodes this node has edges to. + -- The out-list may contain keys that don't correspond to + -- nodes of the graph; such edges are ignored. + -> [SCC (node, key, [key])] -- ^ Topologically sorted + +stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF +stronglyConnCompR edges0 + = map decode forest + where + (graph, vertex_fn,_) = graphFromEdges edges0 + forest = scc graph + decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] + | otherwise = AcyclicSCC (vertex_fn v) + decode other = CyclicSCC (dec other []) + where + dec (Node v ts) vs = vertex_fn v : foldr dec vs ts + mentions_itself v = v `elem` (graph ! v) +-} +------------------------------------------------------------------------- +-- - +-- Graphs +-- - +------------------------------------------------------------------------- + +-- | Abstract representation of vertices. +type Vertex = Int +-- | Table indexed by a contiguous set of vertices. +type Table a = Array Vertex a +-- | Adjacency list representation of a graph, mapping each vertex to its +-- list of successors. +type Graph e = Table [(e,Vertex)] +-- | The bounds of a 'Table'. +type Bounds = (Vertex, Vertex) +-- | An edge from the first vertex to the second. +type Edge e = (Vertex,e,Vertex) + + +-- | Graph structure + colour on the vertices +data ColouredGraph c e = ColouredGraph (Graph e) (Colouring c) +type Colouring a = Vertex -> a + + +showWithColor gr color = concat $ map showNode $ range $ bounds gr + where showNode n = show n ++ ": " ++ show (color n) ++ " -> " ++ show (gr!n) ++ "\n" + +showDotFile gr = + "digraph name {\n" ++ + "rankdir=LR;\n" ++ + (concatMap showEdge $ edges gr) ++ + "}\n" + where showEdge (from, t, to) = show from ++ " -> " ++ show to ++ + " [label = \"" ++ show t ++ "\"];\n" + + +instance (Show c, Show e) => Show (ColouredGraph c e) where + show (ColouredGraph gr col) = showWithColor gr col + + +-- | All vertices of a graph. +vertices :: Graph l -> [Vertex] +vertices = indices + +-- | All edges of a graph. +edges :: Graph e -> [Edge e] +edges g = [ (v,l,w) | v <- vertices g, (l,w) <- g!v ] + + +mapT :: (Vertex -> a -> b) -> Table a -> Table b +mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ] + +-- | Build a graph from a list of edges. +buildG :: Bounds -> [Edge e] -> Graph e +buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 [(v, (l,w)) | (v,l,w) <- edges0] + +-- | The graph obtained by reversing all edges. +transposeG :: Graph e -> Graph e +transposeG g = buildG (bounds g) (reverseE g) + +reverseE :: Graph e -> [Edge e] +reverseE g = [ (w, l, v) | (v, l, w) <- edges g ] + +-- | Reverse all the edges of a graph +reverseG :: Graph e -> Graph e +reverseG g = buildG (bounds g) (reverseE g) + + +-- | A table of the count of edges from each node. +outdegree :: Graph e -> Table Int +outdegree = mapT numEdges + where numEdges _ ws = length ws + +-- | A table of the count of edges into each node. +indegree :: Graph e -> Table Int +indegree = outdegree . transposeG + +-- | Identical to 'graphFromEdges', except that the return value +-- does not include the function which maps keys to vertices. This +-- version of 'graphFromEdges' is for backwards compatibility. +graphFromEdges' + :: Ord key + => [(node, key, [(e,key)])] + -> (Graph e, Vertex -> (node, key, [(e,key)])) +graphFromEdges' x = (a,b) where + (a,b,_) = graphFromEdges x + +-- | Build a graph from a list of nodes uniquely identified by keys, +-- with a list of keys of nodes this node should have edges to. +-- The out-list may contain keys that don't correspond to +-- nodes of the graph; they are ignored. +graphFromEdges + :: forall key e node. + Ord key + => [(node, key, [(e,key)])] + -> (Graph e, Vertex -> (node, key, [(e,key)]), key -> Maybe Vertex) +graphFromEdges edges0 + = (graph, \v -> vertex_map ! v, key_vertex) + where + max_v = length edges0 - 1 + bounds0 = (0,max_v) :: (Vertex, Vertex) + sorted_edges = sortBy lt edges0 + edges1 = zipWith (,) [0..] sorted_edges + + graph :: Graph e + graph = array bounds0 [(,) v [(e,v') | (e,k) <- ks, let Just v' = key_vertex k] + | (,) v (_, _, ks) <- edges1] + key_map = array bounds0 [(,) v k | (,) v (_, k, _ ) <- edges1] + vertex_map = array bounds0 edges1 + + (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2 + + key_vertex :: key -> Maybe Vertex + -- returns Nothing for non-interesting vertices + key_vertex k = findVertex 0 max_v + where + findVertex a b | a > b + = Nothing + findVertex a b = case compare k (key_map ! mid) of + LT -> findVertex a (mid-1) + EQ -> Just mid + GT -> findVertex (mid+1) b + where + mid = (a + b) `div` 2 + +------------------------------------------------------------------------- +-- - +-- Depth first search +-- - +------------------------------------------------------------------------- + +-- | A spanning forest of the graph, obtained from a depth-first search of +-- the graph starting from each vertex in an unspecified order. +dff :: Graph e -> [Tree e Vertex] +dff g = dfs g (vertices g) + +-- | A spanning forest of the part of the graph reachable from the listed +-- vertices, obtained from a depth-first search of the graph starting at +-- each of the listed vertices in order. +dfs :: Graph e -> [Vertex] -> [Tree e Vertex] +dfs g vs = map dropLabel $ prune (bounds g) (map (\v -> error "dfs: no top-level label" ::> generate g v) vs) + +dropLabel ~(_ ::> t) = t + + +generate :: Graph e -> Vertex -> Tree e Vertex +generate g v = Node v [e ::> generate g v' | (e,v') <- g!v] + +prune :: Bounds -> Forest e Vertex -> Forest e Vertex +prune bnds ts = run bnds (chop ts) + +chop :: Forest e Vertex -> SetM s (Forest e Vertex) +chop [] = return [] +chop ((e ::> Node v ts) : us) + = do + visited <- contains v + if visited then + chop us + else do + include v + as <- chop ts + bs <- chop us + return ((e ::> Node v as) : bs) + +-- A monad holding a set of vertices visited so far. +-- Use the ST for constant-time primitives. + +newtype SetM s a = SetM { runSetM :: STArray s Vertex Bool -> ST s a } + +instance Monad (SetM s) where + return x = SetM $ const (return x) + SetM v >>= f = SetM $ \ s -> do { x <- v s; runSetM (f x) s } + +run :: Bounds -> (forall s. SetM s a) -> a +run bnds act = runST (newArray bnds False >>= runSetM act) + +contains :: Vertex -> SetM s Bool +contains v = SetM $ \ m -> readArray m v + +include :: Vertex -> SetM s () +include v = SetM $ \ m -> writeArray m v True + + +------------------------------------------------------------------------- +-- - +-- Algorithms +-- - +------------------------------------------------------------------------- + +------------------------------------------------------------ +-- Algorithm 1: depth first search numbering +------------------------------------------------------------ + +type DList a = a -> a + +dconcat :: [DList a] -> DList a +dconcat = foldr (.) id + +preorder' :: [e] -> Tree e a -> DList [(a,[e])] +preorder' es (Node a ts) = ((a,es) :) . preorderF' es ts + +preorderF' :: [e] -> Forest e a -> DList [(a,[e])] +preorderF' es ts = dconcat [ preorder' (e : es) t | (e ::> t) <- ts] + +second f (a,b) = (a,f b) + +preorderF :: [Tree e a] -> [(a,[e])] +preorderF ts = dconcat [ preorder' [] t | t <- ts] [] + +tabulate :: Bounds -> [Vertex] -> Table Int +tabulate bnds vs = array bnds (zipWith (,) vs [1..]) + + +preArr :: Bounds -> [Tree e Vertex] -> Table Int +preArr bnds = tabulate bnds . map fst . preorderF + +------------------------------------------------------------ +-- Algorithm 2: topological sorting +------------------------------------------------------------ + +postorder :: Tree e a -> [a] -> [a] +postorder (Node a ts) = postorderF (map dropLabel ts) . (a :) + +postorderF :: [Tree e a] -> [a] -> [a] +postorderF ts = foldr (.) id $ map postorder ts + +postOrd :: Graph e -> [Vertex] +postOrd g = postorderF (dff g) [] + +-- | A topological sort of the graph. +-- The order is partially specified by the condition that a vertex /i/ +-- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa. +topSort :: Graph e -> [Vertex] +topSort = reverse . postOrd + +------------------------------------------------------------ +-- Algorithm 3: connected components +------------------------------------------------------------ + +-- | The connected components of a graph. +-- Two vertices are connected if there is a path between them, traversing +-- edges in either direction. +components :: Graph e -> [Tree e Vertex] +components = dff . undirected + +undirected :: Graph e -> Graph e +undirected g = buildG (bounds g) (edges g ++ reverseE g) + +------------------------------------------------------------ +-- Algorithm 4: strongly connected components +------------------------------------------------------------ + +-- | The strongly connected components of a graph. +scc :: Graph e -> [Tree e Vertex] +scc g = dfs g (reverse (postOrd (transposeG g))) + + +------------------------------------------------------------ +-- Algorithm 6: Finding reachable vertices +------------------------------------------------------------ + +-- | A list of vertices reachable from a given vertex. +reachable :: Graph e -> Vertex -> [(Vertex,[e])] +reachable g v = preorderF (dfs g [v]) + + +-- | Is the second vertex reachable from the first? +path :: Graph e -> Vertex -> Vertex -> Bool +path g v w = w `elem` map fst (reachable g v) + +------------------------------------------------------------ +-- Algorithm 7: Biconnected components +------------------------------------------------------------ +{- +-- | The biconnected components of a graph. +-- An undirected graph is biconnected if the deletion of any vertex +-- leaves it connected. +bcc :: Graph -> Forest [Vertex] +bcc g = (concat . map bicomps . map (do_label g dnum)) forest + where forest = dff g + dnum = preArr (bounds g) forest + +do_label :: Graph e -> Table Int -> Tree e Vertex -> Tree e (Vertex,Int,Int) +do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us + where us = map (do_label g dnum) ts + lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v] + ++ [lu | Node (_,_,lu) _ <- us]) + +bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex] +bicomps (Node (v,_,_) ts) + = [ Node (v:vs) us | (_,Node vs us) <- map collect ts] + +collect :: Tree e (Vertex,Int,Int) -> (Int, Tree e [Vertex]) +collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs) + where collected = map collect ts + vs = concat [ ws | (lw, Node ws _) <- collected, lw (key -> (colour, [(edgeLabel, key)])) + -> [key] -> ST stTag ([Vertex], ColouredGraph colour edgeLabel) +unfoldManyST gen seeds = + do mtab <- newSTRef M.empty + allNodes <- newSTRef [] + uidRef <- newSTRef firstId + let -- cyc :: a -> ST s Vertex + cyc src = + do probe <- memTabFind mtab src + case probe of + Just result -> return result + Nothing -> do + v <- allocId uidRef + memTabBind src v mtab + let (lab, deps) = gen src + ws <- mapM (cyc . snd) deps + let res = (v, lab, [(fst d, w) | d <- deps | w <- ws]) + put allNodes res + return v + mapM_ cyc seeds + list <- readSTRef allNodes + seedsResult <- (return . map fromJust) =<< mapM (memTabFind mtab) seeds + lastId <- readSTRef uidRef + let cycamore = array (firstId, lastId-1) [(i, k) | (i, a, k) <- list] + let labels = array (firstId, lastId-1) [(i, a) | (i, a, k) <- list] + return (seedsResult, ColouredGraph cycamore (labels!)) + where firstId = 0::Vertex + memTabFind mt key = return . M.lookup key =<< readSTRef mt + memTabBind key val mt = modifySTRef mt (M.insert key val) + +unfold :: forall key edgeLabel colour stTag. (Ord key) => (key -> (colour, [(edgeLabel, key)])) + -> key -> (Vertex, ColouredGraph colour edgeLabel) +unfold f r = (r', res) + where ([r'], res) = unfoldMany f [r] + +unfoldMany :: forall key edgeLabel colour stTag. (Ord key) => (key -> (colour, [(edgeLabel, key)])) + -> [key] -> ([Vertex], ColouredGraph colour edgeLabel) +unfoldMany f roots = runST (unfoldManyST f roots) + +fold' :: Eq c => c -> (Vertex -> [(b,c)] -> c) -> Graph b -> Vertex -> c +fold' z f gr v = scan' z f gr v + +scan' :: Eq c => c -> (Vertex -> [(b,c)] -> c) -> Graph b -> Colouring c +scan' bot f gr = (finalTbl !) + where finalTbl = fixedPoint updateTbl initialTbl + initialTbl = listArray bnds (replicate (rangeSize bnds) bot) + + fixedPoint f x = fp x + where fp z = if z == z' then z else fp z' + where z' = f z + updateTbl tbl = listArray bnds $ map recompute $ vertices gr + where recompute v = f v [(b, tbl!k) | (b, k) <- gr!v] + bnds = bounds gr + +scan :: Eq c => c -> (a -> [(e,c)] -> c) -> ColouredGraph a e -> ColouredGraph c e +scan bot f (ColouredGraph gr a) = ColouredGraph gr (scan' bot f' gr) + where f' v kids = f (a v) kids + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) , +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 the nor the + names of its 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 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,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/labeled-graph.cabal b/labeled-graph.cabal new file mode 100644 --- /dev/null +++ b/labeled-graph.cabal @@ -0,0 +1,17 @@ +name: labeled-graph +version: 1.0.0.0 +license: BSD3 +license-file: LICENSE +maintainer: jeanphilippe.bernardy@gmail.com +synopsis: Labeled graph structure +category: Data Structures +description: + Labeled tree structure, on the model of the standard Data.Graph +build-type: Simple +cabal-version: >=1.6 + +Library + build-depends: base >= 1 && < 6 + build-depends: labeled-tree >= 1 && < 1000 + exposed-modules: + Data.LabeledGraph