From 0b84629592f0f423db061e986b5110206717e4d9 Mon Sep 17 00:00:00 2001
From: Guyslain <guyslain.naves@lis-lab.fr>
Date: Mon, 15 Jan 2024 13:57:43 +0100
Subject: [PATCH] add sampler for compatible orders of a pqtree
---
lib/pqtrees/pqTree.ml | 57 ++++++++++++++++++++++++++++++++++++++++++
lib/pqtrees/pqTree.mli | 16 ++++++++++--
2 files changed, 71 insertions(+), 2 deletions(-)
diff --git a/lib/pqtrees/pqTree.ml b/lib/pqtrees/pqTree.ml
index cec2e6c..c6b8926 100644
--- a/lib/pqtrees/pqTree.ml
+++ b/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 =
@@ -189,6 +190,54 @@ module MakeEnumerate =
include PQTEnum
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
diff --git a/lib/pqtrees/pqTree.mli b/lib/pqtrees/pqTree.mli
index 875b7ed..57eea92 100644
--- a/lib/pqtrees/pqTree.mli
+++ b/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.
--
GitLab