diff --git a/dune-project b/dune-project
index be2fc95e69ce876d72bbd15895e7b58745600308..2efbe51f707406ca26e9c15bb9a503ce1fc7afac 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 998773dec1a3f26e534455df86bea503763e04e3..781a8088285b03dae54530a291be7638634c2869 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 7be1df77f13c0835fb4098935c8e78cc7661e092..d220897ced07f2911f6ced5e5a05c6c9dc33c311 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 3fe47b2050e62caaec8e0360071e386a128a9d5c..875b7ed8c72b74d7f198b867616b90c7ac42e72e 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 a19265d7839c3987e2f085ab7ab71b3d5aef0bb6..cef5503597f781ec775e454fffd94185b0505b3c 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 0000000000000000000000000000000000000000..ea4dd55cfe8e3e08d812dde42d3e5e4e2fd74f06
--- /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 c96b6938feebe3090db08bdd888b02016d373e98..99e03c758536c0d6c37e7494e853b4f8d1f583ca 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 6bf88586e3f4a39a88f2b2ef30df2dd6647d2cb2..95fa15190f333a6bf71717d9627a0968f782b461 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 71b6de2f84fd39542a93958a3782dfece325bec8..ace45e2394cf230180429c86344318146084b418 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 0000000000000000000000000000000000000000..a3ac4428b1fa5c3749d3c009ed916f6463709e35
--- /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 |}]