From 633fb26ed21f7208517aa29dbaab9f0cf3bb2047 Mon Sep 17 00:00:00 2001 From: Federico Igne Date: Sun, 28 Jan 2024 23:41:50 +0100 Subject: feat: add generic tree zipper data structure --- lib/tipper.ml | 45 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) create mode 100644 lib/tipper.ml (limited to 'lib/tipper.ml') 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) -- cgit v1.2.3