Various zippers

zipper-merged.ml

type 'a tree =
  | Section of {
      item : 'a;
      children : 'a tree list;
    }

let item a = Section { item = a; children = [] }

type 'a path =
  | Top
  | Node of 'a * 'a tree list * 'a path * 'a tree list

type 'a location = Loc of 'a tree * 'a path

let go_left (Loc (t, p)) =
  match p with
  | Top -> failwith "left of top"
  | Node (a, l :: left, up, right) -> Loc (l, Node (a, left, up, t :: right))
  | Node (_a, [], _up, _right) -> failwith "left of first"

let go_right (Loc (t, p)) =
  match p with
  | Top -> failwith "right of top"
  | Node (a, left, up, r :: right) -> Loc (r, Node (a, t :: left, up, right))
  | _ -> failwith "right of last"

let go_up (Loc (t, p)) =
  match p with
  | Top -> failwith "up of top"
  | Node (a, left, up, right) ->
    Loc (Section { item = a; children = List.rev left @ (t :: right) }, up)

let go_down (Loc (t, p)) =
  match t with
  | Section { item; children = t1 :: trees } ->
    Loc (t1, Node (item, [], p, trees))
  | _ -> failwith "down of empty"

let add_child ch (Loc (Section { item; children }, p)) =
  Loc
    ( Section
        { item; children = Section { item = ch; children = [] } :: children },
      p )

let close_node (Loc (Section { item; children }, p)) =
  let l = Loc (Section { item; children = List.rev children }, p) in
  go_up l

let a =
  Section
    {
      item = "+";
      children =
        [
          Section { item = "*"; children = [item "a"; item "b"] };
          Section { item = "*"; children = [item "c"; item "d"] };
        ];
    }

let a1 = Loc (a, Top)
let emp = Loc (Section { item = "root"; children = [] }, Top)

let b =
  emp |> add_child "x" |> go_down |> add_child "y" |> add_child "z"
  |> close_node |> add_child "w"

zipper-vanilla.ml

type 'a tree =
  | Item of 'a
  | Section of { mutable children : 'a tree list }

type 'a path =
  | Top
  | Node of 'a tree list * 'a path * 'a tree list

type 'a location = Loc of 'a tree * 'a path

let go_left (Loc (t, p)) =
  match p with
  | Top -> failwith "left of top"
  | Node (l :: left, up, right) -> Loc (l, Node (left, up, t :: right))
  | Node ([], up, right) -> failwith "left of first"

let go_right (Loc (t, p)) =
  match p with
  | Top -> failwith "right of top"
  | Node (left, up, r :: right) -> Loc (r, Node (t :: left, up, right))
  | _ -> failwith "right of last"

let go_up (Loc (t, p)) =
  match p with
  | Top -> failwith "up of top"
  | Node (left, up, right) ->
    Loc (Section { children = List.rev left @ (t :: right) }, up)

let go_down (Loc (t, p)) =
  match t with
  | Item _ -> failwith "down of item"
  | Section { children = t1 :: trees } -> Loc (t1, Node ([], p, trees))
  | _ -> failwith "down of empty"

let a =
  Section
    {
      children =
        [
          Section { children = [Item "a"; Item "*"; Item "b"] };
          Item "+";
          Section { children = [Item "c"; Item "*"; Item "d"] };
        ];
    }

let a1 = Loc (a, Top)
let emp = Loc (Section { children = [] }, Top)

let add_child (Loc (Section { children }, p)) =
  Loc (Section { children = children @ [Section { children = [] }] }, p)