Commit 81eff104 authored by erwan's avatar erwan
Browse files

New: add support for daemons that use potential fonction to find worst case scenario.

nb: I needed to  split Main to avoid a Module self-loop  (as I need to
use do_step in Daemon).
parent aaaa14ee
Pipeline #46334 failed with stages
in 2 minutes and 17 seconds
(* Time-stamp: <modified the 06/03/2020 (at 10:20) by Erwan Jahier> *)
(* Time-stamp: <modified the 29/06/2020 (at 10:44) by Erwan Jahier> *)
open Sasacore
(* Process programmer API *)
......@@ -41,6 +41,10 @@ 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 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
type 's algo_to_register = {
algo_id: string;
init_state: 's state_init_fun;
......@@ -52,7 +56,8 @@ type 's to_register = {
state_to_string: 's -> string;
state_of_string: (string -> 's) option;
copy_state: 's -> 's;
actions: action list
actions: action list;
potential_function: 's potential_fun option
}
let (to_reg_neigbor : 's Register.neighbor -> 's neighbor) =
......@@ -65,6 +70,16 @@ let (to_reg_neigbor : 's Register.neighbor -> 's neighbor) =
weight = n.Register.weight;
}
let (to_reg_info : 's Register.pf_info -> 's pf_info) =
fun pfi ->
{
neighbors = pfi.Register.neighbors ;
curr = pfi.Register.curr ;
next = pfi.Register.next ;
action = pfi.Register.action
}
let (to_reg_enable_fun : 's enable_fun ->
's Register.neighbor list -> 's -> action list) =
fun f nl s ->
......@@ -75,6 +90,11 @@ let (to_reg_step_fun : 's step_fun ->
fun f nl s a ->
f s (List.map to_reg_neigbor nl) a
let (to_reg_potential_fun :
's potential_fun -> pid list -> (pid -> 's Register.pf_info) -> float) =
fun pf pidl f ->
let nf pid = to_reg_info (f pid) in
pf pidl nf
let (register1 : 's algo_to_register -> unit) =
fun s ->
......@@ -94,11 +114,13 @@ let (register : 's to_register -> unit) =
List.iter register1 s.algo;
(match s.state_of_string with None -> () | Some f -> Register.reg_value_of_string f);
Register.reg_actions s.actions;
(match s.potential_function with
| None -> ()
| Some pf -> Register.reg_potential (Some (to_reg_potential_fun pf))
);
()
let card = Register.card
let get_graph_attribute = Register.get_graph_attribute
let min_degree = Register.min_degree
let mean_degree = Register.mean_degree
......
(* Time-stamp: <modified the 18/06/2020 (at 15:34) by Erwan Jahier> *)
(* Time-stamp: <modified the 01/07/2020 (at 15:26) by Erwan Jahier> *)
(** {1 The Algorithm programming Interface.} *)
(**
{1 What's need to be provided by users.}
......@@ -79,6 +79,15 @@ val diameter : unit -> int
val get_graph_attribute : string -> string
(** {1 Potential function }
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
......@@ -95,7 +104,8 @@ type 's to_register = {
state_to_string: 's -> string;
state_of_string: (string -> 's) option;
copy_state: 's -> 's;
actions : action list (** Mandatory in custom daemon mode, or to use oracles *)
actions : action list (** Mandatory in custom daemon mode, or to use oracles *);
potential_function: 's potential_fun option (** Mandatory with Evil daemons *)
}
(** - 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
......
......@@ -74,11 +74,11 @@ let (make_do: string array -> SasArg.t ->
| 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 > 1) args.daemon pl pre_pnall pre_enab_ll
(args.verbose > 1) args.daemon pl e pre_pnall pre_enab_ll
(get_action_value sl_in)
in
(* 3: Do the steps *)
let ne = Sasacore.Main.do_step pnal e in
let ne = Sasacore.Step.f pnal e in
let sasa_nenv = from_sasa_env pl_n ne in
(* 1': Get enable processes *)
let pnall, enab_ll = Sasacore.Main.get_enable_processes pl_n ne in
......@@ -94,11 +94,11 @@ let (make_do: string array -> SasArg.t ->
let pnall, enab_ll = Sasacore.Main.get_enable_processes pl_n e in
(* 2: read the actions from the outside process, i.e., from sl_in *)
let activate_val, pnal = Daemon.f args.dummy_input
(args.verbose > 1) args.daemon pl pnall enab_ll
(args.verbose > 1) args.daemon pl e pnall enab_ll
(get_action_value sl_in)
in
(* 3: Do the steps *)
let ne = Sasacore.Main.do_step pnal e in
let ne = Sasacore.Step.f pnal e in
sasa_env := ne;
(from_sasa_env pl_n e) @ (get_sl_out true pl enab_ll) @
(get_sl_out false pl activate_val)
......
(* Time-stamp: <modified the 06/03/2020 (at 10:03) by Erwan Jahier> *)
(* Time-stamp: <modified the 01/07/2020 (at 11:14) by Erwan Jahier> *)
type t =
| Synchronous (* select all actions *)
......@@ -6,7 +6,12 @@ type t =
| LocallyCentral (* never activates two neighbors actions in the same step *)
| Distributed (* select at least one action *)
| Custom
| Worst (* always choose the set of actions that maximize the potential function *)
| Bad of int (* try to choose the set actions that maximize the
potential function but looking at sub-graphs of size
N at max *)
(* Enabled processes (with its enabling action + neighbors) *)
type 'v pna = 'v Process.t * 'v Register.neighbor list * Register.action
let (random_list : 'a list -> 'a) = fun l ->
......@@ -100,6 +105,8 @@ let (custom: 'v pna list list -> 'v Process.t list -> bool list list ->
let acti = List.map (List.map fst) acti_l_all in
acti, List.flatten al
let (remove_empty_list: 'a list list -> 'a list list) =
fun ll ->
List.filter (fun l -> l<>[]) ll
......@@ -112,10 +119,9 @@ let (get_activate_val: 'v pna list -> 'v Process.t list -> bool list list)=
let al = List.map (fun (p,_,a) -> p,a) al in
List.map (List.map (fun a -> List.mem a al)) actions
let (f: bool -> bool -> t -> 'v Process.t list -> 'v pna list list -> bool list list ->
let (f: bool -> bool -> t -> 'v Process.t list -> 'v Env.t -> 'v pna list list -> bool list list ->
(string -> string -> bool) -> bool list list * 'v pna list) =
fun dummy_input verbose_mode daemon pl all enab get_action_value ->
fun dummy_input verbose_mode daemon pl e all enab get_action_value ->
if daemon <> Custom && dummy_input then
ignore (RifRead.bool verbose_mode ((List.hd pl).pid) "");
match daemon with
......@@ -131,4 +137,10 @@ let (f: bool -> bool -> t -> 'v Process.t list -> 'v pna list list -> bool list
| Distributed ->
let al = distributed (remove_empty_list all) in
get_activate_val al pl, al
| Worst ->
let al = Evil.worst e (remove_empty_list all) in
get_activate_val al pl, al
| Bad i ->
let al = Evil.bad i e (remove_empty_list all) in
get_activate_val al pl, al
| Custom -> custom all pl enab get_action_value
(* Time-stamp: <modified the 22/01/2020 (at 09:56) by Erwan Jahier> *)
(* Time-stamp: <modified the 29/06/2020 (at 10:51) by Erwan Jahier> *)
type t =
| Synchronous (* select all actions *)
......@@ -6,6 +6,10 @@ type t =
| 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 *)
| Worst (* always choose the set that maximize the potential function *)
| Bad of int (* try to choose the set actions that maximize the
potential function but looking at sub-graphs of
size N at max *)
(* [1] nb: the current implementation of locally central daemon is
biased by the degree of nodes. *)
......@@ -19,12 +23,12 @@ inputs:
- dummy_input_flag: true when used with --ignore-first-inputs
- verbose_mode: true when the verbose level is > 0
- daemon:
- pl:
- pl: list of all processes
- actions_ll: list of list of existing actions
- enab_ll: list of list of enabled actions
- enab: list of list saying which actions are enabled
At the inner list level, exactly one action ougth to be chosen. At the
outter list level, the number of chosen actions depends on the kind
At the inner list level, exactly one action ought to be chosen. At the
outer list level, the number of chosen actions depends on the kind
of daemons.
In custom mode, as a side-effect, read on stdin which actions should be activated.
......@@ -39,6 +43,6 @@ nb: it is possible that we read on stdin that an action should be
inhibit the activation.
*)
val f : bool -> bool -> t -> 'v Process.t list -> 'v pna list list -> bool list list ->
val f : bool -> bool -> t -> 'v Process.t list -> 'v Env.t -> 'v pna list list -> bool list list ->
(string -> string -> bool) -> bool list list * 'v pna list
(* Time-stamp: <modified the 01/07/2020 (at 14:38) by Erwan Jahier> *)
type 'v pna = 'v Process.t * 'v Register.neighbor list * Register.action
(* Enumerate all schedules using continuations *)
type 'a cont = NoMore | Elt of 'a * (unit -> 'a cont)
(* compose continuations *)
let rec (comp : 'a cont -> 'a cont -> 'a cont) =
fun c1 c2 ->
match c1 with
| NoMore -> c2
| Elt(x, c1) -> Elt(x, fun () -> comp (c1()) c2)
(* Enumerate all possible schedules (with one action per process at most)
nb: it can be a lot!
*)
let (enumerate : 'a list list -> 'a list cont) = fun all ->
let rec f acc all =
let res = match all with
| [] -> Elt(acc, fun () -> NoMore)
| []::tl -> f acc tl
| al::tl ->
List.fold_left
(fun cont_acc a ->
let cont_a = f (a::acc) tl in
comp cont_a cont_acc
)
(f acc tl)
al
in
res
in
f [] all
module StringMap = Map.Make(String)
module StringSet = Set.Make(String)
(* split [all] into connected components *)
let (connected_components : 'v pna list list -> 'v pna list list list) =
fun all ->
let pid2pnal =
List.fold_left
(fun acc al ->
match al with
| [] -> acc
| (p,_,_)::_ -> StringMap.add p.Process.pid al acc)
StringMap.empty
all
in
let get_neighors = function
| [] -> assert false
| (_,nl,_)::_ -> nl
in
let rec f marked acc all =
match all with
| [] -> acc
| []::tl -> f marked acc tl
| ((p,nl,_a)::_)::tl ->
if StringSet.mem p.Process.pid marked then
f marked acc tl
else
let marked = StringSet.add p.Process.pid marked in
let marked, component = g marked nl [p.Process.pid] in
let component = List.map (fun pid -> StringMap.find pid pid2pnal) component in
f marked (component::acc) tl
and g marked nl acc =
match nl with
| [] -> marked, acc
| n::nl ->
if StringSet.mem n.Register.pid marked then
g marked nl acc
else
let marked = StringSet.add n.Register.pid marked in
if StringMap.mem n.Register.pid pid2pnal then
let n_nl = get_neighors (StringMap.find n.Register.pid pid2pnal) in
g marked (List.rev_append n_nl nl) (n.Register.pid::acc)
else
(* not all neighbors are enabled !*)
g marked nl acc
in
f StringSet.empty [] all
let time lbl f x =
let t = Sys.time() in
let fx = f x in
Printf.printf " --> [%s] Execution time: %fs\n" lbl (Sys.time() -. t);
fx
let time2 lbl f x y =
let t = Sys.time() in
let fxy = f x y in
Printf.printf " --> [%s] Execution time: %fs\n" lbl (Sys.time() -. t);
fxy
let _time3 lbl f x y z =
let t = Sys.time() in
let fxy = f x y z in
Printf.printf " --> [%s] Execution time: %fs\n" lbl (Sys.time() -. t);
fxy
let (worst: 'v Env.t -> 'v pna list list -> 'v pna list) =
fun e all ->
match Register.get_potential () with
| None -> failwith "No potential function has been provided"
| Some user_pf ->
let rec action_of_pid pid = function
| [] -> assert false
| (p,_,a)::tail -> if p.Process.pid = pid then a else action_of_pid pid tail
in
let pf pnal =
let pidl = List.map (fun (p,_,_) -> p.Process.pid) pnal in
let ne = Step.f pnal e in
let get_info pid =
{
Register.neighbors = pidl ;
Register.curr = Env.get e pid ;
Register.next = Env.get ne pid ;
Register.action = action_of_pid pid pnal
}
in
user_pf pidl get_info
in
let alll = time "connected component" connected_components all in
let cpt = ref 0 in
let res_l =
List.map
(fun all ->
let pnal1, p1, shedules =
match time "enumerate" enumerate all with
| NoMore -> assert false
| Elt(pnal, c) -> pnal, pf pnal, c
in
let rec search_max (pnal_acc, v_acc) shedules =
match shedules with
| NoMore -> (pnal_acc, v_acc)
| Elt(pnal, c) ->
incr cpt;
let v = pf pnal in
if v < v_acc
then search_max (pnal_acc, v_acc) (c())
else search_max (pnal, v) (c())
in
fst (time2 "search" search_max (pnal1, p1) (shedules()))
)
alll
in
Printf.printf "Number of connected components: %i (%i)\n%!" (List.length alll) !cpt;
List.flatten res_l
(* exported *)
let (bad: int -> 'v Env.t -> 'v pna list list -> 'v pna list) =
fun _max_size _e _all ->
assert false (* todo *)
(* exported *)
let (worst4convex: 'v Env.t -> 'v pna list list -> 'v pna list) =
fun _e _all ->
assert false (* todo *)
(* Time-stamp: <modified the 01/07/2020 (at 14:44) by Erwan Jahier> *)
(** This module gathers daemons that tries to reach the worst case with
a potential function using various heuristic. *)
type 'v pna = 'v Process.t * 'v Register.neighbor list * Register.action
(** Enumerate all the combinations (O(2^n) where n is the number of
enabled processes) *)
val worst: 'v Env.t -> 'v pna list list -> 'v pna list
(** Returns the worst solution for convex potential functions, and
just a bad one otherwise (O(n) where n is the number of enabled
processes). *)
val worst4convex: 'v Env.t -> 'v pna list list -> 'v pna list
(** enumerate all the cases in sub-graphs of given size (O(2^size_max)) *)
val bad: int -> 'v Env.t -> 'v pna list list -> 'v pna list
......@@ -48,10 +48,11 @@ let (f: string list -> string * string -> unit) =
state_of_string = %s.of_string;
copy_state = %s.copy;
actions = %s.actions;
potential_function = %s.potential;
}
"
(String.concat ";" l)
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;
......@@ -67,6 +68,7 @@ let (f: string list -> string * string -> unit) =
let to_string _ = \"define_me\"
let of_string = None
let copy x = x
let potential = None
";
flush oc;
close_out oc;
......
(* Time-stamp: <modified the 12/03/2020 (at 16:55) by Erwan Jahier> *)
(* Time-stamp: <modified the 29/06/2020 (at 17:33) by Erwan Jahier> *)
open Register
......@@ -47,16 +47,12 @@ let (dump_process: 'v Process.t * 'v Register.neighbor list -> unit) =
open Process
let (update_env: 'v Env.t -> 'v Process.t * 'v -> 'v Env.t) =
fun e (p, st) ->
Env.set e p.pid st
open SasArg
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 }
type 'v layout = ('v Process.t * 'v Register.neighbor list) list
type 'v enable_processes =
......@@ -85,20 +81,8 @@ let (get_enable_processes: 'v layout -> 'v Env.t -> 'v enable_processes) =
in
all, enab_ll
let (do_step : ('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
let lenv = Env.get_copy e p.pid in
p, p.step nl lenv a)
pnal
in
(* 4: update the env *)
let ne = List.fold_left update_env e lenv_list in
ne
open SasArg
type 'v t = SasArg.t * 'v layout * 'v Env.t
......@@ -117,7 +101,7 @@ let (get_inputs_rif_decl: SasArg.t -> 'v Process.t list -> (string * string) lis
let (get_outputs_rif_decl: SasArg.t -> 'v Process.t list -> (string * string) list) =
fun args pl ->
(* This fonction may be called on huge lists: thus it must remains
(* This fonction may be called on huge lists: thus it must remain
tail-recursive and linear! *)
let pl = List.rev pl in
let vars = [] in
......
(* Time-stamp: <modified the 07/10/2019 (at 16:13) by Erwan Jahier> *)
(* Time-stamp: <modified the 29/06/2020 (at 17:28) by Erwan Jahier> *)
(* XXX find a better name *)
......@@ -13,8 +13,6 @@ type 'v enable_processes =
val get_enable_processes: 'v layout -> 'v Env.t -> 'v enable_processes
val do_step : ('v Process.t * 'v Register.neighbor list * Register.action) list -> 'v Env.t
-> 'v Env.t
val get_inputs_rif_decl : SasArg.t -> 'v Process.t list -> (string * string) list
val get_outputs_rif_decl: SasArg.t -> 'v Process.t list -> (string * string) list
(* Time-stamp: <modified the 06/03/2020 (at 10:20) by Erwan Jahier> *)
(* Time-stamp: <modified the 29/06/2020 (at 10:17) by Erwan Jahier> *)
type 's neighbor = {
state: 's ;
......@@ -13,6 +13,10 @@ type action = string
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 pf_info = { neighbors : pid list ; curr : 's ; next : 's ; action:action }
type 's potential_fun = pid list -> (pid -> 's pf_info) -> float
type 's internal_tables = {
init_state: (string, Obj.t) Hashtbl.t;
enable : (string, Obj.t) Hashtbl.t;
......@@ -21,6 +25,7 @@ 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 potential: Obj.t;
mutable actions:action list;
mutable card : int ;
mutable min_deg : int;
......@@ -55,6 +60,7 @@ let (tbls:'s internal_tables) = {
value_of_string = Hashtbl.create 1;
copy_value = Hashtbl.create 1;
graph_attributes = Hashtbl.create 1;
potential = (Obj.repr None);
actions = [];
card = (-1);
min_deg = (-1);
......@@ -120,6 +126,13 @@ let (get_step : algo_id -> 's step_fun) = fun algo_id ->
print_table "step" tbls.step;
raise (Unregistred ("step", algo_id))
let (reg_potential : 's potential_fun option -> unit) = fun x ->
if !verbose_level > 0 then Printf.eprintf "Registering potential\n%!";
tbls.potential <- (Obj.repr x)
let (get_potential : unit -> 's potential_fun option) = fun () ->
Obj.obj tbls.potential
let (reg_actions : action list -> unit) =
fun x ->
if !verbose_level > 0 then Printf.eprintf "Registering actions\n%!";
......
(* Time-stamp: <modified the 09/03/2020 (at 14:19) by Erwan Jahier> *)
(* Time-stamp: <modified the 29/06/2020 (at 10:18) by Erwan Jahier> *)
(** This module duplicates and extends the Algo module with get_*
functions.
......@@ -21,10 +21,14 @@ type action = string
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 pf_info = { neighbors : pid list ; curr : 's ; next : 's ; action:action }
type 's potential_fun = pid list -> (pid -> 's pf_info) -> float
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_actions : action list -> unit
val reg_value_to_string : ('s -> string) -> unit
val reg_value_of_string : (string -> 's) -> unit
......@@ -58,6 +62,7 @@ val get_enable : algo_id -> 's enable_fun
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_value_to_string : unit -> 's -> string
val get_value_of_string : unit -> (string -> 's) option
val get_copy_value : unit -> ('s -> 's)
......
(* Time-stamp: <modified the 27/02/2020 (at 14:47) by Erwan Jahier> *)
(* Time-stamp: <modified the 25/06/2020 (at 14:57) by Erwan Jahier> *)
type t = {
......@@ -171,6 +171,15 @@ let (mkoptab : string array -> t -> unit) =
(Arg.Unit(fun () -> args.daemon <- Daemon.Custom;args.rif <- true))
["Use a Custom daemon (forces --rif)"];
mkopt args ["--worst-daemon";"-wd"]
(Arg.Unit(fun () -> args.daemon <- Daemon.Worst))
["Use the daemon that maximizes the potential function"];
mkopt args ["--bad-daemon";"-bd"] ~arg:" <int>"
(Arg.Int (fun i -> args.daemon <- Daemon.Bad i))
["Use a daemon that tries to maximize the potential function, ";
"considering sub-graphs of a given maximal size"];
mkopt args ~hide:true ["--rif";"-rif"]
(Arg.Unit(fun () -> args.rif <- true))
["Display only outputs on stdout (i.e., behave as a rif input file)"];
......
......@@ -66,7 +66,7 @@ let (simustep: int -> int -> SasArg.t -> string ->
(* 2: read the actions *)
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 pl all enab_ll get_action_value
(args.verbose > 1) args.daemon pl e all enab_ll get_action_value
in
update_round next_activate_val enab_ll;
let next_activate_val =
......@@ -77,7 +77,7 @@ let (simustep: int -> int -> SasArg.t -> string ->
)