\begin{code}
module Digraph(
- -- At present the only one with a "nice" external interface
- stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs,
-
- Graph, Vertex,
- graphFromEdges, graphFromEdges',
- buildG, transposeG, reverseE, outdegree, indegree,
-
- Tree(..), Forest,
- showTree, showForest,
-
- dfs, dff,
- topSort,
- components,
- scc,
- back, cross, forward,
- reachable, path,
- bcc
-
+ -- At present the only one with a "nice" external interface
+ stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs,
+
+ Graph, Vertex,
+ graphFromEdges, graphFromEdges',
+ buildG, transposeG, reverseE, outdegree, indegree,
+
+ Tree(..), Forest,
+ showTree, showForest,
+
+ dfs, dff,
+ topSort,
+ components,
+ scc,
+ back, cross, forward,
+ reachable, path,
+ bcc
) where
-# include "HsVersions.h"
+-- XXX This define is a bit of a hack, and should be done more nicely
+#define FAST_STRING_NOT_NEEDED 1
+#include "HsVersions.h"
------------------------------------------------------------------------------
-- A version of the graph algorithms described in:
---
+--
-- ``Lazy Depth-First Search and Linear Graph Algorithms in Haskell''
-- by David King and John Launchbury
---
+--
-- Also included is some additional code for printing tree structures ...
------------------------------------------------------------------------------
-import Util ( sortLe )
+import Util ( sortLe )
import Outputable
-- Extensions
import Data.Array
import Data.List
-#if __GLASGOW_HASKELL__ > 604
+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ > 604
import Data.Array.ST
#else
import Data.Array.ST hiding ( indices, bounds )
%************************************************************************
-%* *
-%* External interface
-%* *
+%* *
+%* External interface
+%* *
%************************************************************************
\begin{code}
data SCC vertex = AcyclicSCC vertex
- | CyclicSCC [vertex]
+ | CyclicSCC [vertex]
flattenSCCs :: [SCC a] -> [a]
flattenSCCs = concatMap flattenSCC
+flattenSCC :: SCC a -> [a]
flattenSCC (AcyclicSCC v) = [v]
flattenSCC (CyclicSCC vs) = vs
ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
\end{code}
+Note [Nodes, keys, vertices]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * A 'node' is a big blob of client-stuff
+
+ * Each 'node' has a unique (client) 'key', but the latter
+ is in Ord and has fast comparison
+
+ * Digraph then maps each 'key' to a Vertex (Int) which is
+ arranged densely in 0.n
+
\begin{code}
stronglyConnComp
- :: Ord key
- => [(node, key, [key])] -- The graph; its ok for the
- -- out-list to contain keys which arent
- -- a vertex key, they are ignored
- -> [SCC node] -- Returned in topologically sorted order
- -- Later components depend on earlier ones, but not vice versa
+ :: Ord key
+ => [(node, key, [key])] -- The graph; its ok for the
+ -- out-list to contain keys which arent
+ -- a vertex key, they are ignored
+ -> [SCC node] -- Returned in topologically sorted order
+ -- Later components depend on earlier ones, but not vice versa
stronglyConnComp edges
= map get_node (stronglyConnCompR edges)
-- The "R" interface is used when you expect to apply SCC to
-- the (some of) the result of SCC, so you dont want to lose the dependency info
stronglyConnCompR
- :: Ord key
- => [(node, key, [key])] -- The graph; its ok for the
- -- out-list to contain keys which arent
- -- a vertex key, they are ignored
- -> [SCC (node, key, [key])] -- Topologically sorted
+ :: Ord key
+ => [(node, key, [key])] -- The graph; its ok for the
+ -- out-list to contain keys which arent
+ -- a vertex key, they are ignored
+ -> [SCC (node, key, [key])] -- Topologically sorted
stronglyConnCompR [] = [] -- added to avoid creating empty array in graphFromEdges -- SOF
stronglyConnCompR edges
= map decode forest
where
- (graph, vertex_fn) = _scc_ "graphFromEdges" graphFromEdges edges
- forest = _scc_ "Digraph.scc" scc graph
+ (graph, vertex_fn) = {-# SCC "graphFromEdges" #-} graphFromEdges edges
+ forest = {-# SCC "Digraph.scc" #-} scc graph
decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
- | otherwise = AcyclicSCC (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
+ where
+ dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
mentions_itself v = v `elem` (graph ! v)
\end{code}
%************************************************************************
-%* *
-%* Graphs
-%* *
+%* *
+%* Graphs
+%* *
%************************************************************************
edges g = [ (v, w) | v <- vertices g, 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 ]
+mapT f t = array (bounds t) [ (v, f v (t ! v)) | v <- indices t ]
buildG :: Bounds -> [Edge] -> Graph
buildG bounds edges = accumArray (flip (:)) [] bounds edges
outdegree :: Graph -> Table Int
outdegree = mapT numEdges
- where numEdges v ws = length ws
+ where numEdges _ ws = length ws
indegree :: Graph -> Table Int
indegree = outdegree . transposeG
\begin{code}
-graphFromEdges
- :: Ord key
- => [(node, key, [key])]
- -> (Graph, Vertex -> (node, key, [key]))
-graphFromEdges edges =
- case graphFromEdges' edges of (graph, vertex_fn, _) -> (graph, vertex_fn)
+graphFromEdges
+ :: Ord key
+ => [(node, key, [key])]
+ -> (Graph, Vertex -> (node, key, [key]))
+graphFromEdges edges =
+ case graphFromEdges' edges of (graph, vertex_fn, _) -> (graph, vertex_fn)
graphFromEdges'
- :: Ord key
- => [(node, key, [key])]
- -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
+ :: Ord key
+ => [(node, key, [key])]
+ -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
graphFromEdges' edges
= (graph, \v -> vertex_map ! v, key_vertex)
where
- max_v = length edges - 1
+ max_v = length edges - 1
bounds = (0,max_v) :: (Vertex, Vertex)
sorted_edges = let
- (_,k1,_) `le` (_,k2,_) = case k1 `compare` k2 of { GT -> False; other -> True }
- in
- sortLe le edges
- edges1 = zipWith (,) [0..] sorted_edges
+ (_,k1,_) `le` (_,k2,_) = (k1 `compare` k2) /= GT
+ in
+ sortLe le edges
+ edges1 = zipWith (,) [0..] sorted_edges
- graph = array bounds [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]
- key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1]
- vertex_map = array bounds edges1
+ graph = array bounds [ (v, mapMaybe key_vertex ks)
+ | (v, (_, _, ks)) <- edges1]
+ key_map = array bounds [ (v, k)
+ | (v, (_, k, _ )) <- edges1]
+ vertex_map = array bounds edges1
-- key_vertex :: key -> Maybe Vertex
- -- returns Nothing for non-interesting vertices
- key_vertex k = find 0 max_v
- where
- find a b | a > b
- = Nothing
- find a b = case compare k (key_map ! mid) of
- LT -> find a (mid-1)
- EQ -> Just mid
- GT -> find (mid+1) b
- where
- mid = (a + b) `div` 2
+ -- returns Nothing for non-interesting vertices
+ key_vertex k = find 0 max_v
+ where
+ find a b | a > b
+ = Nothing
+ find a b = case compare k (key_map ! mid) of
+ LT -> find a (mid-1)
+ EQ -> Just mid
+ GT -> find (mid+1) b
+ where
+ mid = (a + b) `div` 2
\end{code}
%************************************************************************
-%* *
-%* Trees and forests
-%* *
+%* *
+%* Trees and forests
+%* *
%************************************************************************
\begin{code}
\begin{code}
instance Show a => Show (Tree a) where
- showsPrec p t s = showTree t ++ s
+ showsPrec _ t s = showTree t ++ s
showTree :: Show a => Tree a -> String
showTree = drawTree . mapTree show
drawTree :: Tree String -> String
drawTree = unlines . draw
+draw :: Tree String -> [String]
draw (Node x ts) = grp this (space (length this)) (stLoop ts)
where this = s1 ++ x ++ " "
stLoop [t] = grp s2 " " (draw t)
stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
+ rsLoop [] = []
rsLoop [t] = grp s5 " " (draw t)
rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
%************************************************************************
-%* *
-%* Depth first search
-%* *
+%* *
+%* Depth first search
+%* *
%************************************************************************
\begin{code}
chop m ts)
chop :: Set s -> Forest Vertex -> ST s (Forest Vertex)
-chop m [] = return []
+chop _ [] = return []
chop m (Node v ts : us)
= contains m v >>= \visited ->
if visited then
%************************************************************************
-%* *
-%* Algorithms
-%* *
+%* *
+%* Algorithms
+%* *
%************************************************************************
------------------------------------------------------------
------------------------------------------------------------
\begin{code}
---preorder :: Tree a -> [a]
+preorder :: Tree a -> [a]
preorder (Node a ts) = a : preorderF ts
preorderF :: Forest a -> [a]
------------------------------------------------------------
\begin{code}
---postorder :: Tree a -> [a]
-postorder (Node a ts) = postorderF ts ++ [a]
+postorder :: Tree a -> [a] -> [a]
+postorder (Node a ts) = postorderF ts . (a :)
-postorderF :: Forest a -> [a]
-postorderF ts = concat (map postorder ts)
+postorderF :: Forest a -> [a] -> [a]
+postorderF ts = foldr (.) id $ map postorder ts
-postOrd :: Graph -> [Vertex]
-postOrd = postorderF . dff
+postOrd :: Graph -> [Vertex]
+postOrd g = postorderF (dff g) []
-topSort :: Graph -> [Vertex]
-topSort = reverse . postOrd
+topSort :: Graph -> [Vertex]
+topSort = reverse . postOrd
\end{code}
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 (u,du,lu) xs <- us])
+ ++ [lu | Node (_,_,lu) _ <- us])
bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
-bicomps (Node (v,dv,lv) ts)
- = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]
+bicomps (Node (v,_,_) ts)
+ = [ Node (v:vs) us | (_,Node vs us) <- map collect ts]
collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
where collected = map collect ts
- vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]
+ vs = concat [ ws | (lw, Node ws _) <- collected, lw<dv]
cs = concat [ if lw<dv then us else [Node (v:ws) us]
| (lw, Node ws us) <- collected ]
\end{code}