Zipper Forests ( from Haskell )

type 'a Tree = { rootLabel:'a

                 subForest:'a Forest }

and 'a Forest = 'a Tree list

type 'a TreeLoc = { tree : 'a Tree

                    lefts : 'a Forest

                    rights : 'a Forest

                    parents : ('a Forest * 'a * 'a Forest) list }

// create_node : 'a -> 'a Tree

let create_node x = { rootLabel = x

                      subForest = [] }

// maybe : 'a -> ('b -> 'a) -> 'b option -> 'a

let maybe n f m = match m with

                  | None -> n

                  | Some x -> f x

// combChildren : 'a list -> 'a -> 'a list -> 'a list

let private combChildren ls t rs = List.fold (fun xs x -> x::xs) (t::rs) ls

// downParents : 'a TreeLoc -> ('a Forest * 'a * 'a Forest) list

let private downParents loc = (loc.lefts, (loc.tree).rootLabel, loc.rights) :: loc.parents

// splitChildren : 'a list -> 'a list -> int -> ('a list * 'a list) option

let rec splitChildren acc xs n =

            match (acc, xs, n) with

            | (acc, xs, 0) -> Some (acc, xs)

            | (acc, x::xs, n) -> splitChildren (x::acc) xs (n - 1)

            | _ -> None                       

// parent : 'a TreeLoc -> 'a TreeLoc option

let parent loc = match loc.parents with

                 | (pls, v, prs) :: ps ->

                       Some { tree = { rootLabel = v

                                       subForest = (combChildren (loc.lefts) (loc.tree) (loc.rights)) }

                              lefts = pls

                              rights = prs

                              parents = ps }

                 | [] -> None

// root : 'a TreeLoc -> 'a TreeLoc                

let rec root loc = maybe loc root (parent loc)

// left : 'a TreeLoc -> 'a TreeLoc option

let left loc = match loc.lefts with

               | t::ts -> Some  { loc with

                                    tree = t

                                    lefts = ts

                                    rights = loc.tree :: loc.rights }

               | [] -> None

// right : 'a TreeLoc -> 'a TreeLoc option

let right loc = match loc.rights with

                | t::ts -> Some { loc with

                                    tree = t

                                    lefts = loc.tree :: loc.lefts

                                    rights = ts }

                | [] -> None

// firstChild : 'a TreeLoc -> 'a TreeLoc option            

let firstChild loc = match (loc.tree).subForest with

                     | t::ts -> Some { tree = t

                                       lefts = []

                                       rights = ts

                                       parents = downParents loc }

                     | [] -> None

// lastChild : 'a TreeLoc -> 'a TreeLoc option

let lastChild loc = match (List.rev ((loc.tree).subForest)) with

                    | t::ts -> Some { tree = t

                                      lefts = ts

                                      rights = []

                                      parents = downParents loc }

                    | [] -> None

// getChild : int -> 'a TreeLoc -> 'a TreeLoc option                   

let getChild n loc =

        splitChildren [] ((loc.tree).subForest) n

        |> Option.map (fun (t::ls, rs) -> { tree = t

                                            lefts = ls

                                            rights = rs

                                            parents = downParents loc })

// findChild : ('a Tree -> bool) -> 'a TreeLoc -> 'a TreeLoc option

let findChild p loc =

       let rec split acc xs =

            match xs with

            | x::xs when p x -> Some(acc, x, xs)

            | x::xs -> split (x::acc) xs

                          | []-> None

       split [] ((loc.tree).subForest)

       |> Option.map (fun (ls, t, rs) -> { tree = t

                                           lefts = ls

                                           rights = rs

                                           parents = downParents loc })

// fromTree : 'a Tree -> 'a TreeLoc

let fromTree t = { tree = t

                   lefts = []

                   rights = []

                   parents = [] }

// fromForest : 'a Forest -> 'a TreeLoc option                  

let fromForest (ts : 'a Forest) =

    match ts with

    | t::ts -> Some { tree = t

                      lefts = []

                      rights = ts

                      parents = [] }

    | [] -> None

// toTree : 'a TreeLoc -> 'a Tree

let toTree loc = (root loc).tree

     

// toForest : 'a TreeLoc -> 'a Forest                     

let toForest loc : 'a Forest =

    let r = root loc in combChildren (r.lefts) (r.tree) (r.rights)    

   

// isRoot : 'a TreeLoc -> bool

let isRoot loc = List.isEmpty (loc.parents)                           

// isFirst : 'a TreeLoc -> bool

let isFirst loc = List.isEmpty (loc.lefts)

// isLast : 'a TreeLoc -> bool

let isLast loc = List.isEmpty (loc.rights)

// isLeaf : 'a TreeLoc -> bool

let isLeaf loc = List.isEmpty ((loc.tree).subForest)

// isChild : 'a TreeLoc -> bool

let isChild loc = not (isRoot loc)

// hasChildren : 'a TreeLoc -> bool

let hasChildren loc = not (isLeaf loc)

// setTree : 'a Tree -> 'a TreeLoc -> 'a TreeLoc

let setTree t loc = { loc with tree = t }

// modifyTree : ('a Tree -> 'a Tree) -> 'a TreeLoc -> 'a TreeLoc

let modifyTree f loc = setTree (f (loc.tree)) loc

// setLabel : 'a -> 'a TreeLoc -> 'a TreeLoc

let setLabel v loc = modifyTree (fun t -> { t with rootLabel = v }) loc

// getLabel : 'a TreeLoc -> 'a

let getLabel loc = (loc.tree).rootLabel

// modifyLabel : ('a -> 'a) -> 'a TreeLoc -> 'a TreeLoc

let modifyLabel f loc = setLabel (f (getLabel loc)) loc

// insertLeft : 'a Tree -> 'a TreeLoc -> 'a TreeLoc

let insertLeft t loc = { loc with tree = t

                                  rights = loc.tree :: loc.rights }

// insertRight : 'a Tree -> 'a TreeLoc -> 'a TreeLoc

let insertRight t loc = { loc with tree = t

                                   lefts = loc.tree :: loc.lefts }

// insertDownFirst : 'a Tree -> 'a TreeLoc -> 'a TreeLoc

let insertDownFirst t loc = { loc with tree = t

                                       lefts = []

                                       rights = (loc.tree).subForest

                                       parents = downParents loc }

// insertDownLast : 'a Tree -> 'a TreeLoc -> 'a TreeLoc                                      

let insertDownLast t loc = { loc with tree = t

                                      lefts = List.rev ((loc.tree).subForest)

                                      rights = []

                                      parents = downParents loc }

// insertDownAt : int -> 'a Tree -> 'a TreeLoc -> 'a TreeLoc option

let insertDownAt n t loc =

        splitChildren [] ((loc.tree).subForest) n

        |> Option.map (fun (ls, rs) -> { loc with tree = t

                                                  lefts = ls

                                                  rights = rs

                                                  parents = downParents loc })