Brian Beckman: The Zen of Stateless State - The State Monad - Part 1

I was thinking that when Visual Studio 2010 finally ships it would be incredibly useful if all these recent C9 parallelism videos (including related theory ones like Brian's) could be pulled together somehow and bundled with the package. If not actually on the DVD then certainly permanently archived online in one, easily navigatable, place.

man, its been a while since briain tied my brain in a knot, ive missed that 

still watching but i gotta ask, is the secret stuff brian's working with oslo? or is it something else?


--edit--

great stuff :O this interview ranks among the best ones ive seen on channel9 but the wmvhigh version (and possibly the others, havent looked yet) end 1:00:47 real abruptly, is there a part two coming?

My guess would be the deep type system and associated libraries support for notions of mutability and functional purity. David Callahan, Anders et al dropped serious hints about this at the PDC.

I am sorry... but is that  a wall of patent cubes on his window sill? O_o

hey dont worry about it charles, just haappy to be of help
i'll watch part two before doing the excercises, some of them didnt make alot of sense to me even after watching part 1 (but that might be because of me )

@AdityaG
sure looks like patent cubes to me :O if you dont stop inventing awsome stuff you'll be walled in brian


(sorry for the spelling, im in belgum and their keyboards are all diffrent)

I have a question. I had assumed that the definition of "bad" would be "a function that has side effects". But Brian gives the key definition as of a mathematical function, which is one that returns the same value given the same arguments. This is much neater because it means that you don't have to decide what "side effect" means (could mean a lot of things). But then I realised that this means that a mathematical function CAN have side effects! It just mustn't allow anything to affect what IT returns for a given set of arguments - but it is okay for it to affect what other functions will return. Those other functions would not be mathematical, because they reveal the side effects. So a mathematical function doesn't reveal side effects via its return - this says nothing about causing them.

So my question is, as long as "printf" returns the same value for a given argument, what does it matter if it has the side effect of printing text out to the console? Why can't I add it to my program harmlessly? Previously I was using all mathematical functions, now I'm adding a printf call somewhere, that's also a mathematical function, so nothing has changed.

(Or can I deduce from this that haskell's equivalent of printf returns a new modified instance of the console every time you call it...? Semi-serious question!)

I (think) I solved exercise 1 & 2. These are really ugly in C# - so much nicer in Haskell. Exercise #2 was terrible, until I realized I needed to change my state updating function depending on if I was going "left" or "right." The single code file is below but I have all the code on github:

  http://github.com/m4dc4p/statemonad/tree/master


If I continue to work on the exercises, commits will show up there. 

Exercise1.cs:

    namespace Exercise1
    {
        // Exercise 1: generalize over the type of the state, from int
        // to <S>, say, so that the SM type can handle any kind of
        // state object. Start with Scp<T> --> Scp<S, T>, from
        // "label-content pair" to "state-content pair".

        public class Scp<State, Contents> // State-Content Pair
        {
            public State label { get; set; }
            public Contents lcpContents { get; set; } // New name; don't confuse
            // with the old "contents"
            public override string ToString()
            {
                return String.Format("Label: {0}, Contents: {1}", label, lcpContents);
            }
        }

        public delegate Scp<State, Contents> S2Scp<State, Contents>(State state);

        public delegate SM<State, Contents2> Maker<State, Contents1, Contents2>(Contents1 input);

        public class SM<State, Contents>
        {
            public S2Scp<State, Contents> s2scp { get; set; }

            public static SM<State, Contents> @return(Contents contents)
            {
                return new SM<State, Contents>
                {
                    s2scp = (st => new Scp<State, Contents>
                    {
                        label = st,
                        lcpContents = contents
                    })
                };
            }

            public static SM<State, Contents2> @bind<Contents2>(SM<State, Contents> inputMonad, Maker<State, Contents, Contents2> inputMaker)
            {
                return new SM<State, Contents2>
                {
                    // The new instance of the state monad is a
                    // function from state to state-contents pair,
                    // here realized as a C# lambda expression:

                    s2scp = (st0 =>
                    {
                        // Deconstruct the result of calling the input
                        // monad on the state parameter (done by
                        // pattern-matching in Haskell, by hand here):

                        var lcp1 = inputMonad.s2scp(st0);
                        var state1 = lcp1.label;
                        var contents1 = lcp1.lcpContents;

                        // Call the input maker on the contents from
                        // above and apply the resulting monad
                        // instance on the state from above:

                        return inputMaker(contents1).s2scp(state1);
                    })
                };
            }
        }
    }

Exercise2.cs:

using System;
using System.Collections.Generic;
using System.Linq;
using System.Text;

namespace StateMonad
{
    namespace Exercise2
    {
        // Exercise 2: go from labeling a tree to doing a constrained
        // container computation, as in WPF. Give everything a
        // bounding box, and size subtrees to fit inside their
        // parents, recursively.

        /// <summary>
        /// A container to fit nodes within. Assume nodes fill their
        /// container.
        /// </summary>
        public class Size
        {
            public Size(int w, int h) { Height = h; Width = w; }

            public int Width { get; private set; }
            public int Height { get; private set; }

            public override string ToString()
            {
                return Width.ToString() + ", " + Height.ToString();
            }
        }

        public class Point
        {
            public Point(int x, int y) { X = x; Y = y; }

            public int X { get; private set; }
            public int Y { get; private set; }

            public override string ToString()
            {
                return X.ToString() + ", " + Y.ToString();
            }
        }

        /// <summary>
        /// Given root a tree and a container size, find the rectangles for each
        /// node in the tree such that all nodes will fit in the container. Only leafs
        /// actually get sizes - branches represent depth only. It is assumed that leaves
        /// will fill all available space.
        /// </summary>
        public class ConstrainTree
        {
            public delegate Exercise1.SM<Size, Size> Updater();

            public static Exercise1.SM<Size, Size> RightUpdateState()
            {
                return new Exercise1.SM<Size, Size>
                {
                    s2scp = (size => new Exercise1.Scp<Size, Size>
                    {
                        label = new Size(size.Width * 2, size.Height * 2),
                        lcpContents = size
                    })
                };
            }

            public static Exercise1.SM<Size, Size> LeftUpdateState()
            {
                return new Exercise1.SM<Size, Size>
                {
                    s2scp = (size => new Exercise1.Scp<Size, Size>
                    {
                        label = new Size(size.Width / 2, size.Height / 2),
                        lcpContents = new Size(size.Width / 2, size.Height / 2)
                    })
                };
            }

            public static Exercise1.SM<Size, Program.Tr<Exercise1.Scp<Size, Size>>> Mk<A>(Program.Tr<A> tree, Updater update)
            {
                if (tree is Program.Lf<A>)
                {
                    var leaf = (Program.Lf<A>)tree;
                    return Exercise1.SM<Size, Size>.bind<Program.Tr<Exercise1.Scp<Size, Size>>>(update(),
                        (contents1 =>
                            Exercise1.SM<Size, Program.Tr<Exercise1.Scp<Size, Size>>>.@return(
                            new Program.Lf<Exercise1.Scp<Size, Size>>
                            {
                                contents = new Exercise1.Scp<Size, Size>
                                {
                                    label = contents1,
                                    lcpContents = contents1
                                }
                            })));
                }
                else
                {
                    var branch = (Program.Br<A>)tree;
                    var left = branch.left;
                    var right = branch.right;

                    return Exercise1.SM<Size, Program.Tr<Exercise1.Scp<Size, Size>>>.bind<Program.Tr<Exercise1.Scp<Size, Size>>>(
                        Mk<A>(left, new Updater(LeftUpdateState)),
                        (newLeft => Exercise1.SM<Size, Program.Tr<Exercise1.Scp<Size, Size>>>.bind<Program.Tr<Exercise1.Scp<Size, Size>>>(
                            Mk<A>(right, new Updater(RightUpdateState)),
                            (newRight => Exercise1.SM<Size, Program.Tr<Exercise1.Scp<Size, Size>>>.@return(
                                new Program.Br<Exercise1.Scp<Size, Size>>
                                {
                                    left = newLeft,
                                    right = newRight
                                }
                                ))
                                )));
                }
            }

            /// <summary>
            /// After traversal the width and height on each node will represent the maximum
            /// bounding box size necessary to cover all children of the node, assuming a binary
            /// tree laid out "down". A bounding box of 1 x 1 will over the node itself.
            /// </summary>
            /// <typeparam name="Contents1"></typeparam>
            /// <param name="tree"></param>
            /// <returns></returns>
            public static Program.Tr<Exercise1.Scp<Size, Size>> Bound<A>(Program.Tr<A> tree, Size containerSize)
            {
                return Mk<A>(tree, new Updater(LeftUpdateState)).s2scp(containerSize).lcpContents;
            }
        }

    }
}

I don't quite understand what "state" means and what is being done with it.  Passing along state and incrementing it makes sense conceptually, but what mechanism is providing the benefit? The haskell compiler?

TIA
Ben Lipman

// F# Monadic tree labeller (using State Monad from http://cs.hubfs.net/forums/thread/7472.aspx)

let rec private mNode (x) =
    match x with
    | Leaf(c) -> state { let! x = GetState
                         do! SetState (x + 1)
                         return Leaf(c,x) }
                         
    | Node(l,r) -> state { let! l = mNode(l)
                           let! r = mNode(r)
                           return Node(l,r) }
                    
let mLabel x = Exec(mNode(x))


// F# Non-Monadic manual state passing tree labeller

let Label a s = 
    let rec Lab' a s = 
                match a with 
                |Leaf(c) -> (Leaf(c,s), s + 1) 
                
                |Node(l,r) -> let l' = Lab' l s 
                              let r' = Lab' r (snd l')
                              (Node(fst l', fst r'), (snd r')) 
     fst (Lab' a s) 

//F# State Monad

type State<'state, 'a> = State of ('state ->'a * 'state)

type StateMonad() = 
        member b.Bind(m, f) = State (fun s -> let r = match m with
                                                      | State f -> f s
                                              match r with
                                              | (v,s) -> match f v with
                                                         | State f -> f s)    
        member b.Return(x) = State (fun s -> x, s)

let state = StateMonad()

let GetState = State (fun s -> s, s)
let SetState s = State (fun _ -> (), s)  

let Execute m s = match m with
                  | State f -> let r = f s
                               match r with
                               |(x,_) -> x

Here is Exercise 3. All the code is available for download at

http://github.com/m4dc4p/statemonad/tree/exercise3

I added some tags so I can push updates and not break the exercises. 

The M class is abstracted over the contents of the monad, but it feels like it should be abstracted over the specific monad AND the contents. In Haskell the monad class is declared as:

  class Monad m where
    (>>=) :: m a -> (a -> m b) -> m b -- bind
    return :: a -> m a

where "m" is abstractd, but I could not get that working in C#. I think that is because C# lacks "higher-kinded" types but I'm not sure. This shows up in my implementation as casts in the overriden bind and @return methods.

First my M class:

namespace StateMonad
{
    namespace Exercise3
    {
        public abstract class M<Contents1>
        {
            public delegate M<Contents2> Maker<Contents2>(Contents1 c);

            public abstract M<Contents2> @bind<Contents2>(M<Contents1> input, Maker<Contents2> maker);

            public abstract M<Contents1> @return(Contents1 contents);
        }

        public class Scp<State, Contents> // State-Content Pair
        {
            public State label { get; set; }
            public Contents lcpContents { get; set; } // New name; don't confuse
            // with the old "contents"
            public override string ToString()
            {
                return String.Format("Label: {0}, Contents: {1}", label, lcpContents);
            }
        }

        public delegate Scp<State, Contents> S2Scp<State, Contents>(State state);

        public class SM<State, Contents1> : M<Contents1>
        {
            public S2Scp<State, Contents1> s2scp { get; set; }

            public override M<Contents2> bind<Contents2>(M<Contents1> input, Maker<Contents2> maker)
            {
                // These casts are UGLY but I can't seem to get
                // rid of them ...
                return (M<Contents2>) new SM<State, Contents2>
                {
                    // The new instance of the state monad is a
                    // function from state to state-contents pair,
                    // here realized as a C# lambda expression:

                    s2scp = (st0 =>
                    {
                        // Deconstruct the result of calling the input
                        // monad on the state parameter (done by
                        // pattern-matching in Haskell, by hand here):

                        Scp<State, Contents1> lcp1 = ((SM<State, Contents1>) input).s2scp(st0);
                        State state1 = lcp1.label;
                        Contents1 contents1 = lcp1.lcpContents;

                        // Call the input maker on the contents from
                        // above and apply the resulting monad
                        // instance on the state from above:
                        var m = maker(contents1);
                        var r = ((SM<State, Contents2>)m).s2scp(state1);
                        return r;
                    })
                };
            }

            public override M<Contents1> @return(Contents1 contents)
            {
                return new SM<State, Contents1>
                {
                    s2scp = (st => new Scp<State, Contents1>
                    {
                        label = st,
                        lcpContents = contents
                    })
                };
            }
        }
   }
}

and the ConstrainedTree example I implemetned in Excercise2 (exactly the same except I added some casts). This is about the most painful C# I've ever had to write!  Fortunately teh compiler helps a lot by telling me which types don't match:

namespace StateMonad
{
    namespace Exercise3
    {
        public class Size
        {
            public Size(int w, int h) { Height = h; Width = w; }

            public int Width { get; private set; }
            public int Height { get; private set; }

            public override string ToString()
            {
                return Width.ToString() + ", " + Height.ToString();
            }
        }

        public class ConstrainTree
        {
            public delegate Exercise3.SM<Size, Size> Updater();

            public static Exercise3.SM<Size, Size> RightUpdateState()
            {
                return new Exercise3.SM<Size, Size>
                {
                    s2scp = (size => new Exercise3.Scp<Size, Size>
                    {
                        label = new Size(size.Width * 2, size.Height * 2),
                        lcpContents = size
                    })
                };
            }

            public static Exercise3.SM<Size, Size> LeftUpdateState()
            {
                return new Exercise3.SM<Size, Size>
                {
                    s2scp = (size => new Exercise3.Scp<Size, Size>
                    {
                        label = new Size(size.Width / 2, size.Height / 2),
                        lcpContents = new Size(size.Width / 2, size.Height / 2)
                    })
                };
            }

            public static Exercise3.SM<Size, Program.Tr<Exercise3.Scp<Size, Size>>> Mk<A>(Program.Tr<A> tree, Updater update)
            {
                if (tree is Program.Lf<A>)
                {
                    var leaf = (Program.Lf<A>)tree;
                    return (Exercise3.SM<Size, Program.Tr<Exercise3.Scp<Size, Size>>>)
                        (new Exercise3.SM<Size, Size>()).bind<Program.Tr<Exercise3.Scp<Size, Size>>>(update(),
                        (contents1 =>
                            (new Exercise3.SM<Size, Program.Tr<Exercise3.Scp<Size, Size>>>()).@return(
                            new Program.Lf<Exercise3.Scp<Size, Size>>
                            {
                                contents = new Exercise3.Scp<Size, Size>
                                {
                                    label = contents1,
                                    lcpContents = contents1
                                }
                            })));
                }
                else
                {
                    var branch = (Program.Br<A>)tree;
                    var left = branch.left;
                    var right = branch.right;

                    return (Exercise3.SM<Size, Program.Tr<Exercise3.Scp<Size, Size>>>)
                        (new Exercise3.SM<Size, Program.Tr<Exercise3.Scp<Size, Size>>>()).bind<Program.Tr<Exercise3.Scp<Size, Size>>>(
                        Mk<A>(left, new Updater(LeftUpdateState)),
                        (newLeft => (new Exercise3.SM<Size, Program.Tr<Exercise3.Scp<Size, Size>>>()).bind<Program.Tr<Exercise3.Scp<Size, Size>>>(
                            Mk<A>(right, new Updater(RightUpdateState)),
                            (newRight => (new Exercise3.SM<Size, Program.Tr<Exercise3.Scp<Size, Size>>>()).@return(
                                new Program.Br<Exercise3.Scp<Size, Size>>
                                {
                                    left = newLeft,
                                    right = newRight
                                }
                                ))
                                )));
                }
            }

            /// <summary>
            /// After traversal the width and height on each node will represent the maximum
            /// bounding box size necessary to cover all children of the node, assuming a binary
            /// tree laid out "down". A bounding box of 1 x 1 will over the node itself.
            /// </summary>
            /// <typeparam name="Contents1"></typeparam>
            /// <param name="tree"></param>
            /// <returns></returns>
            public static Program.Tr<Exercise3.Scp<Size, Size>> Bound<A>(Program.Tr<A> tree, Size containerSize)
            {
                return Mk<A>(tree, new Updater(LeftUpdateState)).s2scp(containerSize).lcpContents;
            }
        }

    }
}

I see - so Haskell says "trust me, this won't last" and Haskell is undoubtedly correct!

// F# Monadically label n-ary tree

let MMap f xs = 
            let rec MMap' (f, xs', out) = 
                state {
                        match xs' with
                        | h :: t -> let! h' = f(h)
                                    return! MMap'(f, t, List.append out [h'])
                        | [] -> return out
                      }
            MMap' (f, xs, [])


let rec private MNNode (x) =
    match x with
    | NLeaf(c) -> state { let! x = GetState
                          do! SetState (x + 1)
                          return NLeaf(c,x) }
                         
    | NNode(xs) -> state { let! xs' = MMap MNNode xs
                           return NNode(xs')  } 
                    
let MNLabel x = Execute(MNNode(x))

//LINQ Monadic Labelling of a Binary Tree

public static StateMonad<BTree> MLabel(BTree tree)
{
    var branch = tree as BBranch;
    var leaf = tree as BLeaf;

    StateMonad<BTree> ret = null;

    if (leaf != null)
    {
        var q = from x in LinqStateMonad.GetState()
                from f in LinqStateMonad.SetState<int>(x + 1)
                select new BLeaf { Content = leaf.Content, State = x };
        ret = s => { var r = q(s); return new StateContentPair<BTree>(r.Content, r.State); };
    }

    if (branch != null)
    {
        var q = from l in MLabel(branch.Left)
                from r in MLabel(branch.Right)
                select new BBranch() { Left = l, Right = r };
        ret = s => { var r = q(s); return new StateContentPair<BTree>(r.Content, r.State); };
    }

    return ret;
}

//LINQ State Monad implementation

public delegate StateContentPair<T> StateMonad<T>(int state);

public static class LinqStateMonad
{
    public static StateMonad<U> Select<T, U>(this StateMonad<T> p, Func<T, U> selector)
    {
        return state => new StateContentPair<U>(selector(p(state).Content), state);
    }
    public static StateMonad<V> SelectMany<T, U, V>(this StateMonad<T> p, Func<T, StateMonad<U>> selector, Func<T, U, V> projector)
    {
        return state =>
        {
            var first = p(state);
            var second = selector(first.Content)(first.State);
            var content = projector(first.Content, second.Content);
            return new StateContentPair<V>(content, second.State);
        };
    }

    public static StateMonad<int> GetState()
    {
        return s => new StateContentPair<int>(s, s);
    }

    public static StateMonad<T> SetState<T>(int s1)
    {
        return s => new StateContentPair<T>(default(T), s1);
    }
}

Brian, I think I get it now.  I was thrown off by the example.  It makes sense that you need to copy the state around to avoid side affects.   I guess the my practical (and procedural) side is too worried that the size of the state and the overhead of copying it over and over is too large for the scenarios I deal with. 

I also agree with what you said in the video about when the project is intricate enough you end up having to deal with all these nasty problems with state dependency, locking, etc.

Ben

// F# Parser Monad (http://www.cs.nott.ac.uk/~gmh/pearl.pdf)

type Parser<'a> = Parser of (string ->('a * string) list)

let extract(Parser(f)) = f

type ParserMonad() = 
        member b.Bind(p, f) = Parser (fun cs -> 
                                                let r = extract(p) cs
                                                let r' = List.map (fun (a,cs') -> extract(f a) cs') r
                                                List.concat r')
        member b.Return(x) = Parser (fun cs -> [x,cs])
        member b.Zero() = Parser (fun cs -> [])


let (++) p q = Parser(fun cs -> List.append (extract p cs) (extract q cs))
let (+++) p q = Parser(fun cs -> match (extract(p ++ q) cs) with
                                 | [] -> []
                                 | x::xs -> [x])

let parser = ParserMonad()

// F# Parsers combinators :))

//A parser which successfully consumes the first character
//if the argument string is non-empty, and fails otherwise.
let item = Parser (fun cs -> match cs with
                             | "" -> []
                             | cs -> [cs.[0], cs.Substring(1)])
                            
//A combinator sat that takes a predicate, and yields a parser that
//consumes a single character if it satisfies the predicate, and fails otherwise.
let sat p = parser { let! c = item
                     if p c then
                      return c }
                      
//A parser for specific characters
let char c = sat (fun s -> c = s)
                                            
//Parse a specific string
let rec stringp s = match s with
                    | "" -> parser { return [] }
                    | xs -> parser { let! c = char xs.[0]
                                     let! cs = stringp (xs.Substring(1))
                                     return c::cs }                        
                                                          
//The many combinator permits zero
//or more applications of p, while many1 permits one or more.
let rec many1 p = parser { let! x = p
                           let! xs = many p
                           return (x::xs) }
and many p = (many1 p) +++ parser { return [] }

                            
//Parse repeated applications of a parser p, separated by applications of a parser
//op whose result value is an operator that is assumed to associate to the left,
//and which is used to combine the results from the p parsers.
and chainl1 p op = 
    let rec rest a = parser { let! f = op
                              let! b = p
                              return! rest (f a b) } +++ parser { return a }
    parser { let! a = p
             return! rest a } 
           
//Parse a string of spaces.
let space = many (sat (fun s -> Char.IsWhiteSpace s))

//Parse a token using a parser p, throwing away any trailing space.
let token p = parser { let! a = p
                       let! _ = space
                       return a }

//Parse a symbolic token:
let symb cs = token (stringp cs)

//Apply a parser p, throwing away any leading space:
let apply p = extract (parser { let! _ = space
                                let! r = p
                                return r })

//F# Monadic Parser - Calculator Example :))) 

// Grammar
//expr ::= expr addop term j term
//term ::= term mulop factor j factor
//factor ::= digit j ( expr )
//digit ::= 0 j 1 j : : : j 9
//addop ::= + j -
//mulop ::= * j /

let addOp = parser { let! _ = symb "+" 
                     return (+) } +++ parser { let! _ = symb "-" 
                                               return (-) } 
let mulOp = parser { let! _ = symb "*" 
                     return (*) } +++ parser { let! _ = symb "/" 
                                               return (/) }  
let digit = parser { let! x = token (sat (fun ch -> Char.IsDigit(ch)))
                     return Char.GetNumericValue(x) - Char.GetNumericValue('0') }

let rec expr   = chainl1 term addOp
and     term   = chainl1 factor mulOp
and     factor = digit +++ parser { let! _ = symb "("
                                    let! n = expr
                                    let! _ = symb ")"
                                    return n }
                                    
let parse s = match apply expr s  with
              | [] -> failwith "failed to parse"
              | (ret, _)::xs -> ret 
                                    

Thank you Brian

I love this stuff. I've been an OO developer for a long time and it is only thank to F# and videos like yours that I started appreciating the beauty of functional ideas. I think my coding at work is improving as a result of this exposure.

I plan to have exercise 10 ready before the end of the year ))

HoloEd

Thank you Charles

// The List Monad in F#

#light

type List<'a> = List of ('a -> 'a list)

type ListMonad() =
    member o.Bind(  (m:'a list), (f: 'a -> 'b list) ) = List.concat( List.map (fun x -> f x) m )
    member o.Return(x) = [x]

let list = ListMonad()

let cartesian = list { let! x = [1..3]
                       let! y = [4..6]
                       return (x,y) }

printf "%A" cartesian

woah holoed you Are the man i havent had time to write out the excercises yet(but ive tried to solve them in my head ), 8 people (out of 35) are beeling let go from where i work and i have to take over like 2 positions plus my own nut no more excuses i really really enjoyed this interview+excercises

please pretty please charles and brian,  do intervies like this about the other monads as well

"So... any solutions available for the exercises above?" <| Geez! Maybe I should look to see if pages of comments exist before displaying my stupidity to the world. Great work holoed!

Here's my solution to exercise 2 using F#:

 

The type defs:

  type Rect =

    { Height: float;

      Width: float;

      Top: float;

      Left: float }

    with override r.ToString() = String.Format("Height: {0}, Width: {1}, Top: {2}, Left: {3}", r.Height, r.Width, r.Top, r.Left)

 

  type Tree<'a> =

    | Leaf of 'a

    | Branch of Tree<'a> * Tree<'a>

 

  // The show method already takes into account the tuples,

  // unlike the show method that is overloaded in the C# version.

  let show tree =

    let rec printTree tree level =

      let spacing = new string(' ', level * indentation)

      printf "%A" spacing

      match tree with

      | Leaf(label, contents) ->

          let labelString = label.ToString()

          printfn "Leaf: %s, Contents: %A" labelString contents

      | Branch(left, right) ->

          printfn "Branch: "

          printTree left (level + 1)

          printTree right (level + 1)

    printTree tree 0

 

The state monad builder:

  (* StateMonad *)

  type State<'S, 'a> = State of ('S -> 'S * 'a)

 

  (* StateBuilder Bounder *)

  let boundTree tree seed leftUpdater rightUpdater =

    let rec labelTree t updater =

      match t with

      | Leaf(c)      -> state { let! s = getState

                                let (next, curr) = updater s

                                do! setState next

                                return Leaf(curr, c) }

 

      | Branch(l, r) -> state { let! l = labelTree l leftUpdater

                                let! r = labelTree r rightUpdater

                                return Branch(l, r) }

 

    exec (labelTree tree leftUpdater) seed

 

  let eval sm s =

    match sm with

    | State f -> f s |> fst

 

  let exec sm s =

    match sm with

    | State f -> f s |> snd

 

The demo tree:

let demoTree = Branch(

                 Leaf("A"), 

                 Branch(

                   Branch(

                     Leaf("B"),

                     Leaf("C")),

                   Leaf("D")))

 

The updaters and execution code:

let leftBounder =

  fun (depth, rect) -> let newDepth = depth + 1.0

                       let multiplier = 2.0 * newDepth

                       ( (newDepth,

                          { Height = rect.Height

                            Width = rect.Width / multiplier

                            Top = rect.Top

                            Left = rect.Left + rect.Width / multiplier }),

                         { Height = rect.Height

                           Width = rect.Width / multiplier

                           Top = rect.Top

                           Left = rect.Left } )

 

let rightBounder =

  fun (depth, rect) -> let newDepth = depth - 1.0

                       ( (newDepth,

                          { Height = rect.Height

                            Width = rect.Width * 2.0

                            Top = rect.Top

                            Left = rect.Left + rect.Width }),

                         rect )

 

let initialDepth = 0.0

let initialRect = { Height = 100.0

                    Width = 100.0

                    Top = 0.0

                    Left = 0.0 }              

let ex2Seed = (initialDepth, initialRect)

 

printfn "Bound tree to rects"

let bTree = boundTree demoTree ex2Seed leftBounder rightBounder

show bTree

 

This works, but I imagine there must be a better way. I'm open to suggestions.

Thanks for including the visio diagrams. Will print them and look at the code...

Does the style of logic/flow diagraming (ie. in Visio) have a special name? It seems like a good way to reason about the problem and was hopinh to find out more information about it?