trapped in the state monad

gistfile1.fs

open System;

module StateMonad =
 
    let (>>=) x f = (fun s0 -> 
        let a,s = x s0 
        f a s)      

    let kwik = (>>=)
    let returnS a b = a, b
    
    type StateBuilder() =
        member m.Bind(x, f) = x >>= f
        member m.Return a = returnS a
 
    let state = new StateBuilder()
 
    let getState = (fun s -> s, s)
    let setState s = (fun _ -> (),s) 
    let Execute m s = m s |> fst

open StateMonad

type Tree<'a> =
    | Leaf of 'a
    | Branch of Tree<'a> * Tree<'a> 
 
let tree =
    Branch(
        Leaf "Max",
        Branch(
            Leaf "Bernd",
            Branch(
                Branch(
                    Leaf "Holger",
                    Leaf "Ralf"),
                    Branch(
                        Leaf "Kerstin",
                        Leaf "Steffen"))))

/// labels a tree by using the state monad
/// (uses F#’s sugared syntax)
let rec labelTree t = state {
   match t with
   | Leaf l ->
        let! s = getState
        do! setState (s+1)  // changing the state
        return Leaf(l,s)
   | Branch(oldL,oldR) ->
        let! newL = labelTree oldL
        let! newR = labelTree oldR
        return Branch(newL,newR)}
 

let mutable state = 0
let rec treeLabeller t =
    match t with
    | Leaf a -> 
        state <- state + 1
        Leaf (state, a)
    | Branch (a, b) ->
        let newA = treeLabeller a
        let newB = treeLabeller b
        Branch (newA, newB)

let treeLabellerNM t =
    let rec treeLabellerInternal t s =
        match t with
        | Leaf a -> s + 1, Leaf(s, a)
        | Branch (a, b) ->
            let (sa, newA) = treeLabellerInternal a s
            let (sb, newB) = treeLabellerInternal b sa
            sb, Branch (newA, newB)
    let _, r = treeLabellerInternal t 1
    r

let printTree t =
    let rec print t level =
        let indent = new String(' ', level * 2)
        match t with
        | Leaf a -> printfn "%sLeaf: %A" indent a
        | Branch (a, b) -> 
            printfn "%sBranch:" indent
            print a (level + 1)
            print b (level + 1)
    print t 0

printTree tree
printfn "====="
printTree (treeLabeller tree)
printfn "====="
printTree (treeLabellerNM tree)
printfn "Labeled (monadic):"
let treeM = Execute (labelTree tree) 0
printTree treeM