From fb6fdca8d4986b099dd7afc0f1f05e2058997ddc Mon Sep 17 00:00:00 2001
From: Erwan Jahier <erwan.jahier@univ-grenoble-alpes.fr>
Date: Thu, 26 Jan 2023 16:44:06 +0100
Subject: [PATCH] test: add a few qtest tests
---
Makefile | 2 +-
Makefile.sasa | 3 ---
lib/qtest/dune | 29 ++++++++++++++++++++++++++++
lib/sasacore/daemon.ml | 26 ++++++++++++++-----------
lib/sasacore/daemon.mli | 13 +++++++------
lib/sasacore/dune | 7 +++++--
lib/sasacore/enumerate.ml | 25 +++++++++++++++++++-----
lib/sasacore/worstInit.ml | 40 +++++++++++++++++++++------------------
sasa.opam | 1 +
9 files changed, 100 insertions(+), 46 deletions(-)
create mode 100644 lib/qtest/dune
diff --git a/Makefile b/Makefile
index d1c5913d..0dbdbb93 100644
--- a/Makefile
+++ b/Makefile
@@ -1,7 +1,7 @@
build: lib/sasacore/sasaVersion.ml
- dune build @install
+ dune build @install @runtest
install:
dune install
diff --git a/Makefile.sasa b/Makefile.sasa
index 58072565..80d32457 100644
--- a/Makefile.sasa
+++ b/Makefile.sasa
@@ -1,8 +1,5 @@
-build: lib/sasacore/sasaVersion.ml
- dune build @install
-
.PHONY:test
test:
diff --git a/lib/qtest/dune b/lib/qtest/dune
new file mode 100644
index 00000000..85d7f9ae
--- /dev/null
+++ b/lib/qtest/dune
@@ -0,0 +1,29 @@
+;;; the qtest documentatiopn wrt its use of dune is helpless
+;; this file is my solution to do it by hand
+
+(rule
+ (targets run_qtest.ml)
+ (deps (source_tree ../sasacore))
+ ; here is where you need to tell qtest what files to consider
+
+ (action
+ (run qtest --preamble "open Sasacore\nopen Daemon\nopen Enumerate"
+ extract ../sasacore/daemon.ml ../sasacore/enumerate.ml -o %{targets})
+ )
+
+ )
+
+(executable
+ (name run_qtest)
+ (modules run_qtest)
+ ; disable some warnings in qtests
+ (flags :standard -warn-error -a -w -33-35-27-39)
+ (libraries qcheck dynlink ocamlgraph lutils sasacore algo)
+
+; (action (run %{target}))
+ )
+
+(rule
+ (alias runtest)
+ (action
+ (run ./run_qtest.exe)))
diff --git a/lib/sasacore/daemon.ml b/lib/sasacore/daemon.ml
index 24781ad2..cace17b5 100644
--- a/lib/sasacore/daemon.ml
+++ b/lib/sasacore/daemon.ml
@@ -1,6 +1,6 @@
-(* Time-stamp: <modified the 21/10/2021 (at 14:17) by Erwan Jahier> *)
+(* Time-stamp: <modified the 25/01/2023 (at 16:47) by Erwan Jahier> *)
-(* Enabled processes (with its enabling action + neighbors) *)
+(* Enabled processes (with its enabling action + neighbors) *)
type 'v pna = 'v Process.t * 'v Register.neighbor list * Register.action
type 'v enabled = 'v pna list list
type 'v triggered = 'v pna list
@@ -16,14 +16,14 @@ let (random_list2 : 'a list -> 'a * 'a list) = fun l ->
assert (l <> []);
let rec split acc i = function
| [] -> assert false (* sno *)
- | x::l ->
+ | x::l ->
if i=0 then x, List.rev_append acc l else split (x::acc) (i-1) l
in
let i = Random.int (List.length l) in
split [] i l
let (central: 'a list list -> 'a list) =
- fun all ->
+ fun all ->
if all = [] then [] else
let al = List.map random_list all in
let a = random_list al in
@@ -36,13 +36,13 @@ let rec (distributed: 'a list list -> 'a list) =
let al = List.map random_list all in
let al = List.filter (fun _ -> Random.bool ()) al in
if al = [] then distributed all else al
-
+
let (synchrone: 'a list list -> 'a list) = fun all ->
if all = [] then [] else
let al = List.map random_list all in
al
-(* LC= 2 neighbors cannot be activated at the same step
+(* LC= 2 neighbors cannot be activated at the same step
XXX this daemon is not fair: it is biased by the degree of nodes.
*)
@@ -94,11 +94,15 @@ let rec map3 f l1 l2 l3 =
| ([], _, _) -> invalid_arg "map3 (1st arg too short)"
| (_, [], _) -> invalid_arg "map3 (2nd arg too short)"
| (_, _, []) -> invalid_arg "map3 (3rd arg too short)"
-
+
+(*$T map3
+ map3 (fun x y z -> x-y+z) [1;2;3] [1;2;3] [1;2;3] = [1;2;3]
+ map3 (fun x y z -> x-y+z) [] [] [] = []
+*)
let (custom: 'v enabled -> 'v Process.t list -> bool list list ->
(string -> string -> bool) -> bool list list * 'v triggered) =
- fun pnall pl enab_ll get_action_value ->
+ fun pnall pl enab_ll get_action_value ->
let f p pnal enab_l =
let actions = p.Process.actions in
let trigger_l = List.map (get_action_value p.Process.pid) actions in
@@ -107,12 +111,12 @@ let (custom: 'v enabled -> 'v Process.t list -> bool list list ->
(fun trig enab a ->
let acti = trig && enab in
acti, if acti
- then List.filter (fun (_,_,a') -> a=a') pnal
+ then List.filter (fun (_,_,a') -> a=a') pnal
else []
) trigger_l enab_l actions
in
acti_l_al
- in
+ in
let acti_l_all = map3 f pl pnall enab_ll in
let acti_l_al = List.flatten acti_l_all in
let al = snd (List.split acti_l_al) in
@@ -131,7 +135,7 @@ let (get_activate_val: 'v triggered -> 'v Process.t list -> bool list list)=
List.map (fun p -> List.map (fun a -> p,a) p.Process.actions) pl
in
let al = List.map (fun (p,_,a) -> p,a) al in
- List.map (List.map (fun a -> List.mem a al)) actions
+ List.map (List.map (fun a -> List.mem a al)) actions
let (f: bool -> bool -> DaemonType.t -> 'v Process.t list ->
('v SimuState.t -> string -> 'v * ('v Register.neighbor * string) list) ->
diff --git a/lib/sasacore/daemon.mli b/lib/sasacore/daemon.mli
index 487faa7d..1cc210ab 100644
--- a/lib/sasacore/daemon.mli
+++ b/lib/sasacore/daemon.mli
@@ -1,17 +1,17 @@
-(* Time-stamp: <modified the 15/10/2021 (at 11:04) by Erwan Jahier> *)
+(* Time-stamp: <modified the 25/01/2023 (at 16:07) by Erwan Jahier> *)
type 'v pna = 'v Process.t * 'v Register.neighbor list * Register.action
type 'v enabled = 'v pna list list
type 'v triggered = 'v pna list
-
+
(** f dummy_input_flag verbose_mode daemon p_nl_l actions_ll enab
inputs:
-- dummy_input_flag: true when used with --ignore-first-inputs
+- dummy_input_flag: true when used with --ignore-first-inputs
- verbose_mode: true when the verbose level is > 0
-- daemon:
+- daemon:
- p_nl_l: list of all processes, and their neighbors
-- actions_ll: list of list of existing actions
+- actions_ll: list of list of existing actions
- enab: list of list saying which actions are enabled
At the inner list level, exactly one action ought to be chosen. At the
@@ -31,7 +31,7 @@ nb: it is possible that we read on stdin that an action should be
*)
type 'v step = 'v triggered -> 'v SimuState.t -> 'v SimuState.t
-
+
val f : bool -> bool -> DaemonType.t -> 'v Process.t list ->
('v SimuState.t -> string -> 'v * ('v Register.neighbor * string) list) ->
'v SimuState.t -> 'v enabled -> bool list list ->
@@ -45,3 +45,4 @@ val distributed: 'a list list -> 'a list
(* pid + its neighbors in input *)
val locally_central: ('v * 'v list) list list -> 'v list
+val map3 : ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
diff --git a/lib/sasacore/dune b/lib/sasacore/dune
index 460dd67f..699e4afa 100644
--- a/lib/sasacore/dune
+++ b/lib/sasacore/dune
@@ -1,16 +1,19 @@
-;; Time-stamp: <modified the 05/10/2021 (at 09:59) by Erwan Jahier>
+;; Time-stamp: <modified the 26/01/2023 (at 16:42) by Erwan Jahier>
(library
(name sasacore)
(public_name sasacore)
(libraries dynlink ocamlgraph lutils psq functory)
; (flags -noassert)
- ;;
+ ;;
; (wrapped false)
+ ; (inline_tests (backend qtest.lib)) ;; does not work );
(library_flags -linkall)
(synopsis "The Sasa main files (shared by the sasa exec and the rdbg plugin)")
)
+;; qtest does not work with dune anyway (would require 'wrapped false')
+;; cf ../qtest/dune for a workaround
; (modules_without_implementation algo)
diff --git a/lib/sasacore/enumerate.ml b/lib/sasacore/enumerate.ml
index 04313f26..841e360e 100644
--- a/lib/sasacore/enumerate.ml
+++ b/lib/sasacore/enumerate.ml
@@ -1,6 +1,6 @@
-(* Enumerate all schedules using continuations *)
+(* Enumerate all schedules using continuations *)
type 'a cont = NoMore | Elt of 'a * (unit -> 'a cont)
(* compose continuations *)
@@ -8,9 +8,9 @@ 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)
+ | 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 (all : 'a list list -> 'a list cont) = fun all ->
@@ -25,7 +25,7 @@ let (all : 'a list list -> 'a list cont) = fun all ->
let cont_a = f (a::acc) tl in
comp cont_a cont_acc
)
- (f acc tl)
+ (f acc tl)
al
in
res
@@ -39,6 +39,7 @@ let (central : 'a list list -> 'a cont) = fun all ->
List.fold_left (fun acc a -> Elt(a, fun () -> acc)) NoMore al
+
let (all_list : 'a list list -> 'a list list) = fun ll ->
let rec f acc c =
match c with
@@ -47,8 +48,22 @@ let (all_list : 'a list list -> 'a list list) = fun ll ->
in
f [] (all ll)
+let sort_ll ll =
+ ll |> List.map (List.sort compare) |> List.sort compare
+
+(*$T all_list
+ sort_ll (all_list [ [1] ;[2]; [3]; [] ]) = sort_ll [ [1]; [2]; [3]; [1;2]; [1;3]; [2;3]; [1;2;3] ];
+ sort_ll (all_list [ [1;2]; [3]; [] ]) = sort_ll [ [1]; [2]; [3]; [1;3]; [2;3] ];
+ *)
+
let (central_list : 'a list list -> 'a list list) = fun all ->
let al = List.flatten all in
List.map (fun x -> [x]) al
+let string_of_int_ll ll =
+ "[" ^ (String.concat "," (List.map (fun l -> "[" ^ (String.concat "," l ^ "]")) ll)) ^ "]"
+
+(*$T central_list
+ List.sort compare (central_list [ [1;2]; [3]; [4;5] ]) = [ [1]; [2]; [3]; [4]; [5] ];
+ *)
diff --git a/lib/sasacore/worstInit.ml b/lib/sasacore/worstInit.ml
index c8826f2d..17827b39 100644
--- a/lib/sasacore/worstInit.ml
+++ b/lib/sasacore/worstInit.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 28/11/2022 (at 17:41) by Erwan Jahier> *)
+(* Time-stamp: <modified the 25/01/2023 (at 15:24) by Erwan Jahier> *)
open Register
@@ -70,23 +70,27 @@ let all_dim_succ d n =
p.(j) <- mutate_value d p.(j)
done;
p
-
-
+
+
let tf = float_of_int
let ti = int_of_float
-
+
let (choose : int -> point -> (point -> point) -> point list) =
fun n p heuristic ->
- (*choose n successors of p using heuristic *)
+ (*choose n successors of p using heuristic *)
assert (n>=0);
let rec f acc i = if i <= 0 then acc else f ((heuristic p)::acc) (i-1) in
f [] n
+(*$T choose
+ List.length (choose 10 [| F(10.), F(42.) |] (one_dim_succ Close)) = 10
+*)
+
(*****************************************************************************)
(* XXX a ranger ailleurs !!! *)
open Process
-
+
let (point_to_ss : point -> 'v SimuState.t -> 'v SimuState.t) =
fun point ss ->
let (state_to_values, values_to_state :
@@ -110,8 +114,8 @@ let (point_to_ss : point -> 'v SimuState.t -> 'v SimuState.t) =
in
f l i j
in
- let new_config, _ =
- List.fold_left
+ let new_config, _ =
+ List.fold_left
(fun (e,j) p ->
let value = make_value [] state_size (j*state_size) in
let st = values_to_state value (Conf.get e p.pid) in
@@ -124,7 +128,7 @@ let (point_to_ss : point -> 'v SimuState.t -> 'v SimuState.t) =
if debug then Printf.printf "point_to_ss ok\n%!";
{ ss with config = new_config }
-
+
let (ss_to_point : 'v SimuState.t -> point) =
fun ss ->
let (state_to_values : ('v -> Register.value list) ) =
@@ -152,7 +156,7 @@ let (ss_to_point : 'v SimuState.t -> point) =
ss.network;
point
(*****************************************************************************)
-
+
open LocalSearch
@@ -189,10 +193,10 @@ let (fchc : out_channel -> ('v SimuState.t -> int) -> 'v SimuState.t -> int
let step_cpt = ref 1 in
let cost p = run (point_to_ss p ss_init) in
let pinit = ss_to_point ss_init in
- let percent_done = ref 0 in
+ let percent_done = ref 0 in
Functory.Cores.set_number_of_cores ss_init.sasarg.cores_nb;
let g =
- {
+ {
init = ({ st = pinit ; d = 0 ; cost = cost pinit ; cpt = 0 }, Q.empty, ());
succ = (fun n ->
(* let beam_size = min 50 (max 1 (dmax / 10)) in *)
@@ -206,7 +210,7 @@ let (fchc : out_channel -> ('v SimuState.t -> int) -> 'v SimuState.t -> int
let beam_size = max 50 ss_init.sasarg.cores_nb in
let percent_close = ((tf !cpt) /. (tf dmax)) ** 2.0 in
let percent_far = 1.0 -. percent_close in
-
+
let far_nb = max 1 (ti ((tf beam_size) *. percent_far) / 6) in
let close_nb = max 1 (ti ((tf beam_size) *. percent_close) / 6) in
incr step_cpt;
@@ -264,10 +268,10 @@ let (fchc : out_channel -> ('v SimuState.t -> int) -> 'v SimuState.t -> int
| LocalSearch.NoMore ->
(* occurs if all successors are cut *)
run_more psol more
- | LocalSearch.Stopped ->
+ | LocalSearch.Stopped ->
Printf.printf "\nThe worst initial configuration costs %d :" psol.cost;
point_to_ss psol.st ss_init
- | LocalSearch.Sol (nsol, more) ->
+ | LocalSearch.Sol (nsol, more) ->
if nsol.cost > psol.cost then (
Printf.printf "Hey, I've found a conf of cost %d! (simu #%d, depth %d)\n%!"
nsol.cost nsol.cpt nsol.d;
@@ -276,8 +280,8 @@ let (fchc : out_channel -> ('v SimuState.t -> int) -> 'v SimuState.t -> int
run_more psol more
)
)
-
- in
+
+ in
match LocalSearch.run g None with
| LocalSearch.Stopped -> assert false (* SNO *)
| LocalSearch.NoMore-> assert false (* SNO *)
@@ -329,5 +333,5 @@ let (global : out_channel -> ('v SimuState.t -> int) -> 'v SimuState.t -> int
n_percent_done dmax
);
if cpt > dmax then ss_worst else loop (cpt+1) (ss_worst, worst)
- in
+ in
loop 1 (ss_init, run ss_init)
diff --git a/sasa.opam b/sasa.opam
index 6f74f287..92a8c50a 100644
--- a/sasa.opam
+++ b/sasa.opam
@@ -23,6 +23,7 @@ depends: [
"conf-graphviz"
"lutils"
"psq"
+ "qtest"
"functory"
"ledit"
"rdbg" { >= "1.200" }
--
GitLab