test: fix the k-clustering cost (since the digraph->rooted-tree move)

test/k-clustering/Makefile

-# 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
 
 

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 *)

test/k-clustering/fig52_kcl.dot

-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
  }
  

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) =