diff --git a/lib/algo/algo.ml b/lib/algo/algo.ml
index 71d833474055b0692242022b4aa548c3450bf905..98a752ad00babbb09345127fbb1c3a62819994af 100644
--- a/lib/algo/algo.ml
+++ b/lib/algo/algo.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 03/07/2019 (at 10:17) by Erwan Jahier> *)
+(* Time-stamp: <modified the 04/07/2019 (at 10:36) by Erwan Jahier> *)
open Sasacore
@@ -31,6 +31,7 @@ type 's to_register = {
copy_state: 's -> 's;
}
+type node_id = string (* cf topology.mli *)
let (to_reg_neigbor : 's Register.neighbor -> 's neighbor) =
fun n ->
@@ -76,5 +77,13 @@ let (register : 's to_register -> unit) =
let card = Register.card
-let get_graph_attribute = Register.get_graph_attribute
-
+let get_graph_attribute = Register.get_graph_attribute
+let min_degree = Register.min_degree
+let mean_degree = Register.mean_degree
+let max_degree = Register.max_degree
+let is_cyclic = Register.is_cyclic
+let is_connected = Register.is_connected
+let is_tree = Register.is_tree
+let height = Register.height
+let links_number = Register.links_number
+let diameter = Register.diameter
diff --git a/lib/algo/algo.mli b/lib/algo/algo.mli
index b5f302bd64e260442cd06e08cc116b33eb63d7a8..251a56261ea56cb6139b1b17f6befee284169c57 100644
--- a/lib/algo/algo.mli
+++ b/lib/algo/algo.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 03/07/2019 (at 10:17) by Erwan Jahier> *)
+(* Time-stamp: <modified the 04/07/2019 (at 10:36) by Erwan Jahier> *)
(** Process programmer API *)
type 's neighbor = {
@@ -41,13 +41,23 @@ type 's to_register = {
If one prepend a value with "some_id=", some_id will we used in
the simulation outputs. Otherwise, an id will be invented *)
+type node_id = string (* cf topology.mli *)
(** To be called once *)
val register : 's to_register -> unit
+
+val get_graph_attribute : string -> string
+
(** Topological infos *)
val card : unit -> int
-(* val degree : unit -> int *)
-(* val diameter : unit -> int *)
+val min_degree : unit -> int
+val mean_degree : unit -> float
+val max_degree : unit -> int
+val is_cyclic : unit -> bool
+val is_connected : unit -> bool
+val is_tree : unit -> bool
+val height : unit -> (node_id -> int) option
+val links_number : unit -> int
+val diameter : unit -> int
-val get_graph_attribute : string -> string
diff --git a/lib/sasacore/demon.ml b/lib/sasacore/demon.ml
index 357632ecb3511427b69840bdf0078418f17f912b..926f12274ff3912132f8bd769f9a360c5707a62f 100644
--- a/lib/sasacore/demon.ml
+++ b/lib/sasacore/demon.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 19/06/2019 (at 10:48) by Erwan Jahier> *)
+(* Time-stamp: <modified the 03/07/2019 (at 17:22) by Erwan Jahier> *)
type t =
| Synchronous (* select all actions *)
@@ -7,30 +7,67 @@ type t =
| Distributed (* select at least one action *)
| Custom
+type 'v pna = 'v Process.t * 'v Register.neighbor list * Register.action
+
let (random_list : 'a list -> 'a) = fun l ->
assert (l <> []);
List.nth l (Random.int (List.length l))
-let (random1: 'a list list -> 'a list) =
+(* returns a random element of a list as well as the rest of the list *)
+let (random_list2 : 'a list -> 'a * 'a list) = fun l ->
+ assert (l <> []);
+ let rec split acc i = function
+ | [] -> assert false (* sno *)
+ | x::l ->
+ if i=0 then x, List.rev_append acc l else split (x::acc) (i-1) l
+ in
+ let i = Random.int (List.length l) in
+ split [] i l
+
+let (central: 'a list list -> 'a list) =
fun all ->
if all = [] then [] else
let al = List.map random_list all in
let a = random_list al in
[a]
-let rec (random: 'a list list -> 'a list) =
+let rec (distributed: 'a list list -> 'a list) =
fun all ->
if all = [] then [] else
(* assert (all <> []); *)
let al = List.map random_list all in
let al = List.filter (fun _ -> Random.bool ()) al in
- if al = [] then random all else al
+ if al = [] then distributed all else al
let (synchrone: 'a list list -> 'a list) = fun all ->
if all = [] then [] else
let al = List.map random_list all in
al
+(* LC= 2 neighbors cannot be activated at the same step
+
+XXX this demon is not fair: it is biased by the degree of nodes.
+*)
+let (locally_central: 'v pna list list -> 'v pna list) =
+ fun all ->
+ let remove_one_conflict al =
+ let _a, al = random_list2 al in
+ al
+ in
+ let rec remove_conflicts al =
+ let activated_pids = List.map (fun (p,_,_) -> p.Process.pid) al in
+ let conflicts, ok = List.partition (fun (_p,nl,_a) ->
+ List.exists (fun n -> List.mem (n.Register.pid ()) activated_pids) nl
+ ) al
+ in
+ if conflicts = [] then ok else
+ let conflicts = remove_one_conflict conflicts in
+ ok @ (remove_conflicts conflicts)
+ in
+ if all = [] then [] else
+ let al = distributed all in
+ remove_conflicts al
+
let rec map3 f l1 l2 l3 =
match (l1, l2, l3) with
([], [], []) -> []
@@ -39,7 +76,6 @@ let rec map3 f l1 l2 l3 =
| (_, [], _) -> invalid_arg "map3 (2nd arg too short)"
| (_, _, []) -> invalid_arg "map3 (3rd arg too short)"
-type 'v pna = 'v Process.t * 'v Register.neighbor list * Register.action
let (custom: 'v pna list list -> 'v Process.t list -> bool list list ->
(string -> string -> bool) -> bool list list * 'v pna list) =
@@ -87,10 +123,12 @@ let (f: bool -> bool -> t -> 'v Process.t list -> 'v pna list list -> bool list
let al = synchrone (remove_empty_list all) in
get_activate_val al pl, al
| Central ->
- let al = random1 (remove_empty_list all) in
+ let al = central (remove_empty_list all) in
+ get_activate_val al pl, al
+ | LocallyCentral ->
+ let al = locally_central (remove_empty_list all) in
get_activate_val al pl, al
- | LocallyCentral -> assert false
| Distributed ->
- let al = random (remove_empty_list all) in
+ let al = distributed (remove_empty_list all) in
get_activate_val al pl, al
| Custom -> custom all pl enab get_action_value
diff --git a/lib/sasacore/demon.mli b/lib/sasacore/demon.mli
index c88424a87004a9f7748294dc81cb7b8df94959e4..b00562fff1cd3933216b9b88bce7277932b1306c 100644
--- a/lib/sasacore/demon.mli
+++ b/lib/sasacore/demon.mli
@@ -1,12 +1,15 @@
-(* Time-stamp: <modified the 19/06/2019 (at 10:50) by Erwan Jahier> *)
+(* Time-stamp: <modified the 03/07/2019 (at 17:25) by Erwan Jahier> *)
type t =
| Synchronous (* select all actions *)
| Central (* select 1 action *)
- | LocallyCentral (* never activates two neighbors actions in the same step *)
+ | LocallyCentral (* never activates two neighbors actions in the same step [1] *)
| Distributed (* select at least one action *)
| Custom (* enable/actions are communicated via stdin/stdout in RIF *)
+(* [1] nb: the current implementation of locally central demon is
+ biased by the degree of nodes. *)
+
type 'v pna = 'v Process.t * 'v Register.neighbor list * Register.action
diff --git a/lib/sasacore/diameter.ml b/lib/sasacore/diameter.ml
new file mode 100644
index 0000000000000000000000000000000000000000..8bada291889891d25666068c9204a54294ee6e50
--- /dev/null
+++ b/lib/sasacore/diameter.ml
@@ -0,0 +1,62 @@
+
+(* take a string and the list of all node and returns the position of the node in the list *)
+let (pos:string -> Topology.node list -> int) =
+ fun nid lid ->
+ fst (List.fold_left (fun (found_i,i) lid -> if (nid=lid.Topology.id) then (i,i+1) else (found_i,i+1) ) (-1, 0) lid)
+
+(* take a graph t and returns the Adjacency matrix of t *)
+let (graph_to_adjency: Topology.t -> int array array) =
+ fun t->
+ let taille = List.length t.nodes in
+ let mat = Array.make_matrix (taille) (taille) 0 in
+ List.iter (fun n -> (List.iter (fun (_,m) -> mat.(pos n.Topology.id t.nodes).(pos m t.nodes) <- 1 )
+ (t.succ n.Topology.id) ) ) (t.nodes);
+ mat
+
+
+(* Initialize the Adjacency matrix for Floyd Warshall algorithm *)
+let (initFW: int array array -> int array array) =
+ fun m ->
+ let n = (Array.length m.(0)) in
+ for i=0 to (n - 1) do
+ for j=0 to (n - 1) do
+ if (i<>j) then
+ (if (m.(i).(j)=1) then m.(i).(j) <- 1 else m.(i).(j) <- n+1)
+ else m.(i).(j) <- 0
+ done;
+ done;
+ m
+
+
+(* Apply Floyd Warshall algorithm which gives the matrix of all pairs shortest path *)
+let (floydwarshall:int array array -> int array array) =
+ fun m ->
+ let w = initFW m in
+ let n = (Array.length m.(0)) in
+ for k=0 to (n - 1) do
+ for i=0 to (n - 1) do
+ for j=0 to (n - 1) do
+ w.(i).(j) <- (min (w.(i).(j)) (w.(i).(k) + w.(k).(j)))
+ done;
+ done;
+ done;
+ w
+
+
+(* returns the greatest int of a matrix *)
+let (max_mat: int array array -> int) =
+ fun mat ->
+ let n = (Array.length mat) and m = (Array.length mat.(0)) in
+ let maxi = ref (-1) in
+ for i=0 to (n - 1) do
+ for j=0 to (m - 1) do
+ maxi := max !maxi mat.(i).(j)
+ done;
+ done;
+ !maxi
+
+(* takes a graph t in argument and returns the diameter *)
+let (get: Topology.t -> int ) =
+ fun t ->
+ (max_mat(floydwarshall (graph_to_adjency t)))
+
\ No newline at end of file
diff --git a/lib/sasacore/diameter.mli b/lib/sasacore/diameter.mli
new file mode 100644
index 0000000000000000000000000000000000000000..386f289100f2db49da1b7f584f8f30b97ea34d70
--- /dev/null
+++ b/lib/sasacore/diameter.mli
@@ -0,0 +1 @@
+val get : Topology.t -> int
diff --git a/lib/sasacore/process.ml b/lib/sasacore/process.ml
index 068712c10d012a5cc2ea35526105506345f33239..e8ab45aad7fe4035f5a85234e97735bf5a2d8e4a 100644
--- a/lib/sasacore/process.ml
+++ b/lib/sasacore/process.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 19/06/2019 (at 10:49) by Erwan Jahier> *)
+(* Time-stamp: <modified the 03/07/2019 (at 15:53) by Erwan Jahier> *)
type 'v t = {
pid : string;
@@ -25,7 +25,8 @@ let (make: bool -> Topology.node -> 'v -> 'v t) =
try Register.get_actions id
with _ ->
if custom_mode then
- failwith "Registering actions is mandatory in algorithms when using custom demon!"
+ failwith
+ "Registering actions is mandatory in algorithms when using custom demon!"
else ["a"]
in
let process = {
diff --git a/lib/sasacore/register.ml b/lib/sasacore/register.ml
index ace0c83be40832bdfe1b2d276441f5b37feba6c3..ef4dd5ec7cdb6ba3a760642abe24a2f22b3f6351 100644
--- a/lib/sasacore/register.ml
+++ b/lib/sasacore/register.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 03/07/2019 (at 10:17) by Erwan Jahier> *)
+(* Time-stamp: <modified the 04/07/2019 (at 10:35) by Erwan Jahier> *)
type 's neighbor = {
state: 's ;
@@ -22,9 +22,29 @@ type 's internal_tables = {
value_of_string : (string, Obj.t) Hashtbl.t;
copy_value : (string, Obj.t) Hashtbl.t;
graph_attributes : (string, string) Hashtbl.t;
- mutable card : int
+ mutable card : int ;
+ mutable min_deg : int;
+ mutable mean_deg : float;
+ mutable max_deg : int;
+ mutable is_cyclic : bool option;
+ mutable is_connected : bool option;
+ mutable is_tree : bool option;
+ mutable height : (string -> int);
+ mutable links_number : int;
+ mutable diameter : int;
+ }
+
+type properties_functions = {
+ mutable card : unit -> int;
+ mutable min_max : unit -> int*int;
+ mutable mean_deg : unit -> float;
+ mutable is_connected_cyclic : unit -> bool*bool;
+ mutable links_number : unit -> int;
+ mutable diameter : unit -> int
}
+type node_id = string (* cf topology.mli *)
+
let (tbls:'s internal_tables) = {
init_state = Hashtbl.create 1;
enable = Hashtbl.create 1;
@@ -34,7 +54,25 @@ let (tbls:'s internal_tables) = {
value_of_string = Hashtbl.create 1;
copy_value = Hashtbl.create 1;
graph_attributes = Hashtbl.create 1;
- card = (-1)
+ card = (-1);
+ min_deg = (-1);
+ mean_deg = (-1.);
+ max_deg = (-1);
+ is_cyclic = None;
+ is_connected = None;
+ is_tree = None;
+ height = (fun _ -> -1);
+ links_number = (-1);
+ diameter = (-1)
+}
+
+let (prop_funs:properties_functions) = {
+ card = (fun () -> -1);
+ min_max = (fun () -> (-1,-1));
+ mean_deg = (fun () -> -1.);
+ is_connected_cyclic = (fun () -> (false,false));
+ links_number = (fun () -> -1);
+ diameter = (fun () -> -1)
}
let verbose_level = ref 0
@@ -127,12 +165,103 @@ let (get_copy_value : unit -> ('s -> 's)) = fun () ->
raise (Unregistred ("copy_value", "_global"))
+let set_min_max : (unit -> unit) =
+ fun () ->
+ let (x,y) = prop_funs.min_max () in
+ tbls.min_deg <- x;
+ tbls.max_deg <- y
+
+let set_connec_cycl : (unit -> unit) =
+ fun () ->
+ let (x,y) = prop_funs.is_connected_cyclic () in
+ tbls.is_connected <- Some x;
+ tbls.is_cyclic <- Some y
+
+
let (card : unit -> int) =
- fun () -> tbls.card
-
-let (set_card : int -> unit) =
- fun i ->
- tbls.card <- i
+ fun () -> match tbls.card with
+ | -1 -> (let c = prop_funs.card () in tbls.card <- c; c)
+ | c -> c
+
+let (min_degree : unit -> int) =
+ fun () -> match tbls.min_deg with
+ | -1 -> (set_min_max (); tbls.min_deg)
+ | m -> m
+
+let (mean_degree : unit -> float) =
+ fun () -> match tbls.mean_deg with
+ | -1. -> (let m = prop_funs.mean_deg () in tbls.mean_deg <- m; m)
+ | m -> m
+
+let (max_degree : unit -> int) =
+ fun () -> match tbls.max_deg with
+ | -1 -> (set_min_max (); tbls.max_deg)
+ | m -> m
+
+let (is_cyclic : unit -> bool) =
+ fun () -> match tbls.is_cyclic with
+ | None -> (set_connec_cycl ();
+ match tbls.is_cyclic with
+ | Some b -> b
+ | _ -> assert false)
+ | Some b -> b
+
+let (is_connected : unit -> bool) =
+ fun () -> match tbls.is_connected with
+ | None -> (set_connec_cycl ();
+ match tbls.is_connected with
+ | Some b -> b
+ | _ -> assert false)
+ | Some b -> b
+
+let (is_tree : unit -> bool) =
+ fun () -> match tbls.is_tree with
+ | None -> (let b = (not (is_cyclic ()) && (is_connected ())) in tbls.is_tree <- Some b; b)
+ | Some b -> b
+
+(* Caution : this option is not the same as the option in the type tbls.height.
+ * If height () = None, then the graph doesn't have a height (because it isn't a tree)*)
+let height : (unit -> (string -> int) option) =
+ fun () ->
+ if is_tree () then
+ Some tbls.height
+ else None
+
+
+let (links_number : unit -> int) =
+ fun () -> match tbls.links_number with
+ | -1 -> (let n = prop_funs.links_number () in tbls.links_number <- n; n)
+ | n -> n
+
+let (diameter : unit -> int) =
+ fun () ->
+ match tbls.diameter with
+ | -1 -> (let d = (prop_funs.diameter ()) in tbls.diameter <- d; d)
+ | d -> d
+
+
+
+let set_card : ((unit -> int) -> unit) =
+ fun f -> prop_funs.card <- f
+
+let set_degrees : ((unit -> int*int) -> unit) =
+ fun f -> prop_funs.min_max <- f
+
+let set_mean_deg : ((unit -> float) -> unit) =
+ fun f -> prop_funs.mean_deg <- f
+
+let set_is_connected_cyclic : ((unit -> bool*bool) -> unit) =
+ fun f -> prop_funs.is_connected_cyclic <- f
+
+let set_height : ((node_id -> int) -> unit) =
+ fun f -> tbls.height <- f
+
+let set_links_number : ((unit -> int) -> unit) =
+ fun f -> prop_funs.links_number <- f
+
+let set_diameter : ((unit -> int) -> unit) =
+ fun f -> prop_funs.diameter <- f
+
let (to_string : 's -> string) =
fun v ->
diff --git a/lib/sasacore/register.mli b/lib/sasacore/register.mli
index db8319ed69ac7f39af3d13005d3c67cc86593e5c..cb2a1de0486054626475a6ea38b50daff0603051 100644
--- a/lib/sasacore/register.mli
+++ b/lib/sasacore/register.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 03/07/2019 (at 10:18) by Erwan Jahier> *)
+(* Time-stamp: <modified the 04/07/2019 (at 10:34) by Erwan Jahier> *)
type 's neighbor = {
state: 's ;
@@ -13,6 +13,7 @@ type action = string
type 's enable_fun = 's neighbor list -> 's -> action list
type 's step_fun = 's neighbor list -> 's -> action -> 's
+type node_id = string (* cf topology.mli *)
val reg_init_state : algo_id -> (int -> 's) -> unit
val reg_enable : algo_id -> 's enable_fun -> unit
@@ -31,15 +32,31 @@ val get_value_to_string : unit -> 's -> string
val get_value_of_string : unit -> (string -> 's) option
val get_copy_value : unit -> ('s -> 's)
val to_string : 's -> string
-val set_card : int -> unit
-(* val set_degree : int -> unit *)
-(* val set_diameter : int -> unit *)
-val card : unit -> int
-(* val degree : unit -> int *)
-(* val diameter : unit -> int *)
-
+
+val set_card : (unit -> int) -> unit
+val set_degrees : (unit -> int*int) -> unit
+val set_mean_deg : (unit -> float) -> unit
+val set_is_connected_cyclic : (unit -> bool*bool) -> unit
+val set_height : (node_id -> int) -> unit
+val set_links_number : (unit -> int) -> unit
+val set_diameter : (unit -> int) -> unit
+
val get_graph_attribute : string -> string
val set_graph_attribute : string -> string -> unit
+val card : unit -> int
+val min_degree : unit -> int
+val mean_degree : unit -> float
+val max_degree : unit -> int
+val is_cyclic : unit -> bool
+val is_connected : unit -> bool
+val is_tree : unit -> bool
+
+(** If height () = None, then the graph doesn't have a height (because it isn't a tree)
+ Otherwise, height () = Some h.*)
+val height : unit -> (string -> int) option
+val links_number : unit -> int
+val diameter : unit -> int
+
val verbose_level: int ref
diff --git a/lib/sasacore/sasa.ml b/lib/sasacore/sasa.ml
index b2e47498d5eefabf735e5f4b5eff16c19f8d12dc..be474c1f98f377b0b64a1f92bf946e6c588a929f 100644
--- a/lib/sasacore/sasa.ml
+++ b/lib/sasacore/sasa.ml
@@ -146,7 +146,66 @@ let (env_rif_decl: SasArg.t -> 'v Process.t list -> string) =
let ssl = get_outputs_rif_decl args pl in
String.concat " "
(List.map (fun (base, tstr) -> Printf.sprintf "\"%s\":%s" base tstr) ssl)
-
+
+
+let (get_degree:Topology.t -> int*int) =
+ fun t -> if t.nodes = [] then 0,0
+ else
+ let node_deg n = List.length (t.succ (n.Topology.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: Topology.t -> bool -> int) =
+ fun t is_oriented ->
+ if not is_oriented then (List.fold_left (fun acc n -> ((List.length (t.succ n.Topology.id))) + acc) (0) (t.nodes)) / 2
+ else (List.fold_left (fun acc n -> ((List.length (t.succ n.Topology.id))) + acc) (0) (t.nodes))
+
+let (get_mean_degree : Topology.t -> float) =
+ fun t ->
+ (float_of_int (get_nb_link t true)) /. (float_of_int (List.length t.nodes))
+
+let bfs : (Topology.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 : Topology.t -> bool*bool =
+ fun t -> match t.nodes with
+ | [] -> (false,false)
+ | hd::_ -> let (cyclic,bfs_nodes) = (bfs t hd.Topology.id) in ((List.compare_lengths t.nodes bfs_nodes) = 0, cyclic)
+
+let rec height : string list -> Topology.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 : Topology.t -> string -> int =
+ fun t ->
+ height ([]) t
+
+
let (make : bool -> string array -> 'v t) =
fun dynlink argv ->
let args =
@@ -167,7 +226,14 @@ let (make : bool -> string array -> 'v t) =
let nl = g.nodes in
let nidl = List.map (fun n -> n.Topology.id) nl in
let nstr = String.concat "," nidl in
- Register.set_card (List.length nl);
+ Register.set_card (fun () -> List.length nl);
+ Register.set_degrees (fun () -> get_degree g);
+ Register.set_mean_deg (fun () -> get_mean_degree g);
+ Register.set_is_connected_cyclic (fun () -> is_connected_and_cyclic g);
+ Register.set_height (get_height g);
+ Register.set_links_number (fun () -> get_nb_link g false);
+ Register.set_diameter (fun () -> Diameter.get g);
+
Register.verbose_level := args.verbose;
Random.init args.seed;
if !Register.verbose_level > 0 then Printf.eprintf "nodes: %s\nedges:\n" nstr;