diff --git a/lib/chain/dune b/lib/chain/dune
new file mode 100644
index 0000000000000000000000000000000000000000..2c4c180e177f89b89e92c5103428a3a7422418c8
--- /dev/null
+++ b/lib/chain/dune
@@ -0,0 +1,4 @@
+(library
+ (name ChainLib)
+ (libraries DissimilarityLib PqTreeLib)
+)
diff --git a/lib/chain/robinsonByChain.ml b/lib/chain/robinsonByChain.ml
new file mode 100644
index 0000000000000000000000000000000000000000..141da9e105c7c320fd7540b263dd9bf7c1f21ad8
--- /dev/null
+++ b/lib/chain/robinsonByChain.ml
@@ -0,0 +1,15 @@
+open DissimilarityLib
+open PqTreeLib
+open Dissimilarity
+
+let find_compatible_order dissimilarity =
+ let insert_chain pqtree_option s = match pqtree_option with
+ | None -> None
+ | Some pqtree ->
+ PqChainInsertion.refine_by_distances s (fun u -> dissimilarity.d s u) pqtree
+ in
+ let initial_tree =
+ PqTree.(P (List.map (fun x -> Leaf x) dissimilarity.elements))
+ in
+ List.fold_left insert_chain (Some initial_tree) dissimilarity.elements
+ |> Option.map PqTree.frontier
diff --git a/lib/chain/robinsonByChain.mli b/lib/chain/robinsonByChain.mli
new file mode 100644
index 0000000000000000000000000000000000000000..4a0cc5993bdfb8edcdfad932700caee21fd588bc
--- /dev/null
+++ b/lib/chain/robinsonByChain.mli
@@ -0,0 +1,4 @@
+
+open DissimilarityLib
+
+val find_compatible_order : 'elt Dissimilarity.t -> 'elt list option
diff --git a/lib/datastruct/deQueue.ml b/lib/datastruct/deQueue.ml
index 71c30869d4705f0b7cbbeffb67f16cf189d82b64..a67fc7b019fcf4747e5be094919354725b12c24d 100644
--- a/lib/datastruct/deQueue.ml
+++ b/lib/datastruct/deQueue.ml
@@ -20,9 +20,9 @@ sig
val reverse : 'elt t -> 'elt t
- val push_all_left : 'elt list -> 'elt t -> 'elt t
+ val append_to_left : 'elt t -> 'elt t -> 'elt t
- val push_all_right : 'elt t -> 'elt list -> 'elt t
+ val append_to_right : 'elt t -> 'elt t -> 'elt t
end
@@ -59,11 +59,15 @@ struct
let reverse (prefix, suffix) = (suffix, prefix)
- let push_all_left list queue =
- List.fold_left (fun queue elt -> push_left elt queue) queue list
+ let rec append_to_left left right =
+ match view_left right with
+ | None -> left
+ | Some (e,q) -> append_to_left (push_right left e) q
- let push_all_right queue list =
- List.fold_left push_right queue list
+ let rec append_to_right left right =
+ match view_right left with
+ | None -> right
+ | Some (q,e) -> append_to_right q (push_left e right)
end
@@ -72,5 +76,69 @@ include NaiveQueue
let singleton elt = push_right empty elt
-let (@>) = push_all_left
-let (@<) = push_all_right
+let (@>) = append_to_right
+let (@<) = append_to_left
+
+
+let map f queue =
+ let rec map_k k queue =
+ match view_left queue with
+ | None -> k empty
+ | Some (first, others) -> map_k (fun res -> k (push_left (f first) res)) others
+ in
+ map_k (fun q -> q) queue
+
+let first queue = match view_left queue with
+| None -> invalid_arg "first on empty DeQueue"
+| Some (e,_) -> e
+
+let last queue = match view_right queue with
+| None -> invalid_arg "last on empty Dequeue"
+| Some (_,e) -> e
+
+let pop_first queue = match view_left queue with
+| None -> invalid_arg "pop_first on empty DeQueue"
+| Some (_,q) -> q
+
+let pop_last queue = match view_right queue with
+| None -> invalid_arg "pop_last on empty DeQueue"
+| Some (q,_) -> q
+
+
+
+let rec fold_lr f accu queue = match view_left queue with
+| None -> accu
+| Some (e,q) -> fold_lr f (f accu e) q
+
+let rec fold_rl f queue accu = match view_right queue with
+| None -> accu
+| Some (q,e) -> fold_rl f q (f e accu)
+
+
+let filter test queue =
+ fold_lr (fun q e -> if test e then push_right q e else q) empty queue
+
+
+let concat_map f queue =
+ fold_lr (fun q e -> append_to_left q (f e)) empty queue
+
+
+let rec for_all test queue =
+ match view_left queue with
+ | None -> true
+ | Some (e,_) when not (test e) -> false
+ | Some (_,q) -> for_all test q
+
+
+let zip queue1 queue2 =
+ let rec zip_k k queue1 queue2 =
+ match view_left queue1, view_left queue2 with
+ | Some (e1,q1), Some (e2,q2) -> zip_k (fun res -> k (push_left (e1,e2) res)) q1 q2
+ | _,_ -> k empty
+ in
+ zip_k (fun q -> q) queue1 queue2
+
+
+let consecutives queue =
+ if is_empty queue then empty
+ else zip (pop_last queue) (pop_first queue)
diff --git a/lib/datastruct/deQueue.mli b/lib/datastruct/deQueue.mli
index 068e1ac96a803b7b6b22954c97bd46c9a11ed777..d8b0f9404db2f4ea69a942002b6c3e10398919ac 100644
--- a/lib/datastruct/deQueue.mli
+++ b/lib/datastruct/deQueue.mli
@@ -18,13 +18,34 @@ val of_list : 'elt list -> 'elt t
val reverse : 'elt t -> 'elt t
-val push_all_left : 'elt list -> 'elt t -> 'elt t
+val append_to_left : 'elt t -> 'elt t -> 'elt t
+
+val append_to_right : 'elt t -> 'elt t -> 'elt t
-val push_all_right : 'elt t -> 'elt list -> 'elt t
val singleton : 'elt -> 'elt t
-val (@>) : 'elt list -> 'elt t -> 'elt t
+val (@>) : 'elt t -> 'elt t -> 'elt t
+
+val (@<) : 'elt t -> 'elt t -> 'elt t
+
+
+val map : ('elt -> 'im) -> 'elt t -> 'im t
+
+val first : 'elt t -> 'elt
+val last : 'elt t -> 'elt
+val pop_first : 'elt t -> 'elt t
+val pop_last : 'elt t -> 'elt t
+
+val fold_lr : ('accu -> 'elt -> 'accu) -> 'accu -> 'elt t -> 'accu
+val fold_rl : ('elt -> 'accu -> 'accu) -> 'elt t -> 'accu -> 'accu
+
+val for_all : ('elt -> bool) -> 'elt t -> bool
+
+val filter : ('elt -> bool) -> 'elt t -> 'elt t
+
+val concat_map : ('elt -> 'im t) -> 'elt t -> 'im t
+
+val consecutives : 'elt t -> ('elt * 'elt) t
-val (@<) : 'elt t -> 'elt list -> 'elt t
diff --git a/lib/pqtree/distanceBL.ml b/lib/pqtrees/distanceBL.ml
similarity index 100%
rename from lib/pqtree/distanceBL.ml
rename to lib/pqtrees/distanceBL.ml
diff --git a/lib/pqtree/dune b/lib/pqtrees/dune
similarity index 100%
rename from lib/pqtree/dune
rename to lib/pqtrees/dune
diff --git a/lib/pqtree/functionalBL.ml b/lib/pqtrees/functionalBL.ml
similarity index 100%
rename from lib/pqtree/functionalBL.ml
rename to lib/pqtrees/functionalBL.ml
diff --git a/lib/pqtree/functionalBL.mli b/lib/pqtrees/functionalBL.mli
similarity index 100%
rename from lib/pqtree/functionalBL.mli
rename to lib/pqtrees/functionalBL.mli
diff --git a/lib/pqtree/imperativeBL.ml b/lib/pqtrees/imperativeBL.ml
similarity index 100%
rename from lib/pqtree/imperativeBL.ml
rename to lib/pqtrees/imperativeBL.ml
diff --git a/lib/pqtree/imperativeBL.mli b/lib/pqtrees/imperativeBL.mli
similarity index 100%
rename from lib/pqtree/imperativeBL.mli
rename to lib/pqtrees/imperativeBL.mli
diff --git a/lib/pqtree/pqChainInsertion.ml b/lib/pqtrees/pqChainInsertion.ml
similarity index 65%
rename from lib/pqtree/pqChainInsertion.ml
rename to lib/pqtrees/pqChainInsertion.ml
index c5f626b6d3dc9ddad8a72605a531166abef2c5fe..998773dec1a3f26e534455df86bea503763e04e3 100644
--- a/lib/pqtree/pqChainInsertion.ml
+++ b/lib/pqtrees/pqChainInsertion.ml
@@ -12,18 +12,6 @@
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
@@ -52,13 +40,14 @@ module Make =
open Chain
open PqTree
- let q = function
- | [_1;_2] as children -> P children
- | children -> Q children
+ let q_node subtrees =
+ match DeQueue.to_list subtrees with
+ | [_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 *)
+ | IncreasingSubtree of int * pqtree DeQueue.t * int (* an increasing subtree is necessarily a Q-node *)
let bounds = function
| ConstantSubtree (delta,_) -> (delta, delta)
@@ -70,34 +59,36 @@ module Make =
| 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
+ | IncreasingSubtree (_, children,_) -> q_node children
let is_increasing_sequence subtrees =
- List.for_all
+ let open DeQueue in
+ 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
+ else let reversed = DeQueue.reverse subtrees in
if is_increasing_sequence reversed then Some reversed
else None
let expand_increasing_sequence subtrees =
let contract = function
- | ConstantSubtree (_,t) -> [t]
+ | ConstantSubtree (_,t) -> DeQueue.singleton t
| IncreasingSubtree (_, children, _) -> children
in
- List.concat_map contract subtrees
+ DeQueue.concat_map contract subtrees
let sort_into_increasing_sequence subtrees =
- IntPairSorter.sort ~get_key:bounds subtrees
+ subtrees
+ |> DeQueue.to_list
+ |> IntPairSorter.sort ~get_key:bounds
+ |> DeQueue.of_list
type sorting_group =
@@ -114,24 +105,22 @@ module Make =
let sort_children_of_p_node children =
let group = function
- | [ ConstantSubtree _ as tree ] -> [ Single tree ]
- | (ConstantSubtree (delta,_)::_) as trees -> [ Group (delta, List.map tree_of_external_tree trees) ]
- | trees -> List.map (fun t -> Single t) trees
+ | [ ConstantSubtree _ as tree ] -> DeQueue.singleton (Single tree)
+ | (ConstantSubtree (delta,_)::_) as trees ->
+ DeQueue.singleton ( Group (delta, List.map tree_of_external_tree trees) )
+ | trees -> List.map (fun t -> Single t) trees |> DeQueue.of_list
in
children
|> sort_into_increasing_sequence
- |> List.concat_map group
+ |> DeQueue.concat_map group
let is_increasing_group_sequence groups =
- List.for_all
+ let open DeQueue in
+ 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))
-
-
@@ -142,7 +131,7 @@ module Make =
let tree_of_centered_tree = function
| Balanced (_, tree) -> tree
- | Skew (_,children,_) -> q (DeQueue.to_list children)
+ | Skew (_,children,_) -> q_node children
let bounds_centered = function
| Balanced (delta,_) -> (delta, delta)
@@ -160,24 +149,25 @@ module Make =
type classification =
| Unclassifiable
- | Internal of external_subtree list * centered_subtree * external_subtree list
- | External of external_subtree list
+ | Internal of external_subtree DeQueue.t * centered_subtree * external_subtree DeQueue.t
+ | External of external_subtree DeQueue.t
let classify children =
+ let open DeQueue in
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
+ go (Internal (left, at_s, push_right right child)) children
| External left_of_s, ExternalSubtree child::children ->
- go (External (child::left_of_s)) children
+ go (External (push_right left_of_s child)) children
| External left_of_s, CenteredSubtree centered::children ->
- go (Internal (left_of_s, centered, [])) children
+ go (Internal (left_of_s, centered, empty)) children
| Internal _, CenteredSubtree _ :: _ -> Unclassifiable
in
- go (External []) children
+ go (External empty) children
@@ -201,13 +191,13 @@ module Make =
| Some (child, trees) when DeQueue.is_empty trees && is_balanced queue ->
(queue.left_bound, child)
| _ ->
- (max queue.left_bound queue.right_bound, q (DeQueue.to_list queue.trees))
+ (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.push_all_right queue.trees subtrees, bound)
+ | Single (IncreasingSubtree (_, subtrees, bound)) -> DeQueue.(queue.trees @< subtrees, bound)
in
{ queue with trees; right_bound }
@@ -215,7 +205,7 @@ module Make =
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.push_all_left subtrees queue.trees, bound)
+ | Single (IncreasingSubtree (_,subtrees, bound)) -> DeQueue.(reverse subtrees @> queue.trees, bound)
in
{ queue with trees; left_bound }
@@ -224,95 +214,103 @@ module Make =
| 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 (DeQueue.to_list queue.trees))
+ Balanced (queue.left_bound, q_node queue.trees)
| _ ->
Skew (queue.left_bound, queue.trees, queue.right_bound)
let rec enqueue groups queue =
let max_bound = max queue.left_bound queue.right_bound in
- match groups with
- | [] ->
+ match DeQueue.view_left groups with
+ | None ->
CenteredSubtree (finalize queue)
- | Group (dist,children) :: groups when dist >= max_bound ->
+ | Some (Group (dist,children), groups) when dist >= max_bound ->
queue
|> collapse
|> (fun (_,tree) -> Balanced (dist, P (tree :: children)))
|> init_queue
|> enqueue groups
- | single :: groups when group_d_min single >= max_bound ->
+ | 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
- | any :: groups when group_d_min any >= queue.right_bound ->
+ | Some (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 ->
+ | 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 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_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 (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 (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
- let centered_subtree left_bound trees right_bound =
- if left_bound = right_bound then
- CenteredSubtree (Balanced (left_bound, q (DeQueue.to_list trees)))
- else
- CenteredSubtree (Skew (left_bound, trees, right_bound))
- in
- if max min_center max_center <= min min_left min_right then
+ 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
- max_left
- DeQueue.(lefts @> singleton (tree_of_centered_tree s_subtree) @< rights)
- max_right
- else if min_left >= min_center && max_center <= min_right then
- centered_subtree
- max_left
- DeQueue.(lefts @> of_list (contract_centered s_subtree) @< rights)
- max_right
- else if min_right >= min_center && max_center <= min_left then
+ left_bound
+ DeQueue.(reverse lefts @> singleton (tree_of_centered_tree s_subtree) @< rights)
+ right_bound
+ | Some left_bound, Some right_bound, _, _ ->
centered_subtree
- max_right
- DeQueue.(rights @> of_list (contract_centered s_subtree) @< lefts)
- max_left
- else NotRepresentable
+ 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
let contract_group = function
- | Group (_, subtrees) -> [ P subtrees ]
- | Single (ConstantSubtree (_,subtree)) -> [ subtree ]
+ | Group (_, subtrees) -> DeQueue.singleton (P subtrees)
+ | Single (ConstantSubtree (_,subtree)) -> DeQueue.singleton (subtree)
| Single (IncreasingSubtree (_,subtrees,_)) -> subtrees
let build_p_external unsorted_subtrees =
let groups = sort_children_of_p_node unsorted_subtrees in
- match groups with
+ match DeQueue.view_left groups with
| _ when not (is_increasing_group_sequence groups) -> NotRepresentable
- | [ Group (delta,children) ] ->
+ | Some (Group (delta,children),q) when DeQueue.is_empty q ->
ExternalSubtree (ConstantSubtree (delta, P children))
| _ ->
- let (delta_min, delta_max) = groups_amplitude groups in
- let subtrees = List.concat_map contract_group groups in
+ let delta_min = group_d_min (DeQueue.first groups) in
+ let delta_max = group_d_max (DeQueue.last groups) in
+ let subtrees = DeQueue.concat_map contract_group groups in
ExternalSubtree (IncreasingSubtree (delta_min, subtrees, delta_max))
@@ -322,9 +320,10 @@ module Make =
| None -> NotRepresentable
| Some subtrees ->
ExternalSubtree (
- let (delta_min, delta_max) = amplitude subtrees in
+ let delta_min = d_min (DeQueue.first subtrees) in
+ let delta_max = d_max (DeQueue.last subtrees) in
if delta_min = delta_max then
- ConstantSubtree (delta_min, Q (List.map tree_of_external_tree subtrees))
+ ConstantSubtree (delta_min, q_node (DeQueue.map tree_of_external_tree subtrees))
else
IncreasingSubtree (delta_min, expand_increasing_sequence subtrees, delta_max)
)
@@ -338,11 +337,11 @@ module Make =
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)
+ build_p_internal at_s (DeQueue.append_to_left left_of_s 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)
+ build_q_internal (DeQueue.reverse left_of_s) at_s right_of_s
| Q _, External subtrees ->
build_q_external subtrees
@@ -361,9 +360,9 @@ module Make =
match solve tree with
| NotRepresentable -> None
| CenteredSubtree (Balanced (_,tree)) -> Some tree
- | CenteredSubtree (Skew (_,trees,_)) -> Some (q (DeQueue.to_list trees))
+ | CenteredSubtree (Skew (_,trees,_)) -> Some (q_node trees)
| ExternalSubtree (ConstantSubtree (_, tree)) -> Some tree
- | ExternalSubtree (IncreasingSubtree (_, trees, _)) -> Some (q trees)
+ | ExternalSubtree (IncreasingSubtree (_, trees, _)) -> Some (q_node trees)
end
diff --git a/lib/pqtree/pqChainInsertion.mli b/lib/pqtrees/pqChainInsertion.mli
similarity index 100%
rename from lib/pqtree/pqChainInsertion.mli
rename to lib/pqtrees/pqChainInsertion.mli
diff --git a/lib/pqtree/pqTree.ml b/lib/pqtrees/pqTree.ml
similarity index 100%
rename from lib/pqtree/pqTree.ml
rename to lib/pqtrees/pqTree.ml
diff --git a/lib/pqtree/pqTree.mli b/lib/pqtrees/pqTree.mli
similarity index 100%
rename from lib/pqtree/pqTree.mli
rename to lib/pqtrees/pqTree.mli
diff --git a/test/unit/chainInsertionTest.ml b/test/unit/chainInsertionTest.ml
index 855a86d02c515782417fc816fcc14c8ba527cae6..6bf88586e3f4a39a88f2b2ef30df2dd6647d2cb2 100644
--- a/test/unit/chainInsertionTest.ml
+++ b/test/unit/chainInsertionTest.ml
@@ -69,3 +69,57 @@ let tree5 = Q [ Q [Leaf 3; Leaf 6; Leaf 9]; Leaf 0; Q [ Leaf 3; Leaf 4; Leaf 5 ]
let%expect_test _ =
refine_by_distances 0 (fun n -> n/3) tree5
|> output; [%expect{|Q[Leaf 9;Leaf 6;Leaf 3;Leaf 0;Q[Leaf 3;Leaf 4;Leaf 5];P[Leaf 6;Leaf 8];Leaf 9]|}]
+
+
+let tree_0 = P [ Leaf 0; Leaf 1; Leaf 2; Leaf 3; Leaf 4; Leaf 5; Leaf 6; Leaf 7; Leaf 8; Leaf 9 ]
+let d0 = [|0;63;11;66;52;12;69;16;11;9|]
+
+let%expect_test _ =
+ refine_by_distances 0 (fun n -> d0.(n)) tree_0
+ |> output; [%expect{|
+ P[P[P[P[P[P[P[P[Leaf 0;Leaf 9];Leaf 2;Leaf 8];Leaf 5];Leaf 7];Leaf 4];Leaf 1];
+ Leaf 3];Leaf 6]|}]
+
+let tree_1 = P[P[P[P[P[P[P[P[Leaf 0;Leaf 9];Leaf 2;Leaf 8];Leaf 5];Leaf 7];Leaf 4];Leaf 1];Leaf 3];Leaf 6]
+let d1 = [|63;0;53;5;12;74;8;78;52;57|]
+
+let%expect_test _ =
+ refine_by_distances 1 (fun n -> d1.(n)) tree_1
+ |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
+
+let tree_2 = Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]
+let d2 = [|11;53;0;56;41;22;59;27;8;5|]
+
+let%expect_test _ =
+ refine_by_distances 2 (fun n -> d2.(n)) tree_2
+ |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
+
+let d3 = [|66;5;56;0;15;77;3;82;56;60|]
+let d4 = [|52;12;41;15;0;63;18;67;42;46|]
+let d5 = [|12;74;22;77;63;0;80;7;23;18|]
+let d6 = [|69;8;59;3;18;80;0;84;59;63|]
+let d7 = [|16;78;27;82;67;7;84;0;27;23|]
+let d8 = [|11;52;8;56;42;23;59;27;0;10|]
+let d9 = [|9;57;5;60;46;18;63;23;10;0|]
+
+let%expect_test _ =
+ refine_by_distances 3 (fun n -> d3.(n)) tree_2
+ |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
+let%expect_test _ =
+ refine_by_distances 4 (fun n -> d4.(n)) tree_2
+ |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
+let%expect_test _ =
+ refine_by_distances 5 (fun n -> d5.(n)) tree_2
+ |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
+let%expect_test _ =
+ refine_by_distances 6 (fun n -> d6.(n)) tree_2
+ |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
+let%expect_test _ =
+ refine_by_distances 7 (fun n -> d7.(n)) tree_2
+ |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
+let%expect_test _ =
+ refine_by_distances 8 (fun n -> d8.(n)) tree_2
+ |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]
+let%expect_test _ =
+ refine_by_distances 9 (fun n -> d9.(n)) tree_2
+ |> output; [%expect{|Q[Leaf 6;Leaf 3;Leaf 1;Leaf 4;Leaf 8;Leaf 2;Leaf 9;Leaf 0;Leaf 5;Leaf 7]|}]