F# for game development

/// Position, meters
[<Measure>] type m

/// Time, seconds
[<Measure>] type s

/// Mass, kilograms
[<Measure>] type kg

/// Force, Newtons
[<Measure>] type N = kg m/s^2

let integrateShips (dt : float32<s>) (ships : Ships) ...

/// A three-dimensional vector with a unit of measure. Built on top of Xna's Vector3.
type TypedVector3<[<Measure>] 'M> =
    struct
        val v : Vector3
        new(x : float32<'M>, y : float32<'M>, z : float32<'M>) =
            { v = Vector3(float32 x, float32 y, float32 z) }
        new(V) = { v = V }

        member this.X : float32<'M> = LanguagePrimitives.Float32WithMeasure this.v.X
        member this.Y : float32<'M> = LanguagePrimitives.Float32WithMeasure this.v.Y
        member this.Z : float32<'M> = LanguagePrimitives.Float32WithMeasure this.v.Z
    end

[<RequireQualifiedAccessAttribute>]
module TypedVector =
    let add3 (U : TypedVector3<'M>, V : TypedVector3<'M>) =
        new TypedVector3<'M>(U.v + V.v)

    let sub3 (U : TypedVector3<'M>, V : TypedVector3<'M>) =
        new TypedVector3<'M>(U.v - V.v)


type TypedVector3<[<Measure>] 'M>
with
    static member public (+) (U, V) = TypedVector.add3 (U, V)
    static member public (-) (U, V) = TypedVector.sub3 (U, V)

let scale3 (k : float32<'K>, U : TypedVector3<'M>) : TypedVector3<'K 'M> =
        let conv = LanguagePrimitives.Float32WithMeasure<'K 'M>
        let v = Vector3.Multiply(U.v, float32 k)
        new TypedVector3<_>(conv v.X, conv v.Y, conv v.Z)

type TypedVector3<[<Measure>] 'M>
with
    static member public (*) (k, U) = TypedVector.scale3 (k, U)

    let speeds2 =
        Array.map2
            (fun speed (accel : TypedVector3<m/s^2>) ->
                let speed : TypedVector3<m/s> = speed + dt * accel
                speed)
            ships.speeds.Content accels.Content

    let posClient =
        ArrayInlined.map3
            (fun pos speed speed2-> pos + 0.5f * dt * (speed + speed2))
            ships.posClient.Content
            ships.speeds.Content
            speeds2

namespace CleverRake.XnaUtils

open Microsoft.Xna.Framework
open System.Threading

type IFramePerSecondCounter =
    abstract FramesPerSecond : float

/// An update-able and drawable game component which performs light updates on the main
/// thread, then draws on a separate thread in parallel of more computation-heavy updates.
/// initialize_fun is called when assets are loaded.
/// dispose is called when the component is disposed, and should be used to unload assets.
/// update_fun takes a GameTime and a state, and should produce draw data and computation
/// data.
/// draw_fun takes a game time and draw data and should return nothing.
/// compute_fun takes a game time and computation data and should return a new state.
type ParallelUpdateDrawGameComponent<'State, 'DrawData, 'ComputationData>
    (game,
     initial_state : 'State,
     initialize_fun : unit -> unit,
     update_fun : GameTime -> 'State -> 'DrawData * 'ComputationData,
     compute_fun : GameTime -> 'ComputationData -> 'State,
     draw_fun : GameTime -> 'DrawData -> unit,
     dispose : unit -> unit) =

    inherit DrawableGameComponent(game)

    let mutable state = initial_state
    let mutable draw_data = Unchecked.defaultof<'DrawData>
    let mutable compute_data = Unchecked.defaultof<'ComputationData>
    let mutable gt_shared = GameTime()

    let mutable enabled = true
    let mutable update_order = 0

    let signal_start = new AutoResetEvent(false)
    let mutable kill_requested = false
    let signal_done = new AutoResetEvent(false)

    let do_compute() =
#if XBOX360
        // Set affinity
        // 0 and 2 are reserved, I assume the "main" thread is 1.
        Thread.CurrentThread.SetProcessorAffinity(3)
#endif
        while not kill_requested do
            signal_start.WaitOne() |> ignore
            state <- compute_fun gt_shared compute_data
            signal_done.Set() |> ignore

    let compute_thread = new Thread(new ThreadStart(do_compute))

    // Must be called from the main thread.
    let post_compute_then_draw gt =
        if not kill_requested then
            let state = state
            gt_shared <- gt
            signal_start.Set() |> ignore
            draw_fun gt draw_data
            signal_done.WaitOne() |> ignore

    let mutable frameCounter = 0
    let mutable timeCounter = 0.0
    let mutable fps = 0.0
    let fpsUpdatePeriod = 0.3

    do
        compute_thread.IsBackground <- true
        compute_thread.Start()

    override this.Initialize() =
        base.Initialize()
        initialize_fun()

    override this.Update(gt) =
        if base.Enabled then
            base.Update(gt)
            let draw, compute = update_fun gt state
            draw_data <- draw
            compute_data <- compute

    override this.Draw(gt) =
        if base.Visible then
            base.Draw(gt)
            post_compute_then_draw gt
        else
            state <- compute_fun gt compute_data
        timeCounter <- timeCounter + gt.ElapsedGameTime.TotalSeconds
        frameCounter <- frameCounter + 1
        if timeCounter > fpsUpdatePeriod then
            fps <- float frameCounter / timeCounter
            timeCounter <- timeCounter - fpsUpdatePeriod
            frameCounter <- 0

    
    interface System.IDisposable with
        member this.Dispose() =
            base.Dispose()
            dispose()
            signal_start.Dispose()
            signal_done.Dispose()

    interface IFramePerSecondCounter with
        member this.FramesPerSecond = fps

    member this.FramesPerSecond = fps

    member this.RequestKill() =
        kill_requested <- false
        signal_start.Set() |> ignore

    member this.WaitUntilDead() =
        compute_thread.Join()

    member this.IsDead = not(compute_thread.IsAlive)

The main subject of the book is the F# language and its various
constructs, but every single chapter is centered around a game-related
problem. Each one of the first 5 chapters describes a problem, shows
and discusses its solution and then discusses in depth the F#
constructs used. The book has a (relatively rare) "problem-solution"
approach where everything is explained because of how well it works in
solving the problem, and not just "because". The 5 problems we present
are:
- a bouncing ball
- the Saturn V rocket
- an asteroid field
- a large asteroid field optimized with quad trees
- a police starship that must fight off a pirate ship attacking a
cargo freighter
In the last two chapters we use XNA to build a 2D and 3D renderer for
two of the samples we have seen. We show the basics of the SpriteBatch
class, the Model class, input management and audio with this powerful
framework. Basically, we cover the most important aspects of XNA in a
simple and succint way.

protected override void Update(GameTime gameTime)
        {
            base.Update(gameTime);

            if (titleStorageLost == GuideStates.Requested)
            {
                if (!Guide.IsVisible) try
                {
                    Guide.BeginShowMessageBox("Storage device disconnected",
                        "The storage device used for scores was disconnected. " +
                        "Scores will not be saved unless a new device is selected. " +
                        "Would you like to select a device now?",
                        new string[] { "Yes", "No" }, 0, MessageBoxIcon.Alert,
                        (result) =>
                        {
                            var choice = Guide.EndShowMessageBox(result);
                            if (choice.HasValue && choice.Value == 0)
                                requestTitleStorage = true;
                            titleStorageLost = GuideStates.None;
                        },
                        null);
                    titleStorageLost = GuideStates.Pending;
                }
                catch (GuideAlreadyVisibleException) { }
            }

            if (titleStorageLost == GuideStates.None && requestTitleStorage)
            {
                storage.RequestTitleStorage();
                requestTitleStorage = false;
            }

            if (titleStorageLost == GuideStates.None && !requestTitleStorage && userStorageLost == GuideStates.Requested)
            {
                if (!Guide.IsVisible) try
                {
                    Guide.BeginShowMessageBox("Storage device disconnected",
                        "The storage device used for player progress was disconnected. " +
                        "Progress will not be saved unless a new device is selected. " +
                        "Would you like to select a device now?",
                        new string[] { "Yes", "No" }, 0, MessageBoxIcon.Alert,
                        (result) =>
                        {
                            var choice = Guide.EndShowMessageBox(result);
                            if (choice.HasValue && choice.Value == 0)
                                requestUserStorage = true;
                            userStorageLost = GuideStates.None;
                        },
                        null);
                    userStorageLost = GuideStates.Pending;
                }
                catch (GuideAlreadyVisibleException) { }
            }

            if (titleStorageLost == GuideStates.None && userStorageLost == GuideStates.None && !requestTitleStorage && requestUserStorage)
            {
                var screens = screenManager.GetScreens();
                if (screens.Length > 0)
                {
                    var topScreen = screens[screens.Length - 1];
                    if (topScreen.ControllingPlayer.HasValue)
                        storage.RequestUserStorage(topScreen.ControllingPlayer.Value);
                }
                requestUserStorage = false;
            }

        }

task {
  do! storage.CheckPlayerStorage
}

You can't steer, you can't see, you can't aim and you can't shoot. You can avoid this game, though... 

Looks fantastic and plays well, just a little redundant [...]. Nice game, enjoyable, but lacking variety.

[<AllowNullLiteral>]
type StorageDevice =
    class
        val drive : DriveInfo
        val path : string
        new (d, p) = { drive = d; path = p }
    end 

[<AllowNullLiteral>]
type StorageDevice =
    class
        val drive : DriveInfo
        val path : string
        new (d, p) = { drive = d; path = p }
    end


[<AllowNullLiteral>]
type StorageContainer =
    class
        val name : string
        val device : StorageDevice
        val mutable is_disposed : bool
    
        new(name, dev) = { name = name; device = dev; is_disposed = false }
    end
with interface IDisposable with
        member this.Dispose() = this.is_disposed <- true

type StorageDevice with
    member this.BeginOpenContainer(displayName : string, cb : AsyncCallback, state : Object) =
        let f = new Task<_>(StorageInternals.openContainer(this, displayName), state)

        StorageInternals.doThenMaybeCallback(f, cb)

        f :> IAsyncResult

    member this.EndOpenContainer(result : IAsyncResult) =
        let task = result :?> Task<StorageContainer>
        task.Wait()
        task.Result

module Module1.fs

namespace Microsoft.Xna.Framework.Storage

type StorageContainer =
    class
        val name : string
        val device : StorageDevice
        val mutable is_disposed : bool
    
        new(name, dev) = { name = name; device = dev; is_disposed = false }
    end
with interface IDisposable with
        member this.Dispose() = this.is_disposed <- true


module StorageInternals =
    let checkConnected(dev : StorageDevice) =
        if not dev.drive.IsReady then raise(StorageDeviceNotConnectedException())

type StorageContainer with

    member this.CreateDirectory(dir) =
        StorageInternals.checkConnected(this.device)
        let path = Path.Combine(this.device.path, this.name, dir)
        Directory.CreateDirectory(path) |> ignore 

let f = new Task<_>(StorageInternals.openContainer(this, displayName), state)

let openContainer(dev : StorageDevice, name) _ =
        let dialog = new FolderBrowser(sprintf "Select container directory [%s]" name, Some dev.path)
        async {
            try
                do! Async.SwitchToContext(gui_context)
                dialog.Show()
                let! _ = Async.AwaitEvent(dialog.Closed)
                return
                    match dialog.Selected with
                    | Some path ->
                        if not(Directory.Exists(path)) then
                            Directory.CreateDirectory(path) |> ignore
                        new StorageContainer(name, dev)
                    | None ->
                        null
            finally
                dialog.Dispose()
        }
        |> Async.RunSynchronously

type ScreenManager(game, ui_content_provider : IUiContentProvider) =
    ...
    member this.AddDoRemove(s : Screen, t : Eventually<'T>) = task {
        try
            this.AddScreen(s)
            return! t
        finally
            this.RemoveScreen(s)
    }

exception TaskKilled of obj

type Environment(scheduler : Scheduler) =
    // When killing all tasks, the data to embed in TaskKilled exceptions.
    let killing_data : obj option ref = ref None

    let checkAndKill = task {
        match !killing_data with
        | Some o -> raise(TaskKilled(o))
        | None -> ()
    }

    member this.StartKillAll(data) =
        killing_data := Some data
        scheduler.WakeAll()

    member this.StopKillAll() =
        killing_data := None

    member this.Wait dt = task {
        do! checkAndKill
        do! wait dt
        do! checkAndKill
    }

type TopState =
    | Initializing
    | AtPressStartScreen
    | AnonPlayer
    | Player of SignedInGamer
    | KillingAllTasks

type TopState =
    | Initializing
    | AtPressStartScreen
    | AnonPlayer
    | Player of SignedInGamer
    | KillingAllTasks
with
    member this.Update(transition) =
        match this, transition with
        | Initializing, InitDone -> AtPressStartScreen
        | Initializing, _ -> invalidOp "Invalid transition from Initializing"

        | AtPressStartScreen, AnonPressedStart -> AnonPlayer
        | AtPressStartScreen, PlayerPressedStart(p) -> Player p
        | AtPressStartScreen, _ -> invalidOp "Invalid transition from AtPressStartScreen"

        | AnonPlayer, Back -> AtPressStartScreen
        | AnonPlayer, _ -> invalidOp "Invalid transition from AnonPlayer"

        | Player p, SignOut -> KillingAllTasks
        | Player p, Back -> AtPressStartScreen
        | Player p, _ -> invalidOp "Invalid transition from Player"

        | KillingAllTasks, AllTasksKilled -> Initializing
        | KillingAllTasks, _ -> invalidOp "Invalid transition from KillingAllTasks"

and TopStateTransition =
    | InitDone
    | AnonPressedStart
    | PlayerPressedStart of SignedInGamer
    | SignOut
    | AllTasksKilled
    | Back

// Initialization and killing of tasks.
        // Killing happens when a signed in player signs out.
        // Initialization happens during start-up and after killing.
        match !top_state with
        | Initializing ->
            scheduler.AddTask(main_task)
            top_state := (!top_state).Update(InitDone)
        | Player p when not(Gamer.IsSignedIn(p.PlayerIndex)) ->
            top_state := (!top_state).Update(SignOut)
            sys.StartKillAll(null)
        | KillingAllTasks when not(scheduler.HasLiveTasks) ->
            sys.StopKillAll()
            top_state := (!top_state).Update(AllTasksKilled)
            // Ideally, screen removal is done in finally handlers, and
            // killing should take care of removing all screens.
            // Nevertheless, we remove all screens here to be on the safe side.
            screen_manager.RemoveAllScreens()
        | _ -> ()

The sample implements a simple game flow with a main menu, an options screen, some actual gameplay, and a pause menu. It displays a loading screen between the menus and gameplay, and uses a popup message box to confirm whether the user really wants to quit.
The ScreenManager class is a reusable component that maintains a stack of one or more GameScreen instances. It coordinates the transitions from one screen to another, and takes care of routing user input to whichever screen is on top of the stack.

The game starts with the press start screen, then the main menu is showed. Depending on the entry selected, the game may go into actual gameplay, show a credits screen...

type MenuScreen<'I when 'I : equality>(
   player : PlayerIndex,
   sys : Environment,
   items : ('I * string)[],
   anim : AnimationParameters,
   placement : PlacementParameters) =

type MainMenuEntries =
    | Play
    | Instructions
    | Options
    | Scores
    | Credits
    | BuyFullVersion
    | Exit

• player is the index of the player who has control, i.e. the player who pressed "start" on the "press start screen"
• sys is the object used to interact with the scheduler, which is used to spawn new tasks, wait, yield control...
• items is a list of (menu entry - text) pairs
• anim is a record whose fields control fade-in and fade-out effects
• placement is another records controlling where the menu is rendered

inherit ScreenBase()

    // A mutable cell holding the index of the entry currently selected.
    let current = ref 0

    // An object wrapping a number of variables controlling fading effects.
    let animation = new Animations.MultipleFadeIn(sys, items.Length, anim.period, anim.shift)

    // Keeps track of button presses on the gamepad of the player with control
    let input = new InputChanges.InputChanges(player)

    // Array keeping track of the state of visibility of each entry.
    // Typically entries are visible, but some must be hidden or showed as gray
    // depending on whether the user is running the full version of the game
    // or the trial.
    let visibility = items |> Array.map (fun _ -> Visible)

    do if items.Length = 0 then invalidArg "items" "items may not be empty"

member this.Task = task {
        this.SetDrawer(this.Drawer)

        let animator = sys.Spawn(animation.Task)

        let selected = ref false
        let backed = ref false
        while not (!selected || !backed) do
            // If this screen is not active, i.e. it is not on top or the guide is visible, wait.
            // We don't want to react to input that's not for us.
            do! sys.WaitUntil(fun () -> this.IsOnTop)

            input.Update()

            if input.IsMenuDown() then moveDown()
            elif input.IsMenuUp() then moveUp()
            elif input.IsStartPressed() then selected := true
            elif input.IsBackPressed() then backed := true

            do! sys.WaitNextFrame()

        animator.Kill()
        do! sys.WaitUntil(fun() -> animator.IsDead)

        return
            if !selected then items.[!current] |> fst |> Some
            else None
    }

use menu =
            new MenuScreen<_>(
                controlling_player,
                sys,
                [| Play, "Play now"
                   Instructions, "How to play"
                   Options, "Options"
                   Scores, "Scores"
                   Credits, "More information"
                   BuyFullVersion, "BuyFullVersion"
                   Exit, "Exit" |],
                menu_animation,
                menu_placement
            )

        // Show the menu
        screen_manager.AddScreen(menu)
        // Execute the menu's code, and get the selected item as a result
        let! action = menu.Task
        // We are done with the menu, hide it.
        screen_manager.RemoveScreen(menu)

        // Deal with the selection in the menu.
        match action with        
        // Back to the board.
        | Some Exit ->
            exit_game := true

// Deal with the selection in the menu.
match action with        
// Back to the board.
| Some Exit ->
    exit_game := true
        
// Start playing.
| Some Play ->
    // Create the screen showing the game.
    use gameplay = new GameplayScreen(sys, controlling_player)

    // Show the gameplay screen. Gameplay itself is in gameplay.Task
    let! gameplay_result = screen_manager.AddDoRemove(gameplay, gameplay.Task)

    // If the game wasn't aborted, and if a new high score was achieved,
    // add it to the score table and show the table.
    match gameplay_result with
    | Aborted _ -> ()
    | TooEarly (_, points) | TooLate (_, points) ->
        use results = new ResultScreen(sys, controlling_player, gameplay_result)
        do! screen_manager.AddDoRemove(results, results.Task)

        let player_name =
            match SignedInGamer.SignedInGamers.ItemOpt(controlling_player) with
            | None -> "Unknown"
            | Some player -> player.Gamertag

        let is_hiscore = (!scores).AddScore(player_name, points)

        if is_hiscore then
            // save the scores.
            if storage.TitleStorage.IsSome then
                do! storage.CheckTitleStorage
                let! result =
                    storage.DoTitleStorage(
                       score_container,
                       saveXml score_filename !scores)

                match result with
                | Some(Some()) -> ()
                | _ -> do! doOnGuide <| fun() -> error "Failed to save scores"
            // Show the scores screen.
            do! showScores

• A typical "press start screen -> menu -> game" flow
• Safe IO using StorageDevice, used for best scores and user preferences
• Throwing back to the "press start screen" when sign-outs occur
• Screen transitions
• Input handling and pausing (not complete at the time of writing)
• Content loading and unloading

• GuideAlreadyVisibleException

• None known

• InvalidOperationException (from msdn)
• ArgumentNullException (from msdn)
• StorageDeviceNotConnectedException

• InvalidOperationException
• StorageDeviceNotConnectedException

• StorageDeviceNotConnectedException
• FileNotFoundException

• StorageDeviceNotConnectedException
• Possibly other exceptions, e.g. if no space is left on the device?

1. Files can only be accessed after getting access to a storage device, which requires interaction with the user as soon as more than one storage device (hard-disk, memory unit, usb stick...) is available. As all of the steps cannot be performed within a single iteration of the update-loop, this forces the programmer to spread the steps over multiple iterations.
2. Attempting to get a storage device while the guide is open results in an exception. The guide is a graphical interface to the console's "operating system" which is available at any time.
3. At most one storage container may be in use at any time (a storage container is a collection of files, it can be seen as a directory).
4. The user may at any time remove a storage device, which results in exceptions being thrown while accessing the device.
5. File access is quite slow. In order to keep the GUI responsive, games must perform IO asynchronously.

Problem 1: Getting a storage device asynchronously

let getUserStorageDevice player = task {
    let! async_result = doOnGuide(fun() -> StorageDevice.BeginShowSelector(player, null, null))
    do! waitUntil(fun() -> async_result.IsCompleted)
    let device = StorageDevice.EndShowSelector(async_result)
    return
        if device = null then
            None
        else
            Some device
}

Problem 2: Avoiding GuideAlreadyVisible exceptions

let rec doOnGuide f = task {
    do! waitUntil(fun() -> not Guide.IsVisible)
    let! result = task {
        try
            return f()
        with
        | :? GuideAlreadyVisibleException ->
            do! wait(0.5f)
            let! eventually_some_bloody_result = doOnGuide f
            return eventually_some_bloody_result
    }
    return result
}

Problem 3: At most one storage container opened at any time

type Storage() =
    let is_busy = ref false
    member this.DoTitleStorage(container_name, f) = task {
            do! waitUntil(fun () -> not !is_busy)
            try
                is_busy := true

                let! result = doInContainer device container_name f
                return result
            finally
                is_busy := false
    }

Problem 4: Uncaring users yanking storage devices at inappropriate times

Problem 5: Asynchronous file operations

Wrap-up

type GameState =
| PressStartFadeIn of ...
| PressStartWaitButtonPress of ...
| PressStartFadeOut of ...
| MenuFadeIn of ...
...

let update(gt : GameTime) =
  state <-
    match state with
    | PressStartFadeIn ...

while not exit_requested do
  let press_start_screen = new PressStartScreen()
  press_start_screen.Show()
  let player = press_start_screen.GetPlayer()
  press_start_screen.Hide()

  let menu_screen = new MenuScreen()
  menu_screen.Show()
  let entry = menu_screen.GetEntry()
  menu_screen.Remove();
  match entry with
  | Play -> play(); showScores()
  | Scores -> showScores()

// This task is chopped in blocks and each block is executed by the scheduler each frame (see Main.Update())
    let press_start_task = task {
        // subtask that makes the "press start" text blink. Executes concurrently
        let blinker =
            sys.Spawn(anim.Task)

        // Task to check if a button is pressed. Sets player when that happens.
        let player : PlayerIndex option ref = ref None
        while (!player).IsNone do
            for p in all_players do
                let state = GamePad.GetState(p)
                if state.IsConnected
                    && (state.Buttons.Start = ButtonState.Pressed
                        || state.Buttons.A = ButtonState.Pressed) then
                    player := Some p
            do! nextFrame()

        // Stop blinking
        blinker.Kill()
    
        // To be nice, wait until the blinker is done.
        // Depending on the blinking period, this could take long as we only check for the kill flag once per blink.
        do! sys.WaitUntil(fun () -> blinker.IsDead)

        // Return the index of the player that pressed start.
        return
            match !player with
            | Some p -> p
            | None -> failwith "Unreachable"
    }

#r @"D:\Documents\WinForms\WinFormsGraphicsDevice\bin\Release\WinFormsGraphicsDevice.exe"

#I @"C:\Program Files\Microsoft XNA\XNA Game Studio\v4.0\References\Windows\x86"
#r "Microsoft.Xna.Framework.Graphics.dll"
#r "Microsoft.Xna.Framework.dll"
#r "Microsoft.Xna.Framework.Game.dll"

open System.Windows.Forms
open Microsoft.Xna.Framework

type XnaControl() =
    inherit WinFormsGraphicsDevice.GraphicsDeviceControl()

    let mutable drawer = fun (dt : GameTime) -> ()
    let watch = new System.Diagnostics.Stopwatch()
    let mutable last_time = watch.Elapsed

    member this.Drawer
        with get ()  = drawer
        and  set (v) = drawer <- v
        
    override this.Initialize() =
        watch.Start()
        last_time <- watch.Elapsed

    override this.Draw() =
        let diff = watch.Elapsed - last_time
        last_time <- watch.Elapsed
        GameTime(diff, watch.Elapsed)
        |> drawer

type XnaForm() =
    inherit Form()

    let ctrl = new XnaControl()
    let animationHandler = new System.EventHandler(fun _ _ -> ctrl.Invalidate())
    do
        ctrl.Dock <- DockStyle.Fill
        base.Controls.Add(ctrl)

    member this.XnaControl = ctrl

    member this.EnableAnimation() =
        Application.Idle.AddHandler(animationHandler)

    member this.DisableAnimation() =
        Application.Idle.RemoveHandler(animationHandler)

let form = new XnaForm()
form.Show()
let content = new Content.ContentManager(form.XnaControl.Services)
content.RootDirectory <- @"D:\Documents\WorldConquest\ContentLibrary\bin\x86\Debug\Content"

let units : Graphics.Texture2D = content.Load("units")

let batch = new Graphics.SpriteBatch(form.XnaControl.GraphicsDevice)

let draw _ =
    try
        batch.Begin()
        batch.Draw(units, Vector2.Zero, Color.White)
    finally
        batch.End()


form.XnaControl.Drawer <- draw

Problem area

Data structure

type Node<'TS> =
    { bbox : BoundingBox
      data : Data<'TS> }
and Data<'TS> =
    | Leaf of int * 'TS          // sequence length, sequence of items
    | Inner of Node<'TS> array   // Array of 8 items exactly

Construction

let rec insert max_count max_depth intersect node item depth =
    assert (
       intersect node.bbox item
    )
    
    match node.data with
    | Leaf(count, items) when (depth >= max_depth || count < max_count) ->
        { node with data = Leaf(count + 1, item :: items) }
    | Leaf(count, items) ->
        let node' = split intersect node
        insert max_count max_depth intersect node' item (depth + 1)
    | Inner(children) ->
        { node with
            data = Inner(
                    children
                    |> Array.map (fun child_node ->
                            if intersect child_node.bbox item
                            then insert max_count max_depth intersect child_node item (depth + 1)
                            else child_node
                        )
                    )
        }

let myInsert = insert 20 5 myIntersectionPredicate

let rec freeze (node : Node<'T list>) : Node<'T[]> =
    match node.data with
    | Leaf (count, ts) -> { bbox = node.bbox ; data = Leaf (count, Array.ofList ts) }
    | Inner (children) -> { bbox = node.bbox ; data = Inner (children |> Array.map freeze) }

Querying

let checkIntersection intersectBbox intersectSomeItem node =
    let rec work node =
        intersectBbox node.bbox
        &&
        match node.data with
        | Leaf(_, items) ->
            intersectSomeItem items
        | Inner(children) ->
            children |> Array.exists work
        
    work node

let intersectBBox2 (spheres : BoundingSphere[]) (i : int) =
    let sph = spheres.[i]

    fun (box : BoundingBox) ->
        box.Intersects(sph)

let intersectBSphere (spheres1 : BoundingSphere[]) (spheres2 : BoundingSphere[]) (i1 : int) =
    let sph = spheres1.[i1]

    fun i2s ->
        i2s
        |> Array.exists (fun i2 -> sph.Intersects(spheres2.[i2]))

let checkIntersection_BoundingSpheres spheres_octree spheres2 node item =
    checkIntersection (intersectBBox2 spheres2 item) (intersectBSphere spheres2 spheres_octree item) node

Alternative implementations

let inline exists (pred : 'T -> bool) (xs : 'T[]) : bool =
    let mutable i = 0
    while i < xs.Length && not (pred xs.[i]) do
        i <- i + 1
    i < xs.Length

Benchmark

Results

Virtual sparse: 0.016 / 1.185
Virtual: 0.011 / 1.136
Virtual dense: 0.096 / 1.029

Inline sparse: 0.016 / 0.777
Inline: 0.011 / 0.743
Inline dense: 0.093 / 0.651

Delegate sparse: 0.009 / 1.194
Delegate: 0.007 / 1.150
Delegate dense: 0.045 / 0.941

Specific sparse: 0.007 / 0.913
Specific: 0.007 / 0.890
Specific dense: 0.043 / 0.759 

Virtual sparse: 0.170 / 1.062
Virtual: 0.194 / 0.972
Virtual dense: 2.193 / 1.800

Inline sparse: 0.117 / 0.574
Inline: 0.146 / 0.558
Inline dense: 2.082 / 0.677

Delegate sparse: 0.082 / 1.605
Delegate: 0.098 / 1.543
Delegate dense: 0.752 / 2.172

Specific sparse: 0.068 / 0.568
Specific: 0.094 / 0.542
Specific dense: 0.656 / 0.423 

Observations

Conclusions

Update: 2010 dec 14