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
21 import Maybes ( Maybe, MaybeErr(..), maybeToBool )
22 import Bag ( Bag, filterBag, bagToList, listToBag )
23 import FiniteMap ( FiniteMap, listToFM, lookupFM, lookupWithDefaultFM )
27 This module implements at least part of an abstract data type for
28 directed graphs. The part implemented is what we need for doing
31 >type Edge vertex = (vertex, vertex)
32 >type Cycle vertex = [vertex]
34 %************************************************************************
36 %* Strongly connected components *
38 %************************************************************************
40 John Launchbury provided the basic code for doing strongly-connected
43 The result is a list of cycles (each of which is a list of vertices),
44 and these cycles are topologically sorted, so that if there is an edge from
45 cycle A to cycle B, then A occurs after B in the result list.
48 stronglyConnComp :: (vertex->vertex->Bool) -> [Edge vertex] -> [vertex] -> [[vertex]]
50 stronglyConnComp eq edges vertices
51 = snd (span_tree (new_range reversed_edges)
53 ( snd (dfs (new_range edges) ([],[]) vertices) )
56 reversed_edges = map swap edges
60 -- new_range :: Eq v => [Edge v] -> v -> [v]
63 new_range ((x,y):xys) w
65 then (y : (new_range xys w))
66 else (new_range xys w)
69 elem x (y:ys) = x `eq` y || x `elem` ys
71 {- span_tree :: Eq v => (v -> [v])
76 span_tree r (vs,ns) [] = (vs,ns)
77 span_tree r (vs,ns) (x:xs)
78 | x `elem` vs = span_tree r (vs,ns) xs
79 | True = case (dfs r (x:vs,[]) (r x)) of { (vs',ns') ->
80 span_tree r (vs',(x:ns'):ns) xs }
82 {- dfs :: Eq v => (v -> [v])
87 dfs r (vs,ns) [] = (vs,ns)
88 dfs r (vs,ns) (x:xs) | x `elem` vs = dfs r (vs,ns) xs
89 | True = case (dfs r (x:vs,[]) (r x)) of { (vs',ns') ->
90 dfs r (vs',(x:ns')++ns) xs }
94 dfs :: (v -> v -> Bool)
100 dfs eq r (vs,ns) [] = (vs,ns)
101 dfs eq r (vs,ns) (x:xs)
102 | any (eq x) vs = dfs eq r (vs,ns) xs
103 | True = case (dfs eq r (x:vs,[]) (r x)) of
104 (vs',ns') -> dfs eq r (vs',(x:ns')++ns) xs
109 => (vertex -> (key, Bag key)) -- Give key of vertex, and keys of thing's
110 -- immediate neighbours. It's ok for the
111 -- list to contain keys which don't correspond
112 -- to any vertex; they are ignored.
113 -> Bag vertex -- Stuff to be SCC'd
114 -> [SCC vertex] -- The union of all these is the original bag
116 data SCC thing = AcyclicSCC thing
117 | CyclicSCC (Bag thing)
121 (keys, keys_of, edgess) = unzip3 (map do_vertex (bagToList vs))
122 key_map = listToFM keys_of
123 edges = concat edgess
125 do_vertex v = (k, (k, (v, ok_ns)), ok_edges)
128 ok_ns = filter key_in_graph (bagToList ns)
129 ok_edges = map (\n->(k,n)) ok_ns
131 key_in_graph n = maybeToBool (lookupFM key_map n)
133 the_sccs = stronglyConnComp (==) edges keys
135 cnv_sccs = map cnv_scc the_sccs
137 cnv_scc [] = panic "findSCCs: empty component"
138 cnv_scc [k] | singlecycle k
139 = AcyclicSCC (get_vertex k)
140 cnv_scc ks = CyclicSCC (listToBag (map get_vertex ks))
142 singlecycle k = not (isIn "cycle" k (get_neighs k))
144 get_vertex k = fst (lookupWithDefaultFM key_map vpanic k)
145 get_neighs k = snd (lookupWithDefaultFM key_map vpanic k)
147 vpanic = panic "Digraph: vertix not found from key"
152 %************************************************************************
154 %* Topological sort *
156 %************************************************************************
158 Topological sort fails if it finds any cycles, returning the offending cycles.
160 If it succeeds, the result is a list of vertices, such that if there is
161 an edge from vertex A to vertex B then A occurs after B in the result list.
164 topologicalSort :: (vertex->vertex->Bool) -> [Edge vertex] -> [vertex]
165 -> MaybeErr [vertex] -- Success: the sorted list
166 [[vertex]] -- Failure: the cycles
168 topologicalSort eq edges vertices
169 = case (stronglyConnComp eq edges vertices) of { sccs ->
170 case (partition (is_cyclic edges) sccs) of { (cycles, singletons) ->
172 then Succeeded [ v | [v] <- singletons ]
176 is_cyclic es [] = panic "is_cyclic: empty component"
177 is_cyclic es [v] = (v,v) `elem` es
178 is_cyclic es vs = True
180 elem (x,y) [] = False
181 elem z@(x,y) ((a,b):cs) = (x `eq` a && y `eq` b) || z `elem` cs