Commit 2e5b8b6f authored by erwan's avatar erwan
Browse files

Update: try to take advantage of polymorphism to handle algo values

But I bumped into the "value restriction" limitation
https://stackoverflow.com/questions/22507448/the-value-restriction

Indeed, I need to store functions of 'v in some tables (or references),

And tables are necessaryly weakly polymorphic !

https://v1.realworldocaml.org/v1/en/html/imperative-programming-1.html#side-effects-and-weak-polymorphism
parent fd6d4d2d
(* Time-stamp: <modified the 11/06/2019 (at 15:59) by Erwan Jahier> *)
(* Time-stamp: <modified the 12/06/2019 (at 11:12) by Erwan Jahier> *)
(** Process programmer API *)
type varT = It | Ft | Bt | Et of int | St | Nt | At of varT * int
type varT = string
type action = string (* just a label *)
type value = I of int | F of float | B of bool | E of int | S of string | N of int
| A of value array
type local_env = string -> value
(*
type value = I of int | F of float | B of bool | E of int | S of string | N of int
| A of value array *)
type 'v local_env = string -> 'v
type vars = (string * varT) list
type neighbor = {
lenv: local_env;
type 'v neighbor = {
lenv: 'v local_env;
n_vars: vars;
pid: unit -> string;
reply: unit -> int;
}
type enable_fun = neighbor list -> local_env -> action list
type step_fun = neighbor list -> local_env -> action -> local_env
type 'v enable_fun = 'v neighbor list -> 'v local_env -> action list
type 'v step_fun = 'v neighbor list -> 'v local_env -> action -> 'v local_env
type internal_tables = {
type 'v internal_tables = {
vars : (string, vars) Hashtbl.t;
init_vars: (string, neighbor list -> local_env) Hashtbl.t;
enable : (string, enable_fun) Hashtbl.t;
step : (string, step_fun) Hashtbl.t;
init_vars: (string, 'v neighbor list -> 'v local_env) Hashtbl.t;
enable : (string, 'v enable_fun) Hashtbl.t;
step : (string, 'v step_fun) Hashtbl.t;
actions : (string, action list) Hashtbl.t;
value_to_string : (string, ('v -> string)) Hashtbl.t;
value_to_data : (string, ('v -> Data.t)) Hashtbl.t;
copy_value : (string, ('v -> 'v)) Hashtbl.t;
mutable card : int
}
let tbls = {
let (tbls:'v internal_tables) = {
vars = Hashtbl.create 1;
init_vars = Hashtbl.create 1;
enable = Hashtbl.create 1;
step = Hashtbl.create 1;
actions = Hashtbl.create 1;
value_to_string = Hashtbl.create 1;
value_to_data = Hashtbl.create 1;
copy_value = Hashtbl.create 1;
card = (-1)
}
let (empty_env: local_env) =
let (empty_env: 'v local_env) =
function _ -> failwith "Empty local env"
let (set : local_env -> string -> value -> local_env) =
let (set : 'v local_env -> string -> 'v -> 'v local_env) =
fun lenv vn vv vn2 ->
if vn=vn2 then vv else lenv vn2
let (get : local_env -> string -> value) =
let (get : 'v local_env -> string -> 'v) =
fun lenv vn ->
lenv vn
let verbose_level = ref 0
let (vart_to_rif_decl: varT -> string -> (string * string) list) =
fun v base ->
match v with
fun v base -> [base,v]
(*
match v with
| It -> [base, "int"]
| Ft -> [base, "real"]
| Bt -> [base, "bool"]
......@@ -78,7 +87,7 @@ let (vart_to_rif_decl: varT -> string -> (string * string) list) =
in
let base_list, tstr = do_array base v in
List.map (fun base -> base, tstr) base_list
*)
let vart_to_rif_string =
fun v base ->
......@@ -86,7 +95,7 @@ let vart_to_rif_string =
String.concat " "
(List.map (fun (base, tstr) -> Printf.sprintf "\"%s\":%s" base tstr) ssl)
(*
let rec value_to_string = function
| I i
| E i
......@@ -103,32 +112,31 @@ let rec (copy_value : value -> value) =
match v with
| I _ | F _ | B _ | E _ | S _ | N _ -> v
| A a -> A (Array.copy (Array.map copy_value a))
let (copy_local_env: vars -> local_env -> local_env) =
fun vars lenv ->
*)
let (copy_local_env: ('v -> 'v) -> vars -> 'v local_env -> 'v local_env) =
fun copy_value vars lenv ->
List.fold_left
(fun acc (n,_) -> (fun str -> if str = n then copy_value (lenv n) else acc str))
(fun _ -> failwith "empty local env")
vars
let (string_of_local_env : vars -> local_env -> string) =
fun vars lenv ->
let (string_of_local_env : ('v -> string) -> vars -> 'v local_env -> string) =
fun value_to_string vars lenv ->
List.fold_left
(fun acc (n,_) -> acc^(Printf.sprintf "%s=%s " n (value_to_string (lenv n))))
""
vars
let (rif_of_local_env : vars -> local_env -> string) =
fun vars lenv ->
let (rif_of_local_env : ('v -> string) -> vars -> 'v local_env -> string) =
fun value_to_string vars lenv ->
List.fold_left
(fun acc (n,_) -> acc^(Printf.sprintf "%s " (value_to_string (lenv n))))
""
vars
let (sl_of_local_env : vars -> string -> local_env -> (string * value) list) =
let (sl_of_local_env : vars -> string -> 'v local_env -> (string * 'v) list) =
fun vars pid lenv ->
List.map
(fun (vn,_) -> (Printf.sprintf "%s_%s" pid vn, (lenv vn)))
......@@ -152,36 +160,22 @@ let (reg_vars : algo_id -> (string * varT) list -> unit) =
let (get_vars : string -> (string * varT) list) = fun algo_id ->
try Hashtbl.find tbls.vars algo_id
with Not_found ->
print_table "vars" tbls.vars;
(* print_table "vars" tbls.vars; *)
raise (Unregistred ("variable", algo_id))
let rec (init_var: neighbor list -> varT -> value) =
fun nl -> function
| Nt ->
assert (nl <> []);
N (try Random.int ((List.length nl)) with _ -> assert false)
| It -> I (Random.int 100000)
| Bt -> B (Random.bool ())
| Ft -> F (Random.float max_float)
| Et i -> I (Random.int i)
| St -> S "dummy"
| At(t,i) -> A(Array.make i (init_var nl t))
let (reg_init_vars : algo_id -> (neighbor list -> local_env) -> unit) =
let (reg_init_vars : algo_id -> ('v neighbor list -> 'v local_env) -> unit) =
fun algo_id x ->
if !verbose_level > 0 then Printf.printf "Registering %s init_vars\n" algo_id;
flush stdout;
Hashtbl.replace tbls.init_vars algo_id x
let (get_init_vars : algo_id -> (string * varT) list -> neighbor list -> local_env) =
let (get_init_vars :
algo_id -> (string * varT) list -> 'v neighbor list -> 'v local_env) =
fun algo_id vars nl ->
let lenv =
let default_env v =
match List.find_opt (fun (x,_t) -> x=v) vars with
None -> failwith (v^" unknown var")
| Some v -> init_var nl (snd v)
failwith (v^" is not initialized (neither in the algo nor in the dot files)")
in
try
let user_env = Hashtbl.find tbls.init_vars algo_id in
......@@ -190,7 +184,8 @@ let (get_init_vars : algo_id -> (string * varT) list -> neighbor list -> local_e
with e ->
if !verbose_level > 1 then
Printf.eprintf
"No init value for '%s' in user init function (%s).\n" v
"No init value for '%s' in user init function (%s).\n"
v
(Printexc.to_string e);
default_env v)
with Not_found ->
......@@ -209,22 +204,22 @@ let (get_init_vars : algo_id -> (string * varT) list -> neighbor list -> local_e
lenv
let (reg_enable : algo_id -> enable_fun -> unit) = fun algo_id x ->
if !verbose_level > 0 then Printf.printf "Registering %s enable\n" algo_id;
flush stdout;
Hashtbl.replace tbls.enable algo_id x
let (get_enable : algo_id -> enable_fun) = fun algo_id ->
try Hashtbl.find tbls.enable algo_id
let (reg_enable : algo_id -> 'v enable_fun -> unit) = fun algo_id x ->
if !verbose_level > 0 then Printf.printf "Registering %s enable\n" algo_id;
flush stdout;
Hashtbl.replace tbls.enable algo_id x
let (get_enable : algo_id -> 'v enable_fun) = fun algo_id ->
try Hashtbl.find tbls.enable algo_id
with Not_found ->
print_table "enable" tbls.enable;
raise (Unregistred ("enable", algo_id))
let (reg_step : algo_id -> step_fun -> unit) = fun algo_id x ->
let (reg_step : algo_id -> 'v step_fun -> unit) = fun algo_id x ->
if !verbose_level > 0 then Printf.printf "Registering %s step\n" algo_id;
flush stdout;
Hashtbl.replace tbls.step algo_id x
let (get_step : algo_id -> step_fun) = fun algo_id ->
let (get_step : algo_id -> 'v step_fun) = fun algo_id ->
try Hashtbl.find tbls.step algo_id
with Not_found ->
print_table "step" tbls.step;
......@@ -241,6 +236,40 @@ let (get_actions : algo_id -> action list) = fun algo_id ->
print_table "actions" tbls.actions;
raise (Unregistred ("actions", algo_id))
let (reg_value_to_string : ('v -> string) -> unit) =
fun f ->
if !verbose_level > 0 then Printf.printf "Registering value_to_string\n";
flush stdout;
Hashtbl.replace tbls.value_to_string "_global" f
let (get_value_to_string : unit -> ('v -> string)) = fun () ->
try Hashtbl.find tbls.value_to_string "_global"
with Not_found ->
print_table "value_to_string" tbls.value_to_string;
raise (Unregistred ("value_to_string", "_global"))
let (reg_value_to_data : ('v -> Data.t) -> unit) =
fun f ->
if !verbose_level > 0 then Printf.printf "Registering value_to_data\n";
flush stdout;
Hashtbl.replace tbls.value_to_data "_global" f
let (get_value_to_data : unit -> ('v -> Data.t)) = fun () ->
try Hashtbl.find tbls.value_to_data "_global"
with Not_found ->
print_table "value_to_data" tbls.value_to_data;
raise (Unregistred ("value_to_data", "_global"))
let (reg_copy_value : ('v -> 'v) -> unit) =
fun f ->
if !verbose_level > 0 then Printf.printf "Registering copy_value\n";
flush stdout;
Hashtbl.replace tbls.copy_value "_global" f
let (get_copy_value : unit -> ('v -> 'v)) = fun () ->
try Hashtbl.find tbls.copy_value "_global"
with Not_found ->
print_table "copy_value" tbls.copy_value;
raise (Unregistred ("copy_value", "_global"))
(* exported *)
......
(* Time-stamp: <modified the 11/06/2019 (at 17:00) by Erwan Jahier> *)
(* Time-stamp: <modified the 12/06/2019 (at 09:54) by Erwan Jahier> *)
(** Process programmer API *)
type value = I of int | F of float | B of bool | E of int | S of string
| N of int (* neighbor channel number *)
| A of value array
(* val copy_value : value -> value *)
type local_env
type 'v local_env
val empty_env: local_env
val set : local_env -> string -> value -> local_env
val get : local_env -> string -> value
val empty_env: 'v local_env
val set : 'v local_env -> string -> 'v -> 'v local_env
val get : 'v local_env -> string -> 'v
(** Types of value *)
type varT = It | Ft | Bt (* int, float, bool *)
| Et of int (* enum *)
| St (* string *)
| Nt (* neighbor channel *)
| At of varT * int (* array *)
type varT = string
type vars = (string * varT) list
type neighbor = {
lenv: local_env;
type 'v neighbor = {
lenv: 'v local_env;
n_vars: vars;
pid: unit -> string; (* Returns the pid of the neigbhor. This info
is not available in all modes (e.g.,
......@@ -37,28 +29,29 @@ type neighbor = {
}
type action = string (* label *)
type enable_fun = neighbor list -> local_env -> action list
type step_fun = neighbor list -> local_env -> action -> local_env
type 'v enable_fun = 'v neighbor list -> 'v local_env -> action list
type 'v step_fun = 'v neighbor list -> 'v local_env -> action -> 'v local_env
(** Those 3 registering functions must be called! *)
type algo_id = string
val reg_vars : algo_id -> vars -> unit
val reg_enable : algo_id -> enable_fun -> unit
val reg_step : algo_id -> step_fun -> unit
val reg_enable : algo_id -> 'v enable_fun -> unit
val reg_step : algo_id -> 'v step_fun -> unit
(** raised by sasa if one of the function above is not called *)
exception Unregistred of string * string
(** This one is not mandatory. The initialisation done in the dot
file have priority over this one. *)
val reg_init_vars : algo_id -> (neighbor list -> local_env) -> unit
val reg_init_vars : algo_id -> ('v neighbor list -> 'v local_env) -> unit
(** Mandatory in custom mode only. *)
val reg_actions : algo_id -> action list -> unit
val reg_value_to_string : ('v -> string) -> unit
val reg_value_to_data : ('v -> Data.t) -> unit
val reg_copy_value : ('v -> 'v) -> unit
(** util(s) *)
val value_to_string : value -> string
(** Global infos *)
val card : unit -> int
......@@ -68,10 +61,10 @@ val card : unit -> int
(**/**)
(** functions below are not part of the API *)
val copy_local_env : vars -> local_env -> local_env
val string_of_local_env : vars -> local_env -> string
val rif_of_local_env : vars -> local_env -> string
val sl_of_local_env : vars -> string -> local_env -> (string * value) list
val copy_local_env : vars -> 'v local_env -> 'v local_env
val string_of_local_env : vars -> 'v local_env -> string
val rif_of_local_env : vars -> 'v local_env -> string
val sl_of_local_env : vars -> string -> 'v local_env -> (string * 'v) list
val vart_to_rif_decl: varT -> string -> (string * string) list
......@@ -83,8 +76,11 @@ val set_card : int -> unit
(** the following functions are used by sasa *)
val get_vars : algo_id -> vars
val get_enable : algo_id -> enable_fun
val get_step : algo_id -> step_fun
val get_init_vars : algo_id -> (string * varT) list -> neighbor list -> local_env
val get_enable : algo_id -> 'v enable_fun
val get_step : algo_id -> 'v step_fun
val get_init_vars : algo_id -> (string * varT) list -> 'v neighbor list -> 'v local_env
val get_actions : algo_id -> action list
val get_value_to_string : unit -> ('v -> string)
val get_value_to_data : unit -> ('v -> Data.v)
val get_copy_value : unit -> ('v -> 'v)
;; Time-stamp: <modified the 11/06/2019 (at 10:59) by Erwan Jahier>
;; Time-stamp: <modified the 12/06/2019 (at 09:53) by Erwan Jahier>
(library
(name algo)
(public_name algo)
(libraries lutils)
(synopsis "The Sasa Algo API")
)
......
(* Time-stamp: <modified the 14/05/2019 (at 10:18) by Erwan Jahier> *)
(* Time-stamp: <modified the 12/06/2019 (at 08:05) by Erwan Jahier> *)
type t =
| Synchronous (* select all actions *)
......@@ -39,10 +39,10 @@ let rec map3 f l1 l2 l3 =
| (_, [], _) -> invalid_arg "map3 (2nd arg too short)"
| (_, _, []) -> invalid_arg "map3 (3rd arg too short)"
type pna = Process.t * Algo.neighbor list * Algo.action
type 'v pna = 'v Process.t * 'v Algo.neighbor list * Algo.action
let (custom: pna list list -> Process.t list -> bool list list ->
(string -> string -> bool) -> bool list list * pna list) =
let (custom: 'v pna list list -> 'v Process.t list -> bool list list ->
(string -> string -> bool) -> bool list list * 'v pna list) =
fun pnall pl enab_ll get_action_value ->
let f p pnal enab_l =
let actions = p.Process.actions in
......@@ -68,7 +68,7 @@ let (remove_empty_list: 'a list list -> 'a list list) =
fun ll ->
List.filter (fun l -> l<>[]) ll
let (get_activate_val: pna list -> Process.t list -> bool list list)=
let (get_activate_val: 'v pna list -> 'v Process.t list -> bool list list)=
fun al pl ->
let actions =
List.map (fun p -> List.map (fun a -> p,a) p.Process.actions) pl
......@@ -77,8 +77,8 @@ let (get_activate_val: pna list -> Process.t list -> bool list list)=
List.map (List.map (fun a -> List.mem a al)) actions
let (f: bool -> bool -> t -> Process.t list -> pna list list -> bool list list ->
(string -> string -> bool) -> bool list list * pna list) =
let (f: bool -> bool -> t -> 'v Process.t list -> 'v pna list list -> bool list list ->
(string -> string -> bool) -> bool list list * 'v pna list) =
fun dummy_input verbose_mode demon pl all enab get_action_value ->
if demon <> Custom && dummy_input then
ignore (RifRead.bool verbose_mode ((List.hd pl).pid) "");
......
(* Time-stamp: <modified the 13/05/2019 (at 17:08) by Erwan Jahier> *)
(* Time-stamp: <modified the 12/06/2019 (at 08:04) by Erwan Jahier> *)
type t =
| Synchronous (* select all actions *)
......@@ -8,7 +8,7 @@ type t =
| Custom (* enable/actions are communicated via stdin/stdout in RIF *)
type pna = Process.t * Algo.neighbor list * Algo.action
type 'v pna = 'v Process.t * 'v Algo.neighbor list * Algo.action
(** f dummy_input_flag verbose_mode demon pl actions_ll enab
......@@ -36,6 +36,6 @@ nb: it is possible that we read on stdin that an action should be
inhibit the activation.
*)
val f : bool -> bool -> t -> Process.t list -> pna list list -> bool list list ->
(string -> string -> bool) -> bool list list * pna list
val f : bool -> bool -> t -> 'v Process.t list -> 'v pna list list -> bool list list ->
(string -> string -> bool) -> bool list list * 'v pna list
(* Time-stamp: <modified the 11/06/2019 (at 16:26) by Erwan Jahier> *)
(* Time-stamp: <modified the 12/06/2019 (at 08:06) by Erwan Jahier> *)
module Dico = Map.Make(String)
open Algo
type t = local_env Dico.t
type 'v t = 'v local_env Dico.t
let (get: t -> string -> Algo.local_env) =
let (get: 'v t -> string -> 'v Algo.local_env) =
fun e pid ->
(* Printf.printf "<-- get pid %s\n" pid; flush stdout; *)
try ((Dico.find pid e))
......@@ -13,15 +13,15 @@ let (get: t -> string -> Algo.local_env) =
failwith (Printf.sprintf "Unknown pid: %s (%s)" pid (Printexc.to_string e))
let (get_copy: Algo.vars -> t -> string -> Algo.local_env) =
let (get_copy: Algo.vars -> 'v t -> string -> 'v Algo.local_env) =
fun vars e pid ->
Algo.copy_local_env vars (get e pid)
let (set: t -> string -> Algo.local_env -> t) =
let (set: 'v t -> string -> 'v Algo.local_env -> 'v t) =
fun e pid lenv ->
(* Printf.printf "--> set pid %s\n" pid; flush stdout; *)
Dico.add pid lenv e
let (init:unit -> t) = fun () -> Dico.empty
let (init:unit -> 'v t) = fun () -> Dico.empty
(* Storing process variables values *)
type t
type 'v t
val init: unit -> t
val init: unit -> 'v t
(** [set env process_id var_name var_value] *)
val set: t -> string -> Algo.local_env -> t
val set: 'v t -> string -> 'v Algo.local_env -> 'v t
(** [get env process_id var_name] *)
val get: t -> string -> Algo.local_env
val get: 'v t -> string -> 'v Algo.local_env
(** In order to make sure that arrays ref are not shared between processes,
this function performs an array copy of the value (if it is an array)
*)
val get_copy: Algo.vars -> t -> string -> Algo.local_env
val get_copy: Algo.vars -> 'v t -> string -> 'v Algo.local_env
(* Time-stamp: <modified the 28/03/2019 (at 18:16) by Erwan Jahier> *)
(* Time-stamp: <modified the 12/06/2019 (at 07:47) by Erwan Jahier> *)
open Process
......@@ -22,7 +22,7 @@ let (gen_atmost_macro : int -> string) =
done;
!str^")\n"
let (f: Process.t list -> string) =
let (f: 'v Process.t list -> string) =
fun pl ->
let all = List.map (fun p -> List.map (fun a -> p.pid^"_"^a) p.actions) pl in
let al = List.flatten all in
......
(* Time-stamp: <modified the 01/04/2019 (at 17:21) by Erwan Jahier> *)
(* Time-stamp: <modified the 12/06/2019 (at 07:46) by Erwan Jahier> *)
(** generated various Lutin demons (distributed, synchronous, etc.) *)
val f: Process.t list -> string
val f: 'v Process.t list -> string
(* Time-stamp: <modified the 11/06/2019 (at 17:12) by Erwan Jahier> *)
(* Time-stamp: <modified the 12/06/2019 (at 07:46) by Erwan Jahier> *)
type t = {
type 'v t = {
pid : string;
variables : Algo.vars;
actions: Algo.action list;
init : Algo.local_env;
enable : Algo.enable_fun;
step : Algo.step_fun ;
init : 'v Algo.local_env;
enable : 'v Algo.enable_fun;
step : 'v Algo.step_fun ;
}
......@@ -17,7 +17,7 @@ let (dynlink_nodes: string -> unit) =
if !Algo.verbose_level > 0 then Printf.printf "Loading %s...\n" cmxs;
Dynlink.loadfile (Dynlink.adapt_filename cmxs)
let (make: bool -> Topology.node -> Algo.neighbor list -> t) =
let (make: bool -> Topology.node -> 'v Algo.neighbor list -> 'v t) =
fun custom_mode n nl ->
let pid = n.Topology.id in
let ml = n.Topology.file in
......@@ -28,7 +28,7 @@ let (make: bool -> Topology.node -> Algo.neighbor list -> t) =
(* let (string_to_value: string -> Algo.value) = *)
let user_init_env = user_init_env nl in
let init_env =
let init_env = (*
List.fold_left
(fun e (v,_) ->
match List.assoc_opt v n.Topology.init with
......@@ -37,7 +37,7 @@ let (make: bool -> Topology.node -> Algo.neighbor list -> t) =
Printf.eprintf "No init value for '%s' found in the graph.\n" v;
e
| Some x -> (
let value =
let value = (* read values from the dot init field *)
match List.assoc_opt v vars with
| Some(Algo.It)
| Some(Algo.Nt) -> Algo.I (int_of_string x)
......@@ -53,9 +53,9 @@ let (make: bool -> Topology.node -> Algo.neighbor list -> t) =
in
Algo.set e v value
)
)
) *)
user_init_env
vars
(* vars *)
in
let actions =
......
(* Time-stamp: <modified the 07/06/2019 (at 16:23) by Erwan Jahier> *)
(* Time-stamp: <modified the 11/06/2019 (at 18:20) by Erwan Jahier> *)
(** There is such a Process.t per node in the dot file. *)
type t = {
type 'v t = {
pid : string; (* unique *)
variables : Algo.vars;
actions: Algo.action list;
init : Algo.local_env;
enable : Algo.enable_fun;
step : Algo.step_fun;
init : 'v Algo.local_env;
enable : 'v Algo.enable_fun;
step : 'v Algo.step_fun;