package / ocaml-base-compiler.4.10.0 / utils / strongly_connected_components.ml
1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Pierre Chambart, OCamlPro *)
6 (* Mark Shinwell and Leo White, Jane Street Europe *)
7 (* *)
8 (* Copyright 2013--2016 OCamlPro SAS *)
9 (* Copyright 2014--2016 Jane Street Group LLC *)
10 (* *)
11 (* All rights reserved. This file is distributed under the terms of *)
12 (* the GNU Lesser General Public License version 2.1, with the *)
13 (* special exception on linking described in the file LICENSE. *)
14 (* *)
15 (**************************************************************************)
16
17 module Int = Numbers.Int
18
19 module Kosaraju : sig
20 type component_graph =
21 { sorted_connected_components : int list array;
22 component_edges : int list array;
23 }
24
25 val component_graph : int list array -> component_graph
26 end = struct
27 let transpose graph =
28 let size = Array.length graph in
29 let transposed = Array.make size [] in
30 let add src dst = transposed.(src) <- dst :: transposed.(src) in
31 Array.iteri (fun src dsts -> List.iter (fun dst -> add dst src) dsts)
32 graph;
33 transposed
34
35 let depth_first_order (graph : int list array) : int array =
36 let size = Array.length graph in
37 let marked = Array.make size false in
38 let stack = Array.make size ~-1 in
39 let pos = ref 0 in
40 let push i =
41 stack.(!pos) <- i;
42 incr pos
43 in
44 let rec aux node =
45 if not marked.(node)
46 then begin
47 marked.(node) <- true;
48 List.iter aux graph.(node);
49 push node
50 end
51 in
52 for i = 0 to size - 1 do
53 aux i
54 done;
55 stack
56
57 let mark order graph =
58 let size = Array.length graph in
59 let graph = transpose graph in
60 let marked = Array.make size false in
61 let id = Array.make size ~-1 in
62 let count = ref 0 in
63 let rec aux node =
64 if not marked.(node)
65 then begin
66 marked.(node) <- true;
67 id.(node) <- !count;
68 List.iter aux graph.(node)
69 end
70 in
71 for i = size - 1 downto 0 do
72 let node = order.(i) in
73 if not marked.(node)
74 then begin
75 aux order.(i);
76 incr count
77 end
78 done;
79 id, !count
80
81 let kosaraju graph =
82 let dfo = depth_first_order graph in
83 let components, ncomponents = mark dfo graph in
84 ncomponents, components
85
86 type component_graph =
87 { sorted_connected_components : int list array;
88 component_edges : int list array;
89 }
90
91 let component_graph graph =
92 let ncomponents, components = kosaraju graph in
93 let id_scc = Array.make ncomponents [] in
94 let component_graph = Array.make ncomponents Int.Set.empty in
95 let add_component_dep node set =
96 let node_deps = graph.(node) in
97 List.fold_left (fun set dep -> Int.Set.add components.(dep) set)
98 set node_deps
99 in
100 Array.iteri (fun node component ->
101 id_scc.(component) <- node :: id_scc.(component);
102 component_graph.(component) <-
103 add_component_dep node (component_graph.(component)))
104 components;
105 { sorted_connected_components = id_scc;
106 component_edges = Array.map Int.Set.elements component_graph;
107 }
108 end
109
110 module type S = sig
111 module Id : Identifiable.S
112
113 type directed_graph = Id.Set.t Id.Map.t
114
115 type component =
116 | Has_loop of Id.t list
117 | No_loop of Id.t
118
119 val connected_components_sorted_from_roots_to_leaf
120 : directed_graph
121 -> component array
122
123 val component_graph : directed_graph -> (component * int list) array
124 end
125
126 module Make (Id : Identifiable.S) = struct
127 type directed_graph = Id.Set.t Id.Map.t
128
129 type component =
130 | Has_loop of Id.t list
131 | No_loop of Id.t
132
133 (* Ensure that the dependency graph does not have external dependencies. *)
134 (* Note: this function is currently not used. *)
135 let _check dependencies =
136 Id.Map.iter (fun id set ->
137 Id.Set.iter (fun v ->
138 if not (Id.Map.mem v dependencies)
139 then
140 Misc.fatal_errorf "Strongly_connected_components.check: the \
141 graph has external dependencies (%a -> %a)"
142 Id.print id Id.print v)
143 set)
144 dependencies
145
146 type numbering = {
147 back : int Id.Map.t;
148 forth : Id.t array;
149 }
150
151 let number graph =
152 let size = Id.Map.cardinal graph in
153 let bindings = Id.Map.bindings graph in
154 let a = Array.of_list bindings in
155 let forth = Array.map fst a in
156 let back =
157 let back = ref Id.Map.empty in
158 for i = 0 to size - 1 do
159 back := Id.Map.add forth.(i) i !back;
160 done;
161 !back
162 in
163 let integer_graph =
164 Array.init size (fun i ->
165 let _, dests = a.(i) in
166 Id.Set.fold (fun dest acc ->
167 let v =
168 try Id.Map.find dest back
169 with Not_found ->
170 Misc.fatal_errorf
171 "Strongly_connected_components: missing dependency %a"
172 Id.print dest
173 in
174 v :: acc)
175 dests [])
176 in
177 { back; forth }, integer_graph
178
179 let component_graph graph =
180 let numbering, integer_graph = number graph in
181 let { Kosaraju. sorted_connected_components;
182 component_edges } =
183 Kosaraju.component_graph integer_graph
184 in
185 Array.mapi (fun component nodes ->
186 match nodes with
187 | [] -> assert false
188 | [node] ->
189 (if List.mem node integer_graph.(node)
190 then Has_loop [numbering.forth.(node)]
191 else No_loop numbering.forth.(node)),
192 component_edges.(component)
193 | _::_ ->
194 (Has_loop (List.map (fun node -> numbering.forth.(node)) nodes)),
195 component_edges.(component))
196 sorted_connected_components
197
198 let connected_components_sorted_from_roots_to_leaf graph =
199 Array.map fst (component_graph graph)
200 end
201