Skip to content

Commit

Permalink
refactor(trie): drop almost all requirements of physical equality (#54)
Browse files Browse the repository at this point in the history 
BREAKING CHANGE: drop all *_endo functions and physical equality requirements
  • Loading branch information
@favonia
favonia committed Mar 7, 2022
1 parent e383d7c commit 262e1be
Show file tree
Hide file tree
Showing 4 changed files with 129 additions and 219 deletions.
89 changes: 10 additions & 79 deletions src/Trie.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -71,16 +71,6 @@ let rec equal_node eq n1 n2 =

let equal eq = Option.equal (equal_node eq)

(*
let rec compare_node cmp n1 n2 =
if n1 == n2 then 0 else
match Option.compare cmp n1.root n2.root with
| 0 -> SegMap.compare ~cmp:(compare_node cmp) n1.children n2.children
| n -> n
let compare cmp = Option.compare (compare_node cmp)
*)

(** {1 Getting data} *)

let rec find_node_cont path n k =
Expand All @@ -100,44 +90,15 @@ let find_root t = find_singleton [] t

(** {1 Traversing the trees} *)

let phy_eq_option r1 r2 =
match r1, r2 with
| None, None -> true
| Some r1, Some r2 -> r1 == r2
| _ -> false

let phy_eq_map c1 c2 = c1 == c2

let replace_nonempty_root_and_children n root children =
if phy_eq_option n.root root && phy_eq_map n.children children
then n else {root; children}

let replace2_nonempty_root_and_children n1 n2 root children =
if phy_eq_option n1.root root && phy_eq_map n1.children children
then n1 else replace_nonempty_root_and_children n2 root children

let replace_root_and_children n root children =
if phy_eq_option n.root root && phy_eq_map n.children children
then non_empty n else mk_tree root children

let replace_root n root =
if phy_eq_option n.root root then non_empty n else mk_tree root n.children

let replace_children n children =
if phy_eq_map n.children children then non_empty n else mk_tree n.root children

let replace_tree t1 t2 =
if phy_eq_option t1 t2 then t1 else t2

let rec update_node_cont n path (k : 'a t -> 'a t) =
match path with
| [] -> k @@ non_empty n
| seg::path ->
replace_children n @@
mk_tree n.root @@
SegMap.update ~key:seg ~f:(fun n -> update_cont n path k) n.children

and update_cont t path k =
replace_tree t @@ match t with
match t with
| None -> prefix path @@ k empty
| Some n -> update_node_cont n path k

Expand All @@ -146,7 +107,7 @@ let update_subtree path f t = update_cont t path f
let update_singleton path f t = update_cont t path @@
function
| None -> root_opt @@ f None
| Some n -> replace_root n (f n.root)
| Some n -> mk_tree (f n.root) n.children

let update_root f t = update_singleton [] f t

Expand All @@ -156,11 +117,7 @@ let union_option f x y =
match x, y with
| _, None -> x
| None, _ -> y
| Some x', Some y' ->
let fxy = f x' y' in
if fxy == x' then x
else if fxy == y' then y
else Some fxy
| Some x', Some y' -> Some (f x' y')

let rec union_node ~rev_prefix m n n' =
let root = union_option (m ~rev_path:rev_prefix) n.root n'.root in
Expand All @@ -173,7 +130,7 @@ let rec union_node ~rev_prefix m n n' =
let f key n n' = Some (union_node ~rev_prefix:(key :: rev_prefix) m n n') in
SegMap.union ~f n.children n'.children
in
replace2_nonempty_root_and_children n n' root children
{root; children}

let union_ ~rev_prefix m = union_option @@ union_node ~rev_prefix m

Expand All @@ -185,32 +142,28 @@ let union_subtree ?(rev_prefix=[]) m t (path, t') =
let union_singleton ?(rev_prefix=[]) m t (path, v) =
update_cont t path @@ function
| None -> non_empty @@ root_opt_node v
| Some n -> replace_root n @@ union_option (m ~rev_path:(List.rev_append path rev_prefix)) n.root @@ Some v
| Some n -> non_empty {n with root = union_option (m ~rev_path:(List.rev_append path rev_prefix)) n.root @@ Some v}

(** {1 Detaching subtrees} *)

(* TODO preserves physical eq *)
let rec apply_and_update_node_cont path n k =
match path with
| [] -> k @@ non_empty n
| seg::path ->
let ans, new_child = apply_and_update_cont path (SegMap.find_opt seg n.children) k in
let children = SegMap.update ~key:seg ~f:(Fun.const new_child) n.children in
ans, replace_children n children
ans, mk_tree n.root children

(* TODO preserves physical eq *)
and apply_and_update_cont path t (k : 'a t -> 'b * 'a t) : 'b * 'a t =
match t with
| None -> let ans, t = k empty in ans, prefix path t
| Some n -> apply_and_update_node_cont path n k

(* TODO preserves physical eq *)
let detach_subtree path t = apply_and_update_cont path t @@ fun t -> t, empty

(* TODO preserves physical eq *)
let detach_singleton path t = apply_and_update_cont path t @@ function
| None -> None, empty
| Some n -> n.root, replace_root n None
| Some n -> n.root, mk_tree None n.children

(** {1 Conversion from/to Seq} *)

Expand Down Expand Up @@ -248,15 +201,6 @@ let rec mapi_node ~rev_prefix f n =
}
let mapi ?(rev_prefix=[]) f t = Option.map (mapi_node ~rev_prefix f) t

let rec mapi_endo_node ~rev_prefix f n =
let root = Option.map (f ~rev_path:rev_prefix) n.root in
let children = SegMap.filter_mapi_endo
(fun ~key:(key:string) n -> Some (mapi_endo_node ~rev_prefix:(key::rev_prefix) f n))
n.children
in
replace_nonempty_root_and_children n root children
let mapi_endo ?(rev_prefix=[]) f t = replace_tree t @@ Option.map (mapi_endo_node ~rev_prefix f) t

let rec filteri_node ~rev_prefix f n =
let root = Option.bind n.root @@
fun v -> if f ~rev_path:rev_prefix v then Some v else None in
Expand All @@ -265,23 +209,10 @@ let rec filteri_node ~rev_prefix f n =
(fun ~key -> filteri_node ~rev_prefix:(key::rev_prefix) f)
n.children
in
replace_root_and_children n root children
let filteri ?(rev_prefix=[]) f t = replace_tree t @@ Option.bind t @@ filteri_node ~rev_prefix f
mk_tree root children
let filteri ?(rev_prefix=[]) f t = Option.bind t @@ filteri_node ~rev_prefix f

let rec filter_mapi_node ~rev_prefix f n =
mk_tree (Option.bind n.root @@ f ~rev_path:rev_prefix) @@
SegMap.filter_mapi (fun ~key -> filter_mapi_node ~rev_prefix:(key::rev_prefix) f) n.children
let filter_mapi ?(rev_prefix=[]) f t = Option.bind t @@ filter_mapi_node ~rev_prefix f

let rec filter_mapi_endo_node ~rev_prefix f n =
let root = Option.bind n.root (f ~rev_path:rev_prefix) in
let children =
SegMap.filter_mapi_endo
(fun ~key -> filter_mapi_endo_node ~rev_prefix:(key::rev_prefix) f)
n.children
in
replace_root_and_children n root children
let filter_mapi_endo ?(rev_prefix=[]) f t = replace_tree t @@
Option.bind t @@ filter_mapi_endo_node ~rev_prefix f

let physically_equal : 'a t -> 'a t -> bool = phy_eq_option
25 changes: 4 additions & 21 deletions src/Trie.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,7 +26,7 @@ val prefix : path -> 'a t -> 'a t
(** [singleton (p, d)] makes a trie with the only binding: [p] and its associated value [d]. It is equivalent to {!val:prefix}[p @@]{!val:root}[d] *)
val singleton : path * 'a -> 'a t

(** [equal eq t1 t2] checks whether two tries are equal. If the internal representations of tries are physically equal, [equal eq t1 t2] will immediately return [true] without calling [eq]. *)
(** [equal eq t1 t2] checks whether two tries are equal. *)
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
(* val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int *)

Expand Down Expand Up @@ -58,13 +58,7 @@ val iteri : ?rev_prefix:path -> (rev_path:path -> 'a -> unit) -> 'a t -> unit
*)
val mapi : ?rev_prefix:path -> (rev_path:path -> 'a -> 'b) -> 'a t -> 'b t

(** [mapi_endo ~rev_prefix f t] is similar to {!val:mapi}[f t] except that the domain and the codomain of the function must be the same. The additional benefit of [mapi_endo] over [mapi] is that, if [f v] returns [v] for every value [v] in [t], then [t] is returned unchanged. (That is, the new trie will be physically equal to the old one.) See {!val:filter_map_endo}.
@param rev_prefix The prefix prepended to any path sent to [f], but in reverse. The default is the empty unit path ([[]]).
*)
val mapi_endo : ?rev_prefix:path -> (rev_path:path -> 'a -> 'a) -> 'a t -> 'a t

(** [filteri ~rev_prefix f t] removes all values [v] at path [p] such that [f ~rev_prefix:p v] returns [false]. If [f v] returns [true] for every value [v] in [t], then [t] is returned unchanged. (That is, the new trie will be physically equal to the old one.)
(** [filteri ~rev_prefix f t] removes all values [v] at path [p] such that [f ~rev_prefix:p v] returns [false].
@param rev_prefix The prefix prepended to any path sent to [f]. The default is the empty unit path ([[]]).
*)
Expand All @@ -76,18 +70,12 @@ val filteri : ?rev_prefix:path -> (rev_path:path -> 'a -> bool) -> 'a t -> 'a t
*)
val filter_mapi : ?rev_prefix:path -> (rev_path:path -> 'a -> 'b option) -> 'a t -> 'b t

(** [filter_mapi_endo ~rev_prefix f t] is similar to {!val:filter_mapi}[~rev_prefix f t] except that [f] must be of type [rev_path:path -> 'a -> 'a option]; that is, its domain and codomain agree up to the [option] type. The additional benefit of [filter_mapi_endo] over [filter_mapi] is that if [f ~rev_prefix:p v] returns [Some v] for every value [v] at [p] in [t], then [t] is returned unchanged. (That is, the new trie will be physically equal to the old one.) See {!val:map_endo}
@param rev_prefix The prefix prepended to any path sent to [f]. The default is the empty unit path ([[]]).
*)
val filter_mapi_endo : ?rev_prefix:path -> (rev_path:path -> 'a -> 'a option) -> 'a t -> 'a t

(** {1 Updating} *)

(** [update_subtree p f t] replaces the subtree [t'] rooted at [p] in [t] with [f t']. It will try to preserve physical equality when [f] returns the trie unchanged. *)
(** [update_subtree p f t] replaces the subtree [t'] rooted at [p] in [t] with [f t']. *)
val update_subtree : path -> ('a t -> 'a t) -> 'a t -> 'a t

(** [update_singleton p f t] replaces the value [v] at [p] in [t] with the result of [f]. If there was no binding at [p], [f None] is evaluated. Otherwise, [f (Some v)] is used. If the result is [None], the old binding at [p] (if any) is removed. Otherwise, if the result is [Some v'], the value at [p] is replaced by [v']. It will try to preserve physical equality when [f] maintains the current status of binding, either returning [None] for [None] or [Some v] for [Some v]. *)
(** [update_singleton p f t] replaces the value [v] at [p] in [t] with the result of [f]. If there was no binding at [p], [f None] is evaluated. Otherwise, [f (Some v)] is used. If the result is [None], the old binding at [p] (if any) is removed. Otherwise, if the result is [Some v'], the value at [p] is replaced by [v']. *)
val update_singleton : path -> ('a option -> 'a option) -> 'a t -> 'a t

(** [update_root f t] updates the value at root with [f]. It is equivalent to {!val:update_singleton}[[] f t]. *)
Expand Down Expand Up @@ -143,8 +131,3 @@ val to_seq_values : 'a t -> 'a Seq.t
@param rev_prefix The prefix prepended to any path sent to [merger], but in reverse. The default is the empty unit path ([[]]).
*)
val of_seq : ?rev_prefix:path -> (rev_path:path -> 'a -> 'a -> 'a) -> (path * 'a) Seq.t -> 'a t

(**/**)

(** This is an internal API for testing whether the library is preserving physical equality as much as possible. Do not use this function in other situations. If [physically_equal t1 t2] returns [true] then [equal eq t1 t2] must return [true]. *)
val physically_equal : 'a t -> 'a t -> bool
4 changes: 2 additions & 2 deletions test/TestAction.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -193,7 +193,7 @@ let test_filter_map_1 () =
(Ok (of_list [["y"], 110]))
(Action.run_with_hooks
~hooks:(fun () ~rev_prefix t ->
Result.ok @@ Trie.filter_mapi_endo ~rev_prefix
Result.ok @@ Trie.filter_mapi ~rev_prefix
(fun ~rev_path:_ d -> if d > 20 then Some (d + 80) else None) t)
~union:cantor
(hook ()) (of_list [["x"; "y"], 10; ["x"; "x"], 20; ["y"], 30]))
Expand All @@ -204,7 +204,7 @@ let test_filter_map_2 () =
(Ok t)
(Action.run_with_hooks
~hooks:(fun () ~rev_prefix t ->
Result.ok @@ Trie.filter_mapi_endo ~rev_prefix
Result.ok @@ Trie.filter_mapi ~rev_prefix
(fun ~rev_path:_ x -> Some x) t)
~union:cantor
(hook ()) t)
Expand Down
Loading

0 comments on commit 262e1be

Please sign in to comment.