Family tree zipper example

Zipper.fs

module Zipper

type Person = { Name : string; Children : List<Person> }

type Parent = Parent of {| Name : string;  OtherChildren : List<Person> |} // Note *other* children

/// The "family tree" zipper
type FamilyTree = FamilyTree of Person * List<Parent> // A person and his/her ancestors

/// Person -> FamilyTree
///
/// "Start" a family tree with the given person as the family head. See also `familyHead`.
let familyTree person = FamilyTree (person, [])

/// FamilyTree -> Person
///
/// Whom the given family tree is currently focused at.
let who (FamilyTree (person, _)) = person

/// Name -> FamilyTree -> FamilyTree
///
/// In a family tree, go "down" to the child of `who` with the given name. No effect if `who` does not have a
/// child with that name.
let toChild childName (FamilyTree (person, ancestors)) =
    match person.Children |> List.partition (fun c -> c.Name = childName) with
    | [child], siblings -> FamilyTree (child, Parent {| Name = person.Name; OtherChildren = siblings |} :: ancestors) 
    | _ -> FamilyTree (person, ancestors)

/// FamilyTree -> FamilyTree
///
/// In a family tree, go "up" to the parent of `who`. No effect if `who` is the "family head", i.e. a person without the
/// recorded parent.
let toParent (FamilyTree (person, ancestors)) =
    match ancestors with
    | [] -> FamilyTree (person, ancestors)
    | Parent parent :: olderAncestors ->
        let parent = {
            Name = parent.Name
            Children = person :: parent.OtherChildren
        }
        FamilyTree (parent, olderAncestors)

/// FamilyTree -> Person
///
/// The family head of the given family tree. See also `familyTree`.
let rec familyHead (FamilyTree (person, ancestors) as familyTree) =
    match ancestors with
    | [] -> person
    | _ -> familyHead (toParent familyTree)

/// Name -> FamilyTree -> FamilyTree
///
/// Record a new child of `who` in the given family tree.
let addChild childName (FamilyTree (person, ancestors)) =
    let newChild = {
        Name = childName
        Children = []
    }
    FamilyTree ({ person with Children = newChild :: person.Children }, ancestors)