Commit 3891cd6c authored by erwan's avatar erwan
Browse files

New: the idea of using polymorphic value now works!

The idea is to use the Obj module (arg !!!), which is safe thanks to
the fact that there is now only one register function, which forces all the
'v to be bound to the same type.
parent 483e953b
(* Time-stamp: <modified the 12/06/2019 (at 11:12) by Erwan Jahier> *)
(* Time-stamp: <modified the 17/06/2019 (at 11:35) by Erwan Jahier> *)
(** Process programmer API *)
type varT = string
......@@ -22,13 +22,13 @@ type 'v step_fun = 'v neighbor list -> 'v local_env -> action -> 'v local_env
type 'v internal_tables = {
vars : (string, vars) 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;
init_vars: (string, Obj.t) Hashtbl.t;
enable : (string, Obj.t) Hashtbl.t;
step : (string, Obj.t) 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;
value_to_string : (string, Obj.t) Hashtbl.t;
value_to_data : (string, Obj.t) Hashtbl.t;
copy_value : (string, Obj.t) Hashtbl.t;
mutable card : int
}
......@@ -167,7 +167,7 @@ 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
Hashtbl.replace tbls.init_vars algo_id (Obj.repr x)
let (get_init_vars :
......@@ -178,7 +178,8 @@ let (get_init_vars :
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
let (user_env: 'v neighbor list -> 'v local_env) =
Obj.obj (Hashtbl.find tbls.init_vars algo_id) in
(fun v ->
try user_env nl v
with e ->
......@@ -207,9 +208,9 @@ let (get_init_vars :
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
Hashtbl.replace tbls.enable algo_id (Obj.repr x)
let (get_enable : algo_id -> 'v enable_fun) = fun algo_id ->
try Hashtbl.find tbls.enable algo_id
try Obj.obj (Hashtbl.find tbls.enable algo_id)
with Not_found ->
print_table "enable" tbls.enable;
raise (Unregistred ("enable", algo_id))
......@@ -217,10 +218,10 @@ let (get_enable : algo_id -> 'v enable_fun) = fun algo_id ->
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
Hashtbl.replace tbls.step algo_id (Obj.repr x)
let (get_step : algo_id -> 'v step_fun) = fun algo_id ->
try Hashtbl.find tbls.step algo_id
try Obj.obj (Hashtbl.find tbls.step algo_id)
with Not_found ->
print_table "step" tbls.step;
raise (Unregistred ("step", algo_id))
......@@ -240,20 +241,20 @@ 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
Hashtbl.replace tbls.value_to_string "_global" (Obj.repr f)
let (get_value_to_string : unit -> ('v -> string)) = fun () ->
try Hashtbl.find tbls.value_to_string "_global"
try Obj.obj (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) =
let (reg_value_to_data : ('v -> Data.v) -> 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"
Hashtbl.replace tbls.value_to_data "_global" (Obj.repr f)
let (get_value_to_data : unit -> ('v -> Data.v)) = fun () ->
try Obj.obj (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"))
......@@ -262,16 +263,40 @@ 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
Hashtbl.replace tbls.copy_value "_global" (Obj.repr f)
let (get_copy_value : unit -> ('v -> 'v)) = fun () ->
try Hashtbl.find tbls.copy_value "_global"
try Obj.obj (Hashtbl.find tbls.copy_value "_global")
with Not_found ->
print_table "copy_value" tbls.copy_value;
raise (Unregistred ("copy_value", "_global"))
let (register1 : algo_id * vars * ('v neighbor list -> 'v local_env) option *
'v enable_fun * 'v step_fun -> unit) =
fun (algo_id, vars, init_vars_opt, enab, step) ->
reg_vars algo_id vars;
reg_enable algo_id enab;
reg_step algo_id step;
(match init_vars_opt with Some f -> reg_init_vars algo_id f | None -> ());
()
let registered = ref false
(* exported *)
let (register :
(algo_id * vars * ('v neighbor list -> 'v local_env) option *
'v enable_fun * 'v step_fun) list * ('v -> string) *
('v -> Data.v) * ('v -> 'v) -> unit) =
fun (l, value_to_string, value_to_data, copy_value) ->
if !registered then failwith "Register can only be called once!";
registered := true;
List.iter register1 l;
reg_value_to_string value_to_string;
reg_value_to_data value_to_data;
reg_copy_value copy_value;
()
let (card : unit -> int) =
fun () -> tbls.card
......
(* Time-stamp: <modified the 14/06/2019 (at 13:46) by Erwan Jahier> *)
(* Time-stamp: <modified the 17/06/2019 (at 11:34) by Erwan Jahier> *)
(** Process programmer API *)
(* val copy_value : value -> value *)
type 'v local_env
val empty_env: 'v local_env
val set : 'v local_env -> string -> 'v -> 'v local_env
val get : 'v local_env -> string -> 'v
......@@ -34,9 +33,18 @@ 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 register :
(algo_id * vars * ('v neighbor list -> 'v local_env) option * 'v enable_fun *
'v step_fun) list * ('v -> string) * ('v -> Data.v) * ('v -> 'v) -> unit
val reg_vars : algo_id -> vars -> unit
val reg_enable : algo_id -> 'v enable_fun -> unit
val reg_step : algo_id -> 'v step_fun -> unit
val reg_value_to_string : ('v -> string) -> unit
val reg_value_to_data : ('v -> Data.v) -> unit
val reg_copy_value : ('v -> 'v) -> unit
(** raised by sasa if one of the function above is not called *)
exception Unregistred of string * string
......@@ -47,9 +55,6 @@ 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) *)
(** Global infos *)
......@@ -61,9 +66,10 @@ val card : unit -> int
(**/**)
(** functions below are not part of the API *)
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 copy_local_env : ('v -> 'v) -> vars -> 'v local_env -> 'v local_env
val string_of_local_env : ('v -> string) -> vars -> 'v local_env -> string
val rif_of_local_env : ('v -> string) -> vars -> 'v local_env -> string
val sl_of_local_env : vars -> string -> 'v local_env -> (string * 'v) list
......
(* Time-stamp: <modified the 14/06/2019 (at 13:46) by Erwan Jahier> *)
(* Time-stamp: <modified the 14/06/2019 (at 14:20) by Erwan Jahier> *)
module Dico = Map.Make(String)
......@@ -15,13 +15,14 @@ let (get: 'v t -> string -> 'v 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 copy_value = Algo.get_copy_value () in
Algo.copy_local_env copy_value vars (get e pid)
let (set: 'v t -> string -> 'v Algo.local_env -> 'v t) =
fun e pid lenv ->
(* Printf.printf "--> set pid %s\n" pid; flush stdout; *)
let lenv = Algo.set lenv "pid" (Algo.S pid) in
(* let lenv = Algo.set lenv "pid" (Algo.S pid) in *)
Dico.add pid lenv e
let (init:unit -> 'v t) = fun () -> Dico.empty
......
......@@ -20,10 +20,11 @@ let (algo_neighbor : 'v Algo.neighbor -> string) = fun n ->
open Process
let (env: 'v Env.t -> 'v Process.t list -> string) =
fun env pl ->
let value_to_string = Algo.get_value_to_string () in
let l = List.map
(fun p ->
Printf.sprintf "%s: %s" p.pid
(Algo.string_of_local_env p.variables (Env.get env p.pid)))
(Algo.string_of_local_env value_to_string p.variables (Env.get env p.pid)))
pl
in
String.concat ", " l
......@@ -31,9 +32,11 @@ let (env: 'v Env.t -> 'v Process.t list -> string) =
let (env_rif: 'v Env.t -> 'v Process.t list -> string) =
fun env pl ->
let value_to_string = Algo.get_value_to_string () in
let l = List.map
(fun p ->
Printf.sprintf "%s" (Algo.rif_of_local_env p.variables (Env.get env p.pid)))
Printf.sprintf "%s"
(Algo.rif_of_local_env value_to_string p.variables (Env.get env p.pid)))
pl
in
String.concat " " l
......
(* Time-stamp: <modified the 11/06/2019 (at 16:40) by Erwan Jahier> *)
(* Time-stamp: <modified the 17/06/2019 (at 14:15) by Erwan Jahier> *)
(* This is algo 5.4 in the book *)
open Algo
let vars = ["d",It; "par",Nt ]
let vars = ["d","int"; "par", "int" ]
let d=10 (* degree() *)
let actions = ["CD";"CP"]
let (init_vars: neighbor list -> local_env) =
let (init_vars: 'v neighbor list -> 'v local_env) =
fun nl ->
let e = empty_env in
let e = set e "d" (I (Random.int d)) in
let e = set e "par" (N (Random.int ((List.length nl)))) in
let e = set e "d" (Random.int d) in
let e = set e "par"(Random.int ((List.length nl))) in
e
(* casting *)
let i v = match v with I i | N i -> i | _ -> assert false
let (dist: neighbor list -> int) = fun nl ->
let dl = List.map (fun n -> i (get n.lenv "d")) nl in
let (dist: 'v neighbor list -> int) = fun nl ->
let dl = List.map (fun n -> (get n.lenv "d")) nl in
1+(List.fold_left min (d-1) dl)
let (dist_ok: neighbor list -> local_env -> bool) =
let (dist_ok: 'v neighbor list -> 'v local_env -> bool) =
fun nl e ->
let dl = List.map (fun n -> i (get n.lenv "d")) nl in
let dl = List.map (fun n -> get n.lenv "d") nl in
let md = List.fold_left min (List.hd dl) (List.tl dl) in
i (get e "d") - 1 = md
(get e "d") - 1 = md
let (get_parent: neighbor list -> local_env -> neighbor) =
let (get_parent: 'v neighbor list -> 'v local_env -> 'v neighbor) =
fun nl e ->
let canal = i (get e "par") in
let canal = get e "par" in
try List.nth nl canal
with Failure _ -> failwith (Printf.sprintf "Canal %i does not exist (canal in [0..%i])\n" canal ((List.length nl)-1))
let (enable_f:neighbor list -> local_env -> action list) =
let (enable_f:'v neighbor list -> 'v local_env -> action list) =
fun nl e ->
let par = get_parent nl e in
let par_env = par.lenv in
(if i (get e "d") <> dist nl then ["CD"] else []) @
(if (dist_ok nl e) && (i (get par_env "d") <> i (get e "d") -1) then ["CP"] else [])
(if (get e "d") <> dist nl then ["CD"] else []) @
(if (dist_ok nl e) && ( (get par_env "d") <> (get e "d") -1) then ["CP"] else [])
let (index_of_first_true : bool list -> int) = fun bl ->
......@@ -51,24 +48,17 @@ let (index_of_first_true : bool list -> int) = fun bl ->
in
f 0 bl
let (step_f : neighbor list -> local_env -> action -> local_env) =
let (step_f : 'v neighbor list -> 'v local_env -> action -> 'v local_env) =
fun nl e ->
function
| "CD" -> set e "d" (I (dist nl))
| "CD" -> set e "d" (dist nl)
| "CP" ->
let d = i (get e "d") in
let ok_l = List.map (fun n -> i (get n.lenv "d") = d-1) nl in
let d = get e "d" in
let ok_l = List.map (fun n -> (get n.lenv "d") = d-1) nl in
let q = index_of_first_true ok_l in
set e "par" (I q)
set e "par" q
| _ -> assert false
let () =
let algo_id = "p" in
Algo.reg_vars algo_id vars;
Algo.reg_init_vars algo_id init_vars;
Algo.reg_enable algo_id enable_f;
Algo.reg_step algo_id step_f;
Algo.reg_actions algo_id actions;
()
(* Time-stamp: <modified the 11/06/2019 (at 16:38) by Erwan Jahier> *)
(* Time-stamp: <modified the 17/06/2019 (at 14:54) by Erwan Jahier> *)
(* This is algo 5.3 in the book *)
open Algo
let vars = ["d",It]
let vars = ["d","int"]
let d=10
let (init_vars: neighbor list -> local_env) =
let (init_vars: 'v neighbor list -> 'v local_env) =
fun _nl ->
set empty_env "d" (I (Random.int d))
set empty_env "d" (Random.int d)
let (enable_f:neighbor list -> local_env -> action list) =
let (enable_f:'v neighbor list -> 'v local_env -> action list) =
fun nl e ->
if (get e "d") <> I 0 then ["CD"] else []
if (get e "d") <> 0 then ["CD"] else []
let (step_f : neighbor list -> local_env -> action -> local_env) =
let (step_f : 'v neighbor list -> 'v local_env -> action -> 'v local_env) =
fun nl e ->
function | _ -> set e "d" (I 0)
function | _ -> set e "d" 0
let (value_to_string: ('v -> string)) = string_of_int
let (value_to_data : ('v -> Data.v)) = fun i -> Data.I i
let (copy_value : ('v -> 'v)) = fun x -> x
let () =
let algo_id = "root" in
Algo.reg_vars algo_id vars;
Algo.reg_init_vars algo_id init_vars;
Algo.reg_enable algo_id enable_f;
Algo.reg_step algo_id step_f;
Algo.reg_actions algo_id ["CD"];
()
let algo_root = "root" in
let algo_p = "p" in
Algo.register
([(algo_root, vars, (Some init_vars), enable_f, step_f);
(algo_p, P.vars, (Some P.init_vars), P.enable_f, P.step_f)
],
value_to_string,
value_to_data,
copy_value) ;
Algo.reg_actions algo_root ["CD"];
Algo.reg_actions algo_p P.actions;
()
(* Time-stamp: <modified the 14/06/2019 (at 13:26) by Erwan Jahier> *)
(* Time-stamp: <modified the 17/06/2019 (at 14:54) by Erwan Jahier> *)
(* This is algo 3.1 in the book *)
open Algo
let vars = ["c",It]
let k=3
let (init_vars: neighbor list -> local_env) =
let (init_vars: 'v neighbor list -> 'v local_env) =
fun _nl ->
set empty_env "c" (I (Random.int k))
set empty_env "c" (Random.int k)
let vars = ["c","int"]
let verbose = true
let (neigbhors_values : neighbor list -> Algo.value list) =
let (value_to_string: ('v -> string)) = string_of_int
let (value_to_data : ('v -> Data.v)) = fun i -> Data.I i
let (copy_value : ('v -> 'v)) =
fun x -> x
let (neigbhors_values : 'v neighbor list -> 'v list) =
fun nl ->
List.map (fun n -> get n.lenv "c") nl
let (clash : Algo.value -> neighbor list -> bool) = fun v nl ->
let (clash : 'v -> 'v neighbor list -> bool) = fun v nl ->
let vnl = neigbhors_values nl in
let inl = List.map (fun n -> n.pid()) nl in
let res = List.mem v vnl in
......@@ -31,36 +37,36 @@ let (clash : Algo.value -> neighbor list -> bool) = fun v nl ->
);
res
let (free : neighbor list -> Algo.value list) = fun nl ->
let (free : 'v neighbor list -> 'v list) = fun nl ->
let clash_list = List.sort_uniq compare (neigbhors_values nl) in
let rec aux free clash i =
if i > k then free else
(match clash with
| x::tail ->
if x = I i then aux free tail (i+1) else aux ((I i)::free) clash (i+1)
| [] -> aux ((I i)::free) clash (i+1)
if x = i then aux free tail (i+1) else aux (i::free) clash (i+1)
| [] -> aux (i::free) clash (i+1)
)
in
let res = aux [] clash_list 0 in
List.rev res
let (enable_f:neighbor list -> local_env -> action list) =
let (enable_f:'v neighbor list -> 'v local_env -> action list) =
fun nl e ->
if (clash (get e "c") nl) then ["conflict"] else []
let (step_f : neighbor list -> local_env -> action -> local_env) =
let (step_f : 'v neighbor list -> 'v local_env -> action -> 'v local_env) =
fun nl e a ->
let f = free nl in
if f = [] then e else
match a with
| _ -> set e "c" (List.hd f)
let () =
let algo_id = "p" in
Algo.register
([(algo_id, vars, (Some init_vars), enable_f, step_f) ],
value_to_string, value_to_data, copy_value) ;
Algo.reg_actions algo_id ["conflict"];
Algo.reg_vars algo_id vars;
Algo.reg_init_vars algo_id init_vars;
Algo.reg_enable algo_id enable_f;
Algo.reg_step algo_id step_f;
()
# Time-stamp: <modified the 11/06/2019 (at 16:55) by Erwan Jahier>
# Time-stamp: <modified the 17/06/2019 (at 16:19) by Erwan Jahier>
test: test0 lurette0
test0: cmxs
$(sasa) -rif -l 200 g.dot -sd
cmxs: p.cmxs root.cmxs g.lut p.cma root.cma
cmxs: root.cmxs p.cmxs g.lut p.cma root.cma
sim2chrogtk: g.rif
sim2chrogtk -ecran -in $< > /dev/null
......@@ -30,6 +32,15 @@ rdbg: cmxs g.lut
-sut-nd "lutin g.lut -n dummy"
%.cmxs: value.cmx %.ml
ocamlfind ocamlopt -shared $(LIB) $^ -o $@
p.cmxs: value.cmx p.ml
ocamlfind ocamlopt -shared $(LIB) root.ml $^ -o $@
-include ../Makefile.inc
value.cmx: value.ml
ocamlfind ocamlopt -package lutils value.ml
(* Time-stamp: <modified the 11/06/2019 (at 16:45) by Erwan Jahier> *)
(* Time-stamp: <modified the 17/06/2019 (at 16:34) by Erwan Jahier> *)
(* cf Collin-Dolex-94 *)
open Algo
let delta=10 (* diameter() *)
let vars = ["path",(At (It,delta)); "par",Nt]
let vars = ["v","int int int int int int int int int int"]
let actions = ["update_path";"compute_parent"]
let (init_vars: neighbor list -> local_env) =
open Root
open Value
let (init_vars: 'v neighbor list -> 'v local_env) =
fun nl ->
let e = empty_env in
let e = set e "path" (A (Array.make delta (I (-1)))) in
let e = set e "par" (N (try Random.int ((List.length nl)) with _ -> assert false)) in
e
set e "v" {
path = Array.make delta (-1);
par = try Random.int ((List.length nl)) with _ -> assert false
}
(* casting *)
let (a:value -> value array) = function A a -> a | _ -> assert false
let (i:value -> int) = function N i -> i | _ -> assert false
let str_of_array a =
let l = List.map Algo.value_to_string (Array.to_list a) in
let l = List.map Value.to_string (Array.to_list a) in
"["^(String.concat "," l)^"]"
let min_path al =
......@@ -28,20 +31,20 @@ let min_path al =
| [] -> assert false
| x::t -> List.fold_left min x t
let (get_paths: neighbor list -> local_env -> value array list) =
fun nl e ->
List.mapi (fun alpha_i n -> a (get n.lenv "path")) nl
let (get_paths: 'v neighbor list -> int array list) =
fun nl ->
List.mapi (fun alpha_i n -> (get n.lenv "v").path) nl
(* The index of the first negative elt in a starting from i. Returns
the size of the a if none is found *)
let rec end_of_a a i =
if i=delta then delta else
if a.(i) < I 0 then i else end_of_a a (i+1)
if a.(i) < 0 then i else end_of_a a (i+1)
(* concat and truncate *)
let (concat_path : value array -> int -> value array) =
let (concat_path : int array -> int -> int array) =
fun a alpha ->
let s = Array.length a in
let last = end_of_a a 1 in
......@@ -49,10 +52,10 @@ let (concat_path : value array -> int -> value array) =
for i = 1 to s-1 do
a.(i-1) <- a.(i)
done;
a.(s-1) <- I alpha
a.(s-1) <- alpha
)
else
a.(last) <- I alpha;
a.(last) <- alpha;
a
let equals_up_to p1 p2 i =
......@@ -62,16 +65,16 @@ let equals_up_to p1 p2 i =
done;
!res
let (compute_parent : neighbor list -> value array -> value) =
let (compute_parent : Value.t neighbor list -> int array -> int) =