Recursive tree type and handling of recursive trees

Trees.fsx

[<AutoOpen>]
module Types =


    type BinaryTree<'Node> =
        | Empty
        | Node of
            node: 'Node *
            left: BinaryTree<'Node> *
            right: BinaryTree<'Node>


    /// Recursive tree type with tree-like semantics.
    /// So the tree can just consist of a leaf or branch
    /// or a branch can have multiple subtrees consisting
    /// of either leafs or branches.
    /// A leaf or branch can but do not nescessarily be of
    /// different types.
    type GeneralTree<'Branch, 'Leaf> =
        | Empty
        | Leaf of leaf: 'Leaf
        | Branch of branch: 'Branch * trees: GeneralTree<'Branch, 'Leaf> seq


    type SimpleTree<'Node> = GeneralTree<'Node, 'Node>



[<RequireQualifiedAccess>]
module GeneralTree =


    /// Catamorphism of a tree, using:
    /// - fLeaf: that handles a leaf type and
    /// - fBranch: that handles a branch type and
    /// the recursed results of handling the subtrees.
    let cata fLeaf fBranch (tree: GeneralTree<_, _>) =
        let rec loop fLeaf fbranch tree =
            let recurse = loop fLeaf fbranch

            match tree with
            | Empty -> Empty
            | Leaf leaf -> leaf |> fLeaf
            | Branch (branch, subTrees) ->
                subTrees |> Seq.map recurse |> fbranch branch

        loop fLeaf fBranch tree


    /// A fold over a tree, using
    /// - fLeaf: that handles a leaf type and the accumulator
    /// - fBranch: that handles a branch type and the accumulator
    let fold fLeaf fBranch acc (tree: GeneralTree<_, _>) =
        let rec loop fLeaf fbranch acc tree =
            let recurse = loop fLeaf fbranch

            match tree with
            | Empty -> acc
            | Leaf leaf -> leaf |> fLeaf acc
            | Branch (branch, subTrees) ->
                let acc = branch |> fbranch acc
                subTrees |> Seq.fold recurse acc

        loop fLeaf fBranch acc tree


    /// Foldback of a tree, using:
    /// - fLeaf: that handles a leaf type and the accumulator
    /// - fBranch: that handles a branch type and the accumulator
    let foldBack fLeaf fBranch (tree: GeneralTree<_, _>) acc =
        let rec loop fLeaf fbranch tree fAcc =
            let recurse = loop fLeaf fbranch

            match tree with
            | Empty -> fAcc
            | Leaf leaf -> fun _ -> leaf |> fLeaf (fAcc ())
            | Branch (branch, subTrees) ->
                fun _ -> branch |> fBranch (fAcc ())
                |> Seq.foldBack recurse subTrees

        loop fLeaf fBranch tree (fun () -> acc)
        |> fun f -> f ()


    /// Map the leaf and branch types of a tree, using
    /// - fLeaf: to map the leaf type from a -> b and
    /// - fBranch: to map a branch from c -> d
    let map fLeaf fBranch (tree: GeneralTree<_, _>) =
        let rec loop fLeaf fBranch tree =
            let recurse = loop fLeaf fBranch

            match tree with
            | Empty -> Empty
            | Leaf leaf -> leaf |> fLeaf |> Leaf
            | Branch (branch, subTrees) ->
                (branch |> fBranch, subTrees |> Seq.map recurse)
                |> Branch

        loop fLeaf fBranch tree


    /// Iterate through a tree, using
    /// - fLeaf: to handle the leaf type and
    /// - fBranch: to handle the branch type
    let iter fLeaf fBranch (tree: GeneralTree<_, _>) =
        let rec loop fLeaf fBranch tree =
            let recurse = loop fLeaf fBranch

            match tree with
            | Empty -> ()
            | Leaf leaf -> leaf |> fLeaf
            | Branch (branch, trees) ->
                trees |> Seq.iter recurse
                branch |> fBranch

        loop fLeaf fBranch tree


    /// Map the leaf and branch types of a tree, using
    /// - fLeaf: to map the leaf type from a -> b and
    /// - fBranch: to map a branch from c -> d
    /// the map functions also get all the tree indexes:
    /// - p: a sequence of parent indexes
    /// - d: the depth of the tree item
    /// - i: the item number in the parent
    let mapi fLeaf fBranch (tree: GeneralTree<_, _>) =
        let rec loop fLeaf fBranch p d i tree =
            let recurse = loop fLeaf fBranch

            match tree with
            | Empty -> Empty
            | Leaf leaf -> leaf |> fLeaf p d i |> Leaf
            | Branch (branch, subTrees) ->
                let branch = branch |> fBranch p d i
                let p = [ i ] |> List.append p
                let d = d + 1

                (branch,
                 subTrees
                 |> Seq.mapi (fun i t -> i, t)
                 |> Seq.map (fun (i, tree) -> recurse p d i tree))
                |> Branch

        loop fLeaf fBranch [] 0 0 tree


    /// Gives an nice string representation of a tree
    /// incorperating all tree specific indexes like:
    /// - parent indexes
    /// - depth (by indentation)
    /// - breath (the count) and
    /// - the item number in the list of the parent
    let toString leafToString branchToString (tree: GeneralTree<_, _>) =
        let fLeaf p d i leaf =
            let leaf = leaf |> leafToString
            let p = p @ [ i ] |> List.map string |> String.concat "."
            let s = $"{p} %s{leaf}"
            let tabs = "\t" |> Seq.replicate d |> String.concat ""
            sprintf "%s" (tabs + s)

        let fBranch p d i branch =
            let branch = branch |> branchToString
            let p = p @ [ i ] |> List.map string |> String.concat "."
            let s = $"{p} %s{branch}"
            let tabs = "\t" |> Seq.replicate d |> String.concat ""
            sprintf "%s" (tabs + s)

        let tost acc s = $"{acc}\n{s}"

        tree |> mapi fLeaf fBranch |> fold tost tost ""


    /// Iterate through a tree, using
    /// - fLeaf: to handle the leaf type and
    /// - fBranch: to handle the branch type
    /// the handle functions also get all the tree indexes:
    /// - p: a sequence of parent indexes
    /// - d: the depth of the tree item
    /// - b: the breath of the tree item
    /// - i: the item number in the parent
    let iteri fLeaf fBranch (tree: GeneralTree<_, _>) =
        let rec loop fLeaf fBranch p d b i tree =
            let recurse = loop fLeaf fBranch

            match tree with
            | Empty -> b
            | Leaf leaf ->
                leaf |> fLeaf p b d i
                b
            | Branch (branch, trees) ->
                branch |> fBranch p b d i
                let p = [ i ] |> List.append p
                let d = d + 1

                trees
                |> Seq.mapi (fun i t -> i, t)
                |> Seq.fold (fun b (i, tree) -> recurse p d (b + 1) i tree) b

        loop fLeaf fBranch [] 0 0 0 tree |> ignore


    /// Transform a tree to a table
    let toTable (tree: GeneralTree<_, _>) =
        let tableCell c item = item |> c |> Seq.singleton

        let rec loop table tree =
            match tree with
            | Empty -> Seq.empty
            | Leaf leaf ->
                let tc = leaf |> tableCell Leaf

                if table |> Seq.isEmpty then
                    tc |> Seq.singleton
                else
                    table |> Seq.map (fun row -> tc |> Seq.append row)
            | Branch (branch, trees) ->
                if trees |> Seq.isEmpty then
                    (branch, Seq.empty)
                    |> tableCell Branch
                    |> Seq.singleton
                else
                    trees
                    |> Seq.collect (loop table)
                    |> Seq.map (fun row ->
                        let tc = (branch, Seq.empty) |> tableCell Branch
                        row |> Seq.append tc)

        loop Seq.empty tree


    /// Get all distinct branhces and leaves of a tree
    let distinct (tree: GeneralTree<_, _>) =
        let addItem c acc item =
            let item = item |> c

            if acc |> Seq.contains item then
                acc
            else
                item |> Seq.singleton |> Seq.append acc

        let fLeaf = addItem Leaf
        let fBranch = addItem (fun b -> (b, Seq.empty) |> Branch)
        fold fLeaf fBranch Seq.empty tree


    /// Detect wheter in a tree there are any cyclic
    /// tree sections
    let detectCycles (tree: GeneralTree<_, _>) =
        tree
        |> toTable
        |> Seq.fold
            (fun acc row ->
                row
                |> Seq.distinct
                |> Seq.fold
                    (fun acc t ->
                        row
                        |> Seq.fold
                            (fun (n, acc') t' ->
                                match n with
                                | _ when n = 0 && t' = t ->
                                    (1, t' |> Seq.singleton)
                                | _ when n = 1 && t' <> t ->
                                    (1, t' |> Seq.singleton |> Seq.append acc')
                                | _ when n = 1 && t' = t ->
                                    (2, t' |> Seq.singleton |> Seq.append acc')
                                | _ -> (n, acc'))
                            (0, Seq.empty)
                        |> Seq.singleton
                        |> Seq.append acc)
                    Seq.empty
                |> Seq.filter (fun (n, _) -> n = 2)
                |> Seq.map snd
                |> Seq.append acc)
            Seq.empty


    let empty = Empty


    /// Initialize a tree with a branch
    let init branch = (branch, Seq.empty) |> Branch


    /// Add an item (leaf or branch) to a branch
    let addTobranch item branch tree =
        let fBranch b tree =
            if b <> branch then
                (b, tree)
            else
                (branch, item |> Seq.singleton |> Seq.append tree)
            |> Branch

        cata Leaf fBranch tree


    /// Add a leaf to a branch
    let addLeafTobranch root leaf =
        let item = leaf |> Leaf
        addTobranch item root


    /// Add a branch to a branch
    let addBranchTobranch root branch =
        let item = branch |> init
        addTobranch item root



module TestTree =

    module Tree = GeneralTree


    let tree =
        "root"
        |> Tree.init
        |> Tree.addBranchTobranch "root" "branch0"
        |> Tree.addLeafTobranch "root" "leaf1"
        |> Tree.addBranchTobranch "root" "branch1"
        |> Tree.addLeafTobranch "branch1" "leaf2"
        |> Tree.addLeafTobranch "branch1" "leaf3"
        |> Tree.addBranchTobranch "root" "branch2"
        |> Tree.addLeafTobranch "branch2" "leaf4"
        |> Tree.addLeafTobranch "branch2" "leaf5"
        |> Tree.addBranchTobranch "branch1" "branch3"
        |> Tree.addLeafTobranch "branch3" "leaf6"
        |> Tree.addBranchTobranch "branch2" "branch5"
        |> Tree.addBranchTobranch "root" "branch4"


    tree |> Tree.toString id id |> printfn "%s"


    tree
    |> Tree.iteri
        (fun p b d i leaf ->
            let p = p @ [ i ] |> List.map string |> String.concat "." in
            let s = $"{p} {leaf} ({b})" in
            let tabs = "\t" |> Seq.replicate d |> String.concat "" in
            printfn "%s" (tabs + s))
        (fun p b d i branch ->
            let p = p @ [ i ] |> List.map string |> String.concat "." in
            let s = $"{p} {branch} ({b})" in
            let tabs = "\t" |> Seq.replicate d |> String.concat "" in
            printfn "%s" (tabs + s))


    tree
    |> Tree.addBranchTobranch "branch5" "root"
    |> Tree.addBranchTobranch "branch5" "branch2"
    |> Tree.toTable
    |> Seq.map (fun row ->
        row
        |> Seq.map (fun tree ->
            match tree with
            | Empty -> ""
            | Leaf leaf -> leaf
            | Branch (branch, _) -> branch)
        |> String.concat "\t")
    |> Seq.iter (printfn "%s")


    tree
    |> Tree.distinct
    |> Seq.iter (Tree.toString id id >> printfn "%s")


    tree
    |> Tree.addBranchTobranch "branch5" "root"
    |> Tree.addBranchTobranch "branch5" "branch2"
    |> Tree.detectCycles
//|> Seq.distinctBy (fun r -> r)



[<RequireQualifiedAccess>]
module SimpleTree =


    module Tree = GeneralTree


    /// Catamorphism of a tree, using:
    /// - fNode: that handles a node type and
    /// - the recursed results of handling the subtrees.
    let cata fNode (tree: SimpleTree<_>) : SimpleTree<_> =
        let fLeaf leaf = fNode leaf Seq.empty
        Tree.cata fLeaf fNode tree


    /// A fold over a tree, using
    /// - fNode: that handles a node type and the accumulator
    let fold fNode acc (tree: SimpleTree<_>) : SimpleTree<_> =
        Tree.fold fNode fNode acc tree


    /// Foldback of a tree, using:
    /// - fNode: that handles a node type and the accumulator
    let foldBack fNode (tree: SimpleTree<_>) acc =
        Tree.foldBack fNode fNode tree acc


    /// Map the node type of a tree, using
    /// - fNode: to map the node type from a -> b
    let map fNode (tree: SimpleTree<_>) : SimpleTree<'Node> =
        Tree.map fNode fNode tree


    /// Iterate through a tree, using
    /// - fNode: to handle the node type and
    let iter fNode (tree: SimpleTree<_>) = Tree.iter fNode fNode tree


    /// Map the node type of a tree, using
    /// - fNode: to map the node type from a -> b
    /// the map functions also get all the tree indexes:
    /// - p: a sequence of parent indexes
    /// - d: the depth of the tree item
    /// - i: the item number in the parent
    let mapi fNode (tree: SimpleTree<_>) : SimpleTree<_> =
        Tree.mapi fNode fNode tree


    /// Gives an nice string representation of a tree
    /// incorperating all tree specific indexes like:
    /// - parent indexes
    /// - depth (by indentation)
    /// - breath (the count) and
    /// - the item number in the list of the parent
    let toString nodeToString (tree: SimpleTree<_>) =
        Tree.toString nodeToString nodeToString tree


    /// Iterate through a tree, using
    /// - fNode: to handle the node type
    /// the handle functions also get all the tree indexes:
    /// - p: a sequence of parent indexes
    /// - d: the depth of the tree item
    /// - b: the breath of the tree item
    /// - i: the item number in the parent
    let iteri fNode (tree: SimpleTree<_>) = Tree.iteri fNode fNode tree


    /// Transform a tree to a table
    let toTable (tree: SimpleTree<_>) : SimpleTree<_> seq seq =
        Tree.toTable tree

    /// Get all distinct nodes of a tree
    let distinct (tree: SimpleTree<_>) : SimpleTree<_> seq = Tree.distinct tree


    /// Detect wheter in a tree there are any cyclic
    /// tree sections
    let detectCycles (tree: SimpleTree<_>) : SimpleTree<_> seq seq =
        Tree.detectCycles tree


    /// Initialize a tree with a node
    let init node : SimpleTree<_> = (node, Seq.empty) |> Branch


    /// Add a node
    let add item node (tree: SimpleTree<_>) : SimpleTree<_> =
        Tree.addBranchTobranch item node tree



module TestSimpleTree =

    module Tree = SimpleTree

    let tree =
        "root"
        |> Tree.init
        |> Tree.add "root" "branch0"
        |> Tree.add "root" "leaf1"
        |> Tree.add "root" "branch1"
        |> Tree.add "branch1" "leaf2"
        |> Tree.add "branch1" "leaf3"
        |> Tree.add "root" "branch2"
        |> Tree.add "branch2" "leaf4"
        |> Tree.add "branch2" "leaf5"
        |> Tree.add "branch1" "branch3"
        |> Tree.add "branch3" "leaf6"
        |> Tree.add "branch2" "branch5"
        |> Tree.add "root" "branch4"


    tree |> Tree.toString id |> printfn "%s"


    tree
    |> Tree.iteri (fun p b d i node ->
        let p = p @ [ i ] |> List.map string |> String.concat "." in
        let s = $"{p} {node} ({b})" in
        let tabs = "\t" |> Seq.replicate d |> String.concat "" in
        printfn "%s" (tabs + s))


    tree
    |> Tree.add "branch5" "root"
    |> Tree.add "branch5" "branch2"
    |> Tree.toTable
    |> Seq.map (fun row ->
        row
        |> Seq.map (fun tree ->
            match tree with
            | Empty -> ""
            | Leaf leaf -> leaf
            | Branch (branch, _) -> branch)
        |> String.concat "\t")
    |> Seq.iter (printfn "%s")


    tree
    |> Tree.distinct
    |> Seq.iter (Tree.toString id >> printfn "%s")


    tree
    |> Tree.add "branch5" "root"
    |> Tree.add "branch5" "branch2"
    |> Tree.detectCycles
//|> Seq.distinctBy (fun r -> r)



[<RequireQualifiedAccess>]
module BinaryTree =

    module Tree = GeneralTree


    let empty = BinaryTree.Empty


    let node a = (a, empty, empty) |> Node

    /// Helper function to map a binary tree
    /// to a general tree
    let mapToGeneralTree (tree: BinaryTree<'Node>) : GeneralTree<'Node, 'Node> =
        let rec recurse tree =
            match tree with
            | BinaryTree.Empty -> GeneralTree.empty
            | Node (node, BinaryTree.Empty, BinaryTree.Empty) ->
                node |> GeneralTree.init
            | Node (node, left, right) ->
                node
                |> GeneralTree.init
                |> GeneralTree.addTobranch (recurse left) node
                |> GeneralTree.addTobranch (recurse right) node

        recurse tree

    /// Helper function to map a general tree to
    /// a binary tree
    let mapToBinaryTree (tree: GeneralTree<_, _>) : BinaryTree<_> =
        let rec recurse tree =
            match tree with
            | GeneralTree.Empty -> empty
            | Branch (branch, trees) when trees |> Seq.length = 0 ->
                branch |> node
            | Branch (branch, trees) when trees |> Seq.length = 2 ->
                Node(
                    branch,
                    trees |> Seq.item 0 |> recurse,
                    trees |> Seq.item 1 |> recurse
                )
            | _ -> $"{tree} is not a valid binary tree" |> failwith

        tree |> recurse


    let applyMap f fBranch tree =
        let fLeaf _ = $"not supported" |> failwith

        tree
        |> mapToGeneralTree
        |> f fLeaf fBranch
        |> mapToBinaryTree


    let applyFold f fBranch acc tree =
        let fLeaf _ = $"not supported" |> failwith

        tree |> mapToGeneralTree |> f fLeaf fBranch acc


    let applyIter f fBranch acc tree =
        let fLeaf _ = $"not supported" |> failwith

        tree |> mapToGeneralTree |> f fLeaf fBranch


    /// Catamorphism of a tree, using:
    /// - fLeaf: that handles a leaf type and
    /// - fBranch: that handles a branch type and
    /// the recursed results of handling the subtrees.
    let cata fNode (tree: BinaryTree<_>) =
        let fBranch node nodes =
            if nodes |> Seq.length <> 2 then
                $"not supported" |> failwith
            else
                fNode
                    node
                    (nodes |> Seq.item 0 |> mapToBinaryTree)
                    (nodes |> Seq.item 1 |> mapToBinaryTree)
                |> mapToGeneralTree

        tree |> applyMap Tree.cata fBranch


    /// A fold over a tree, using
    /// - fLeaf: that handles a leaf type and the accumulator
    /// - fBranch: that handles a branch type and the accumulator
    let fold fNode acc (tree: BinaryTree<_>) =
        let fBranch acc node = node |> fNode acc

        tree |> applyFold GeneralTree.fold fBranch acc


    /// Foldback of a tree, using:
    /// - fLeaf: that handles a leaf type and the accumulator
    /// - fBranch: that handles a branch type and the accumulator
    let foldBack fNode (tree: BinaryTree<_>) acc =
        let fBranch acc node = node |> fNode acc

        let foldBack fLeaf fBranch acc tree =
            GeneralTree.foldBack fLeaf fBranch tree acc

        tree |> applyFold foldBack fBranch acc


    /// Map the leaf and branch types of a tree, using
    /// - fLeaf: to map the leaf type from a -> b and
    /// - fBranch: to map a branch from c -> d
    let map fNode (tree: BinaryTree<_>) : BinaryTree<_> =
        tree |> applyMap Tree.map fNode


    /// Iterate through a tree, using
    /// - fLeaf: to handle the leaf type and
    /// - fBranch: to handle the branch type
    let iter fNode (tree: BinaryTree<_>) = tree |> applyIter Tree.iter fNode


    /// Map the leaf and branch types of a tree, using
    /// - fLeaf: to map the leaf type from a -> b and
    /// - fBranch: to map a branch from c -> d
    /// the map functions also get all the tree indexes:
    /// - p: a sequence of parent indexes
    /// - d: the depth of the tree item
    /// - i: the item number in the parent
    let mapi fNode (tree: BinaryTree<_>) : BinaryTree<_> =
        tree |> applyMap Tree.mapi fNode


    /// Gives an nice string representation of a tree
    /// incorperating all tree specific indexes like:
    /// - parent indexes
    /// - depth (by indentation)
    /// - breath (the count) and
    /// - the item number in the list of the parent
    let toString nodeToString (tree: BinaryTree<_>) =
        tree
        |> mapToGeneralTree
        |> Tree.toString nodeToString nodeToString


    /// Iterate through a tree, using
    /// - fLeaf: to handle the leaf type and
    /// - fBranch: to handle the branch type
    /// the handle functions also get all the tree indexes:
    /// - p: a sequence of parent indexes
    /// - d: the depth of the tree item
    /// - b: the breath of the tree item
    /// - i: the item number in the parent
    let iteri fNode (tree: SimpleTree<_>) = tree |> applyIter Tree.iteri fNode


    /// Transform a tree to a table
    let toTable (tree: BinaryTree<_>) : BinaryTree<_> seq seq =
        tree
        |> mapToGeneralTree
        |> Tree.toTable
        |> Seq.map (Seq.map mapToBinaryTree)

    /// Get all distinct branhces and leaves of a tree
    let distinct (tree: BinaryTree<_>) : BinaryTree<_> seq =
        tree
        |> mapToGeneralTree
        |> Tree.distinct
        |> Seq.map mapToBinaryTree


    /// Detect wheter in a tree there are any cyclic
    /// tree sections
    let detectCycles (tree: BinaryTree<_>) : BinaryTree<_> seq seq =
        tree
        |> mapToGeneralTree
        |> Tree.detectCycles
        |> Seq.map (Seq.map mapToBinaryTree)


    /// Initialize a tree with a branch
    let init = node


    /// Add an item (leaf or branch) to a branch
    let add node origin (tree: BinaryTree<_>) : BinaryTree<_> =
        tree
        |> mapToGeneralTree
        |> Tree.addBranchTobranch node origin
        |> mapToBinaryTree