Landing Ship in F#

0_README.md

Landing a rocket

How to run

1. WPF requires a Windows box
2. Install dotnet: https://dotnet.microsoft.com/en-us/download
3. Create a folder named for example: FsLanding
4. Create file in the folder named: FsLanding.fsproj and copy the content of 1_FsLanding.fsproj below into that file
5. Create file in the folder named: Program.fs and copy the content of 2_Program.fs below into that file
6. Launch the application in Visual Studio or through the command line dotnet run from the folder FsLanding

1_FsLanding.fsproj

<Project Sdk="Microsoft.NET.Sdk">

  <PropertyGroup>
    <OutputType>WinExe</OutputType>
    <TargetFramework>net6.0-windows</TargetFramework>
    <UseWPF>true</UseWPF>
  </PropertyGroup>

  <ItemGroup>
    <Compile Include="Program.fs" />
  </ItemGroup>

</Project>

2_Program.fs

// Hi!. The particle system is defined at row: 236+

// `open` are F# version of C# `using`
open System
open System.Collections.Generic
open System.Diagnostics
open System.Globalization
open System.Numerics

open System.Windows
open System.Windows.Input
open System.Windows.Media
open System.Windows.Media.Animation

open FSharp.Core.Printf

type V1 = float32
type V2 = Vector2

// F# inline is sometimes used for performance but often
//  it's used to get access to more advanced generics than
//  supported by .NET CLR
//  x here can be any type that supports conversion to float32
let inline v1 x           = float32 x
let inline v2 x y         = V2 (float32 x, float32 y)
let v2_0                  = v2 0.F 0.F
let inline clamp v i x    = max i (min v x)
let inline clamp2 v i x   = V2.Max (i, V2.Min(v, x))
let tanh_approx x         =
  // tanh is (exp(x) − exp(−x)) / (exp(x) + exp(−x))
  // But exp is pretty expensive. Following is s decent approx
  let x2 = x*x
  clamp (x*(27.F+x2)/(27.F+9.F*x2)) -1.F 1.F

[<RequireQualifiedAccess>]
type Color =
  | Gray
  | Green
  | Red
  | White
  | Yellow
let noColor : Color option = Some Color.Gray

// Define a particle record
//  Mass is stored in difference ways to avoid recomputing it
//  Current is the current position
//  Previous is the previous position
//  The speed then implicitly is Current-Previous
//  This representation is used in something called Verlet Integration
//  Verlet Integration avoids needing to update the speed vector
//  when computing the constraints
//  It doesn't produce accurate physics but it looks believable
//  which is good enough for this program
//  Verlet Integration is described with some detail here:
//    https://en.wikipedia.org/wiki/Verlet_integration
type Particle =
  {
    Color             : Color option
    Mass              : V1
    SqrtMass          : V1
    InvertedMass      : V1
    mutable Current   : V2
    mutable Previous  : V2
  }

  // Verlet step moves the particle with inertia and gravity
  member x.Step (gravity : V1) =
    // InvertedMass of 0 means this is a fixed particle of infinite
    //  mass. These particles don't move
    if x.InvertedMass > 0.F then
      let c = x.Current
      let g = v2 0.F gravity
      x.Current   <- g + c + (c - x.Previous)
      x.Previous  <- c

// Makes a particle given mass, position x,y and velocity vx,vy
let inline mkParticle pc mass x y vx vy : Particle =
  let m = v1 mass
  let c = v2 x y
  let v = v2 vx vy
  {
    Color         = pc
    Mass          = m
    InvertedMass  = 1.F/m
    SqrtMass      = sqrt m
    Current       = c
    Previous      = c - v
  }

// Makes a fix particle position x,y
//  a fix particle has infinite mass and doesn't move
//  used as an anchor point for other particles and constraints
let inline mkFixParticle pc x y = mkParticle pc infinityf x y 0.F 0.F

module Details =
  let inline adapt f    = OptimizedClosures.FSharpFunc<V1, V1, V1>.Adapt f
  let stickActivation   = adapt (fun l d -> d)
  let ropeActivation    = adapt (fun l d -> if d > 0.F then d else 0.F)
  let springActivation f= adapt (fun l d -> d*tanh_approx (f*(abs d/l)))
  let epsilon           = 0.0001F
  let epsilonSquared    = epsilon*epsilon

  let rec isPressed (pressed : HashSet<Key>) (keys : Key array) i =
    if i < keys.Length then
      if pressed.Contains keys.[i] then 
        true
      else
        isPressed pressed keys (i + 1)
    else
      false
open Details

// Defines a constraint which is either a stick or a rope
//  a stick tries to make sure that the distance between two particles
//  are the Length value
//  a rope tries to makes sure that distance between two particles
//  are at most the Length value
type Constraint =
  {
    Color           : Color option
    Activation      : OptimizedClosures.FSharpFunc<V1, V1, V1>
    Length          : V1
    Left            : Particle
    Right           : Particle
  }

  // After the verlet step most constraints are "over stretched"
  //  Relax moves the two particles so that the constraint is "relaxed"
  //  again. This will in turn make other constraints "over stretched"
  //  but it turns out applying Relax over and over moves the system
  //  to a relaxed state
  member x.Relax () =
    // Bunch of math but the intent is this:
    //  compute the distance between the two particles in the constraint
    //  if the distance is not the right distance
    //  then move the two particles towards or away from eachother
    //  so that the distance is correct
    //  The comparitive mass of the particles is used to make sure
    //  that a small particle moves more than the bigger one it's
    //  connected to
    let l  = x.Left
    let r  = x.Right
    let lc = l.Current
    let rc = r.Current

    let diff  = lc - rc
    let len   = diff.Length ()
    let ldiff = len - x.Length
    let adiff = x.Activation.Invoke (x.Length, ldiff)
    if abs adiff > epsilon then
      let imass = 0.5F/(l.InvertedMass + r.InvertedMass)
      let mdiff = (imass*adiff/len)*diff
      let loff  = l.InvertedMass * mdiff
      let roff  = r.InvertedMass * mdiff

      l.Current <- lc - loff
      r.Current <- rc + roff

// Makes a stick constraint between two particles
let inline mkStick c (l : Particle) (r : Particle) : Constraint =
  {
    Color       = c
    Activation  = stickActivation
    Length      = (l.Current - r.Current).Length ()
    Left        = l
    Right       = r
  }

// Makes a spring constraint between two particles
let inline mkSpring c f (l : Particle) (r : Particle) : Constraint =
  {
    Color       = c
    Activation  = springActivation f
    Length      = (l.Current - r.Current).Length ()
    Left        = l
    Right       = r
  }

// Makes a rope constraint between two particles
//  allows making the rope a bit longer than the initial distance
let inline mkRope c extraLength (l : Particle) (r : Particle) : Constraint =
  {
    Color       = c
    Activation= ropeActivation
    Length    = (1.F + abs (float32 extraLength))*(l.Current - r.Current).Length ()
    Left      = l
    Right     = r
  }

// Defines a global constraint that forces all particles inside a box
type GlobalConstraint =
  {
    Variant : bool
    Min     : V2
    Max     : V2
  }

  // If the current particle position is outside the box
  //  force it into the box again
  member x.Relax (ps : Particle array) =
    for p in ps do
      let c   = p.Current
      let nc  = 
        if x.Variant then
          let di  = c - x.Min
          let dx  = x.Max - c
          if di.X >= 0.F && dx.X >= 0.F && di.Y >= 0.F && dx.Y >= 0.F then
            let ddx = if di.X < dx.X then -di.X else dx.X
            let ddy = if di.Y < dx.Y then -di.Y else dx.Y
            if abs ddx < abs ddy then
              v2 (c.X + ddx) c.Y
            else
              v2 c.X (c.Y + ddy)
          else
            c
        else
          clamp2 c x.Min x.Max
      let ls  = (nc - c).LengthSquared ()
      // Faking friction
      if ls > epsilonSquared then
        let v   = nc - p.Previous
        let nv  = 0.9F * v
        p.Current   <- nc
        p.Previous  <- nc - nv

// Creates a global contraint
let mkGlobalConstraint v x0 y0 x1 y1 : GlobalConstraint =
  {
    Variant = v
    Min     = v2 (min x0 x1) (min y0 y1)
    Max     = v2 (max x0 x1) (max y0 y1)
  }

// Defines a rocket that fires either forward or reverse
//  depending on what keys are pressed
//  The rocket gets the same position as the particle it's connected
//  to and the rocket direction is computed with the help of the
//  anchor particle.
type Rocket =
  {
    Perpendicular : bool
    ConnectedTo   : Particle
    AnchoredTo    : Particle
    Force         : V1
    ForwardWhen   : Key       array
    ReverseWhen   : Key       array
  }

  member x.ForceVector (pressed : HashSet<Key>) =
    let forceVector () =
      // Compute the difference between the connected to
      //  and anchor particle. Normalize it ie make the length == 1
      let d = V2.Normalize (x.ConnectedTo.Current - x.AnchoredTo.Current)
        // the force vector
      if x.Perpendicular then
        // The rocket direction is perpendicular to the difference
        let n = v2 d.Y -d.X
        x.Force*n
      else
        // The rocket direction is tangential to the difference
        x.Force*d

    // Is any of the forward keys pressed?
    if isPressed pressed x.ForwardWhen 0 then
      forceVector ()
    // Is any of the reverse keys pressed?
    elif isPressed pressed x.ReverseWhen 0 then
      -forceVector ()
    // If neither then rocket is idle
    else
      v2_0

// Creates a rocket
let mkRocket
  perpendicular
  connectedTo
  anchoredTo
  force
  forwardWhen
  reverseWhen : Rocket =
  {
    Perpendicular = perpendicular
    ConnectedTo   = connectedTo
    AnchoredTo    = anchoredTo
    Force         = force
    ForwardWhen   = forwardWhen
    ReverseWhen   = reverseWhen
  }

// Creates a box of particles and constraints
let mkBox pc cc mass size x y vx vy : Particle array* Constraint array =
  let inline p x y = mkParticle pc (0.25F*mass) x y vx vy
  let hsz = 0.5F*size
  let p00 = p (x - hsz) (y - hsz)
  let p01 = p (x - hsz) (y + hsz)
  let p10 = p (x + hsz) (y - hsz)
  let p11 = p (x + hsz) (y + hsz)
  let ps = [|p00; p01; p11; p10|]
  let inline stick cc i j = mkStick cc ps.[i] ps.[j]
  let nc = noColor
  let cs =
    [|
      stick cc 0 1
      stick cc 1 2
      stick cc 2 3
      stick cc 3 0
      stick nc 0 2
      stick nc 1 3
    |]
  ps, cs

// The global constraint is a box that the particles has to stay within
let globalConstraints = 
  [|
    mkGlobalConstraint false -600.F -1000.F  600.F  400.F
    mkGlobalConstraint true  -480.F 401.F -380.F 0.F
    mkGlobalConstraint true  -300.F 401.F -200.F 0.F
  |]

let mkRocketShip off =
  let nc                            = noColor
  let pc                            = noColor
  let cc                            = Some Color.Yellow
  let topParticle                   = mkParticle pc 1.F   0.F  (-200.F + off)  0.F 0.F
  let bottomParticle                = mkParticle pc 20.F  0.F  (  85.F + off)  0.F 0.F
  let leftLegParticle               = mkParticle pc 1.F -85.F  ( 150.F + off)  0.F 0.F
  let rightLegParticle              = mkParticle pc 1.F  85.F  ( 150.F + off)  0.F 0.F
  let boxParticles, boxConstraints  = mkBox pc cc 20.F 100.F 0.F off 0.F 0.F

  let particles =
    [|
      topParticle
      leftLegParticle
      rightLegParticle
      bottomParticle
      yield! boxParticles
    |]

  let constraints =
    [|
      // Top
      mkStick   cc        topParticle       boxParticles.[0]
      mkStick   cc        topParticle       boxParticles.[3]

      // Rocket
      mkStick   nc        bottomParticle    topParticle
      mkStick   nc        bottomParticle    boxParticles.[1]
      mkStick   nc        bottomParticle    boxParticles.[2]

      // Left left
      mkStick    cc       leftLegParticle   boxParticles.[1]
      mkSpring   cc 4.F   leftLegParticle   bottomParticle
                     
      // Right left  
      mkStick    cc       rightLegParticle  boxParticles.[2]
      mkSpring   cc 4.F   rightLegParticle  bottomParticle

      yield! boxConstraints
    |]

  let rockets =
    [|
      // Add 2 rockets to the box ship
      mkRocket true  topParticle    bottomParticle   2.F    [|Key.Left|] [|Key.Right|]
      mkRocket false bottomParticle topParticle     -15.F   [|Key.Up|]   [||]
    |]

  bottomParticle, particles, constraints, rockets

let mkBoxShip off =
  let nc                            = noColor
  let pc                            = noColor
  let cc                            = Some Color.Yellow
  let boxParticles, boxConstraints  = mkBox pc cc 20.F 100.F 0.F 0.F 0.F 0.F
  let leftLegParticle               = mkParticle pc 1.F -55.F  ( 150.F + off)  0.F 0.F
  let rightLegParticle              = mkParticle pc 1.F  55.F  ( 150.F + off)  0.F 0.F
  let bottomParticle                = boxParticles.[1]

  let rot = Matrix3x2.CreateRotation (v1 (-Math.PI / 4.))
  let tra = Matrix3x2.CreateTranslation (v2 0.F (off - 50.F))
  let full= rot*tra
  for bp in boxParticles do
    bp.Current  <- V2.Transform (bp.Current , full)
    bp.Previous <- V2.Transform (bp.Previous, full)

  let particles =
    [|
      leftLegParticle
      rightLegParticle
      yield! boxParticles
    |]

  let constraints =
    [|
      // Left left
      mkStick    cc       leftLegParticle   boxParticles.[0]
      mkSpring   cc 4.F   leftLegParticle   bottomParticle
      // Right left  
      mkStick    cc       rightLegParticle  boxParticles.[2]
      mkSpring   cc 4.F   rightLegParticle  bottomParticle

      yield! boxConstraints
    |]

  let rockets =
    [|
      // Add 2 rockets to the box ship
      mkRocket true  boxParticles.[0]     boxParticles.[2] -5.F  [|Key.Up; Key.Right|]   [||]
      mkRocket true  boxParticles.[2]     boxParticles.[0]  5.F  [|Key.Up; Key.Left |]  [||]
    |]

  bottomParticle, particles, constraints, rockets

// Creates a small system of particles and constraints
let particles, constraints, rockets =
  let pc                            = noColor
  let cc                            = Some Color.Yellow
  let rc                            = Some Color.Gray
  let off                           = 250.F


  let shipConnectParticles, shipParticles, shipConstraints, shipRockets = mkBoxShip off

  let del0Particles, del0Constraints= mkBox pc cc 20.F 40.F 120.F (120.F + off) 0.F 0.F
  let del1Particles, del1Constraints= mkBox pc cc 20.F 40.F 240.F (120.F + off) 0.F 0.F

  let particles =
    [|
      yield! shipParticles
      yield! del0Particles
      yield! del1Particles
    |]

  let constraints =
    [|
      yield! shipConstraints
      mkRope rc 0.F   shipConnectParticles  del0Particles.[2]
      mkRope rc 0.F   del0Particles.[0]     del1Particles.[2]
      yield! del0Constraints
      yield! del1Constraints
    |]

  let rockets =
    [|
      yield! shipRockets
    |]

  particles, constraints, rockets

// Creates a CanvasElement class that will act like a canvas for us
//  We override the OnRender method to draw graphics. In order to make the graphics
//  animate we have a time animation that invalidates the element which forces a redraw
type CanvasElement () =
  class
    // This is how in F# we inherit, this is typically not done as much
    //  as in C# but in order to be part of WPF Visual tree we need to
    //  inherit UIElement
    inherit UIElement ()

    // Declaring a DependencyProperty member for Time
    //  This is WPF magic but it's created so that we can create
    //  an "animation" of the time value.
    //  This will help use do smooth updates.
    //  Nothing like web requestAnimationFrame in WPF AFAIK
    static let timeProperty =
      let pc = PropertyChangedCallback CanvasElement.TimePropertyChanged
      let md = PropertyMetadata (0., pc)
      DependencyProperty.Register ("Time", typeof<float>, typeof<CanvasElement>, md)

    // Freezing resources prevents updates of WPF Resources
    //  Can help WPF optimize rendering
    //  #Freezable is like C# constraint : where T : Freezable
    let freeze (f : #Freezable) =
      f.Freeze ()
      f

    // Helper function to create pens
    let makePen thickness brush =
      Pen (Thickness = thickness, Brush = brush) |> freeze

    // Help text
    let helpText = 
      FormattedText (   "Use arrow keys to fire rockets. Drive responsibly"
                      , CultureInfo.InvariantCulture
                      , FlowDirection.LeftToRight
                      , Typeface "Arial"
                      , 36.0
                      , Brushes.Gray
                      , 1.0
                      )

    // Some pens to draw lines with
    let pens        =
      [|
        Color.Gray  , Brushes.Gray
        Color.Green , Brushes.Green
        Color.Red   , Brushes.Red
        Color.White , Brushes.White
        Color.Yellow, Brushes.Yellow
      |]
      |> Array.map (fun (k, v) -> k, makePen 2. v)
      |> dict

    // Currently pressed key
    let mutable pressed = HashSet<Key>()

    // More WPF dependency property magic
    //  Not very interesting but this becomes member function in the class
    static member TimePropertyChanged (d : DependencyObject) (e : DependencyPropertyChangedEventArgs) =
      let g = d :?> CanvasElement
      // Whenever time change we invalidate the entire canvas element
      g.InvalidateVisual ()

    // Idiomatically WPF Dependency properties should be readonly
    //  static fields. However, F# don't allow us to declare that
    //  Luckily it seems static readonly properties works fine
    static member TimeProperty = timeProperty

    // Store pressed key
    override x.OnKeyDown e =
      pressed.Add e.Key |> ignore

    // Reset pressed key
    override x.OnKeyUp e =
      pressed.Remove e.Key |> ignore

    // Gets the Time dependency property
    member x.Time = x.GetValue CanvasElement.TimeProperty :?> float

    // Create an animation that animates a floating point from 0 to 1E9
    //  over 1E9 seconds thus the time. This animation is then hooked onto the Time property
    //  Basically more WPF magic
    member x.Start () =
      // Initial time value
      let b   = 0.
      // End time, application animation stops after approx 30 years
      let e   = 1E9
      let dur = Duration (TimeSpan.FromSeconds (e - b))
      let ani = DoubleAnimation (b, e, dur) |> freeze
      // Animating Time property
      x.BeginAnimation (CanvasElement.TimeProperty, ani);

    // Finally we get to the good stuff!
    //  dc is a DeviceContext, basically a canvas we can draw on
    override x.OnRender dc =
      // Get the current time, will change over time (hohoh)
      let time  = x.Time
      // This is the size of the canvas in pixels
      let rs    = x.RenderSize

      let center= v2 (0.5*rs.Width) (0.5*rs.Height)

      for _ = 1 to 1 do
        // Apply rocket force
        for r in rockets do
          let f = (r.ForceVector pressed)
          let p = r.ConnectedTo
          p.Current <- p.Current + f*p.InvertedMass

        // Apply the verlet step to all particles
        for p in particles do
          p.Step 0.1F

        // Relax all constraints 5 times
        //  If you relax less times the system becomes more "bouncy"
        //  More times makes it more "stiff"
        for _ = 1 to 5 do
          for gc in globalConstraints do
            gc.Relax particles
          for c in constraints do
            c.Relax ()

      // Draw the instructions
      dc.DrawText (helpText, new Point(0, 0))

      // inline here allows us to create helper function that
      //  uses a local variable without the overhead of creating
      //  a new function object
      //  Creating a bunch of objects during drawing can lead
      //  to GC which we like to avoid
      let inline toPoint (p : Particle) =
        let pos = p.Current + center
        Point (float pos.X, float pos.Y)

      // Draw all constraints
      for c in constraints do
        match c.Color with
        | None -> ()
        | Some cc -> 
          let pen = pens.[cc]
          dc.DrawLine (pen , toPoint c.Left, toPoint c.Right)

      // Draw all particles
      for p in particles do
        match p.Color with
        | None    -> ()
        | Some pc ->
          let r, b =
            if p.InvertedMass = 0.F then
              10., Brushes.White
            else
              let r = 3.F + p.SqrtMass |> float
              r, Brushes.Black
          dc.DrawEllipse (b, pens.[pc], toPoint p, r, r)

      // Shadowing the previous toPoint function is fine in F#
      let inline toPoint (p : V2) =
        let pos = p + center
        Point (float pos.X, float pos.Y)

      // Draw all rockets
      let forcePen = pens.[Color.Red]
      for r in rockets do
        let cto = r.ConnectedTo
        let c   = cto.Current
        let f   = -10.F*r.ForceVector pressed
        let pt0 = toPoint c
        let pt1 = toPoint (c + f)
        let pen = forcePen
        dc.DrawLine (pen, pt0, pt1)

      // Draws the Global Constraint (surrounding box)
      let globalPen0 = pens.[Color.Green]
      let globalPen1 = pens.[Color.Gray]
      for gc in globalConstraints do
        let p = if gc.Variant then globalPen1 else globalPen0
        dc.DrawRectangle (null, p, Rect(toPoint gc.Min, toPoint gc.Max))
  end

// Tells F# that this method is the main entry point
[<EntryPoint>]
// More 1990s magic! Basically in Windows there's a requirement that
//  UI controls runs in something called a Single Threaded Apartment.
//  So we tell .NET that the thread that calls main should be in a
//  Single Threaded Apartment.
//  Basically MS idea in 1990s on how to solve the problem of writing
//  multi threaded applications.
//  The .NET equivalent to apartments could be SynchronizationContext
[<STAThread>]
let main argv =
  // Sets up the main window
  let window  = Window (Title = "FsLanding", Background = Brushes.Black)
  // Creates our canvas
  let element = CanvasElement ()
  // Makes our canvas the content of the Window
  window.Content <- element
  // Make element focusable to be able to capture key strokes
  element.Focusable <- true
  element.Focus () |> ignore
  // Starts the time animation
  element.Start ()
  // Shows the Window
  window.ShowDialog () |> ignore
  0