Commit a872f728 authored by erwan's avatar erwan
Browse files

gg: refactor the code (cleaner, more efficient)

parent ab191609
......@@ -3,79 +3,103 @@ open Topology
open Ggcore
open List
type node_succ_t = (string, (int * string) list) Hashtbl.t
type node_succ_t = (string, int * string) Hashtbl.t
type node_pred_t = (string, string) Hashtbl.t
(* Add symmetric edges when not directed *)
let update_tbl directed succ pred =
if not directed then (
Hashtbl.iter
(fun n1 (_, n2) ->
if not (List.mem (1,n1) (Hashtbl.find_all succ n2)) then
Hashtbl.add succ n2 (1,n1))
(Hashtbl.copy succ);
Hashtbl.iter
(fun n1 n2 ->
if not (List.mem n1 (Hashtbl.find_all pred n2)) then
Hashtbl.add pred n2 n1)
(Hashtbl.copy pred);
)
let nid_list_remove : (node_id list -> node_id -> (int*node_id) list) =
fun l e ->
rev (fold_left (fun acc elem -> if(elem <> e) then (1,elem)::acc else acc ) [] l)
(* remove e from l, and add the weight 1 to elements of l *)
rev (fold_left (fun acc elem ->
if(elem <> e) then (1,elem)::acc else acc ) [] l)
let (gen_clique: bool -> int -> Topology.t) =
fun directed nb ->
let (node_succ:node_succ_t) = Hashtbl.create nb
and (node_pred:node_pred_t) = Hashtbl.create nb
and nodes = create_nodes "p" (0,nb)
in
List.iter
(fun node_id -> Hashtbl.replace node_succ node_id (nid_list_remove nodes node_id))
(fun node_id ->
List.iter
(fun x ->
if (snd x) < node_id then (
Hashtbl.add node_succ node_id x;
Hashtbl.add node_pred (snd x) node_id
)
)
(nid_list_remove nodes node_id))
nodes;
let nl = id_to_empty_nodes nodes in
update_tbl directed node_succ node_pred;
{
nodes = nl;
succ = (fun n -> try Hashtbl.find node_succ n with Not_found -> []);
succ = (fun n -> Hashtbl.find_all node_succ n);
pred = (fun n -> Hashtbl.find_all node_pred n);
of_id = get_of_id nl;
directed = directed;
attributes = []
}
let (gen_star: bool -> int -> Topology.t) =
fun directed nb ->
let (node_succ:node_succ_t) = Hashtbl.create nb and nodes = "root"::(create_nodes "p" (1,nb)) in
let first = hd nodes in
List.iter
(fun node ->
Hashtbl.replace node_succ node
(if node = first then nid_list_remove nodes node else [(1,first)])) nodes;
let nl = id_to_empty_nodes nodes in
let (node_succ:node_succ_t) = Hashtbl.create nb in
let (node_pred:node_pred_t) = Hashtbl.create nb in
let nodes = create_nodes "p" (1,nb) in
List.iter (fun n -> Hashtbl.add node_succ "root" (1,n)) nodes;
List.iter (fun n -> Hashtbl.add node_pred n "root") nodes;
update_tbl directed node_succ node_pred;
let nl = id_to_empty_nodes ("root"::nodes) in
{
nodes = nl;
succ = (fun n -> try Hashtbl.find node_succ n with Not_found -> []);
succ = (fun n -> Hashtbl.find_all node_succ n);
pred = (fun n -> Hashtbl.find_all node_pred n);
of_id = get_of_id nl;
directed = directed;
attributes = []
}
let rec list_iter3 f l1 l2 l3 =
match (l1, l2, l3) with
([], [], []) -> ()
| (a1::l1, a2::l2, a3::l3) -> f a1 a2 a3; list_iter3 f l1 l2 l3
| (_, _, _) -> invalid_arg "list_iter3"
let neighbours_ring : bool -> (node_id list -> (node_id -> (int * node_id) list)) =
fun dir nodes ->
let node_succ:node_succ_t = Hashtbl.create (length nodes) in
let nodes2, nodes3 = match nodes with
| n1::n2::t -> (n2::t)@[n1], t@[n1;n2]
let neighbours_ring dir nodes =
let nb = length nodes in
let node_succ:node_succ_t = Hashtbl.create nb in
let (node_pred:node_pred_t) = Hashtbl.create nb in
let nodes2 = match nodes with
| n1::t -> t@[n1]
| _ -> assert false
in
list_iter3 (fun n1 n2 n3 ->
if dir then
Hashtbl.replace node_succ n2 [1,n3]
else
Hashtbl.replace node_succ n2 [(1,n3);(1,n1)]
List.iter2 (fun n1 n2 ->
Hashtbl.add node_succ n1 (1,n2);
Hashtbl.add node_pred n2 n1
)
nodes nodes2 nodes3;
(fun n -> try Hashtbl.find node_succ n with Not_found -> [])
nodes nodes2 ;
update_tbl dir node_succ node_pred;
(fun n -> Hashtbl.find_all node_succ n),
(fun n -> Hashtbl.find_all node_pred n)
let (gen_ring: bool -> int -> Topology.t) =
fun directed nb ->
let nodes = (create_nodes "p" (0,nb)) in
let nl = id_to_empty_nodes nodes in
let succ, pred = neighbours_ring directed nodes in
{
nodes = nl;
succ = neighbours_ring directed nodes;
succ = succ;
pred = pred;
of_id = get_of_id nl;
directed = directed;
attributes = []
......@@ -87,7 +111,10 @@ let (gen_grid: bool -> int -> int -> Topology.t) =
Printf.eprintf "Computing a %ix%i grid...\n" length width;
flush stderr;
let nb = length*width in
let nodes = (create_nodes "p" (0,nb)) and table = Hashtbl.create nb in
let nodes = (create_nodes "p" (0,nb))
and succ_t = Hashtbl.create nb
and pred_t = Hashtbl.create nb
in
for i=0 to length-1 do
for j=0 to width-1 do
let n_id = (List.nth nodes (j*length + i)) in
......@@ -97,53 +124,65 @@ let (gen_grid: bool -> int -> int -> Topology.t) =
let bdown = if(j=(width-1)) then 0 else 1 in
for ip=bl to br do
for jp=bup to bdown do
if not ((ip=0 && jp=0) || (ip=jp) || (ip = -jp)) then
(Hashtbl.replace table n_id
((1,(List.nth nodes ((j+jp)*length + i+ip)))::(
try Hashtbl.find table n_id with Not_found -> [])); ) else ()
let n_id2 = List.nth nodes ((j+jp)*length + i+ip) in
if not ((ip=0 && jp=0) || (ip=jp) || (ip = -jp)) && (n_id<n_id2)
then (
Hashtbl.add succ_t n_id (1, n_id2);
Hashtbl.add pred_t n_id2 n_id
)
done;
done;
done;
done;
let nl = id_to_empty_nodes nodes in
update_tbl directed succ_t pred_t;
Printf.eprintf "Computing a %ix%i grid: Done!\n" length width;flush stderr;
{
nodes = nl;
succ = (fun nid -> (try Hashtbl.find table nid with Not_found -> []));
succ = (fun nid -> Hashtbl.find_all succ_t nid);
pred = (fun nid -> Hashtbl.find_all pred_t nid);
of_id = get_of_id nl;
directed = directed;
attributes = []
}
let rec link_hypercube_nodes : (node_id array -> node_succ_t -> unit) =
fun na n_s ->
let len = Array.length na in let mid = len / 2 in
let rec link_hypercube_nodes :
(node_id array -> node_succ_t -> node_pred_t -> unit) =
fun na n_s n_p ->
let len = Array.length na in
let mid = len / 2 in
if len > 1 then
let n1 = (Array.sub na 0 mid) and n2 = (Array.sub na mid mid) in
link_hypercube_nodes n1 n_s;
link_hypercube_nodes n2 n_s;
Array.iter2 (fun node1 node2 ->
Hashtbl.replace n_s node1
(( 1,node2)::(try Hashtbl.find n_s node1 with Not_found -> []));
Hashtbl.replace n_s node2
((1,node1)::(try Hashtbl.find n_s node2 with Not_found -> []))
let n1 = (Array.sub na 0 mid)
and n2 = (Array.sub na mid mid) in
link_hypercube_nodes n1 n_s n_p;
link_hypercube_nodes n2 n_s n_p;
Array.iter2 (fun node1 node2 ->
if node1 < node2 then (
Hashtbl.add n_s node1 (1, node2)
)
) n1 n2
let neighbours_hyper_cube : (node_id list -> (node_id -> (int * node_id) list)) =
fun nl ->
let (neighbours_hyper_cube : bool -> node_id list ->
(node_id -> (int * node_id) list) * (node_id -> node_id list)) =
fun dir nl ->
let na = Array.of_list nl in
let (node_succ:node_succ_t) = Hashtbl.create (Array.length na) in
link_hypercube_nodes na node_succ;
(fun n -> try Hashtbl.find node_succ n with Not_found -> [])
let (node_pred:node_pred_t) = Hashtbl.create (Array.length na) in
link_hypercube_nodes na node_succ node_pred;
update_tbl dir node_succ node_pred;
(fun n -> Hashtbl.find_all node_succ n),
(fun n -> Hashtbl.find_all node_pred n)
let gen_hyper_cube : (bool -> int -> Topology.t) =
fun directed dim ->
let nb = int_of_float (2. ** (float_of_int dim)) in
let nodes = (create_nodes "p" (0,nb)) in
let nl = id_to_empty_nodes nodes in
let succ, pred = neighbours_hyper_cube directed nodes in
{
nodes = nl;
succ = neighbours_hyper_cube nodes;
succ = succ;
pred = pred;
of_id = get_of_id nl;
directed = directed;
attributes = []
......
......@@ -3,98 +3,137 @@ open Topology
open Ggcore
open List
type node_succ_t = (node_id, (int * node_id) list) Hashtbl.t
type node_succ_t = (node_id, int * node_id) Hashtbl.t
type node_pred_t = (node_id, node_id) Hashtbl.t
type probability = float (*between 0 and 1*)
(* Add symmetric edges when not directed *)
let update_tbl directed succ pred =
if not directed then (
Hashtbl.iter
(fun n1 (_, n2) ->
if not (List.mem (1,n1) (Hashtbl.find_all succ n2)) then
Hashtbl.add succ n2 (1,n1))
(Hashtbl.copy succ);
Hashtbl.iter
(fun n1 n2 ->
if not (List.mem n1 (Hashtbl.find_all pred n2)) then
Hashtbl.add pred n2 n1)
(Hashtbl.copy pred);
)
let gen_ER : (bool -> int -> probability -> Topology.t) =
fun directed nb p ->
let (node_succ:node_succ_t) = Hashtbl.create nb
and nodes = create_nodes "p" (0,nb)
let (node_succ:node_succ_t) = Hashtbl.create nb in
let (node_pred:node_pred_t) = Hashtbl.create nb in
let nodes = create_nodes "p" (0,nb) in
let succ n = Hashtbl.find_all node_succ n in
let pred n = Hashtbl.find_all node_pred n in
let add_succ n m =
Hashtbl.add node_succ n (1,m);
Hashtbl.add node_pred m n
in
let succ n = try Hashtbl.find node_succ n with Not_found -> [] in
let add_succ n m = Hashtbl.replace node_succ n ((1,m)::(succ n)) in
iteri (fun i n ->
iteri (fun j m ->
if not directed then (
if i < j && (Random.float 1.) < p then (
add_succ n m;
add_succ m n
);
) else (
if i <> j && (Random.float 1.) < p then
add_succ n m;
)
if i < j && (Random.float 1.) < p then add_succ n m)
else (
if i <> j && (Random.float 1.) < p then add_succ n m)
)
nodes
)
nodes;
let nl = id_to_empty_nodes nodes in
{
update_tbl directed node_succ node_pred;
{
nodes = nl;
succ = succ;
pred = pred;
of_id = get_of_id nl;
directed = directed;
attributes = []
}
let rec init_m_nodes : (int -> node_succ_t -> node_id list -> node_id list) =
fun i node_succ ->
function
| (node::tail) ->
(* split the list, the 1st one having the first m nodes *)
let get_m_nodes m nodes =
let rec f i acc nodes =
match nodes with
| [] -> assert false
| (node::tail) ->
if i > 0 then
(Hashtbl.replace node_succ node [];
init_m_nodes (i-1) node_succ tail)
else node::tail
| _ -> assert false
f (i-1) (node::acc) tail
else
List.rev acc, nodes
in
f m [] nodes
let (neighbours_BA : node_id list -> int -> node_succ_t ->
(node_id -> (int * node_id) list)) =
fun nodes m node_succ ->
let (neighbours_BA : node_id list -> int -> node_succ_t -> node_pred_t ->
((node_id -> (int * node_id) list) * (node_id -> node_id list))) =
fun nodes m node_succ node_pred ->
let d_tot = 2 * m in
let nodes = init_m_nodes m node_succ nodes in
let m_nodes, nodes = get_m_nodes m nodes in
List.iter (fun n ->
Hashtbl.remove node_succ n;
Hashtbl.remove node_pred n;
)
m_nodes;
match nodes with
| [] -> assert false
| head::nodes ->
Hashtbl.replace node_succ head
(Hashtbl.fold
(fun n _ succ ->
Hashtbl.replace node_succ n [(1,head)];
(1,n)::succ) node_succ []
);
(*init terminée. On a un graph connexe pour les m+1 premiers points,
nl ne contient que les points non ajoutés*)
List.iter (fun n ->
Hashtbl.add node_succ n (1,head);
Hashtbl.add node_succ head (1,n);
Hashtbl.add node_pred head n ;
Hashtbl.add node_pred n head
)
m_nodes;
(*init terminée. On a un graph connexe pour les m premiers points,
nodes ne contient que les points non ajoutés*)
ignore (
fold_left
(fun deg_tot node ->
let deg_temp = deg_tot in
let succ = ref [] in
let deg_temp = ref deg_temp in
let succ = ref [] in (* hold the m new links for node *)
let deg_ref = ref deg_tot in
for _ = 0 to m-1 do (*for each edge to create*)
let ran = Random.int !deg_temp in
let ran = Random.int !deg_ref in
let visited = ref [] in
ignore (
Hashtbl.fold
(fun n_id n_succ r ->
if r >= 0 && not (List.mem (1,n_id) !succ) then
let r = r - (length n_succ) in
if r < 0 then (
(fun n_id _ r ->
let skip = List.mem n_id !visited in
if not skip then visited := n_id::!visited;
(* skip is used to make sure n_id is considered once *)
if (r >= 0 && not skip) then (
let n_succ = Hashtbl.find_all node_succ n_id in
let d_n_id = length n_succ in
let r = r - d_n_id in
if r < 0 && not skip then (
succ := (1,n_id)::!succ;
Hashtbl.replace node_succ n_id
((1,node)::n_succ);
deg_temp := !deg_temp - length n_succ
deg_ref := !deg_ref - d_n_id
);
r
)
else r
)
node_succ ran);
node_succ
ran);
done;
Hashtbl.replace node_succ node !succ;
assert (length !succ = m);
List.iter (fun s ->
Hashtbl.add node_succ node s;
Hashtbl.add node_succ (snd s) (1,node);
Hashtbl.add node_pred (snd s) node ;
Hashtbl.add node_pred node (snd s)
)
!succ;
(deg_tot + (2 * m))
)
d_tot
nodes
);
(fun n -> try Hashtbl.find node_succ n with Not_found -> [])
(fun n -> Hashtbl.find_all node_succ n),
(fun n -> Hashtbl.find_all node_pred n)
let gen_BA : (bool -> int -> int -> Topology.t) =
fun directed nb m ->
......@@ -102,8 +141,9 @@ let gen_BA : (bool -> int -> int -> Topology.t) =
Printf.eprintf "A Barabasi–Albert graph cannot be directed\n%!";
exit 2
);
let (node_succ:node_succ_t) = Hashtbl.create nb
and nodes = create_nodes "p" (0,nb) in
let (node_succ:node_succ_t) = Hashtbl.create nb in
let (node_pred:node_pred_t) = Hashtbl.create nb in
let nodes = create_nodes "p" (0,nb) in
if nb < m + 1 then
(Printf.eprintf
"Error: with -m %d, the node number needs to be at least %d (it is %d).\n%!"
......@@ -111,17 +151,20 @@ let gen_BA : (bool -> int -> int -> Topology.t) =
exit 2
);
let nl = id_to_empty_nodes nodes in
let succ, pred = neighbours_BA nodes m node_succ node_pred in
{
nodes = nl;
succ = neighbours_BA nodes m node_succ;
succ = succ;
pred = pred;
of_id = get_of_id nl;
directed = directed;
attributes = []
}
let pre_rand_tree : (GraphGen_arg.tree_edge -> node_succ_t -> node_id list ->
(node_id -> (int * node_id) list)) =
fun tree_edge node_succ ->
let (pre_rand_tree : bool -> GraphGen_arg.tree_edge -> node_succ_t ->
node_pred_t -> node_id list ->
((node_id -> (int * node_id) list) * (node_id -> node_id list))) =
fun dir tree_edge node_succ node_pred ->
function
| [] -> failwith "Tree Error : You need at least one nodes in your tree"
| h::t ->
......@@ -132,28 +175,35 @@ let pre_rand_tree : (GraphGen_arg.tree_edge -> node_succ_t -> node_id list ->
- up edges
- both
*)
if tree_edge <> GraphGen_arg.OutTree then
(Hashtbl.replace node_succ no
((1,elem)::(try Hashtbl.find node_succ no with Not_found -> [])));
if tree_edge <> GraphGen_arg.InTree then
Hashtbl.replace node_succ elem
((1,no)::(try Hashtbl.find node_succ elem with Not_found -> []));
if tree_edge <> GraphGen_arg.OutTree then (
Hashtbl.add node_succ no (1,elem);
Hashtbl.add node_pred elem no
);
if tree_edge <> GraphGen_arg.InTree then (
Hashtbl.add node_succ elem (1,no);
Hashtbl.add node_pred no elem
);
(elem::acc)
) [h] (t));
(fun n -> try Hashtbl.find node_succ n with Not_found -> [])
update_tbl dir node_succ node_pred;
(fun n -> Hashtbl.find_all node_succ n),
(fun n -> Hashtbl.find_all node_pred n)
let (rand_tree: GraphGen_arg.tree_edge -> bool -> int -> Topology.t) =
fun tree_edge directed nb ->
let (node_succ:node_succ_t) = Hashtbl.create nb
and nodes = "root"::(create_nodes "p" (1,nb-1)) in
let nl = id_to_empty_nodes nodes in
{
nodes = nl;
succ = (pre_rand_tree tree_edge node_succ nodes);
of_id = get_of_id nl;
directed = directed;
attributes = []
}
let (node_succ:node_succ_t) = Hashtbl.create nb in
let (node_pred:node_pred_t) = Hashtbl.create nb in
let nodes = "root"::(create_nodes "p" (1,nb-1)) in
let nl = id_to_empty_nodes nodes in
let succ, pred = pre_rand_tree directed tree_edge node_succ node_pred nodes in
{
nodes = nl;
succ = succ;
pred = pred;
of_id = get_of_id nl;
directed = directed;
attributes = []
}
type node_udg = node_id*float*float
......@@ -171,30 +221,35 @@ let (dist_udg: node_udg -> node_udg -> float) =
let gen_qudg : (bool -> int -> float -> float -> float -> float -> float ->
(Topology.t * plan_udg)) =
fun directed nb x y r0 r1 p ->
let (node_succ:node_succ_t) = Hashtbl.create nb and nodes = create_nodes "p" (0,nb) in
let (node_succ:node_succ_t) = Hashtbl.create nb in
let (node_pred:node_pred_t) = Hashtbl.create nb in
let nodes = create_nodes "p" (0,nb) in
let pl = (make_plan_udg nodes x y) in
List.iter (fun n_udg ->
let (node, _, _) = n_udg in
List.iter (fun elem ->
let (n,_,_) = elem and dist = dist_udg n_udg elem in
if node <> n && (dist <= r0 || (dist <= r1 && Random.float 1. <= p))
(* e.q. if the node is : (within the radius r0)
or : (within the radius r1, with a brobability of p) *)
then (
Hashtbl.replace node_succ node
((1,n)::(try Hashtbl.find node_succ node with Not_found -> []))
)
) pl
) pl;
let (node, _, _) = n_udg in
List.iter (fun elem ->
let (n,_,_) = elem and dist = dist_udg n_udg elem in
if node <> n &&
(dist <= r0 || (dist <= r1 && Random.float 1. <= p))
(* e.g. if the node is : (within the radius r0)
or : (within the radius r1, with a probability of p) *)
then (
Hashtbl.add node_succ node (1,n);
Hashtbl.add node_pred n node;
)
) pl
) pl;
let nl = id_to_empty_nodes nodes in
update_tbl directed node_succ node_pred;
{
nodes = nl;
succ =(fun n -> (try Hashtbl.find node_succ n with Not_found -> []));
succ = (fun n -> Hashtbl.find_all node_succ n);
pred = (fun n -> Hashtbl.find_all node_pred n);
of_id = get_of_id nl;
directed = directed;
attributes = []
},pl
let gen_udg : (bool -> int -> float -> float -> float -> (Topology.t * plan_udg)) =
let (gen_udg : bool -> int -> float -> float -> float ->
(Topology.t * plan_udg)) =
fun directed nb x y r -> (gen_qudg directed nb x y r 0. 0.)
......@@ -9,28 +9,31 @@ type plan_udg = node_udg list
of n nodes and of probability p for each possible edge to appear. *)
val gen_ER : bool -> int -> probability -> Topology.t
(** [gen_BA n m] generate a graph using Barabasi–Albert model,
of n nodes and with m edges added for each new node.
m has to be lower than n.
The initialization is a star of m+1 nodes, with the (m+1)th node being the root.
Barabasi–Albert model is used for the remaining nodes *)
(** [gen_BA n m] generate a graph using Barabasi–Albert model, of n
nodes and with m edges added for each new node. m has to be lower
than n.
The initialization is a star of m+1 nodes, with the (m+1)th node
being the root. Barabasi–Albert model is used for the remaining
nodes *)
val gen_BA : bool -> int -> int -> Topology.t
(** [rand_tree n] generate a random tree of n nodes *)
val rand_tree: GraphGen_arg.tree_edge -> bool -> int -> Topology.t
(** [gen_udg nb x y r] generate a graph using the Unit Disc Graph model, of n nodes.
w and h are the width and the height of the area in which the nodes are randomly disposed,
and r is the radius around each node, in which all the other nodes will be neighbors.
*)
(** [gen_udg nb x y r] generate a graph using the Unit Disc Graph