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
|
module Djup.Program
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 =
{ PhysicsContext: nativeint
CurrentSnapshot: nativeint
PlayerId: int }
type Msg =
| PhysicsTick of float32
| Tick of GameTime
| 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 playerId = 0
match putPlayer playerId (Player()) with
| 0 -> ()
| errorCode -> failwithf "Failed to put player (error code %d)" errorCode
let model =
{ PhysicsContext = physics
CurrentSnapshot = snapshot
PlayerId = playerId }
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
| 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
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.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
|
