From 3870982f640260822bf605e693782ce9f5d79cf6 Mon Sep 17 00:00:00 2001 From: Joel Stålnacke Date: Fri, 20 Mar 2026 21:38:46 +0200 Subject: Get a player drawing on screen --- Djup/src/Djup.fsproj | 4 + Djup/src/Program.fs | 258 +++++++++++++++++++++++--------------------- Djup/src/packages.lock.json | 3 + 3 files changed, 142 insertions(+), 123 deletions(-) (limited to 'Djup/src') 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 @@ + + + + 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 -} - -// ───────────────────────────────────────────────────────────── -// 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 - -// ───────────────────────────────────────────────────────────── -// Init -// ───────────────────────────────────────────────────────────── - -let init(ctx: GameContext) : struct (Model * Cmd) = - 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 -let update (msg: Msg) (model: Model) : struct (Model * Cmd) = - 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) = + 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) = + 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) = - // 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 + [] 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(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(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" } } } -- cgit v1.2.3