diff --git a/lib/datastruct/bucketSort.ml b/lib/datastruct/bucketSort.ml
new file mode 100644
index 0000000000000000000000000000000000000000..d8d745e7dfe0903a7c09a19c58541fe5e04d31bc
--- /dev/null
+++ b/lib/datastruct/bucketSort.ml
@@ -0,0 +1,23 @@
+module Make = functor (K : Map.OrderedType) ->
+struct
+
+ module M = Map.Make(K)
+
+ let add_to_list key value map =
+ M.update key
+ (function
+ | None -> Some [value]
+ | Some list -> Some (value::list)
+ )
+ map
+
+ let insert ~get_key map value =
+ add_to_list (get_key value) value map
+
+ let sort ~get_key values =
+ values
+ |> List.fold_left (insert ~get_key) M.empty
+ |> M.bindings
+ |> List.map snd
+
+end
diff --git a/lib/datastruct/bucketSort.mli b/lib/datastruct/bucketSort.mli
new file mode 100644
index 0000000000000000000000000000000000000000..b952de7a90c11a3ab88799b3cc68ade5c978f5d3
--- /dev/null
+++ b/lib/datastruct/bucketSort.mli
@@ -0,0 +1,5 @@
+module Make :
+ functor (K : Map.OrderedType) ->
+ sig
+ val sort : get_key:('a -> K.t) -> 'a list -> 'a list list
+ end
diff --git a/lib/pqtree/pqChainInsertion.ml b/lib/pqtree/pqChainInsertion.ml
new file mode 100644
index 0000000000000000000000000000000000000000..7c98da6162b4ff3d96c82007fa03d1bf227e86f4
--- /dev/null
+++ b/lib/pqtree/pqChainInsertion.ml
@@ -0,0 +1,361 @@
+(** This modules contains an algorithm that, given a PQ-tree T on X,
+ and a chain S_0 = {s}, S_1, ... S_k = X, builds a PQ-tree
+ representing all the permutations represented by T and for which
+ each S_i is an interval, if such a PQ-tree exists.
+
+ This could be done by the Booth-Lueker interval insertion
+ algorithm (functionalBL or imperativeBL), with k insertions. This
+ algorithm improves upon repeated insertion by having a linear-time
+ complexity.
+*)
+
+open DataStruct
+
+
+let consecutives list =
+ let rec go accu = function
+ | [] | [_] -> List.rev accu
+ | x::((y::_) as tail) -> go ((x,y)::accu) tail
+ in
+ go [] list
+
+let last = function
+| [] -> invalid_arg "last on empty list"
+| h::t -> List.fold_left (fun _ e -> e) h t
+
+
+
+module IntPair =
+struct
+ type t = (int * int)
+ let compare (x1,y1) (x2,y2) =
+ let diff = x1 - x2 in
+ if diff = 0 then y1 - y2
+ else diff
+end
+module IntPairSorter = BucketSort.Make(IntPair)
+module IntPairMap = Map.Make(IntPair)
+
+
+
+(* We parametrize the whole algorithm by the chain, encoded by a rank function d,
+ d(x) is such that x \in S_{d(x)} \setminus S_{d(x)-1}, and d(s) = 0.
+ *)
+module Make =
+ functor (Chain : sig type t val s : t val d : t -> int end) ->
+ struct
+
+
+ type elt = Chain.t
+ type pqtree = elt PqTree.t
+
+ open Chain
+ open PqTree
+
+ let q = function
+ | [_1;_2] as children -> P children
+ | children -> Q children
+
+ type external_subtree =
+ | ConstantSubtree of int * pqtree
+ | IncreasingSubtree of int * pqtree list * int (* an increasing subtree is necessarily a Q-node *)
+
+ let bounds = function
+ | ConstantSubtree (delta,_) -> (delta, delta)
+ | IncreasingSubtree (delta_min, _, delta_max) -> (delta_min, delta_max)
+ let d_min = function
+ | ConstantSubtree (delta,_) -> delta
+ | IncreasingSubtree (delta,_,_) -> delta
+ let d_max = function
+ | ConstantSubtree (delta, _) -> delta
+ | IncreasingSubtree (_,_,delta) -> delta
+
+ let amplitude subtrees = (d_min (List.hd subtrees), d_max (last subtrees))
+
+ let tree_of_external_tree = function
+ | ConstantSubtree (_,t) -> t
+ | IncreasingSubtree (_, children,_) -> q children
+
+
+ let is_increasing_sequence subtrees =
+ List.for_all
+ (fun (subtree1, subtree2) -> d_max subtree1 <= d_min subtree2)
+ (consecutives subtrees)
+
+ let force_increasing_sequence subtrees =
+ if is_increasing_sequence subtrees then Some subtrees
+ else let reversed = List.rev subtrees in
+ if is_increasing_sequence reversed then Some reversed
+ else None
+
+ let expand_increasing_sequence subtrees =
+ let contract = function
+ | ConstantSubtree (_,t) -> [t]
+ | IncreasingSubtree (_, children, _) -> children
+ in
+ List.concat_map contract subtrees
+
+
+ let sort_into_increasing_sequence subtrees =
+ IntPairSorter.sort ~get_key:bounds subtrees
+
+
+ type sorting_group =
+ | Group of int * pqtree list
+ | Single of external_subtree
+
+ let group_d_min = function
+ | Group (delta,_) -> delta
+ | Single subtree -> d_min subtree
+
+ let group_d_max = function
+ | Group (delta,_) -> delta
+ | Single subtree -> d_max subtree
+
+ let sort_children_of_p_node children =
+ let group = function
+ | (ConstantSubtree (delta,_)::_) as trees -> [ Group (delta, List.map tree_of_external_tree trees) ]
+ | trees -> List.map (fun t -> Single t) trees
+ in
+ children
+ |> sort_into_increasing_sequence
+ |> List.concat_map group
+
+
+ let is_increasing_group_sequence groups =
+ List.for_all
+ (fun (group1, group2) -> group_d_max group1 <= group_d_min group2)
+ (consecutives groups)
+
+ let groups_amplitude groups =
+ ( group_d_min (List.hd groups), group_d_max (last groups))
+
+
+
+
+
+
+ type centered_subtree =
+ | Balanced of int * pqtree
+ | Skew of int * pqtree list * int
+
+ let tree_of_centered_tree = function
+ | Balanced (_, tree) -> tree
+ | Skew (_,children,_) -> q children
+
+ let bounds_centered = function
+ | Balanced (delta,_) -> (delta, delta)
+ | Skew (delta0,_,delta1) -> (delta0,delta1)
+
+ let contract_centered = function
+ | Balanced (_,single) -> [ single ]
+ | Skew (_,children,_) -> children
+
+
+ type result =
+ | NotRepresentable
+ | CenteredSubtree of centered_subtree
+ | ExternalSubtree of external_subtree
+
+ type classification =
+ | Unclassifiable
+ | Internal of external_subtree list * centered_subtree * external_subtree list
+ | External of external_subtree list
+
+ let classify children =
+ let rec go classification children =
+ match classification, children with
+ | _, [] -> classification
+ | Unclassifiable, _
+ | _, NotRepresentable::_ -> Unclassifiable
+ | Internal (left, at_s, right), ExternalSubtree child::children ->
+ go (Internal (left, at_s, child::right)) children
+ | External left_of_s, ExternalSubtree child::children ->
+ go (External (child::left_of_s)) children
+ | External left_of_s, CenteredSubtree centered::children ->
+ go (Internal (left_of_s, centered, [])) children
+ | Internal _, CenteredSubtree _ :: _ -> Unclassifiable
+ in
+ go (External []) children
+
+
+
+
+ type queue =
+ { left_bound : int;
+ left_trees : pqtree list;
+ right_trees : pqtree list;
+ right_bound : int
+ }
+
+ let init_queue = function
+ | Balanced (bound, tree) ->
+ { left_bound = bound; left_trees = []; right_trees = [tree]; right_bound = bound }
+ | Skew (left_bound, right_trees, right_bound) ->
+ { left_bound; left_trees = []; right_trees; right_bound }
+
+ let is_balanced queue = queue.left_bound = queue.right_bound
+
+ let compact queue =
+ match List.rev_append queue.left_trees queue.right_trees with
+ | [single_child] when is_balanced queue -> Balanced (queue.left_bound, single_child)
+ | children when is_balanced queue -> Balanced (queue.left_bound, q children)
+ | children -> Skew (queue.left_bound, children, queue.right_bound)
+
+ let enqueue_right group queue =
+ let (right_trees, right_bound) = match group with
+ | Group (bound, children) -> (P children :: queue.right_trees, bound)
+ | Single (ConstantSubtree (bound, subtree)) -> (subtree :: queue.right_trees, bound)
+ | Single (IncreasingSubtree (_, subtrees, bound)) -> (List.rev_append subtrees queue.right_trees, bound)
+ in
+ { queue with right_trees; right_bound }
+
+ let enqueue_left group queue =
+ let (left_trees, left_bound) = match group with
+ | Group (bound, children) -> (P children :: queue.left_trees, bound)
+ | Single (ConstantSubtree (bound, subtree)) -> (subtree :: queue.left_trees, bound)
+ | Single (IncreasingSubtree (_,subtrees, bound)) -> (List.rev_append subtrees queue.left_trees, bound)
+ in
+ { queue with left_trees; left_bound }
+
+
+ let rec enqueue groups queue =
+ let max_bound = max queue.left_bound queue.right_bound in
+ match groups with
+ | [] ->
+ CenteredSubtree (compact queue)
+ | Group (dist,children) :: groups when dist >= max_bound ->
+ queue
+ |> compact
+ |> tree_of_centered_tree
+ |> (fun tree -> Balanced (dist, P (tree :: children)))
+ |> init_queue
+ |> enqueue groups
+ | single :: groups when group_d_min single >= max_bound ->
+ queue
+ |> compact
+ |> init_queue
+ |> enqueue_right single
+ |> enqueue groups
+ | any :: groups when group_d_min any >= queue.right_bound ->
+ queue
+ |> enqueue_right any
+ |> enqueue groups
+ | any :: groups when group_d_min any >= queue.left_bound ->
+ queue
+ |> enqueue_left any
+ |> enqueue groups
+ | _ (* when group_d_min any < min queue.left_bound queue.right_bound *) ->
+ NotRepresentable
+
+ let build_p_internal left_subtrees s_subtree right_subtrees =
+ let increasing_subtrees =
+ sort_children_of_p_node (List.rev_append left_subtrees right_subtrees)
+ in
+ enqueue increasing_subtrees (init_queue s_subtree)
+
+
+
+ let build_q_internal left_subtrees s_subtree right_subtrees =
+ if not (is_increasing_sequence left_subtrees && is_increasing_sequence right_subtrees) then
+ NotRepresentable
+ else
+ let (min_center, max_center) = bounds_centered s_subtree in
+ let (min_left, max_left) = amplitude left_subtrees in
+ let (min_right, max_right) = amplitude right_subtrees in
+ let lefts = expand_increasing_sequence left_subtrees in
+ let rights = expand_increasing_sequence right_subtrees in
+ let centered_subtree left_bound trees right_bound =
+ if left_bound = right_bound then
+ CenteredSubtree (Balanced (left_bound, q trees))
+ else
+ CenteredSubtree (Skew (left_bound, trees, right_bound))
+ in
+ if max(min_center, max_center) <= min (min_left, min_right) then
+ centered_subtree
+ max_left
+ (List.rev lefts @ [tree_of_centered_tree s_subtree] @ rights)
+ max_right
+ else if min_left >= min_center && max_center <= min_right then
+ centered_subtree
+ max_left
+ (List.rev lefts @ contract_centered s_subtree @ rights)
+ max_right
+ else if min_right >= min_center && max_center <= min_left then
+ centered_subtree
+ max_right
+ (List.rev rights @ contract_centered s_subtree @ lefts)
+ max_left
+ else NotRepresentable
+
+
+
+ let contract_group = function
+ | Group (_, subtrees) -> [ P subtrees ]
+ | Single (ConstantSubtree (_,subtree)) -> [ subtree ]
+ | Single (IncreasingSubtree (_,subtrees,_)) -> subtrees
+
+ let build_p_external unsorted_subtrees =
+ let groups = sort_children_of_p_node unsorted_subtrees in
+ match groups with
+ | _ when not (is_increasing_group_sequence groups) -> NotRepresentable
+ | [ Group (delta,children) ] ->
+ ExternalSubtree (ConstantSubtree (delta, P children))
+ | _ ->
+ let (delta_min, delta_max) = groups_amplitude groups in
+ let subtrees = List.concat_map contract_group groups in
+ ExternalSubtree (IncreasingSubtree (delta_min, subtrees, delta_max))
+
+
+
+ let build_q_external subtrees =
+ match force_increasing_sequence subtrees with
+ | None -> NotRepresentable
+ | Some subtrees ->
+ ExternalSubtree (
+ let (delta_min, delta_max) = amplitude subtrees in
+ if delta_min = delta_max then
+ ConstantSubtree (delta_min, Q (List.map tree_of_external_tree subtrees))
+ else
+ IncreasingSubtree (delta_min, expand_increasing_sequence subtrees, delta_max)
+ )
+
+
+
+ let dispatch root children =
+ match root, classify children with
+ | Leaf x, _ when x = s ->
+ CenteredSubtree (Balanced (0, Leaf s))
+ | Leaf x, _ ->
+ ExternalSubtree (ConstantSubtree (d x, Leaf x))
+ | _, Unclassifiable -> NotRepresentable
+ | P _, Internal (left_of_s, at_s, right_of_s) ->
+ build_p_internal left_of_s at_s (List.rev right_of_s)
+ | P _, External subtrees ->
+ build_p_external subtrees
+ | Q _, Internal (left_of_s, at_s, right_of_s) ->
+ build_q_internal left_of_s at_s (List.rev right_of_s)
+ | Q _, External subtrees ->
+ build_q_external subtrees
+
+
+ let children = function
+ | Leaf _ -> []
+ | P children
+ | Q children -> children
+
+ let rec solve tree =
+ children tree
+ |> List.map solve
+ |> dispatch tree
+
+ let insert_chain tree =
+ match solve tree with
+ | NotRepresentable -> None
+ | CenteredSubtree (Balanced (_,tree)) -> Some tree
+ | CenteredSubtree (Skew (_,trees,_)) -> Some (q trees)
+ | ExternalSubtree (ConstantSubtree (_, tree)) -> Some tree
+ | ExternalSubtree (IncreasingSubtree (_, trees, _)) -> Some (q trees)
+
+
+ end
diff --git a/lib/pqtree/pqChainInsertion.mli b/lib/pqtree/pqChainInsertion.mli
new file mode 100644
index 0000000000000000000000000000000000000000..f79fb5011d6be5c2e7618f451f746133277dc889
--- /dev/null
+++ b/lib/pqtree/pqChainInsertion.mli
@@ -0,0 +1,5 @@
+module Make :
+ functor (Chain : sig type t val s : t val d : t -> int end) ->
+ sig
+ val insert_chain : Chain.t PqTree.t -> Chain.t PqTree.t option
+ end