Skip to content
Snippets Groups Projects
Select Git revision
  • 68e6f2672f4c006498a8a79e44c124db0b4504e4
  • master default protected
2 results

pqChainInsertion.ml

Blame
  • 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