Inside F#

Brian's thoughts on F# and .NET

Archive for June, 2008

Catamorphisms, part eight

Posted by Brian on June 16, 2008

In the interest of completeness, I have to point out one thing I left out of the previous blog entry in the series.  Some of you may have wondered why I used the continuation monad in "Change5to0bst", but not in the definition of KFoldTree.  If you try writing KFoldTree as

let KFoldTree nodeF leafV tree =
    let rec Loop t = K {
        match t with
        | Node(x,left,right) -> return! nodeF x (Loop left) (Loop right) t
        | Leaf -> return! leafV t 
    }
    Loop tree (fun x -> x)

(with the rest of the code unchanged since the previous blog entry,) you’ll discover you once again get a stack overflow.  Ack!  The good news is, this is just because I originally defined the monad slightly wrong.  The fix is simple; here is the corrected definition:

type ContinuationBuilder() =
    member this.Return(x) = (fun k -> k x)
    member this.ReturnFrom(x) = x
    member this.Bind(m,f) = (fun k -> m (fun a -> f a k))
    member this.Delay(f) = (fun k -> f () k)
let K = new ContinuationBuilder()

The only difference is the definition of Delay, which has undergone eta-conversion.  With the corrected definition of "K", the above code for KFoldTree works correctly.  I am posting this just for completeness and posterity, so no deep explanations or new material today. 

The end!

Posted in Uncategorized | 3 Comments »

“Game of Life” Challenge

Posted by Brian on June 15, 2008

I was browsing the web looking for fun small programming tasks, and I stumbled across Conway’s Game of Life.  This is an oldie but a goodie; I am continually fascinated by how such a simple set of rules and starting conditions leads to such complex behavior.

Coding up the game logic is simple; however I know so little about graphics/presentation that I struggled to make a minimal display.  The first thing I got working was displaying a different bitmap image each frame, yielding results that look like this:

GameOfLife

While good enough to watch, I would love to make it prettier (show the number of generations, perhaps use color to suggest the age of cells, use circles or gridlines or something that makes the image itself look nicer) and have interaction (slider bar to control speed, ability to pause and interact to add/remove cells, change size/zoom of overall grid), as well as be better engineered (the code I wrote does both the animation and the display very crudely), but I lack the WPF skills, the time, or both.

…Hence the "challenge" in the blog title today.  Show me your skills!  I would like to see what others can do with F#.  Extra points for good eye candy, cool user interaction, and demonstration of advanced WPF features.  You can put a link to your submission as a ‘comment’ on this blog entry.  Have fun!

(EDIT, Feb 2010: I just saw http://fsharpnews.blogspot.com/2010/02/john-conways-game-of-life-in-32-lines.html check it out)

The source code

Here’s the code I have:

#I @"C:\Program Files\Reference Assemblies\Microsoft\Framework\v3.0" 
#r @"WindowsBase.dll" 
#r @"PresentationCore.dll" 
#r @"PresentationFramework.dll"

open System
open System.Windows 
open System.Windows.Controls 
open System.Windows.Media 
open System.Windows.Media.Imaging
open System.Threading

let MAXX = 80
let MAXY = 60
let SCALE = 8   // size of block in pixels – this must be 8 (for simplicity of coding bitmap)

// game board is just 2D array of bools
let mutable cells = Array2D.create MAXX MAXY false

let NumNeighbors(x,y) =
    let At(x,y) =
        if x < 0 || x >= MAXX || y < 0 || y >= MAXY then
            false
        else
            cells.[x,y]
    let mutable r = 0
    if At(x-1,y-1) then r <- r + 1
    if At(x-1,y) then r <- r + 1
    if At(x-1,y+1) then r <- r + 1
    if At(x,y-1) then r <- r + 1
    if At(x,y+1) then r <- r + 1
    if At(x+1,y-1) then r <- r + 1
    if At(x+1,y) then r <- r + 1
    if At(x+1,y+1) then r <- r + 1
    r

// compute next board
let Tick() =
    let nextCells = Array2D.init MAXX MAXY (fun x y ->
        if cells.[x,y] then
            match NumNeighbors(x,y) with
            | 2 | 3 -> true
            | _ -> false
        else
            NumNeighbors(x,y) = 3)
    cells <- nextCells

// use a small grid of 1s and 0s to initialize the whole grid;
// put initial contents in the center of the large grid
let Init(seed) =
    let seedHeight = Array.length seed
    let seedWidth = Array.length seed.[0]
    let starty = (MAXY – seedHeight) / 2
    let startx = (MAXX – seedWidth) / 2
    for x in 0..seedWidth-1 do
        for y in 0..seedHeight-1 do
            cells.[startx+x,starty+y] <- seed.[y].[x] = 1

// some sample starters
let glider = [| [| 1; 1; 1 |] 
                [| 1; 0; 0 |]
                [| 0; 1; 0 |]
             |]
let diehard = [| [| 0; 0; 0; 0; 0; 0; 1; 0 |] 
                 [| 1; 1; 0; 0; 0; 0; 0; 0 |]
                 [| 0; 1; 0; 0; 0; 1; 1; 1 |]
              |]
let fPentomino = [| [| 0; 1; 1 |] 
                    [| 1; 1; 0 |]
                    [| 0; 1; 0 |]
                 |]
let acorn = [| [| 0; 1; 0; 0; 0; 0; 0 |] 
               [| 0; 0; 0; 1; 0; 0; 0 |]
               [| 1; 1; 0; 0; 1; 1; 1 |]
            |]
             
Init(acorn)

type MyWPFWindow() as this = 
    inherit Window()    

    // make a bitmap of the data
    let GetByte bn =
        let n = bn * 8
        let y = n / (MAXX*SCALE*SCALE)
        let xs = n % (MAXX*SCALE*SCALE)
        let x = (xs % (MAXX*SCALE))/SCALE
        if not(cells.[x,y]) then
            byte 255
        else
            byte 0
    let MakeBitmapSource() =
        let bytes = Array.init (SCALE*MAXX*MAXY) GetByte
        BitmapSource.Create(SCALE*MAXX, SCALE*MAXY, 1., 1., PixelFormats.BlackWhite, 
                            BitmapPalettes.BlackAndWhite, bytes, MAXX)
    // display code   
    let image = new Image(Width=float (SCALE*MAXX), Height=float (SCALE*MAXY))
    let mutable iter = 0
    do
        image.Source <- MakeBitmapSource()
        CompositionTarget.add_Rendering(fun o e -> // prevent loss of first frame
                                                   if iter < 2 then 
                                                       iter <- iter + 1
                                                   else
                                                       Tick()
                                                       image.Source <- MakeBitmapSource()
                                                       Thread.Sleep(200))
        this.Content <- image
        this.Title <- "Game of Life" 
        this.SizeToContent <- SizeToContent.WidthAndHeight  

[<STAThread()>] 
do  
    let app =  new Application() 
    app.Run(new MyWPFWindow()) |> ignore

Posted in Uncategorized | 1 Comment »

Catamorphisms, part seven

Posted by Brian on June 7, 2008

The code in the previous blog entry was difficult to read due to the use of explicit continuations.  Today I’ll show how to make the code more readable using a continuation monad.  I’ll also discuss F# "computation expressions" (a.k.a. "workflows") in a little more depth.

(Today’s blog entry is probably the most "advanced" that I’ve written, as it deals with three advanced functional programming concepts (catamorphisms, continuations, and monads) simultaneously.  I’ll try to revert back to some beginner/intermediate F# topics (that may attract a wider audience) in future blog entries… but today I am just writing about things that tickle my fancy.)

The trouble with continuations

Continuations are an almost indispensable mechanism for achieving certain goals.  For example, in the previous entry I showed how to use KFold to process arbitrary tree-like data structures without using the call stack.  This is a win when you need to process large, arbitrarily-shaped (e.g. unbalanced trees) data.  However the resulting code suffered a bit in terms of readability.  Last time we ended up with code like

let Change5to0bstExplicitContinuations tree = 
    KFoldTree (fun x kl kr (Node(_,oldL,oldR)) k -> 
        if x < 5 then 
            kr (fun newR -> 
            k (Node(x, oldL, newR))) 
        elif x > 5 then 
            kl (fun newL -> 
            k (Node(x, newL, oldR))) 
        else 
            k (Node(0,oldL,oldR)) 
    ) (fun t k -> k t) tree

for changing one value to another in a binary search tree.  The weird bits now are that our lambdas take an extra "k" parameter at the end of the parameter list, and we write code using the "k" variables rather awkwardly.  Compare the code above to a simple, non-tail-recursive implementation of the same method which doesn’t use a fold:

let rec Change5to0bstUsingStack tree =
    match tree with
    | Node(x,oldL,oldR) ->
        if x < 5 then
            let newR = Change5to0bstUsingStack oldR
            Node(x, oldL, newR)
        elif x > 5 then
            let newL = Change5to0bstUsingStack oldL
            Node(x, newL, oldR)
        else
            Node(0, oldL, oldR)
    | Leaf -> tree

The main difference I want to highlight is this

            kr (fun newR -> 
            k (Node(x, oldL, newR))) 

versus this

            let newR = Change5to0bstUsingStack oldR
            Node(x, oldL, newR)

The latter code looks much more familiar, whereas the former code that explicitly uses continuations looks kind of odd/backwards and uses weird lambdas and parens that are hard to read/parse at a glance.

It turns out that we can leverage F# computation expressions to get better syntax for the continuation-version of the code.  By coding up the continuation monad, we can use continuation workflows, so that that little code snippet becomes

            let! newR = kr               
            return Node(x, oldL, newR)

In the long run, this is much more readable an understandable (especially if there are more than 2 lines of code) than the explicit continuations version.  But the "let!" and "return" keywords are pretty new to us (we saw them in passing in a previous blog about async workflows), so let’s pause and talk a little about F# computation expressions first.

How to read F# computation expressions

F# computation expressions are a syntax sugar for writing code where a portion of that code deals with a particular monad.  (I’m continuing to defer the discussion of exactly what a monad is, but if you’ve been keeping up with previous blog entries I’ve written, you know that parsers can be expressed as a monad, and asynchronous computations can be expressed through monads, and today we’ll see a monad of continuations.  Monads have many uses, but they are very abstract, and thus hard to explain without a lot of examples already under your belt.)  A computation expression takes this general form:

    foo { comp_expr_code }

where "foo" is a "builder" object for a particular monad, and then comp_expr_code is code written using a special subset of F# that can be used inside computation expressions.

Consider this "normal" F# code:

    let x = 3
    f()
    let y = g(x)
    h(y)
    x + y

Assuming that all these functions and values have nothing to do with the "foo" monad, we can lift this code into a computation expression for foos thusly:

    foo {
        let x = 3 
        do f() 
        let y = g(x) 
        do h(y) 
        return x + y
    }

When moving code into a computation expression, "let"s are unchanged, functions that are called just for effects are prefixed with "do", and the final value is prefixed with the "return" keyword.  The result is code with pretty much the same meaning, except that the whole expression has been lifted into the "foo" monad, which may change its final value and type.  If in this example, "x" and "y" had type "int", then the normal code results in an "int", whereas the computation expression results in a value of type "Foo<int>" where "Foo" is some data type associated with the monad described by builder "foo".

A concrete example will help – consider asynchronous computations.  In the example above, if "foo" is replaced with "async", then the result of the whole expression is an "Async<int>" – an asynchronous computation that will eventually yield a value of type "int".  Recall that "Async<‘a>" is the data type that describes asynchronous computations, and "async" is the corresponding "builder" object for the asynchronous monad ("async" and "Async<‘a>" are defined in the F# Control library).

In addition to "let", "do" and "return", which operate on "normal" values, there are corresponding keywords "let!", "do!", and "return!" which operate on monadic values.  In our previous example, "g" was a function that returned an "int", and "h" was a function that returned "unit".  Suppose, instead, that "g" returns a "Foo<int>" and "h" returns "Foo<unit>".  In that case, we could write

   foo {
        let x = 3 
        do f() 
        let! y = g(x) 
        do! h(y) 
        return x + y
    }

where we have added the "!" (usually pronounced "bang") to the lines using "g" and "h".  The "!" says that the expression being processed is monadic, and should be processed according to the semantics given by the corresponding builder object.  The results of these monadic computations still have "normal" values – so for example, even though "g" returns a "Foo<int>", the "let!" ensures that the type of "y" is simply "int".

Again, a concrete example helps – consider again async computations.  Suppose "g" returns an Async<int>.  The "let!" says to run that async computation to completion until it yields an "int" value, and then bind that value to "y".  Similarly, if "foo" were "async", then "do!" would run its async computation to completion to produce an effect.

In short, inside a computation expression, you use "let", "do", and "return" for "normal" values, and you use "let!", "do!", and "return!" for values with a monadic type that need special processing specific to the particular monad we are in (as described by the builder object).  As with LINQ in C#, it’s all just syntax sugar – the compiler desugars the code snippet above into

    foo.Delay(     fun () -> 
    let x = 3  
    do f()  
    foo.Bind(g(x), fun->
    foo.Bind(h(y), fun () ->
    foo.Return(x+y))))))

Now, it just so happens that, given particular interesting definitions of "Delay", "Bind", and "Return", you can make that little code snippet have all kinds of interesting effects (like async, or parsing, or continuations, or …) – that is the magic of monads.  But we’re getting ahead of ourselves – for now, at least you have a cursory introduction to the F# computation expression syntax.

Defining a continuation monad

A continuation monad in F# can be defined like so:

type ContinuationBuilder() =
    member this.Return(x) = (fun k -> k x)
    member this.ReturnFrom(x) = x
    member this.Bind(m,f) = (fun k -> m (fun a -> f a k))
    member this.Delay(f) = f()
let K = new ContinuationBuilder()

Unless you are trying to understand the mechanics of what is going on very deeply, you can pretty much just gloss over that definition – continuation monads are well-understood, and that’s what it looks like to write one in F#.  Generally this is code that would be off in a library somewhere, but this code isn’t in any of the standard F# libraries, so I’m writing it myself.

What is important is that, with this thing in hand, we can now write "continuation workflows", which are just computation expressions that use the "K" builder object to produce values in the monad of continuations.  Let’s see how to use it.

Leveraging the continuation monad to make our code more readable

Consider again our code that was traversing a binary search tree to replace values:

let Change5to0bstExplicitContinuations tree = 
    KFoldTree (fun x kl kr (Node(_,oldL,oldR)) k -> 
        if x < 5 then 
            kr (fun newR -> 
            k (Node(x, oldL, newR))) 
        elif x > 5 then 
            kl (fun newL -> 
            k (Node(x, newL, oldR))) 
        else 
            k (Node(0,oldL,oldR)) 
    ) (fun t k -> k t) tree

We can rewrite this code using the continuation monad thusly:

let Change5to0bst tree =
    KFoldTree (fun x kl kr (Node(_,oldL,oldR)) -> K { 
        if x < 5 then
            let! newR = kr               
            return Node(x, oldL, newR)
        elif x > 5 then
            let! newL = kl
            return Node(x, newL, oldR) 
        else
            return Node(0,oldL,oldR)
    }) (fun t -> K { return t } ) tree

Here are the changes relative to the previous version:

  • The final "k" parameter to each lambda has been eliminated.  Since the body of each lambda is now a continuation workflow (code of the form "K { … }"), the result will be a monadic value of the general form "fun k -> …", and so extra "k" parameter is now implicitly handled by the monad.
  • The "continuation-ness" of the "kl" and "kr" parameters is gone.  Recall that these parameters represent recursive calls on the left and right subtrees, respectively.  Whereas previously we had to call them using continuation-style syntax "kr (fun newR -> …", now we call them with more natural syntax "let! newR = kr".  We use the "!" form of "let" because "kr" is a value in the monad ("kr" is a continuation).
  • We don’t have to call a continuation on the final result, we just need to "return" it.  We are returning Nodes, which are "normal" (non-monadic) values, so we use the non-"!" form ("return" rather than "return!"). 

The types and behavior all work out just as in the original version – this code has the same semantics as the original version, it’s just easier on the eyes (especially so once you are already familiar with the F# computation expression syntax).

One more example

Let’s take a look at one more example of applying the continuation monad – using it on the "Eval" function, another running example in this blog series.  (Recall: that example has a data type called "Expr" to represent a tiny expression language, comprising integer constants, binary operators (Plus and Minus), if-then-else expressions, and "print" expressions.)  Here is the previous version of the "Eval" code, using explicit continuations (though slightly reformatted to make for easier comparison with the new version I’m about to show):

let EvalExplicitContinuations expr =  
    KFoldExpr (fun x _ k -> k x) 
              (fun kl op kr _ k -> kl (fun l ->
                                   kr (fun r ->
                                   match op with 
                                   | Plus -> k (l+r)
                                   | Minus -> k (l-r))))
              (fun kc kt ke _ k -> kc (fun c ->
                                   if c <> 0 then
                                       kt (fun t -> k t)
                                   else
                                       ke (fun e -> k e)))
              (fun ke _ k -> ke (fun e ->
                             printf "<%d>" e
                             k e))
              expr

Now here it is rewritten using the continuation monad:

let Eval expr =  
    KFoldExpr (fun x _ -> K { return x } ) 
              (fun kl op kr _ -> K { let! l = kl
                                     let! r = kr
                                     match op with 
                                     | Plus -> return l+r
                                     | Minus -> return l-r } )
              (fun kc kt ke _ -> K { let! c = kc
                                     if c <> 0 then
                                         return! kt
                                     else
                                         return! ke } )
              (fun ke _ -> K { let! e = ke 
                               do printf "<%d>" e
                               return e } )
              expr

This reads so much better.  In the case of binary operators (the second lambda), for example, I can read the code "aloud" as something like "Let ‘l’ be the value of the recursive call on the left-hand subtree, and let ‘r’ be the value of the recursive call on the right-hand subtree.  If the operator is ‘Plus’, return ‘l+r’, else return ‘l-r’."  The previous version with explicit continuations, though equivalent, is much harder to decipher, and doesn’t let you "read it aloud" nearly so easily.

Another thing worth pointing out in this example is the use of the "return!" keyword.  In the case of if-then-else expressions (the third lambda), the "read aloud" version goes something like "Let ‘c’ be the value of the recursive call on the condition expression.  If ‘c’ is non-zero, then the result is the value of recursing on the ‘then’ subtree, else the result is the value of recursing on the ‘else’ subtree."  Since "kt" and "ke" are monadic values (they are continuations that represent the recursive calls into the ‘Then’ and ‘Else’ subtrees), we use the "!" version of "return" to return the value. 

The source code

Here’s the code from today’s blog entry.

type ContinuationBuilder() =
    member this.Return(x) = (fun k -> k x) 
    member this.ReturnFrom(x) = x 
    member this.Bind(m,f) = (fun k -> m (fun a -> f a k))
    member this.Delay(f) = f()
let K = new ContinuationBuilder()

open System

// handy operator
let (===) = fun x y -> Object.ReferenceEquals(x,y) 

type Tree<‘a> = 
    | Node of (*data*)‘a * (*left*)Tree<‘a> * (*right*)Tree<‘a> 
    | Leaf 

//     4
//  2     6
// 1 3   5 7
let tree7 = Node(4, Node(2, Node(1, Leaf, Leaf), Node(3, Leaf, Leaf))
                    Node(6, Node(5, Leaf, Leaf), Node(7, Leaf, Leaf)))

let KFoldTree nodeF leafV tree =
    let rec Loop t k =
        match t with
        | Node(x,left,right) -> nodeF x (Loop left) (Loop right) t k
        | Leaf -> leafV t k
    Loop tree (fun x -> x)

// explicit continuations version
let Change5to0bstExplicitContinuations tree = 
    KFoldTree (fun x kl kr (Node(_,oldL,oldR)) k -> 
        if x < 5 then 
            kr (fun newR -> 
            k (Node(x, oldL, newR))) 
        elif x > 5 then 
            kl (fun newL -> 
            k (Node(x, newL, oldR))) 
        else 
            k (Node(0,oldL,oldR)) 
    ) (fun t k -> k t) tree

// plain recursive version (blows stack)   
let rec Change5to0bstUsingStack tree =
    match tree with
    | Node(x,oldL,oldR) ->
        if x < 5 then
            let newR = Change5to0bstUsingStack oldR
            Node(x, oldL, newR)
        elif x > 5 then
            let newL = Change5to0bstUsingStack oldL
            Node(x, newL, oldR)
        else
            Node(0, oldL, oldR)
    | Leaf -> tree

// version using continuation workflow
let Change5to0bst tree =
    KFoldTree (fun x kl kr (Node(_,oldL,oldR)) -> K { 
        if x < 5 then
            let! newR = kr               
            return Node(x, oldL, newR)
        elif x > 5 then
            let! newL = kl
            return Node(x, newL, oldR) 
        else
            return Node(0,oldL,oldR)
    }) (fun t -> K { return t } ) tree

// CreateZeroRightTree : int -> Tree<int>
let CreateZeroRightTree size =
    let rec Loop t n =
        if (n < size) then
            Loop (Node(0,Leaf,t)) (n+1)
        else
            t
    Loop Leaf 0
// make a big tree of 2 million nodes all going to the right
let bigTree = CreateZeroRightTree (2 * 1000 * 1000)
// call our tail-recursive function on it, to prove we get no StackOverflowException
Change5to0bst bigTree

///////////////////////////////////////////////////////////////////////////////////

// types capable of representing a small integer expression language
type Op = 
    | Plus 
    | Minus 
type Expr = 
    | Literal of int 
    | BinaryOp of Expr * Op * Expr     // left, op, right
    | IfThenElse of Expr * Expr * Expr // cond, then, else; 0=false in cond
    | Print of Expr                    // prints, then returns that value

let exprs = [Literal(42) 
             BinaryOp(Literal(1), Plus, Literal(1)) 
             IfThenElse(Literal(1), Print(Literal(42)), Print(Literal(0))) 
            ]
            
let KFoldExpr litF binF ifF printF expr = 
    let rec Loop ex k =
        match ex with 
        | Literal(x) -> litF x ex k
        | BinaryOp(l,op,r) -> binF (Loop l) op (Loop r) ex k
        | IfThenElse(c,t,e) -> ifF (Loop c) (Loop t) (Loop e) ex k
        | Print(e) -> printF (Loop e) ex k
    Loop expr (fun x -> x)

// EvalExplicitContinuations : Expr -> int
let EvalExplicitContinuations expr =  
    KFoldExpr (fun x _ k -> k x) 
              (fun kl op kr _ k -> kl (fun l ->
                                   kr (fun r ->
                                   match op with 
                                   | Plus -> k (l+r)
                                   | Minus -> k (l-r))))
              (fun kc kt ke _ k -> kc (fun c ->
                                   if c <> 0 then
                                       kt (fun t ->
                                       k t)
                                   else
                                       ke (fun e ->
                                       k e)))
              (fun ke _ k -> ke (fun e ->
                             printf "<%d>" e
                             k e))
              expr

// Eval : Expr -> int
let Eval expr =  
    KFoldExpr (fun x _ -> K { return x } ) 
              (fun kl op kr _ -> K { let! l = kl
                                     let! r = kr
                                     match op with 
                                     | Plus -> return l+r
                                     | Minus -> return l-r } )
              (fun kc kt ke _ -> K { let! c = kc
                                     if c <> 0 then
                                         return! kt
                                     else
                                         return! ke } )
              (fun ke _ -> K { let! e = ke 
                               do printf "<%d>" e
                               return e } )
              expr
                     
exprs |> List.iter (fun expr -> printfn "%d" (Eval expr)) 
// 42
// 2
// <42>42
printfn "press a key"
System.Console.ReadKey() |> ignore

Posted in Uncategorized | Leave a Comment »

Catamorphisms, part six

Posted by Brian on June 2, 2008

Oops!… I did it again.

I completely botched a key aspect of my previous blog entry.  Fortunately I have some alert readers who are keeping me honest.  Whereas last time I had to correct a blunder about run-time performance, this time I have to correct my implementation because I failed to make it properly tail-recursive.  It’s a learning opportunity, both for you and for me!

The problem

Last time I showed this code for KFoldTree and Change5to0bst:

let KFoldTree nodeF leafV tree =  
    let rec Loop t =  
        match t with  
        | Node(x,left,right) -> nodeF x (fun k -> k (Loop left)) (fun k -> k (Loop right))
        | Leaf -> leafV t 
    Loop tree 

// Change5to0bst : Tree<int> -> Tree<int>
let Change5to0bst tree =  
    KFoldTree (fun x kl kr t -> 
        let (Node(_,oldL,oldR)) = t 
        if x < 5 then 
            kr (fun newR ->  
            Node (x, oldL, newR)) 
        elif x > 5 then 
            kl (fun newL -> 
            Node (x, newL, oldR)) 
        else 
            Node(0,oldL,oldR) 
    ) (fun t -> t) tree

and I looked very carefully at Change5to0bst to ensure that every call was a tail call.  It is.  The problem is, the "Loop" calls in KFoldTree are not tail calls!  For example:

    (fun k -> k (Loop left))

Here, we will make a recursive call to "Loop", but when that call returns, there is still "more work to do" (we must pass that result to "k").  Thus, Loop is not a tail call here.  Oops!  The implication is that we must allocate a stack frame for the duration of the recursive call.  And so if we write…

// CreateZeroRightTree : int -> Tree<int>
let CreateZeroRightTree size =
    let rec Loop t n =
        if (n < size) then
            Loop (Node(0,Leaf,t)) (n+1)
        else
            t
    Loop Leaf 0
// make a big tree of 2 million nodes all going to the right
let bigTree = CreateZeroRightTree (2 * 1000 * 1000)
// call our supposedly-tail-recursive function on it
Change5to0bst bigTree

…sure enough – kaboom!  StackOverflowException.  Clearly I failed to test my code from my previous blog entry.

The fix

The fix involves explicitly passing the continuations throughout the computation.  The definition of KFold actually gets a little simpler, though the client code becomes slightly more complicated.  Here’s the new KFold:

let KFoldTree nodeF leafV tree =
    let rec Loop t k =
        match t with
        | Node(x,left,right) -> nodeF x (Loop left) (Loop right) t k
        | Leaf -> leafV t k
    Loop tree (fun x -> x)

Relative to the previous (broken) version, "Loop" takes an extra continuation parameter, and passed it as an extra parameter to the client functions ("nodeF" and "leafV").  Note that the "Loop" calls got simpler, since for example

    (fun k -> Loop left k)

can just be written as

    (Loop left)

thanks to currying.

Here is how this affects the client:

let Change5to0bst tree =
    KFoldTree (fun x kl kr t k ->
        let (Node(_,oldL,oldR)) = t
        if x < 5 then
            kr (fun newR ->
            k (Node(x, oldL, newR)))
        elif x > 5 then
            kl (fun newL ->
            k (Node(x, newL, oldR)))
        else
            k (Node(0,oldL,oldR))
    ) (fun t k -> k t) tree

The two client lambdas now take an extra final parameter "k", and everywhere that the client used to "return a final value", now we are calling the continuation "k" on that final value.  Apart from that, the code is otherwise unchanged.

The lesson

Tail recursion is subtle – especially when dealing with mutually recursive functions/lambdas.  If you are going to try to be tail-recursive, test your code on large inputs to ensure you got it right!  I failed to test the new "Eval" function (see below), so as to leave that as a good exercise for you to try – create some large data and find out if I got the definitions of KFoldExpr and Eval right!

Other bits

Again, we can express XFold in terms of the new (corrected) KFold, and we can generalize this new KFold to other discriminated union types (like Expr).  For examples, see today’s source code.

Sorry that today’s blog entry is so short on prose, but I didn’t originally intend to spend time writing a blog entry today.  The error in my previous blog entry was sufficiently grievous, though, that I felt compelled to correct it immediately.

The source code

open System

// handy operator
let (===) = fun x y -> Object.ReferenceEquals(x,y) 

type Tree<‘a> = 
    | Node of (*data*)‘a * (*left*)Tree<‘a> * (*right*)Tree<‘a> 
    | Leaf 

//     4
//  2     6
// 1 3   5 7
let tree7 = Node(4, Node(2, Node(1, Leaf, Leaf), Node(3, Leaf, Leaf))
                    Node(6, Node(5, Leaf, Leaf), Node(7, Leaf, Leaf)))

let KFoldTree nodeF leafV tree =
    let rec Loop t k =
        match t with
        | Node(x,left,right) -> nodeF x (Loop left) (Loop right) t k
        | Leaf -> leafV t k
    Loop tree (fun x -> x)

let Change5to0bst tree =
    KFoldTree (fun x kl kr t k ->
        let Node(_,oldL,oldR) = t
        if x < 5 then
            kr (fun newR ->
            k (Node(x, oldL, newR)))
        elif x > 5 then
            kl (fun newL ->
            k (Node(x, newL, oldR)))
        else
            k (Node(0,oldL,oldR))
    ) (fun t k -> k t) tree

// CreateZeroRightTree : int -> Tree<int>
let CreateZeroRightTree size =
    let rec Loop t n =
        if (n < size) then
            Loop (Node(0,Leaf,t)) (n+1)
        else
            t
    Loop Leaf 0
// make a big tree of 2 million nodes all going to the right
let bigTree = CreateZeroRightTree (2 * 1000 * 1000)
// call our tail-recursive function on it, to prove we get no StackOverflowException
Change5to0bst bigTree

// XFoldTree : (‘a -> ‘r -> ‘r -> Tree<‘a> -> ‘r) -> (Tree<‘a> -> ‘r) -> Tree<‘a> -> ‘r
let XFoldTree nodeF leafV tree = 
    KFoldTree (fun x l r t k -> l (fun lacc -> r (fun racc -> k (nodeF x lacc racc t)))) 
              (fun t k -> k (leafV t)) tree

// Other useful Tree boilerplate from previous blogs
let XNode (x,l,r) (Node(xo,lo,ro) as orig) =
    if xo = x && lo === l && ro === r then 
        orig
    else
        Node(x,l,r)
let XLeaf (Leaf as orig) =
    orig
let FoldTree nodeF leafV tree = 
    XFoldTree (fun x l r _ -> nodeF x l r) (fun _ -> leafV) tree

// another example to suggest that the XFold written in terms of the KFold is also still tail-recursive
let XChange5to0 tree = 
    XFoldTree (fun x l r -> XNode((if x=5 then 0 else x), l, r)) XLeaf tree 
XChange5to0 bigTree  // no StackOverflowException

///////////////////////////////////////////////////////////////////////////////////

// types capable of representing a small integer expression language
type Op = 
    | Plus 
    | Minus 
type Expr = 
    | Literal of int 
    | BinaryOp of Expr * Op * Expr     // left, op, right
    | IfThenElse of Expr * Expr * Expr // cond, then, else; 0=false in cond
    | Print of Expr                    // prints, then returns that value

let exprs = [Literal(42) 
             BinaryOp(Literal(1), Plus, Literal(1)) 
             IfThenElse(Literal(1), Print(Literal(42)), Print(Literal(0))) 
            ]
            
let KFoldExpr litF binF ifF printF expr = 
    let rec Loop ex k = 
        match ex with 
        | Literal(x) -> litF x ex k
        | BinaryOp(l,op,r) -> binF (Loop l) op (Loop r) ex k
        | IfThenElse(c,t,e) -> ifF (Loop c) (Loop t) (Loop e) ex k
        | Print(e) -> printF (Loop e) ex k
    Loop expr (fun x -> x)

// Eval : Expr -> int
let Eval expr =  
    KFoldExpr (fun x _ k -> k x) 
              (fun kl op kr _ k -> match op with 
                                   | Plus -> kl (fun l -> kr (fun r -> k (l+r)))
                                   | Minus -> kl (fun l -> kr (fun r -> k (l-r))))
              (fun kc kt ke _ k -> kc (fun c -> if c <> 0 then
                                                    kt (fun t -> k t)
                                                else
                                                    ke (fun e -> k e)))
              (fun ke _ k -> ke (fun e -> printf "<%d>" e
                                          k e))
              expr
                     
exprs |> List.iter (fun expr -> printfn "%d" (Eval expr)) 
// 42
// 2
// <42>42

Posted in Uncategorized | Leave a Comment »