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
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
|
{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, OverloadedRecordDot #-}
{- |
- Module : Game
- Description : runs game
- Copyright : 2025 Andromeda
- License : BSD 3-clause
- Maintainer : Matrix @Andromeda:tchncs.de
- Stability : Experimental
-}
module Game (main) where
import Game.Internal.Types
import Game.Internal
import Control.Lens ((^.))
import Data.IORef (newIORef)
import GHC.Float (double2Float)
import qualified Graphics.UI.GLFW as GLFW
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL as GL (($=))
import qualified Linear as L
import Linear ( V3(..), _y )
-- | Main function runs game
main :: IO ()
main = do
_ <- GLFW.init
GLFW.defaultWindowHints
-- OpenGL core >=3.3
GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3
GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3
GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
-- MSAA
GLFW.windowHint $ GLFW.WindowHint'Samples $ Just 8
-- create window
monitor <- GLFW.getPrimaryMonitor
Just window <- GLFW.createWindow 256 256 "hs-game" monitor Nothing
GLFW.makeContextCurrent $ Just window
-- add callbacks
GLFW.setWindowCloseCallback window $ Just shutdownWindow
GLFW.setWindowSizeCallback window $ Just resizeWindow
GLFW.setKeyCallback window $ Just (keyPressed Nothing)
GLFW.setCursorInputMode window GLFW.CursorInputMode'Hidden
GLFW.setCursorPosCallback window $ Just (cursorPosHandler Nothing)
(objects, program) <- initResources testVertices
-- init model
let
model =
mkModel
(mkCamera
(V3 0 0 3) -- camPos
0 -- pitch
0 -- yaw
(V3 0 0 (-1)) -- reference vector
(V3 0 0 0) -- velocity
2 -- mouse sensitivity
16 -- strafe strength
12 -- jump strength
)
objects
program
(mkWorldProperties
2
0.16
(V3 0 1 0)
)
modelRef <- newIORef model
-- add callbacks with io ref to model
GLFW.setKeyCallback window $ Just $ keyPressed $ Just modelRef
GLFW.setCursorPosCallback window $ Just $ cursorPosHandler $ Just modelRef
loop window 0 update view modelRef
--------------------------------------------------------------------------------
-- Arrays
--------------------------------------------------------------------------------
-- | centered unit square
testVertices :: [V3 GL.GLfloat]
testVertices =
[ V3 (-0.5) (-0.5) 0
, V3 0.5 (-0.5) 0
, V3 (-0.5) 0.5 0
, V3 0.5 0.5 0
]
--------------------------------------------------------------------------------
-- Elm-like data structures
--------------------------------------------------------------------------------
-- | update function
update :: Float -> Model -> Model
update dt model =
updateVelocity
dt
$ updateAcceleration
dt
$ updateCameraAngle
dt
model
updateAcceleration :: Float -> Model -> Model
updateAcceleration dt model =
let
zp = if elem GLFW.Key'S model.keys then 1 else 0
zn = if elem GLFW.Key'W model.keys then 1 else 0
xp = if elem GLFW.Key'D model.keys then 1 else 0
xn = if elem GLFW.Key'A model.keys then 1 else 0
x = xp - xn
z = zp - zn
friction = V3 (1 - model.wprop.friction) 1 (1 - model.wprop.friction)
movement = L.normalize (V3 x 0 z) L.^* (dt * model.camera.strafeStrength)
movement' = L.rotate (L.axisAngle model.wprop.up model.camera.camYaw) movement
jump =
if model.camera.hasJumped then
V3 0 (0 - model.wprop.g * model.camera.airTime) 0
else
V3 0 0 0
camVel' = friction * (model.camera.camVel + movement' + jump)
aboveGround = (model.camera.camPos + dt L.*^ camVel') ^. _y > 0
in
if
(elem GLFW.Key'Space model.keys)
&& (model.camera.hasJumped == False)
then
updateAcceleration dt $ model { camera = model.camera { airTime = dt, camVel = model.camera.camVel + (V3 0 model.camera.jumpStrength 0), hasJumped = True } }
else
if aboveGround then
model
{ camera = model.camera
{ airTime = model.camera.airTime + dt
, camVel = camVel'
, hasJumped = aboveGround
}
}
else
model
{ camera = model.camera
{ airTime = 0
, camVel = camVel' * (V3 1 0 1)
, camPos = model.camera.camPos * (V3 1 0 1)
, hasJumped = aboveGround
}
}
updateVelocity :: Float -> Model -> Model
updateVelocity dt model =
model
{ camera = model.camera
{ camPos = model.camera.camPos + dt L.*^ model.camera.camVel
}
}
updateCameraAngle :: Float -> Model -> Model
updateCameraAngle dt model =
let
scaleFactor = model.camera.mouseSensitivity * dt
newPitch = model.camera.camPitch -
scaleFactor * (double2Float $ snd model.cursorDeltaPos) -- mouse sensitivity, update pitch
newPitch' = if newPitch > 1.56 then 1.56 else newPitch
newPitch'' = if newPitch' < (-1.56) then (-1.56) else newPitch'
newYaw = model.camera.camYaw +
scaleFactor * (double2Float $ fst model.cursorDeltaPos)
in
model
{ cursorDeltaPos = (0, 0)
, camera = model.camera
{ camPitch = newPitch''
, camYaw = newYaw
}
}
-- | views the model
view :: GLFW.Window -> Model -> IO ()
view window model = do
-- fit viewport to window
(w, h) <- GLFW.getFramebufferSize window
GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
-- clear screen
GL.clearColor $= GL.Color4 1 0 1 1
GL.clear [GL.ColorBuffer, GL.DepthBuffer]
-- depth
GL.depthFunc $= Just GL.Less
-- apply transforms
let
pitch = model.camera.camPitch
yaw = model.camera.camYaw
forward = V3 (cos pitch * sin yaw) (sin pitch) (cos pitch * cos yaw)
viewMatrix =
L.lookAt
model.camera.camPos
(model.camera.camPos - forward)
model.wprop.up
projectionMatrix = L.perspective 1.5 (fromIntegral w / fromIntegral h) 0.01 10000
viewGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix viewMatrix :: IO (GL.GLmatrix GL.GLfloat)
viewLocation <- GL.get $ GL.uniformLocation model.program "u_view"
GL.uniform viewLocation $= viewGLMatrix
projectionGLMatrix <- GL.newMatrix GL.RowMajor $ toGLMatrix projectionMatrix :: IO (GL.GLmatrix GL.GLfloat)
projectionLocation <- GL.get $ GL.uniformLocation model.program "u_projection"
GL.uniform projectionLocation $= projectionGLMatrix
-- draw objects; returns IO []
_ <- drawObjects model.objects
-- swap to current buffer
GLFW.swapBuffers window
-- check for interrupts
GLFW.pollEvents
|
