Last active
July 17, 2022 07:56
-
-
Save halcwb/ec64ae3a4e1c2e1257096e5d5766e559 to your computer and use it in GitHub Desktop.
Recursive tree type and handling of recursive trees
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
[<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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment