Commit cd8e0e37 authored by erwan's avatar erwan
Browse files

New: add a fault functions to the Algo (to inject fault when a legitimate...

New: add a fault functions to the Algo (to inject fault when a legitimate configuratiuon is reached).
parent 1a8985b6
(* 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
......
(* 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
......
......@@ -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;
......
(* 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%!";
......
(* 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)
......
......@@ -5,3 +5,4 @@ let of_string = None
let copy = fun x -> x
let actions = ["C1";"C2"]
let potential = None
let fault = None
......@@ -5,3 +5,4 @@ let of_string = Some int_of_string
let copy x = x
let actions = ["a"]
let potential = None
let fault = None
......@@ -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
......@@ -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
......@@ -18,3 +18,4 @@ let (copy : ('v -> 'v)) = fun x -> x
let actions = ["CD";"CP"]
let potential = None
let fault = None
......@@ -19,3 +19,4 @@ let print_neighbor =
let actions = ["R0";"R1"]
let potential = None
let fault = None
......@@ -17,5 +17,5 @@ let pf pidl get =
pidl;
float_of_int !clash
let potential = Some pf
let fault = None
......@@ -21,3 +21,4 @@ let of_string = None
let copy x = x
let actions = ["update_path";"compute_parent"]
let potential = None
let fault = None
......@@ -28,3 +28,4 @@ let (copy : t -> t) =
let of_string = None
let actions = ["update_path";"compute_parent"]
let potential = None
let fault = None
......@@ -5,3 +5,4 @@ let of_string = None
let copy x = x
let actions = ["T"]
let potential = None
let fault = None
......@@ -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
......@@ -19,3 +19,4 @@ let print_neighbor =
let actions = ["R0";"R1";"R2"]
let potential = None
let fault = None
......@@ -5,3 +5,4 @@ let of_string = Some int_of_string
let copy x = x
let actions = ["R"]
let potential = None
let fault = None
......@@ -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
......@@ -5,3 +5,4 @@ let of_string = None
let copy x = x
let actions = ["g"]
let potential = None
let fault = None
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment