Wednesday 22 May 2013

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