13 * - node: index -> nodevalue
14 * - arc: (index * index) * edgevalue
16 * invariant: key in pred is also in succ (completness) and value in
17 * either assoc is a key also.
19 * How ? matrix ? but no growing array :(
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.
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.
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).
41 class ['a
,'b
] ograph_extended
=
42 let build_assoc () = new oassocb
[] in (* opti?: = oassoch *)
43 let build_set () = new osetb
Setb.empty
in
46 (* inherit ['a] ograph *)
50 val succ
= build_assoc()
51 val pred
= build_assoc()
52 val nods
= build_assoc()
54 method add_node
(e
: 'a
) =
57 nods
= nods#add
(i, e
);
58 pred
= pred#add
(i, build_set() );
59 succ
= succ#add
(i, build_set() );
63 method add_nodei
i (e
: 'a
) =
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;
74 (* check: e is effectively the index associated with e,
75 and check that already in *)
77 (* todo: assert that have no pred and succ, otherwise
78 * will have some dangling pointers
85 method replace_node
(i, (e
: 'a
)) =
86 assert (nods#haskey
i);
88 nods
= nods#replkey
(i, e
);
91 method add_arc
((a
,b
),(v
: 'b
)) =
93 succ
= succ#replkey
(a
, (succ#find a
)#add
(b
, v
));
94 pred
= pred#replkey
(b
, (pred#find b
)#add
(a
, v
));
96 method del_arc
((a
,b
),v
) =
98 succ
= succ#replkey
(a
, (succ#find a
)#del
(b
,v
));
99 pred
= pred#replkey
(b
, (pred#find b
)#del
(a
,v
));
102 method successors e
= succ#find e
103 method predecessors e
= pred#find e
106 method allsuccessors
= succ
109 method ancestors xs =
111 match xs#view with (* could be done with an iter *)
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 []) *)
120 match xs#view
with (* could be done with an iter *)
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 []) *)
128 let parents = o#predecessors x
in
129 (parents#fold
(fun acc e
-> acc $
++$ o#successors e
) (f2
()))#del x
138 class ['a
,'b
] ograph_mutable
=
139 let build_assoc () = new oassocb
[] in
140 let build_set () = new osetb
Setb.empty
in
144 val mutable free_index
= 0
146 val mutable succ
= build_assoc()
147 val mutable pred
= build_assoc()
148 val mutable nods
= build_assoc()
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() );
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;
165 method del_node
(i) =
166 (* check: e is effectively the index associated with e,
167 and check that already in *)
169 (* todo: assert that have no pred and succ, otherwise
170 * will have some dangling pointers
172 nods
<- nods#delkey
i;
173 pred
<- pred#delkey
i;
174 succ
<- succ#delkey
i;
176 method replace_node
(i, (e
: 'a
)) =
177 assert (nods#haskey
i);
178 nods
<- nods#replkey
(i, e
);
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
));
187 method successors e
= succ#find e
188 method predecessors e
= pred#find e
191 method allsuccessors
= succ
196 (* depth first search *)
197 let dfs_iter xi f g
=
198 let already = Hashtbl.create
101 in
200 xs
+> List.iter
(fun xi
->
201 if Hashtbl.mem
already xi
then ()
203 Hashtbl.add
already xi
true;
205 let succ = g#successors xi
in
206 aux_dfs (succ#tolist
+> List.map fst
);
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 ()
217 Hashtbl.add
already xi
true;
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
230 let generate_ograph_generic g label fnode filename
=
231 Common.with_open_outfile filename
(fun (pr
,_
) ->
232 pr
"digraph misc {\n" ;
233 pr
"size = \"10,10\";\n" ;
236 | Some x
-> pr
(Printf.sprintf
"label = \"%s\";\n" x
));
238 let nodes = g#
nodes in
239 nodes#iter
(fun (k
,node
) ->
240 let (str
,border_color
,inner_color
) = fnode
(k
, node
) in
242 match inner_color
with
244 (match border_color
with
246 | Some x
-> Printf.sprintf
", style=\"setlinewidth(3)\", color = %s" 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)
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
);
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" ;
271 let nodes = g#
nodes in
272 nodes#iter
(fun (k
,(node
, s
)) ->
273 (* so can see if nodes without arcs were created *)
274 pr
(sprintf
"%d [label=\"%s [%d]\"];\n" k s k
)
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
);
288 let launch_gv_cmd filename
=
290 Unix.system
("dot " ^ filename ^
" -Tps -o " ^ filename ^
".ps;") in
291 let _status = Unix.system
("gv " ^ filename ^
".ps &")
293 (* zarb: I need this when I launch the program via eshell, otherwise gv
294 do not get the chance to be launched *)
298 let print_ograph_extended g filename launchgv
=
299 generate_ograph_xxx g filename
;
300 if launchgv
then launch_gv_cmd filename
302 let print_ograph_mutable g filename launchgv
=
303 generate_ograph_xxx g filename
;
304 if launchgv
then launch_gv_cmd filename
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