feat: add generic tree zipper data structure

2 files changed, 138 insertions, 0 deletions

diff --git a/lib/tipper.ml b/lib/tipper.ml
new file mode 100644
index 0000000..bf09bb9
--- /dev/null
+++ b/lib/tipper.ml
@@ -0,0 +1,45 @@
+(* Module [Tipper]: functional tree zippers *)
+
+open Base
+
+type !+'a tipper = {
+  elt : 'a;
+  parent : 'a tipper option;
+  children : 'a tipper Zipper.t;
+}
+
+type !+'a t = 'a tipper
+
+let create a = { elt = a; parent = None; children = Zipper.empty }
+let focus t = t.elt
+let is_root t = Option.(t.parent |> is_none)
+let is_leaf t = Zipper.(t.children |> is_empty)
+let is_far_left t = Zipper.(t.children |> is_far_left)
+let is_far_right t = Zipper.(t.children |> is_far_right ~by_one:true)
+let left t = { t with children = Zipper.left t.children }
+let far_left t = { t with children = Zipper.far_left t.children }
+let right t = { t with children = Zipper.right ~by_one:true t.children }
+let far_right t = { t with children = Zipper.far_right ~by_one:true t.children }
+let set_focus a t = { t with elt = a }
+let push t1 t2 = { t2 with children = Zipper.push t1 t2.children }
+
+let pop t =
+  let s, cs = Zipper.pop t.children in
+  (Sequence.hd s, { t with children = cs })
+
+let up t = Option.(map ~f:(push t) t.parent |> value ~default:t)
+
+let rec up_while ~f t =
+  if (not (is_root t)) && f t then t |> up |> up_while ~f else t
+
+let root t = up_while ~f:(fun n -> not (is_root n)) t
+
+let down t =
+  match pop t with None, _ -> t | Some c, p -> { c with parent = Some p }
+
+let rec fold ~a ~f t =
+  let a = f a t in
+  if is_leaf t then
+    let t = up_while ~f:is_far_right t in
+    if is_root t && is_far_right t then a else fold ~a ~f (t |> right |> down)
+  else fold ~a ~f (t |> far_left |> down)
diff --git a/lib/tipper.mli b/lib/tipper.mli
new file mode 100644
index 0000000..f2a8288
--- /dev/null
+++ b/lib/tipper.mli
@@ -0,0 +1,93 @@
+open Base
+
+(** Tree zippers.
+
+    A zipper represents {b a paused traversal} of a certain data
+    structure. A tree zipper of type ['a tipper] represents a zipper
+    over a generic tree of ['a] elements.
+
+    One can access the {b focused element} of the zipper with [focus].
+    The focus of a zipper is also known as the the {b cursor} of the
+    zipper. The cursor can be moved [up] to the parent node, if any, or
+    [down] to one of the selected children; [left] and [right] can be
+    used to select adjacent children. To select the right (resp. left)
+    sibling of the current cursor, for example, one should go [up], move
+    [right] (resp. [left]) and [down] again.
+
+    Elements can be added to the children of the current cursor with
+    [push] and removed with [pop].
+
+    In this particular implementation, there is no such thing as an {b
+    empty} tree zipper. *)
+
+type !+'a tipper
+(** A zipper is represented as an element of type ['a], a parent ['a
+    tipper] (with a hole) and a sequences of ['a tipper] children. *)
+
+type !+'a t = 'a tipper
+(** An alias for the ['a tipper] type. *)
+
+val create : 'a -> 'a tipper
+(** [create a] returns a new tipper with a single node containing [a]. *)
+
+val focus : 'a tipper -> 'a
+(** Returns the element pointed by the cursor *)
+
+val is_root : 'a tipper -> bool
+(** Returns whether the cursor is at the root of the tree. *)
+
+val is_leaf : 'a tipper -> bool
+(** Returns whether the cursor is pointing to a leaf (a node with no
+    children). *)
+
+val is_far_left : 'a tipper -> bool
+(** Returns whether the leftmost child is selected. *)
+
+val is_far_right : 'a tipper -> bool
+(** Returns whether the rightmost child is selected. *)
+
+(** {1 Moving the cursor} *)
+
+val left : 'a tipper -> 'a tipper
+(** Select the children on the left. *)
+
+val far_left : 'a tipper -> 'a tipper
+(** Select the children on the far left. *)
+
+val right : 'a tipper -> 'a tipper
+(** Select the children on the right. *)
+
+val far_right : 'a tipper -> 'a tipper
+(** Select the children on the far right. *)
+
+val up : 'a tipper -> 'a tipper
+(** Move cursor to the parent node, if any. *)
+
+val up_while : f:('a tipper -> bool) -> 'a tipper -> 'a tipper
+(** [up_while ~f t] moves the cursor in [t] up while the predicate [f]
+    is satisfied. *)
+
+val root : 'a tipper -> 'a tipper
+(** Move the cursor up to the root of the tree. *)
+
+val down : 'a tipper -> 'a tipper
+(** Move cursor to the selected child node, if any. *)
+
+(** {1 Modifying the tree zipper} *)
+
+val set_focus : 'a -> 'a tipper -> 'a tipper
+(** [set_focus a t] sets the element at the cursor position in [t] to
+    [a]. *)
+
+val push : 'a tipper -> 'a tipper -> 'a tipper
+(** [push t1 t2] adds [t1] as a subtree child of the node in [t2]
+    pointed by the cursor, so that [t1] is the newly selected child. *)
+
+val pop : 'a tipper -> 'a tipper option * 'a tipper
+(** [pop t] removes the subtree associated with the selected child.
+    Returns the subtree as a first element and the modified [t] as the
+    second. *)
+
+(** {1 Consuming the tree zipper} *)
+
+val fold : a:'a -> f:('a -> 'b tipper -> 'a) -> 'b tipper -> 'a