Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 223 lines (201 sloc) 7.777 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (** same module as the one from ocamlgraph, except that this one allows you to
19 choose the size of the hashtbls used internally
20 and so it is much faster (unless you're stupid) on small input graphs
21 *)
22 module Components =
23 struct
24 module type G = sig
25 type t
26 module V : Graph.Sig.COMPARABLE
27 val iter_vertex : (V.t -> unit) -> t -> unit
28 val iter_succ : (V.t -> unit) -> t -> V.t -> unit
29 end
30
31 module Make(G:G) =
32 struct
33 module Hash = Hashtbl.Make(G.V)
34
35 (* Tarjan's algorithm for computings strongly connected components
36 * http://en.wikipedia.org/wiki/Tarjan%27s_strongly_connected_components_algorithm
37 *)
38 let scc ~size graph =
39 let index = ref 0 in
40 let stack = ref [] in
41 let indexes = Hash.create size in
42 let lowlinks = Hash.create size in
43 let sccs = ref [] in
44 let rec decant acc min_index = function
45 | (node,index) :: tl when index >= min_index ->
46 Hash.remove lowlinks node; (* satisfying the invariant described below *)
47 decant (node :: acc) min_index tl
48 | l ->
49 sccs := acc :: !sccs;
50 stack := l in
51 let rec tarjan v = (* returns the value of the first test *)
52 if not (Hash.mem indexes v) then (
53 let local_index = !index in
54 Hash.add indexes v local_index;
55 Hash.add lowlinks v local_index; (* invariant: in lowlinks <=> in the stack *)
56 stack := (v,local_index) :: !stack;
57 incr index;
58 G.iter_succ
59 (fun v' ->
60 if tarjan v' then
61 try Hash.replace lowlinks v (min (Hash.find lowlinks v) (Hash.find lowlinks v'))
62 with Not_found -> () (* happens when the value has been popped off the stack
63 * in which case, it had a greater value anyway *)
64 else if Hash.mem lowlinks v' (* using the invariant to check [v' in the stack] *) then
65 Hash.replace lowlinks v (min (Hash.find lowlinks v) (Hash.find indexes v'))
66 ) graph v;
67 if local_index = Hash.find lowlinks v then
68 decant [] local_index !stack;
69 true
70 ) else
71 false in
72 G.iter_vertex (fun x -> ignore (tarjan x)) graph;
73 List.rev !sccs (* need to reverse so that the result is topologically ordered
74 * if there is an arc from v to u, then v appears before in the list *)
75 end
76 end
77
78
79 module Reachability
80 (VSet:BaseSetSig.S)
81 (VMap:BaseMapSig.S with type key = VSet.elt)
82 (G:sig
83 type t
84 module V : Graph.Sig.COMPARABLE with type t = VSet.elt
85 val mem_vertex : t -> V.t -> bool
86 val iter_succ : (V.t -> unit) -> t -> V.t -> unit
87 val add_vertex : t -> V.t -> unit
88 val add_edge : t -> V.t -> V.t -> unit
89 val create : ?size:int -> unit -> t
90 val fold_vertex : (V.t -> 'acc -> 'acc) -> t -> 'acc -> 'acc
91 end) : sig
92 val give_unreachable_nodes : G.V.t list -> (G.V.t * VSet.t) list -> VSet.t
93 val get_reachable_graph_from : ?addon_roots:G.V.t list VMap.t -> G.V.t list -> G.t -> G.t
94 val graph_of_deps : (G.V.t * VSet.t) list -> G.t
95 end =
96 struct
97 let rec add_successors g graph addon_roots from =
98 if not(G.mem_vertex g from) then
99 begin
100 G.add_vertex g from;
101 begin match VMap.find_opt from addon_roots with
102 | None -> ()
103 | Some li ->
104 List.iter (add_successors g graph addon_roots) li
105 end;
106 G.iter_succ
107 (fun to_ ->
108 add_successors g graph addon_roots to_;
109 G.add_edge g from to_
110 ) graph from
111 end
112
113
114 (** computes the subgraph reachable from the roots
115 * addon_roots is here to provide some conditional roots:
116 * you may have magic_to_string -> [int_to_string, float_to_string, ...]
117 * that means if the node magic_to_string is reachable, then you must also keep
118 * int_to_string, etc
119 * if you don't encounter magic_to_string, then you may or may not keep
120 * magic_to_string (depending on whether other expressions need it)
121 *)
122 let get_reachable_graph_from ?(addon_roots=VMap.empty) roots graph =
123 let g = G.create () in
124 List.iter
125 (fun root ->
126 add_successors g graph addon_roots root)
127 roots;
128 g
129
130 let graph_of_deps (depslist : (G.V.t * VSet.t) list) =
131 let dep_g = G.create () in
132 List.iter (fun (v0, _) -> G.add_vertex dep_g v0) depslist;
133 List.iter (fun (v0, deps) ->
134 VSet.iter (fun v1 -> G.add_edge dep_g v0 v1) deps
135 ) depslist;
136 dep_g
137
138 let vertices_of (graph:G.t) =
139 G.fold_vertex VSet.add graph VSet.empty
140
141 let give_unreachable_nodes roots deps_set =
142 let graph = graph_of_deps deps_set in
143 let reachable_graph = get_reachable_graph_from roots graph in
144 let all_vertices = vertices_of graph in
145 let reachable_vertices = vertices_of reachable_graph in
146 VSet.diff all_vertices reachable_vertices
147
148 end
149
150 (** An already instantiated imperative graph with int labels on the nodes *)
151 module Int =
152 struct
153 module V : Graph.Sig.COMPARABLE with type t = int =
154 struct
155 type t = int
156 let equal : int -> int -> bool = (=)
157 let hash = Hashtbl.hash
158 let compare : int -> int -> int = Pervasives.compare
159 end
160
161 module G = Graph.Imperative.Digraph.ConcreteBidirectional (V)
162 module SCC = Graph.Components.Make (G)
163
164 let rec add_successors g graph addon_roots from =
165 if not(G.mem_vertex g from) then
166 begin
167 G.add_vertex g from;
168 begin match IntMap.find_opt from addon_roots with
169 | None -> ()
170 | Some li ->
171 List.iter (add_successors g graph addon_roots) li
172 end;
173 G.iter_succ
174 (fun to_ ->
175 add_successors g graph addon_roots to_;
176 G.add_edge g from to_
177 ) graph from
178 end
179
180 include Reachability(IntSet)(IntMap)(G)
181 end
182
183
184 module String =
185 struct
186 module V : Graph.Sig.COMPARABLE with type t = string =
187 struct
188 type t = string
189 let equal : string -> string -> bool = (=)
190 let hash = Hashtbl.hash
191 let compare : string -> string -> int = Pervasives.compare
192 end
193
194 module G = Graph.Imperative.Digraph.ConcreteBidirectional (V)
195 module SCC = Graph.Components.Make (G)
196 end
197 module DefaultGraphviz(G:Graph.Sig.G)(T:sig val vertex_name : G.V.t -> string end) =
198 struct
199 include Graph.Graphviz.Dot(
200 struct
201 include G
202 let graph_attributes _ = []
203 let default_vertex_attributes _ = []
204 let vertex_name = T.vertex_name
205 let vertex_attributes _ = []
206 let get_subgraph _ = None
207 let default_edge_attributes _ = []
208 let edge_attributes _ = []
209 end
210 )
211 let to_file filename g =
212 let channel = open_out filename in
213 output_graph channel g;
214 close_out channel
215 let to_file_and_ps filename_no_extension g =
216 to_file (filename_no_extension^".dot") g;
217 let exit_code =
218 Sys.command (
219 Printf.sprintf "dot -Tps %s.dot > %s.ps"
220 filename_no_extension filename_no_extension) in
221 if exit_code <> 0 then failwith "GraphUtils.DefaultGraphviz.to_file_and_ps: dot failed"
222 end
Something went wrong with that request. Please try again.