type src = int ;;
type flt = (int -> int) ;;
type cmp = (int -> int -> int) ;;
type lay_tree =
| Src of src
| Edge of flt * lay_tree
| Junc of cmp * lay_tree * lay_tree ;;
type lay_tree =
| Src_type
| Edge_type
| Junc_type ;;
type lay_back =
| Root
| Left of cmp * lay_tree * lay_back
| Right of cmp * lay_tree * lay_back
| Straight of flt * lay_back ;;
type lay_pointed = Ptr of lay_tree * lay_back ;;
let shift_layer_left (Ptr (layers, backup)) = match layers with
| Src _ -> failwith "Leaf"
| Edge -> failwith "Edge"
| Junc (cmp, lay1, lay2) -> Ptr (lay1, Left (cmp, lay2, backup)) ;;
let shift_layer_right (Ptr (layers, backup)) = match layers with
| Src _ -> failwith "Leaf"
| Edge -> failwith "Edge"
| Junc (cmp, lay1, lay2) -> Ptr (lay2, Right (cmp, lay1, backup)) ;;
let shift_through_edge (Ptr (layers, backup)) = match layers with
| Src _ -> failwith "Leaf"
| Edge (flt, lay) -> Ptr (lay, Straight (flt, backup))
| Junc _ -> failwith "Junction" ;;
let shift_up_back (Ptr (layers, backup)) = match backup with
| Root -> failwith "Root"
| Left (cmp, lay_, backup_tail) -> Ptr (Junc (cmp, layers, lay_), backup_tail)
| Right (cmp, lay_, backup_tail) -> Ptr (Junc (cmp, lay_, layers), backup_tail)
| Straight (flt, backup_tail) -> Ptr (Edge (flt, layers), backup_tail) ;;
let get_node_type (Ptr (layers, _)) = match layers with
| Src _ -> Src_type
| Edge _ -> Edge_type
| Junc _ -> Junc_type ;;
let rec shift_all ~func switch =
func switch;
match get_node_type switch with
| Src_type -> ()
| Edge_type -> shift_all ~func (shift_through_edge switch)
| Junc_type -> shift_all ~func (shift_layer_right switch)
shift_all ~func (shift_layer_left switch) ;;
type 'a bintree =
| BLeaf
| BNode of 'a * 'a bintree * 'a bintree;;
type 'a path =
| BRoot
| BLeft of 'a * 'a bintree * 'a path
| BRight of 'a * 'a bintree * 'a path;;
type 'a zipper = BZip of 'a bintree * 'a path;;
let move_left (BZip (tree, path)) = match tree with
| BLeaf -> failwith "Leaf"
| BNode (x, t1, t2) -> BZip (t1, BLeft (x, t2, path)) ;;
let move_right (BZip (tree, path)) = match tree with
| BLeaf -> failwith "Leaf"
| BNode (x, t1, t2) -> BZip (t2, BRight (x, t1, path)) ;;
let move_up (BZip (tree, path)) = match path with
| BRoot -> failwith "Root"
| BLeft (x, t, path_tail) -> BZip (BNode (x, tree, t), path_tail)
| BRight (x, t, path_tail) -> BZip (BNode (x, t, tree), path_tail) ;;
let _ =
let b1 =
BNode(2, BNode(3, BNode(5, BLeaf, BLeaf),
BNode(6, BLeaf, BLeaf) ),
BNode(4, BNode(7, BLeaf, BLeaf),
BNode(8, BLeaf, BLeaf) )
)
in
let z1 = Zip (b1, Root) in
let z2 = move_left z1 in
let z2' =
Zip
(BNode(3, BNode (5, BLeaf, BLeaf),
BNode (6, BLeaf, BLeaf) ),
Left (2, BNode (4, BNode (7, BLeaf, BLeaf),
BNode (8, BLeaf, BLeaf) ),
Root)
)
in if z2 = z2' then print_endline " z2 OK";
let z3 = move_left z2 in
let z3' =
Zip
(BNode (5, BLeaf, BLeaf),
Left (3, BNode (6, BLeaf, BLeaf),
Left (2, BNode (4, BNode (7, BLeaf, BLeaf),
BNode (8, BLeaf, BLeaf)),
Root))
)
in if z3 = z3' then print_endline " z3 OK";
;;