Binary Tree Zipper with F#. References : http://www.st.cs.uni-sb.de/edu/seminare/2005/advanced-fp/docs/huet-zipper.pdf

BinaryTreeZipper.fs

module BinaryTreeZipper

type BinaryTree<'value> = 
    | Node of BinaryTree<'value> * 'value * BinaryTree<'value>   // leftChild * value * rightChild
    | LeftOnlyNode of BinaryTree<'value> * 'value
    | RightOnlyNode of 'value * BinaryTree<'value>
    | Leaf of string

type Path<'value> = 
    | Top
    | LeftOfNode of Path<'value> * 'value * BinaryTree<'value>   // up * value * rightChild
    | LeftOfLeftOnly of Path<'value> * 'value
    | RightOfNode of 'value * BinaryTree<'value> * Path<'value>   // value * leftChild * up
    | RightOfRightOnly of 'value * Path<'value>

type Location<'value> = 
    | Loc of BinaryTree<'value> * Path<'value>

let getNodeValue (Loc(tree, _)) = 
    match tree with
    | Node(_, value, _)
    | LeftOnlyNode(_, value)
    | RightOnlyNode(value, _)
    | Leaf(value) -> value

let goLeftChild (Loc(tree, path)) = 
    match tree with
    | Node(left, value, right) -> Loc(left, LeftOfNode(path, value, right))
    | LeftOnlyNode(left, value) -> Loc(left, LeftOfLeftOnly(path, value))
    | _ -> failwith "this node does not have left child"

let goRightChild (Loc(tree, path)) = 
    match tree with
    | Node(left, value, right) -> Loc(right, RightOfNode(value, left, path))
    | RightOnlyNode(value, right) -> Loc(right, RightOfRightOnly(value, path))
    | _ -> failwith "this node does not have right child" 

let goUp (Loc(tree, path)) = 
    match path with
    | Top -> failwith "up of top"
    | LeftOfNode(up, value, right) -> Loc(Node(tree, value, right), up)
    | LeftOfLeftOnly(up, value) -> Loc(LeftOnlyNode(tree, value), up)
    | RightOfNode(value, left, up) -> Loc(Node(left, value, tree), up)
    | RightOfRightOnly(value, up) -> Loc(RightOnlyNode(value, tree), up)

let rec goTop (Loc(_, path) as loc) =
    match path with
    | Top -> loc
    | _ -> loc |> goUp |> goTop

let insertLeftChild value (Loc(tree, path)) = 
    match tree with
    | RightOnlyNode(item, right) -> Loc(Node(Leaf(value), item, right), path)
    | Leaf(item) -> Loc(LeftOnlyNode(Leaf(value), item), path)
    | Node(_) | LeftOnlyNode(_) -> failwith "this node has already left child" 

let insertRightChild value (Loc(tree, path)) = 
    match tree with
    | LeftOnlyNode(left, item) -> Loc(Node(left, item, Leaf(value)), path)
    | Leaf(item) -> Loc(RightOnlyNode(item, Leaf(value)), path)
    | Node(_) | RightOnlyNode(_) -> failwith "this node has already right child" 

let updateValue value (Loc(tree, path)) = 
    match tree with
    | Node(left, _, right) -> Loc(Node(left, value, right), path)
    | LeftOnlyNode(left, _) -> Loc(LeftOnlyNode(left, value), path)
    | RightOnlyNode(_, right) -> Loc(RightOnlyNode(value, right), path)
    | Leaf(_) -> Loc(Leaf(value), path)

let hasLeftNode (Loc(tree, _)) = 
    match tree with
    | Node(_) | LeftOnlyNode(_) -> true
    | _ -> false

let hasRightNode (Loc(tree, _)) = 
    match tree with
    | Node(_) | RightOnlyNode(_) -> true
    | _ -> false

let isLeaf (Loc(tree, _)) = 
    match tree with
    | Leaf(_) -> true
    | _ -> false