diff --git a/lib/sasacore/dune b/lib/sasacore/dune
index 07bbbd9c0d8105c81953f1f0da806a679ac3a309..3b807dc3c8cf1ab549c0a28f53976f1b344f18a7 100644
--- a/lib/sasacore/dune
+++ b/lib/sasacore/dune
@@ -1,9 +1,9 @@
-;; Time-stamp: <modified the 06/09/2019 (at 10:09) by Erwan Jahier>
+;; Time-stamp: <modified the 14/10/2019 (at 20:15) by Erwan Jahier>
(library
(name sasacore)
(public_name sasacore)
- (libraries ocamlgraph lutils)
+ (libraries dynlink ocamlgraph lutils)
;;
; (wrapped false)
diff --git a/lib/sasacore/topology.ml b/lib/sasacore/topology.ml
index 72a2b35ec6216eac193f357903aed7a5eb284d83..83a70e33dea3cdbce7923ea3e8f01576f1ed2111 100644
--- a/lib/sasacore/topology.ml
+++ b/lib/sasacore/topology.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 14/10/2019 (at 14:33) by Erwan Jahier> *)
+(* Time-stamp: <modified the 14/10/2019 (at 16:50) by Erwan Jahier> *)
open Graph
open Graph.Dot_ast
@@ -102,8 +102,10 @@ let (do_stmt: bool -> node list -> Dot_ast.stmt -> node list) =
"Bad topology: %s can not ne a neighbor of itself!" n1);
let pn1 = try Hashtbl.find node_succ n1 with Not_found -> [] in
let pn2 = try Hashtbl.find node_succ n2 with Not_found -> [] in
- Hashtbl.replace node_succ n1 ((weight,n2)::pn1);
- if not directed then Hashtbl.replace node_succ n2 ((None,n1)::pn2);
+ if not (List.mem (weight,n2) pn1) then
+ Hashtbl.replace node_succ n1 ((weight,n2)::pn1);
+ if not directed && not (List.mem (None,n1) pn2) then
+ Hashtbl.replace node_succ n2 ((None,n1)::pn2);
n2
in
ignore (List.fold_left add_edge node nodes);
@@ -127,54 +129,6 @@ let (read: string -> t) = fun f ->
)
}
-
-let make_links_dot : (t -> string) =
- fun t ->
- let links = List.flatten (
- List.map (fun n ->
- let l = t.succ n.id in
- List.map (fun (w,neighbour) ->
- (
- match w with
- | None -> if n.id < neighbour then
- Printf.sprintf (" %s -- %s") n.id neighbour
- else
- Printf.sprintf (" %s -- %s") neighbour n.id
- | Some x ->
- Printf.sprintf (" %s -- %s [weight=%d]") n.id neighbour x
- )
-
- ) l
- ) t.nodes
- ) in
- String.concat "\n" (List.sort_uniq compare links)
-
-let rec make_nodes_dot : (node list -> string) =
- (*Create a string in the dot syntax from a node list*)
- function
- | [] -> ""
- | (node)::tail -> (
- Printf.sprintf " %s [algo=\"%s\"]\n%s" node.id node.file) (make_nodes_dot tail)
-
-let make_dot : (t -> string -> unit) =
- (*Create a dot file from a graph*)
- fun t file_name ->
- let name = ref "graph0" in
- let f = (if file_name = "" then stdout else
- (
- name := Filename.basename file_name;
- (try ( (* remove all extensions. So if name = ref "tt.dot.dot" at the beginning, at the end name = ref "tt". *)
- while true do
- name := Filename.chop_extension !name;
- done;
- ) with Invalid_argument _ -> ());
- open_out file_name
- )
- ) in
- let dot = (Printf.sprintf "graph %s {\n\n" !name) ^ (make_nodes_dot t.nodes) ^ "\n" ^ (make_links_dot t) ^ "\n}\n" in
- Printf.fprintf f "%s" dot
- (*ignore (Sys.command (Printf.sprintf "echo \"%s\" > \"%s.dot\"" dot file_name)); ()*)
-
let (to_adjency: t -> bool array array) =
fun t ->
let n = List.length t.nodes in
@@ -188,4 +142,73 @@ let (to_adjency: t -> bool array array) =
)
t.nodes;
m
-
+let (get_degree:t -> int*int) =
+ fun t -> if t.nodes = [] then 0,0
+ else
+ let node_deg n = List.length (t.succ (n.id)) in
+ let d_start = node_deg ((List.hd t.nodes)) in
+ List.fold_left (fun (d_min,d_max) n ->
+ (min (node_deg n) d_min, max (node_deg n) d_max)
+ ) (d_start,d_start) (List.tl t.nodes)
+
+(* take a graph t and a boolean is_oriented and return the number of
+ link in the graph *)
+let (get_nb_link: t -> bool -> int) =
+ fun t is_oriented ->
+ if not is_oriented then
+ (List.fold_left
+ (fun acc n -> ((List.length (t.succ n.id))) + acc) (0) (t.nodes)) / 2
+ else
+ (List.fold_left
+ (fun acc n -> ((List.length (t.succ n.id))) + acc) (0) (t.nodes))
+
+let (get_mean_degree : t -> float) =
+ fun t ->
+ (float_of_int (get_nb_link t true)) /. (float_of_int (List.length t.nodes))
+
+let bfs : (t -> string -> bool * string list) =
+ fun t n ->
+ let q = Queue.create () in
+ let discovered = ref [n] and parent = ref (function _ -> "") in
+ let cyclic = ref false in
+ Queue.add n q;
+ while not (Queue.is_empty q) do
+ let node = Queue.take q in
+ parent := List.fold_left (fun parents (_,suc) ->
+ if List.for_all (fun disc -> disc <> suc) !discovered
+ then (
+ Queue.add suc q;
+ discovered := (suc)::!discovered;
+ function a -> if a = suc then node else parents a
+ ) else ((
+ if suc <> (parents node)
+ then
+ cyclic := true);
+ parents
+ )
+ ) !parent (t.succ node)
+
+ done;
+ (!cyclic, !discovered)
+
+let is_connected_and_cyclic : t -> bool*bool =
+ fun t -> match t.nodes with
+ | [] -> (false,false)
+ | hd::_ ->
+ let (cyclic,bfs_nodes) = (bfs t hd.id) in
+ ((List.compare_lengths t.nodes bfs_nodes) = 0, cyclic)
+
+let rec height : string list -> t -> string -> int =
+ fun parents t n ->
+ (List.fold_left (fun h (_,succ) ->
+ if List.mem succ parents then
+ h
+ else
+ max h (height (n::parents) t succ)) (-1) (t.succ n)) + 1
+
+let get_height : t -> string -> int =
+ fun t ->
+ height ([]) t
+
+(********************************************)
+
diff --git a/lib/sasacore/topology.mli b/lib/sasacore/topology.mli
index bbea959405b2748c02527aebad34354cf4009810..ad9f732caa692ac265de42bcbbb294b6d34c0eaf 100644
--- a/lib/sasacore/topology.mli
+++ b/lib/sasacore/topology.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 05/07/2019 (at 16:19) by Erwan Jahier> *)
+(* Time-stamp: <modified the 14/10/2019 (at 16:55) by Erwan Jahier> *)
type node_id = string
type node = {
@@ -17,17 +17,13 @@ type t = {
(** Parse a sasa dot file *)
val read: string -> t
-
-(** Create a string containing the links of the graph given in argument in a DOT syntax *)
-val make_links_dot : (t -> string)
-
-(** Create a string containing the nodes given in argument in a DOT syntax *)
-val make_nodes_dot : (node list -> string)
-
-(** Create a DOT file from a graph *)
-val make_dot : (t -> string -> unit)
+val to_adjency: t -> bool array array
+val get_degree: t -> int*int
+val get_nb_link: t -> bool -> int
+val get_mean_degree : t -> float
+val is_connected_and_cyclic : t -> bool*bool
+val height : string list -> t -> string -> int
+val get_height : t -> string -> int
-val to_adjency: t -> bool array array
-
diff --git a/test/rdbg-utils/dot.ml b/test/rdbg-utils/dot.ml
index 432f42307c1c46f631fb40eeecf05309c127e37e..636fbbb9c2710b3bfd3d0561a8a9a8807bebfa7a 100644
--- a/test/rdbg-utils/dot.ml
+++ b/test/rdbg-utils/dot.ml
@@ -123,7 +123,8 @@ let to_pdf engine par_var g f e =
let enabled = if enabled = "" then "" else (enabled^"|") in
let loc = String.concat "|"
(List.map (fun (n,v) ->
- Printf.sprintf "%s=%s" n (Data.val_to_string string_of_float v))
+ Printf.sprintf "%s=%s" n
+ (Data.val_to_string string_of_float v))
pid.vars
)
in
@@ -161,7 +162,8 @@ let to_pdf engine par_var g f e =
let trans_dir,trans_undir = List.partition is_directed trans in
let trans_dir_str = String.concat "\n" trans_dir in
let trans_undir_str = String.concat "\n" trans_undir in
- let trans_undir_str = Str.global_replace (Str.regexp "--") "->" trans_undir_str in
+ let trans_undir_str =
+ Str.global_replace (Str.regexp "--") "->" trans_undir_str in
let trans_str =
(* if trans_dir_str = "" then trans_undir_str else *)
Printf.sprintf "subgraph dir {\n\t%s}
diff --git a/tools/ggDeco/ggDeco.ml b/tools/ggDeco/ggDeco.ml
index fc7b0d38d93d42f296a57f1fbb332a0b4a454530..7e188aff18e0b0c9a945d292338a46e3823a0767 100644
--- a/tools/ggDeco/ggDeco.ml
+++ b/tools/ggDeco/ggDeco.ml
@@ -1,7 +1,7 @@
+open GgDeco_Arg
open Sasacore
open Topology
-open GgDeco_Arg
exception Crossover (* Two different intervals crossover each-other *)
exception No_file_for of int
@@ -51,6 +51,62 @@ let deco : (Topology.t -> files_spec_t list -> Topology.t) =
of_id = g.of_id;
}
+
+(**********************************************************)
+(* XXX duplicated from GraphGen !! *)
+let to_dot_string : (t -> string -> string) =
+ fun g name ->
+ let node_to_node_string n =
+ Printf.sprintf " %s [algo=\"%s\"]\n" n.id n.file
+ in
+ let nodes = String.concat "\n" (List.map node_to_node_string g.Topology.nodes) in
+
+ let node_to_link_string n =
+ let succ = g.succ n.id in
+ let links =
+ List.map
+ (fun (w,neighbour) ->
+ (match w with
+ | None ->
+ if n.id < neighbour then
+ Printf.sprintf (" %s -- %s") n.id neighbour
+ else
+ Printf.sprintf (" %s -- %s") neighbour n.id
+ | Some x ->
+ Printf.sprintf (" %s -- %s [weight=%d]") n.id neighbour x
+ )
+ )
+ succ
+ in
+ links
+ in
+ let links = List.map node_to_link_string g.nodes in
+ let links = List.sort_uniq compare (List.flatten links) in
+ let links = String.concat "\n" links in
+ Printf.sprintf "graph %s {\n\n%s\n%s\n}\n" name nodes links
+
+
+let make_dot : (t -> string -> unit) =
+ (*Create a dot file from a graph*)
+ fun t file_name ->
+ let name = ref "graph0" in
+ let dot = to_dot_string t file_name in
+ let oc = if file_name = "" then stdout
+ else (
+ name := Filename.basename file_name;
+ (try ( (* remove all extensions. So if name = ref "tt.dot.dot"
+ at the beginning, at the end name = ref "tt". *)
+ while true do
+ name := Filename.chop_extension !name;
+ done;
+ ) with Invalid_argument _ -> ());
+ open_out file_name
+ )
+ in
+ Printf.fprintf oc "%s\n" dot
+ (*ignore (Sys.command (Printf.sprintf "echo \"%s\" > \"%s.dot\"" dot file_name)); ()*)
+(**********************************************************)
+
let () = (
let args = parse Sys.argv in
let g = read args.dot_file in
diff --git a/tools/graphgen/graphGen.ml b/tools/graphgen/graphGen.ml
index f4f2e1db336b76ed5b22990201a44a73051fd2ff..1475dab4dec06019c68e9d501cf19534a81f2f19 100644
--- a/tools/graphgen/graphGen.ml
+++ b/tools/graphgen/graphGen.ml
@@ -1,17 +1,17 @@
-open Sasacore
-open Topology
(* open GraphProp *)
open ClassicGraph
open RandomGraph
open GraphGen_arg
open UdgUtils
+open Sasacore
+open Topology
exception Incorrect_attribute
let min_max = ref None
let connected_cyclic = ref None
-let height = ref None
+let height:int option ref = ref None
let generate_du_dur graph plan_udg t : unit =
@@ -24,7 +24,7 @@ let generate_du_dur graph plan_udg t : unit =
);
()
-let compute_attr : (Topology.t -> string list -> (string*string) list) =
+let compute_attr : (Topology.t -> string list -> (string * string) list) =
fun g ->
List.map
(fun attr ->
@@ -71,55 +71,105 @@ let compute_attr : (Topology.t -> string list -> (string*string) list) =
(fst x) && (snd x))
| Some x -> (fst x) && (snd x) )
| "links_number" -> string_of_int (get_nb_link g false)
- | "diameter" -> string_of_int (get_diameter g)
+ | "diameter" -> string_of_int (Diameter.get g)
| s -> string_of_int (let s = String.split_on_char ' ' s in
if List.hd s = "height" && List.length s = 2 then
get_height g (List.hd (List.tl s))
else raise Incorrect_attribute)
)
-
+let to_dot_string : (t -> string -> string) =
+ fun g name ->
+ let node_to_node_string n =
+ Printf.sprintf " %s [algo=\"%s\"]\n" n.id n.file
+ in
+ let nodes = String.concat "\n" (List.map node_to_node_string g.nodes) in
+
+ let node_to_link_string n =
+ let succ = g.succ n.id in
+ let links =
+ List.map
+ (fun (w,neighbour) ->
+ (match w with
+ | None ->
+ if n.id < neighbour then
+ Printf.sprintf (" %s -- %s") n.id neighbour
+ else
+ Printf.sprintf (" %s -- %s") neighbour n.id
+ | Some x ->
+ Printf.sprintf (" %s -- %s [weight=%d]") n.id neighbour x
+ )
+ )
+ succ
+ in
+ links
+ in
+ let links = List.map node_to_link_string g.nodes in
+ let links = List.sort_uniq compare (List.flatten links) in
+ let links = String.concat "\n" links in
+ Printf.sprintf "graph %s {\n\n%s\n%s\n}\n" name nodes links
+
+
+let make_dot : (t -> string -> (string * string) list -> unit) =
+ (*Create a dot file from a graph*)
+ fun t file_name _attrs ->
+ let name = ref "graph0" in
+ let dot = to_dot_string t file_name in
+ let oc = if file_name = "" then stdout
+ else (
+ name := Filename.basename file_name;
+ (try ( (* remove all extensions. So if name = ref "tt.dot.dot"
+ at the beginning, at the end name = ref "tt". *)
+ while true do
+ name := Filename.chop_extension !name;
+ done;
+ ) with Invalid_argument _ -> ());
+ open_out file_name
+ )
+ in
+ Printf.fprintf oc "%s\n" dot
+ (*ignore (Sys.command (Printf.sprintf "echo \"%s\" > \"%s.dot\"" dot file_name)); ()*)
let () = (
- let t = parse Sys.argv in
+ let t = parse Sys.argv in
- if (t.n < 0) then (
- let msg = match t.action with
- | "void" | "grid" -> ""
- | "HC" -> (
- t.n <- 3;
- "=========================================================================\n"^
- "Caution : the dimension is not defined or negative. It has been set to 3.\n"^
- "=========================================================================\n"
- )
- | _ -> (
- t.n <- 10;
- "=============================================================================\n"^
- "Caution : the nodes number is not defined or negative. It has been set to 10.\n"^
+ if (t.n < 0) then (
+ let msg = match t.action with
+ | "void" | "grid" -> ""
+ | "HC" -> (
+ t.n <- 3;
+ "=========================================================================\n"^
+ "Caution : the dimension is not defined or negative. It has been set to 3.\n"^
+ "=========================================================================\n"
+ )
+ | _ -> (
+ t.n <- 10;
+ "=============================================================================\n"^
+ "Caution : the nodes number is not defined or negative. It has been set to 10.\n"^
"=============================================================================\n"
- ) in
- if (not t.silent) then Printf.fprintf stderr "%s" msg
- );
- if (t.outputFile <> "" && not t.silent)
+ ) in
+ if (not t.silent) then Printf.fprintf stderr "%s" msg
+ );
+ if (t.outputFile <> "" && not t.silent)
then Printf.printf "Generating a %s graph...\n" t.action;
- let g = ( match t.action with
- | "void" -> exit 0
- | "clique" -> (gen_clique t.n)
- | "star" -> (gen_star t.n)
- | "ring" -> (gen_ring t.n)
- | "grid" -> (gen_grid t.grid.height t.grid.width)
- | "HC" -> (gen_hyper_cube t.n)
- | "ER" -> (gen_ER t.n t.er)
- | "BA" -> (gen_BA t.n t.ba)
- | "tree" -> (rand_tree t.n)
- | "UDG" -> (let (graph, plan) = gen_udg t.n t.qudg.width t.qudg.height t.qudg.radius in
- generate_du_dur graph plan t; graph)
- | "QUDG" -> (let (graph, plan) = gen_qudg t.n t.qudg.width t.qudg.height t.qudg.radius t.qudg.r1 t.qudg.p in
- generate_du_dur graph plan t; graph)
- | _ -> (Printf.fprintf stderr "Unexpected outcome. Command line : %s\n"
- (String.concat " " (Array.to_list Sys.argv)); assert false)
- ) in
+ let g = ( match t.action with
+ | "void" -> exit 0
+ | "clique" -> (gen_clique t.n)
+ | "star" -> (gen_star t.n)
+ | "ring" -> (gen_ring t.n)
+ | "grid" -> (gen_grid t.grid.height t.grid.width)
+ | "HC" -> (gen_hyper_cube t.n)
+ | "ER" -> (gen_ER t.n t.er)
+ | "BA" -> (gen_BA t.n t.ba)
+ | "tree" -> (rand_tree t.n)
+ | "UDG" -> (let (graph, plan) = gen_udg t.n t.qudg.width t.qudg.height t.qudg.radius in
+ generate_du_dur graph plan t; graph)
+ | "QUDG" -> (let (graph, plan) = gen_qudg t.n t.qudg.width t.qudg.height t.qudg.radius t.qudg.r1 t.qudg.p in
+ generate_du_dur graph plan t; graph)
+ | _ -> (Printf.fprintf stderr "Unexpected outcome. Command line : %s\n"
+ (String.concat " " (Array.to_list Sys.argv)); assert false)
+ ) in
make_dot g t.outputFile (compute_attr g t.attr);
- if (t.outputFile <> "" && not t.silent)
+ if (t.outputFile <> "" && not t.silent)
then Printf.printf "Done.\nOutput file : '%s'\n" t.outputFile
-)
+ )
diff --git a/tools/graphgen/udgUtils.ml b/tools/graphgen/udgUtils.ml
index 8dd52f8ad7764a963e2c5984f5843436f37612ae..2e32dcec215bf3f3677379e8073b101762bb5ec3 100644
--- a/tools/graphgen/udgUtils.ml
+++ b/tools/graphgen/udgUtils.ml
@@ -33,42 +33,71 @@ let compute_mean_degree : (int -> float -> float -> float -> float) =
(******************************************************************************)
let rec make_nodes_dot_udg : (node_udg list -> float -> float -> string) =
- (*Create a string in the dot syntax from a node list*)
- fun nudg r0 r1 ->
- match nudg with
- | [] -> ""
- | head::tail ->
- let (node,x,y) = head in
- (Printf.sprintf "%s [pos=\"%f,%f!\"]\n" node x y )^
- let draw_rad = (if (r0 > 0.) then
- (Printf.sprintf "%srad [pos=\"%f,%f!\",width=%f, length=%f,shape = circle,label=\"\",color=\"red\"]\n"
- node x y (2.*.r0) (2.*.r0) ) else "")^
- if(r1 > r0) then
- (Printf.sprintf "%srad2 [pos=\"%f,%f!\",width=%f, length=%f,shape = circle,label=\"\",color=\"lightblue\"]\n"
- node x y (2.*.r1) (2.*.r1) ) else "" in
- draw_rad^(make_nodes_dot_udg tail r0 r1)
+ (*Create a string in the dot syntax from a node list*)
+ fun nudg r0 r1 ->
+ match nudg with
+ | [] -> ""
+ | head::tail ->
+ let (node,x,y) = head in
+ (Printf.sprintf "%s [pos=\"%f,%f!\"]\n" node x y )^
+ let draw_rad = (if (r0 > 0.) then
+ (Printf.sprintf "%srad [pos=\"%f,%f!\",width=%f, length=%f,shape = circle,label=\"\",color=\"red\"]\n"
+ node x y (2.*.r0) (2.*.r0) ) else "")^
+ if(r1 > r0) then
+ (Printf.sprintf "%srad2 [pos=\"%f,%f!\",width=%f, length=%f,shape = circle,label=\"\",color=\"lightblue\"]\n"
+ node x y (2.*.r1) (2.*.r1) ) else "" in
+ draw_rad^(make_nodes_dot_udg tail r0 r1)
-let make_dot_udg_qudg : (Topology.t -> plan_udg -> (float*float) -> ?r0:float -> ?r1:float -> string -> unit) =
- (*Create a dot file from a graph*)
- fun t plan dim ?(r0 = 0.) ?(r1 = 0.) file_name ->
- let name = ref "graph0" in (* default name *)
- let f = (if file_name = "" then stdout else
- (
- name := file_name;
- (try ( (* remove all extensions. So if name = ref "tt.dot.dot" at the beginning, at the end name = ref "tt". *)
+(* XXX duplicates GraphGen.to_dot_string *)
+let make_links_dot g =
+ let node_to_link_string n =
+ let succ = g.succ n.id in
+ let links =
+ List.map
+ (fun (w,neighbour) ->
+ (match w with
+ | None ->
+ if n.id < neighbour then
+ Printf.sprintf (" %s -- %s") n.id neighbour
+ else
+ Printf.sprintf (" %s -- %s") neighbour n.id
+ | Some x ->
+ Printf.sprintf (" %s -- %s [weight=%d]") n.id neighbour x
+ )
+ )
+ succ
+ in
+ links
+ in
+ let links = List.map node_to_link_string g.nodes in
+ let links = List.sort_uniq compare (List.flatten links) in
+ let links = String.concat "\n" links in
+ links
+
+
+let make_dot_udg_qudg : (Topology.t -> plan_udg -> (float*float) ->
+ ?r0:float -> ?r1:float -> string -> unit) =
+ (*Create a dot file from a graph*)
+ fun t plan dim ?(r0 = 0.) ?(r1 = 0.) file_name ->
+ let name = ref "graph0" in (* default name *)
+ let f = (if file_name = "" then stdout else
+ (
+ name := file_name;
+ (try ( (* remove all extensions. So if name = ref "tt.dot.dot"
+at the beginning, at the end name = ref "tt". *)
while true do
name := Filename.chop_extension !name;
done;
) with Invalid_argument _ -> ());
- open_out file_name
- )
- ) in
- let (w,l) = dim in
- let mpos = if(r0 > 0. || r1 > 0.) then
- (Printf.sprintf "size = \"%f,%f!\"\ntopLeft [pos=\"%f,%f!\",style=invis]\nlowRight [pos=\"0,0!\",style = invis]\nnode [fixedsize=false,shape=circle]\n" w l w l)
+ open_out file_name
+ )
+ ) in
+ let (w,l) = dim in
+ let mpos = if(r0 > 0. || r1 > 0.) then
+ (Printf.sprintf "size = \"%f,%f!\"\ntopLeft [pos=\"%f,%f!\",style=invis]\nlowRight [pos=\"0,0!\",style = invis]\nnode [fixedsize=false,shape=circle]\n" w l w l)
else "" in
- let dot = (Printf.sprintf "graph %s {\n\n"!name )^mpos
- ^(make_nodes_dot_udg plan r0 r1) ^ "\n" ^ (make_links_dot t) ^ "\n}\n" in
- Printf.fprintf f "%s" dot;
- flush f;
- close_out f
+ let dot = (Printf.sprintf "graph %s {\n\n"!name )^mpos
+ ^(make_nodes_dot_udg plan r0 r1) ^ "\n" ^ (make_links_dot t) ^ "\n}\n" in
+ Printf.fprintf f "%s" dot;
+ flush f;
+ close_out f