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

lib/pqtrees/pqChainInsertion.mli

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

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
        )

lib/randomdissimilarity/fromPqtree.ml

@@ -59,7 +59,10 @@ let uniform n =
 
 
 let pqtree_from_intervals ~n ~k =
-  let pqtree = P (DataStruct.MoreList.range 0 (n-1) |> List.map (fun i -> Leaf i)) in 
+  let pqtree = 
+    if n = 1 then Leaf 0
+    else P (DataStruct.MoreList.range 0 (n-1) |> List.map (fun i -> Leaf i)) 
+  in 
   let index i = i in 
   let algo = ImperativeBL.get_algorithms pqtree index in
   let insert_interval () =

test/propertytest/chainInsertion.ml

@@ -32,6 +32,7 @@ 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))
+    ~count:1000
     Gen.(int_range 1 100 >>= sized_pqtree_interval_gen)
     interval_insertion_does_not_fail
     

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

test/propertytest/pqtree.ml

@@ -7,6 +7,29 @@ open QCheck2
 
 let print = IntPqTree.to_string
 
+
+let rec arity_checks = function 
+| Leaf _ -> true
+| P children -> List.length children >= 2 && List.for_all arity_checks children 
+| Q children -> List.length children >= 3 && List.for_all arity_checks children
+
+let test_arities_of_sampled_pqtree_are_valid = 
+  QCheck2.Test.make
+    ~name:"In sampled pqtrees, P nodes have >= 2 children, Q nodes >= 3 children"
+    ~count:100
+    ~print
+    Gen.(int_range 1 100 >>= sized_pqtree_gen)
+    arity_checks
+
+
+let test_shrinked_pq_trees_have_valid_arities = 
+  QCheck2.Test.make 
+    ~name:"Shrinked pqtrees have valid degrees"
+    ~print
+    pqtree_gen 
+    (fun tree -> Seq.fold_left (&&) true (Seq.map arity_checks (shrink tree)))
+
+
 let frontier_is_a_contained_permutation pqtree =
   CheckPermutation.contains_permutation pqtree (frontier pqtree)
 
@@ -65,7 +88,9 @@ let test_shuffled_frontier_is_a_contained_permutation =
 
 
 let tests = 
-  [ test_frontier_is_a_contained_permutation;
+  [ test_arities_of_sampled_pqtree_are_valid;
+    test_shrinked_pq_trees_have_valid_arities;
+    test_frontier_is_a_contained_permutation;
     test_sampled_permutation_is_contained_in_pqtree;
     test_shuffled_is_equal_to_pqtree;
     test_shuffled_frontier_is_a_contained_permutation

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