untested algorithm for inserting a chain in a pqtree

lib/datastruct/bucketSort.ml

+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 

lib/datastruct/bucketSort.mli

+module Make :
+  functor (K : Map.OrderedType) ->
+    sig
+      val sort : get_key:('a -> K.t) -> 'a list -> 'a list list
+    end

lib/pqtree/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

lib/pqtree/pqChainInsertion.mli

+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