diff --git a/lib/algo/algo.ml b/lib/algo/algo.ml
index 7a1f9a13a011da08a884cee4a1f5057173f88a5a..91d0bed03bf7664114694c28beea997162baa880 100644
--- a/lib/algo/algo.ml
+++ b/lib/algo/algo.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 02/09/2020 (at 10:30) by Erwan Jahier> *)
+(* Time-stamp: <modified the 13/10/2020 (at 15:55) by Erwan Jahier> *)
open Sasacore
(* Process programmer API *)
@@ -43,9 +43,9 @@ type 's enable_fun = 's -> 's neighbor list -> action list
type 's step_fun = 's -> 's neighbor list -> action -> 's
type 's state_init_fun = int -> string -> 's
type 's fault_fun = int -> string -> 's -> 's
-type 's legitimate_fun = pid list -> (pid -> 's * 's neighbor list) -> bool
+type 's legitimate_fun = pid list -> (pid -> 's * ('s neighbor * pid) list) -> bool
-type 's potential_fun = pid list -> (pid -> 's * 's neighbor list) -> float
+type 's potential_fun = pid list -> (pid -> 's * ('s neighbor * pid) list) -> float
type 's algo_to_register = {
algo_id: string;
@@ -72,11 +72,11 @@ let (to_reg_neigbor : 's Register.neighbor -> 's neighbor) =
spid = n.Register.spid;
reply = n.Register.reply;
weight = n.Register.weight;
- }
+ }
-let (to_reg_info : 's * 's Register.neighbor list -> 's * 's neighbor list) =
+let (to_reg_info : 's * ('s Register.neighbor * pid) list -> 's * ('s neighbor *pid) list) =
fun (s, nl) ->
- s, List.map to_reg_neigbor nl
+ s, List.map (fun (n,pid) -> to_reg_neigbor n, pid) nl
let (to_reg_enable_fun : 's enable_fun ->
's Register.neighbor list -> 's -> action list) =
@@ -89,17 +89,17 @@ let (to_reg_step_fun : 's step_fun ->
f s (List.map to_reg_neigbor nl) a
let (to_reg_potential_fun :
- 's potential_fun -> pid list -> (pid -> 's * 's Register.neighbor list) -> float) =
+ 's potential_fun -> pid list -> (pid -> 's * ('s Register.neighbor * pid) list) -> float) =
fun pf pidl f ->
let nf pid = to_reg_info (f pid) in
pf pidl nf
let (to_reg_legitimate_fun :
- 's legitimate_fun -> pid list -> (pid -> 's * 's Register.neighbor list) -> bool) =
+ 's legitimate_fun -> pid list -> (pid -> 's * ('s Register.neighbor * pid) list) -> bool) =
fun lf pidl from_pid ->
let n_from_pid pid =
let s, nl = from_pid pid in
- s, List.map to_reg_neigbor nl
+ s, List.map (fun (n,pid) -> to_reg_neigbor n, pid) nl
in
lf pidl n_from_pid
diff --git a/lib/algo/algo.mli b/lib/algo/algo.mli
index 9460dc002a6d1a06060459c49033430850cb0e19..2cc2ca7c0632728dca383835896cb095fc21b9cb 100644
--- a/lib/algo/algo.mli
+++ b/lib/algo/algo.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 16/09/2020 (at 15:42) by Erwan Jahier> *)
+(* Time-stamp: <modified the 13/10/2020 (at 15:30) by Erwan Jahier> *)
(** {1 The Algorithm programming Interface}
A SASA process is an instance of an algorithm defined via this
@@ -53,12 +53,12 @@ type 's state_init_fun = int -> string -> 's
*)
type pid = string
-type 's potential_fun = pid list -> (pid -> 's * 's neighbor list) -> float
+type 's potential_fun = pid list -> (pid -> 's * ('s neighbor * pid) list) -> float
(** {3 Legitimate Configurations} *)
-type 's legitimate_fun = pid list -> (pid -> 's * 's neighbor list) -> bool
+type 's legitimate_fun = pid list -> (pid -> 's * ('s neighbor * pid) list) -> bool
(** By default, legitimate configurations (i.e., global states) are
silent ones. But this is not true for all algorithms. Predicates
of this type are used to redefine what's a legitimate configuration
diff --git a/lib/sasa/sasaRun.ml b/lib/sasa/sasaRun.ml
index ba174a44949996ffe04c8eb904f605ecd4e184f4..627c29961bb83ff48f63f302b8390abf04dc8511 100644
--- a/lib/sasa/sasaRun.ml
+++ b/lib/sasa/sasaRun.ml
@@ -45,146 +45,151 @@ let (compute_potentiel: ('v Process.t * 'v Register.neighbor list) list ->
| Some user_pf ->
let pidl = List.map (fun (p,_) -> p.Process.pid) p_nl_l in
let get_info pid =
+ let nl = snd (List.find (fun (p,_) -> p.Process.pid = pid) p_nl_l) in
Env.get ne pid,
- snd (List.find (fun (p,_) -> p.Process.pid = pid) p_nl_l)
+ List.map (fun n -> n, n.Register.pid) nl
in
let p = (user_pf pidl get_info) in
[("potential", Data.F p)]
-
+
+(* The nl local state needs to be updated w.r.t. e *)
+let update_p_nl_l e p_nl_l = List.map
+ (fun (p,nl) -> p, List.map (Sasacore.Main.update_neighbor_env e) nl)
+ p_nl_l
+
let (make_do: string array -> SasArg.t ->
('v Process.t * 'v Register.neighbor list) list -> 'v Env.t -> RdbgPlugin.t) =
fun argv args p_nl_l e ->
- let pl = fst (List.split p_nl_l) in
- let prog_id = Printf.sprintf "%s (with sasa Version %s)"
- (String.concat " " (Array.to_list argv)) SasaVersion.str
- in
- let vntl_i =
- List.map (fun (vn,vt) -> vn, Data.type_of_string vt)
- (Sasacore.Main.get_inputs_rif_decl args pl)
- in
- let vntl_o =
- List.map (fun (vn,vt) -> vn, Data.type_of_string vt)
- (Sasacore.Main.get_outputs_rif_decl args pl)
- in
- let vntl_o =
- if Register.get_potential () = None then vntl_o else ("potential", Data.Real)::vntl_o in
- let vntl_o = ("silent", Data.Bool)::vntl_o in
- let pre_enable_processes_opt = ref None in
- let sasa_env = ref e in
- let reset () =
- pre_enable_processes_opt := None;
- sasa_env := e
- in
- (* Do the same job as SasaMain.simustep *)
- let (step: RdbgPlugin.sl -> RdbgPlugin.sl) =
- fun sl_in ->
- let e = !sasa_env in
- match !pre_enable_processes_opt with
- | None -> ( (* the first step *)
- (* 1: Get enable processes *)
- let pnall, enab_ll = Sasacore.Main.get_enable_processes p_nl_l e in
- let sasa_nenv = from_sasa_env p_nl_l e in
- let pot_sl = compute_potentiel p_nl_l e in
+ let pl = fst (List.split p_nl_l) in
+ let prog_id = Printf.sprintf "%s (with sasa Version %s)"
+ (String.concat " " (Array.to_list argv)) SasaVersion.str
+ in
+ let vntl_i =
+ List.map (fun (vn,vt) -> vn, Data.type_of_string vt)
+ (Sasacore.Main.get_inputs_rif_decl args pl)
+ in
+ let vntl_o =
+ List.map (fun (vn,vt) -> vn, Data.type_of_string vt)
+ (Sasacore.Main.get_outputs_rif_decl args pl)
+ in
+ let vntl_o =
+ if Register.get_potential () = None then vntl_o else ("potential", Data.Real)::vntl_o in
+ let vntl_o = ("silent", Data.Bool)::vntl_o in
+ let pre_enable_processes_opt = ref None in
+ let sasa_env = ref e in
+ let reset () =
+ pre_enable_processes_opt := None;
+ sasa_env := e
+ in
+ (* Do the same job as SasaMain.simustep *)
+ let (step: RdbgPlugin.sl -> RdbgPlugin.sl) =
+ fun sl_in ->
+ let e = !sasa_env in
+ let p_nl_l = update_p_nl_l e p_nl_l in
+ match !pre_enable_processes_opt with
+ | None -> ( (* the first step *)
+ (* 1: Get enable processes *)
+ let pnall, enab_ll = Sasacore.Main.get_enable_processes p_nl_l e in
+ let sasa_nenv = from_sasa_env p_nl_l e in
+ let pot_sl = compute_potentiel p_nl_l e in
+ let silent = List.for_all (fun b -> not b) (List.flatten enab_ll) in
+ pre_enable_processes_opt := Some(pnall, enab_ll);
+ ("silent", Data.B silent)::pot_sl @ sasa_nenv @ (get_sl_out true pl enab_ll)
+ )
+ | Some (pre_pnall, pre_enab_ll) ->
+ (* 2: read the actions from the outside process, i.e., from sl_in *)
+ let _, pnal = Daemon.f args.dummy_input
+ (args.verbose > 0) args.daemon p_nl_l e pre_pnall pre_enab_ll
+ (get_action_value sl_in)
+ in
+ (* 3: Do the steps *)
+ let ne = Sasacore.Step.f pnal e in
+ let new_p_nl_l = update_p_nl_l ne p_nl_l in
+ let sasa_nenv = from_sasa_env p_nl_l ne in
+ (* 1': Get enable processes *)
+ let pnall, enab_ll = Sasacore.Main.get_enable_processes p_nl_l ne in
let silent = List.for_all (fun b -> not b) (List.flatten enab_ll) in
+ let pot_sl = compute_potentiel new_p_nl_l ne in
pre_enable_processes_opt := Some(pnall, enab_ll);
- ("silent", Data.B silent)::pot_sl @ sasa_nenv @ (get_sl_out true pl enab_ll)
- )
- | Some (pre_pnall, pre_enab_ll) ->
- (* 2: read the actions from the outside process, i.e., from sl_in *)
- let _, pnal = Daemon.f args.dummy_input
- (args.verbose > 0) args.daemon p_nl_l e pre_pnall pre_enab_ll
- (get_action_value sl_in)
- in
- (* 3: Do the steps *)
- let ne = Sasacore.Step.f pnal e in
- let sasa_nenv = from_sasa_env p_nl_l ne in
- (* 1': Get enable processes *)
- let new_p_nl_l =
- List.map (fun (p,nl) ->
- p, List.map (Sasacore.Main.update_neighbor_env ne) nl ) p_nl_l
- in
- let pnall, enab_ll = Sasacore.Main.get_enable_processes p_nl_l ne in
+ sasa_env := ne;
+ ("silent", Data.B silent)::pot_sl @ sasa_nenv @ (get_sl_out true pl enab_ll)
+ in
+ let (step_internal_daemon: RdbgPlugin.sl -> RdbgPlugin.sl) =
+ fun sl_in ->
+ (* in this mode, sasa does not play first *)
+ let e = !sasa_env in
+ let p_nl_l = update_p_nl_l e p_nl_l in
+ (* 1: Get enable processes *)
+ let pnall, enab_ll = Sasacore.Main.get_enable_processes p_nl_l e in
+ let pot_sl = compute_potentiel p_nl_l e in
let silent = List.for_all (fun b -> not b) (List.flatten enab_ll) in
- let pot_sl = compute_potentiel new_p_nl_l ne in
- pre_enable_processes_opt := Some(pnall, enab_ll);
- sasa_env := ne;
- ("silent", Data.B silent)::pot_sl @ sasa_nenv @ (get_sl_out true pl enab_ll)
- in
- let (step_internal_daemon: RdbgPlugin.sl -> RdbgPlugin.sl) =
- fun sl_in ->
- (* in this mode, sasa does not play first *)
- let e = !sasa_env in
- (* 1: Get enable processes *)
- let pnall, enab_ll = Sasacore.Main.get_enable_processes p_nl_l e in
- let silent = List.for_all (fun b -> not b) (List.flatten enab_ll) in
- if silent then (
- ("silent", Data.B true)::(from_sasa_env p_nl_l e) @ (get_sl_out true pl enab_ll)
- )
- else
- (* 2: read the actions from the outside process, i.e., from sl_in *)
- let activate_val, pnal = Daemon.f args.dummy_input
- (args.verbose > 0) args.daemon p_nl_l e pnall enab_ll
- (get_action_value sl_in)
- in
- (* 3: Do the steps *)
- let ne = Sasacore.Step.f pnal e in
- let pot_sl = compute_potentiel p_nl_l ne in
- sasa_env := ne;
- ("silent", Data.B false)::pot_sl @
- (from_sasa_env p_nl_l e) @ (get_sl_out true pl enab_ll) @
- (get_sl_out false pl activate_val)
- in
- let step = if args.daemon = Daemon.Custom then step else step_internal_daemon in
- let ss_table = Hashtbl.create 10 in
- let step_dbg sl_in ctx cont =
- let sl_out = step sl_in in
- { ctx with
- (* RdbgEvent.nb = 0; *)
- (* RdbgEvent.step = 0; (* we are actually in the middle of the first step! *) *)
- RdbgEvent.depth = ctx.RdbgEvent.depth + 1;
- RdbgEvent.kind = RdbgEvent.Exit;
- RdbgEvent.lang = "sasa";
- RdbgEvent.sinfo = None;
- RdbgEvent.name = "sasa";
- RdbgEvent.inputs = vntl_i;
- RdbgEvent.outputs = vntl_o;
- RdbgEvent.locals = [];
- RdbgEvent.data = sl_in@sl_out;
- RdbgEvent.next = (
- fun () ->
- let ctx = { ctx with RdbgEvent.nb = 1 + ctx.RdbgEvent.nb } in
- cont sl_out ctx );
+ if silent then (
+ ("silent", Data.B true)::(from_sasa_env p_nl_l e) @ (get_sl_out true pl enab_ll)
+ )
+ else
+ (* 2: read the actions from the outside process, i.e., from sl_in *)
+ let activate_val, pnal = Daemon.f args.dummy_input
+ (args.verbose > 0) args.daemon p_nl_l e pnall enab_ll
+ (get_action_value sl_in)
+ in
+ (* 3: Do the steps *)
+ let ne = Sasacore.Step.f pnal e in
+ sasa_env := ne;
+ ("silent", Data.B false)::pot_sl @
+ (from_sasa_env p_nl_l e) @ (get_sl_out true pl enab_ll) @
+ (get_sl_out false pl activate_val)
+ in
+ let step = if args.daemon = Daemon.Custom then step else step_internal_daemon in
+ let ss_table = Hashtbl.create 10 in
+ let step_dbg sl_in ctx cont =
+ let sl_out = step sl_in in
+ { ctx with
+ (* RdbgEvent.nb = 0; *)
+ (* RdbgEvent.step = 0; (* we are actually in the middle of the first step! *) *)
+ RdbgEvent.depth = ctx.RdbgEvent.depth + 1;
+ RdbgEvent.kind = RdbgEvent.Exit;
+ RdbgEvent.lang = "sasa";
+ RdbgEvent.sinfo = None;
+ RdbgEvent.name = "sasa";
+ RdbgEvent.inputs = vntl_i;
+ RdbgEvent.outputs = vntl_o;
+ RdbgEvent.locals = [];
+ RdbgEvent.data = sl_in@sl_out;
+ RdbgEvent.next = (
+ fun () ->
+ let ctx = { ctx with RdbgEvent.nb = 1 + ctx.RdbgEvent.nb } in
+ cont sl_out ctx );
+ }
+ in
+ let (mems_in : Data.subst list) = [] in
+ let (mems_out : Data.subst list) = [] in
+ {
+ id = prog_id;
+ inputs = vntl_i;
+ outputs= vntl_o;
+ reset=(fun () -> reset());
+ kill=(fun _ -> flush stdout; flush stderr);
+ init_inputs=mems_in;
+ init_outputs=mems_out;
+ step=step;
+ step_dbg = step_dbg;
+ save_state = (fun i ->
+ let prgs = Random.get_state () in
+ (* Printf.eprintf "Save state %i from sasa\n%!" i; *)
+ Hashtbl.replace ss_table i
+ (prgs, !sasa_env, !pre_enable_processes_opt)
+ );
+ restore_state = (fun i ->
+ match Hashtbl.find_opt ss_table i with
+ | Some (prgs, e, pepo) ->
+ Random.set_state prgs;
+ (* Printf.eprintf "Restore state %i from sasa\n%!" i; *)
+ sasa_env := e; pre_enable_processes_opt := pepo
+ | None ->
+ Printf.eprintf "Cannot restore state %i from sasa\n" i;
+ flush stderr
+ );
}
- in
- let (mems_in : Data.subst list) = [] in
- let (mems_out : Data.subst list) = [] in
- {
- id = prog_id;
- inputs = vntl_i;
- outputs= vntl_o;
- reset=(fun () -> reset());
- kill=(fun _ -> flush stdout; flush stderr);
- init_inputs=mems_in;
- init_outputs=mems_out;
- step=step;
- step_dbg = step_dbg;
- save_state = (fun i ->
- let prgs = Random.get_state () in
- (* Printf.eprintf "Save state %i from sasa\n%!" i; *)
- Hashtbl.replace ss_table i
- (prgs, !sasa_env, !pre_enable_processes_opt)
- );
- restore_state = (fun i ->
- match Hashtbl.find_opt ss_table i with
- | Some (prgs, e, pepo) ->
- Random.set_state prgs;
- (* Printf.eprintf "Restore state %i from sasa\n%!" i; *)
- sasa_env := e; pre_enable_processes_opt := pepo
- | None ->
- Printf.eprintf "Cannot restore state %i from sasa\n" i;
- flush stderr
- );
- }
let (make: string array -> RdbgPlugin.t) =
diff --git a/lib/sasacore/env.mli b/lib/sasacore/env.mli
index 0b4204ce2a09bc87259951014829d702db023dd2..c22d152dfd974b0be63355edb270f245e23dfd73 100644
--- a/lib/sasacore/env.mli
+++ b/lib/sasacore/env.mli
@@ -3,11 +3,12 @@ type 'v t
val init: unit -> 'v t
-(** [set env process_id var_name var_value] *)
+(** [set env process_id var_value] *)
val set: 'v t -> string -> 'v -> 'v t
-(** [get env process_id var_name] *)
+(** [get env process_id] *)
val get: 'v t -> string -> 'v
-(** Use registered copy function to returns an (hopefully) fresh copy *)
+(** Use registered copy function to returns an hopefully (if the user
+ provided copy state function is correct) fresh copy *)
val get_copy: 'v t -> string -> 'v
diff --git a/lib/sasacore/evil.ml b/lib/sasacore/evil.ml
index 82de548cf061ed2014452f6788bd66b8835bd938..5aee11602d62f078cbf70eb425efa09de7768ba7 100644
--- a/lib/sasacore/evil.ml
+++ b/lib/sasacore/evil.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 28/09/2020 (at 11:31) by Erwan Jahier> *)
+(* Time-stamp: <modified the 13/10/2020 (at 16:06) by Erwan Jahier> *)
type 'v pna = 'v Process.t * 'v Register.neighbor list * Register.action
@@ -129,8 +129,9 @@ let (worst: bool -> 'v Env.t -> ('v Process.t * 'v Register.neighbor list) list
let pidl = List.map (fun (p,_) -> p.Process.pid) p_nl_l in
let ne = Step.f pnal e in
let get_info pid =
+ let nl = snd (List.find (fun (p,_) -> p.Process.pid = pid) p_nl_l) in
Env.get ne pid,
- snd (List.find (fun (p,_) -> p.Process.pid = pid) p_nl_l)
+ List.map (fun n -> n, n.Register.pid) nl
in
user_pf pidl get_info
in
@@ -170,8 +171,9 @@ let (worst_central: bool -> 'v Env.t -> ('v Process.t * 'v Register.neighbor lis
let pidl = List.map (fun (p,_) -> p.Process.pid) p_nl_l in
let ne = Step.f [pna] e in
let get_info pid =
+ let nl = snd (List.find (fun (p,_) -> p.Process.pid = pid) p_nl_l) in
Env.get ne pid,
- snd (List.find (fun (p,_) -> p.Process.pid = pid) p_nl_l)
+ List.map (fun n -> n, n.Register.pid) nl
in
user_pf pidl get_info
in
diff --git a/lib/sasacore/main.ml b/lib/sasacore/main.ml
index 22cd51b82c393a2960f8844328536011de3f0252..0f79e98d27cc11fb0222bd48ff454a3c6d5c5a1a 100644
--- a/lib/sasacore/main.ml
+++ b/lib/sasacore/main.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 01/09/2020 (at 17:15) by Erwan Jahier> *)
+(* Time-stamp: <modified the 15/10/2020 (at 15:53) by Erwan Jahier> *)
open Register
@@ -274,9 +274,13 @@ let (make : bool -> string array -> 'v t) =
Printf.eprintf "==> get input var names...\n%!";
List.iter (fun (vn,vt) -> Printf.printf "\"%s\":%s " vn vt) inputs_decl;
Printf.printf "\n%!";
+ let pot = match Register.get_potential () with
+ | None -> ""
+ | Some _ -> "potential:real"
+ in
if !Register.verbose_level > 0 then
Printf.eprintf "==> get output var names...\n%!";
- Printf.printf "#outputs %s\n" (env_rif_decl args pl);
+ Printf.printf "#outputs %s %s\n" (env_rif_decl args pl) pot;
Printf.printf "\n%!";
flush_all()
);
diff --git a/lib/sasacore/register.ml b/lib/sasacore/register.ml
index 350e829acf2b44d5a4990cd7e501764fd5c40032..2c646c476484fee0808e3b41fcc1dce14e84313a 100644
--- a/lib/sasacore/register.ml
+++ b/lib/sasacore/register.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 02/09/2020 (at 10:31) by Erwan Jahier> *)
+(* Time-stamp: <modified the 13/10/2020 (at 15:37) by Erwan Jahier> *)
type 's neighbor = {
state: 's ;
@@ -14,9 +14,9 @@ type 's enable_fun = 's neighbor list -> 's -> action list
type 's step_fun = 's neighbor list -> 's -> action -> 's
type pid = string
-type 's potential_fun = pid list -> (pid -> 's * 's neighbor list) -> float
+type 's potential_fun = pid list -> (pid -> 's * ('s neighbor * pid) list) -> float
type 's fault_fun = int -> string -> 's -> 's
-type 's legitimate_fun = string list -> (string -> 's * 's neighbor list) -> bool
+type 's legitimate_fun = string list -> (string -> 's * ('s neighbor * pid) list) -> bool
type 's internal_tables = {
init_state: (string, Obj.t) Hashtbl.t;
diff --git a/lib/sasacore/register.mli b/lib/sasacore/register.mli
index 2b93b06b5d586d9f7b44af524fe3dba32e678a3c..e405b94d6cbb8e3020a9760482a03e6ca7446e7f 100644
--- a/lib/sasacore/register.mli
+++ b/lib/sasacore/register.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 02/09/2020 (at 10:32) by Erwan Jahier> *)
+(* Time-stamp: <modified the 13/10/2020 (at 15:36) by Erwan Jahier> *)
(** This module duplicates and extends the Algo module with get_*
functions.
@@ -23,8 +23,8 @@ type 's step_fun = 's neighbor list -> 's -> action -> 's
type 's fault_fun = int -> string -> 's -> 's
type pid = string
-type 's potential_fun = pid list -> (pid -> 's * 's neighbor list) -> float
-type 's legitimate_fun = string list -> (string -> 's * 's neighbor list) -> bool
+type 's potential_fun = pid list -> (pid -> 's * ('s neighbor * pid) list) -> float
+type 's legitimate_fun = string list -> (string -> 's * ('s neighbor * pid) list) -> bool
val reg_init_state : algo_id -> (int -> string -> 's) -> unit
val reg_enable : algo_id -> 's enable_fun -> unit
diff --git a/lib/sasacore/step.ml b/lib/sasacore/step.ml
index 55068b9738ee99cd6d96af8f414180669bab711c..6e62b4bb787f0b3d414eb01c0713321a363dbe41 100644
--- a/lib/sasacore/step.ml
+++ b/lib/sasacore/step.ml
@@ -3,21 +3,18 @@ open Register
open Process
-let (update_neighbor_env: 'v Env.t -> 'v Register.neighbor -> 'v Register.neighbor) =
- fun e n ->
- { n with state = Env.get_copy e n.Register.pid }
let (update_env: 'v Env.t -> 'v Process.t * 'v -> 'v Env.t) =
fun e (p, st) ->
Env.set e p.pid st
-let (f : ('v Process.t * 'v Register.neighbor list * action) list -> 'v Env.t
- -> 'v Env.t) =
+let (f : ('v Process.t * 'v Register.neighbor list * action) list -> 'v Env.t -> 'v Env.t) =
fun pnal e ->
let lenv_list =
List.map (fun (p,nl,a) ->
- let nl = List.map (update_neighbor_env e) nl in
+ (* I perform a copy of the local env to make sure the
+ configuration update is atomic *)
let lenv = Env.get_copy e p.pid in
p, p.step nl lenv a)
pnal
diff --git a/lib/sasacore/step.mli b/lib/sasacore/step.mli
index 0ca3da97e26f0a3064692be218c7aaccdbe217f9..436e95e3eeb6dee7300bf30c60bbe2f8f856a1fa 100644
--- a/lib/sasacore/step.mli
+++ b/lib/sasacore/step.mli
@@ -1,2 +1,5 @@
+
+(* [f pnal e] performs a step (according to the actions in pnal) and returns a new env *)
+
val f : ('v Process.t * 'v Register.neighbor list * Register.action) list -> 'v Env.t
-> 'v Env.t
diff --git a/src/sasaMain.ml b/src/sasaMain.ml
index 2062ab765e5bce0cb0f8cbb84953441b478eeb6d..0a65fcd60f77067e4f3f06fa2e0493afc10b1acd 100644
--- a/src/sasaMain.ml
+++ b/src/sasaMain.ml
@@ -1,8 +1,8 @@
open Sasacore
-let (print_step : int -> int -> SasArg.t -> 'v Env.t -> 'v Process.t list -> string ->
- bool list list -> unit) =
- fun n i args e pl activate_val enab_ll ->
+let (print_step : int -> int -> string -> SasArg.t -> 'v Env.t -> 'v Process.t list -> string ->
+ bool list list -> unit) =
+ fun n i pot args e pl activate_val enab_ll ->
let enable_val =
String.concat " " (List.map (fun b -> if b then "t" else "f")
(List.flatten enab_ll))
@@ -13,17 +13,17 @@ let (print_step : int -> int -> SasArg.t -> 'v Env.t -> 'v Process.t list -> str
if args.daemon = Daemon.Custom then (
(* in custom mode, to be able to talk with lurette, this should not be
printed on stdout
- *)
+ *)
Printf.eprintf "\n#step %s\n" (string_of_int (n-i)) ;
Printf.eprintf "%s #outs " activate_val; flush stderr;
- Printf.printf "%s %s\n" (StringOf.env_rif e pl) enable_val;
+ Printf.printf "%s %s %s\n" (StringOf.env_rif e pl) enable_val pot;
) else (
(* rif mode, internal daemons *)
if args.rif then
- Printf.printf " %s %s %s\n%!" (StringOf.env_rif e pl) enable_val activate_val
+ Printf.printf " %s %s %s %s\n%!" (StringOf.env_rif e pl) enable_val activate_val pot
else (
Printf.printf "\n#step %s\n" (string_of_int (n-i));
- Printf.printf "#outs %s %s %s\n%!" (StringOf.env_rif e pl) enable_val activate_val
+ Printf.printf "#outs %s %s %s %s\n%!" (StringOf.env_rif e pl) enable_val activate_val pot
);
);
flush stderr;
@@ -62,8 +62,10 @@ let legitimate p_nl_l e =
| [] -> assert false (* sno *)
| (p,nl)::tail ->
if p.Process.pid = pid then
+ let nl = List.map (Sasacore.Main.update_neighbor_env e) nl in
+ let nl = List.map (fun n -> n,n.Register.pid) nl in
Env.get e pid,
- List.map (Sasacore.Main.update_neighbor_env e) nl
+ nl
else
from_pid tail pid
in
@@ -79,12 +81,35 @@ let inject_fault ff p_nl e =
List.fold_left update_nodes e p_nl
let plur i = if i>1 then "s" else ""
-
+
+let (compute_potentiel: ('v Process.t * 'v Register.neighbor list) list ->
+ 'v Env.t -> string) =
+ fun p_nl_l ne ->
+ match Register.get_potential () with
+ | None -> ""
+ | Some user_pf ->
+ let pidl = List.map (fun (p,_) -> p.Process.pid) p_nl_l in
+ let get_info pid =
+ let nl = match List.find_opt (fun (p,_) -> p.Process.pid = pid) p_nl_l with
+ None -> failwith (Printf.sprintf "no %s found in %s" pid
+ (String.concat "," (List.map (fun (p,_) -> p.Process.pid) p_nl_l)))
+ | Some (_,x) -> x
+ in
+ Env.get ne pid,
+ List.map (fun n -> n, n.Register.pid) nl
+ in
+ let p = (user_pf pidl get_info) in
+ string_of_float p
+
+
let (simustep: int -> int -> SasArg.t -> string ->
('v Process.t * 'v Register.neighbor list) list -> 'v Env.t -> 'v Env.t * string) =
fun n i args activate_val p_nl_l e ->
(* 1: Get enable processes *)
+ if !Register.verbose_level > 0 then
+ Printf.eprintf "==> SasaMain.simustep :1: Get enable processes\n%!";
let all, enab_ll = Sasacore.Main.get_enable_processes p_nl_l e in
+ let pot = compute_potentiel p_nl_l e in
let pl = fst(List.split p_nl_l) in
let e, all, enab_ll =
if
@@ -92,41 +117,43 @@ let (simustep: int -> int -> SasArg.t -> string ->
then (
match Register.get_fault () with
| None ->
- print_step n i args e pl activate_val enab_ll;
- incr rounds;
- raise (Silent (n-i))
+ print_step n i pot args e pl activate_val enab_ll;
+ incr rounds;
+ raise (Silent (n-i))
| Some ff ->
- print_step n i args e pl activate_val enab_ll;
- let str = if args.rif then "#" else "" in
- Printf.eprintf "\n%sThis algo is silent after %i move%s, %i step%s, %i round%s.\n"
- str !moves (plur !moves) (n-i) (plur (n-i)) !rounds (plur !rounds);
- Printf.eprintf "%s==> Inject a fault\n%!" str;
- let e = inject_fault ff p_nl_l e in
- let all, enab_ll = Sasacore.Main.get_enable_processes p_nl_l e in
- e, all, enab_ll
+ print_step n i pot args e pl activate_val enab_ll;
+ let str = if args.rif then "#" else "" in
+ Printf.eprintf "\n%sThis algo is silent after %i move%s, %i step%s, %i round%s.\n"
+ str !moves (plur !moves) (n-i) (plur (n-i)) !rounds (plur !rounds);
+ Printf.eprintf "%s==> Inject a fault\n%!" str;
+ let e = inject_fault ff p_nl_l e in
+ let all, enab_ll = Sasacore.Main.get_enable_processes p_nl_l e in
+ e, all, enab_ll
)
else if legitimate p_nl_l e then (
match Register.get_fault () with
| None ->
- print_step n i args e pl activate_val enab_ll;
- raise (Legitimate (n-i))
+ print_step n i pot args e pl activate_val enab_ll;
+ raise (Legitimate (n-i))
| Some ff ->
- print_step n i args e pl activate_val enab_ll;
- let str = if args.rif then "#" else "" in
- Printf.eprintf
- "\n%sThis algo reached a legitimate configuration after %i move%s, %i step%s, %i round%s.\n"
- str !moves (plur !moves) (n-i) (plur (n-i)) !rounds (plur !rounds);
- Printf.eprintf "%s==> Inject a fault\n%!" str;
- let e = inject_fault ff p_nl_l e in
- let all, enab_ll = Sasacore.Main.get_enable_processes p_nl_l e in
- e, all, enab_ll
+ print_step n i pot args e pl activate_val enab_ll;
+ let str = if args.rif then "#" else "" in
+ Printf.eprintf
+ "\n%sThis algo reached a legitimate configuration after %i move%s, %i step%s, %i round%s.\n"
+ str !moves (plur !moves) (n-i) (plur (n-i)) !rounds (plur !rounds);
+ Printf.eprintf "%s==> Inject a fault\n%!" str;
+ let e = inject_fault ff p_nl_l e in
+ let all, enab_ll = Sasacore.Main.get_enable_processes p_nl_l e in
+ e, all, enab_ll
)
else
e, all, enab_ll
in
if args.daemon = Daemon.Custom then
- print_step n i args e pl activate_val enab_ll;
+ print_step n i pot args e pl activate_val enab_ll;
(* 2: read the actions *)
+ if !Register.verbose_level > 0 then
+ Printf.eprintf "==> SasaMain.simustep : 2: read the actions\n%!";
let get_action_value = RifRead.bool (args.verbose > 1) in
let next_activate_val, pnal = Daemon.f args.dummy_input
(args.verbose >= 1) args.daemon p_nl_l e all enab_ll get_action_value
@@ -135,15 +162,22 @@ let (simustep: int -> int -> SasArg.t -> string ->
update_round next_activate_val enab_ll;
let next_activate_val = bool_ll_to_string next_activate_val in
(* 3: Do the steps *)
- let ne = Sasacore.Step.f pnal e in
+ if !Register.verbose_level > 0 then
+ Printf.eprintf "==> SasaMain.simustep : 3: Do the steps\n%!";
if args.daemon <> Daemon.Custom then
- print_step n i args e pl next_activate_val enab_ll;
+ print_step n i pot args e pl next_activate_val enab_ll;
+ let ne = Sasacore.Step.f pnal e in
ne, next_activate_val
let rec (simuloop: int -> int -> SasArg.t -> string ->
('v Process.t * 'v Register.neighbor list) list -> 'v Env.t -> unit) =
fun n i args activate_val p_nl_l e ->
+ if !Register.verbose_level > 0 then Printf.eprintf "==> SasaMain.simuloop %d/%d \n%!" i n;
let ne, next_activate_val = simustep n i args activate_val p_nl_l e in
+ let p_nl_l = List.map
+ (fun (p,nl) -> p, List.map (Sasacore.Main.update_neighbor_env ne) nl)
+ p_nl_l
+ in
if i > 0 then simuloop n (i-1) args next_activate_val p_nl_l ne else (
print_string "#q\n"; flush stdout
)
diff --git a/test/Makefile.dot b/test/Makefile.dot
index e4ff29bace26af01024f247d01dff7d42c58e769..77920060e1406f77dc70dfccfc3bbb3515a434ac 100644
--- a/test/Makefile.dot
+++ b/test/Makefile.dot
@@ -1,4 +1,4 @@
-# Time-stamp: <modified the 14/04/2020 (at 17:16) by Erwan Jahier>
+# Time-stamp: <modified the 14/10/2020 (at 21:46) by Erwan Jahier>
# Rules to generate various dot files.
@@ -33,6 +33,10 @@ ring%.dot:
gg ring -n $* -o $@
gg-deco $(DECO_PATTERN) $@ -o $@
+dtree%.dot:
+ gg tree -dir -n $* -o $@
+ gg-deco $(DECO_PATTERN) $@ -o $@
+
cleandot:
rm -f ring5* ring30* er30* er100* grid* ba100* udg* qudg*
diff --git a/test/coloring/config.ml b/test/coloring/config.ml
index 5a3230915315beb71fad5aa3d0e774277f7aa0f8..aa5fd985aaae3bb14c7ed2859797d3d1b58e479b 100644
--- a/test/coloring/config.ml
+++ b/test/coloring/config.ml
@@ -5,7 +5,7 @@ let clash_number pidl get =
let clash = ref 0 in
let color pid = fst (get pid) in
List.iter (fun pid ->
- List.iter (fun n -> if state n = color pid then incr clash) (snd (get pid)))
+ List.iter (fun (n,_) -> if state n = color pid then incr clash) (snd (get pid)))
pidl;
float_of_int !clash
diff --git a/test/dijkstra-ring/config.ml b/test/dijkstra-ring/config.ml
index 762edb25517cc351730c539f0891391fd9e2e8de..661adc58d02bceefdec43c4410e9b8581062be4d 100644
--- a/test/dijkstra-ring/config.ml
+++ b/test/dijkstra-ring/config.ml
@@ -10,6 +10,7 @@ let (legitimate: t Algo.legitimate_fun) =
(* only one node is enabled *)
let incr_token i pid =
let s, nl = get pid in
+ let nl = List.map fst nl in
let have_token = (if s.root then Root.enable_f s nl else P.enable_f s nl) <> [] in
if have_token then i+1 else i
in
diff --git a/test/k-clustering/Makefile b/test/k-clustering/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..cc38fd6c6e9fd7128981df40b89797d9efdafafc
--- /dev/null
+++ b/test/k-clustering/Makefile
@@ -0,0 +1,32 @@
+# Time-stamp: <modified the 15/10/2020 (at 15:36) by Erwan Jahier>
+
+
+test: fig52_kcl.cmxs
+ sasa -gcd fig52_kcl.dot
+
+cd: fig52_kcl.cmxs
+ sasa -cd fig52_kcl.dot
+
+DECO_PATTERN="0-:p.ml"
+-include ../Makefile.dot
+
+sim2chrogtk: fig52_kcl.rif
+ sim2chrogtk -ecran -in $< > /dev/null
+
+gnuplot: fig52_kcl.rif
+ gnuplot-rif $<
+
+rdbg: fig52_kcl.ml
+ rdbg -o fig52_kcl.rif -env "sasa fig52_kcl.dot -gcd"
+
+rdbgcd: fig52_kcl.ml
+ rdbg -o fig52_kcl.rif -env "sasa fig52_kcl.dot -cd"
+
+dtree50: dtree50.cmxs
+ sasa -cd dtree50.dot
+
+clean: genclean
+ rm -f fig52_kcl.ml
+
+-include ../Makefile.inc
+-include Makefile.untracked
diff --git a/test/k-clustering/config.ml b/test/k-clustering/config.ml
new file mode 100644
index 0000000000000000000000000000000000000000..3e8fabff253cbc2d859561c205f07c3aaafe42d4
--- /dev/null
+++ b/test/k-clustering/config.ml
@@ -0,0 +1,44 @@
+
+open Algo
+open State
+open P
+
+let debug = false
+
+let rec (pot : pid -> (pid -> ('a * ('a neighbor*pid) list)) -> int -> int -> int) =
+ fun pid get level acc ->
+ (* From a pid and its level, adds to acc the potential of the tree
+ rooted in pid *)
+ let s, nl = get pid in
+ let nl2 = List.map fst nl in
+ let acc = if P.enable_f s nl2 <> [] then (
+ (* if debug then Printf.printf "%s -> acc=%d+%d\n%!" pid acc level ; *)
+ acc+level
+ )
+ else acc in
+ List.fold_left (fun acc (_, pid) -> pot pid get (level+1) acc) acc nl
+
+
+(* The potential is defined as the sum of enabled nodes levels (the
+ level is 1 for root, 2 for its children, and so on *)
+let (pf: pid list -> (pid -> ('a * ('a neighbor * pid) list)) -> float) =
+ fun pidl get ->
+ let root_pot = pot "root" get 1 0 in
+ if debug then (
+ let enab pid =
+ let v,nl = get pid in
+ if P.enable_f v (List.map fst nl) = [] then
+ ""
+ else
+ pid
+ in
+ let enab_list = List.map enab pidl in
+ Printf.printf "=================> potential(%s) = %d\n%!" (String.concat "," enab_list) root_pot
+ );
+ (* (String.concat "," (List.map (fun pid -> Printf.sprintf "%s=%b" get pid) pidl) root_pot ; *)
+ float_of_int root_pot
+
+let potential = Some pf
+
+let legitimate = None (* None => only silent configuration are legitimate *)
+let fault = None (* None => the simulation stop once a legitimate configuration is reached *)
diff --git a/test/k-clustering/fig52_kcl.dot b/test/k-clustering/fig52_kcl.dot
new file mode 100644
index 0000000000000000000000000000000000000000..8e94c2cdfaee2a0b609fe64483a27254e63930b7
--- /dev/null
+++ b/test/k-clustering/fig52_kcl.dot
@@ -0,0 +1,14 @@
+digraph fig52 {
+
+ root [algo="p.ml" init="{is_root=1 ; alpha=0}"]
+ p2 [algo="p.ml" init="{is_root=0 ; alpha=0}"]
+ p3 [algo="p.ml" init="{is_root=0 ; alpha=0}"]
+ p4 [algo="p.ml" init="{is_root=0 ; alpha=0}"]
+ p5 [algo="p.ml" init="{is_root=0 ; alpha=0}"]
+ p6 [algo="p.ml" init="{is_root=0 ; alpha=0}"]
+ p7 [algo="p.ml" init="{is_root=0 ; alpha=0}"]
+
+ root -> p2 -> p3 -> p4 -> p5 -> p6
+ p5 -> p7
+ }
+
\ No newline at end of file
diff --git a/test/k-clustering/my-rdbg-tuning.ml b/test/k-clustering/my-rdbg-tuning.ml
new file mode 100644
index 0000000000000000000000000000000000000000..b12b09cd74c71569488cc5d47df38332619d2edf
--- /dev/null
+++ b/test/k-clustering/my-rdbg-tuning.ml
@@ -0,0 +1,4 @@
+ (* *)
+#use "rdbg-cmds.ml";;
+#use "../sasa-rdbg-cmds.ml";;
+dot_view := fd;;
diff --git a/test/k-clustering/p.ml b/test/k-clustering/p.ml
new file mode 100644
index 0000000000000000000000000000000000000000..bef8df291239231ca0cf811560820fde9ecc3831
--- /dev/null
+++ b/test/k-clustering/p.ml
@@ -0,0 +1,72 @@
+(*
+Algorithm 1 of:
+ A Framework for Certified Self-Stabilization
+ Case Study: Silent Self-Stabilizing k-Dominating Set on a Tree
+https://hal.archives-ouvertes.fr/hal-01272158/document
+*)
+
+open Algo
+open State
+
+
+(* State predicates *)
+
+let isRoot p = p.isRoot
+
+let (isShort: 'st -> bool) =
+ fun p -> p.alpha < k
+
+let (isTall: 'st -> bool) =
+ fun p -> p.alpha >= k
+
+(* Actually unused *)
+let (kDominator: 'v -> bool) =
+ fun p -> (p.alpha = k) || ((isShort p) && (isRoot p))
+
+
+let rec (shortChildren: State.t neighbor list -> State.t list) =
+ fun nl ->
+ List.filter isShort (List.map state nl)
+
+let rec (tallChildren: State.t neighbor list -> 'st list) =
+ fun nl ->
+ List.filter isTall (List.map state nl)
+
+let rec (max: 'st list -> int -> int) =
+ fun sl cur ->
+ match sl with
+ [] -> cur
+ | s::liste -> if (s.alpha) > cur then max liste (s.alpha) else max liste cur
+
+let rec (min: 'st list -> int -> int) =
+ fun sl cur ->
+ match sl with
+ [] -> cur
+ | s::liste -> if (s.alpha) < cur then min liste (s.alpha) else min liste cur
+
+let (maxAShort: 'st neighbor list -> int) =
+ fun nl -> max (shortChildren nl) (-1)
+
+let (minATall: 'st neighbor list -> int) =
+ fun nl -> min (tallChildren nl) (2*k+1)
+
+let (newAlpha: 'st neighbor list -> int) =
+ fun nl ->
+ let mas = (maxAShort nl) in
+ let mit = (minATall nl) in
+ if (mas + mit) <= (2*k - 2) then (mit + 1) else (mas + 1)
+
+(*end macros*)
+
+let (init_state: int -> string -> 'st) =
+ fun _ pid ->
+ {
+ isRoot = pid = "root"; (* ZZZ: The root of the tree should be named "root"! *)
+ alpha = Random.int (2*k+1)
+ }
+
+let (enable_f: 'st -> 'st neighbor list -> action list) =
+ fun p nl -> if (p.alpha <> (newAlpha nl)) then ["change_alpha"] else []
+
+let (step_f : 'st -> 'st neighbor list -> action -> 'st ) =
+ fun p nl a -> if a = "change_alpha" then {p with alpha = (newAlpha nl)} else assert false
diff --git a/test/k-clustering/state.ml b/test/k-clustering/state.ml
new file mode 100644
index 0000000000000000000000000000000000000000..8985084259ea5adc24ce690f037f930688b111ed
--- /dev/null
+++ b/test/k-clustering/state.ml
@@ -0,0 +1,23 @@
+open Algo
+
+let d = max_degree()
+
+type t = {
+ isRoot:bool;
+ alpha:int;
+}
+
+let (to_string: (t -> string)) =
+ fun s ->
+ Printf.sprintf "alpha=%d" s.alpha
+
+let (of_string: (string -> t) option) =
+ Some (fun s ->
+ Scanf.sscanf s "{is_root=%d ; alpha=%d}"
+ (fun i alpha -> {isRoot = (i=1) ; alpha = alpha}))
+
+let (copy : ('v -> 'v)) = fun x -> x
+let actions = ["change_alpha"]
+
+let k = 2
+
diff --git a/tools/gg/graphGen.ml b/tools/gg/graphGen.ml
index 4e35fd346e77cff914a22d8c0dd412906f10de5a..bab125621dbb6ae9bdafc3d7e8a7d427bef3817f 100644
--- a/tools/gg/graphGen.ml
+++ b/tools/gg/graphGen.ml
@@ -241,7 +241,7 @@ let () = (
| "HC" -> (gen_hyper_cube dir t.n)
| "ER" -> (gen_ER dir t.n t.er)
| "BA" -> (gen_BA dir t.n t.ba)
- | "tree" -> (rand_tree dir t.n)
+ | "tree" -> (rand_tree t.tree_edge dir t.n)
| "UDG" ->
let (graph, plan) =
gen_udg dir t.n t.qudg.width t.qudg.height t.qudg.radius
diff --git a/tools/gg/graphGen_arg.ml b/tools/gg/graphGen_arg.ml
index b18a6f3fcb31f4ffa28dd8fd3f53ee6dc238bc44..2b1282be29b72407bc6214b9a60a5d24632246ff 100644
--- a/tools/gg/graphGen_arg.ml
+++ b/tools/gg/graphGen_arg.ml
@@ -17,6 +17,7 @@ type qudg_arg = {
type er_prob = float (*between 0 and 1*)
type ba_m = int (*positive*)
+type tree_edge = InTree | OutTree | InOutTree
type t = {
mutable outputFile: string;
@@ -25,6 +26,7 @@ type t = {
mutable action: action;
mutable n : int;
+ mutable tree_edge : tree_edge;
mutable grid : grid_arg;
mutable er : er_prob;
mutable ba : ba_m;
@@ -63,6 +65,7 @@ let (make_args : unit -> t) =
dotUDGrad = "";
action = "void";
+ tree_edge = InTree;
n = -1;
grid = {
width = 0;
@@ -134,7 +137,7 @@ let help args tool = (
("HC",[(["Generate a hyper-cube graph"],"")]);
("ER",[(["Generate a graph using the Erdos Renyi algo"],"")]);
("BA",[(["Generate a graph using the Barabasi–Albert algo"],"")]);
- ("tree",[(["Generate an acyclic graph (tree)"],"")]);
+ ("tree",[(["Generate a tree"],"")]);
("UDG",[(["Generate a graph using the Unit Disc Graph algo"],"")]);
("QUDG",[(["Generate a graph using the Quasi UDG algo"],"")]);
];
@@ -180,6 +183,24 @@ let (mkoptab : string array -> t -> unit) =
[([msg],"clique");([msg],"star");([msg],"ring");
([msg],"ER");([msg],"BA");([msg],"tree");([msg],"UDG");([msg],"QUDG")];
+ mkopt args ["--in-tree"]
+ (Arg.Unit (fun () -> match args.action with
+ | "tree" -> args.tree_edge <- InTree; args.directed <- true
+ | _ -> unexpected "--in-tree"))
+ [(["Generate directed in-trees (downward edges); Do the same as -dir actually "],"tree")];
+
+ mkopt args ["--out-tree"]
+ (Arg.Unit (fun () -> match args.action with
+ | "tree" -> args.tree_edge <- OutTree; args.directed <- true
+ | _ -> unexpected "--out-tree"))
+ [(["Generate directed out-trees (upward edges) "],"tree")];
+
+ mkopt args ["--in-out-tree"]
+ (Arg.Unit (fun () -> match args.action with
+ | "tree" -> args.tree_edge <- InOutTree; args.directed <- true
+ | _ -> unexpected "--in-out-tree"))
+ [(["Generate directed in-out-trees (downward+upward edges) "],"tree")];
+
mkopt args ["--dimension";"-d"] ~arg:" <int>"
(Arg.Int (fun n -> match args.action with
| "HC"-> args.n <- n
@@ -274,7 +295,7 @@ let (mkoptab : string array -> t -> unit) =
mkopt args ["--directed";"-dir"]
(Arg.Unit (fun () -> args.directed <- true))
- [(["NOT WORKING! Generate a directed graph."],"void")];
+ [(["Generate a directed graph"],"void")];
mkopt args ["--help";"-h"]
(Arg.Unit (fun () -> help args ((argv.(0))^(if args.action = "void" then ""
diff --git a/tools/gg/graphGen_arg.mli b/tools/gg/graphGen_arg.mli
index 5c966acf55010d85c41ed1e88210f9ecc822315b..c57eda5072298a19fcaa5235c7a189cbc8ff306f 100644
--- a/tools/gg/graphGen_arg.mli
+++ b/tools/gg/graphGen_arg.mli
@@ -15,6 +15,7 @@ type qudg_arg = {
type er_prob = float (*between 0 and 1*)
type ba_m = int (*positive*)
+type tree_edge = InTree | OutTree | InOutTree
type t = {
mutable outputFile: string;
@@ -23,6 +24,7 @@ type t = {
mutable action: action;
mutable n : int;
+ mutable tree_edge : tree_edge;
mutable grid : grid_arg;
mutable er : er_prob;
mutable ba : ba_m;
diff --git a/tools/gg/randomGraph.ml b/tools/gg/randomGraph.ml
index 27af6022a61b943271ab1b2458a7295f7a60fbb0..5b4df62f9e0125bff439de2e2a2a96a25e42de25 100644
--- a/tools/gg/randomGraph.ml
+++ b/tools/gg/randomGraph.ml
@@ -119,27 +119,37 @@ let gen_BA : (bool -> int -> int -> Topology.t) =
attributes = []
}
-let pre_rand_tree : (node_succ_t -> node_id list -> (node_id -> (int * node_id) list)) =
- fun node_succ ->
+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 ->
function
| [] -> failwith "Tree Error : You need at least one nodes in your tree"
| h::t ->
ignore (List.fold_left (fun acc elem ->
let no = (List.nth acc (Random.int (List.length acc))) in
- (Hashtbl.replace node_succ no ((1,elem)::(try Hashtbl.find node_succ no with Not_found -> []));
- Hashtbl.replace node_succ elem ((1,no)::(try Hashtbl.find node_succ elem with Not_found -> []))
- );
- (elem::acc)
+ (* add an option to control whether to add
+ - down edges
+ - 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 -> []));
+ (elem::acc)
) [h] (t));
(fun n -> try Hashtbl.find node_succ n with Not_found -> [])
-let (rand_tree: bool -> int -> Topology.t) =
- fun directed nb ->
- let (node_succ:node_succ_t) = Hashtbl.create nb and nodes = create_nodes "p" (0,nb) in
+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 node_succ nodes);
+ succ = (pre_rand_tree tree_edge node_succ nodes);
of_id = get_of_id nl;
directed = directed;
attributes = []
diff --git a/tools/gg/randomGraph.mli b/tools/gg/randomGraph.mli
index c26f84183a0de2e4a19e2e1077c81693619ac434..63e5009441f23c8568b3fa2e7d1460c8a98a9460 100644
--- a/tools/gg/randomGraph.mli
+++ b/tools/gg/randomGraph.mli
@@ -16,8 +16,9 @@ val gen_ER : bool -> int -> probability -> Topology.t
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: bool -> int -> Topology.t
+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,