Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 323 lines (264 sloc) 9.123 kB
8634b74 initial import into fresh git repo.
pad authored
1 open Common
2
3 open Ocollection
4 open Oset
5 open Oassoc
6 (* open Ograph *)
7
8 open Oassocb
9 open Osetb
10
b77e5af @aryx * h_program-lang/graph_code.ml: more
aryx authored
11 (*****************************************************************************)
12 (* Prelude *)
13 (*****************************************************************************)
8634b74 initial import into fresh git repo.
pad authored
14 (*
b77e5af @aryx * h_program-lang/graph_code.ml: more
aryx authored
15 * An imperative directed polymorphic graph.
16 *
17 * todo?: prendre en parametre le type de finitemap et set?
18 * todo?: add_arc doit ramer, car del la key, puis add. Better to
19 * have a ref to a set?
8634b74 initial import into fresh git repo.
pad authored
20 *
21 * opti: graph with pointers and a tag visited => need keep global value
b77e5af @aryx * h_program-lang/graph_code.ml: more
aryx authored
22 * visited_counter. check(that node is in, ...), display.
8634b74 initial import into fresh git repo.
pad authored
23 * opti: when the graph structure is stable, have a method compact, that
b77e5af @aryx * h_program-lang/graph_code.ml: more
aryx authored
24 * transforms that in a matrix (assert that all number between 0 and
25 * free_index are used, or do some defrag-like-move/renaming).
8634b74 initial import into fresh git repo.
pad authored
26 *)
27
b77e5af @aryx * h_program-lang/graph_code.ml: more
aryx authored
28 (*****************************************************************************)
29 (* Types *)
30 (*****************************************************************************)
8634b74 initial import into fresh git repo.
pad authored
31 type nodei = int
32
b77e5af @aryx * h_program-lang/graph_code.ml: more
aryx authored
33 (*****************************************************************************)
34 (* Pure version *)
35 (*****************************************************************************)
36
8634b74 initial import into fresh git repo.
pad authored
37 class ['a,'b] ograph_extended =
38 let build_assoc () = new oassocb [] in (* opti?: = oassoch *)
39 let build_set () = new osetb Set_poly.empty in
40
41 object(o)
42 (* inherit ['a] ograph *)
43
44 val free_index = 0
45
46 val succ = build_assoc()
47 val pred = build_assoc()
48 val nods = build_assoc()
49
50 method add_node (e: 'a) =
51 let i = free_index in
52 ({<
53 nods = nods#add (i, e);
54 pred = pred#add (i, build_set() );
55 succ = succ#add (i, build_set() );
56 free_index = i + 1;
57 >}, i)
58
59 method add_nodei i (e: 'a) =
60 ({<
61 nods = nods#add (i, e);
62 pred = pred#add (i, build_set() );
63 succ = succ#add (i, build_set() );
64 free_index = (max free_index i) + 1;
65 >}, i)
66
67
68 method del_node (i) =
69 {<
70 (* check: e is effectively the index associated with e,
71 and check that already in *)
72
73 (* todo: assert that have no pred and succ, otherwise
74 * will have some dangling pointers
75 *)
76 nods = nods#delkey i;
77 pred = pred#delkey i;
78 succ = succ#delkey i;
79 >}
80
81 method replace_node (i, (e: 'a)) =
82 assert (nods#haskey i);
83 {<
84 nods = nods#replkey (i, e);
85 >}
86
87 method add_arc ((a,b),(v: 'b)) =
88 {<
89 succ = succ#replkey (a, (succ#find a)#add (b, v));
90 pred = pred#replkey (b, (pred#find b)#add (a, v));
91 >}
92 method del_arc ((a,b),v) =
93 {<
94 succ = succ#replkey (a, (succ#find a)#del (b,v));
95 pred = pred#replkey (b, (pred#find b)#del (a,v));
96 >}
97
98 method successors e = succ#find e
99 method predecessors e = pred#find e
100
101 method nodes = nods
102 method allsuccessors = succ
103
104 (*
105 method ancestors xs =
106 let rec aux xs acc =
107 match xs#view with (* could be done with an iter *)
108 | Empty -> acc
109 | Cons(x, xs) -> (acc#add x)
110 +> (fun newacc -> aux (o#predecessors x) newacc)
111 +> (fun newacc -> aux xs newacc)
112 in aux xs (f2()) (* (new osetb []) *)
113
114 method children xs =
115 let rec aux xs acc =
116 match xs#view with (* could be done with an iter *)
117 | Empty -> acc
118 | Cons(x, xs) -> (acc#add x)
119 +> (fun newacc -> aux (o#successors x) newacc)
120 +> (fun newacc -> aux xs newacc)
121 in aux xs (f2()) (* (new osetb []) *)
122
123 method brothers x =
124 let parents = o#predecessors x in
125 (parents#fold (fun acc e -> acc $++$ o#successors e) (f2()))#del x
126
127 *)
128
129 end
130
b77e5af @aryx * h_program-lang/graph_code.ml: more
aryx authored
131 (*****************************************************************************)
132 (* Mutable version *)
133 (*****************************************************************************)
8634b74 initial import into fresh git repo.
pad authored
134
135 class ['a,'b] ograph_mutable =
136 let build_assoc () = new oassocb [] in
137 let build_set () = new osetb Set_poly.empty in
138
139 object(o)
140
141 val mutable free_index = 0
142
143 val mutable succ = build_assoc()
144 val mutable pred = build_assoc()
145 val mutable nods = build_assoc()
146
147 method add_node (e: 'a) =
148 let i = free_index in
149 nods <- nods#add (i, e);
150 pred <- pred#add (i, build_set() );
151 succ <- succ#add (i, build_set() );
152 free_index <- i + 1;
153 i
154
155 method add_nodei i (e: 'a) =
156 nods <- nods#add (i, e);
157 pred <- pred#add (i, build_set() );
158 succ <- succ#add (i, build_set() );
159 free_index <- (max free_index i) + 1;
160
161
162 method del_node (i) =
163 (* check: e is effectively the index associated with e,
164 and check that already in *)
165
166 (* todo: assert that have no pred and succ, otherwise
167 * will have some dangling pointers
168 *)
169 nods <- nods#delkey i;
170 pred <- pred#delkey i;
171 succ <- succ#delkey i;
172
173 method replace_node (i, (e: 'a)) =
174 assert (nods#haskey i);
175 nods <- nods#replkey (i, e);
176
177 method add_arc ((a,b),(v: 'b)) =
178 succ <- succ#replkey (a, (succ#find a)#add (b, v));
179 pred <- pred#replkey (b, (pred#find b)#add (a, v));
180 method del_arc ((a,b),v) =
181 succ <- succ#replkey (a, (succ#find a)#del (b,v));
182 pred <- pred#replkey (b, (pred#find b)#del (a,v));
183
184 method successors e = succ#find e
185 method predecessors e = pred#find e
186
187 method nodes = nods
188 method allsuccessors = succ
189
190 method nb_nodes =
191 nods#length
192
193 method nb_edges =
194 nods#fold (fun acc (i, e) ->
195 let children = o#successors i in
196 acc + children#cardinal
197 ) 0
198
199 end
200
b77e5af @aryx * h_program-lang/graph_code.ml: more
aryx authored
201 (*****************************************************************************)
202 (* API *)
203 (*****************************************************************************)
8634b74 initial import into fresh git repo.
pad authored
204
205 (* depth first search *)
206 let dfs_iter xi f g =
207 let already = Hashtbl.create 101 in
208 let rec aux_dfs xs =
209 xs +> List.iter (fun xi ->
210 if Hashtbl.mem already xi then ()
211 else begin
212 Hashtbl.add already xi true;
213 f xi;
214 let succ = g#successors xi in
215 aux_dfs (succ#tolist +> List.map fst);
216 end
217 ) in
218 aux_dfs [xi]
219
220
221 let dfs_iter_with_path xi f g =
222 let already = Hashtbl.create 101 in
223 let rec aux_dfs path xi =
224 if Hashtbl.mem already xi then ()
225 else begin
226 Hashtbl.add already xi true;
227 f xi path;
228 let succ = g#successors xi in
229 let succ' = succ#tolist +> List.map fst in
230 succ' +> List.iter (fun yi ->
231 aux_dfs (xi::path) yi
232 );
233 end
234 in
235 aux_dfs [] xi
236
237
238
239 let generate_ograph_generic g label fnode filename =
240 Common.with_open_outfile filename (fun (pr,_) ->
241 pr "digraph misc {\n" ;
242 pr "size = \"10,10\";\n" ;
243 (match label with
244 None -> ()
245 | Some x -> pr (Printf.sprintf "label = \"%s\";\n" x));
246
247 let nodes = g#nodes in
248 nodes#iter (fun (k,node) ->
249 let (str,border_color,inner_color) = fnode (k, node) in
250 let color =
251 match inner_color with
252 None ->
253 (match border_color with
254 None -> ""
255 | Some x -> Printf.sprintf ", style=\"setlinewidth(3)\", color = %s" x)
256 | Some x ->
257 (match border_color with
258 None -> Printf.sprintf ", style=\"setlinewidth(3),filled\", fillcolor = %s" x
259 | Some x' -> Printf.sprintf ", style=\"setlinewidth(3),filled\", fillcolor = %s, color = %s" x x') in
260 (* so can see if nodes without arcs were created *)
261 pr (sprintf "%d [label=\"%s [%d]\"%s];\n" k str k color)
262 );
263
264 nodes#iter (fun (k,node) ->
265 let succ = g#successors k in
266 succ#iter (fun (j,edge) ->
267 pr (sprintf "%d -> %d;\n" k j);
268 );
269 );
270 pr "}\n" ;
271 );
272 ()
273
274
275 let generate_ograph_xxx g filename =
276 with_open_outfile filename (fun (pr,_) ->
277 pr "digraph misc {\n" ;
278 pr "size = \"10,10\";\n" ;
279
280 let nodes = g#nodes in
281 nodes#iter (fun (k,(node, s)) ->
282 (* so can see if nodes without arcs were created *)
283 pr (sprintf "%d [label=\"%s [%d]\"];\n" k s k)
284 );
285
286 nodes#iter (fun (k,node) ->
287 let succ = g#successors k in
288 succ#iter (fun (j,edge) ->
289 pr (sprintf "%d -> %d;\n" k j);
290 );
291 );
292 pr "}\n" ;
293 );
294 ()
295
296
297 let launch_gv_cmd filename =
298 let _status =
299 Unix.system ("dot " ^ filename ^ " -Tps -o " ^ filename ^ ".ps;") in
300 let _status = Unix.system ("gv " ^ filename ^ ".ps &")
301 in
302 (* zarb: I need this when I launch the program via eshell, otherwise gv
303 do not get the chance to be launched *)
304 Unix.sleep 1;
305 ()
306
307 let print_ograph_extended g filename launchgv =
308 generate_ograph_xxx g filename;
309 if launchgv then launch_gv_cmd filename
310
311 let print_ograph_mutable g filename launchgv =
312 generate_ograph_xxx g filename;
313 if launchgv then launch_gv_cmd filename
314
315 let print_ograph_mutable_generic
316 ?(title=None)
317 ?(launch_gv = true)
318 ?(output_file = "/tmp/ograph.dot")
319 ~s_of_node
320 g =
321 generate_ograph_generic g title s_of_node output_file;
322 if launch_gv then launch_gv_cmd output_file
Something went wrong with that request. Please try again.