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

Rx Live Morse Code Translation

open System

open System.Threading

open System.Threading.Tasks

open System.Reactive.Linq

open System.Reactive.Threading

open System.Reactive.Concurrency

open System.Reactive.Subjects

module Observable =

  let observeOn (scheduler:IScheduler) (xs:IObservable<'a>) =

    Observable.ObserveOn(xs, scheduler)

  let subscribeOn (scheduler:IScheduler) (xs:IObservable<'a>) =

    Observable.SubscribeOn(xs, scheduler)

  let window (f: Unit -> IObservable<'b>) (xs:IObservable<'a>)  =

    Observable.Window(xs, new Func<IObservable<'b>>(f))

  let subscribe' f g (xs:IObservable<'a>) =

    ObservableExtensions.Subscribe(xs, new Action<'a>(f), new Action(g))

let splitBy separator (xs:IObservable<'a>) =

    xs |> Observable.window (fun () -> xs |> Observable.filter (fun x -> x = separator))

       |> Observable.map (Observable.filter (fun y -> y <> separator))         

type MorseCode = Node of string * MorseCode * MorseCode

               | Leaf of string 

               | Empty

let morseCodeTree =

            let zeroNode =  Leaf("0")

            let nineNode =  Leaf("9")

            let dashNode =  Node("", zeroNode, nineNode)

            let nullLeaf =  Empty

            let eightNode =  Leaf("8")

            let dotNode =  Node("", nullLeaf, eightNode)

            let oNode =  Node("O", dashNode, dotNode)

            let qNode =  Node("Q", nullLeaf, nullLeaf)

            let sevenNode =  Leaf("7")

            let zNode =  Node("Z", nullLeaf, sevenNode)

            let gNode =  Node("G", qNode, zNode)

            let mNode =  Node("M", oNode, gNode)

            let yNode =  Leaf("Y")

            let cNode =  Leaf("C")

            let kNode =  Node("K", yNode, cNode)

            let xNode =  Leaf("X")

            let sixNode =  Leaf("6")

            let bNode =  Node("B", nullLeaf, sixNode)

            let dNode =  Node("D", xNode, bNode)

            let nNode =  Node("N", kNode, dNode)

            let tNode =  Node("T", mNode, nNode)

            let oneNode =  Leaf("1")

            let jNode =  Node("J", oneNode, nullLeaf)

            let pNode =  Leaf("P")

            let wNode =  Node("W", jNode, pNode)

            let lNode =  Leaf("L")

            let rNode =  Node("R", nullLeaf, lNode)

            let aNode =  Node("A", wNode, rNode)

            let twoNode =  Leaf("2")

            let udNode =  Node("", twoNode, nullLeaf)

            let fNode =  Leaf("F")

            let uNode =  Node("U", udNode, fNode)

            let threeNode =  Leaf("3")

            let vNode =  Node("V", threeNode, nullLeaf)

            let fourNode =  Leaf("4")

            let fiveNode =  Leaf("5")

            let hNode =  Node("H", fourNode, fiveNode)

            let sNode =  Node("S", vNode, hNode)

            let iNode =  Node("I", uNode, sNode)

            let eNode =  Node("E", aNode, iNode)

            Node("", tNode, eNode)

let extractChar n = match n with

                    | Node (ch, _, _) -> ch

                    | Leaf ch -> ch

                    | Empty -> ""

let processChar acc ch = match (ch, acc) with

                         | '-', Node (_, dash, _) -> dash

                         | '.', Node (_, _, dot) -> dot

                         | _ -> Empty

let translateMorseCode xs = 

              xs |> splitBy ' '

                 |> Observable.map(Observable.scan processChar morseCodeTree >> Observable.map extractChar)

let processKeyPress(subject:ISubject<char>) =       

              let mutable info:ConsoleKeyInfo option = None

              while (info.IsNone || info.Value.Key <> ConsoleKey.Enter) do                            

                       info <- Some (Console.ReadKey())

                       subject.OnNext info.Value.KeyChar                            

              Environment.Exit(0)

let getKeyPresses =       

            let subject = new Subject<char>()

            Task.Run(fun () -> processKeyPress(subject)) |> ignore

            subject |> Observable.observeOn(CurrentThreadScheduler.Instance)

       

let mutable index = 0

let writeCode (x:string) =

    let oldpos = Console.CursorLeft

    Console.SetCursorPosition (index, 1)

    Console.Write x

    Console.SetCursorPosition (oldpos, 0)

getKeyPresses |> translateMorseCode

              |> Observable.subscribe(Observable.subscribe' writeCode  (fun () -> index <- index + 1) >> ignore)

              |> ignore

Thread.Sleep -1