diff options
Diffstat (limited to 'Djup/src')
| -rw-r--r-- | Djup/src/Program.fs | 136 |
1 files changed, 71 insertions, 65 deletions
diff --git a/Djup/src/Program.fs b/Djup/src/Program.fs index 45dea91..c0c7e9f 100644 --- a/Djup/src/Program.fs +++ b/Djup/src/Program.fs @@ -1,5 +1,6 @@ module Djup.Program +open System open FSharp.NativeInterop open Microsoft.Xna.Framework open Microsoft.Xna.Framework.Graphics @@ -27,9 +28,11 @@ let inputMap = |> InputMap.key MoveDown Keys.S type Model = - { PhysicsContext: nativeint - CurrentSnapshot: nativeint - PlayerId: int } + { SimulationContext: nativeint + CurrentSnapshot: Snapshot nativeptr + PlayerId: EntityId + LogFunc: LoggerDelegate + AssertFunc: AssertDelegate } type Msg = | PhysicsTick of float32 @@ -37,82 +40,82 @@ type Msg = | InputChanged of ActionState<GameAction> 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) - - printfn "libdjup %s %s:%d: %s" level source line message) - ) - - let physics = LibDjup.physics_context_create (2, 1, 1000) - - if physics = 0 then - failwith "Failed to allocate physics context" - - let snapshot = LibDjup.physics_context_get_snapshot physics - - let putPlayer playerId player = - use ptr = fixed &player - LibDjup.snapshot_put_player (snapshot, playerId, ptr) + let ctx = LibDjup.sim_create (2, 1000) - let playerId = 0 + if ctx = 0 then + failwith "Failed to allocate physics context" - match putPlayer playerId (Player()) with - | 0 -> () - | errorCode -> failwithf "Failed to put player (error code %d)" errorCode + let logFunc = + LoggerDelegate( + fun level message procedure file line -> + let level = + match level with + | LogLevel.Debug -> "DEBUG" + | LogLevel.Info -> "INFO " + | LogLevel.Warn -> "WARN " + | LogLevel.Error -> "ERROR" + | LogLevel.Fatal -> "FATAL" + | _ -> sprintf "UNKNOWN(%d)" (int level) + + printfn "libdjup %s %O:%O:%d: %O" level procedure file line message) + let assertFunc = AssertDelegate( + fun prefix message procedure file line -> + printfn "libdjup ASSERT %O:%O:%d: %O %O" procedure file line prefix message + Environment.Exit 1) + + LibDjup.sim_log_init(ctx, logFunc, assertFunc) + + let snapshot = LibDjup.sim_get_snapshot ctx + + let playerId = + match LibDjup.snapshot_create_entity snapshot with + | id when id.IsInvalid -> failwith "Failed to create player" + | id -> id + + let ball = Ball() + use ptr = fixed &ball + LibDjup.snapshot_add_component(snapshot, playerId, Component.Ball, ptr |> NativePtr.toVoidPtr) + let playerInput = PlayerInput() + use ptr = fixed &playerInput + LibDjup.snapshot_add_component(snapshot, playerId, Component.PlayerInput, ptr |> NativePtr.toVoidPtr) let model = - { PhysicsContext = physics + { SimulationContext = ctx CurrentSnapshot = snapshot - PlayerId = playerId } + PlayerId = playerId + LogFunc = logFunc + AssertFunc = assertFunc } model, Cmd.none 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 + | PhysicsTick _ -> + let next = LibDjup.sim_get_snapshot model.SimulationContext + LibDjup.sim_tick (model.CurrentSnapshot, next) + LibDjup.sim_return_snapshot (model.SimulationContext, model.CurrentSnapshot) + { model with CurrentSnapshot = next }, 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 mutable input = Vec2() let isHeld action = actionState.Held.Contains action if isHeld MoveUp then - input <- input ||| byte PlayerInput.Up + input.Y <- input.Y - 1.0f if isHeld MoveDown then - input <- input ||| byte PlayerInput.Down + input.Y <- input.Y + 1.0f if isHeld MoveLeft then - input <- input ||| byte PlayerInput.Left + input.X <- input.X - 1.0f if isHeld MoveRight then - input <- input ||| byte PlayerInput.Right - - let ret = - LibDjup.snapshot_set_player_input (model.CurrentSnapshot, model.PlayerId, input) + input.X <- input.X + 1.0f - match ret with - | 0 -> () - | errorCode -> printfn "Failed to set player input (error code %d)" errorCode + let snapshot = NativePtr.toByRef model.CurrentSnapshot + let span = snapshot.PlayerInputs.AsSpan() + span[model.PlayerId].Direction <- input model, Cmd.none | Tick _ -> model, Cmd.none @@ -128,15 +131,18 @@ let view (ctx: GameContext) (model: Model) (buffer: RenderBuffer<RenderCmd2D>) = 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 snapshot = NativePtr.toByRef model.CurrentSnapshot + + let mask = Components.Exists ||| Components.Ball + let metadata = snapshot.Metadata.AsReadOnlySpan() + let balls = snapshot.Balls.AsReadOnlySpan() + for i = 0 to metadata.Length - 1 do + if metadata[i] &&& mask = mask then + let pos = balls[i].Position + printfn "%O: %O" (EntityId i) pos + Draw2D.sprite pixel (Rectangle(int pos.X, int pos.Y, 32, 32)) + |> Draw2D.withColor Color.Red + |> Draw2D.submit buffer [<EntryPoint>] |