Get a player drawing on screenHEADmibomaster

3 files changed, 142 insertions, 123 deletions

diff --git a/Djup/src/Djup.fsproj b/Djup/src/Djup.fsproj
index dad45e9..607589c 100644
--- a/Djup/src/Djup.fsproj
+++ b/Djup/src/Djup.fsproj
@@ -27,6 +27,10 @@
     <MonoGameContentReference Include="Content/Content.mgcb" />
   </ItemGroup>
 
+  <ItemGroup>
+    <ProjectReference Include="..\..\Djup.Native\src\Djup.Native.csproj" />
+  </ItemGroup>
+
   <Import Project="../../Djup.Native/scripts/AddRuntimeTargetsToDepsJson.targets" />
 
 </Project>
diff --git a/Djup/src/Program.fs b/Djup/src/Program.fs
index 2427252..45dea91 100644
--- a/Djup/src/Program.fs
+++ b/Djup/src/Program.fs
@@ -1,153 +1,165 @@
 module Djup.Program
 
-open System
+open FSharp.NativeInterop
 open Microsoft.Xna.Framework
 open Microsoft.Xna.Framework.Graphics
 open Microsoft.Xna.Framework.Input
 open Mibo.Elmish
 open Mibo.Elmish.Graphics2D
 open Mibo.Input
-
-// ─────────────────────────────────────────────────────────────
-// Input
-// ─────────────────────────────────────────────────────────────
+open Djup.Native
 
 type GameAction =
-  | MoveLeft
-  | MoveRight
-  | MoveUp
-  | MoveDown
+    | MoveLeft
+    | MoveRight
+    | MoveUp
+    | MoveDown
 
 let inputMap =
-  InputMap.empty
-  |> InputMap.key MoveLeft Keys.Left
-  |> InputMap.key MoveLeft Keys.A
-  |> InputMap.key MoveRight Keys.Right
-  |> InputMap.key MoveRight Keys.D
-  |> InputMap.key MoveUp Keys.Up
-  |> InputMap.key MoveUp Keys.W
-  |> InputMap.key MoveDown Keys.Down
-  |> InputMap.key MoveDown Keys.S
-
-// ─────────────────────────────────────────────────────────────
-// Model
-// ─────────────────────────────────────────────────────────────
-
-type Model = {
-  Position: Vector2
-  Velocity: Vector2
-  Input: ActionState<GameAction>
-}
-
-// ─────────────────────────────────────────────────────────────
-// Messages
-// ─────────────────────────────────────────────────────────────
+    InputMap.empty
+    |> InputMap.key MoveLeft Keys.Left
+    |> InputMap.key MoveLeft Keys.A
+    |> InputMap.key MoveRight Keys.Right
+    |> InputMap.key MoveRight Keys.D
+    |> InputMap.key MoveUp Keys.Up
+    |> InputMap.key MoveUp Keys.W
+    |> InputMap.key MoveDown Keys.Down
+    |> InputMap.key MoveDown Keys.S
+
+type Model =
+    { PhysicsContext: nativeint
+      CurrentSnapshot: nativeint
+      PlayerId: int }
 
 type Msg =
-  | Tick of GameTime
-  | InputChanged of ActionState<GameAction>
-
-// ─────────────────────────────────────────────────────────────
-// Init
-// ─────────────────────────────────────────────────────────────
-
-let init(ctx: GameContext) : struct (Model * Cmd<Msg>) =
-  let model = {
-    Position = Vector2(400.f, 300.f)
-    Velocity = Vector2(200.f, 150.f)
-    Input = ActionState.empty
-  }
-
-  model, Cmd.none
-
-// ─────────────────────────────────────────────────────────────
-// Update
-// ─────────────────────────────────────────────────────────────
+    | PhysicsTick of float32
+    | Tick of GameTime
+    | InputChanged of ActionState<GameAction>
 
-let update (msg: Msg) (model: Model) : struct (Model * Cmd<Msg>) =
-  match msg with
-  | InputChanged input -> { model with Input = input }, Cmd.none
-
-  | Tick gt ->
-    let dt = float32 gt.ElapsedGameTime.TotalSeconds
-
-    // Manual movement
-    let speed = 200.f
-    let mutable manualVelocity = Vector2.Zero
+let init (_: GameContext) : struct (Model * Cmd<Msg>) =
+    LibDjup.log_set_output (
+        LoggerDelegate(fun level source line message ->
+            let level =
+                match level with
+                | LogLevel.Trace -> "TRACE"
+                | LogLevel.Debug -> "DEBUG"
+                | LogLevel.Info -> "INFO "
+                | LogLevel.Warn -> "WARN "
+                | LogLevel.Error -> "ERROR"
+                | LogLevel.Fatal -> "FATAL"
+                | _ -> sprintf "UNKNOWN(%d)" (int level)
 
-    if model.Input.Held.Contains MoveLeft then
-      manualVelocity.X <- manualVelocity.X - speed
+            printfn "libdjup %s %s:%d: %s" level source line message)
+    )
 
-    if model.Input.Held.Contains MoveRight then
-      manualVelocity.X <- manualVelocity.X + speed
+    let physics = LibDjup.physics_context_create (2, 1, 1000)
 
-    if model.Input.Held.Contains MoveUp then
-      manualVelocity.Y <- manualVelocity.Y - speed
+    if physics = 0 then
+        failwith "Failed to allocate physics context"
 
-    if model.Input.Held.Contains MoveDown then
-      manualVelocity.Y <- manualVelocity.Y + speed
+    let snapshot = LibDjup.physics_context_get_snapshot physics
 
-    // Bouncing logic
-    let mutable velocity = model.Velocity
+    let putPlayer playerId player =
+        use ptr = fixed &player
+        LibDjup.snapshot_put_player (snapshot, playerId, ptr)
 
-    let mutable position =
-      model.Position + (velocity * dt) + (manualVelocity * dt)
+    let playerId = 0
 
-    if position.X < 0.f || position.X > 800.f - 32.f then
-      velocity.X <- -velocity.X
+    match putPlayer playerId (Player()) with
+    | 0 -> ()
+    | errorCode -> failwithf "Failed to put player (error code %d)" errorCode
 
-    if position.Y < 0.f || position.Y > 600.f - 32.f then
-      velocity.Y <- -velocity.Y
+    let model =
+        { PhysicsContext = physics
+          CurrentSnapshot = snapshot
+          PlayerId = playerId }
 
-    {
-      model with
-          Position = position
-          Velocity = velocity
-    },
-    Cmd.none
+    model, Cmd.none
 
-// ─────────────────────────────────────────────────────────────
-// View
-// ─────────────────────────────────────────────────────────────
+let update (msg: Msg) (model: Model) : struct (Model * Cmd<Msg>) =
+    match msg with
+    | PhysicsTick delta ->
+        let next = LibDjup.physics_context_get_snapshot model.PhysicsContext
+
+        match LibDjup.physics_tick (model.CurrentSnapshot, double delta, next) with
+        | 0 ->
+            LibDjup.physics_context_return_snapshot (model.PhysicsContext, model.CurrentSnapshot)
+            { model with CurrentSnapshot = next }, Cmd.none
+        | errorCode ->
+            printfn "Physics tick failed, code %d" errorCode
+            LibDjup.physics_context_return_snapshot (model.PhysicsContext, next)
+            model, Cmd.none
+    | InputChanged actionState ->
+        // TODO: Actions get applied for a long time, a small press causes the
+        // player to slide in the pressed direction for a while
+        let mutable input = 0uy
+        let isHeld action = actionState.Held.Contains action
+
+        if isHeld MoveUp then
+            input <- input ||| byte PlayerInput.Up
+
+        if isHeld MoveDown then
+            input <- input ||| byte PlayerInput.Down
+
+        if isHeld MoveLeft then
+            input <- input ||| byte PlayerInput.Left
+
+        if isHeld MoveRight then
+            input <- input ||| byte PlayerInput.Right
+
+        let ret =
+            LibDjup.snapshot_set_player_input (model.CurrentSnapshot, model.PlayerId, input)
+
+        match ret with
+        | 0 -> ()
+        | errorCode -> printfn "Failed to set player input (error code %d)" errorCode
+
+        model, Cmd.none
+    | Tick _ -> model, Cmd.none
 
 let view (ctx: GameContext) (model: Model) (buffer: RenderBuffer<RenderCmd2D>) =
-  // Draw player (using a 1x1 pixel texture if no asset loaded, or load one)
-  let pixel =
-    Assets.getOrCreate
-      "pixel"
-      (fun gd ->
-        let t = new Texture2D(gd, 1, 1)
-        t.SetData([| Color.White |])
-        t)
-      ctx
-
-  Draw2D.sprite
-    pixel
-    (Rectangle(int model.Position.X, int model.Position.Y, 32, 32))
-  |> Draw2D.withColor Color.Red
-  |> Draw2D.submit buffer
-
-// ─────────────────────────────────────────────────────────────
-// Program
-// ─────────────────────────────────────────────────────────────
+    // Draw player (using a 1x1 pixel texture if no asset loaded, or load one)
+    let pixel =
+        Assets.getOrCreate
+            "pixel"
+            (fun gd ->
+                let t = new Texture2D(gd, 1, 1)
+                t.SetData [| Color.White |]
+                t)
+            ctx
+
+    let snapshot: Snapshot =
+        let ptr = model.CurrentSnapshot |> NativePtr.ofNativeInt
+        NativePtr.get ptr 0
+
+    // TODO: Snapshot.Players should be active players
+    for p in snapshot.Players do
+        Draw2D.sprite pixel (Rectangle(int p.Position.X, int p.Position.Y, 32, 32))
+        |> Draw2D.withColor Color.Red
+        |> Draw2D.submit buffer
+
 
 [<EntryPoint>]
 let main _ =
-  let program =
-    Program.mkProgram init update
-    |> Program.withAssets
-    |> Program.withRenderer(fun g -> Batch2DRenderer.create g view)
-    |> Program.withInput
-    |> Program.withSubscription(fun ctx _ ->
-      InputMapper.subscribeStatic inputMap InputChanged ctx)
-    |> Program.withTick Tick
-    |> Program.withConfig(fun (game, graphics) ->
-      game.Content.RootDirectory <- "Content"
-      game.Window.Title <- "Mibo 2D Game"
-      game.IsMouseVisible <- true
-      graphics.PreferredBackBufferWidth <- 800
-      graphics.PreferredBackBufferHeight <- 600)
-
-  use game = new ElmishGame<Model, Msg>(program)
-  game.Run()
-  0
+    let program =
+        Program.mkProgram init update
+        |> Program.withAssets
+        |> Program.withRenderer (fun g -> Batch2DRenderer.create g view)
+        |> Program.withInput
+        |> Program.withSubscription (fun ctx _ -> InputMapper.subscribeStatic inputMap InputChanged ctx)
+        |> Program.withFixedStep
+            { StepSeconds = 1f / 60f
+              MaxStepsPerFrame = 5
+              MaxFrameSeconds = ValueNone
+              Map = PhysicsTick }
+        |> Program.withTick Tick
+        |> Program.withConfig (fun (game, graphics) ->
+            game.Content.RootDirectory <- "Content"
+            game.Window.Title <- "Djup"
+            game.IsMouseVisible <- true
+            graphics.PreferredBackBufferWidth <- 800
+            graphics.PreferredBackBufferHeight <- 600)
+
+    use game = new ElmishGame<Model, Msg>(program)
+    game.Run()
+    0
diff --git a/Djup/src/packages.lock.json b/Djup/src/packages.lock.json
index 64ca908..da5e725 100644
--- a/Djup/src/packages.lock.json
+++ b/Djup/src/packages.lock.json
@@ -66,6 +66,9 @@
         "type": "Transitive",
         "resolved": "0.10.4",
         "contentHash": "WYnil3DhQHzjCY0dM9I2B3r1vWip90AOuQd25KE4NrjPQBg0tBJFluRLm5YPnO5ZLDmwrfosY8jCQGQRmWI/Pg=="
+      },
+      "djup.native": {
+        "type": "Project"
       }
     }
   }