lib/pqtrees/pqTree.ml

@@ -126,6 +126,7 @@ sig
   type elt 
   include FeatCore.EnumSig.ENUM
   val enumeration : elt t enum 
+  val compatible_orders : 'elt t -> 'elt list IFSeq.seq
 end
 
 module MakeEnumerate =
@@ -190,6 +191,44 @@ module MakeEnumerate =
       let enumeration = 
         PQTEnum.map to_pqtree enum_skeleton
 
+
+      let rec enum_permutations = 
+        let open PQTIFSeq in 
+        function 
+        | 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 
+        function 
+        | [] -> singleton []
+        | head::tail -> 
+            product head (big_product tail)
+            |> map (fun (sample_head, samples_tail) -> sample_head :: samples_tail)
+
+      let apply_permutation (sigma : int list) (elements : 'a list) : 'a list = 
+        List.map (List.nth elements) sigma
+
+      let rec compatible_orders pqtree =
+        let open PQTIFSeq in 
+        match pqtree with 
+        | Leaf x -> singleton [x]
+        | P children -> 
+            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)
+        | Q children -> 
+            let left_to_right_seq = 
+              children 
+              |> List.map compatible_orders
+              |> big_product 
+              |> map List.concat 
+            in 
+            sum (left_to_right_seq) (left_to_right_seq |> map List.rev)
+                        
   end 
 
 
@@ -201,6 +240,14 @@ let sample size =
   | _ -> invalid_arg (Format.sprintf "PqTree.sample %d" size)
 
 
+let sample_compatible_order pqtree = 
+  let sequence = Enum.compatible_orders pqtree in 
+  match Seq.uncons (Enum.PQTIFSeq.sample 1 sequence Seq.empty) with 
+  | Some (sample,_) -> sample 
+  | None -> assert false
+
+
+
 let rec shrink_a_child children = 
   MoreList.extend children 
   |> List.to_seq 

lib/pqtrees/pqTree.mli

@@ -61,7 +61,8 @@ val count_permutations : 'elt t -> Big_int_Z.big_int
 (** A random permutation among those encoded by a given PQ-tree.
 
     @param tree a PQ-tree
-    @return a random permutation, as a list of elements, chosen uniformly randomly among all permutations encoded by [tree]
+    @return a random permutation, as a list of elements, chosen
+      uniformly randomly among all permutations encoded by [tree]
 *)
 val sample_permutation : 'elt t -> 'elt list 
 
@@ -71,7 +72,7 @@ val sample_permutation : 'elt t -> 'elt list
     consecutively in any permutation in the set {%$\mathcal{P}$%}. The
     interval is sampled by first sampling a uniformly chosen
     permutation, then sampling in this permutation a random
-    subsequence of elemnts. This sampling is not uniform in general.
+    subsequence of elements. This sampling is not uniform in general.
 
     @param tree a PQ-tree
     @return a random interval for the set of permutations encoded by [tree]
@@ -161,6 +162,9 @@ sig
 
   (** An enumeration of all PQ-trees over some type of elements *)
   val enumeration : elt t enum 
+
+  (** A sequence of all compatible orders of a PQ-tree. *)
+  val compatible_orders : 'elt t -> 'elt list IFSeq.seq
 end
 
 (** A functor to build a function to enumerate over PQ-trees. *)
@@ -183,6 +187,14 @@ module Enum : EnumerateSig with type elt = int
 val sample : int -> int t 
 
 
+(** Sample a uniformly random compatible order from a PQ-tree. 
+    
+    @param pqtree the pqtree from which a compatible order must be sampled.
+    @return A uniformly random compatible order of [pqtree].
+*)
+val sample_compatible_order : 'elt t -> 'elt list 
+
+
 (** A type for modules providing functions to define a canonical
     representation of equivalent PQ-trees, where two PQ-trees are
     equivalent when they encode the same set of permutations.

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
   ]