F# Tree Maps

treemap.fs

module TreeMaps


type Map<'k,'v> = 
    | Map of ('v -> 'k -> 'v)


[<Struct>]
type ShallowMap<'k,'v,'c> = 
    | ShallowMap of value:'v * lookup:('k -> 'v -> 'c)


module ShallowMap = 
    let create lookup value = ShallowMap(value, lookup)
    let get (ShallowMap(value, _)) = value
    let lookup key (ShallowMap(value, lookup)) = lookup key value 
    let map f (ShallowMap(value, lookup)) = ShallowMap(value, fun k v -> lookup k v |> f)

[<Struct>]
type TreeMap<'k,'v> = 
    | TreeMap of value:'v * lookup:('k -> 'v -> 'v)

    

module TreeMap = 
    let create lookup value = TreeMap(value, lookup)
    //let get (TreeMap(value, _)) = value
    //let getChild k (TreeMap(value, lookup)) = TreeMap(lookup k value, lookup)
    let map (f:'a -> 'b) (TreeMap(value:'a, lookup: ('k -> 'a -> 'a))) = 
        TreeMap(f value, fun k _ -> lookup k value |> f)
    let foldOut (seed: 'b) (fold: 'b -> 'a -> 'b)  (TreeMap(value:'a, lookup: ('k -> 'a -> 'a))) = 
        let newLookup = fun (k:'k) (v:'b) -> 
            let oldChild = lookup k value
            fold v oldChild
        let newRoot = fold seed value     
        TreeMap(newRoot, newLookup)

    //let mapRec (mapValue:'v -> 'c2) (lookup2: 'c -> 'k -> 'c2 -> 'c2) (treeMap:ShallowMap<'k,'v,'c>) : TreeMap<'k,'c2> = 
    //    match treeMap with
    //    | ShallowMap(value, lookup) -> 
    //        let newLookup = fun k (v:'c2) -> 
    //            let oldChild = lookup k value
    //            let newChild : 'c2 = lookup2 oldChild k v
    //            newChild
    //        TreeMap(mapValue value, newLookup)

type Tree<'a> = private Tree of value:'a * children:Tree<'a> list

module Tree = 
    let rec walk (Tree(value, children)) = 
        [ yield value
          for c in children do
            yield! walk c ]
    let rec pair (Tree(parentValue, children)) = 
        [ for c in children do
            let (Tree(value, _)) = c
            yield (parentValue, value)
          for c in children do
            yield! pair c ]
    let rec map seed f (Tree(value, children)) =
        let newValue = f(seed, value)
        Tree(newValue, children |> List.map (map value f))
        
    let rec flatMap (f: 'a -> 'b list -> 'b) (Tree(value, children)) = 
        f value [ for c in children -> flatMap f c ]

[<Struct>]
type TreeBuilder<'a> = private TreeBuilder of value:'a * getChildren:('a -> 'a list)

module TreeBuilder =
    let getValue (TreeBuilder(value, _)) = value
    let getChildren (TreeBuilder(value, get)) = 
        [ for c in get value -> TreeBuilder(c, get) ]
    let map f (TreeBuilder(value, getChildren)) = 
        TreeBuilder(f value, (fun _ -> value |> getChildren |> List.map f))
    let filter f (TreeBuilder(value, getChildren)) = 
        TreeBuilder(value, getChildren >> List.filter f)
    let mapOut2 (f: ('b * 'a) -> 'b) (state:'b) (TreeBuilder(value, getChildren)) = 
        let newGetChildren(b:'b) = 
            let g : ('a -> 'b) = fun a -> f(b, a)
            value |> getChildren |> List.map g
        TreeBuilder(f(state, value), newGetChildren)
    let mapOut (f: ('a * 'b) -> 'b) (state:'b) (TreeBuilder(value, getChildren)) = 
        let newGetChildren(b:'b) = 
            let g : ('a -> 'b) = fun a -> f(a, b)
            value |> getChildren |> List.map g
        TreeBuilder(f(value, state), newGetChildren)
        
    let rec reduceUp (max:int) (reduce: 'a * 'a list -> 'a) tree =
        match max, tree with
        | 0, TreeBuilder(value, _) -> reduce (value, [])
        | 1, TreeBuilder(value, getValues) -> reduce(value, getValues(value))
        | maxDepth, TreeBuilder(value, getValues) -> 
            let childrenSums = [ for c in tree |> getChildren do 
                                    let value = reduceUp (maxDepth - 1) reduce c
                                    yield value ]
            reduce (value, childrenSums)

    let rec toTree (max:int) builder = 
        match max, builder with
        | (0, TreeBuilder(value, _)) -> Tree(value, [])
        | (1, TreeBuilder(value, getValues) as b) -> 
            Tree(value, [ for v in getValues(value) -> Tree(v, []) ])
        | (_, b) -> Tree(b |> getValue, [ for c in getChildren(b) -> toTree (max - 1) c ])
        
let toLookup (item, _) = (sprintf "x%i" item, item)


type TreeBuilder<'a> with
    member this.Value = this |> Tree.getValue
    member this.Children = this |> Tree.getChildren
  

//type TreeView<'k,'v> = TreeView of treeMap:TreeMap<'k,'v> * getKeys: ('v -> list<'k>)

//type TreeView

//    //let (TreeMap(value, lookup)) = treeMap
//    //member this.Value = value
//    //member this.Children = 
//    //    [| for k in getKeys(value) -> 
//    //        TreeView(TreeMap(lookup k value, lookup), getKeys) |]

//module TreeView =

//    let map (f: 'v -> 'v1) (TreeView(treeMap, getKeys)) =
//        let newTree = treeMap |> TreeMap.map f
//        //let newValue = f(value)
//        //let newLookup = fun k (_:'v1) -> lookup k value |> f
//        let newGetKeys = fun (_:'v1) -> getKeys value
//        //()
//        TreeView<'k, 'v1>(newTree, newGetKeys)

let toPath list = list |> List.rev |> List.toSeq |> String.concat "/"

let map1 = 
    ["Root"] 
    |> TreeMap.create(fun k v -> k::v)
    |> TreeMap.foldOut "" (fun s p -> s + String.concat "/" (p))