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