diff --git a/lib/algo/algo.ml b/lib/algo/algo.ml
index 70987a158f14f571732d476414cf5c55f0f13604..ec69d07aba571ac79eb73b43bcccdefc5d2dc925 100644
--- a/lib/algo/algo.ml
+++ b/lib/algo/algo.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 29/06/2020 (at 10:44) by Erwan Jahier> *)
+(* Time-stamp: <modified the 06/07/2020 (at 13:37) by Erwan Jahier> *)
open Sasacore
(* Process programmer API *)
@@ -57,7 +57,8 @@ type 's to_register = {
state_of_string: (string -> 's) option;
copy_state: 's -> 's;
actions: action list;
- potential_function: 's potential_fun option
+ potential_function: 's potential_fun option;
+ fault_function : 's state_init_fun option
}
let (to_reg_neigbor : 's Register.neighbor -> 's neighbor) =
@@ -118,6 +119,10 @@ let (register : 's to_register -> unit) =
| None -> ()
| Some pf -> Register.reg_potential (Some (to_reg_potential_fun pf))
);
+ (match s.fault_function with
+ | None -> ()
+ | Some ff -> Register.reg_fault (Some ff)
+ );
()
let card = Register.card
diff --git a/lib/algo/algo.mli b/lib/algo/algo.mli
index ec5e771de5adfafaa39fe8161756a1af9adaa440..4bc09c571de29c195e4ae8d706138dacd6bafd22 100644
--- a/lib/algo/algo.mli
+++ b/lib/algo/algo.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 01/07/2020 (at 15:26) by Erwan Jahier> *)
+(* Time-stamp: <modified the 06/07/2020 (at 13:27) by Erwan Jahier> *)
(** {1 The Algorithm programming Interface.} *)
(**
{1 What's need to be provided by users.}
@@ -86,8 +86,7 @@ useful to explore best/worst case daemons
type pid = string
type 's pf_info = { neighbors : pid list ; curr : 's ; next : 's ; action:action }
type 's potential_fun = pid list -> (pid -> 's pf_info) -> float
-
-
+
(** {1 Code Registration}
The [register: 's to_register -> unit] function must be called once in
@@ -105,7 +104,8 @@ type 's to_register = {
state_of_string: (string -> 's) option;
copy_state: 's -> 's;
actions : action list (** Mandatory in custom daemon mode, or to use oracles *);
- potential_function: 's potential_fun option (** Mandatory with Evil daemons *)
+ potential_function: 's potential_fun option (** Mandatory with Evil daemons *);
+ fault_function : 's state_init_fun option (** used when a legitimate configuration is reached *)
}
(** - For the [state_to_string] field, the idea is to print the raw
values contained in ['s]. If a value is omitted, one won't see it
diff --git a/lib/sasacore/genRegister.ml b/lib/sasacore/genRegister.ml
index 8f474b3c7ddca6d34ec39f366c3ab472330875f2..6a19181d3bb8d5d7b40fc130037ea6322c03658a 100644
--- a/lib/sasacore/genRegister.ml
+++ b/lib/sasacore/genRegister.ml
@@ -49,10 +49,11 @@ let (f: string list -> string * string -> unit) =
copy_state = %s.copy;
actions = %s.actions;
potential_function = %s.potential;
+ fault_function = %s.fault;
}
"
(String.concat ";" l)
- state_module state_module state_module state_module state_module;
+ state_module state_module state_module state_module state_module state_module;
flush oc;
close_out oc;
Printf.eprintf " [sasa] The file %s has been generated\n" register_file;
@@ -69,6 +70,7 @@ let to_string _ = \"define_me\"
let of_string = None
let copy x = x
let potential = None
+let fault = None
";
flush oc;
close_out oc;
diff --git a/lib/sasacore/register.ml b/lib/sasacore/register.ml
index a2d5d8de7d2a790705a2f07248b72af62c91e31c..9225b819acd6c31423a1294388261afc836a8fae 100644
--- a/lib/sasacore/register.ml
+++ b/lib/sasacore/register.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 29/06/2020 (at 10:17) by Erwan Jahier> *)
+(* Time-stamp: <modified the 06/07/2020 (at 13:35) by Erwan Jahier> *)
type 's neighbor = {
state: 's ;
@@ -26,6 +26,7 @@ type 's internal_tables = {
copy_value : (string, Obj.t) Hashtbl.t;
graph_attributes : (string, string) Hashtbl.t;
mutable potential: Obj.t;
+ mutable fault: Obj.t;
mutable actions:action list;
mutable card : int ;
mutable min_deg : int;
@@ -61,6 +62,7 @@ let (tbls:'s internal_tables) = {
copy_value = Hashtbl.create 1;
graph_attributes = Hashtbl.create 1;
potential = (Obj.repr None);
+ fault = (Obj.repr None);
actions = [];
card = (-1);
min_deg = (-1);
@@ -133,6 +135,13 @@ let (reg_potential : 's potential_fun option -> unit) = fun x ->
let (get_potential : unit -> 's potential_fun option) = fun () ->
Obj.obj tbls.potential
+let (reg_fault : (int -> string -> 's) option -> unit) = fun x ->
+ if !verbose_level > 0 then Printf.eprintf "Registering fault function\n%!";
+ tbls.fault <- (Obj.repr x)
+
+let (get_fault : unit -> (int -> string -> 's) option) = fun () ->
+ Obj.obj tbls.fault
+
let (reg_actions : action list -> unit) =
fun x ->
if !verbose_level > 0 then Printf.eprintf "Registering actions\n%!";
diff --git a/lib/sasacore/register.mli b/lib/sasacore/register.mli
index 81c28577bb69357d8dde74a90c0ec2935383fde7..6a2c3e2b372410ac1d24fac65a61d1cc14054a34 100644
--- a/lib/sasacore/register.mli
+++ b/lib/sasacore/register.mli
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 29/06/2020 (at 10:18) by Erwan Jahier> *)
+(* Time-stamp: <modified the 06/07/2020 (at 13:35) by Erwan Jahier> *)
(** This module duplicates and extends the Algo module with get_*
functions.
@@ -29,6 +29,7 @@ val reg_init_state : algo_id -> (int -> string -> 's) -> unit
val reg_enable : algo_id -> 's enable_fun -> unit
val reg_step : algo_id -> 's step_fun -> unit
val reg_potential : 's potential_fun option -> unit
+val reg_fault : (int -> string -> 's) option -> unit
val reg_actions : action list -> unit
val reg_value_to_string : ('s -> string) -> unit
val reg_value_of_string : (string -> 's) -> unit
@@ -63,6 +64,7 @@ val get_step : algo_id -> 's step_fun
val get_init_state : algo_id -> int -> string -> 's
val get_actions : unit -> action list
val get_potential : unit -> 's potential_fun option
+val get_fault : unit -> (int -> string -> 's) option
val get_value_to_string : unit -> 's -> string
val get_value_of_string : unit -> (string -> 's) option
val get_copy_value : unit -> ('s -> 's)
diff --git a/test/alea-coloring-alt/state.ml b/test/alea-coloring-alt/state.ml
index c8e3fd3640c26dccab6fb4d3d590a3a56547fbaa..e944f30a90bbf6a10c17f7f12be80c297247bf88 100644
--- a/test/alea-coloring-alt/state.ml
+++ b/test/alea-coloring-alt/state.ml
@@ -5,3 +5,4 @@ let of_string = None
let copy = fun x -> x
let actions = ["C1";"C2"]
let potential = None
+let fault = None
diff --git a/test/alea-coloring-unif/state.ml b/test/alea-coloring-unif/state.ml
index f69023579037a89ba55f9196074ed4e91e408390..3984bb907c8557f422fefe8b7ee6b84d59c56157 100644
--- a/test/alea-coloring-unif/state.ml
+++ b/test/alea-coloring-unif/state.ml
@@ -5,3 +5,4 @@ let of_string = Some int_of_string
let copy x = x
let actions = ["a"]
let potential = None
+let fault = None
diff --git a/test/alea-coloring/state.ml b/test/alea-coloring/state.ml
index 7a1881515a2e7982b277b7478e66b073bf02bbfe..6b2b39f2650627a650b7c65f26d87d166df4f861 100644
--- a/test/alea-coloring/state.ml
+++ b/test/alea-coloring/state.ml
@@ -8,4 +8,6 @@ let of_string = Some int_of_string
let copy = fun x -> x
let actions = ["conflict"]
let potential = None
+let fault = None
+
diff --git a/test/async-unison/state.ml b/test/async-unison/state.ml
index d7044857a1eb95451bdc883eff9f0d98088e9d3c..0ccc8734fcfcd91ffc93c9d17d0810b11c3a4b19 100644
--- a/test/async-unison/state.ml
+++ b/test/async-unison/state.ml
@@ -5,3 +5,4 @@ let of_string = Some int_of_string
let copy x = x
let actions = ["I(p)"; "R(p)"]
let potential = None
+let fault = None
diff --git a/test/bfs-spanning-tree/state.ml b/test/bfs-spanning-tree/state.ml
index fae5b2f351e88238d87a89e5a5ce36056021ed0e..8f46e63302956bb3e99fcbd39993cdd941a0cf3f 100644
--- a/test/bfs-spanning-tree/state.ml
+++ b/test/bfs-spanning-tree/state.ml
@@ -18,3 +18,4 @@ let (copy : ('v -> 'v)) = fun x -> x
let actions = ["CD";"CP"]
let potential = None
+let fault = None
diff --git a/test/bfs-st-HC92/state.ml b/test/bfs-st-HC92/state.ml
index 6a098a5b2ece6e9336312a5bdd138f09c44accec..b8656efa9fd2864208ea1ca3413c143838f63eac 100644
--- a/test/bfs-st-HC92/state.ml
+++ b/test/bfs-st-HC92/state.ml
@@ -19,3 +19,4 @@ let print_neighbor =
let actions = ["R0";"R1"]
let potential = None
+let fault = None
diff --git a/test/coloring/state.ml b/test/coloring/state.ml
index 35e088c0aaaa2901d3452866d7d9d7d4dfb89589..96d0d9ef129b77d0deb41468856e85cc4c70e0f1 100644
--- a/test/coloring/state.ml
+++ b/test/coloring/state.ml
@@ -17,5 +17,5 @@ let pf pidl get =
pidl;
float_of_int !clash
-
let potential = Some pf
+let fault = None
diff --git a/test/dfs-list/state.ml b/test/dfs-list/state.ml
index d0fcb271f8a77ab319d1415f0630dbc5e74144f8..baab13519a6e8004d4016fde5206d0bb5c8265a5 100644
--- a/test/dfs-list/state.ml
+++ b/test/dfs-list/state.ml
@@ -21,3 +21,4 @@ let of_string = None
let copy x = x
let actions = ["update_path";"compute_parent"]
let potential = None
+let fault = None
diff --git a/test/dfs/state.ml b/test/dfs/state.ml
index 8c9cb34296d80d34c8a67d67cb0fb13ba6ce2820..7d99786e39c3ab2b7b56b20d54e67ab9081efbd5 100644
--- a/test/dfs/state.ml
+++ b/test/dfs/state.ml
@@ -28,3 +28,4 @@ let (copy : t -> t) =
let of_string = None
let actions = ["update_path";"compute_parent"]
let potential = None
+let fault = None
diff --git a/test/dijkstra-ring/state.ml b/test/dijkstra-ring/state.ml
index b40d2d73d673d5800fe0a33f524d771f85a27e0b..0c7a6dfb0facee5f3713f51c1e679afc46b2fea5 100644
--- a/test/dijkstra-ring/state.ml
+++ b/test/dijkstra-ring/state.ml
@@ -5,3 +5,4 @@ let of_string = None
let copy x = x
let actions = ["T"]
let potential = None
+let fault = None
diff --git a/test/skeleton/state.ml b/test/skeleton/state.ml
index cbc645702c76c1a02556633c21a4cee881231f0f..7e536a4ad474f358e054fa46e91d7715e412e18f 100644
--- a/test/skeleton/state.ml
+++ b/test/skeleton/state.ml
@@ -5,3 +5,4 @@ let of_string = Some int_of_string
let copy x = x
let actions = ["action1";"action2"]
let potential = None
+let fault = None
diff --git a/test/st-CYH91/state.ml b/test/st-CYH91/state.ml
index 33bac8f5c2a5e7fc8db5491de6378b8f1e74b16d..4d8dfc66bb4055dac20676c69048ea18b9ab61f0 100644
--- a/test/st-CYH91/state.ml
+++ b/test/st-CYH91/state.ml
@@ -19,3 +19,4 @@ let print_neighbor =
let actions = ["R0";"R1";"R2"]
let potential = None
+let fault = None
diff --git a/test/st-KK06-algo1/state.ml b/test/st-KK06-algo1/state.ml
index 423c1691eaa2b32594e4b01624bb5a630fd6f049..905b2c0c7a67955fdbe1c349ce23c1272ebbc351 100644
--- a/test/st-KK06-algo1/state.ml
+++ b/test/st-KK06-algo1/state.ml
@@ -5,3 +5,4 @@ let of_string = Some int_of_string
let copy x = x
let actions = ["R"]
let potential = None
+let fault = None
diff --git a/test/st-KK06-algo2/state.ml b/test/st-KK06-algo2/state.ml
index 8b4c9d90f90a9ff15df807be41b2a0ec53334442..af66e31f0fd474121db2a1ec541656d80d834f22 100644
--- a/test/st-KK06-algo2/state.ml
+++ b/test/st-KK06-algo2/state.ml
@@ -5,3 +5,4 @@ let of_string = Some int_of_string
let copy x = x
let actions = ["R";"R1"]
let potential = None
+let fault = None
diff --git a/test/unison/state.ml b/test/unison/state.ml
index d94360226fc99bca89e01a6b40f0fbb498c4dd64..87fa19e47500232dc4229fc67e64fae35f52c830 100644
--- a/test/unison/state.ml
+++ b/test/unison/state.ml
@@ -5,3 +5,4 @@ let of_string = None
let copy x = x
let actions = ["g"]
let potential = None
+let fault = None