Driving Range Pooled Allocator

A number of projects that I’ve worked on over the years involve processing data in some kind of batch: a file, a message, the contents of a database, etc. One recurring design need in these scenarios is a means of allocating large, but variable, numbers of small, simple instances which are allocated over the life of the batch, but which can all be released when the batch is finished. Large numbers of small allocations can be brutal on a memory management system, especially in terms of CPU time (and in terms of fragmentation on non-GC systems). This post presents an F# implementation of a pooling algorithm I’ve used for many years, and in various languages from C onwards, to solve this problem.

In a nutshell, it sub-allocates fixed-size batches of instances. Instances are dispensed from these batches, with more batches being added as required. When the run is complete, the batches are “virtually de-allocated” by resetting various indices, but the instances themselves are not de-allocated.

I don’t know whether this algorithm has a formal name and history. I’m sure it does, but I’ll call it the “Driving Range Pooled Allocator.” This is because it reminds me of a golf driving range. The main kiosk at the range sub-allocates golf balls in little buckets, golfers then take the golf balls from these buckets one at a time and drive them out onto the range. The algorithm is like a really low-budget operation that only has one customer at a time and a golf-ball recovery tractor with no safety cage. The customer represents a batch run, allocating golf-balls over the life of the run. When the customer is finished, the tractor goes out and sweeps up all the golf balls at once.

This algorithm is not designed to be a general purpose allocator. It works best when the instances are small, have no special creation, disposal, or finalization concerns, and can be easily reset to a fresh state. Additionally, the algorithm will be most efficient when the standard deviation in allocation count is large enough to make pre-allocation an issue, but small enough that over-allocation is not an issue.

One more caveat: 99% of the time, when you think you can build a better allocator on top of the system-provided allocator, you're wrong. This algorithm is no exception. Use if for that rare remaining 1%; make sure it's applicable and -- if in doubt -- benchmark your application of it.

I named the sub-allocation array classes “Bucket” and the main class “Barrel.” The interfaces are fairly straightforward. I would like to point out that Barrel has two Reset functions. The first, Reset(), does a simple reset of the indices. The second, Reset(n), resets the indices, but also shrinks the allocation to a size as small as possible while retaining a capacity of at least n. This is handy for scenarios where the allocation size can occasionally grow huge and you want to scale it back to something closer to the median allocation size without reallocating the whole Barrel. Barrel.Count and Barrel.Capacity are not unit-time algorithms; they are generally rarely used. If you need faster versions, you can compute and cache these values.

I did my best to test for errors, but this is a generation 1.0 F# implementation. For one thing, it is designed mainly for internal use and so does minimal error-checking (i.e. not library-level error checking). Also, I re-wrote it from scratch rather than porting-it, and I may have let a bug or two slip by. If any are found, I’ll post a correction.

And, as always, presented "as-is" and without warranty or implied fitness of any kind; use at your own risk.

///<summary>Pooled array allocator.</summary>
type Bucket<'a when 'a:(new:unit->'a)> (size:int) = 

  //<summary>The array.</summary>
  let b = Array.init size (fun i->new 'a())

  //<summary>Current allocation point.</summary>
  let mutable cursor = size

  //<summary>Chain for use in Barrel<'a>.</summary>
  let mutable next:Bucket<'a> option = None

  //<summary>Get capacity.</summary>
  member this.Capacity = 
    size

  //<summary>Get current allocation count.</summary>
  member this.Count 
    with get() = size-cursor

  //<summary>Get current allocation item.</summary>
  member this.Current 
    with get() = b.[cursor]

  //<summary>Move to next allocation item.</summary>
  member this.MoveNext () =
    match cursor with
    | 0 -> false
    | _ ->
       cursor<-cursor-1
       true 

  //<summary>Chain for use in Barrel<'a>.</summary>
  member this.Next 
    with get() = next
    and set v = next<-v

  ///<summary>Reset allocation.</summary>
  member this.Reset() = cursor<-size


///<summary>Pooled batch allocator.</summary>
///<param name="s0">First bucket capacity.</param>
///<param name="sn">Nth bucket capacity.</param>
type Barrel<'a when 'a:(new:unit->'a)> (s0:int, sn:int) = 

  ///<summary>First bucket (always instantiated).</summary>
  let head = (Bucket<'a> s0)

  ///<summary>Tail for quick appends.</summary>
  let mutable tail = head

  ///<summary>Current allocation bucket.</summary>
  let mutable cursor = head

  ///<summary>Helper for this.Capacity.</summary>
  let rec capacity (b:Bucket<'a>) s =
    match b.Next with
    | None -> s+b.Capacity
    | Some(b') -> capacity b' (s+b.Capacity)

  ///<summary>Helper for this.Count.</summary>
  let rec count (b:Bucket<'a>) s =
    match b.Count with
    | 0 -> s
    | _ ->
        match b.Next with
        | None -> s+b.Count
        | Some(b') -> count b' (s+b.Count)

  ///<summary>Helper for this.Reset.</summary>
  let rec reset (b:Bucket<'a>) =
    if b.Count>0 then
      b.Reset()
      if b.Next.IsSome then
        reset b.Next.Value 

  ///<summary>Helper for this.Reset(n).</summary>
  let rec resetCapacity c0 cs (b:Bucket<'a>) =
    b.Reset()
    match cs>=c0 with
    | true -> 
        tail<-b
        tail.Next<-None
    | false -> 
        match b.Next with
        | None -> 
            tail<-b
            tail.Next<-None
        | Some(b') ->
            resetCapacity c0 (cs+b.Capacity) b'
  
  ///<summary>Get current capacity.</summary>
  member this.Capacity 
    with get() = 
      capacity head 0
  
  ///<summary>Get current allocation count.</summary>
  member this.Count 
    with get() =
      count head 0
  
  ///<summary>Reset allocation.</summary>
  member this.Reset () =
    reset head
    cursor<-head
  
  ///<summary>Reset allocation and capacity.</summary>
  ///<param name="n">New minimum capacity.</param>
  member this.Reset n =
    if n<0 then
      raise (new System.ArgumentException())
    resetCapacity n head.Capacity head
    cursor<-head
  
  ///<summary>Allocate an item.</summary>
  member this.Take () =
    match cursor.MoveNext() with
    | true -> cursor.Current
    | false ->
        match cursor.Next with
        | Some(b) -> cursor<-b
        | None ->
            cursor<-Bucket<'a> sn
            tail.Next<-Some(cursor)
            tail<-cursor
        cursor.MoveNext() |> ignore
        cursor.Current

  
///<summary>Simple test class.</summary>
type Indexed () =
  
  static let mutable instances = 0

  let index = instances

  do instances<-instances+1

  member this.Index with get() = index


// Perform some tests.

let bb = Barrel<Indexed>(10,5)

for i=1 to 12 do
  printfn "(%i %i %i)" ((bb.Take()).Index) bb.Count bb.Capacity

bb.Reset()
printfn "Clear"

for i=1 to 22 do
  printfn "(%i %i %i)" ((bb.Take()).Index) bb.Count bb.Capacity

bb.Reset 11
printfn "Reset"

for i=1 to 12 do
  printfn "(%i %i %i)" ((bb.Take()).Index) bb.Count bb.Capacity

bb.Reset 0
printfn "Reset"

for i=1 to 22 do
  printfn "(%i %i %i)" ((bb.Take()).Index) bb.Count bb.Capacity

F# vs. C# Proof-of-Concept at One Week

This being roughly a week into my large-scale F# proof-of-concept, I’d like to present what I feel are some of the benefits of F# over C# and vice versa. This includes “F#-style” in the sense that it encompasses multi-paradigm techniques that can be used in C#, but which are more naturally supported by the F# language (at least at this point).

Benefits of F# and F#-style over C#.

1) Fewer lines of source code.
2) Fewer classes.
3) Fewer functions.
4) Shallower hierarchy.
5) More direct modeling of the problem.
6) More efficient runtime IL (speed and probably space as well).
7) Constructs like easy operator overloading simplify testing and agile programming.

Benefits of C# over F# and F#-style.

1) Still getting used to the F# language and multi-paradigm programming.
2) VS2010 tools (e.g. auto-complete, refactoring) currently work better with C#.
3) Mechanics of C# projects (multiple sub-directories, etc.) more mature. (Although I do like the way F# harkens back to the older idea of source-code over project structure.)
4) Some conflict between F#-style/conventions and .NET library-style/conventions at this stage. (Minor issue only.)

So at least thus far, F# as a language is working out for me; most of the problems I have with F# are tool integration issues that will improve over time. I really, really like this language; programming is fun again!

(Lest any C# aficionados or C#-group members take offense, let me say that this is not intended to be a slight on C#. C# 4.0 is a very effective language and is itself growing into a multi-paradigm language. For many tasks, I think the choice of F# vs. C# will be a choice based on preference between equals.)

-Neil

Gap

Sorry for a bit of a gap in the posting. Blame Microsoft; VS2010 is full of new stuff and it's been a lot of fun playing around with it for the last couple of weeks!

One thing I've done is to begin my first large-scale project in F#; it's actually a proof-of-concept for some professional work I'm doing. It's going really well, and it has forced me to learn a lot of the nuts and bolts of putting together a large, maintainable project in F# as opposed to working mainly with isolated snippets and algorithms. Based on early analysis, I predict that it will benchmark faster than a C# version, and -- if I can get a handle on F# module and namespace practices -- it should be more maintainable. (The former due to the fact that the F# compiler provides very good optimization, and the latter due to the fact that the F# source is more succinct and more directly models the problem.)

I still have a few more hurdles to accomplish, including coming to grips with F#/Microsoft Office interaction, XML in F#, and WCF. But in the meantime, in an effort to keep this blog running, I'll cast about for some interesting things to post here.

Thanks again to the VS and F# team for making F# a reality in VS2010!

-Neil

A Spell-Binding Tale of Three Recursions

One coding problem that often arises is the need to package a tail recursive function in some syntactic wrapper. Tail recursive functions often involve accumulators, continuations, and other values which are not really of concern to the ultimate users of those functions. These can often be curried away or otherwise hidden from the ultimate user. This post looks at three obvious techniques for doing so (there are some more that are less obvious), the differences between the three techniques, etc.

(For reference purposes, I compiled the examples using Microsoft F# 2.0, Compiler build 4.0.30319.1 and examined the results using Red Gate’s .NET Reflector v.6.0.0.918. And, as always: presented “as-is” and without warranty or implied fitness; use at your own risk.)

Assuming no side effects are added to them, the three bindings below compile to code which can produce identical results. In this case, it is a simple integer sum. The first version calls an internal function, while the second and third versions return a curried internal function. (In each of the examples, note that the code for the internal function sum’ is identical.)

let sum1 n =
  let rec sum' a n =
    match n with
    | _ when n<=0 -> a
    | _ -> sum' (a+n) (n-1)
  sum' 0 n


let sum2 =
  let rec sum' a n =
    match n with
    | _ when n<=0 -> a
    | _ -> sum' (a+n) (n-1)
  sum' 0 


let sum3 () =
  let rec sum' a n =
    match n with
    | _ when n<=0 -> a
    | _ -> sum' (a+n) (n-1)
  sum' 0 

So what are the differences? Major, as it turns out.

But first, let’s add some side effects and some test code that makes this apparent:

open System
open System.Collections.Generic


let sum1 n =
  Console.WriteLine("1: Instantiating HashSet")
  let h = new HashSet<int>()
  let rec sum' a n =
    Console.WriteLine("1: Add {0} -> {1} ",n,(h.Add n))
    match n with
    | _ when n<=0 -> a
    | _ -> sum' (a+n) (n-1)
  sum' 0 n


let sum2 =
  Console.WriteLine("2: Instantiating HashSet")
  let h = new HashSet<int>()
  let rec sum' a n =
    Console.WriteLine("2: Add {0} -> {1} ",n,(h.Add n))
    match n with
    | _ when n<=0 -> a
    | _ -> sum' (a+n) (n-1)
  sum' 0 


let sum3 () =
  Console.WriteLine("3: Instantiating HashSet")
  let h = new HashSet<int>()
  let rec sum' a n =
    Console.WriteLine("3: Add {0} -> {1} ",n,(h.Add n))
    match n with
    | _ when n<=0 -> a
    | _ -> sum' (a+n) (n-1)
  sum' 0 

System.Console.WriteLine ("------- Starting test calls. -------")
System.Console.WriteLine ("1: ---------------- Result={0} ",(sum1 2))
System.Console.WriteLine ("2: ---------------- Result={0} ",(sum2 2))
System.Console.WriteLine ("3: ---------------- Result={0} ",(sum3() 2))
System.Console.WriteLine ("1: ---------------- Result={0} ",(sum1 2))
System.Console.WriteLine ("2: ---------------- Result={0} ",(sum2 2))
System.Console.WriteLine ("3: ---------------- Result={0} ",(sum3() 2))

System.Console.ReadLine() |> ignore

And here is the result of compiling and running the above:

2: Instantiating HashSet
------- Starting test calls. --------
1: Instantiating HashSet
1: Add 2 -> True
1: Add 1 -> True
1: Add 0 -> True
1: ----------------- Result=3
2: Add 2 -> True
2: Add 1 -> True
2: Add 0 -> True
2: ----------------- Result=3
3: Instantiating HashSet
3: Add 2 -> True
3: Add 1 -> True
3: Add 0 -> True
3: ----------------- Result=3
1: Instantiating HashSet
1: Add 2 -> True
1: Add 1 -> True
1: Add 0 -> True
1: ----------------- Result=3
2: Add 2 -> False
2: Add 1 -> False
2: Add 0 -> False
2: ----------------- Result=3
3: Instantiating HashSet
3: Add 2 -> True
3: Add 1 -> True
3: Add 0 -> True
3: ---------------- Result=3

After adding side effects, the first and third versions produce similar results (though they are very different under the hood, as is hinted at by the different means of calling the third version). The second version produces a different result. To show why this is so, let me try to state, in plain terms, what each of the three bindings does.

Example one binds sum1 to a function that takes a single argument, n. When this function is executed, it: 1) instantiates a HashSet, 2) calls the internally defined function sum’ with arguments 0 and n, with the HashSet captured in a closure, and 3) returns the result.

Example two: 1) instantiates a HashSet, and 2) binds sum2 to a curried version of an internal function sum’ which captures that hash set in a closure and is curried with an argument of 0. When sum2 is called with an argument, that curried function is called.

Example three binds sum3 to a function with no arguments. When that function is executed, it: 1) instantiates a HashSet, 2) returns a curried version of an internal function sum’ which captures that hash set in a closure and is curried with an argument of 0. When the result of executing sum3 is called with an argument, that curried function is called.

Example 1 comes closest to what we normally think of as a function call. Every time it is executed, it instantiates a new local copy of a HashSet and then calls an internal function. Examining the code in IL or (or decompiling it using some tool like Red Gate’s .NET Reflector) will show that this is a good description of its internal behavior as well.

Example 2 comes closer to behaving like a traditional object. It instantiates one HashSet which, like an object property, is shared across all the calls to the returned function. It’s a little bit like returning a delegate which accesses a static property, and if one looks at the IL, this is very much how it is implemented. (An class is created to represent the binding, but HashSet is made into a property of the main program class.)

Example 3 combines the behavior of the two. Like example 2, rather than binding to a function, it binds to something that returns a function. However, like example 1, the instantiation of the HashSet occurs when the function is executed rather than when the symbol is bound.

So which to choose?

Obviously, if you need some set of side effects to occur on every function call, either method 1 or method 3 is an obvious choice. If, on the other hand, you need some set of side effects to occur once, method 2 is probably your best bet.

And being me, when picking an algorithm, once the criteria of correctness, appropriateness, and maintainability are met, my next most important consideration is…

Benchmarks!

So I did a simple test of the three methods, removing the side effects and simply doing the summation. The results after some myriad iterations of each on the same data are:

Method 1: 2.42 seconds.
Method 2: 2.81 seconds.
Method 3: 10.92 seconds.

Methods 1 and 2 are the clear winners, with method 3 a distant third. These results are also predictable from an examination of the source code. Clearly, unless some application demands method 3, the others are superior. However, methods 1 and 2 are close enough in performance that (if side-effects are not a consideration) the choice can be made based on which best represents the underlying concepts the code is intended to represent.

[I’m relatively new to F#, and my grad-school lambda calculus is rusty, I welcome any corrections of fact or terminology to the above.]

-Neil

VS2010 and a C# Aside

Like most people in the Microsoft-programming world, I've been in the midst of installing Visual Studio 2010 (I had to service pack my PC, etc.), and now I'm in the midst of experimenting with all the new features. Hopefully, the fact that F# is now included with the Studio will generate a lot of activity in the online F# world over the coming weeks.

In the meantime, here are a couple of C# articles that may be of interest to F# programmers:

Solving Combinatory Problems with LINQ

Using LINQ to solve puzzles

-Neil

Simple WPF Animation

Since I want to be able to visually demonstrate solutions to the sliding-block puzzle, I wanted a way to animate the WPF display. Below is part of the solution I've come up with. I don't know a huge amount about WPF, so this may look pretty off the wall and grim to experienced WPF-ers. If so, leave a comment and I'll try to make corrections.

(Presented “as-is” and without warranty or implied fitness; use at your own risk.)

First, the timer code:

type Animator () =

  let timer = 
    new System.Windows.Threading.DispatcherTimer()
    
  let stop () = 
    if timer.IsEnabled then timer.Stop()
    
  let animate (fCallback:unit->bool) 
              e =
    if not(fCallback()) then stop()
    
  member this.Start (fCallback:unit->bool)
                    (interval:int) =
    stop()
    timer.Tick.Add (animate fCallback)
    timer.Interval <- new System.TimeSpan(0,0,0,0,interval)
    timer.Start()
        
  member this.Stop () =
    stop()

And a simple use that makes random moves (to be placed within MainWindow or whatever class displays the Fifteen puzzle):

  let Animate  =
    let animator = new Animator()
    let rand = new Random()
    (fun interval ->
      animator.Start 
        (fun () ->
          moveTile(rand.Next 4)
          true)
        interval)

Sliding Block Puzzle in F# and WPF

I realized that I wanted something more visual with which to test my search algorithms. I have also been wanting to learn how to write WPF applications using F#. To that end, I offer the following F#/WPF application of the famous Fifteen Puzzle, the ancestor of all sliding-block puzzles.

I did some early experiments with XAML, but what I needed was more repetitive than complex. It turns out creating the controls in code was simpler for this application. I’m very much a WPF novice, so I don’t expect my simple user interface to win any awards. It was, however, a fun afternoon and I learned a lot.

This weekend, on the ##fsharp IRC channel on irc.freenode.net, we were joking around about the compulsion to point out tricky or interesting bits of one's code. In that mode, I would like to call attention to the fact that I use one-dimensional arrays rather than the two-dimensional arrays that immediately come to mind for a sliding block puzzle. One dimensional arrays seem to provide a simpler solution. (Technically, the second dimension is smuggled in via the "tileMoves" array.)

In a comment at the top of the code, I have listed the references my project includes. If you use visual studio, you will also need to make sure to set your project type to "Windows Application" on the project properties Application panel.

Coming soon, I will connect the interface to one or more of my search algorithms and will animate the interface to show the generated solution. (Extending the puzzle to formats other than 4x4 is left as an exercise to the reader.)

(Presented “as-is” and without warranty or implied fitness; use at your own risk.)

// I have the following libraries referenced
// in the solution:
//
// Accessibility
// FSharp.Core
// mscorlib
// PresentationCore
// PresentationFramework
// System
// System.Core
// System.Xml
// WindowsBase

open System
open System.Windows
open System.Windows.Controls
open System.Windows.Media


// These literals define the 
// cardinal directions as 
// array offsets.
[<Literal>]
let up = 0
[<Literal>]
let right = 1
[<Literal>]
let down = 2
[<Literal>]
let left = 3
  

// Class which handles the tiles.  
type Tiles () =
 
  // The slots as a one-dimensional array.
  let tileSlot = [| 0..15 |]
  
  // The moves from each tileSlot.
  // Format is:
  //   tileSlot 0 (up,right,down,left)
  //   tileSlot 1 ... 
  // -1 = an illegal move. 
  let tileMoves =
    [|
      [|-1; 1; 4;-1 |] 
      [|-1; 2; 5; 0 |] 
      [|-1; 3; 6; 1 |] 
      [|-1;-1; 7; 2 |]
      
      [| 0; 5; 8;-1 |] 
      [| 1; 6; 9; 4 |] 
      [| 2; 7;10; 5 |] 
      [| 3;-1;11; 6 |]
      
      [| 4; 9;12;-1 |] 
      [| 5;10;13; 8 |] 
      [| 6;11;14; 9 |] 
      [| 7;-1;15;10 |]
      
      [| 8;13;-1;-1 |] 
      [| 9;14;-1;12 |] 
      [|10;15;-1;13 |] 
      [|11;-1;-1;14 |]
    |]             
  
  // The blank tile is at the 
  // center of the action  
  let mutable tileBlank = 15;
  
  // Return the index of the tile
  // in a tileSlot.
  member this.GetTile i  =
    tileSlot.[i]
  
  // Move the blank slot.
  // Returns a to*from pair.  
  // Returns to*to on an illegal move.
  member this.Move dir =
    let tb = tileBlank
    let tn = tileMoves.[tileBlank].[dir]
    match tn with 
    | -1 -> (tb,tb)
    | _ -> 
      tileSlot.[tb] <- tileSlot.[tn]
      tileSlot.[tn] <- 15
      tileBlank <- tn
      (tb,tn)



// Window class.
type MainWindow (app: Application) =
  inherit Window()

  // Colors for even-numbered tiles.
  let tileColorEven = ( 
    Brushes.DarkSlateGray, 
    Brushes.Bisque, 
    Brushes.DarkSlateGray )

  // Colors for odd-numbered tiles.
  let tileColorOdd = ( 
    Brushes.DarkSlateGray, 
    Brushes.Azure, 
    Brushes.DarkSlateGray )

  // Colors for the blank slot.
  let tileColorBlank = ( 
    Brushes.DimGray, 
    Brushes.Gray,
    Brushes.Gray)
  
  // Tile storage.
  let tiles = Tiles()
  
  // The window has one element, a grid.      
  let grid:Grid = System.Windows.Controls.Grid() 
  
  // Returns a format tuple for the tileSlot.
  let getFormat i =
    match tiles.GetTile i with 
    | 15 -> ("F#",tileColorBlank)
    | t -> 
        match t%2 with 
        | 0 -> (((t+1).ToString()),tileColorEven)
        | _ -> (((t+1).ToString()),tileColorOdd)
  
  // Creates a Label control for the tileSlot.
  let createLabel (i:int) =
    let l = new Label()
    l.FontSize <- 20.0
    l.HorizontalContentAlignment <- 
      HorizontalAlignment.Center 
    l.VerticalContentAlignment <- 
      VerticalAlignment.Center 
    l.BorderThickness <- Thickness(1.0)
    l.SetValue(Grid.RowProperty,(i/4))
    l.SetValue(Grid.ColumnProperty,(i%4))
    l
  
  // Updates the Label format for the tileSlot.
  let labelFormat (l:Label) (i:int) =
    let (t,(b0,b1,b2)) = getFormat i 
    l.Content <- t
    l.Foreground  <- b0
    l.Background  <- b1
    l.BorderBrush <- b2
    l
  
  // Move the blank slot.  
  let moveTile d =
    let (t0,t1) = tiles.Move d
    if (t0<>t1) then
      labelFormat (grid.Children.[t0] :?> Label) t0 |> ignore
      labelFormat (grid.Children.[t1] :?> Label) t1 |> ignore
  
  // Move the blank slot.  
  let rec moveTiles d =
    match d with 
    | [] -> ()
    | h::t ->
        moveTile h
        moveTiles t
  
  // Keyboard handler.
  // Note that the blank slot moves in the
  // opposite direction from the keypress.
  // This feels more natural to me.
  let onKeyDown (e:Input.KeyEventArgs)  =
    match e.Key with
    | Input.Key.Up    -> moveTile down
    | Input.Key.Right -> moveTile left
    | Input.Key.Down  -> moveTile up
    | Input.Key.Left  -> moveTile right
    | _ -> ()
    

  // Move the blank slot.  
  member this.MoveTile d =
    moveTile d

  // Move the blank slot.  
  member this.MoveTiles d =
    moveTiles d 
    
  // Initialize the window and all the data.  
  member this.Initialize () =
    
    this.Title <- "Fifteen Puzzle"
    this.Width <- 240.0
    this.Height <- this.Width
    
    for i in 0..3 do
      grid.ColumnDefinitions.Add(new ColumnDefinition());
      grid.RowDefinitions.Add(new RowDefinition());
     
    this.AddChild grid
    
    for i in 0..15 do
      grid.Children.Add (labelFormat (createLabel i) i) |> ignore
      
    this.KeyDown.Add onKeyDown
      
    ()


// Test application.
type App () =
  inherit Application()
  
  static member Go() =
  
    let app = new App()
    
    let win = new MainWindow(app)
      
    win.Initialize()
    
    let r = new Random()
    
    for i=1 to 50 do
      win.MoveTile (r.Next 4)
    
    app.Run(win) |> ignore


[<STAThread>] 
do
  App.Go()

Generic Binary Heap

I'm pretty sure I'm going to need a priority queue for my A* search, so I decided to code a generic heap class in F#. The F# code below is largely a translation from Robert Sedgewick's Algorithms in C (Parts 1-4). I tested it pretty thoroughly, but I want to test it a bit more, and I might make a few changes here and there. For the near future, at least, it's designed to be an internal component, so error-reporting, etc. are minimal.

(Presented “as-is” and without warranty or implied fitness; use at your own risk.)

type BinaryHeap<'a> (less:'a->'a->bool,
                     size:int,
                     resize:int) =

  let mutable cursor = 0
    
  let mutable aa :'a array= 
    Array.zeroCreate (max size 1)
    
  let swap i j =
    aa.[0] <- aa.[i]
    aa.[i] <- aa.[j]
    aa.[j] <- aa.[0]
    
  let incCursor () =
    cursor <- cursor+1
    if cursor>=aa.Length then
      aa <-
        Array.append 
          aa
          (Array.zeroCreate (max resize 1))
    
  let rec downHeap i = 
    let left = i*2
    if (left<=cursor) then
      let largest = 
        match (left<cursor) && 
              (less aa.[left] aa.[left+1]) with
        | true -> left+1
        | false -> left
      if (less aa.[i] aa.[largest]) then
        swap i largest
        downHeap largest

  let rec upHeap i = 
    let parent = i/2
    if (i>1) && (less aa.[parent] aa.[i]) then
      swap i parent
      upHeap parent
 
  // Clear the heap and the array.
  member this.Clear () =
    Array.mapi 
      (fun i a -> aa.[i]<-Unchecked.defaultof<'a>) 
      aa |> ignore
    cursor <- 0 
  
  // Returns the number of items on the heap.  
  member this.Count 
    with get () = cursor 
  
  // Drop the top item.  
  member this.Drop () =
    if cursor<1 then failwith "Underflow"
    swap 1 cursor
    cursor <- cursor-1
    downHeap 1 
  
  // Insert an item.    
  member this.Insert a = 
    incCursor()
    aa.[cursor] <- a
    upHeap cursor 
  
  // Return the top item.    
  member this.Top  
    with get () = aa.[1]
    
  // Drop the top item and return it.  
  member this.Extract () =
    let top = this.Top 
    this.Drop()
    top
    

// Tests. 
    
let h = BinaryHeap<int>((>),16,16)

let r = new System.Random()

h.Insert (r.Next 100)
h.Insert (r.Next 100)
h.Insert (r.Next 100)
h.Insert (r.Next 100)

printf "%i " (h.Extract())
printf "%i " (h.Extract())
printf "%i " (h.Extract())
printf "%i " (h.Extract())


System.Console.ReadLine() |> ignore

Improved Canonical Search

Here is an improved search. This the simplest version of the “canonical” graph search given in many A.I. textbooks.

I decided to code it using mostly sequences. There was no overriding technical reason for this, I simply wanted some practice using sequences in F#.

The code is split into three sections: a generic search function, a specific implementation and adapter using a simple node type, and a test.

The test graph is the same as that used in Patrick Henry Winston’s Artificial Intelligence (3rd edition, p.64ff). I added a disconnected node, H, so that I could test search failures. For convenience, here is a copy of it:



This test shows depth- and breadth-first searches. A* will come next, but will require some modification to the canonical search.

The code is below. There may be a bug or two, or a bad practice. I did test it using Winston’s examples, and it passed.

(Presented “as-is” and without warranty or implied fitness; use at your own risk.)

open System.Collections.Generic

//// Generic search.

// A path: (cost,head,tail).
type Path<'n> = int*'n*('n list)


// Search for a path.
let rec search<'n> 
    (isGoal:'n->bool)
    (expand:'n->seq<'n*int>) 
    (merge:seq<Path<'n>>->seq<Path<'n>>->seq<Path<'n>>) 
    (paths:seq<Path<'n>>) =
  match Seq.isEmpty paths with 
  | true -> Seq.empty
  | false -> 
      let (c,n,nl) = Seq.head paths
      match isGoal n with
      | true -> paths
      | false -> 
          search
            isGoal 
            expand
            merge
            (merge 
              (Seq.skip 1 paths) 
              (Seq.map 
                (fun (n0,c0)->(c+c0,n0,n::nl)) 
                (expand n)))
            

// Merge functions determine search behavior.
let breadthFirst s0 s1 = Seq.append s0 s1
let depthFirst   s0 s1 = Seq.append s1 s0


//// Non-generic parts.


// A simple node.
type Node = {
  id:string
  mutable links:(Node*int) list }

// Base node for initialization. 
let node = { id=""; links=[] }


// Search adapter.
let searchNodes = 

  // Prevents looping.
  let hashLoop = new HashSet<string>()
  
  // Goal test.
  let testNode (g:Node) (n:Node) = g.id=n.id
  
  // Expand a path.  
  let expandNode (n:Node) = 
    match hashLoop.Add n.id with 
    | false -> Seq.empty
    | true -> (List.toSeq n.links)

  // Search adapter internal function.
  let searchAdapter 
      (merge:seq<Path<Node>>->seq<Path<Node>>->seq<Path<Node>>)
      (start:Node) 
      (goal:Node) =
    hashLoop.Clear()
    let sr = 
      search 
        (testNode goal) 
        expandNode 
        merge 
        (seq { yield (0,start,[]) })
    match Seq.isEmpty sr with
    | true -> None
    | _ -> Some(Seq.head sr)
    
  searchAdapter 


// Define a graph.

let s = { node with id="s" }
let a = { node with id="a" }
let b = { node with id="b" }
let c = { node with id="c" }
let d = { node with id="d" }
let e = { node with id="e" }
let f = { node with id="f" }
let g = { node with id="g" }
let h = { node with id="h" }

s.links <- [(a,3);(d,4)]
a.links <- [(s,3);(b,4);(d,5)]
b.links <- [(a,4);(c,4);(e,5)]
c.links <- [(b,4)]
d.links <- [(s,4);(a,5);(e,2)]
e.links <- [(b,5);(d,2);(f,4)]
f.links <- [(e,4);(g,3)]
g.links <- [(f,3)]


// Print a path.
let printo (po:Path<Node> option) =
  let rec printo0 (l:Node list) =
    match l with 
    | [] -> printfn ""
    | h::t ->
        printf "%s " h.id
        printo0 t
  match po with 
  | None -> printfn "Search Failed"
  | Some((c,n,nl)) -> printo0 (n::nl)

  
// Test some searches.

printo (searchNodes depthFirst s d)
printo (searchNodes depthFirst s g)
printo (searchNodes depthFirst s h)
printo (searchNodes breadthFirst s d)
printo (searchNodes breadthFirst s g)
printo (searchNodes breadthFirst s h)

System.Console.ReadLine() |> ignore

Search Routines, Continued

Yay! I finished my taxes. I hope to post some more F# stuff over the coming weekend.

In the meantime, here is a first try at general purpose depth/breadth-first search routine. It's not really generic yet, being based on a specific data structure. However, my goal is, over the next few days, to turn it into a nice generic search routine that I can use in a number of applications. The final version will implement the A* search rather than depth/breadth-first search. THAT is what I will finally marry with the semantic network.

Also, the code below is very, very rough; rather grim and awfull, actually. I wrote it quickly last night in between various chores and while worrying about a half-dozen other things. I mainly post it as a way of forcing myself to stay active on the blog here.

(Presented “as-is” and without warranty or implied fitness; use at your own risk.)

// Rough-draft code, hammered-in between eating dinner, 
// playing with my pet rabbit to keep him from becoming feral,
// worrying about taxes, etc.
//
// Take it with a grain of salt 
// and an eye towards what it may become.

open System.Collections.Generic


type Node = {
  id:string
  mutable links:(Node*int) list }
  
let defaultNode = { id=""; links=[] }

type Path = int*Node*(Node list)


let search =

  let hashLoop = new HashSet<string>()
  
  let rec search0 (g:string)
                  (pl:Path list) =
                  
    let rec expand (c:int)
                   (l:(Node*int) list)
                   (nl:Node list)
                   (pl:Path list) =
      match l with
      | [] -> pl
      | (ln,lc)::t ->
          match hashLoop.Add ln.id with
          // Breadth-first.
          //| true  -> expand c t nl (List.append pl [(c+lc,ln,nl)]) 
          // Depth-first.
          | true  -> expand c t nl ((c+lc,ln,nl)::pl) 
          | false -> expand c t nl pl
          
    match pl with
    | [] -> None
    | (c,n,nl)::pt -> 
        match n.id=g with 
        | true -> Some(c,n::nl)
        | false -> 
            search0 g (expand c n.links nl pt) 
    
  let search1 (s:Node) gid =
    hashLoop.Clear()
    search0 gid [(0,s,[])]
    
  search1
  

// This is the same network used for 
// search examples in Patrick Henry Winston's 
// Artificial Intelligence, 3rd Edition, p.64ff  
  
let s = { defaultNode with id="s" }
let a = { defaultNode with id="a" }
let b = { defaultNode with id="b" }
let c = { defaultNode with id="c" }
let d = { defaultNode with id="d" }
let e = { defaultNode with id="e" }
let f = { defaultNode with id="f" }
let g = { defaultNode with id="g" }

s.links <- [(a,3);(d,4)]
a.links <- [(s,3);(b,4);(d,5)]
b.links <- [(a,4);(c,4);(e,5)]
c.links <- [(b,4)]
d.links <- [(s,4);(a,5);(e,2)]
e.links <- [(b,5);(d,2);(f,4)]
f.links <- [(e,4);(g,3)]
g.links <- [(f,3)]

          
let x0 = search s "c"


System.Console.ReadLine() |> ignore  

Logic of the Tiny Bit Computer

Just for fun, here's the logic diagram of a single production rule in the tiny bit computer as it now stands. Added is the ability to execute one of two action rules, depending on the state of the test.

(Presented “as-is” and without warranty or implied fitness; use at your own risk.)

Easter

In honor of the day, I present the following short program for calculating the date of Easter. The method is from Butcher's Ecclesiastical Calendar (1876). I present it in the form given in Peter Duffett-Smith's Practical Astronomy With Your Calculator (Cambridge 1981, the 1988 version is still available from Amazon, et al).

Numerous implementations of this algorithm in various other languages (including C#), as well as historical details, etc., can easily be found via web search if you're interested.

By the way, Mr. Duffett-Smith's book (and I presume his later books on computer astronomy) is an absolute gem. If you've ever read predictions of eclipses, etc. and wondered "how did they calculate that?" his books will make all such mysteries plain.

(Presented “as-is” and without warranty or implied fitness; use at your own risk.)

// Computes the date of Easter for a
// given year beginning from 1583.  
// Method is that described in "Butcher's 
// Ecclesiastical Calendar" (1876), 
// and as given in:
// "Practical Astronomy With Your Calculator"
// by Peter Duffett-Smith (Cambridge, 1981).
let easter year =
  // Return integer and fractional
  // part of a division as a tuple.
  let (/%) l r = (l/r),(l%r)
  // The calculation.
  let a     = year%19
  let (b,c) = year/%100
  let (d,e) = b/%4
  let f     = (b+8)/25
  let g     = (b-f+1)/3
  let h     = (19*a+b-d-g+15)%30
  let (i,k) = c/%4
  let l     = (32+2*e+2*i-h-k)%7
  let m     = (a+11*h+22*l)/451
  let (n,p) = (h+l+7*m+114)/%31
  new System.DateTime(year,n,p+1)

let e2009 = easter 2009
let e2010 = easter 2010
let e2011 = easter 2011

printfn 
  "Easter this year is: %s" 
  ((easter System.DateTime.Now.Year).ToString())

System.Console.ReadLine() |> ignore

Update

I discovered that the tiny computer addition program listed in my earlier post here, is not minimal. There is a program consisting of 10 lines instead of 13. Since I will probably be listing it later, its discovery is currently left as an exercise to the reader.

Coming Soon

I'm taking time to actually write some code (!) over the next few days, so this will be brief.

Looking at my and/xor production system, it occurred to me that it was an excellent start on representing a Holland classifier system in schema theorem notation. Which prompts the question: it was easy to come up with a rulset for bitwise addition, but can a learning classifier system generalize a ruleset for addition using my machine?

To that end, I am re-writing, modularizing, and generally improving the code. Then, I'll write a genetic algorithm system to try to evolve the rules. I'll post each module here as I get them complete, but I may also start a code project somewhere to make downloads and updates easier.

Item 175 At Large

Having looked at HAKMEM Item 175 (Gosper) in the abstract, here’s a look at how it can be used.

Item 175 does this: given a binary number x, it returns the next greatest number with the same number of set bits. So called repeatedly on its own output, it generates an ascending sequence of all the numbers starting at n which have the same number of bits as x.

What is this good for? Well, among other things, it can be used to enumerate the combinations of n things taken r at a time. The algorithm is apparent: start with the lowest binary number with the correct number of bits, and cycle until the number with the maximum number of bits is exceeded. For example, to enumerate the combinations of 5 things taken 3 at a time, start with the number 7 (three bits set), and cycle as long as the number is less than 32.

The code below demonstrates an F# implementation of this. I did my best to get it correct, but it is tax time, so there may be a bug or two, there’s no runtime error or boundary condition checking, etc. Also, there may be simpler ways to code some of the functions. If you find a problem, post a comment and I’ll fix the problem.

(Presented “as-is” and without warranty or implied fitness; use at your own risk.)

open System


// HAKMEM Item 175 (Gosper) 
// Return the next highest number
// with the same number of set bits.
let g175 x =   
  let u = x &&& -x
  let v = x + u
  v + (((v^^^x)/u)>>>2)
  

// Select items from a list, 
// where the corresponding bits in n are set.
let select<'a> (l:'a list) n =
  let rec select0 ((i0,l0):int * 'a list) (li:'a) =
    match i0&&&1 with 
    | 0 -> (i0/2,l0)
    | _ -> (i0/2,li::l0) 
  snd (List.fold select0 (n,[]) l)
  

// Return a series of bit sequences
// representing the combinations
// of n things taken r at a time.
let nCr n r =
  let rec comb0 l n = seq {
    match n>=l with 
    | true -> ()
    | _ -> 
        yield n
        yield! comb0 l (g175 n) }
  comb0 (1<<<n) ((1<<<r)-1)
  

// Return a series of lists
// representing the combinations 
// from a list of n things taken r at a time.
let lCr l r = 
  Seq.map 
    (fun i -> select l i) 
    (nCr l.Length r)
    

// Test.
    
let toppings = 
  [
    "pepperoni";
    "sausage";
    "extra cheese"
    "peppers";
    "onions"
  ]
 
  
let budgetPizzas      = Seq.toList (lCr toppings 1)
let standardPizzas    = Seq.toList (lCr toppings 3)
let deluxePizzas      = Seq.toList (lCr toppings 4)
let techNeilogyPizzas = Seq.toList (lCr toppings 5)

let printPizzas s choices =
  printfn s
  (List.map 
    (fun l -> 
       printf "  "
       (List.map (fun c -> printf "%s " c) l) |> ignore
       printfn "")
     choices) |> ignore
    
printPizzas "Budget Pizzas"      budgetPizzas 
printPizzas "Standard Pizzas"    standardPizzas 
printPizzas "Deluxe Pizzas"      deluxePizzas 
printPizzas "TechNeilogy Pizzas" techNeilogyPizzas 
 
printfn ""
printfn "Press any key to order..."
Console.ReadLine() |> ignore