Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
325 lines (266 sloc) 8.92 KB
open Common
open Ocollection
open Oset
open Oassoc
(* open Ograph *)
open Oassocb
open Osetb
(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(*
* An imperative directed polymorphic graph.
*
* todo?: prendre en parametre le type de finitemap et set?
* todo?: add_arc doit ramer, car del la key, puis add. Better to
* have a ref to a set?
*
* opti: graph with pointers and a tag visited => need keep global value
* visited_counter. check(that node is in, ...), display.
* opti: when the graph structure is stable, have a method compact, that
* transforms that in a matrix (assert that all number between 0 and
* free_index are used, or do some defrag-like-move/renaming).
*)
(*****************************************************************************)
(* Types *)
(*****************************************************************************)
type nodei = int
(*****************************************************************************)
(* Pure version *)
(*****************************************************************************)
class ['a,'b] ograph_extended =
let build_assoc () = new oassocb [] in (* opti?: = oassoch *)
let build_set () = new osetb Set_poly.empty in
object(o)
(* inherit ['a] ograph *)
val free_index = 0
val succ = build_assoc()
val pred = build_assoc()
val nods = build_assoc()
method add_node (e: 'a) =
let i = free_index in
({<
nods = nods#add (i, e);
pred = pred#add (i, build_set() );
succ = succ#add (i, build_set() );
free_index = i + 1;
>}, i)
method add_nodei i (e: 'a) =
({<
nods = nods#add (i, e);
pred = pred#add (i, build_set() );
succ = succ#add (i, build_set() );
free_index = (max free_index i) + 1;
>}, i)
method del_node (i) =
{<
(* check: e is effectively the index associated with e,
and check that already in *)
(* todo: assert that have no pred and succ, otherwise
* will have some dangling pointers
*)
nods = nods#delkey i;
pred = pred#delkey i;
succ = succ#delkey i;
>}
method replace_node (i, (e: 'a)) =
assert (nods#haskey i);
{<
nods = nods#replkey (i, e);
>}
method add_arc ((a,b),(v: 'b)) =
{<
succ = succ#replkey (a, (succ#find a)#add (b, v));
pred = pred#replkey (b, (pred#find b)#add (a, v));
>}
method del_arc ((a,b),v) =
{<
succ = succ#replkey (a, (succ#find a)#del (b,v));
pred = pred#replkey (b, (pred#find b)#del (a,v));
>}
method successors e = succ#find e
method predecessors e = pred#find e
method nodes = nods
method allsuccessors = succ
(*
method ancestors xs =
let rec aux xs acc =
match xs#view with (* could be done with an iter *)
| Empty -> acc
| Cons(x, xs) -> (acc#add x)
+> (fun newacc -> aux (o#predecessors x) newacc)
+> (fun newacc -> aux xs newacc)
in aux xs (f2()) (* (new osetb []) *)
method children xs =
let rec aux xs acc =
match xs#view with (* could be done with an iter *)
| Empty -> acc
| Cons(x, xs) -> (acc#add x)
+> (fun newacc -> aux (o#successors x) newacc)
+> (fun newacc -> aux xs newacc)
in aux xs (f2()) (* (new osetb []) *)
method brothers x =
let parents = o#predecessors x in
(parents#fold (fun acc e -> acc $++$ o#successors e) (f2()))#del x
*)
end
(*****************************************************************************)
(* Mutable version *)
(*****************************************************************************)
class ['a,'b] ograph_mutable =
let build_assoc () = new oassocb [] in
let build_set () = new osetb Set_poly.empty in
object(o)
val mutable free_index = 0
val mutable succ = build_assoc()
val mutable pred = build_assoc()
val mutable nods = build_assoc()
method add_node (e: 'a) =
let i = free_index in
nods <- nods#add (i, e);
pred <- pred#add (i, build_set() );
succ <- succ#add (i, build_set() );
free_index <- i + 1;
i
method add_nodei i (e: 'a) =
nods <- nods#add (i, e);
pred <- pred#add (i, build_set() );
succ <- succ#add (i, build_set() );
free_index <- (max free_index i) + 1;
method del_node (i) =
(* check: e is effectively the index associated with e,
and check that already in *)
(* todo: assert that have no pred and succ, otherwise
* will have some dangling pointers
*)
nods <- nods#delkey i;
pred <- pred#delkey i;
succ <- succ#delkey i;
method replace_node (i, (e: 'a)) =
assert (nods#haskey i);
nods <- nods#replkey (i, e);
method add_arc ((a,b),(v: 'b)) =
succ <- succ#replkey (a, (succ#find a)#add (b, v));
pred <- pred#replkey (b, (pred#find b)#add (a, v));
method del_arc ((a,b),v) =
succ <- succ#replkey (a, (succ#find a)#del (b,v));
pred <- pred#replkey (b, (pred#find b)#del (a,v));
method successors e = succ#find e
method predecessors e = pred#find e
method nodes = nods
method allsuccessors = succ
method nb_nodes =
nods#length
method nb_edges =
nods#fold (fun acc (i, e) ->
let children = o#successors i in
acc + children#cardinal
) 0
end
(*****************************************************************************)
(* API *)
(*****************************************************************************)
(* depth first search *)
let dfs_iter xi f g =
let already = Hashtbl.create 101 in
let rec aux_dfs xs =
xs +> List.iter (fun xi ->
if Hashtbl.mem already xi then ()
else begin
Hashtbl.add already xi true;
f xi;
let succ = g#successors xi in
aux_dfs (succ#tolist +> List.map fst);
end
) in
aux_dfs [xi]
let dfs_iter_with_path xi f g =
let already = Hashtbl.create 101 in
let rec aux_dfs path xi =
if Hashtbl.mem already xi then ()
else begin
Hashtbl.add already xi true;
f xi path;
let succ = g#successors xi in
let succ' = succ#tolist +> List.map fst in
succ' +> List.iter (fun yi ->
aux_dfs (xi::path) yi
);
end
in
aux_dfs [] xi
let generate_ograph_generic g label fnode filename =
Common.with_open_outfile filename (fun (pr,_) ->
pr "digraph misc {\n" ;
pr "size = \"10,10\";\n" ;
(match label with
None -> ()
| Some x -> pr (Printf.sprintf "label = \"%s\";\n" x));
let nodes = g#nodes in
nodes#iter (fun (k,node) ->
let (str,border_color,inner_color) = fnode (k, node) in
let color =
match inner_color with
None ->
(match border_color with
None -> ""
| Some x -> Printf.sprintf ", style=\"setlinewidth(3)\", color = %s" x)
| Some x ->
(match border_color with
None -> Printf.sprintf ", style=\"setlinewidth(3),filled\", fillcolor = %s" x
| Some x' -> Printf.sprintf ", style=\"setlinewidth(3),filled\", fillcolor = %s, color = %s" x x') in
(* so can see if nodes without arcs were created *)
pr (spf "%d [label=\"%s [%d]\"%s];\n" k str k color)
);
nodes#iter (fun (k,node) ->
let succ = g#successors k in
succ#iter (fun (j,edge) ->
pr (spf "%d -> %d;\n" k j);
);
);
pr "}\n" ;
);
()
let generate_ograph_xxx g filename =
with_open_outfile filename (fun (pr,_) ->
pr "digraph misc {\n" ;
pr "size = \"10,10\";\n" ;
let nodes = g#nodes in
nodes#iter (fun (k,(node, s)) ->
(* so can see if nodes without arcs were created *)
pr (spf "%d [label=\"%s [%d]\"];\n" k s k)
);
nodes#iter (fun (k,node) ->
let succ = g#successors k in
succ#iter (fun (j,edge) ->
pr (spf "%d -> %d;\n" k j);
);
);
pr "}\n" ;
);
()
let launch_gv_cmd filename =
let _status =
Unix.system ("dot " ^ filename ^ " -Tps -o " ^ filename ^ ".ps;") in
let _status =
Unix.system ("gv " ^ filename ^ ".ps")
in
(* zarb: I needed this when I launch the program with '&' via eshell,
* otherwise gv did not get the chance to be launched
* Unix.sleep 1;
*)
()
let print_ograph_extended g filename launchgv =
generate_ograph_xxx g filename;
if launchgv then launch_gv_cmd filename
let print_ograph_mutable g filename launchgv =
generate_ograph_xxx g filename;
if launchgv then launch_gv_cmd filename
let print_ograph_mutable_generic
?(title=None)
?(launch_gv = true)
?(output_file = "/tmp/ograph.dot")
~s_of_node
g =
generate_ograph_generic g title s_of_node output_file;
if launch_gv then launch_gv_cmd output_file