blob: bf09bb984ee849784504b79c93a806e1ed5d594c (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
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)
|
