From d16ba9278ad1141035675279b51e27f6cf330ff6 Mon Sep 17 00:00:00 2001
From: Guyslain <guyslain.naves@lis-lab.fr>
Date: Fri, 5 Jan 2024 10:46:53 +0100
Subject: [PATCH] more tests, there is an error in the algorithm, that requires
a significant refactoring.
---
dune-project | 2 +-
lib/pqtrees/pqChainInsertion.ml | 3 +-
lib/pqtrees/pqChainInsertion.mli | 85 +++++++++++++++++++++++++++--
lib/pqtrees/pqTree.mli | 2 +-
robinson.opam | 2 +-
test/propertytest/chainInsertion.ml | 43 +++++++++++++++
test/propertytest/main_prop_test.ml | 3 +-
test/unit/chainInsertionTest.ml | 65 ++++++++++++++++------
test/unit/dune | 2 +-
test/unit/robinsonByChainTest.ml | 39 +++++++++++++
10 files changed, 220 insertions(+), 26 deletions(-)
create mode 100644 test/propertytest/chainInsertion.ml
create mode 100644 test/unit/robinsonByChainTest.ml
diff --git a/dune-project b/dune-project
index be2fc95..2efbe51 100644
--- a/dune-project
+++ b/dune-project
@@ -1,4 +1,4 @@
-(lang dune 3.0)
+(lang dune 3.7)
(name robinson)
diff --git a/lib/pqtrees/pqChainInsertion.ml b/lib/pqtrees/pqChainInsertion.ml
index 998773d..781a808 100644
--- a/lib/pqtrees/pqChainInsertion.ml
+++ b/lib/pqtrees/pqChainInsertion.ml
@@ -47,7 +47,8 @@ module Make =
type external_subtree =
| ConstantSubtree of int * pqtree
- | IncreasingSubtree of int * pqtree DeQueue.t * int (* an increasing subtree is necessarily a Q-node *)
+ | IncreasingSubtree of int * pqtree DeQueue.t * int
+ (* an increasing subtree is necessarily a Q-node *)
let bounds = function
| ConstantSubtree (delta,_) -> (delta, delta)
diff --git a/lib/pqtrees/pqChainInsertion.mli b/lib/pqtrees/pqChainInsertion.mli
index 7be1df7..d220897 100644
--- a/lib/pqtrees/pqChainInsertion.mli
+++ b/lib/pqtrees/pqChainInsertion.mli
@@ -1,7 +1,84 @@
+open DataStruct
+
module Make :
functor (Chain : sig type t val s : t val d : t -> int end) ->
- sig
- val insert_chain : Chain.t PqTree.t -> Chain.t PqTree.t option
- end
+ sig
+ type elt = Chain.t
+ type pqtree = elt PqTree.t
+
+ val q_node : pqtree DeQueue.t -> pqtree
+
+
+ type external_subtree =
+ | ConstantSubtree of int * pqtree
+ | IncreasingSubtree of int * pqtree DeQueue.t * int
+
+ val bounds : external_subtree -> int * int
+ val d_min : external_subtree -> int
+ val d_max : external_subtree -> int
+ val tree_of_external_tree : external_subtree -> pqtree
+ val is_increasing_sequence : external_subtree DeQueue.t -> bool
+ val force_increasing_sequence : external_subtree DeQueue.t -> external_subtree DeQueue.t option
+ val expand_increasing_sequence : external_subtree DeQueue.t -> pqtree DeQueue.t
+ val sort_into_increasing_sequence : external_subtree DeQueue.t -> external_subtree list DeQueue.t
+
+ type sorting_group =
+ | Group of int * pqtree list
+ | Single of external_subtree
+
+ val group_d_min : sorting_group -> int
+ val group_d_max : sorting_group -> int
+ val sort_children_of_p_node : external_subtree DeQueue.t -> sorting_group DeQueue.t
+
+ val is_increasing_group_sequence : sorting_group DeQueue.t -> bool
+
+
+ type centered_subtree =
+ | Balanced of int * pqtree
+ | Skew of int * pqtree DeQueue.t * int
+
+ val tree_of_centered_tree : centered_subtree -> pqtree
+ val bounds_centered : centered_subtree -> int * int
+ val contract_centered : centered_subtree -> pqtree list
+
+ type result =
+ | NotRepresentable
+ | CenteredSubtree of centered_subtree
+ | ExternalSubtree of external_subtree
+
+ type classification =
+ | Unclassifiable
+ | Internal of external_subtree DeQueue.t * centered_subtree * external_subtree DeQueue.t
+ | External of external_subtree DeQueue.t
+
+ val classify : result list -> classification
+
+
+ type queue =
+ { left_bound : int;
+ trees : pqtree DeQueue.t;
+ right_bound : int
+ }
+
+ val init_queue : centered_subtree -> queue
+ val is_balanced : queue -> bool
+ val collapse : queue -> int * pqtree
+ val enqueue_right : sorting_group -> queue -> queue
+ val enqueue_left : sorting_group -> queue -> queue
+ val finalize : queue -> centered_subtree
+ val enqueue : sorting_group DeQueue.t -> queue -> result
+
+ val build_p_internal : centered_subtree -> external_subtree DeQueue.t -> result
+
+ val centered_subtree : int -> pqtree DeQueue.t -> int -> result
-val refine_by_distances : 'elt -> ('elt -> int) -> 'elt PqTree.t -> 'elt PqTree.t option
+ val build_q_internal : external_subtree DeQueue.t -> centered_subtree -> external_subtree DeQueue.t -> result
+ val contract_group : sorting_group -> pqtree DeQueue.t
+ val build_p_external : external_subtree DeQueue.t -> result
+ val build_q_external : external_subtree DeQueue.t -> result
+ val dispatch : pqtree -> result list -> result
+ val children : pqtree -> pqtree list
+ val solve : pqtree -> result
+ val insert_chain : pqtree -> pqtree option
+ end
+val refine_by_distances : 'elt -> ('elt -> int) -> 'elt PqTree.t -> 'elt PqTree.t option
diff --git a/lib/pqtrees/pqTree.mli b/lib/pqtrees/pqTree.mli
index 3fe47b2..875b7ed 100644
--- a/lib/pqtrees/pqTree.mli
+++ b/lib/pqtrees/pqTree.mli
@@ -165,7 +165,7 @@ end
(** A functor to build a function to enumerate over PQ-trees. *)
module MakeEnumerate :
- functor (RND : FeatCore.RandomSig.S) -> EnumerateSig with type elt = int
+ functor (_ : FeatCore.RandomSig.S) -> EnumerateSig with type elt = int
(** A pre-application of the [MakeEnumerate] functor, to enumerate of
diff --git a/robinson.opam b/robinson.opam
index a19265d..cef5503 100644
--- a/robinson.opam
+++ b/robinson.opam
@@ -11,7 +11,7 @@ doc: "https://url/to/documentation"
bug-reports: "https://github.com/username/reponame/issues"
depends: [
"ocaml"
- "dune" {>= "3.0"}
+ "dune" {>= "3.7"}
"fix"
"feat"
"RobinsonLib"
diff --git a/test/propertytest/chainInsertion.ml b/test/propertytest/chainInsertion.ml
new file mode 100644
index 0000000..ea4dd55
--- /dev/null
+++ b/test/propertytest/chainInsertion.ml
@@ -0,0 +1,43 @@
+open PqTreeLib
+open RobinsonTest
+open IntPqTree
+open DataStruct
+
+open QCheck2
+
+
+module IntSet = Set.Make(Int)
+
+let insert_interval interval pqtree =
+ let f i = if IntSet.mem i interval then 0 else 1 in
+ let s = IntSet.choose interval in
+ PqChainInsertion.refine_by_distances s f pqtree
+
+
+let rec is_an_interval ints = function
+ | [] -> IntSet.cardinal ints = 0
+ | (hd :: _) as permutation when IntSet.mem hd ints ->
+ let length = IntSet.cardinal ints in
+ (permutation |> MoreList.take length |> List.for_all (fun i -> IntSet.mem i ints))
+ && (permutation |> MoreList.drop length |> List.for_all (fun i -> not (IntSet.mem i ints)))
+ | _ :: permutation -> is_an_interval ints permutation
+
+
+let interval_insertion_does_not_fail (pqtree,interval) =
+ insert_interval (IntSet.of_list interval) pqtree
+ |> Option.is_some
+
+
+let test_interval_insertion_does_not_fail =
+ Test.make
+ ~name:"Chain insertion generalizes interval insertion in PQ-tree"
+ ~print:Print.(pair to_string (list int))
+ Gen.(int_range 1 100 >>= sized_pqtree_interval_gen)
+ interval_insertion_does_not_fail
+
+
+
+let tests =
+ [
+ test_interval_insertion_does_not_fail
+ ]
diff --git a/test/propertytest/main_prop_test.ml b/test/propertytest/main_prop_test.ml
index c96b693..99e03c7 100644
--- a/test/propertytest/main_prop_test.ml
+++ b/test/propertytest/main_prop_test.ml
@@ -3,7 +3,8 @@ let all_tests =
[ Pqtree.tests;
FunctionalBLtest.tests;
ImperativeBLTest.tests;
- Pivotpair.tests
+ Pivotpair.tests;
+ ChainInsertion.tests
]
let%test _ =
diff --git a/test/unit/chainInsertionTest.ml b/test/unit/chainInsertionTest.ml
index 6bf8858..95fa151 100644
--- a/test/unit/chainInsertionTest.ml
+++ b/test/unit/chainInsertionTest.ml
@@ -96,30 +96,63 @@ let%expect_test _ =
let d3 = [|66;5;56;0;15;77;3;82;56;60|]
let d4 = [|52;12;41;15;0;63;18;67;42;46|]
-let d5 = [|12;74;22;77;63;0;80;7;23;18|]
-let d6 = [|69;8;59;3;18;80;0;84;59;63|]
-let d7 = [|16;78;27;82;67;7;84;0;27;23|]
-let d8 = [|11;52;8;56;42;23;59;27;0;10|]
-let d9 = [|9;57;5;60;46;18;63;23;10;0|]
let%expect_test _ =
refine_by_distances 3 (fun n -> d3.(n)) tree_2
|> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
let%expect_test _ =
refine_by_distances 4 (fun n -> d4.(n)) tree_2
- |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
+ |> output; [%expect{|not an interval|}]
+
+
+
+let interval_distance elements i =
+ if List.mem i elements then 0
+ else 1
+
+let ptree1 =
+ P[Leaf 0;Leaf 1;
+ P[Leaf 2;Leaf 3;Leaf 4;
+ P[P[P[Leaf 5;Leaf 6];Leaf 7];Leaf 8;P[Leaf 9;Leaf 10];Leaf 11];
+ P[Leaf 12;Leaf 13]];Leaf 14;Leaf 15;Leaf 16;Leaf 17;
+ P[P[Leaf 18;Leaf 19];Leaf 20;Leaf 21];Leaf 22
+ ]
+
let%expect_test _ =
- refine_by_distances 5 (fun n -> d5.(n)) tree_2
- |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
+ refine_by_distances 10 (interval_distance [10;12]) ptree1
+ |> output; [%expect{| |}]
+
+
+let ptree2 =
+ P[Leaf 2;Leaf 3;Leaf 4;
+ P[P[P[Leaf 5;Leaf 6];Leaf 7];Leaf 8;P[Leaf 9;Leaf 10];Leaf 11];
+ P[Leaf 12;Leaf 13]]
+
let%expect_test _ =
- refine_by_distances 6 (fun n -> d6.(n)) tree_2
- |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
+ refine_by_distances 10 (interval_distance [10;12]) ptree2
+ |> output; [%expect{| |}]
+
+
+let ptree3 =
+ P[Leaf 2;
+ P[Leaf 7;P[Leaf 9;Leaf 10]];
+ P[Leaf 12;Leaf 13]
+ ]
+
let%expect_test _ =
- refine_by_distances 7 (fun n -> d7.(n)) tree_2
- |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
+ refine_by_distances 10 (interval_distance [10;12]) ptree3
+ |> output; [%expect{| |}]
+
+let ptree4 =
+ P[Leaf 7;P[Leaf 8; Leaf 9;Leaf 10];Leaf 11]
+
let%expect_test _ =
- refine_by_distances 8 (fun n -> d8.(n)) tree_2
- |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
+ refine_by_distances 10 (interval_distance [10;12]) ptree4
+ |> output; [%expect{| |}]
+
+let ptree5 =
+ P[Leaf 8; Leaf 9;Leaf 10]
+
let%expect_test _ =
- refine_by_distances 9 (fun n -> d9.(n)) tree_2
- |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
+ refine_by_distances 10 (interval_distance [10;12]) ptree5
+ |> output; [%expect{| |}]
diff --git a/test/unit/dune b/test/unit/dune
index 71b6de2..ace45e2 100644
--- a/test/unit/dune
+++ b/test/unit/dune
@@ -1,6 +1,6 @@
(library
(name RobinsonUnit)
- (libraries RobinsonLib RobinsonTest)
+ (libraries RobinsonLib ChainLib RobinsonTest)
(inline_tests)
(preprocess (pps ppx_inline_test ppx_expect))
)
diff --git a/test/unit/robinsonByChainTest.ml b/test/unit/robinsonByChainTest.ml
new file mode 100644
index 0000000..a3ac442
--- /dev/null
+++ b/test/unit/robinsonByChainTest.ml
@@ -0,0 +1,39 @@
+open RobinsonTest.IntPqTree
+
+open ChainLib
+
+
+let output result =
+ result
+ |> Option.map Canonical.canonical
+ |> Option.map to_string
+ |> Option.value ~default:"not an interval"
+ |> print_endline
+
+
+let print_order order =
+ let open Format in
+ fprintf std_formatter
+ "%a\n"
+ (pp_print_list ~pp_sep:(fun fmt () -> pp_print_string fmt ", ") pp_print_int)
+ order
+
+
+let diss1 = RandomDissimilarity.Toeplitz.toeplitz012 ~k:1 ~n:10
+
+let%expect_test _ =
+ begin match RobinsonByChain.find_compatible_order diss1 with
+ | Some order -> print_order order
+ | None -> Format.(fprintf std_formatter "not Robinson")
+ end;
+ [%expect{| 9, 8, 7, 6, 5, 4, 3, 2, 1, 0 |}]
+
+
+let diss2 = RandomDissimilarity.Toeplitz.toeplitz012 ~k:3 ~n:20
+
+let%expect_test _ =
+ begin match RobinsonByChain.find_compatible_order diss2 with
+ | Some order -> print_order order
+ | None -> Format.(fprintf std_formatter "not Robinson")
+ end;
+ [%expect{| 19, 18, 17, 16, 15, 14, 13, 12, 11, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1, 0 |}]
--
GitLab