diff --git a/lib/pqtrees/pqChainInsertion.ml b/lib/pqtrees/pqChainInsertion.ml
index efbd4376862815b283038e544cf5eb017a332847..ddef3c9b3f017e5b70587c1e39733e042050f889 100644
--- a/lib/pqtrees/pqChainInsertion.ml
+++ b/lib/pqtrees/pqChainInsertion.ml
@@ -224,8 +224,11 @@ module Make =
| Single (IncreasingSubtree (_,pqtrees,dmax)) ->
Central (left_bound, DeQueue.(centrals @< pqtrees), dmax)
- let push_any_side prefers_left (Central (_,centrals,_) as central) = function
- | Group (delta, pqtrees) -> Central (delta, DeQueue.singleton (P (DeQueue.first centrals :: pqtrees)), delta)
+ let push_any_side prefers_left (Central (l,centrals,r) as central) = function
+ | Group (delta, pqtrees) ->
+ Central (delta, DeQueue.singleton (P (DeQueue.first centrals :: pqtrees)), delta)
+ | Single (ConstantSubtree (delta, pqtree)) when delta = l && delta = r ->
+ Central (delta, DeQueue.singleton (P [DeQueue.first centrals; pqtree]), delta)
| group when prefers_left -> push_left central group
| group -> push_right central group
@@ -354,7 +357,7 @@ module Make =
| End s -> Some (Central (0, DeQueue.singleton (Leaf s), 0))
| PPath (subtrees, path_to_s) ->
let sorted_subtrees = sort_children_of_p_node subtrees in
- let new_bound = Bound.Bounded (group_d_min (DeQueue.first sorted_subtrees)) in
+ let new_bound = Bound.at_most (group_d_min (DeQueue.first sorted_subtrees)) in
let s_subtree =
if Bound.compare left_bound right_bound <= 0 then
fold_path (Bound.min new_bound left_bound) right_bound path_to_s
@@ -371,7 +374,7 @@ module Make =
let fits_left = Bound.is_bounded max_d left_bound in
let fits_right = Bound.is_bounded max_d right_bound in
let children = expand_increasing_sequence subtrees in
- if fits_left && (compare left_bound right_bound <= 0 || not fits_right) then
+ if fits_left && (Bound.compare left_bound right_bound <= 0 || not fits_right) then
fold_path new_bound right_bound path_to_s >>=
collapse new_bound right_bound >>= fun (_,trees, right) ->
Some (Central (max_d, DeQueue.(reverse children @> trees), right))
diff --git a/lib/pqtrees/pqChainInsertion.mli b/lib/pqtrees/pqChainInsertion.mli
index d0ab8c9a7195a7557a08a028db3044f9455d10e9..0eabebf3e51eb4039b83b373308fbaa2807d1f4a 100644
--- a/lib/pqtrees/pqChainInsertion.mli
+++ b/lib/pqtrees/pqChainInsertion.mli
@@ -1,4 +1,13 @@
-(* open DataStruct *)
+open DataStruct
+
+module Bound :
+ sig
+ type t = Infinity | Bounded of int
+ val at_most : int -> t
+ val compare : t -> t -> int
+ val min : t -> t -> t
+ val is_bounded : int -> t -> bool
+ end
module Make :
functor (Chain : sig type t val s : t val d : t -> int end) ->
@@ -6,79 +15,73 @@ module Make :
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 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 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 s_path =
+ | End of elt
+ | PPath of external_subtree DeQueue.t * s_path
+ | QPathIn of external_subtree DeQueue.t * s_path * external_subtree DeQueue.t
+ | QPathOut of s_path * external_subtree DeQueue.t
+
+ type result =
+ | NotRepresentable
+ | CenteredSubtree of s_path
+ | ExternalSubtree of external_subtree
+
+ type classification =
+ | Unclassifiable
+ | Internal of external_subtree DeQueue.t * s_path * external_subtree DeQueue.t
+ | External of external_subtree DeQueue.t
+
+ val classify : result list -> classification
+
+
+ type centered_subtree = Central of (int * pqtree DeQueue.t * int)
+
+ val left_bound_of : centered_subtree -> int
+ val right_bound_of : centered_subtree -> int
+ val central_tree : centered_subtree -> pqtree
+ val consolidate : centered_subtree -> centered_subtree
+ val reverse : centered_subtree -> centered_subtree
+ val push_left : centered_subtree -> sorting_group -> centered_subtree
+ val push_right : centered_subtree -> sorting_group -> centered_subtree
+ val push_any_side : bool -> centered_subtree -> sorting_group -> centered_subtree
+ val push : Bound.t -> Bound.t -> centered_subtree -> sorting_group -> centered_subtree option
+ val push_all_groups : Bound.t -> Bound.t -> centered_subtree -> sorting_group DeQueue.t -> centered_subtree option
+ val build_p_internal : Bound.t -> Bound.t -> sorting_group DeQueue.t -> centered_subtree -> centered_subtree option
+ 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 make_s_path : pqtree -> result
+ val collapse : Bound.t -> Bound.t -> centered_subtree -> (int * pqtree DeQueue.t * int) option
+ val fold_path : Bound.t -> Bound.t -> s_path -> centered_subtree option
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.ml b/lib/pqtrees/pqTree.ml
index 6884682e7f838f3a4589abb228ff3a00657ccaa6..cec2e6c4c4d7c8afe2057a6d11c7471cf8b9bda7 100644
--- a/lib/pqtrees/pqTree.ml
+++ b/lib/pqtrees/pqTree.ml
@@ -208,9 +208,9 @@ let rec shrink_a_child children =
| (P grandchildren as child, pre, post)
| (Q grandchildren as child, pre, post ) ->
let reset c = List.flatten [List.rev pre; c; post] in
- Seq.cons
- (reset grandchildren)
- (Seq.map (fun c -> reset [c]) (shrink child))
+ shrink child
+ |> Seq.map (fun new_child -> reset [new_child])
+ |> Seq.cons (reset grandchildren)
| (Leaf _,_,_) ->
Seq.empty
)
diff --git a/test/propertytest/pivotpair.ml b/test/propertytest/pivotpair.ml
index b3796520320294a4998c6246c5462f27ac546954..2de5f9f8fb7942e2230c8014a1e6c27ae43f43c7 100644
--- a/test/propertytest/pivotpair.ml
+++ b/test/propertytest/pivotpair.ml
@@ -56,5 +56,5 @@ let test_blocks_discriminates_triplets =
let tests =
[
test_pivotpair_algorithm_terminates;
- test_blocks_discriminates_triplets;
+ (* test_blocks_discriminates_triplets; *)
]
diff --git a/test/testlib/intPqTree.ml b/test/testlib/intPqTree.ml
index b46c17a83bdbcb64d6791e14eb4852e2f2aee80f..6472c0289873db658b3b49797ea0704f0eb7ce09 100644
--- a/test/testlib/intPqTree.ml
+++ b/test/testlib/intPqTree.ml
@@ -78,6 +78,7 @@ let sized_pqtree_gen size =
make_primitive
~gen:(sized_uniform_gen size)
~shrink:PqTree.shrink;
+ (* ~shrink:(fun _ -> Seq.empty); *)
(int_range 1 10 >>= fun k -> sized_interval_insertion_gen k size)
]
diff --git a/test/unit/chainInsertionTest.ml b/test/unit/chainInsertionTest.ml
index 03deeead9c115f5705543bc3686c8b874e812cef..47f2d2d76857124efa32af2c8bfd6a7ad5529458 100644
--- a/test/unit/chainInsertionTest.ml
+++ b/test/unit/chainInsertionTest.ml
@@ -162,3 +162,47 @@ let ptree4 =
let%expect_test _ =
refine_by_distances 10 (interval_distance [8;10]) ptree4
|> output; [%expect{| P[Leaf 7;P[P[Leaf 8;Leaf 10];Leaf 9];Leaf 11] |}]
+
+
+let ptree5 =
+ P[
+ Leaf 4;Leaf 23;Leaf 25;Leaf 29;Leaf 33;Leaf 35;Leaf 38;
+ Q[
+ P[Leaf 15;Leaf 0;Leaf 13;Leaf 37;Leaf 9;Leaf 22;Leaf 11;Leaf 16;
+ Leaf 7;Leaf 24;Leaf 20;Leaf 30;Leaf 21;Leaf 6;Leaf 27;Leaf 39;
+ Leaf 28;
+ P[Leaf 26;Leaf 17;Leaf 34;Leaf 5];
+ P[Leaf 10;Leaf 3]
+ ];
+ P[Leaf 14;Leaf 19;Leaf 1;Leaf 8;Leaf 2;Leaf 31];
+ P[Leaf 12;Leaf 32;Leaf 36;Leaf 18]
+ ]
+ ]
+
+let%expect_test _ =
+ refine_by_distances 0 (interval_distance [0; 20; 37; 15; 14; 19; 31; 1; 2; 8; 12; 36; 32; 18; 29]) ptree5
+ |> output; [%expect{|
+ P[Q[P[P[Leaf 3;Leaf 10];P[Leaf 5;Leaf 17;Leaf 26;Leaf 34];Leaf 6;Leaf 7;
+ Leaf 9;Leaf 11;Leaf 13;Leaf 16;Leaf 21;Leaf 22;Leaf 24;Leaf 27;
+ Leaf 28;Leaf 30;Leaf 39];P[Leaf 0;Leaf 15;Leaf 20;Leaf 37];
+ P[Leaf 1;Leaf 2;Leaf 8;Leaf 14;Leaf 19;Leaf 31];
+ P[Leaf 12;Leaf 18;Leaf 32;Leaf 36];Leaf 29];Leaf 4;Leaf 23;Leaf 25;
+ Leaf 33;Leaf 35;Leaf 38] |}]
+
+
+let ptree6 =
+ P[
+ Leaf 1;Leaf 2;Leaf 3;
+ Q[
+ P[Leaf 4;Leaf 5;Leaf 6;Leaf 7];
+ P[Leaf 8;Leaf 9];
+ P[Leaf 10;Leaf 11]
+ ]
+ ]
+
+let%expect_test _ =
+ refine_by_distances 6 (interval_distance [2; 4; 6; 8; 9; 10; 11]) ptree6
+ |> output; [%expect{|
+ P[Leaf 1;
+ Q[Leaf 2;P[Leaf 10;Leaf 11];P[Leaf 8;Leaf 9];P[Leaf 4;Leaf 6];
+ P[Leaf 5;Leaf 7]];Leaf 3] |}]