From ce8f38b13f83a54438d5f7cbfb86fc8bf7ab67a2 Mon Sep 17 00:00:00 2001
From: Erwan Jahier <erwan.jahier@univ-grenoble-alpes.fr>
Date: Thu, 23 Jun 2022 10:21:04 +0200
Subject: [PATCH] test: fix the k-clustering cost (since the
digraph->rooted-tree move)
---
test/k-clustering/Makefile | 12 +++----
test/k-clustering/config.ml | 62 +++++++++++++++++++++++++++------
test/k-clustering/fig52_kcl.dot | 20 +++++------
test/k-clustering/p.ml | 4 +--
4 files changed, 69 insertions(+), 29 deletions(-)
diff --git a/test/k-clustering/Makefile b/test/k-clustering/Makefile
index ad53a1e1..f0c0528d 100644
--- a/test/k-clustering/Makefile
+++ b/test/k-clustering/Makefile
@@ -1,4 +1,4 @@
-# Time-stamp: <modified the 11/06/2022 (at 15:03) by Erwan Jahier>
+# Time-stamp: <modified the 22/06/2022 (at 23:22) by Erwan Jahier>
DECO_PATTERN="0-:p.ml"
-include ../Makefile.inc
@@ -10,9 +10,9 @@ DECO_PATTERN="0-:p.ml"
##############################################################################
# Non-regression tests
-test: fig52_kcl.cmxs fig52_kcl.rdbg-test
- sasa -gcd fig52_kcl.dot && make clean
-utest: clean
+test: fig52_kcl.gm_test fig52_kcl.rdbg-test rtree10.gm_test
+
+utest: fig52_kcl.ugm_test rtree10.ugm_test
clean: genclean
rm -f fig52_kcl.ml
@@ -35,7 +35,7 @@ rdbg: fig52_kcl.ml
rdbg: fig52_kcl.ml
rdbg --sasa -o fig52_kcl.rif -env "sasa fig52_kcl.dot -cd"
-dtree50: dtree50.cmxs
- sasa -cd dtree50.dot
+rtree50: rtree50.cmxs
+ sasa -cd rtree50.dot
diff --git a/test/k-clustering/config.ml b/test/k-clustering/config.ml
index 8cbc35bc..73755430 100644
--- a/test/k-clustering/config.ml
+++ b/test/k-clustering/config.ml
@@ -5,25 +5,64 @@ open P
let debug = false
+let exit2 msg =
+ Printf.printf "Error in config.ml: %s\n%!" msg;
+ exit 2
+
+let remove_nth n l =
+ assert (n>=0);
+ let rec f n l =
+ if n=0 then List.tl l else
+ match l with
+ | [] -> assert false
+ | x::tl -> x::(f (n-1) tl)
+ in
+ if (n >= List.length l) then (
+ exit2 (Printf.sprintf "cannot get the %dth element of a list of size %d"
+ n (List.length l))
+ )
+ else
+ f n l
+
let rec (pot : pid -> (pid -> ('a * ('a neighbor*pid) list)) -> int -> int -> int) =
fun pid get level acc ->
(* From a pid and its level, adds to acc the potential of the tree
rooted in pid *)
- let s, nl = get pid in
- let nl2 = List.map fst nl in
- let acc = if P.enable_f s nl2 <> [] then (
- if debug then Printf.printf "%s -> acc=%d+%d\n%!" pid acc level ;
- acc+level
- )
- else acc in
- List.fold_left (fun acc (_, pid) -> pot pid get (level+1) acc) acc nl
-
+ if debug then Printf.printf "pot %s\n%!" pid;
+ let s, nl = get pid in
+ let nl = if s.isRoot then nl else remove_nth s.par nl in
+ let nl2 = List.map fst nl in
+ let acc = if P.enable_f s nl2 <> [] then (
+ if debug then Printf.printf "%s -> acc=%d+%d\n%!" pid acc level;
+ acc+level
+ )
+ else (
+ acc
+ )
+ in
+ List.fold_left (fun acc (_, pid) -> pot pid get (level+1) acc) acc nl
+
+
+
+(* Do this work only once, we store the root name in a string option ref *)
+let root = ref None
+let get_root pidl get =
+ match !root with
+ | None ->
+ ( match List.filter (fun pid -> (fst (get pid)).isRoot) pidl with
+ [ pid ] -> root := Some pid; pid
+ | [] -> exit2 "at least one node should be the root"
+ | _::_ -> exit2 "at most one node should be the root"
+ )
+ | Some pid -> pid
(* The potential is defined as the sum of enabled nodes levels (the
level is 1 for root, 2 for its children, and so on *)
let (pf: pid list -> (pid -> ('a * ('a neighbor * pid) list)) -> float) =
fun pidl get ->
- let root_pot = pot "root" get 1 0 in
+ let root = get_root pidl get in
+ if debug then Printf.printf "=================> %s is the root \n%!" root;
+ let root_pot = pot root get 1 0 in
if debug then (
let enab pid =
let v,nl = get pid in
@@ -35,9 +74,10 @@ let (pf: pid list -> (pid -> ('a * ('a neighbor * pid) list)) -> float) =
let enab_list = List.map enab pidl in
Printf.printf "=================> potential(%s) = %d\n%!" (String.concat "," enab_list) root_pot
);
- (* (String.concat "," (List.map (fun pid -> Printf.sprintf "%s=%b" get pid) pidl) root_pot ; *)
+ (* (String.concat "," (List.map (fun pid -> Printf.sprintf "%s=%b" get pid) pidl) root_pot ; *)
float_of_int root_pot
+let potential = None
let potential = Some pf
let legitimate = None (* None => only silent configuration are legitimate *)
diff --git a/test/k-clustering/fig52_kcl.dot b/test/k-clustering/fig52_kcl.dot
index 8fb08ebb..b9f15d3e 100644
--- a/test/k-clustering/fig52_kcl.dot
+++ b/test/k-clustering/fig52_kcl.dot
@@ -1,14 +1,14 @@
-digraph fig52 {
-
- root [algo="p.ml" init="{is_root=1 ; alpha=0; par=-1}"]
- p2 [algo="p.ml" init="{is_root=0 ; alpha=0; par=1}"]
- p3 [algo="p.ml" init="{is_root=0 ; alpha=0; par=1}"]
- p4 [algo="p.ml" init="{is_root=0 ; alpha=0; par=1}"]
- p5 [algo="p.ml" init="{is_root=0 ; alpha=0; par=2}"]
- p6 [algo="p.ml" init="{is_root=0 ; alpha=0; par=1}"]
+graph fig52 {
+
+ Root [algo="p.ml" init="{is_root=1 ; alpha=0; par=-1}"]
+ p2 [algo="p.ml" init="{is_root=0 ; alpha=0; par=0}"]
+ p3 [algo="p.ml" init="{is_root=0 ; alpha=0; par=0}"]
+ p4 [algo="p.ml" init="{is_root=0 ; alpha=0; par=0}"]
+ p5 [algo="p.ml" init="{is_root=0 ; alpha=0; par=0}"]
+ p6 [algo="p.ml" init="{is_root=0 ; alpha=0; par=0}"]
p7 [algo="p.ml" init="{is_root=0 ; alpha=0; par=0}"]
- root -> p2 -> p3 -> p4 -> p5 -> p6
- p5 -> p7
+ Root -- p2 -- p3 -- p4 -- p5 -- p6
+ p5 -- p7
}
diff --git a/test/k-clustering/p.ml b/test/k-clustering/p.ml
index 490ab21a..9928fa0e 100644
--- a/test/k-clustering/p.ml
+++ b/test/k-clustering/p.ml
@@ -72,7 +72,7 @@ let (newAlpha: s -> nl -> int) =
let mas = (maxAShort p nl) in
let mit = (minATall p nl) in
let res = if (mas + mit) <= (2*k - 2) then (mit + 1) else (mas + 1) in
- (* Printf.printf "newAlpha -> %d\n%!" res; *)
+ (* Printf.printf "newAlpha -> %d\n%!" res; *)
res
(*end macros*)
@@ -82,7 +82,7 @@ let (init_state: int -> string -> s) =
{
isRoot = pid = "Root"; (* ZZZ: The root of the tree should be named "Root"! *)
alpha = Random.int (2*k+1);
- par = 0 (* the input tree should be sorted alphabetically (wrt a bf traversal) *)
+ par = if pid="Root" then -1 else 0 (* the input tree should be sorted alphabetically (wrt a bf traversal) *)
}
let (enable_f: s -> nl -> action list) =
--
GitLab