1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
|
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
open Djup.Native
type GameAction =
| 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
type Model =
{ SimulationContext: nativeint
CurrentSnapshot: Snapshot nativeptr
PlayerId: EntityId
LogFunc: LoggerDelegate
AssertFunc: AssertDelegate }
type Msg =
| PhysicsTick of float32
| Tick of GameTime
| InputChanged of ActionState<GameAction>
let init (_: GameContext) : struct (Model * Cmd<Msg>) =
let ctx = LibDjup.sim_create (2, 1000)
if ctx = 0 then
failwith "Failed to allocate physics context"
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 =
{ SimulationContext = ctx
CurrentSnapshot = snapshot
PlayerId = playerId
LogFunc = logFunc
AssertFunc = assertFunc }
model, Cmd.none
let update (msg: Msg) (model: Model) : struct (Model * Cmd<Msg>) =
match msg with
| 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 = Vec2()
let isHeld action = actionState.Held.Contains action
if isHeld MoveUp then
input.Y <- input.Y - 1.0f
if isHeld MoveDown then
input.Y <- input.Y + 1.0f
if isHeld MoveLeft then
input.X <- input.X - 1.0f
if isHeld MoveRight then
input.X <- input.X + 1.0f
let snapshot = NativePtr.toByRef model.CurrentSnapshot
let span = snapshot.PlayerInputs.AsSpan()
span[model.PlayerId].Direction <- input
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
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>]
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.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
|
