2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[Digraph]{An implementation of directed graphs}
7 #include "HsVersions.h"
15 -- alternative interface
16 findSCCs, SCC(..), Bag
19 CHK_Ubiq() -- debugging consistency check
20 IMPORT_1_3(List(partition))
22 import Maybes ( MaybeErr(..), maybeToBool )
23 import Bag ( Bag, filterBag, bagToList, listToBag )
24 import FiniteMap ( FiniteMap, listToFM, lookupFM, lookupWithDefaultFM )
25 import Unique ( Unique )
29 This module implements at least part of an abstract data type for
30 directed graphs. The part implemented is what we need for doing
33 >type Edge vertex = (vertex, vertex)
34 >type Cycle vertex = [vertex]
36 %************************************************************************
38 %* Strongly connected components *
40 %************************************************************************
42 John Launchbury provided the basic code for doing strongly-connected
45 The result is a list of cycles (each of which is a list of vertices),
46 and these cycles are topologically sorted, so that if there is an edge from
47 cycle A to cycle B, then A occurs after B in the result list.
50 stronglyConnComp :: (vertex->vertex->Bool) -> [Edge vertex] -> [vertex] -> [[vertex]]
52 stronglyConnComp eq edges vertices
53 = snd (span_tree (new_range reversed_edges)
55 ( snd (dfs (new_range edges) ([],[]) vertices) )
58 reversed_edges = map swap edges
62 -- new_range :: Eq v => [Edge v] -> v -> [v]
65 new_range ((x,y):xys) w
67 then (y : (new_range xys w))
68 else (new_range xys w)
71 elem x (y:ys) = x `eq` y || x `elem` ys
73 {- span_tree :: Eq v => (v -> [v])
78 span_tree r (vs,ns) [] = (vs,ns)
79 span_tree r (vs,ns) (x:xs)
80 | x `elem` vs = span_tree r (vs,ns) xs
81 | True = case (dfs r (x:vs,[]) (r x)) of { (vs',ns') ->
82 span_tree r (vs',(x:ns'):ns) xs }
84 {- dfs :: Eq v => (v -> [v])
89 dfs r (vs,ns) [] = (vs,ns)
90 dfs r (vs,ns) (x:xs) | x `elem` vs = dfs r (vs,ns) xs
91 | True = case (dfs r (x:vs,[]) (r x)) of { (vs',ns') ->
92 dfs r (vs',(x:ns')++ns) xs }
96 dfs :: (v -> v -> Bool)
102 dfs eq r (vs,ns) [] = (vs,ns)
103 dfs eq r (vs,ns) (x:xs)
104 | any (eq x) vs = dfs eq r (vs,ns) xs
105 | True = case (dfs eq r (x:vs,[]) (r x)) of
106 (vs',ns') -> dfs eq r (vs',(x:ns')++ns) xs
110 {-# SPECIALIZE findSCCs :: (a -> (Unique, Bag Unique)) -> Bag a -> [SCC a] #-}
113 => (vertex -> (key, Bag key)) -- Give key of vertex, and keys of thing's
114 -- immediate neighbours. It's ok for the
115 -- list to contain keys which don't correspond
116 -- to any vertex; they are ignored.
117 -> Bag vertex -- Stuff to be SCC'd
118 -> [SCC vertex] -- The union of all these is the original bag
120 data SCC thing = AcyclicSCC thing
121 | CyclicSCC (Bag thing)
125 (keys, keys_of, edgess) = unzip3 (map do_vertex (bagToList vs))
126 key_map = listToFM keys_of
127 edges = concat edgess
129 do_vertex v = (k, (k, (v, ok_ns)), ok_edges)
132 ok_ns = filter key_in_graph (bagToList ns)
133 ok_edges = map (\n->(k,n)) ok_ns
135 key_in_graph n = maybeToBool (lookupFM key_map n)
137 the_sccs = stronglyConnComp (==) edges keys
139 cnv_sccs = map cnv_scc the_sccs
141 cnv_scc [] = panic "findSCCs: empty component"
142 cnv_scc [k] | singlecycle k
143 = AcyclicSCC (get_vertex k)
144 cnv_scc ks = CyclicSCC (listToBag (map get_vertex ks))
146 singlecycle k = not (isIn "cycle" k (get_neighs k))
148 get_vertex k = fst (lookupWithDefaultFM key_map vpanic k)
149 get_neighs k = snd (lookupWithDefaultFM key_map vpanic k)
151 vpanic = panic "Digraph: vertix not found from key"
156 %************************************************************************
158 %* Topological sort *
160 %************************************************************************
162 Topological sort fails if it finds any cycles, returning the offending cycles.
164 If it succeeds, the result is a list of vertices, such that if there is
165 an edge from vertex A to vertex B then A occurs after B in the result list.
168 topologicalSort :: (vertex->vertex->Bool) -> [Edge vertex] -> [vertex]
169 -> MaybeErr [vertex] -- Success: the sorted list
170 [[vertex]] -- Failure: the cycles
172 topologicalSort eq edges vertices
173 = case (stronglyConnComp eq edges vertices) of { sccs ->
174 case (partition (is_cyclic edges) sccs) of { (cycles, singletons) ->
176 then Succeeded [ v | [v] <- singletons ]
180 is_cyclic es [] = panic "is_cyclic: empty component"
181 is_cyclic es [v] = (v,v) `elem` es
182 is_cyclic es vs = True
184 elem (x,y) [] = False
185 elem z@(x,y) ((a,b):cs) = (x `eq` a && y `eq` b) || z `elem` cs