From 4c4b42e4001f3030e700654957e171a6d603d794 Mon Sep 17 00:00:00 2001
From: Guyslain <guyslain.naves@lis-lab.fr>
Date: Wed, 10 Jan 2024 10:09:03 +0100
Subject: [PATCH] new version of the chain insertion algorithm, not yet tested
---
lib/pqtrees/pqChainInsertion.ml | 334 ++++++++++++++++++-------------
lib/pqtrees/pqChainInsertion.mli | 114 +++++------
2 files changed, 247 insertions(+), 201 deletions(-)
diff --git a/lib/pqtrees/pqChainInsertion.ml b/lib/pqtrees/pqChainInsertion.ml
index 781a808..498e1d1 100644
--- a/lib/pqtrees/pqChainInsertion.ml
+++ b/lib/pqtrees/pqChainInsertion.ml
@@ -26,6 +26,32 @@ module IntPairMap = Map.Make(IntPair)
+
+module Bound = struct
+ type t =
+ | Infinity
+ | Bounded of int
+
+
+ let at_most value = Bounded value
+
+ let compare bound1 bound2 =
+ match bound1, bound2 with
+ | Bounded _, Infinity -> -1
+ | Infinity, Bounded _ -> 1
+ | Bounded b1, Bounded b2 -> Int.compare b1 b2
+ | Infinity, Infinity -> 0
+
+ let min bound1 bound2 =
+ if compare bound1 bound2 <= 0 then bound1 else bound2
+
+ let is_bounded value = function
+ | Infinity -> true
+ | Bounded b -> value <= b
+
+
+end
+
(* 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.
*)
@@ -125,32 +151,23 @@ module Make =
+ type s_path =
+ | End of elt
+ | PPath of external_subtree DeQueue.t * s_path
+ | QPathIn of external_subtree DeQueue.t * s_path * external_subtree DeQueue.t
+ | QPathOut of s_path * external_subtree DeQueue.t
- type centered_subtree =
- | Balanced of int * pqtree
- | Skew of int * pqtree DeQueue.t * int
-
- let tree_of_centered_tree = function
- | Balanced (_, tree) -> tree
- | Skew (_,children,_) -> q_node children
-
- let bounds_centered = function
- | Balanced (delta,_) -> (delta, delta)
- | Skew (delta0,_,delta1) -> (delta0,delta1)
- let contract_centered = function
- | Balanced (_,single) -> [ single ]
- | Skew (_,children,_) -> DeQueue.to_list children
type result =
| NotRepresentable
- | CenteredSubtree of centered_subtree
+ | CenteredSubtree of s_path
| ExternalSubtree of external_subtree
type classification =
| Unclassifiable
- | Internal of external_subtree DeQueue.t * centered_subtree * external_subtree DeQueue.t
+ | Internal of external_subtree DeQueue.t * s_path * external_subtree DeQueue.t
| External of external_subtree DeQueue.t
let classify children =
@@ -160,8 +177,8 @@ module Make =
| _, [] -> classification
| Unclassifiable, _
| _, NotRepresentable::_ -> Unclassifiable
- | Internal (left, at_s, right), ExternalSubtree child::children ->
- go (Internal (left, at_s, push_right right child)) children
+ | Internal (left,path_to_s,right) , ExternalSubtree child::children ->
+ go (Internal (left, path_to_s, push_right right child)) children
| External left_of_s, ExternalSubtree child::children ->
go (External (push_right left_of_s child)) children
| External left_of_s, CenteredSubtree centered::children ->
@@ -170,130 +187,87 @@ module Make =
in
go (External empty) children
+
+
+ type centered_subtree = Central of (int * pqtree DeQueue.t * int)
+
+ let left_bound_of (Central (b,_,_)) = b
+ let right_bound_of (Central (_,_,b)) = b
+
+ let central_tree (Central (_,subtrees,_)) =
+ match DeQueue.view_left subtrees with
+ | Some (single,queue) when DeQueue.is_empty queue -> single
+ | Some _ -> q_node subtrees
+ | None -> assert false
+
+ let compact (Central (left_bound,_,right_bound) as tree) =
+ Central (left_bound, DeQueue.singleton (central_tree tree), right_bound)
+
+ let reverse (Central (left_bound, subtrees, right_bound)) =
+ Central (right_bound, DeQueue.reverse subtrees, left_bound)
+
+ let push_left (Central (_, centrals, right_bound)) = function
+ | Group (delta, pqtrees) ->
+ Central (delta, DeQueue.push_left (PqTree.P pqtrees) centrals, right_bound)
+ | Single (ConstantSubtree (delta, pqtree)) ->
+ Central (delta, DeQueue.push_left pqtree centrals,right_bound)
+ | Single (IncreasingSubtree (_, pqtrees, dmax)) ->
+ Central (dmax, DeQueue.(reverse pqtrees @> centrals), right_bound)
+
+ let push_right (Central (left_bound, centrals, _)) = function
+ | Group (delta, pqtrees) ->
+ Central (left_bound, DeQueue.push_right centrals (PqTree.P pqtrees), delta)
+ | Single (ConstantSubtree (delta, pqtree)) ->
+ Central (left_bound, DeQueue.push_right centrals pqtree, delta)
+ | Single (IncreasingSubtree (_,pqtrees,dmax)) ->
+ Central (left_bound, DeQueue.(centrals @< pqtrees), dmax)
+ let push_any_side prefers_left (Central (_,centrals,_) as central) = function
+ | Group (delta, pqtrees) -> Central (delta, DeQueue.singleton (P (DeQueue.first centrals :: pqtrees)), delta)
+ | group when prefers_left -> push_left central group
+ | group -> push_right central group
+
+
+ let push bound_left bound_right central group =
+ let d_min = group_d_min group and d_max = group_d_max group in
+ let central =
+ if d_min >= max (left_bound_of central) (right_bound_of central) then
+ compact central
+ else
+ central
+ in
+ let no_overleft = Bound.is_bounded d_max bound_left in
+ let no_overright = Bound.is_bounded d_max bound_right in
+ let is_left_compatible = d_min >= left_bound_of central && no_overleft in
+ let is_right_compatible = d_min >= right_bound_of central && no_overright in
+ let prefers_left = left_bound_of central >= right_bound_of central in
+ if is_left_compatible && is_right_compatible then
+ Some (push_any_side prefers_left central group)
+ else if is_left_compatible then
+ Some (push_left central group)
+ else if is_right_compatible then
+ Some (push_right central group)
+ else if d_min >= left_bound_of central && no_overright then
+ Some (push_right (reverse central) group)
+ else if d_min >= right_bound_of central && no_overleft then
+ Some (push_left (reverse central) group)
+ else
+ None
- type queue =
- { left_bound : int;
- trees : pqtree DeQueue.t;
- right_bound : int
- }
-
- let init_queue = function
- | Balanced (bound, tree) ->
- { left_bound = bound; trees = DeQueue.(push_left tree empty); right_bound = bound }
- | Skew (left_bound, trees, right_bound) ->
- { left_bound; trees; right_bound }
-
- let is_balanced queue = queue.left_bound = queue.right_bound
-
- let collapse queue =
- match DeQueue.view_left queue.trees with
- | Some (child, trees) when DeQueue.is_empty trees && is_balanced queue ->
- (queue.left_bound, child)
- | _ ->
- (max queue.left_bound queue.right_bound, q_node queue.trees)
-
- let enqueue_right group queue =
- let (trees, right_bound) = match group with
- | Group (bound, children) -> (DeQueue.push_right queue.trees (P children), bound)
- | Single (ConstantSubtree (bound, subtree)) -> (DeQueue.push_right queue.trees subtree, bound)
- | Single (IncreasingSubtree (_, subtrees, bound)) -> DeQueue.(queue.trees @< subtrees, bound)
- in
- { queue with trees; right_bound }
+ let push_all_groups bound_left bound_right central sorted_groups =
+ let optional_push optional_central group =
+ match optional_central with
+ | Some central -> push bound_left bound_right central group
+ | None -> None
+ in
+ DeQueue.fold_lr optional_push (Some central) sorted_groups
- let enqueue_left group queue =
- let (trees, left_bound) = match group with
- | Group (bound, children) -> (DeQueue.push_left (P children) queue.trees, bound)
- | Single (ConstantSubtree (bound, subtree)) -> (DeQueue.push_left subtree queue.trees, bound)
- | Single (IncreasingSubtree (_,subtrees, bound)) -> DeQueue.(reverse subtrees @> queue.trees, bound)
- in
- { queue with trees; left_bound }
-
- let finalize queue =
- match DeQueue.view_left queue.trees with
- | Some (single, others) when DeQueue.is_empty others && is_balanced queue ->
- Balanced (queue.left_bound, single)
- | _ when is_balanced queue ->
- Balanced (queue.left_bound, q_node queue.trees)
- | _ ->
- Skew (queue.left_bound, queue.trees, queue.right_bound)
-
+
+ let build_p_internal left_bound right_bound children center_child =
+ push_all_groups left_bound right_bound center_child children
- let rec enqueue groups queue =
- let max_bound = max queue.left_bound queue.right_bound in
- match DeQueue.view_left groups with
- | None ->
- CenteredSubtree (finalize queue)
- | Some (Group (dist,children), groups) when dist >= max_bound ->
- queue
- |> collapse
- |> (fun (_,tree) -> Balanced (dist, P (tree :: children)))
- |> init_queue
- |> enqueue groups
- | Some (single, groups) when group_d_min single >= max_bound ->
- queue
- |> collapse
- |> (fun (delta, tree) -> init_queue (Balanced (delta, tree)))
- |> enqueue_right single
- |> enqueue groups
- | Some (any, groups) when group_d_min any >= queue.right_bound ->
- queue
- |> enqueue_right any
- |> enqueue groups
- | Some (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 central_subtree external_subtrees =
- let increasing_subtrees = sort_children_of_p_node external_subtrees in
- enqueue increasing_subtrees (init_queue central_subtree)
-
-
-
- let centered_subtree left_bound trees right_bound =
- if left_bound = right_bound then
- CenteredSubtree (Balanced (left_bound, q_node trees))
- else
- CenteredSubtree (Skew (left_bound, trees, right_bound))
- let build_q_internal left_subtrees s_subtree right_subtrees =
- let open DeQueue in
- if not (is_increasing_sequence left_subtrees && is_increasing_sequence right_subtrees) then
- NotRepresentable
- else
- let (left_center_bound, right_center_bound) = bounds_centered s_subtree in
- let check central_bound subtrees = match view_left subtrees with
- | None -> Some central_bound
- | Some (subtree,_) when d_min subtree < central_bound -> None
- | Some _ -> Some (d_max (last subtrees))
- in
- let lefts = expand_increasing_sequence left_subtrees in
- let rights = expand_increasing_sequence right_subtrees in
- match check left_center_bound left_subtrees, check right_center_bound right_subtrees,
- check left_center_bound right_subtrees, check right_center_bound left_subtrees
- with
- | Some left_bound, Some right_bound, Some _, Some _ ->
- centered_subtree
- left_bound
- DeQueue.(reverse lefts @> singleton (tree_of_centered_tree s_subtree) @< rights)
- right_bound
- | Some left_bound, Some right_bound, _, _ ->
- centered_subtree
- left_bound
- DeQueue.(reverse lefts @> of_list (contract_centered s_subtree) @< rights)
- right_bound
- | _, _, Some left_bound, Some right_bound ->
- centered_subtree
- left_bound
- DeQueue.(reverse rights @> of_list (contract_centered s_subtree) @< lefts)
- right_bound
- | _,_,_,_ ->
- NotRepresentable
@@ -333,16 +307,23 @@ module Make =
let dispatch root children =
match root, classify children with
| Leaf x, _ when x = s ->
- CenteredSubtree (Balanced (0, Leaf s))
+ CenteredSubtree (End s)
| Leaf x, _ ->
ExternalSubtree (ConstantSubtree (d x, Leaf x))
| _, Unclassifiable -> NotRepresentable
| P _, Internal (left_of_s, at_s, right_of_s) ->
- build_p_internal at_s (DeQueue.append_to_left left_of_s right_of_s)
+ CenteredSubtree (PPath (DeQueue.append_to_left left_of_s right_of_s, at_s))
| P _, External subtrees ->
build_p_external subtrees
| Q _, Internal (left_of_s, at_s, right_of_s) ->
- build_q_internal (DeQueue.reverse left_of_s) at_s right_of_s
+ CenteredSubtree (
+ if DeQueue.is_empty left_of_s then
+ QPathOut (at_s, right_of_s)
+ else if DeQueue.is_empty right_of_s then
+ QPathOut (at_s, DeQueue.reverse left_of_s)
+ else
+ QPathIn (DeQueue.reverse left_of_s, at_s, right_of_s)
+ )
| Q _, External subtrees ->
build_q_external subtrees
@@ -352,16 +333,81 @@ module Make =
| P children
| Q children -> children
- let rec solve tree =
+ let rec make_s_path tree =
children tree
- |> List.map solve
+ |> List.map make_s_path
|> dispatch tree
+
+ let collapse bound1 bound2 (Central (left, trees, right)) =
+ let max_d = max left right in
+ if Bound.is_bounded max_d bound1 && Bound.is_bounded max_d bound2 then
+ Some (left, DeQueue.singleton (q_node trees), right)
+ else Some (left,trees,right)
+
+
+ let rec fold_path left_bound right_bound =
+ let (>>=) e f = Option.bind e f in
+ function
+ | End s -> Some (Central (0, DeQueue.singleton (Leaf s), 0))
+ | PPath (subtrees, path_to_s) ->
+ let sorted_subtrees = sort_children_of_p_node subtrees in
+ let new_bound = Bound.Bounded (group_d_min (DeQueue.first sorted_subtrees)) in
+ let s_subtree =
+ if Bound.compare left_bound right_bound <= 0 then
+ fold_path (Bound.min new_bound left_bound) right_bound path_to_s
+ else
+ fold_path left_bound (Bound.min new_bound right_bound) path_to_s
+ in
+ Option.bind
+ s_subtree
+ (build_p_internal left_bound right_bound sorted_subtrees)
+ | QPathOut (path_to_s, subtrees) ->
+ if not (is_increasing_sequence subtrees) then None else
+ let new_bound = Bound.at_most (d_min (DeQueue.first subtrees)) in
+ let max_d = d_max (DeQueue.last subtrees) in
+ let fits_left = Bound.is_bounded max_d left_bound in
+ let fits_right = Bound.is_bounded max_d right_bound in
+ let children = expand_increasing_sequence subtrees in
+ if fits_left && (compare left_bound right_bound <= 0 || not fits_right) then
+ fold_path new_bound right_bound path_to_s >>=
+ collapse new_bound right_bound >>= fun (_,trees, right) ->
+ Some (Central (max_d, DeQueue.(reverse children @> trees), right))
+ else if fits_right && (compare left_bound right_bound >= 0 || not fits_left) then
+ fold_path left_bound new_bound path_to_s >>= fun (Central (left,trees,_)) ->
+ Some (Central (left, DeQueue.(trees @< children), max_d))
+ else None
+
+ | QPathIn (left_subtrees, path_to_s, right_subtrees) ->
+ if not (is_increasing_sequence left_subtrees)
+ || not (is_increasing_sequence right_subtrees)
+ then None else
+ let new_bound_left = Bound.Bounded (d_min (DeQueue.first left_subtrees)) in
+ let new_bound_right = Bound.Bounded (d_min (DeQueue.first right_subtrees)) in
+ let max_d_left = d_max (DeQueue.last left_subtrees) in
+ let max_d_right = d_max (DeQueue.last right_subtrees) in
+ let left_children = expand_increasing_sequence left_subtrees in
+ let right_children = expand_increasing_sequence right_subtrees in
+ if Bound.(is_bounded max_d_left left_bound && is_bounded max_d_right right_bound) then
+ fold_path new_bound_left new_bound_right path_to_s >>=
+ collapse new_bound_left new_bound_right >>= fun (_,trees,_) ->
+ Some (Central (max_d_left, DeQueue.(reverse left_children @> trees @< right_children), max_d_right))
+ else if Bound.(is_bounded max_d_right left_bound && is_bounded max_d_left right_bound) then
+ fold_path new_bound_right new_bound_left path_to_s >>=
+ collapse new_bound_right new_bound_left >>= fun (_, trees, _) ->
+ Some (Central (max_d_right, DeQueue.(reverse right_children @> trees @< left_children), max_d_left))
+ else
+ None
+
+
+
let insert_chain tree =
- match solve tree with
+ match make_s_path tree with
| NotRepresentable -> None
- | CenteredSubtree (Balanced (_,tree)) -> Some tree
- | CenteredSubtree (Skew (_,trees,_)) -> Some (q_node trees)
+ | CenteredSubtree path_to_s ->
+ path_to_s
+ |> fold_path Infinity Infinity
+ |> Option.map central_tree
| ExternalSubtree (ConstantSubtree (_, tree)) -> Some tree
| ExternalSubtree (IncreasingSubtree (_, trees, _)) -> Some (q_node trees)
diff --git a/lib/pqtrees/pqChainInsertion.mli b/lib/pqtrees/pqChainInsertion.mli
index d220897..d0ab8c9 100644
--- a/lib/pqtrees/pqChainInsertion.mli
+++ b/lib/pqtrees/pqChainInsertion.mli
@@ -1,84 +1,84 @@
-open DataStruct
+(* open DataStruct *)
module Make :
functor (Chain : sig type t val s : t val d : t -> int end) ->
sig
type elt = Chain.t
- type pqtree = elt PqTree.t
+ type pqtree = elt PqTree.t
- val q_node : pqtree DeQueue.t -> pqtree
+ (* val q_node : pqtree DeQueue.t -> pqtree *)
- type external_subtree =
- | ConstantSubtree of int * pqtree
- | IncreasingSubtree of int * pqtree DeQueue.t * int
+ (* type external_subtree = *)
+ (* | ConstantSubtree of int * pqtree *)
+ (* | IncreasingSubtree of int * pqtree DeQueue.t * int *)
- val bounds : external_subtree -> int * int
- val d_min : external_subtree -> int
- val d_max : external_subtree -> int
- val tree_of_external_tree : external_subtree -> pqtree
- val is_increasing_sequence : external_subtree DeQueue.t -> bool
- val force_increasing_sequence : external_subtree DeQueue.t -> external_subtree DeQueue.t option
- val expand_increasing_sequence : external_subtree DeQueue.t -> pqtree DeQueue.t
- val sort_into_increasing_sequence : external_subtree DeQueue.t -> external_subtree list DeQueue.t
+ (* val bounds : external_subtree -> int * int *)
+ (* val d_min : external_subtree -> int *)
+ (* val d_max : external_subtree -> int *)
+ (* val tree_of_external_tree : external_subtree -> pqtree *)
+ (* val is_increasing_sequence : external_subtree DeQueue.t -> bool *)
+ (* val force_increasing_sequence : external_subtree DeQueue.t -> external_subtree DeQueue.t option *)
+ (* val expand_increasing_sequence : external_subtree DeQueue.t -> pqtree DeQueue.t *)
+ (* val sort_into_increasing_sequence : external_subtree DeQueue.t -> external_subtree list DeQueue.t *)
- type sorting_group =
- | Group of int * pqtree list
- | Single of external_subtree
+ (* type sorting_group = *)
+ (* | Group of int * pqtree list *)
+ (* | Single of external_subtree *)
- val group_d_min : sorting_group -> int
- val group_d_max : sorting_group -> int
- val sort_children_of_p_node : external_subtree DeQueue.t -> sorting_group DeQueue.t
+ (* val group_d_min : sorting_group -> int *)
+ (* val group_d_max : sorting_group -> int *)
+ (* val sort_children_of_p_node : external_subtree DeQueue.t -> sorting_group DeQueue.t *)
- val is_increasing_group_sequence : sorting_group DeQueue.t -> bool
+ (* val is_increasing_group_sequence : sorting_group DeQueue.t -> bool *)
- type centered_subtree =
- | Balanced of int * pqtree
- | Skew of int * pqtree DeQueue.t * int
+ (* type centered_subtree = *)
+ (* | Balanced of int * pqtree *)
+ (* | Skew of int * pqtree DeQueue.t * int *)
- val tree_of_centered_tree : centered_subtree -> pqtree
- val bounds_centered : centered_subtree -> int * int
- val contract_centered : centered_subtree -> pqtree list
+ (* val tree_of_centered_tree : centered_subtree -> pqtree *)
+ (* val bounds_centered : centered_subtree -> int * int *)
+ (* val contract_centered : centered_subtree -> pqtree list *)
- type result =
- | NotRepresentable
- | CenteredSubtree of centered_subtree
- | ExternalSubtree of external_subtree
+ (* type result = *)
+ (* | NotRepresentable *)
+ (* | CenteredSubtree of centered_subtree *)
+ (* | ExternalSubtree of external_subtree *)
- type classification =
- | Unclassifiable
- | Internal of external_subtree DeQueue.t * centered_subtree * external_subtree DeQueue.t
- | External of external_subtree DeQueue.t
+ (* type classification = *)
+ (* | Unclassifiable *)
+ (* | Internal of external_subtree DeQueue.t * centered_subtree * external_subtree DeQueue.t *)
+ (* | External of external_subtree DeQueue.t *)
- val classify : result list -> classification
+ (* val classify : result list -> classification *)
- type queue =
- { left_bound : int;
- trees : pqtree DeQueue.t;
- right_bound : int
- }
+ (* type queue = *)
+ (* { left_bound : int; *)
+ (* trees : pqtree DeQueue.t; *)
+ (* right_bound : int *)
+ (* } *)
- val init_queue : centered_subtree -> queue
- val is_balanced : queue -> bool
- val collapse : queue -> int * pqtree
- val enqueue_right : sorting_group -> queue -> queue
- val enqueue_left : sorting_group -> queue -> queue
- val finalize : queue -> centered_subtree
- val enqueue : sorting_group DeQueue.t -> queue -> result
+ (* val init_queue : centered_subtree -> queue *)
+ (* val is_balanced : queue -> bool *)
+ (* val collapse : queue -> int * pqtree *)
+ (* val enqueue_right : sorting_group -> queue -> queue *)
+ (* val enqueue_left : sorting_group -> queue -> queue *)
+ (* val finalize : queue -> centered_subtree *)
+ (* val enqueue : sorting_group DeQueue.t -> queue -> result *)
- val build_p_internal : centered_subtree -> external_subtree DeQueue.t -> result
+ (* val build_p_internal : centered_subtree -> external_subtree DeQueue.t -> result *)
- val centered_subtree : int -> pqtree DeQueue.t -> int -> result
+ (* val centered_subtree : int -> pqtree DeQueue.t -> int -> result *)
- val build_q_internal : external_subtree DeQueue.t -> centered_subtree -> external_subtree DeQueue.t -> result
- val contract_group : sorting_group -> pqtree DeQueue.t
- val build_p_external : external_subtree DeQueue.t -> result
- val build_q_external : external_subtree DeQueue.t -> result
- val dispatch : pqtree -> result list -> result
- val children : pqtree -> pqtree list
- val solve : pqtree -> result
+ (* val build_q_internal : external_subtree DeQueue.t -> centered_subtree -> external_subtree DeQueue.t -> result *)
+ (* val contract_group : sorting_group -> pqtree DeQueue.t *)
+ (* val build_p_external : external_subtree DeQueue.t -> result *)
+ (* val build_q_external : external_subtree DeQueue.t -> result *)
+ (* val dispatch : pqtree -> result list -> result *)
+ (* val children : pqtree -> pqtree list *)
+ (* val solve : pqtree -> result *)
val insert_chain : pqtree -> pqtree option
end
val refine_by_distances : 'elt -> ('elt -> int) -> 'elt PqTree.t -> 'elt PqTree.t option
--
GitLab