Select Git revision
pqChainInsertion.ml
pqChainInsertion.ml 12.04 KiB
(** 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