From e7783862408f04a6fa4b3399f64c23e70f9c1fba Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Sat, 20 Jan 2024 22:58:40 -0500 Subject: [PATCH 01/13] first draft --- src/rtree.ml | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/src/rtree.ml b/src/rtree.ml index 62cbf64..52bb62c 100644 --- a/src/rtree.ml +++ b/src/rtree.ml @@ -129,6 +129,39 @@ module Make (E : Envelope) (V : Value with type envelope = E.t) = struct | a, b -> { max_node_load = t.max_node_load; tree = Node [ a; b ] } (* root split *) +(** Traverse tree and if an element that is equal to 'elem' is found, + remove that element and return `Some tree`else return `None` + + t -> Repr.t, runime representation of Tree element type + elem -> element to be removed + tree -> root node + + If root has child nodes/leaves then recurse on those nodes until leaves are + explored, else return `None` *) +let rec remove_eq' eq tree = + let removed = ref false in + let rec loop = function + | Node ns -> + Node (List.map (fun (e, tree') -> (e, loop tree')) ns) + | Leaf es -> + if List.exists (fun (_, elt) -> eq elt) es then + removed := true; + Leaf (List.filter (fun (_, elt) -> eq elt |> not) es) + | Empty -> + tree + in + let res = loop tree in + if !removed then + Some res + else + None + +let remove_eq t elem tree = + let eq = (Repr.equal t |> Repr.unstage) elem in + Option.map (fun tree' -> (tree', elem)) (remove_eq' eq tree) + + + let filter_intersecting e = List.filter (fun (e', _) -> E.intersects e e') let rec find' t e = From ea9e214ef315302dc62342689aea81c9fb99ff6e Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Sat, 10 Feb 2024 19:06:37 -0500 Subject: [PATCH 02/13] immutable remove functions first draft --- src/rtree.ml | 81 +++++++++++++++++++++++++++++++--------------------- 1 file changed, 49 insertions(+), 32 deletions(-) diff --git a/src/rtree.ml b/src/rtree.ml index 52bb62c..b860a99 100644 --- a/src/rtree.ml +++ b/src/rtree.ml @@ -129,38 +129,55 @@ module Make (E : Envelope) (V : Value with type envelope = E.t) = struct | a, b -> { max_node_load = t.max_node_load; tree = Node [ a; b ] } (* root split *) -(** Traverse tree and if an element that is equal to 'elem' is found, - remove that element and return `Some tree`else return `None` - - t -> Repr.t, runime representation of Tree element type - elem -> element to be removed - tree -> root node - - If root has child nodes/leaves then recurse on those nodes until leaves are - explored, else return `None` *) -let rec remove_eq' eq tree = - let removed = ref false in - let rec loop = function - | Node ns -> - Node (List.map (fun (e, tree') -> (e, loop tree')) ns) - | Leaf es -> - if List.exists (fun (_, elt) -> eq elt) es then - removed := true; - Leaf (List.filter (fun (_, elt) -> eq elt |> not) es) - | Empty -> - tree - in - let res = loop tree in - if !removed then - Some res - else - None - -let remove_eq t elem tree = - let eq = (Repr.equal t |> Repr.unstage) elem in - Option.map (fun tree' -> (tree', elem)) (remove_eq' eq tree) - - + let rec remove_eq' eq elem = function + | Node ns -> + let opts, ns' = + List.map + (fun (e, t) -> + let opt, t' = remove_eq' eq elem t in + (opt, (e, t'))) + ns + |> List.split + in + let opts = List.concat opts in + (opts, Node ns') + | Leaf es -> + let matching, non_matching = + List.partition (fun (_, e) -> eq elem e) es + in + let elts = List.map snd matching in + (elts, Leaf non_matching) + | Empty -> ([], Empty) + + let remove_eq t ty e = + let eq = Repr.equal ty |> Repr.unstage in + match remove_eq' eq e t with + | [], _ -> None + | (_ as elts), t' -> Some (elts, t') + + let rec remove_env' env = function + | Node ns -> + let opts, ns' = + List.map + (fun (e, t) -> + let opt, t' = remove_env' env t in + (opt, (e, t'))) + ns + |> List.split + in + let opts = List.concat opts in + (opts, Node ns') + | Leaf es -> + let in_env, out_env = + List.partition (fun (e, _) -> E.contains env e) es + in + (List.map (fun (_, v) -> v) in_env, Leaf out_env) + | Empty -> ([], Empty) + + let remove_env t env = + match remove_env' env t with + | [], _ -> None + | (_ as elts), t' -> Some (elts, t') let filter_intersecting e = List.filter (fun (e', _) -> E.intersects e e') From c4ef04d4d290809776accd700c7df3a33f8a3013 Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Sat, 10 Feb 2024 19:13:15 -0500 Subject: [PATCH 03/13] matching up signatures, trying to generalize remove by pred --- src/rtree.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/rtree.ml b/src/rtree.ml index b860a99..dc51772 100644 --- a/src/rtree.ml +++ b/src/rtree.ml @@ -129,12 +129,12 @@ module Make (E : Envelope) (V : Value with type envelope = E.t) = struct | a, b -> { max_node_load = t.max_node_load; tree = Node [ a; b ] } (* root split *) - let rec remove_eq' eq elem = function + let rec remove_eq' eq = function | Node ns -> let opts, ns' = List.map (fun (e, t) -> - let opt, t' = remove_eq' eq elem t in + let opt, t' = remove_eq' eq t in (opt, (e, t'))) ns |> List.split @@ -143,15 +143,15 @@ module Make (E : Envelope) (V : Value with type envelope = E.t) = struct (opts, Node ns') | Leaf es -> let matching, non_matching = - List.partition (fun (_, e) -> eq elem e) es + List.partition (fun (_, e) -> eq e) es in let elts = List.map snd matching in (elts, Leaf non_matching) | Empty -> ([], Empty) let remove_eq t ty e = - let eq = Repr.equal ty |> Repr.unstage in - match remove_eq' eq e t with + let eq = (Repr.equal ty |> Repr.unstage) e in + match remove_eq' eq t with | [], _ -> None | (_ as elts), t' -> Some (elts, t') From 0c6c697c78e946d2abc82d42aaa5cb8e5f55ca86 Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Mon, 12 Feb 2024 11:07:18 -0500 Subject: [PATCH 04/13] attempt @ branch optimization --- src/rtree.ml | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/rtree.ml b/src/rtree.ml index dc51772..93e63c7 100644 --- a/src/rtree.ml +++ b/src/rtree.ml @@ -142,9 +142,7 @@ module Make (E : Envelope) (V : Value with type envelope = E.t) = struct let opts = List.concat opts in (opts, Node ns') | Leaf es -> - let matching, non_matching = - List.partition (fun (_, e) -> eq e) es - in + let matching, non_matching = List.partition (fun (_, e) -> eq e) es in let elts = List.map snd matching in (elts, Leaf non_matching) | Empty -> ([], Empty) @@ -155,13 +153,21 @@ module Make (E : Envelope) (V : Value with type envelope = E.t) = struct | [], _ -> None | (_ as elts), t' -> Some (elts, t') + let rec take_children lst = function + | Node ns -> List.split ns |> snd |> List.concat_map (take_children lst) + | Leaf es -> List.split es |> snd |> ( @ ) lst + | Empty -> [] + let rec remove_env' env = function | Node ns -> let opts, ns' = List.map (fun (e, t) -> - let opt, t' = remove_env' env t in - (opt, (e, t'))) + if E.contains env e then + (take_children [] t, (e, Empty)) + else + let opt, t' = remove_env' env t in + (opt, (e, t'))) ns |> List.split in From 306110b432d57704300e81c1263bf34ed36f49ba Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Sat, 17 Feb 2024 16:17:50 -0500 Subject: [PATCH 05/13] refactor awkward case in match block --- src/rtree.ml | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/src/rtree.ml b/src/rtree.ml index 93e63c7..f30bd1d 100644 --- a/src/rtree.ml +++ b/src/rtree.ml @@ -149,12 +149,10 @@ module Make (E : Envelope) (V : Value with type envelope = E.t) = struct let remove_eq t ty e = let eq = (Repr.equal ty |> Repr.unstage) e in - match remove_eq' eq t with - | [], _ -> None - | (_ as elts), t' -> Some (elts, t') + match remove_eq' eq t with [], _ -> None | elts, t' -> Some (elts, t') let rec take_children lst = function - | Node ns -> List.split ns |> snd |> List.concat_map (take_children lst) + | Node ns -> List.split ns |> snd |> List.concat_map (take_children lst) | Leaf es -> List.split es |> snd |> ( @ ) lst | Empty -> [] @@ -163,9 +161,8 @@ module Make (E : Envelope) (V : Value with type envelope = E.t) = struct let opts, ns' = List.map (fun (e, t) -> - if E.contains env e then - (take_children [] t, (e, Empty)) - else + if E.contains env e then (take_children [] t, (e, Empty)) + else let opt, t' = remove_env' env t in (opt, (e, t'))) ns @@ -177,13 +174,11 @@ module Make (E : Envelope) (V : Value with type envelope = E.t) = struct let in_env, out_env = List.partition (fun (e, _) -> E.contains env e) es in - (List.map (fun (_, v) -> v) in_env, Leaf out_env) + (List.map snd in_env, Leaf out_env) | Empty -> ([], Empty) let remove_env t env = - match remove_env' env t with - | [], _ -> None - | (_ as elts), t' -> Some (elts, t') + match remove_env' env t with [], _ -> None | elts, t' -> Some (elts, t') let filter_intersecting e = List.filter (fun (e', _) -> E.intersects e e') From 7937ebb55037945982886b864335372b943a15fa Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Tue, 20 Feb 2024 16:43:26 -0500 Subject: [PATCH 06/13] add fns to intf, wrap + unwrap tree --- src/rtree.ml | 12 ++++++++---- src/rtree_intf.ml | 8 ++++++++ 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/src/rtree.ml b/src/rtree.ml index f30bd1d..850103a 100644 --- a/src/rtree.ml +++ b/src/rtree.ml @@ -147,9 +147,11 @@ module Make (E : Envelope) (V : Value with type envelope = E.t) = struct (elts, Leaf non_matching) | Empty -> ([], Empty) - let remove_eq t ty e = - let eq = (Repr.equal ty |> Repr.unstage) e in - match remove_eq' eq t with [], _ -> None | elts, t' -> Some (elts, t') + let remove_eq t e = + let eq = (Repr.equal V.t |> Repr.unstage) e in + match remove_eq' eq t.tree with + | [], _ -> None + | elts, t' -> Some (elts, { t with tree = t' }) let rec take_children lst = function | Node ns -> List.split ns |> snd |> List.concat_map (take_children lst) @@ -178,7 +180,9 @@ module Make (E : Envelope) (V : Value with type envelope = E.t) = struct | Empty -> ([], Empty) let remove_env t env = - match remove_env' env t with [], _ -> None | elts, t' -> Some (elts, t') + match remove_env' env t.tree with + | [], _ -> None + | elts, t' -> Some (elts, { t with tree = t' }) let filter_intersecting e = List.filter (fun (e', _) -> E.intersects e e') diff --git a/src/rtree_intf.ml b/src/rtree_intf.ml index 4e822f7..86e7d1e 100644 --- a/src/rtree_intf.ml +++ b/src/rtree_intf.ml @@ -108,6 +108,14 @@ module type S = sig val insert : t -> Value.t -> t (** Insert a new element into the tree *) + val remove_env : t -> Envelope.t -> (Value.t list * t) option + (** Remove all elements within a certain envelope, + returning them and the new tree or None if none are found *) + + val remove_eq : t -> Value.t -> (Value.t list * t) option + (** Remove all eelements with equality to the element passed, + returning them and the new tree, or None if none are found *) + val find : t -> Envelope.t -> Value.t list (** [find tree env] find all value contained by [env] in [tree]. *) From 46b0d1687f017a2555a88662a60516e92aca3276 Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Tue, 20 Feb 2024 16:48:21 -0500 Subject: [PATCH 07/13] added suggessted unit test --- test/basic.ml | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/test/basic.ml b/test/basic.ml index 4ee5157..05a0f3e 100644 --- a/test/basic.ml +++ b/test/basic.ml @@ -234,6 +234,24 @@ let test_size () = let calc_depth = R.size t in assert (calc_depth = 4) +let test_remove () = + let module R = R1 in + let lines = + [ + { p1 = (0., 0.); p2 = (1., 1.) }; + { p1 = (1., 1.); p2 = (2., 2.) }; + { p1 = (2., 2.); p2 = (3., 3.) }; + { p1 = (3., 3.); p2 = (4., 4.) }; + ] + in + let idx = R.load ~max_node_load:2 lines in + let t' = R.remove_eq idx (List.hd lines) in + match t' with + | None -> failwith "Unexpected none returned from remove" + | Some (vs, t') -> + assert (R.size t' = 3); + assert (List.hd vs = List.hd lines) + let suite = "R" >::: [ @@ -246,6 +264,7 @@ let suite = "size" >:: test_size; "depth" >:: test_depth; "cube" >:: cube; + "remove" >:: test_remove; ] let _ = run_test_tt_main suite From cc4f0776d94f9851806a222afc7dfbbea1811181 Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Tue, 20 Feb 2024 17:05:13 -0500 Subject: [PATCH 08/13] add remove_env unit test --- test/basic.ml | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/test/basic.ml b/test/basic.ml index 05a0f3e..04c55c6 100644 --- a/test/basic.ml +++ b/test/basic.ml @@ -234,7 +234,7 @@ let test_size () = let calc_depth = R.size t in assert (calc_depth = 4) -let test_remove () = +let test_remove_eq () = let module R = R1 in let lines = [ @@ -252,6 +252,25 @@ let test_remove () = assert (R.size t' = 3); assert (List.hd vs = List.hd lines) +let test_remove_env () = + let module R = R1 in + let lines = + [ + { p1 = (0., 0.); p2 = (1., 1.) }; + { p1 = (1., 1.); p2 = (2., 2.) }; + { p1 = (2., 2.); p2 = (3., 3.) }; + { p1 = (3., 3.); p2 = (4., 4.) }; + ] + in + let idx = R.load ~max_node_load:2 lines in + let env = Rtree.Rectangle.v ~x0:0. ~y0:0. ~x1:2. ~y1:2. in + let t' = R.remove_env idx env in + match t' with + | None -> failwith "Unexpected none returned from remove" + | Some (vs, t') -> + assert (R.size t' = 2); + assert (List.length vs = 2) + let suite = "R" >::: [ @@ -264,7 +283,8 @@ let suite = "size" >:: test_size; "depth" >:: test_depth; "cube" >:: cube; - "remove" >:: test_remove; + "remove_eq" >:: test_remove_eq; + "remove_env" >:: test_remove_env; ] let _ = run_test_tt_main suite From 65988141982e56a5edccc6ff89f03f302dc98cd8 Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Fri, 15 Mar 2024 17:45:20 -0400 Subject: [PATCH 09/13] add unit test for removal from empty tree --- test/basic.ml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/test/basic.ml b/test/basic.ml index 04c55c6..6db930c 100644 --- a/test/basic.ml +++ b/test/basic.ml @@ -271,6 +271,15 @@ let test_remove_env () = assert (R.size t' = 2); assert (List.length vs = 2) +let test_remove_empty () = + let module R = R1 in + let empty = R.empty 2 in + let env = Rtree.Rectangle.v ~x0:0. ~y0:0. ~x1:1. ~y1:1. in + let remove_env = R.remove_env empty env in + let line = { p1 = (0., 0.); p2 = (1., 1.) } in + let remove_eq = R.remove_eq empty line in + assert (Option.is_none remove_env && Option.is_none remove_eq) + let suite = "R" >::: [ From 9ab8ea6c4f55301aa8548b83344be46eb2820230 Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Fri, 15 Mar 2024 19:58:27 -0400 Subject: [PATCH 10/13] add tests remove_one remove_many --- test/basic.ml | 46 +++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 45 insertions(+), 1 deletion(-) diff --git a/test/basic.ml b/test/basic.ml index 6db930c..751d8ac 100644 --- a/test/basic.ml +++ b/test/basic.ml @@ -278,7 +278,48 @@ let test_remove_empty () = let remove_env = R.remove_env empty env in let line = { p1 = (0., 0.); p2 = (1., 1.) } in let remove_eq = R.remove_eq empty line in - assert (Option.is_none remove_env && Option.is_none remove_eq) + assert (Option.is_none remove_env); + assert (Option.is_none remove_eq) + +let test_remove_one () = + let module R = R1 in + let line = { p1 = (0., 0.); p2 = (1., 1.) } in + let t = R.load [ line ] in + let removed_env, t_env = + R.remove_env t (Rtree.Rectangle.v ~x0:0. ~y0:0. ~x1:1. ~y1:1.) |> Option.get + in + let removed_eq, t_eq = R.remove_eq t line |> Option.get in + assert (List.length removed_env == 1); + assert (R.size t_env == 0); + assert (List.length removed_eq == 1); + assert (R.size t_eq == 0) + +let test_remove_many () = + let module R = R1 in + let env = Rtree.Rectangle.v ~x0:0. ~y0:0. ~x1:1. ~y1:1. in + let lines = + List.init 1_000 (fun _ -> + { + p1 = (Random.float 1., Random.float 1.); + p2 = (Random.float 1., Random.float 1.); + }) + in + let t = R.load lines in + let t_env = R.remove_env t env in + let t_eq = + List.fold_left + (fun acc line -> + assert_bool + "Remove_many unexpectedly failed: element not present in tree" + @@ Option.is_some acc; + R.remove_eq (Option.get acc |> snd) line) + (Some ([], t)) + lines + in + assert (Option.is_some t_env); + assert (R.size (Option.get t_env |> snd) == 0); + assert (Option.is_some t_eq); + assert (R.size (Option.get t_eq |> snd) == 0) let suite = "R" @@ -294,6 +335,9 @@ let suite = "cube" >:: cube; "remove_eq" >:: test_remove_eq; "remove_env" >:: test_remove_env; + "remove empty" >:: test_remove_empty; + "remove one elt from tree of size one" >:: test_remove_one; + "remove many" >:: test_remove_many; ] let _ = run_test_tt_main suite From c0cd69789bde050db1a5b882572344e91b63d346 Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Fri, 15 Mar 2024 20:03:30 -0400 Subject: [PATCH 11/13] add test to remove element that is not present in tree --- test/basic.ml | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/test/basic.ml b/test/basic.ml index 751d8ac..e27bff0 100644 --- a/test/basic.ml +++ b/test/basic.ml @@ -321,6 +321,23 @@ let test_remove_many () = assert (Option.is_some t_eq); assert (R.size (Option.get t_eq |> snd) == 0) +let test_remove_not_present () = + let module R = R1 in + let lines = + List.init 1_000 (fun _ -> + { + p1 = (Random.float 1., Random.float 1.); + p2 = (Random.float 1., Random.float 1.); + }) + in + let t = R.load lines in + let t_env = + R.remove_env t (Rtree.Rectangle.v ~x0:1.01 ~y0:1.01 ~x1:2. ~y1:2.) + in + let t_eq = R.remove_eq t { p1 = (2., 2.); p2 = (3., 3.) } in + assert (Option.is_none t_env); + assert (Option.is_none t_eq) + let suite = "R" >::: [ @@ -338,6 +355,7 @@ let suite = "remove empty" >:: test_remove_empty; "remove one elt from tree of size one" >:: test_remove_one; "remove many" >:: test_remove_many; + "remove element not present in tree" >:: test_remove_not_present; ] let _ = run_test_tt_main suite From 676c2652ec181f892896c3dfae24c067613831e1 Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Fri, 15 Mar 2024 20:06:07 -0400 Subject: [PATCH 12/13] fix doc comments --- src/rtree_intf.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/rtree_intf.ml b/src/rtree_intf.ml index 86e7d1e..d875796 100644 --- a/src/rtree_intf.ml +++ b/src/rtree_intf.ml @@ -109,11 +109,11 @@ module type S = sig (** Insert a new element into the tree *) val remove_env : t -> Envelope.t -> (Value.t list * t) option - (** Remove all elements within a certain envelope, + (** [remove_env tree envelope] Remove all elements within a certain envelope, returning them and the new tree or None if none are found *) val remove_eq : t -> Value.t -> (Value.t list * t) option - (** Remove all eelements with equality to the element passed, + (** [remove_eq tree element] Remove all elements with equality to the element passed, returning them and the new tree, or None if none are found *) val find : t -> Envelope.t -> Value.t list From a5e367a230b9b30e22ca2f8ee85f731c1de8fc76 Mon Sep 17 00:00:00 2001 From: Fay Carsons Date: Sat, 16 Mar 2024 17:26:14 -0400 Subject: [PATCH 13/13] add unit test removing from an envelope containing half the tree's elts --- test/basic.ml | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/test/basic.ml b/test/basic.ml index e27bff0..e9ebc65 100644 --- a/test/basic.ml +++ b/test/basic.ml @@ -296,7 +296,6 @@ let test_remove_one () = let test_remove_many () = let module R = R1 in - let env = Rtree.Rectangle.v ~x0:0. ~y0:0. ~x1:1. ~y1:1. in let lines = List.init 1_000 (fun _ -> { @@ -305,6 +304,7 @@ let test_remove_many () = }) in let t = R.load lines in + let env = Rtree.Rectangle.v ~x0:0. ~y0:0. ~x1:1. ~y1:1. in let t_env = R.remove_env t env in let t_eq = List.fold_left @@ -338,6 +338,26 @@ let test_remove_not_present () = assert (Option.is_none t_env); assert (Option.is_none t_eq) +let test_count_env () = + let module R = R1 in + let ranf () = Random.float 0.5 in + let in_range = + List.init 50 (fun _ -> { p1 = (ranf (), ranf ()); p2 = (ranf (), ranf ()) }) + in + let out_range = + List.init 50 (fun _ -> + (* Elts in range starting at .5001 to make sure they're not in the envelope *) + { + p1 = (0.5001 +. ranf (), 0.5001 +. ranf ()); + p2 = (0.5001 +. ranf (), 0.5001 +. ranf ()); + }) + in + let t = R.load (in_range @ out_range) in + let env = Rtree.Rectangle.v ~x0:0. ~y0:0. ~x1:0.5 ~y1:0.5 in + let t = R.remove_env t env in + assert (Option.is_some t); + assert (Option.get t |> snd |> R.size |> ( == ) 50) + let suite = "R" >::: [ @@ -356,6 +376,7 @@ let suite = "remove one elt from tree of size one" >:: test_remove_one; "remove many" >:: test_remove_many; "remove element not present in tree" >:: test_remove_not_present; + "remove elements within an envelope" >:: test_count_env; ] let _ = run_test_tt_main suite