pqChainInsertion.ml

(** 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