more tests on chain insertion

lib/pqtrees/pqTree.ml

@@ -192,23 +192,13 @@ module MakeEnumerate =
         PQTEnum.map to_pqtree enum_skeleton
 
 
-      let extensions list = 
-        let rec go previous = function 
-        | [] -> []
-        | this::next -> (this, List.rev_append previous next) :: go (this::previous) next
-        in 
-        go [] list
-
-
       let rec enum_permutations = 
         let open PQTIFSeq in 
         function 
-        | [] -> singleton [] 
-        | elements ->
-            exists 
-              (extensions elements)
-              (fun (head,tail) -> map (List.cons head) (enum_permutations tail))
-           
+        | 0 -> singleton [] 
+        | n ->
+            product (up 0 n) (enum_permutations (n-1)) 
+            |> map (fun (i,sigma) -> i :: List.map (fun j -> if i = j then (n-1) else j) sigma)
             
       let rec big_product = 
         let open PQTIFSeq in 
@@ -226,7 +216,7 @@ module MakeEnumerate =
         match pqtree with 
         | Leaf x -> singleton [x]
         | P children -> 
-            let permutations = enum_permutations (List.mapi (fun i _ -> i) children) in
+            let permutations = enum_permutations (List.length children) in
             let orders = big_product (List.map compatible_orders children) in 
             product permutations orders
             |> map (fun (permutation, orders) -> apply_permutation permutation orders |> List.concat)

test/propertytest/chainInsertion.ml

@@ -45,6 +45,12 @@ let rec zip list1 list2 = match list1, list2 with
 
   
 
+let function_from_list assocs = 
+  let map = 
+    List.fold_left (fun map (arg,res) -> IntMap.add arg res map) IntMap.empty assocs 
+  in 
+  fun arg -> IntMap.find arg map
+
 let print_tree_and_chain = 
   Print.(pair to_string (pair int (list (pair int int))))
 
@@ -68,7 +74,7 @@ let gen_tree_and_chain =
 
 
 let new_valid_permutation_is_old_valid_permutation (pqtree, (source,distances)) =
-  let f i = List.assoc i distances in  
+  let f = function_from_list distances in  
   match PqChainInsertion.refine_by_distances source f pqtree with
   | None -> false
   | Some new_pqtree -> Ref.is_refinement new_pqtree pqtree 
@@ -77,13 +83,41 @@ let test_new_valid_permutation_is_old_valid_permutation =
   Test.make
     ~name:"Chain insertion returns a refinement of the original PQ-tree"
     ~print:print_tree_and_chain
-    ~count:1000
+    ~count:100
     gen_tree_and_chain 
     new_valid_permutation_is_old_valid_permutation
     
   
 
+let rec is_increasing = function 
+| [] | [_] -> true
+| x::y::tail -> x <= y && is_increasing (y::tail)
+
+let rec is_bitonic = function 
+| [] | [_] -> true
+| x::y::tail when x >= y -> is_bitonic (y::tail)
+| _::y::tail -> is_increasing (y::tail)
+
+
 
+let permutations_are_bitonic (pqtree, (source, distances)) =
+  let f = function_from_list distances in 
+  match PqChainInsertion.refine_by_distances source f pqtree with 
+  | None -> false
+  | Some pqtree -> 
+      Seq.repeat ()
+      |> Seq.take 10 
+      |> Seq.map (fun _ -> PqTree.sample_compatible_order pqtree)  
+      |> Seq.map (List.map f)
+      |> Seq.for_all is_bitonic
+
+let test_permutations_are_bitonic = 
+  Test.make 
+    ~name:"Permutations of refined pqtree are bitonic relative to the distance to the source"
+    ~print:print_tree_and_chain 
+    ~count:1000
+    gen_tree_and_chain 
+    permutations_are_bitonic
 
 
 
@@ -91,4 +125,5 @@ let tests =
   [ 
     test_interval_insertion_does_not_fail;
     test_new_valid_permutation_is_old_valid_permutation;
+    test_permutations_are_bitonic
   ]

test/propertytest/pqtree.ml

@@ -85,6 +85,17 @@ let test_shuffled_frontier_is_a_contained_permutation =
     shuffled_frontier_is_a_contained_permutation
 
 
+let sampled_compatible_order_is_a_valid_permutation (permutation, pqtree) =
+  CheckPermutation.contains_permutation pqtree permutation  
+
+let test_sampled_compatible_order_is_a_valid_permutation = 
+  QCheck2.Test.make 
+    ~name:"Sampled compatible order are valid permutations"
+    ~print:QCheck2.Print.(pair (list int) print)
+    ~count:100
+    Gen.(pqtree_gen >>= fun pqtree -> return (PqTree.sample_compatible_order pqtree, pqtree))
+    sampled_compatible_order_is_a_valid_permutation
+
 
 
 let tests = 
@@ -93,5 +104,6 @@ let tests =
     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_shuffled_frontier_is_a_contained_permutation;
+    test_sampled_compatible_order_is_a_valid_permutation
   ]