add sampler for compatible orders of a pqtree

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,54 @@ module MakeEnumerate =
       let enumeration = 
         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))
+           
+            
+      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.mapi (fun i _ -> i) 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 +250,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.