#! /usr/bin/env ocaml

(* {{{ lay types *)

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 ;;

(* }}} *)
(* {{{ shifts *)

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) ;;

(* }}} *)

(* {{{ types *)

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;;

(* }}} *)
(* {{{ moves *)

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) ;;

(* }}} *)
(* {{{ test *)

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";
;;
(* }}} *)

(* vim: sw=2 sts=2 ts=2 et fdm=marker
 *)