fractal_forest.fsx

// Install-Package -ProviderName nuget SharpDX -Destination $pwd\packages
#r "packages/SharpDX.2.6.3/Bin/DirectX11-Signed-net40/SharpDX.dll"
#r "packages/SharpDX.2.6.3/Bin/DirectX11-Signed-net40/SharpDX.D3DCompiler.dll"
#r "packages/SharpDX.2.6.3/Bin/DirectX11-Signed-net40/SharpDX.DXGI.dll"
#r "packages/SharpDX.2.6.3/Bin/DirectX11-Signed-net40/SharpDX.Direct3D11.dll"

open System
open System.Collections.Generic
open System.Diagnostics

open SharpDX

module Common =
  let dispose (d : IDisposable) =
    if d <> null then
      try
        d.Dispose ()
      with
      | e -> printfn "Dispose failed: %s" e.Message

  let onExit (a : unit -> unit) : IDisposable =
    {
      new IDisposable with
        member x.Dispose () =
          try
            a ()
          with
          | e -> printfn "Dispose failed: %s" e.Message
    }

  let inline size2 w h  = Size2F (w,h)

  let inline v2 x y     = Vector2 (x,y)
  let inline v4 x y z w = Vector4 (x,y,z,w)

  let inline s2 (r : float32) x = Vector2.Multiply (x, r)

  let inline lerp4 t x y= Vector4.Lerp (x, y, t)

  let rdeg2rad          = float32 <| Math.PI / 180.0
  let inline deg2rad d  = rdeg2rad * d

  let inline rotate (a : float32) = Matrix3x2.Rotation a
  let inline scale  (s : float32) = Matrix3x2.Scaling s

  let inline apply m v            = Matrix3x2.TransformPoint (m,v)

  type LineRenderer     = LineRenderer of (Vector2*Vector2*float32*Vector4 -> unit)

module Shaders =
  let shaderSource = """
struct VS_IN
{
  float4 pos : POSITION;
  float4 col : COLOR;
};

struct PS_IN
{
  float4 pos : SV_POSITION;
  float4 col : COLOR;
};

PS_IN VS( VS_IN input )
{
  PS_IN output = (PS_IN)0;

  output.pos = input.pos;
  output.col = input.col;

  return output;
}

float4 PS( PS_IN input ) : SV_Target
{
  return input.col;
}

technique10 Render
{
  pass P0
  {
    SetGeometryShader( 0 );
    SetVertexShader( CompileShader( vs_4_0, VS() ) );
    SetPixelShader( CompileShader( ps_4_0, PS() ) );
  }
}
"""

  let compile (entryPoint : string) (profile : string) =
    use bc = D3DCompiler.ShaderBytecode.Compile(shaderSource, entryPoint, profile, D3DCompiler.ShaderFlags.None, D3DCompiler.EffectFlags.None)
    bc.Bytecode.Data

  let vertexShader        = compile "VS" "vs_4_0"
  let pixelShader         = compile "PS" "ps_4_0"

  let vertexShaderInput   =
    use input = D3DCompiler.ShaderSignature.GetInputSignature (vertexShader)
    input.Data

module View =
  open Common

  type Lines (maxLines : int) =
    let vertices            = Array.zeroCreate<Vector4> (12 * maxLines)
    let mutable count       = 0

    member x.Clear ()       = count <- 0
    member x.Count          = count
    member x.Vertices       = vertices

    member x.AppendLine (f : Vector2, t: Vector2, w : float32, c : Vector4) : unit =
      if count + 2*3*2 < vertices.Length && w > 0.0f then
        let d = t - f
        let l = d.Length ()
        if l > 0.0f then
          let hn = (v2 d.Y -d.X) * (w / (2.0f * l))

          let inline app (v : Vector2) =
            let vv = v4 v.X v.Y 0.5f 1.0f
            vertices.[count]  <- vv
            count <- count + 1
            vertices.[count]  <- c
            count <- count + 1

          app (f + hn)
          app (f - hn)
          app (t + hn)

          app (f - hn)
          app (t - hn)
          app (t + hn)

  type Device (initial : Vector4 [], form : Windows.RenderForm) =

    let getDeviceAndSwapChain (form : Windows.RenderForm) =
      let width               = form.ClientSize.Width
      let height              = form.ClientSize.Height

      let mutable desc        = DXGI.SwapChainDescription ()
      desc.BufferCount        <- 2
      desc.ModeDescription    <- SharpDX.DXGI.ModeDescription (
                                  width                           ,
                                  height                          ,
                                  DXGI.Rational (60, 1)           ,
                                  DXGI.Format.R8G8B8A8_UNorm
                                  )
      desc.IsWindowed         <- Bool true
      desc.OutputHandle       <- form.Handle
      desc.SampleDescription  <- DXGI.SampleDescription (4, 0)
      desc.SwapEffect         <- DXGI.SwapEffect.Sequential
      desc.Usage              <- DXGI.Usage.RenderTargetOutput

      let featureLevels       =
          [|
              Direct3D.FeatureLevel.Level_11_0
              Direct3D.FeatureLevel.Level_10_1
              Direct3D.FeatureLevel.Level_10_0
              Direct3D.FeatureLevel.Level_9_3
              Direct3D.FeatureLevel.Level_9_2
              Direct3D.FeatureLevel.Level_9_1
          |]

      Direct3D11.Device.CreateWithSwapChain (
        Direct3D.DriverType.Hardware                ,
        Direct3D11.DeviceCreationFlags.BgraSupport  ,
        featureLevels                               ,
        desc
        )

    let width               = float32 form.ClientSize.Width
    let height              = float32 form.ClientSize.Height

    let device, swapChain   = getDeviceAndSwapChain form
    let factory             = swapChain.GetParent<DXGI.Factory> ()

    let associateWithWindow = factory.MakeWindowAssociation (form.Handle, DXGI.WindowAssociationFlags.IgnoreAll)

    let backBuffer          = Direct3D11.Texture2D.FromSwapChain<Direct3D11.Texture2D> (swapChain, 0)
    let surface             = backBuffer.QueryInterface<SharpDX.DXGI.Surface> ();
    let renderView          = new Direct3D11.RenderTargetView (device, backBuffer)

    let vertexShader        = new Direct3D11.VertexShader (device, Shaders.vertexShader)
    let pixelShader         = new Direct3D11.PixelShader (device, Shaders.pixelShader)

    let sizeOfVector        = sizeof<Vector4>
    let sizeOfVertex        = 2*sizeOfVector

    let layout              =
      new Direct3D11.InputLayout (device,
                                  Shaders.vertexShaderInput,
                                  [|
                                    Direct3D11.InputElement ("POSITION" , 0, DXGI.Format.R32G32B32A32_Float, 0 * sizeOfVector, 0)
                                    Direct3D11.InputElement ("COLOR"    , 0, DXGI.Format.R32G32B32A32_Float, 1 * sizeOfVector, 0)
                                  |])

    let maxVertexCount      = initial.Length

    let vertexBuffer        =
      Direct3D11.Buffer.Create (device,
                                Direct3D11.BindFlags.VertexBuffer,
                                initial,
                                usage = Direct3D11.ResourceUsage.Dynamic,
                                accessFlags = Direct3D11.CpuAccessFlags.Write)

    let vertexBufferBinding = new Direct3D11.VertexBufferBinding (vertexBuffer, sizeOfVertex, 0)

    let context             =
      let ctx = device.ImmediateContext
      let ia = ctx.InputAssembler
      ia.InputLayout              <- layout
      ia.PrimitiveTopology        <- Direct3D.PrimitiveTopology.TriangleList
      ia.SetVertexBuffers         (0, vertexBufferBinding)
      ctx.Rasterizer.SetViewport  (0.0f, 0.0f, width, height, 0.0f, 1.0f)
      ctx.VertexShader.Set        vertexShader
      ctx.PixelShader.Set         pixelShader
      ctx.OutputMerger.SetTargets renderView
      ctx

    let mutable vertextCount= 0

    member x.Width          = width
    member x.Height         = height
    member x.ClientSize     = size2 (float32 width) (float32 height)

    member x.Draw (lines : Lines) =
      context.ClearRenderTargetView (renderView, Color.White.ToColor4 ())

      vertextCount <- min maxVertexCount lines.Count

      if vertextCount > 0 then
        let db = context.MapSubresource (vertexBuffer, 0, Direct3D11.MapMode.WriteDiscard, Direct3D11.MapFlags.None)
        ignore <| Utilities.Write (db.DataPointer, lines.Vertices, 0, vertextCount)
        context.UnmapSubresource (vertexBuffer, 0)
        context.Draw (vertextCount, 0)

      swapChain.Present (1, DXGI.PresentFlags.None)

    member x.Redraw () =
      context.ClearRenderTargetView (renderView, Color.White.ToColor4 ())

      if vertextCount > 0 then
        context.Draw (vertextCount, 0)

      swapChain.Present (1, DXGI.PresentFlags.None)

    interface IDisposable with
      member x.Dispose () =
        dispose context
        dispose vertexBuffer
        dispose layout
        dispose pixelShader
        dispose vertexShader
        dispose renderView
        dispose surface
        dispose backBuffer
        dispose factory
        dispose swapChain
        dispose device

  open System.Collections.Concurrent
  open System.Threading

  let show
    (title      : string                )
    (maxLines   : int                   )
    (width      : int                   )
    (height     : int                   )
    (onKeyUp    : int -> unit           )
    (onRender   : LineRenderer -> unit  ) =

    use freeBuffers         = new BlockingCollection<Lines> ()
    let fullBuffers         = ConcurrentQueue<Lines> ()

    for i = 0 to 2 do
      freeBuffers.Add <| Lines maxLines

    let worker ()           =
      let mutable cont = true
      while cont do
        let freeBuffer = freeBuffers.Take ()
        if freeBuffer = Unchecked.defaultof<_> then
          cont <- false
        else
          freeBuffer.Clear ()
          onRender (LineRenderer freeBuffer.AppendLine) // TODO: Heap
          fullBuffers.Enqueue freeBuffer

    let workerThread        =
      let t           = Thread (ThreadStart worker)
      t.IsBackground  <- true
      t.Start ()
      t

    let current             = ref Unchecked.defaultof<Lines>

    // Await first set of lines
    while not <| fullBuffers.TryDequeue current do
      Thread.Sleep 10

    use form                = new Windows.RenderForm (title)
    form.AutoScaleMode      <- Windows.Forms.AutoScaleMode.None

    form.ClientSize         <- Drawing.Size (width,height)

    let device              = ref <| new Device ((!current).Vertices, form)

    let disposeDevice ()    = dispose !device
    let recreateDevice ()   = disposeDevice ()
                              device := new Device ((!current).Vertices, form)

    use onExitDisposeDevice = onExit disposeDevice

    let resizer             = EventHandler (fun o e -> recreateDevice ())
    let keyUp               = Windows.Forms.KeyEventHandler (fun o e -> onKeyUp e.KeyValue)

    form.Resize.AddHandler resizer
    form.KeyUp.AddHandler keyUp

    use onExitRemoveHandler = onExit <| fun () -> form.Resize.RemoveHandler resizer

    let render () =
      let d = !device

      let ok, next = fullBuffers.TryDequeue ()

      if ok then
        freeBuffers.Add !current
        current := next
        d.Draw !current
      else
        d.Redraw ()

    Windows.RenderLoop.Run (form, render)

    // Stops the worker
    freeBuffers.Add Unchecked.defaultof<_>

    workerThread.Join ()

open Common

let doNothing _ = ()

let r = Random ()

let brown   = Color.Brown.ToVector4 ()
let green   = Color.LimeGreen.ToVector4 ()
let width   = 0.02f
let height  = 0.6f

let plants =
  let count = 25
  let inline next f t = float32 <| r.NextDouble (float f,float t)
  [|
    for i = 1 to count do
      let lefts   = next 0.50f 0.75f
      let rights  = next 0.50f 0.75f
      let leftr   = next 20.0f 55.0f
      let rightr  = next 20.0f 55.0f
      let leftb   = next 0.50f 1.0f
      let rightb  = next 0.50f 1.0f
      let left    = rotate (deg2rad leftr)  * scale lefts
      let right   = rotate (deg2rad -rightr) * scale rights
//        let x       = next -1.0f 1.0f
      let x       = -1.0f - 1.0f / (float32 count) + 2.0f * (float32 i) / (float32 count)
      let s       = next 0.5f 1.0f

      let rec tree lr t (m : int) (n : int) (w : float32) (s : Vector2) (d : Vector2) =
        if n > 0 then
          let d = apply t d
          let r = float32 n / float32 m
          let c = lerp4 (r * r) green brown

          let b = s + d

          let lb = s + s2 leftb d
          let ld = apply left d
          let rb = s + s2 rightb d
          let rd = apply right d

          tree lr t m (n - 1) (lefts * w) lb ld
          tree lr t m (n - 1) (rights * w) rb rd

          lr (s, b, w, c)

      let plant (LineRenderer lr) turn =
        let t = rotate (turn / s)
        let w = s * width
        let d = (v2 0.0f (s * height))


        tree lr t 8 8 w (v2 x -1.0f) d

      yield plant
  |]

let sw      = Stopwatch ()
sw.Start ()

printfn "Fractal Trees - Mårten Rånge, @marten_range"

View.show "Fractal Trees" 32000 1600 1200 doNothing <| fun lr ->
  let sec     = float32 sw.ElapsedMilliseconds / 1000.f
  let turn    = deg2rad <| 8.0f * sin (0.3f * sec)

  for plant in plants do
    plant lr turn