Source file `treeContext.ml`

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
46
47
48
49
50
51
52
open UtilsLib

module Tree =
struct
  type 'a tree = Node of ('a * 'a tree list)
                         
  let rec pp ppf fmt t = 
    match t with
    | Node (v, []) -> Format.fprintf fmt "@[%a@]" ppf v
    | Node (v, children) ->
      Format.fprintf
        fmt
        "@[%a @[<v>%a@]@]"
        ppf
        v
        (Utils.pp_list ~sep:"@;" (fun fmt t -> Format.fprintf fmt "@[-- @[%a@]@]" (pp ppf) t))
        children
        
  let rec fold_depth_first ((transform, apply) as f) t =
    match t with
    | Node (v, []) -> transform v
    | Node (v, children) ->
      List.fold_left
        (fun acc child -> apply acc (fold_depth_first f child))
        (transform v)
        children

  let label (Node (a, _)) = a
    
end

  

module TreeContext =
struct
  type 'a t =
    | Top
    | Zipper of ('a * 'a Tree.tree ListContext.focused_list * 'a t)
                
  
  type 'a focused_tree = 'a t * 'a Tree.tree

  type direction = Up | Down | Right [@@warning "-37"]

  exception Move_failure of direction

  let up = function
    | Top, _ -> raise (Move_failure Up)
    | Zipper (label, (elders, youngers), z), t -> z, Tree.Node (label, ListContext.zip_up elders (t::youngers))

end