aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
author3gg <3gg@shellblade.net>2022-09-17 17:46:27 -0700
committer3gg <3gg@shellblade.net>2022-09-17 17:46:27 -0700
commit8f2ec33e8c15e523b2b60d3bfd8e6360313a0657 (patch)
tree842ebba3752e32fccca644bb44f5c0ea8eb56ad9
parent4ce19dca3441d1e079a66e2f3dc55b77a7f0898f (diff)
2020s update
Diffstat
-rw-r--r--.gitignore1
-rw-r--r--Spear.cabal32
-rw-r--r--Spear/GL.hs827
-rw-r--r--Spear/Game.hs111
-rw-r--r--Spear/Render/AnimatedModel.hs287
-rw-r--r--Spear/Render/StaticModel.hs146
-rw-r--r--Spear/Scene/Loader.hs457
-rw-r--r--Spear/Step.hs201
-rw-r--r--Spear/Sys/Timer.hsc52
-rw-r--r--Spear/Window.hs710
-rw-r--r--demos/pong/Main.hs99
-rw-r--r--demos/pong/Pong.hs125
-rw-r--r--demos/pong/Setup.hs1
-rw-r--r--demos/pong/cabal.project2
-rw-r--r--demos/pong/pong.cabal12
15 files changed, 1635 insertions, 1428 deletions
diff --git a/.gitignore b/.gitignore
index 8d5c25e..726ea43 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,4 @@
1demos/pong/dist/ 1demos/pong/dist/
2demos/pong/pong 2demos/pong/pong
3dist/ 3dist/
4dist-newstyle/
diff --git a/Spear.cabal b/Spear.cabal
index a19d89f..4c75dd8 100644
--- a/Spear.cabal
+++ b/Spear.cabal
@@ -4,7 +4,7 @@ cabal-version: >=1.2
4build-type: Simple 4build-type: Simple
5license: BSD3 5license: BSD3
6license-file: LICENSE 6license-file: LICENSE
7maintainer: jeannekamikaze@gmail.com 7maintainer: 3gg@shellblade.net
8homepage: http://spear.shellblade.net 8homepage: http://spear.shellblade.net
9synopsis: A 2.5D game framework. 9synopsis: A 2.5D game framework.
10category: Game 10category: Game
@@ -12,13 +12,14 @@ author: Marc Sunet
12data-dir: "" 12data-dir: ""
13 13
14library 14library
15 build-depends: GLFW -any, 15 build-depends: GLFW-b -any,
16 OpenGL -any, 16 OpenGL >= 3,
17 OpenGLRaw -any, 17 OpenGLRaw -any,
18 StateVar -any, 18 StateVar -any,
19 base -any, 19 base -any,
20 bytestring -any, 20 bytestring -any,
21 directory -any, 21 directory -any,
22 exceptions -any,
22 mtl -any, 23 mtl -any,
23 transformers -any, 24 transformers -any,
24 resourcet -any, 25 resourcet -any,
@@ -46,6 +47,7 @@ library
46 Spear.Math.Segment 47 Spear.Math.Segment
47 Spear.Math.Spatial2 48 Spear.Math.Spatial2
48 Spear.Math.Spatial3 49 Spear.Math.Spatial3
50 Spear.Math.Sphere
49 Spear.Math.Triangle 51 Spear.Math.Triangle
50 Spear.Math.Utils 52 Spear.Math.Utils
51 Spear.Math.Vector 53 Spear.Math.Vector
@@ -87,18 +89,28 @@ library
87 extensions: TypeFamilies 89 extensions: TypeFamilies
88 90
89 includes: Spear/Assets/Image/BMP/BMP_load.h 91 includes: Spear/Assets/Image/BMP/BMP_load.h
90 Spear/Assets/Image/Image.h Spear/Assets/Image/Image_error_code.h 92 Spear/Assets/Image/Image.h
91 Spear/Assets/Image/sys_types.h Spear/Assets/Model/MD2/MD2_load.h 93 Spear/Assets/Image/Image_error_code.h
92 Spear/Assets/Model/OBJ/OBJ_load.h Spear/Assets/Model/OBJ/cvector.h 94 Spear/Assets/Image/sys_types.h
93 Spear/Assets/Model/Model.h Spear/Assets/Model/Model_error_code.h 95 Spear/Assets/Model/MD2/MD2_load.h
94 Spear/Assets/Model/sys_types.h Spear/Render/RenderModel.h 96 Spear/Assets/Model/OBJ/OBJ_load.h
97 Spear/Assets/Model/OBJ/cvector.h
98 Spear/Assets/Model/Model.h
99 Spear/Assets/Model/Model_error_code.h
100 Spear/Assets/Model/sys_types.h
101 Spear/Render/RenderModel.h
95 Timer/Timer.h 102 Timer/Timer.h
96 103
97 include-dirs: Spear/Assets/Image Spear/Assets/Model Spear/Render 104 include-dirs: .
105 Spear
106 Spear/Assets/Image
107 Spear/Assets/Image/BMP
108 Spear/Assets/Model
109 Spear/Render
98 Spear/Sys 110 Spear/Sys
99 111
100 hs-source-dirs: . 112 hs-source-dirs: .
101 113
102 ghc-options: -O2 114 ghc-options: -O2
103 115
104 ghc-prof-options: -O2 -rtsopts -fprof-auto -fprof-cafs 116 ghc-prof-options: -O2 -fprof-auto -fprof-cafs
diff --git a/Spear/GL.hs b/Spear/GL.hs
index f5cfe4e..21ed9ec 100644
--- a/Spear/GL.hs
+++ b/Spear/GL.hs
@@ -1,101 +1,112 @@
1{-# LANGUAGE FlexibleInstances #-} 1{-# LANGUAGE FlexibleInstances #-}
2
2module Spear.GL 3module Spear.GL
3( 4 ( -- * Programs
4 -- * Programs 5 GLSLProgram,
5 GLSLProgram 6 newProgram,
6, newProgram 7 linkProgram,
7, linkProgram 8 useProgram,
8, useProgram 9 unuseProgram,
9, unuseProgram 10 withGLSLProgram,
10, withGLSLProgram 11
11 -- ** Locations 12 -- ** Locations
12, attribLocation 13 attribLocation,
13, fragLocation 14 fragLocation,
14, uniformLocation 15 uniformLocation,
16
15 -- ** Uniforms 17 -- ** Uniforms
16, Uniform(..) 18 Uniform (..),
19
17 -- * Shaders 20 -- * Shaders
18, GLSLShader 21 GLSLShader,
19, ShaderType(..) 22 ShaderType (..),
20, attachShader 23 attachShader,
21, detachShader 24 detachShader,
22, loadShader 25 loadShader,
23, newShader 26 newShader,
27
24 -- ** Source loading 28 -- ** Source loading
25, loadSource 29 loadSource,
26, shaderSource 30 shaderSource,
27, readSource 31 readSource,
28, compile 32 compile,
33
29 -- * Helper functions 34 -- * Helper functions
30, ($=) 35 ($=),
31, Data.StateVar.get 36 Data.StateVar.get,
37
32 -- * VAOs 38 -- * VAOs
33, VAO 39 VAO,
34, newVAO 40 newVAO,
35, bindVAO 41 bindVAO,
36, unbindVAO 42 unbindVAO,
37, enableVAOAttrib 43 enableVAOAttrib,
38, attribVAOPointer 44 attribVAOPointer,
45
39 -- ** Rendering 46 -- ** Rendering
40, drawArrays 47 drawArrays,
41, drawElements 48 drawElements,
49
42 -- * Buffers 50 -- * Buffers
43, GLBuffer 51 GLBuffer,
44, TargetBuffer(..) 52 TargetBuffer (..),
45, BufferUsage(..) 53 BufferUsage (..),
46, newBuffer 54 newBuffer,
47, bindBuffer 55 bindBuffer,
48, unbindBuffer 56 unbindBuffer,
49, BufferData(..) 57 BufferData (..),
50, bufferData' 58 bufferData',
51, withGLBuffer 59 withGLBuffer,
60
52 -- * Textures 61 -- * Textures
53, Texture 62 Texture,
54, SettableStateVar 63 SettableStateVar,
55, ($) 64 ($),
65
56 -- ** Creation and destruction 66 -- ** Creation and destruction
57, newTexture 67 newTexture,
58, loadTextureImage 68 loadTextureImage,
69
59 -- ** Manipulation 70 -- ** Manipulation
60, bindTexture 71 bindTexture,
61, unbindTexture 72 unbindTexture,
62, loadTextureData 73 loadTextureData,
63, texParami 74 texParami,
64, texParamf 75 texParamf,
65, activeTexture 76 activeTexture,
77
66 -- * Error Handling 78 -- * Error Handling
67, getGLError 79 getGLError,
68, printGLError 80 printGLError,
69, assertGL 81 assertGL,
82
70 -- * OpenGL 83 -- * OpenGL
71, module Graphics.Rendering.OpenGL.Raw.Core32 84 module Graphics.GL.Core46,
72, Ptr 85 Ptr,
73, nullPtr 86 nullPtr,
74) 87 )
75where 88where
76 89
77import Spear.Assets.Image
78import Spear.Game
79import Spear.Math.Matrix3 (Matrix3)
80import Spear.Math.Matrix4 (Matrix4)
81import Spear.Math.Vector
82
83import Control.Monad 90import Control.Monad
84import Control.Monad.Trans.Class 91import Control.Monad.Trans.Class
85import Control.Monad.Trans.Error
86import Control.Monad.Trans.State as State 92import Control.Monad.Trans.State as State
87import qualified Data.ByteString.Char8 as B 93import qualified Data.ByteString.Char8 as B
88import Data.StateVar 94import Data.StateVar
89import Data.Word 95import Data.Word
90import Foreign.C.String 96import Foreign.C.String
91import Foreign.C.Types 97import Foreign.C.Types
92import Foreign.Ptr
93import Foreign.Storable
94import Foreign.Marshal.Utils as Foreign (with)
95import Foreign.Marshal.Alloc (alloca) 98import Foreign.Marshal.Alloc (alloca)
96import Foreign.Marshal.Array (withArray) 99import Foreign.Marshal.Array (withArray)
100import Foreign.Marshal.Utils as Foreign (with)
101import Foreign.Ptr
102import Foreign.Storable
97import Foreign.Storable (peek) 103import Foreign.Storable (peek)
98import Graphics.Rendering.OpenGL.Raw.Core32 104import Graphics.GL.Core46
105import Spear.Assets.Image
106import Spear.Game
107import Spear.Math.Matrix3 (Matrix3)
108import Spear.Math.Matrix4 (Matrix4)
109import Spear.Math.Vector
99import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory) 110import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory)
100import System.IO (hPutStrLn, stderr) 111import System.IO (hPutStrLn, stderr)
101import Unsafe.Coerce 112import Unsafe.Coerce
@@ -105,30 +116,30 @@ import Unsafe.Coerce
105-- 116--
106 117
107-- | A GLSL shader handle. 118-- | A GLSL shader handle.
108data GLSLShader = GLSLShader 119data GLSLShader = GLSLShader
109 { getShader :: GLuint 120 { getShader :: GLuint,
110 , getShaderKey :: Resource 121 getShaderKey :: Resource
111 } 122 }
112 123
113instance ResourceClass GLSLShader where 124instance ResourceClass GLSLShader where
114 getResource = getShaderKey 125 getResource = getShaderKey
115 126
116-- | A GLSL program handle. 127-- | A GLSL program handle.
117data GLSLProgram = GLSLProgram 128data GLSLProgram = GLSLProgram
118 { getProgram :: GLuint 129 { getProgram :: GLuint,
119 , getProgramKey :: Resource 130 getProgramKey :: Resource
120 } 131 }
121 132
122instance ResourceClass GLSLProgram where 133instance ResourceClass GLSLProgram where
123 getResource = getProgramKey 134 getResource = getProgramKey
124 135
125-- | Supported shader types. 136-- | Supported shader types.
126data ShaderType = VertexShader | FragmentShader | GeometryShader deriving (Eq, Show) 137data ShaderType = VertexShader | FragmentShader | GeometryShader deriving (Eq, Show)
127 138
128toGLShader :: ShaderType -> GLenum 139toGLShader :: ShaderType -> GLenum
129toGLShader VertexShader = gl_VERTEX_SHADER 140toGLShader VertexShader = GL_VERTEX_SHADER
130toGLShader FragmentShader = gl_FRAGMENT_SHADER 141toGLShader FragmentShader = GL_FRAGMENT_SHADER
131toGLShader GeometryShader = gl_GEOMETRY_SHADER 142toGLShader GeometryShader = GL_GEOMETRY_SHADER
132 143
133-- | Apply the given function to the program's id. 144-- | Apply the given function to the program's id.
134withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a 145withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a
@@ -137,58 +148,58 @@ withGLSLProgram prog f = f $ getProgram prog
137-- | Get the location of the given uniform variable within the given program. 148-- | Get the location of the given uniform variable within the given program.
138uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint 149uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint
139uniformLocation prog var = makeGettableStateVar $ 150uniformLocation prog var = makeGettableStateVar $
140 withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str) 151 withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str)
141 152
142-- | Get or set the location of the given variable to a fragment shader colour number. 153-- | Get or set the location of the given variable to a fragment shader colour number.
143fragLocation :: GLSLProgram -> String -> StateVar GLint 154fragLocation :: GLSLProgram -> String -> StateVar GLint
144fragLocation prog var = makeStateVar get set 155fragLocation prog var = makeStateVar get set
145 where 156 where
146 get = withCString var $ \str -> glGetFragDataLocation (getProgram prog) (unsafeCoerce str) 157 get = withCString var $ \str -> glGetFragDataLocation (getProgram prog) (unsafeCoerce str)
147 set idx = withCString var $ \str -> 158 set idx = withCString var $ \str ->
148 glBindFragDataLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str) 159 glBindFragDataLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str)
149 160
150-- | Get or set the location of the given attribute within the given program. 161-- | Get or set the location of the given attribute within the given program.
151attribLocation :: GLSLProgram -> String -> StateVar GLint 162attribLocation :: GLSLProgram -> String -> StateVar GLint
152attribLocation prog var = makeStateVar get set 163attribLocation prog var = makeStateVar get set
153 where 164 where
154 get = withCString var $ \str -> glGetAttribLocation (getProgram prog) (unsafeCoerce str) 165 get = withCString var $ \str -> glGetAttribLocation (getProgram prog) (unsafeCoerce str)
155 set idx = withCString var $ \str -> 166 set idx = withCString var $ \str ->
156 glBindAttribLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str) 167 glBindAttribLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str)
157 168
158-- | Create a new program. 169-- | Create a new program.
159newProgram :: [GLSLShader] -> Game s GLSLProgram 170newProgram :: [GLSLShader] -> Game s GLSLProgram
160newProgram shaders = do 171newProgram shaders = do
161 h <- gameIO glCreateProgram 172 h <- gameIO glCreateProgram
162 when (h == 0) $ gameError "glCreateProgram failed" 173 when (h == 0) $ gameError "glCreateProgram failed"
163 rkey <- register $ deleteProgram h 174 rkey <- register $ deleteProgram h
164 let program = GLSLProgram h rkey 175 let program = GLSLProgram h rkey
165 mapM_ (gameIO . attachShader program) shaders 176 mapM_ (gameIO . attachShader program) shaders
166 linkProgram program 177 linkProgram program
167 return program 178 return program
168 179
169-- Delete the program. 180-- Delete the program.
170deleteProgram :: GLuint -> IO () 181deleteProgram :: GLuint -> IO ()
171--deleteProgram = glDeleteProgram 182--deleteProgram = glDeleteProgram
172deleteProgram prog = do 183deleteProgram prog = do
173 putStrLn $ "Deleting shader program " ++ show prog 184 putStrLn $ "Deleting shader program " ++ show prog
174 glDeleteProgram prog 185 glDeleteProgram prog
175 186
176-- | Link the program. 187-- | Link the program.
177linkProgram :: GLSLProgram -> Game s () 188linkProgram :: GLSLProgram -> Game s ()
178linkProgram prog = do 189linkProgram prog = do
179 let h = getProgram prog 190 let h = getProgram prog
180 err <- gameIO $ do 191 err <- gameIO $ do
181 glLinkProgram h 192 glLinkProgram h
182 alloca $ \statptr -> do 193 alloca $ \statptr -> do
183 glGetProgramiv h gl_LINK_STATUS statptr 194 glGetProgramiv h GL_LINK_STATUS statptr
184 status <- peek statptr 195 status <- peek statptr
185 case status of 196 case status of
186 0 -> getStatus glGetProgramiv glGetProgramInfoLog h 197 0 -> getStatus glGetProgramiv glGetProgramInfoLog h
187 _ -> return "" 198 _ -> return ""
188 199
189 case length err of 200 case length err of
190 0 -> return () 201 0 -> return ()
191 _ -> gameError err 202 _ -> gameError err
192 203
193-- | Use the program. 204-- | Use the program.
194useProgram :: GLSLProgram -> IO () 205useProgram :: GLSLProgram -> IO ()
@@ -212,82 +223,84 @@ detachShader prog shader = glDetachShader (getProgram prog) (getShader shader)
212-- see 'loadSource', 'shaderSource' and 'readSource'. 223-- see 'loadSource', 'shaderSource' and 'readSource'.
213loadShader :: ShaderType -> FilePath -> Game s GLSLShader 224loadShader :: ShaderType -> FilePath -> Game s GLSLShader
214loadShader shaderType file = do 225loadShader shaderType file = do
215 shader <- newShader shaderType 226 shader <- newShader shaderType
216 loadSource file shader 227 loadSource file shader
217 compile file shader 228 compile file shader
218 return shader 229 return shader
219 230
220-- | Create a new shader. 231-- | Create a new shader.
221newShader :: ShaderType -> Game s GLSLShader 232newShader :: ShaderType -> Game s GLSLShader
222newShader shaderType = do 233newShader shaderType = do
223 h <- gameIO $ glCreateShader (toGLShader shaderType) 234 h <- gameIO $ glCreateShader (toGLShader shaderType)
224 case h of 235 case h of
225 0 -> gameError "glCreateShader failed" 236 0 -> gameError "glCreateShader failed"
226 _ -> do 237 _ -> do
227 rkey <- register $ deleteShader h 238 rkey <- register $ deleteShader h
228 return $ GLSLShader h rkey 239 return $ GLSLShader h rkey
229 240
230-- | Free the shader. 241-- | Free the shader.
231deleteShader :: GLuint -> IO () 242deleteShader :: GLuint -> IO ()
232--deleteShader = glDeleteShader 243--deleteShader = glDeleteShader
233deleteShader shader = do 244deleteShader shader = do
234 putStrLn $ "Deleting shader " ++ show shader 245 putStrLn $ "Deleting shader " ++ show shader
235 glDeleteShader shader 246 glDeleteShader shader
236 247
237-- | Load a shader source from the file specified by the given string 248-- | Load a shader source from the file specified by the given string
238-- into the shader. 249-- into the shader.
239loadSource :: FilePath -> GLSLShader -> Game s () 250loadSource :: FilePath -> GLSLShader -> Game s ()
240loadSource file h = do 251loadSource file h = do
241 exists <- gameIO $ doesFileExist file 252 exists <- gameIO $ doesFileExist file
242 case exists of 253 case exists of
243 False -> gameError "the specified shader file does not exist" 254 False -> gameError "the specified shader file does not exist"
244 True -> gameIO $ do 255 True -> gameIO $ do
245 code <- readSource file 256 code <- readSource file
246 withCString code $ shaderSource h 257 withCString code $ shaderSource h
247 258
248-- | Load the given shader source into the shader. 259-- | Load the given shader source into the shader.
249shaderSource :: GLSLShader -> CString -> IO () 260shaderSource :: GLSLShader -> CString -> IO ()
250shaderSource shader str = 261shaderSource shader str =
251 let ptr = unsafeCoerce str 262 let ptr = unsafeCoerce str
252 in withArray [ptr] $ flip (glShaderSource (getShader shader) 1) nullPtr 263 in withArray [ptr] $ flip (glShaderSource (getShader shader) 1) nullPtr
253 264
254-- | Compile the shader. 265-- | Compile the shader.
255compile :: FilePath -> GLSLShader -> Game s () 266compile :: FilePath -> GLSLShader -> Game s ()
256compile file shader = do 267compile file shader = do
257 let h = getShader shader 268 let h = getShader shader
258 269
259 -- Compile 270 -- Compile
260 gameIO $ glCompileShader h 271 gameIO $ glCompileShader h
261 272
262 -- Verify status 273 -- Verify status
263 err <- gameIO $ alloca $ \statusPtr -> do 274 err <- gameIO $
264 glGetShaderiv h gl_COMPILE_STATUS statusPtr 275 alloca $ \statusPtr -> do
265 result <- peek statusPtr 276 glGetShaderiv h GL_COMPILE_STATUS statusPtr
266 case result of 277 result <- peek statusPtr
267 0 -> getStatus glGetShaderiv glGetShaderInfoLog h 278 case result of
268 _ -> return "" 279 0 -> getStatus glGetShaderiv glGetShaderInfoLog h
280 _ -> return ""
269 281
270 case length err of 282 case length err of
271 0 -> return () 283 0 -> return ()
272 _ -> gameError $ "Unable to compile shader " ++ file ++ ":\n" ++ err 284 _ -> gameError $ "Unable to compile shader " ++ file ++ ":\n" ++ err
273 285
274type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO () 286type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO ()
275type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO () 287
288type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO ()
276 289
277getStatus :: StatusCall -> LogCall -> GLuint -> IO String 290getStatus :: StatusCall -> LogCall -> GLuint -> IO String
278getStatus getStatus getLog h = do 291getStatus getStatus getLog h = do
279 alloca $ \lenPtr -> do 292 alloca $ \lenPtr -> do
280 getStatus h gl_INFO_LOG_LENGTH lenPtr 293 getStatus h GL_INFO_LOG_LENGTH lenPtr
281 len <- peek lenPtr 294 len <- peek lenPtr
282 case len of 295 case len of
283 0 -> return "" 296 0 -> return ""
284 _ -> withCString (replicate (unsafeCoerce len) '\0') $ getErrorString getLog h (unsafeCoerce len) 297 _ -> withCString (replicate (unsafeCoerce len) '\0') $ getErrorString getLog h (unsafeCoerce len)
285 298
286getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String 299getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String
287getErrorString getLog h len str = do 300getErrorString getLog h len str = do
288 let ptr = unsafeCoerce str 301 let ptr = unsafeCoerce str
289 getLog h len nullPtr ptr 302 getLog h len nullPtr ptr
290 peekCString str 303 peekCString str
291 304
292-- | Load the shader source specified by the given file. 305-- | Load the shader source specified by the given file.
293-- 306--
@@ -298,110 +311,121 @@ readSource = fmap B.unpack . readSource'
298 311
299readSource' :: FilePath -> IO B.ByteString 312readSource' :: FilePath -> IO B.ByteString
300readSource' file = do 313readSource' file = do
301 let includeB = B.pack "#include" 314 let includeB = B.pack "#include"
302 newLineB = B.pack "\n" 315 newLineB = B.pack "\n"
303 isInclude = ((==) includeB) . B.take 8 316 isInclude = ((==) includeB) . B.take 8
304 clean = B.dropWhile (\c -> c == ' ') 317 clean = B.dropWhile (\c -> c == ' ')
305 cleanInclude = B.filter (\c -> c /= '"') . B.dropWhile (\c -> c /= ' ') 318 cleanInclude = B.filter (\c -> c /= '"') . B.dropWhile (\c -> c /= ' ')
306 toLines = B.splitWith (\c -> c == '\n' || c == '\r') 319 toLines = B.splitWith (\c -> c == '\n' || c == '\r')
307 addNewLine s = if (B.last s /= '\n') then B.append s newLineB else s 320 addNewLine s = if (B.last s /= '\n') then B.append s newLineB else s
308 parse = fmap B.concat . (fmap . fmap $ flip B.append newLineB) . sequence . 321 parse =
309 fmap (processLine . clean) . toLines 322 fmap B.concat . (fmap . fmap $ flip B.append newLineB) . sequence
310 processLine l = 323 . fmap (processLine . clean)
311 if isInclude l 324 . toLines
312 then readSource' $ B.unpack . clean . cleanInclude $ l 325 processLine l =
313 else return l 326 if isInclude l
314 327 then readSource' $ B.unpack . clean . cleanInclude $ l
315 contents <- B.readFile file 328 else return l
316 329
317 dir <- getCurrentDirectory 330 contents <- B.readFile file
318 let dir' = dir ++ "/" ++ (reverse . dropWhile (\c -> c /= '/') . reverse) file 331
319 332 dir <- getCurrentDirectory
320 setCurrentDirectory dir' 333 let dir' = dir ++ "/" ++ (reverse . dropWhile (\c -> c /= '/') . reverse) file
321 code <- parse contents 334
322 setCurrentDirectory dir 335 setCurrentDirectory dir'
323 336 code <- parse contents
324 return code 337 setCurrentDirectory dir
338
339 return code
325 340
326class Uniform a where 341class Uniform a where
327 -- | Load a list of uniform values. 342 -- | Load a list of uniform values.
328 uniform :: GLint -> a -> IO () 343 uniform :: GLint -> a -> IO ()
329 344
330instance Uniform Int where uniform loc a = glUniform1i loc (fromIntegral a) 345instance Uniform Int where uniform loc a = glUniform1i loc (fromIntegral a)
331instance Uniform Float where uniform loc a = glUniform1f loc (unsafeCoerce a)
332instance Uniform CFloat where uniform loc a = glUniform1f loc a
333 346
334instance Uniform (Int,Int) where 347instance Uniform Float where uniform loc a = glUniform1f loc a
335 uniform loc (x,y) = glUniform2i loc (fromIntegral x) (fromIntegral y)
336 348
337instance Uniform (Float,Float) where 349instance Uniform CFloat where uniform loc a = glUniform1f loc (unsafeCoerce a)
338 uniform loc (x,y) = glUniform2f loc (unsafeCoerce x) (unsafeCoerce y)
339 350
340instance Uniform (Int,Int,Int) where 351instance Uniform (Int, Int) where
341 uniform loc (x,y,z) = glUniform3i loc (fromIntegral x) (fromIntegral y) (fromIntegral z) 352 uniform loc (x, y) = glUniform2i loc (fromIntegral x) (fromIntegral y)
342 353
343instance Uniform (Float,Float,Float) where 354instance Uniform (Float, Float) where
344 uniform loc (x,y,z) = glUniform3f loc (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z) 355 uniform loc (x, y) = glUniform2f loc x y
345 356
346instance Uniform (Int,Int,Int,Int) where 357instance Uniform (Int, Int, Int) where
347 uniform loc (x,y,z,w) = glUniform4i loc 358 uniform loc (x, y, z) = glUniform3i loc (fromIntegral x) (fromIntegral y) (fromIntegral z)
348 (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w)
349 359
350instance Uniform (Float,Float,Float,Float) where 360instance Uniform (Float, Float, Float) where
351 uniform loc (x,y,z,w) = glUniform4f loc 361 uniform loc (x, y, z) = glUniform3f loc x y z
352 (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z) (unsafeCoerce w) 362
363instance Uniform (Int, Int, Int, Int) where
364 uniform loc (x, y, z, w) =
365 glUniform4i
366 loc
367 (fromIntegral x)
368 (fromIntegral y)
369 (fromIntegral z)
370 (fromIntegral w)
371
372instance Uniform (Float, Float, Float, Float) where
373 uniform loc (x, y, z, w) = glUniform4f loc x y z w
353 374
354instance Uniform Vector2 where 375instance Uniform Vector2 where
355 uniform loc v = glUniform2f loc x' y' 376 uniform loc v = glUniform2f loc x' y'
356 where x' = unsafeCoerce $ x v 377 where
357 y' = unsafeCoerce $ y v 378 x' = unsafeCoerce $ x v
379 y' = unsafeCoerce $ y v
358 380
359instance Uniform Vector3 where 381instance Uniform Vector3 where
360 uniform loc v = glUniform3f loc x' y' z' 382 uniform loc v = glUniform3f loc x' y' z'
361 where x' = unsafeCoerce $ x v 383 where
362 y' = unsafeCoerce $ y v 384 x' = unsafeCoerce $ x v
363 z' = unsafeCoerce $ z v 385 y' = unsafeCoerce $ y v
386 z' = unsafeCoerce $ z v
364 387
365instance Uniform Vector4 where 388instance Uniform Vector4 where
366 uniform loc v = glUniform4f loc x' y' z' w' 389 uniform loc v = glUniform4f loc x' y' z' w'
367 where x' = unsafeCoerce $ x v 390 where
368 y' = unsafeCoerce $ y v 391 x' = unsafeCoerce $ x v
369 z' = unsafeCoerce $ z v 392 y' = unsafeCoerce $ y v
370 w' = unsafeCoerce $ w v 393 z' = unsafeCoerce $ z v
394 w' = unsafeCoerce $ w v
371 395
372instance Uniform Matrix3 where 396instance Uniform Matrix3 where
373 uniform loc mat = 397 uniform loc mat =
374 with mat $ \ptrMat -> 398 with mat $ \ptrMat ->
375 glUniformMatrix3fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) 399 glUniformMatrix3fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
376 400
377instance Uniform Matrix4 where 401instance Uniform Matrix4 where
378 uniform loc mat = 402 uniform loc mat =
379 with mat $ \ptrMat -> 403 with mat $ \ptrMat ->
380 glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) 404 glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
381 405
382instance Uniform [Float] where 406instance Uniform [Float] where
383 uniform loc vals = withArray (map unsafeCoerce vals) $ \ptr -> 407 uniform loc vals = withArray (map unsafeCoerce vals) $ \ptr ->
384 case length vals of 408 case length vals of
385 1 -> glUniform1fv loc 1 ptr 409 1 -> glUniform1fv loc 1 ptr
386 2 -> glUniform2fv loc 1 ptr 410 2 -> glUniform2fv loc 1 ptr
387 3 -> glUniform3fv loc 1 ptr 411 3 -> glUniform3fv loc 1 ptr
388 4 -> glUniform4fv loc 1 ptr 412 4 -> glUniform4fv loc 1 ptr
389 413
390instance Uniform [CFloat] where 414instance Uniform [CFloat] where
391 uniform loc vals = withArray vals $ \ptr -> 415 uniform loc vals = withArray vals $ \ptr ->
392 case length vals of 416 case length vals of
393 1 -> glUniform1fv loc 1 ptr 417 1 -> glUniform1fv loc 1 $ castPtr ptr
394 2 -> glUniform2fv loc 1 ptr 418 2 -> glUniform2fv loc 1 $ castPtr ptr
395 3 -> glUniform3fv loc 1 ptr 419 3 -> glUniform3fv loc 1 $ castPtr ptr
396 4 -> glUniform4fv loc 1 ptr 420 4 -> glUniform4fv loc 1 $ castPtr ptr
397 421
398instance Uniform [Int] where 422instance Uniform [Int] where
399 uniform loc vals = withArray (map fromIntegral vals) $ \ptr -> 423 uniform loc vals = withArray (map fromIntegral vals) $ \ptr ->
400 case length vals of 424 case length vals of
401 1 -> glUniform1iv loc 1 ptr 425 1 -> glUniform1iv loc 1 ptr
402 2 -> glUniform2iv loc 1 ptr 426 2 -> glUniform2iv loc 1 ptr
403 3 -> glUniform3iv loc 1 ptr 427 3 -> glUniform3iv loc 1 ptr
404 4 -> glUniform4iv loc 1 ptr 428 4 -> glUniform4iv loc 1 ptr
405 429
406-- 430--
407-- VAOs 431-- VAOs
@@ -409,28 +433,29 @@ instance Uniform [Int] where
409 433
410-- | A vertex array object. 434-- | A vertex array object.
411data VAO = VAO 435data VAO = VAO
412 { getVAO :: GLuint 436 { getVAO :: GLuint,
413 , vaoKey :: Resource 437 vaoKey :: Resource
414 } 438 }
415 439
416instance ResourceClass VAO where 440instance ResourceClass VAO where
417 getResource = vaoKey 441 getResource = vaoKey
418 442
419instance Eq VAO where 443instance Eq VAO where
420 vao1 == vao2 = getVAO vao1 == getVAO vao2 444 vao1 == vao2 = getVAO vao1 == getVAO vao2
421 445
422instance Ord VAO where 446instance Ord VAO where
423 vao1 < vao2 = getVAO vao1 < getVAO vao2 447 vao1 < vao2 = getVAO vao1 < getVAO vao2
448 vao1 <= vao2 = getVAO vao1 <= getVAO vao2
424 449
425-- | Create a new vao. 450-- | Create a new vao.
426newVAO :: Game s VAO 451newVAO :: Game s VAO
427newVAO = do 452newVAO = do
428 h <- gameIO . alloca $ \ptr -> do 453 h <- gameIO . alloca $ \ptr -> do
429 glGenVertexArrays 1 ptr 454 glGenVertexArrays 1 ptr
430 peek ptr 455 peek ptr
431 456
432 rkey <- register $ deleteVAO h 457 rkey <- register $ deleteVAO h
433 return $ VAO h rkey 458 return $ VAO h rkey
434 459
435-- | Delete the vao. 460-- | Delete the vao.
436deleteVAO :: GLuint -> IO () 461deleteVAO :: GLuint -> IO ()
@@ -447,38 +472,54 @@ unbindVAO = glBindVertexArray 0
447-- | Enable the given vertex attribute of the bound vao. 472-- | Enable the given vertex attribute of the bound vao.
448-- 473--
449-- See also 'bindVAO'. 474-- See also 'bindVAO'.
450enableVAOAttrib :: GLuint -- ^ Attribute index. 475enableVAOAttrib ::
451 -> IO () 476 -- | Attribute index.
477 GLuint ->
478 IO ()
452enableVAOAttrib = glEnableVertexAttribArray 479enableVAOAttrib = glEnableVertexAttribArray
453 480
454-- | Bind the bound buffer to the given point. 481-- | Bind the bound buffer to the given point.
455attribVAOPointer 482attribVAOPointer ::
456 :: GLuint -- ^ The index of the generic vertex attribute to be modified. 483 -- | The index of the generic vertex attribute to be modified.
457 -> GLint -- ^ The number of components per generic vertex attribute. Must be 1,2,3,4. 484 GLuint ->
458 -> GLenum -- ^ The data type of each component in the array. 485 -- | The number of components per generic vertex attribute. Must be 1,2,3,4.
459 -> Bool -- ^ Whether fixed-point data values should be normalized. 486 GLint ->
460 -> GLsizei -- ^ Stride. Byte offset between consecutive generic vertex attributes. 487 -- | The data type of each component in the array.
461 -> Int -- ^ Offset to the first component in the array. 488 GLenum ->
462 -> IO () 489 -- | Whether fixed-point data values should be normalized.
490 Bool ->
491 -- | Stride. Byte offset between consecutive generic vertex attributes.
492 GLsizei ->
493 -- | Offset to the first component in the array.
494 Int ->
495 IO ()
463attribVAOPointer idx ncomp dattype normalise stride off = 496attribVAOPointer idx ncomp dattype normalise stride off =
464 glVertexAttribPointer idx ncomp dattype normalise' stride (unsafeCoerce off) 497 glVertexAttribPointer idx ncomp dattype normalise' stride (unsafeCoerce off)
465 where normalise' = if normalise then 1 else 0 498 where
499 normalise' = if normalise then 1 else 0
466 500
467-- | Draw the bound vao. 501-- | Draw the bound vao.
468drawArrays 502drawArrays ::
469 :: GLenum -- ^ The kind of primitives to render. 503 -- | The kind of primitives to render.
470 -> Int -- ^ Starting index in the enabled arrays. 504 GLenum ->
471 -> Int -- ^ The number of indices to be rendered. 505 -- | Starting index in the enabled arrays.
472 -> IO () 506 Int ->
507 -- | The number of indices to be rendered.
508 Int ->
509 IO ()
473drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count) 510drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count)
474 511
475-- | Draw the bound vao, indexed mode. 512-- | Draw the bound vao, indexed mode.
476drawElements 513drawElements ::
477 :: GLenum -- ^ The kind of primitives to render. 514 -- | The kind of primitives to render.
478 -> Int -- ^ The number of elements to be rendered. 515 GLenum ->
479 -> GLenum -- ^ The type of the index values. Must be one of gl_UNSIGNED_BYTE, gl_UNSIGNED_SHORT, or gl_UNSIGNED_INT. 516 -- | The number of elements to be rendered.
480 -> Ptr a -- ^ Pointer to the location where indices are stored, or offset into the index array when there is a bound ElementArrayBuffer. 517 Int ->
481 -> IO () 518 -- | The type of the index values. Must be one of gl_UNSIGNED_BYTE, gl_UNSIGNED_SHORT, or gl_UNSIGNED_INT.
519 GLenum ->
520 -- | Pointer to the location where indices are stored, or offset into the index array when there is a bound ElementArrayBuffer.
521 Ptr a ->
522 IO ()
482drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs 523drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs
483 524
484-- 525--
@@ -487,60 +528,60 @@ drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs
487 528
488-- | An OpenGL buffer. 529-- | An OpenGL buffer.
489data GLBuffer = GLBuffer 530data GLBuffer = GLBuffer
490 { getBuffer :: GLuint 531 { getBuffer :: GLuint,
491 , rkey :: Resource 532 rkey :: Resource
492 } 533 }
493 534
494instance ResourceClass GLBuffer where 535instance ResourceClass GLBuffer where
495 getResource = rkey 536 getResource = rkey
496 537
497-- | The type of target buffer. 538-- | The type of target buffer.
498data TargetBuffer 539data TargetBuffer
499 = ArrayBuffer 540 = ArrayBuffer
500 | ElementArrayBuffer 541 | ElementArrayBuffer
501 | PixelPackBuffer 542 | PixelPackBuffer
502 | PixelUnpackBuffer 543 | PixelUnpackBuffer
503 deriving (Eq, Show) 544 deriving (Eq, Show)
504 545
505fromTarget :: TargetBuffer -> GLenum 546fromTarget :: TargetBuffer -> GLenum
506fromTarget ArrayBuffer = gl_ARRAY_BUFFER 547fromTarget ArrayBuffer = GL_ARRAY_BUFFER
507fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER 548fromTarget ElementArrayBuffer = GL_ELEMENT_ARRAY_BUFFER
508fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER 549fromTarget PixelPackBuffer = GL_PIXEL_PACK_BUFFER
509fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER 550fromTarget PixelUnpackBuffer = GL_PIXEL_UNPACK_BUFFER
510 551
511-- | A buffer usage. 552-- | A buffer usage.
512data BufferUsage 553data BufferUsage
513 = StreamDraw 554 = StreamDraw
514 | StreamRead 555 | StreamRead
515 | StreamCopy 556 | StreamCopy
516 | StaticDraw 557 | StaticDraw
517 | StaticRead 558 | StaticRead
518 | StaticCopy 559 | StaticCopy
519 | DynamicDraw 560 | DynamicDraw
520 | DynamicRead 561 | DynamicRead
521 | DynamicCopy 562 | DynamicCopy
522 deriving (Eq, Show) 563 deriving (Eq, Show)
523 564
524fromUsage :: BufferUsage -> GLenum 565fromUsage :: BufferUsage -> GLenum
525fromUsage StreamDraw = gl_STREAM_DRAW 566fromUsage StreamDraw = GL_STREAM_DRAW
526fromUsage StreamRead = gl_STREAM_READ 567fromUsage StreamRead = GL_STREAM_READ
527fromUsage StreamCopy = gl_STREAM_COPY 568fromUsage StreamCopy = GL_STREAM_COPY
528fromUsage StaticDraw = gl_STATIC_DRAW 569fromUsage StaticDraw = GL_STATIC_DRAW
529fromUsage StaticRead = gl_STATIC_READ 570fromUsage StaticRead = GL_STATIC_READ
530fromUsage StaticCopy = gl_STATIC_COPY 571fromUsage StaticCopy = GL_STATIC_COPY
531fromUsage DynamicDraw = gl_DYNAMIC_DRAW 572fromUsage DynamicDraw = GL_DYNAMIC_DRAW
532fromUsage DynamicRead = gl_DYNAMIC_READ 573fromUsage DynamicRead = GL_DYNAMIC_READ
533fromUsage DynamicCopy = gl_DYNAMIC_COPY 574fromUsage DynamicCopy = GL_DYNAMIC_COPY
534 575
535-- | Create a new buffer. 576-- | Create a new buffer.
536newBuffer :: Game s GLBuffer 577newBuffer :: Game s GLBuffer
537newBuffer = do 578newBuffer = do
538 h <- gameIO . alloca $ \ptr -> do 579 h <- gameIO . alloca $ \ptr -> do
539 glGenBuffers 1 ptr 580 glGenBuffers 1 ptr
540 peek ptr 581 peek ptr
541 582
542 rkey <- register $ deleteBuffer h 583 rkey <- register $ deleteBuffer h
543 return $ GLBuffer h rkey 584 return $ GLBuffer h rkey
544 585
545-- | Delete the buffer. 586-- | Delete the buffer.
546deleteBuffer :: GLuint -> IO () 587deleteBuffer :: GLuint -> IO ()
@@ -555,21 +596,30 @@ unbindBuffer :: TargetBuffer -> IO ()
555unbindBuffer target = glBindBuffer (fromTarget target) 0 596unbindBuffer target = glBindBuffer (fromTarget target) 0
556 597
557class Storable a => BufferData a where 598class Storable a => BufferData a where
558 -- | Set the buffer's data. 599 -- | Set the buffer's data.
559 bufferData :: TargetBuffer -> [a] -> BufferUsage -> IO () 600 bufferData :: TargetBuffer -> [a] -> BufferUsage -> IO ()
560 bufferData tgt vals usage = 601 bufferData tgt vals usage =
561 let n = sizeOf (head vals) * length vals 602 let n = sizeOf (head vals) * length vals
562 in withArray vals $ \ptr -> bufferData' tgt n ptr usage 603 in withArray vals $ \ptr -> bufferData' tgt n ptr usage
563 604
564instance BufferData Word8 605instance BufferData Word8
606
565instance BufferData Word16 607instance BufferData Word16
608
566instance BufferData Word32 609instance BufferData Word32
610
567instance BufferData CChar 611instance BufferData CChar
612
568instance BufferData CInt 613instance BufferData CInt
614
569instance BufferData CFloat 615instance BufferData CFloat
616
570instance BufferData CDouble 617instance BufferData CDouble
618
571instance BufferData Int 619instance BufferData Int
620
572instance BufferData Float 621instance BufferData Float
622
573instance BufferData Double 623instance BufferData Double
574 624
575{-bufferData :: Storable a 625{-bufferData :: Storable a
@@ -582,11 +632,13 @@ bufferData target n bufData usage = withArray bufData $
582 \ptr -> bufferData target (n * length bufData) ptr usage-} 632 \ptr -> bufferData target (n * length bufData) ptr usage-}
583 633
584-- | Set the buffer's data. 634-- | Set the buffer's data.
585bufferData' :: TargetBuffer 635bufferData' ::
586 -> Int -- ^ Buffer size in bytes. 636 TargetBuffer ->
587 -> Ptr a 637 -- | Buffer size in bytes.
588 -> BufferUsage 638 Int ->
589 -> IO () 639 Ptr a ->
640 BufferUsage ->
641 IO ()
590bufferData' target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage) 642bufferData' target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage)
591 643
592-- | Apply the given function the buffer's id. 644-- | Apply the given function the buffer's id.
@@ -599,88 +651,102 @@ withGLBuffer buf f = f $ getBuffer buf
599 651
600-- | Represents a texture resource. 652-- | Represents a texture resource.
601data Texture = Texture 653data Texture = Texture
602 { getTex :: GLuint 654 { getTex :: GLuint,
603 , texKey :: Resource 655 texKey :: Resource
604 } 656 }
605 657
606instance Eq Texture where 658instance Eq Texture where
607 t1 == t2 = getTex t1 == getTex t2 659 t1 == t2 = getTex t1 == getTex t2
608 660
609instance Ord Texture where 661instance Ord Texture where
610 t1 < t2 = getTex t1 < getTex t2 662 t1 < t2 = getTex t1 < getTex t2
663 t1 <= t2 = getTex t1 <= getTex t2
611 664
612instance ResourceClass Texture where 665instance ResourceClass Texture where
613 getResource = texKey 666 getResource = texKey
614 667
615-- | Create a new texture. 668-- | Create a new texture.
616newTexture :: Game s Texture 669newTexture :: Game s Texture
617newTexture = do 670newTexture = do
618 tex <- gameIO . alloca $ \ptr -> do 671 tex <- gameIO . alloca $ \ptr -> do
619 glGenTextures 1 ptr 672 glGenTextures 1 ptr
620 peek ptr 673 peek ptr
621 674
622 rkey <- register $ deleteTexture tex 675 rkey <- register $ deleteTexture tex
623 return $ Texture tex rkey 676 return $ Texture tex rkey
624 677
625-- | Delete the texture. 678-- | Delete the texture.
626deleteTexture :: GLuint -> IO () 679deleteTexture :: GLuint -> IO ()
627--deleteTexture tex = with tex $ glDeleteTextures 1 680--deleteTexture tex = with tex $ glDeleteTextures 1
628deleteTexture tex = do 681deleteTexture tex = do
629 putStrLn $ "Releasing texture " ++ show tex 682 putStrLn $ "Releasing texture " ++ show tex
630 with tex $ glDeleteTextures 1 683 with tex $ glDeleteTextures 1
631 684
632-- | Load the 'Texture' specified by the given file. 685-- | Load the 'Texture' specified by the given file.
633loadTextureImage :: FilePath 686loadTextureImage ::
634 -> GLenum -- ^ Texture's min filter. 687 FilePath ->
635 -> GLenum -- ^ Texture's mag filter. 688 -- | Texture's min filter.
636 -> Game s Texture 689 GLenum ->
690 -- | Texture's mag filter.
691 GLenum ->
692 Game s Texture
637loadTextureImage file minFilter magFilter = do 693loadTextureImage file minFilter magFilter = do
638 image <- loadImage file 694 image <- loadImage file
639 tex <- newTexture 695 tex <- newTexture
640 gameIO $ do 696 gameIO $ do
641 let w = width image 697 let w = width image
642 h = height image 698 h = height image
643 pix = pixels image 699 pix = pixels image
644 rgb = fromIntegral . fromEnum $ gl_RGB 700 rgb = fromIntegral . fromEnum $ GL_RGB
645 701
646 bindTexture tex 702 bindTexture tex
647 loadTextureData gl_TEXTURE_2D 0 rgb w h 0 gl_RGB gl_UNSIGNED_BYTE pix 703 loadTextureData GL_TEXTURE_2D 0 rgb w h 0 GL_RGB GL_UNSIGNED_BYTE pix
648 texParami gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $= minFilter 704 texParami GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $= minFilter
649 texParami gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $= magFilter 705 texParami GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $= magFilter
650 706
651 return tex 707 return tex
652 708
653-- | Bind the texture. 709-- | Bind the texture.
654bindTexture :: Texture -> IO () 710bindTexture :: Texture -> IO ()
655bindTexture = glBindTexture gl_TEXTURE_2D . getTex 711bindTexture = glBindTexture GL_TEXTURE_2D . getTex
656 712
657-- | Unbind the bound texture. 713-- | Unbind the bound texture.
658unbindTexture :: IO () 714unbindTexture :: IO ()
659unbindTexture = glBindTexture gl_TEXTURE_2D 0 715unbindTexture = glBindTexture GL_TEXTURE_2D 0
660 716
661-- | Load data onto the bound texture. 717-- | Load data onto the bound texture.
662-- 718--
663-- See also 'bindTexture'. 719-- See also 'bindTexture'.
664loadTextureData :: GLenum 720loadTextureData ::
665 -> Int -- ^ Target 721 GLenum ->
666 -> Int -- ^ Level 722 -- | Target
667 -> Int -- ^ Internal format 723 Int ->
668 -> Int -- ^ Width 724 -- | Level
669 -> Int -- ^ Height 725 Int ->
670 -> GLenum -- ^ Border 726 -- | Internal format
671 -> GLenum -- ^ Texture type 727 Int ->
672 -> Ptr a -- ^ Texture data 728 -- | Width
673 -> IO () 729 Int ->
730 -- | Height
731 Int ->
732 -- | Border
733 GLenum ->
734 -- | Texture type
735 GLenum ->
736 -- | Texture data
737 Ptr a ->
738 IO ()
674loadTextureData target level internalFormat width height border format texType texData = do 739loadTextureData target level internalFormat width height border format texType texData = do
675 glTexImage2D target 740 glTexImage2D
676 (fromIntegral level) 741 target
677 (fromIntegral internalFormat) 742 (fromIntegral level)
678 (fromIntegral width) 743 (fromIntegral internalFormat)
679 (fromIntegral height) 744 (fromIntegral width)
680 (fromIntegral border) 745 (fromIntegral height)
681 (fromIntegral format) 746 (fromIntegral border)
682 texType 747 (fromIntegral format)
683 texData 748 texType
749 texData
684 750
685-- | Set the bound texture's parameter to the given value. 751-- | Set the bound texture's parameter to the given value.
686texParami :: GLenum -> GLenum -> SettableStateVar GLenum 752texParami :: GLenum -> GLenum -> SettableStateVar GLenum
@@ -701,19 +767,20 @@ activeTexture = makeSettableStateVar glActiveTexture
701-- | Get the last OpenGL error. 767-- | Get the last OpenGL error.
702getGLError :: IO (Maybe String) 768getGLError :: IO (Maybe String)
703getGLError = fmap translate glGetError 769getGLError = fmap translate glGetError
704 where 770 where
705 translate err 771 translate err
706 | err == gl_NO_ERROR = Nothing 772 | err == GL_NO_ERROR = Nothing
707 | err == gl_INVALID_ENUM = Just "Invalid enum" 773 | err == GL_INVALID_ENUM = Just "Invalid enum"
708 | err == gl_INVALID_VALUE = Just "Invalid value" 774 | err == GL_INVALID_VALUE = Just "Invalid value"
709 | err == gl_INVALID_OPERATION = Just "Invalid operation" 775 | err == GL_INVALID_OPERATION = Just "Invalid operation"
710 | err == gl_OUT_OF_MEMORY = Just "Out of memory" 776 | err == GL_OUT_OF_MEMORY = Just "Out of memory"
711 | otherwise = Just "Unknown error" 777 | otherwise = Just "Unknown error"
712 778
713-- | Print the last OpenGL error. 779-- | Print the last OpenGL error.
714printGLError :: IO () 780printGLError :: IO ()
715printGLError = getGLError >>= \err -> case err of 781printGLError =
716 Nothing -> return () 782 getGLError >>= \err -> case err of
783 Nothing -> return ()
717 Just str -> hPutStrLn stderr str 784 Just str -> hPutStrLn stderr str
718 785
719-- | Run the given setup action and check for OpenGL errors. 786-- | Run the given setup action and check for OpenGL errors.
@@ -722,8 +789,8 @@ printGLError = getGLError >>= \err -> case err of
722-- the given string appended to the string describing the error. 789-- the given string appended to the string describing the error.
723assertGL :: Game s a -> String -> Game s a 790assertGL :: Game s a -> String -> Game s a
724assertGL action err = do 791assertGL action err = do
725 result <- action 792 result <- action
726 status <- gameIO getGLError 793 status <- gameIO getGLError
727 case status of 794 case status of
728 Just str -> gameError $ "OpenGL error raised: " ++ err ++ "; " ++ str 795 Just str -> gameError $ "OpenGL error raised: " ++ err ++ "; " ++ str
729 Nothing -> return result 796 Nothing -> return result
diff --git a/Spear/Game.hs b/Spear/Game.hs
index 44cb13c..c5b043b 100644
--- a/Spear/Game.hs
+++ b/Spear/Game.hs
@@ -1,47 +1,56 @@
1module Spear.Game 1module Spear.Game
2( 2 ( Game,
3 Game 3 GameException (..),
4, Resource 4 Resource,
5, ResourceClass(..) 5 ResourceClass (..),
6
6 -- * Game state 7 -- * Game state
7, getGameState 8 getGameState,
8, saveGameState 9 saveGameState,
9, modifyGameState 10 modifyGameState,
11
10 -- * Game resources 12 -- * Game resources
11, register 13 register,
12, unregister 14 unregister,
15
13 -- * Error handling 16 -- * Error handling
14, gameError 17 gameError,
15, assertMaybe 18 assertMaybe,
16, catchGameError 19 catchGameError,
17, catchGameErrorFinally 20 catchGameErrorFinally,
21
18 -- * Running and IO 22 -- * Running and IO
19, runGame 23 runGame,
20, runGame' 24 runGame',
21, runSubGame 25 runSubGame,
22, runSubGame' 26 runSubGame',
23, evalSubGame 27 evalSubGame,
24, execSubGame 28 execSubGame,
25, gameIO 29 gameIO,
26) 30 )
27where 31where
28 32
29import Control.Monad.Trans.Class (lift) 33import Control.Monad.Catch
30import Control.Monad.State.Strict 34import Control.Monad.State.Strict
31import Control.Monad.Error 35import Control.Monad.Trans.Class (lift)
32import qualified Control.Monad.Trans.Resource as R 36import qualified Control.Monad.Trans.Resource as R
33 37
34type Resource = R.ReleaseKey 38type Resource = R.ReleaseKey
35type Game s = StateT s (R.ResourceT (ErrorT String IO)) 39
40type Game s = StateT s (R.ResourceT IO)
36 41
37class ResourceClass a where 42class ResourceClass a where
38 getResource :: a -> Resource 43 getResource :: a -> Resource
44
45 release :: a -> Game s ()
46 release = unregister . getResource
47
48 clean :: a -> IO ()
49 clean = R.release . getResource
39 50
40 release :: a -> Game s () 51newtype GameException = GameException String deriving (Show)
41 release = unregister . getResource
42 52
43 clean :: a -> IO () 53instance Exception GameException
44 clean = R.release . getResource
45 54
46-- | Retrieve the game state. 55-- | Retrieve the game state.
47getGameState :: Game s s 56getGameState :: Game s s
@@ -65,49 +74,49 @@ unregister = lift . R.release
65 74
66-- | Throw an error from the 'Game' monad. 75-- | Throw an error from the 'Game' monad.
67gameError :: String -> Game s a 76gameError :: String -> Game s a
68gameError = lift . lift . throwError 77gameError = gameError' . GameException
78
79-- | Throw an error from the 'Game' monad.
80gameError' :: GameException -> Game s a
81gameError' = lift . lift . throwM
69 82
70-- | Throw the given error string if given 'Nothing'. 83-- | Throw the given error if given 'Nothing'.
71assertMaybe :: Maybe a -> String -> Game s a 84assertMaybe :: Maybe a -> GameException -> Game s a
72assertMaybe Nothing err = gameError err 85assertMaybe Nothing err = gameError' err
73assertMaybe (Just x) _ = return x 86assertMaybe (Just x) _ = return x
74 87
75-- | Run the given game with the given error handler. 88-- | Run the given game with the given error handler.
76catchGameError :: Game s a -> (String -> Game s a) -> Game s a 89catchGameError :: Game s a -> (GameException -> Game s a) -> Game s a
77catchGameError game catch = catchError game catch 90catchGameError = catch
78 91
79-- | Run the given game, catch any error, run the given finaliser and rethrow the error. 92-- | Run the given game, catch any error, run the given finaliser and rethrow the error.
80catchGameErrorFinally :: Game s a -> Game s a -> Game s a 93catchGameErrorFinally :: Game s a -> Game s a -> Game s a
81catchGameErrorFinally game finally = catchError game $ \err -> finally >> gameError err 94catchGameErrorFinally game finally = catch game $ \err -> finally >> gameError' err
82 95
83-- | Run the given game. 96-- | Run the given game.
84runGame :: Game s a -> s -> IO (Either String (a,s)) 97runGame :: Game s a -> s -> IO (a, s)
85runGame game state = runErrorT . R.runResourceT . runStateT game $ state 98runGame game = R.runResourceT . runStateT game
86 99
87-- | Run the given game and discard its state. 100-- | Run the given game and discard its state.
88runGame' :: Game s a -> s -> IO (Either String a) 101runGame' :: Game s a -> s -> IO a
89runGame' g s = runGame g s >>= \result -> return $ case result of 102runGame' g s = fst <$> runGame g s
90 Right (a,s) -> Right a
91 Left err -> Left err
92 103
93-- | Fully run the given sub game, unrolling the entire monad stack. 104-- | Fully run the given sub game, unrolling the entire monad stack.
94runSubGame :: Game s a -> s -> Game t (a,s) 105runSubGame :: Game s a -> s -> Game t (a, s)
95runSubGame game state = gameIO (runGame game state) >>= \result -> case result of 106runSubGame g s = gameIO $ runGame g s
96 Left err -> gameError err
97 Right x -> return x
98 107
99-- | Like 'runSubGame', but discarding the result. 108-- | Like 'runSubGame', but discarding the result.
100runSubGame' :: Game s a -> s -> Game t () 109runSubGame' :: Game s a -> s -> Game t ()
101runSubGame' game state = runSubGame game state >> return () 110runSubGame' g s = void $ runSubGame g s
102 111
103-- | Run the given game and return its result. 112-- | Run the given game and return its result.
104evalSubGame :: Game s a -> s -> Game t a 113evalSubGame :: Game s a -> s -> Game t a
105evalSubGame g s = runSubGame g s >>= \(a,_) -> return a 114evalSubGame g s = fst <$> runSubGame g s
106 115
107-- | Run the given game and return its state. 116-- | Run the given game and return its state.
108execSubGame :: Game s a -> s -> Game t s 117execSubGame :: Game s a -> s -> Game t s
109execSubGame g s = runSubGame g s >>= \(_,s) -> return s 118execSubGame g s = snd <$> runSubGame g s
110 119
111-- | Perform the given IO action in the 'Game' monad. 120-- | Perform the given IO action in the 'Game' monad.
112gameIO :: IO a -> Game s a 121gameIO :: IO a -> Game s a
113gameIO = lift . lift . lift 122gameIO = lift . lift
diff --git a/Spear/Render/AnimatedModel.hs b/Spear/Render/AnimatedModel.hs
index c31c18a..e69ce75 100644
--- a/Spear/Render/AnimatedModel.hs
+++ b/Spear/Render/AnimatedModel.hs
@@ -1,35 +1,41 @@
1module Spear.Render.AnimatedModel 1module Spear.Render.AnimatedModel
2( 2 ( -- * Data types
3 -- * Data types 3 AnimatedModelResource,
4 AnimatedModelResource 4 AnimatedModelRenderer,
5, AnimatedModelRenderer 5 AnimationSpeed,
6, AnimationSpeed 6
7 -- * Construction and destruction 7 -- * Construction and destruction
8, animatedModelResource 8 animatedModelResource,
9, animatedModelRenderer 9 animatedModelRenderer,
10
10 -- * Accessors 11 -- * Accessors
11, animationSpeed 12 animationSpeed,
12, box 13 box,
13, currentAnimation 14 currentAnimation,
14, currentFrame 15 currentFrame,
15, frameProgress 16 frameProgress,
16, modelRes 17 modelRes,
17, nextFrame 18 nextFrame,
19
18 -- * Manipulation 20 -- * Manipulation
19, update 21 update,
20, setAnimation 22 setAnimation,
21, setAnimationSpeed 23 setAnimationSpeed,
24
22 -- * Rendering 25 -- * Rendering
23, bind 26 bind,
24, render 27 render,
28
25 -- * Collision 29 -- * Collision
26, mkColsFromAnimated 30 mkColsFromAnimated,
27) 31 )
28where 32where
29 33
34import Control.Applicative ((<$>), (<*>))
35import qualified Data.Vector as V
30import Spear.Assets.Model 36import Spear.Assets.Model
31import Spear.Game
32import Spear.GL 37import Spear.GL
38import Spear.Game
33import Spear.Math.AABB 39import Spear.Math.AABB
34import Spear.Math.Collision 40import Spear.Math.Collision
35import Spear.Math.Matrix4 (Matrix4) 41import Spear.Math.Matrix4 (Matrix4)
@@ -37,9 +43,6 @@ import Spear.Math.Vector
37import Spear.Render.Material 43import Spear.Render.Material
38import Spear.Render.Model 44import Spear.Render.Model
39import Spear.Render.Program 45import Spear.Render.Program
40
41import Control.Applicative ((<$>), (<*>))
42import qualified Data.Vector as V
43import Unsafe.Coerce (unsafeCoerce) 46import Unsafe.Coerce (unsafeCoerce)
44 47
45type AnimationSpeed = Float 48type AnimationSpeed = Float
@@ -48,24 +51,25 @@ type AnimationSpeed = Float
48-- 51--
49-- Contains model data necessary to render an animated model. 52-- Contains model data necessary to render an animated model.
50data AnimatedModelResource = AnimatedModelResource 53data AnimatedModelResource = AnimatedModelResource
51 { model :: Model 54 { model :: Model,
52 , vao :: VAO 55 vao :: VAO,
53 , nFrames :: Int 56 nFrames :: Int,
54 , nVertices :: Int 57 nVertices :: Int,
55 , material :: Material 58 material :: Material,
56 , texture :: Texture 59 texture :: Texture,
57 , boxes :: V.Vector Box 60 boxes :: V.Vector Box,
58 , rkey :: Resource 61 rkey :: Resource
59 } 62 }
60 63
61instance Eq AnimatedModelResource where 64instance Eq AnimatedModelResource where
62 m1 == m2 = vao m1 == vao m2 65 m1 == m2 = vao m1 == vao m2
63 66
64instance Ord AnimatedModelResource where 67instance Ord AnimatedModelResource where
65 m1 < m2 = vao m1 < vao m2 68 m1 < m2 = vao m1 < vao m2
69 m1 <= m2 = vao m1 <= vao m2
66 70
67instance ResourceClass AnimatedModelResource where 71instance ResourceClass AnimatedModelResource where
68 getResource = rkey 72 getResource = rkey
69 73
70-- | An animated model renderer. 74-- | An animated model renderer.
71-- 75--
@@ -78,83 +82,98 @@ instance ResourceClass AnimatedModelResource where
78-- state changes by sorting 'AnimatedModelRenderer's by their underlying 82-- state changes by sorting 'AnimatedModelRenderer's by their underlying
79-- 'AnimatedModelResource' when rendering the scene. 83-- 'AnimatedModelResource' when rendering the scene.
80data AnimatedModelRenderer = AnimatedModelRenderer 84data AnimatedModelRenderer = AnimatedModelRenderer
81 { modelResource :: AnimatedModelResource 85 { modelResource :: AnimatedModelResource,
82 , currentAnim :: Int 86 currentAnim :: Int,
83 , frameStart :: Int 87 frameStart :: Int,
84 , frameEnd :: Int 88 frameEnd :: Int,
85 , currentFrame :: Int -- ^ Get the renderer's current frame. 89 -- | Get the renderer's current frame.
86 , frameProgress :: Float -- ^ Get the renderer's frame progress. 90 currentFrame :: Int,
87 , animationSpeed :: Float -- ^ Get the renderer's animation speed. 91 -- | Get the renderer's frame progress.
88 } 92 frameProgress :: Float,
93 -- | Get the renderer's animation speed.
94 animationSpeed :: Float
95 }
89 96
90instance Eq AnimatedModelRenderer where 97instance Eq AnimatedModelRenderer where
91 m1 == m2 = modelResource m1 == modelResource m2 98 m1 == m2 = modelResource m1 == modelResource m2
92 99
93instance Ord AnimatedModelRenderer where 100instance Ord AnimatedModelRenderer where
94 m1 < m2 = modelResource m1 < modelResource m2 101 m1 < m2 = modelResource m1 < modelResource m2
102 m1 <= m2 = modelResource m1 <= modelResource m2
95 103
96-- | Create an model resource from the given model. 104-- | Create an model resource from the given model.
97animatedModelResource :: AnimatedProgramChannels 105animatedModelResource ::
98 -> Material 106 AnimatedProgramChannels ->
99 -> Texture 107 Material ->
100 -> Model 108 Texture ->
101 -> Game s AnimatedModelResource 109 Model ->
102 110 Game s AnimatedModelResource
103animatedModelResource 111animatedModelResource
104 (AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan) 112 (AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan)
105 material texture model = do 113 material
106 RenderModel elements numFrames numVertices <- gameIO . renderModelFromModel $ model 114 texture
107 elementBuf <- newBuffer 115 model = do
108 vao <- newVAO 116 RenderModel elements numFrames numVertices <- gameIO . renderModelFromModel $ model
109 boxes <- gameIO $ modelBoxes model 117 elementBuf <- newBuffer
110 118 vao <- newVAO
111 gameIO $ do 119 boxes <- gameIO $ modelBoxes model
112 120
113 let elemSize = 56 121 gameIO $ do
114 elemSize' = fromIntegral elemSize 122 let elemSize = 56
115 n = numVertices * numFrames 123 elemSize' = fromIntegral elemSize
116 124 n = numVertices * numFrames
117 bindVAO vao 125
118 126 bindVAO vao
119 bindBuffer ArrayBuffer elementBuf 127
120 bufferData' ArrayBuffer (unsafeCoerce $ elemSize * n) elements StaticDraw 128 bindBuffer ArrayBuffer elementBuf
121 129 bufferData' ArrayBuffer (unsafeCoerce $ elemSize * n) elements StaticDraw
122 attribVAOPointer vertChan1 3 gl_FLOAT False elemSize' 0 130
123 attribVAOPointer vertChan2 3 gl_FLOAT False elemSize' 12 131 attribVAOPointer vertChan1 3 GL_FLOAT False elemSize' 0
124 attribVAOPointer normChan1 3 gl_FLOAT False elemSize' 24 132 attribVAOPointer vertChan2 3 GL_FLOAT False elemSize' 12
125 attribVAOPointer normChan2 3 gl_FLOAT False elemSize' 36 133 attribVAOPointer normChan1 3 GL_FLOAT False elemSize' 24
126 attribVAOPointer texChan 2 gl_FLOAT False elemSize' 48 134 attribVAOPointer normChan2 3 GL_FLOAT False elemSize' 36
127 135 attribVAOPointer texChan 2 GL_FLOAT False elemSize' 48
128 enableVAOAttrib vertChan1 136
129 enableVAOAttrib vertChan2 137 enableVAOAttrib vertChan1
130 enableVAOAttrib normChan1 138 enableVAOAttrib vertChan2
131 enableVAOAttrib normChan2 139 enableVAOAttrib normChan1
132 enableVAOAttrib texChan 140 enableVAOAttrib normChan2
133 141 enableVAOAttrib texChan
134 rkey <- register $ do 142
135 putStrLn "Releasing animated model resource" 143 rkey <- register $ do
136 clean vao 144 putStrLn "Releasing animated model resource"
137 clean elementBuf 145 clean vao
138 146 clean elementBuf
139 return $ AnimatedModelResource 147
140 model vao (unsafeCoerce numFrames) (unsafeCoerce numVertices) 148 return $
141 material texture boxes rkey 149 AnimatedModelResource
150 model
151 vao
152 (unsafeCoerce numFrames)
153 (unsafeCoerce numVertices)
154 material
155 texture
156 boxes
157 rkey
142 158
143-- | Create a renderer from the given model resource. 159-- | Create a renderer from the given model resource.
144animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer 160animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer
145animatedModelRenderer animSpeed modelResource = 161animatedModelRenderer animSpeed modelResource =
146 AnimatedModelRenderer modelResource 0 0 0 0 0 animSpeed 162 AnimatedModelRenderer modelResource 0 0 0 0 0 animSpeed
147 163
148-- | Update the renderer. 164-- | Update the renderer.
149update dt (AnimatedModelRenderer model curAnim startFrame endFrame curFrame fp s) = 165update dt (AnimatedModelRenderer model curAnim startFrame endFrame curFrame fp s) =
150 AnimatedModelRenderer model curAnim startFrame endFrame curFrame' fp' s 166 AnimatedModelRenderer model curAnim startFrame endFrame curFrame' fp' s
151 where f = fp + dt * s 167 where
152 nextFrame = f >= 1.0 168 f = fp + dt * s
153 fp' = if nextFrame then f - 1.0 else f 169 nextFrame = f >= 1.0
154 curFrame' = if nextFrame 170 fp' = if nextFrame then f - 1.0 else f
155 then let x = curFrame + 1 171 curFrame' =
156 in if x > endFrame then startFrame else x 172 if nextFrame
157 else curFrame 173 then
174 let x = curFrame + 1
175 in if x > endFrame then startFrame else x
176 else curFrame
158 177
159-- | Get the model's ith bounding box. 178-- | Get the model's ith bounding box.
160box :: Int -> AnimatedModelResource -> Box 179box :: Int -> AnimatedModelResource -> Box
@@ -171,65 +190,65 @@ modelRes = modelResource
171-- | Get the renderer's next frame. 190-- | Get the renderer's next frame.
172nextFrame :: AnimatedModelRenderer -> Int 191nextFrame :: AnimatedModelRenderer -> Int
173nextFrame rend = 192nextFrame rend =
174 let curFrame = currentFrame rend 193 let curFrame = currentFrame rend
175 in 194 in if curFrame == frameEnd rend
176 if curFrame == frameEnd rend
177 then frameStart rend 195 then frameStart rend
178 else curFrame + 1 196 else curFrame + 1
179 197
180-- | Set the active animation to the given one. 198-- | Set the active animation to the given one.
181setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer 199setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer
182setAnimation anim modelRend = 200setAnimation anim modelRend =
183 let (Animation _ f1 f2) = animation (model . modelResource $ modelRend) anim' 201 let (Animation _ f1 f2) = animation (model . modelResource $ modelRend) anim'
184 anim' = fromEnum anim 202 anim' = fromEnum anim
185 in 203 in modelRend {currentAnim = anim', frameStart = f1, frameEnd = f2, currentFrame = f1}
186 modelRend { currentAnim = anim', frameStart = f1, frameEnd = f2, currentFrame = f1 }
187 204
188-- | Set the renderer's animation speed. 205-- | Set the renderer's animation speed.
189setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer 206setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer
190setAnimationSpeed s r = r { animationSpeed = s } 207setAnimationSpeed s r = r {animationSpeed = s}
191 208
192-- | Bind the given renderer to prepare it for rendering. 209-- | Bind the given renderer to prepare it for rendering.
193bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () 210bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO ()
194bind (AnimatedProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _ _) modelRend = 211bind (AnimatedProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _ _) modelRend =
195 let model' = modelResource modelRend 212 let model' = modelResource modelRend
196 in do 213 in do
197 bindVAO . vao $ model' 214 bindVAO . vao $ model'
198 bindTexture $ texture model' 215 bindTexture $ texture model'
199 activeTexture $= gl_TEXTURE0 216 activeTexture $= GL_TEXTURE0
200 glUniform1i texLoc 0 217 glUniform1i texLoc 0
201 218
202-- | Render the model described by the given renderer. 219-- | Render the model described by the given renderer.
203render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () 220render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO ()
204render uniforms (AnimatedModelRenderer model _ _ _ curFrame fp _) = 221render uniforms (AnimatedModelRenderer model _ _ _ curFrame fp _) =
205 let n = nVertices model 222 let n = nVertices model
206 (Material _ ka kd ks shi) = material model 223 (Material _ ka kd ks shi) = material model
207 in do 224 in do
208 uniform (kaLoc uniforms) ka 225 uniform (kaLoc uniforms) ka
209 uniform (kdLoc uniforms) kd 226 uniform (kdLoc uniforms) kd
210 uniform (ksLoc uniforms) ks 227 uniform (ksLoc uniforms) ks
211 glUniform1f (shiLoc uniforms) $ unsafeCoerce shi 228 glUniform1f (shiLoc uniforms) $ unsafeCoerce shi
212 glUniform1f (fpLoc uniforms) (unsafeCoerce fp) 229 glUniform1f (fpLoc uniforms) (unsafeCoerce fp)
213 drawArrays gl_TRIANGLES (n*curFrame) n 230 drawArrays GL_TRIANGLES (n * curFrame) n
214 231
215-- | Compute AABB collisioners in view space from the given model. 232-- | Compute AABB collisioners in view space from the given model.
216mkColsFromAnimated 233mkColsFromAnimated ::
217 :: Int -- ^ Source frame 234 -- | Source frame
218 -> Int -- ^ Dest frame 235 Int ->
219 -> Float -- ^ Frame progress 236 -- | Dest frame
220 -> Matrix4 -- ^ Modelview matrix 237 Int ->
221 -> AnimatedModelResource 238 -- | Frame progress
222 -> [Collisioner2] 239 Float ->
240 -- | Modelview matrix
241 Matrix4 ->
242 AnimatedModelResource ->
243 [Collisioner2]
223mkColsFromAnimated f1 f2 fp modelview modelRes = 244mkColsFromAnimated f1 f2 fp modelview modelRes =
224 let 245 let (Box (Vec3 xmin1 ymin1 zmin1) (Vec3 xmax1 ymax1 zmax1)) = box f1 modelRes
225 (Box (Vec3 xmin1 ymin1 zmin1) (Vec3 xmax1 ymax1 zmax1)) = box f1 modelRes 246 (Box (Vec3 xmin2 ymin2 zmin2) (Vec3 xmax2 ymax2 zmax2)) = box f2 modelRes
226 (Box (Vec3 xmin2 ymin2 zmin2) (Vec3 xmax2 ymax2 zmax2)) = box f2 modelRes 247 min1 = vec3 xmin1 ymin1 zmin1
227 min1 = vec3 xmin1 ymin1 zmin1 248 max1 = vec3 xmax1 ymax1 zmax1
228 max1 = vec3 xmax1 ymax1 zmax1 249 min2 = vec3 xmin2 ymin2 zmin2
229 min2 = vec3 xmin2 ymin2 zmin2 250 max2 = vec3 xmax2 ymax2 zmax2
230 max2 = vec3 xmax2 ymax2 zmax2 251 min = min1 + scale fp (min2 - min1)
231 min = min1 + scale fp (min2 - min1) 252 max = max1 + scale fp (max2 - max1)
232 max = max1 + scale fp (max2 - max1) 253 in mkCols modelview $
233 in 254 Box (Vec3 (x min) (y min) (z min)) (Vec3 (x max) (y max) (z max))
234 mkCols modelview
235 $ Box (Vec3 (x min) (y min) (z min)) (Vec3 (x max) (y max) (z max))
diff --git a/Spear/Render/StaticModel.hs b/Spear/Render/StaticModel.hs
index 2e9804f..f0b141e 100644
--- a/Spear/Render/StaticModel.hs
+++ b/Spear/Render/StaticModel.hs
@@ -1,25 +1,29 @@
1module Spear.Render.StaticModel 1module Spear.Render.StaticModel
2( 2 ( -- * Data types
3 -- * Data types 3 StaticModelResource,
4 StaticModelResource 4 StaticModelRenderer,
5, StaticModelRenderer 5
6 -- * Construction and destruction 6 -- * Construction and destruction
7, staticModelResource 7 staticModelResource,
8, staticModelRenderer 8 staticModelRenderer,
9
9 -- * Manipulation 10 -- * Manipulation
10, box 11 box,
11, modelRes 12 modelRes,
13
12 -- * Rendering 14 -- * Rendering
13, bind 15 bind,
14, render 16 render,
17
15 -- * Collision 18 -- * Collision
16, mkColsFromStatic 19 mkColsFromStatic,
17) 20 )
18where 21where
19 22
23import qualified Data.Vector as V
20import Spear.Assets.Model 24import Spear.Assets.Model
21import Spear.Game
22import Spear.GL 25import Spear.GL
26import Spear.Game
23import Spear.Math.AABB 27import Spear.Math.AABB
24import Spear.Math.Collision 28import Spear.Math.Collision
25import Spear.Math.Matrix4 (Matrix4) 29import Spear.Math.Matrix4 (Matrix4)
@@ -27,75 +31,80 @@ import Spear.Math.Vector
27import Spear.Render.Material 31import Spear.Render.Material
28import Spear.Render.Model 32import Spear.Render.Model
29import Spear.Render.Program 33import Spear.Render.Program
30
31import qualified Data.Vector as V
32import Unsafe.Coerce (unsafeCoerce) 34import Unsafe.Coerce (unsafeCoerce)
33 35
34data StaticModelResource = StaticModelResource 36data StaticModelResource = StaticModelResource
35 { vao :: VAO 37 { vao :: VAO,
36 , nVertices :: Int 38 nVertices :: Int,
37 , material :: Material 39 material :: Material,
38 , texture :: Texture 40 texture :: Texture,
39 , boxes :: V.Vector Box 41 boxes :: V.Vector Box,
40 , rkey :: Resource 42 rkey :: Resource
41 } 43 }
42 44
43instance Eq StaticModelResource where 45instance Eq StaticModelResource where
44 m1 == m2 = vao m1 == vao m2 46 m1 == m2 = vao m1 == vao m2
45 47
46instance Ord StaticModelResource where 48instance Ord StaticModelResource where
47 m1 < m2 = vao m1 < vao m2 49 m1 < m2 = vao m1 < vao m2
50 m1 <= m2 = vao m1 <= vao m2
48 51
49instance ResourceClass StaticModelResource where 52instance ResourceClass StaticModelResource where
50 getResource = rkey 53 getResource = rkey
51 54
52data StaticModelRenderer = StaticModelRenderer { model :: StaticModelResource } 55data StaticModelRenderer = StaticModelRenderer {model :: StaticModelResource}
53 56
54instance Eq StaticModelRenderer where 57instance Eq StaticModelRenderer where
55 m1 == m2 = model m1 == model m2 58 m1 == m2 = model m1 == model m2
56 59
57instance Ord StaticModelRenderer where 60instance Ord StaticModelRenderer where
58 m1 < m2 = model m1 < model m2 61 m1 < m2 = model m1 < model m2
62 m1 <= m2 = model m1 <= model m2
59 63
60-- | Create a model resource from the given model. 64-- | Create a model resource from the given model.
61staticModelResource :: StaticProgramChannels 65staticModelResource ::
62 -> Material 66 StaticProgramChannels ->
63 -> Texture 67 Material ->
64 -> Model 68 Texture ->
65 -> Game s StaticModelResource 69 Model ->
66 70 Game s StaticModelResource
67staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do 71staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do
68 RenderModel elements _ numVertices <- gameIO . renderModelFromModel $ model 72 RenderModel elements _ numVertices <- gameIO . renderModelFromModel $ model
69 elementBuf <- newBuffer 73 elementBuf <- newBuffer
70 vao <- newVAO 74 vao <- newVAO
71 boxes <- gameIO $ modelBoxes model 75 boxes <- gameIO $ modelBoxes model
72
73 gameIO $ do
74 76
75 let elemSize = 32 77 gameIO $ do
76 elemSize' = fromIntegral elemSize 78 let elemSize = 32
77 n = numVertices 79 elemSize' = fromIntegral elemSize
80 n = numVertices
78 81
79 bindVAO vao 82 bindVAO vao
80 83
81 bindBuffer ArrayBuffer elementBuf 84 bindBuffer ArrayBuffer elementBuf
82 bufferData' ArrayBuffer (fromIntegral $ elemSize*n) elements StaticDraw 85 bufferData' ArrayBuffer (fromIntegral $ elemSize * n) elements StaticDraw
83 86
84 attribVAOPointer vertChan 3 gl_FLOAT False elemSize' 0 87 attribVAOPointer vertChan 3 GL_FLOAT False elemSize' 0
85 attribVAOPointer normChan 3 gl_FLOAT False elemSize' 12 88 attribVAOPointer normChan 3 GL_FLOAT False elemSize' 12
86 attribVAOPointer texChan 2 gl_FLOAT False elemSize' 24 89 attribVAOPointer texChan 2 GL_FLOAT False elemSize' 24
87 90
88 enableVAOAttrib vertChan 91 enableVAOAttrib vertChan
89 enableVAOAttrib normChan 92 enableVAOAttrib normChan
90 enableVAOAttrib texChan 93 enableVAOAttrib texChan
91 94
92 rkey <- register $ do 95 rkey <- register $ do
93 putStrLn "Releasing static model resource" 96 putStrLn "Releasing static model resource"
94 clean vao 97 clean vao
95 clean elementBuf 98 clean elementBuf
96 99
97 return $ StaticModelResource 100 return $
98 vao (unsafeCoerce numVertices) material texture boxes rkey 101 StaticModelResource
102 vao
103 (unsafeCoerce numVertices)
104 material
105 texture
106 boxes
107 rkey
99 108
100-- | Create a renderer from the given model resource. 109-- | Create a renderer from the given model resource.
101staticModelRenderer :: StaticModelResource -> StaticModelRenderer 110staticModelRenderer :: StaticModelResource -> StaticModelRenderer
@@ -112,27 +121,28 @@ modelRes = model
112-- | Bind the given renderer to prepare it for rendering. 121-- | Bind the given renderer to prepare it for rendering.
113bind :: StaticProgramUniforms -> StaticModelRenderer -> IO () 122bind :: StaticProgramUniforms -> StaticModelRenderer -> IO ()
114bind (StaticProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _) (StaticModelRenderer model) = 123bind (StaticProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _) (StaticModelRenderer model) =
115 let (Material _ ka kd ks shi) = material model 124 let (Material _ ka kd ks shi) = material model
116 in do 125 in do
117 bindVAO . vao $ model 126 bindVAO . vao $ model
118 bindTexture $ texture model 127 bindTexture $ texture model
119 activeTexture $= gl_TEXTURE0 128 activeTexture $= GL_TEXTURE0
120 glUniform1i texLoc 0 129 glUniform1i texLoc 0
121 130
122-- | Render the given renderer. 131-- | Render the given renderer.
123render :: StaticProgramUniforms -> StaticModelRenderer -> IO () 132render :: StaticProgramUniforms -> StaticModelRenderer -> IO ()
124render uniforms (StaticModelRenderer model) = 133render uniforms (StaticModelRenderer model) =
125 let (Material _ ka kd ks shi) = material model 134 let (Material _ ka kd ks shi) = material model
126 in do 135 in do
127 uniform (kaLoc uniforms) ka 136 uniform (kaLoc uniforms) ka
128 uniform (kdLoc uniforms) kd 137 uniform (kdLoc uniforms) kd
129 uniform (ksLoc uniforms) ks 138 uniform (ksLoc uniforms) ks
130 glUniform1f (shiLoc uniforms) $ unsafeCoerce shi 139 glUniform1f (shiLoc uniforms) $ unsafeCoerce shi
131 drawArrays gl_TRIANGLES 0 $ nVertices model 140 drawArrays GL_TRIANGLES 0 $ nVertices model
132 141
133-- | Compute AABB collisioners in view space from the given model. 142-- | Compute AABB collisioners in view space from the given model.
134mkColsFromStatic 143mkColsFromStatic ::
135 :: Matrix4 -- ^ Modelview matrix 144 -- | Modelview matrix
136 -> StaticModelResource 145 Matrix4 ->
137 -> [Collisioner2] 146 StaticModelResource ->
147 [Collisioner2]
138mkColsFromStatic modelview modelRes = mkCols modelview (box 0 modelRes) 148mkColsFromStatic modelview modelRes = mkCols modelview (box 0 modelRes)
diff --git a/Spear/Scene/Loader.hs b/Spear/Scene/Loader.hs
index 7c072e8..a4a7ea2 100644
--- a/Spear/Scene/Loader.hs
+++ b/Spear/Scene/Loader.hs
@@ -1,22 +1,28 @@
1{-# LANGUAGE FlexibleContexts #-}
2
1module Spear.Scene.Loader 3module Spear.Scene.Loader
2( 4 ( SceneResources (..),
3 SceneResources(..) 5 loadScene,
4, loadScene 6 validate,
5, validate 7 resourceMap,
6, resourceMap 8 value,
7, value 9 unspecified,
8, unspecified 10 mandatory,
9, mandatory 11 asString,
10, asString 12 asFloat,
11, asFloat 13 asVec3,
12, asVec3 14 asVec4,
13, asVec4 15 )
14)
15where 16where
16 17
18import Control.Monad.State.Strict
19import Control.Monad.Trans (lift)
20import Data.List as L (find)
21import Data.Map as M
22import qualified Data.StateVar as SV (get)
17import Spear.Assets.Model as Model 23import Spear.Assets.Model as Model
18import Spear.Game
19import qualified Spear.GL as GL 24import qualified Spear.GL as GL
25import Spear.Game
20import Spear.Math.Collision 26import Spear.Math.Collision
21import Spear.Math.Matrix3 as M3 27import Spear.Math.Matrix3 as M3
22import Spear.Math.Matrix4 as M4 28import Spear.Math.Matrix4 as M4
@@ -28,12 +34,6 @@ import Spear.Render.Program
28import Spear.Render.StaticModel as SM 34import Spear.Render.StaticModel as SM
29import Spear.Scene.Graph 35import Spear.Scene.Graph
30import Spear.Scene.SceneResources 36import Spear.Scene.SceneResources
31
32import Control.Monad.State.Strict
33import Control.Monad.Trans (lift)
34import Data.List as L (find)
35import Data.Map as M
36import qualified Data.StateVar as SV (get)
37import Text.Printf (printf) 37import Text.Printf (printf)
38 38
39type Loader = Game SceneResources 39type Loader = Game SceneResources
@@ -41,14 +41,14 @@ type Loader = Game SceneResources
41-- | Load the scene specified by the given file. 41-- | Load the scene specified by the given file.
42loadScene :: FilePath -> Game s (SceneResources, SceneGraph) 42loadScene :: FilePath -> Game s (SceneResources, SceneGraph)
43loadScene file = do 43loadScene file = do
44 result <- gameIO $ loadSceneGraphFromFile file 44 result <- gameIO $ loadSceneGraphFromFile file
45 case result of 45 case result of
46 Left err -> gameError $ show err 46 Left err -> gameError $ show err
47 Right g -> case validate g of 47 Right g -> case validate g of
48 Nothing -> do 48 Nothing -> do
49 sceneRes <- resourceMap g 49 sceneRes <- resourceMap g
50 return (sceneRes, g) 50 return (sceneRes, g)
51 Just err -> gameError err 51 Just err -> gameError err
52 52
53-- | Validate the given SceneGraph. 53-- | Validate the given SceneGraph.
54validate :: SceneGraph -> Maybe String 54validate :: SceneGraph -> Maybe String
@@ -60,59 +60,63 @@ resourceMap g = execSubGame (resourceMap' g) emptySceneResources
60 60
61resourceMap' :: SceneGraph -> Loader () 61resourceMap' :: SceneGraph -> Loader ()
62resourceMap' node@(SceneLeaf nid props) = do 62resourceMap' node@(SceneLeaf nid props) = do
63 case nid of 63 case nid of
64 "shader-program" -> newShaderProgram node 64 "shader-program" -> newShaderProgram node
65 "model" -> newModel node 65 "model" -> newModel node
66 x -> return () 66 x -> return ()
67
68resourceMap' node@(SceneNode nid props children) = do 67resourceMap' node@(SceneNode nid props children) = do
69 mapM_ resourceMap' children 68 mapM_ resourceMap' children
70 69
71-- Lookup the given resource in the data pool. Load it if it is not present, otherwise return it. 70-- Lookup the given resource in the data pool. Load it if it is not present, otherwise return it.
72loadResource :: String -- ^ Resource name. 71loadResource ::
73 -> (SceneResources -> Map String a) -- ^ Map getter. 72 -- | Resource name.
74 -> (String -> a -> Loader ()) -- ^ Function to modify resources. 73 String ->
75 -> Loader a -- ^ Resource loader. 74 -- | Map getter.
76 -> Loader a 75 (SceneResources -> Map String a) ->
76 -- | Function to modify resources.
77 (String -> a -> Loader ()) ->
78 -- | Resource loader.
79 Loader a ->
80 Loader a
77loadResource key field modifyResources load = do 81loadResource key field modifyResources load = do
78 sceneData <- get 82 sceneData <- get
79 case M.lookup key $ field sceneData of 83 case M.lookup key $ field sceneData of
80 Just val -> return val 84 Just val -> return val
81 Nothing -> do 85 Nothing -> do
82 gameIO $ printf "Loading %s..." key 86 gameIO $ printf "Loading %s..." key
83 resource <- load 87 resource <- load
84 gameIO $ printf "done\n" 88 gameIO $ printf "done\n"
85 modifyResources key resource 89 modifyResources key resource
86 return resource 90 return resource
87 91
88addShader name shader = modify $ \sceneData -> 92addShader name shader = modify $ \sceneData ->
89 sceneData { shaders = M.insert name shader $ shaders sceneData } 93 sceneData {shaders = M.insert name shader $ shaders sceneData}
90 94
91addCustomProgram name prog = modify $ \sceneData -> 95addCustomProgram name prog = modify $ \sceneData ->
92 sceneData { customPrograms = M.insert name prog $ customPrograms sceneData } 96 sceneData {customPrograms = M.insert name prog $ customPrograms sceneData}
93 97
94addStaticProgram name prog = modify $ \sceneData -> 98addStaticProgram name prog = modify $ \sceneData ->
95 sceneData { staticPrograms = M.insert name prog $ staticPrograms sceneData } 99 sceneData {staticPrograms = M.insert name prog $ staticPrograms sceneData}
96 100
97addAnimatedProgram name prog = modify $ \sceneData -> 101addAnimatedProgram name prog = modify $ \sceneData ->
98 sceneData { animatedPrograms = M.insert name prog $ animatedPrograms sceneData } 102 sceneData {animatedPrograms = M.insert name prog $ animatedPrograms sceneData}
99 103
100addTexture name tex = modify $ \sceneData -> 104addTexture name tex = modify $ \sceneData ->
101 sceneData { textures = M.insert name tex $ textures sceneData } 105 sceneData {textures = M.insert name tex $ textures sceneData}
102 106
103addStaticModel name model = modify $ 107addStaticModel name model = modify $
104 \sceneData -> sceneData { staticModels = M.insert name model $ staticModels sceneData } 108 \sceneData -> sceneData {staticModels = M.insert name model $ staticModels sceneData}
105 109
106addAnimatedModel name model = modify $ 110addAnimatedModel name model = modify $
107 \sceneData -> sceneData { animatedModels = M.insert name model $ animatedModels sceneData } 111 \sceneData -> sceneData {animatedModels = M.insert name model $ animatedModels sceneData}
108 112
109-- Get the given resource from the data pool. 113-- Get the given resource from the data pool.
110getResource :: (SceneResources -> Map String a) -> String -> Loader a 114getResource :: (SceneResources -> Map String a) -> String -> Loader a
111getResource field key = do 115getResource field key = do
112 sceneData <- get 116 sceneData <- get
113 case M.lookup key $ field sceneData of 117 case M.lookup key $ field sceneData of
114 Just val -> return val 118 Just val -> return val
115 Nothing -> gameError $ "Oops, the given resource has not been loaded: " ++ key 119 Nothing -> gameError $ "Oops, the given resource has not been loaded: " ++ key
116 120
117---------------------- 121----------------------
118-- Resource Loading -- 122-- Resource Loading --
@@ -120,171 +124,170 @@ getResource field key = do
120 124
121newModel :: SceneGraph -> Loader () 125newModel :: SceneGraph -> Loader ()
122newModel (SceneLeaf _ props) = do 126newModel (SceneLeaf _ props) = do
123 name <- asString $ mandatory' "name" props 127 name <- asString $ mandatory' "name" props
124 file <- asString $ mandatory' "file" props 128 file <- asString $ mandatory' "file" props
125 tex <- asString $ mandatory' "texture" props 129 tex <- asString $ mandatory' "texture" props
126 prog <- asString $ mandatory' "shader-program" props 130 prog <- asString $ mandatory' "shader-program" props
127 ke <- asVec4 $ mandatory' "ke" props 131 ke <- asVec4 $ mandatory' "ke" props
128 ka <- asVec4 $ mandatory' "ka" props 132 ka <- asVec4 $ mandatory' "ka" props
129 kd <- asVec4 $ mandatory' "kd" props 133 kd <- asVec4 $ mandatory' "kd" props
130 ks <- asVec4 $ mandatory' "ks" props 134 ks <- asVec4 $ mandatory' "ks" props
131 shi <- asFloat $ mandatory' "shi" props 135 shi <- asFloat $ mandatory' "shi" props
132 136
133 let rotation = asRotation $ value "rotation" props 137 let rotation = asRotation $ value "rotation" props
134 scale = asVec3 $ value "scale" props 138 scale = asVec3 $ value "scale" props
135 139
136 gameIO $ printf "Loading model %s..." name 140 gameIO $ printf "Loading model %s..." name
137 model <- loadModel' file rotation scale 141 model <- loadModel' file rotation scale
138 gameIO . putStrLn $ "done" 142 gameIO . putStrLn $ "done"
139 texture <- loadTexture tex 143 texture <- loadTexture tex
140 sceneRes <- get 144 sceneRes <- get
141 145
142 let material = Material ke ka kd ks shi 146 let material = Material ke ka kd ks shi
143 147
144 case animated model of 148 case animated model of
145 False -> 149 False ->
146 case M.lookup prog $ staticPrograms sceneRes of 150 case M.lookup prog $ staticPrograms sceneRes of
147 Nothing -> (gameError $ "Static shader program " ++ prog ++ " does not exist") >> return () 151 Nothing -> (gameError $ "Static shader program " ++ prog ++ " does not exist") >> return ()
148 Just p -> 152 Just p ->
149 let StaticProgram _ channels _ = p 153 let StaticProgram _ channels _ = p
150 in do 154 in do
151 model' <- staticModelResource channels material texture model 155 model' <- staticModelResource channels material texture model
152 loadResource name staticModels addStaticModel (return model') 156 loadResource name staticModels addStaticModel (return model')
153 return () 157 return ()
154 True -> 158 True ->
155 case M.lookup prog $ animatedPrograms sceneRes of 159 case M.lookup prog $ animatedPrograms sceneRes of
156 Nothing -> (gameError $ "Animated shader program " ++ prog ++ " does not exist") >> return () 160 Nothing -> (gameError $ "Animated shader program " ++ prog ++ " does not exist") >> return ()
157 Just p -> 161 Just p ->
158 let AnimatedProgram _ channels _ = p 162 let AnimatedProgram _ channels _ = p
159 in do 163 in do
160 model' <- animatedModelResource channels material texture model 164 model' <- animatedModelResource channels material texture model
161 loadResource name animatedModels addAnimatedModel (return model') 165 loadResource name animatedModels addAnimatedModel (return model')
162 return () 166 return ()
163 167
164loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Game s Model 168loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Game s Model
165loadModel' file rotation scale = do 169loadModel' file rotation scale = do
166 let transform = 170 let transform =
167 (case rotation of 171 ( case rotation of
168 Nothing -> Prelude.id 172 Nothing -> Prelude.id
169 Just rot -> rotateModel rot) . 173 Just rot -> rotateModel rot
170 174 )
171 (case scale of 175 . ( case scale of
172 Nothing -> Prelude.id 176 Nothing -> Prelude.id
173 Just s -> flip Model.transformVerts $ 177 Just s -> flip Model.transformVerts $
174 \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z')) 178 \(Vec3 x' y' z') -> Vec3 (x s * x') (y s * y') (z s * z')
179 )
175 180
176 (fmap transform $ Model.loadModel file) >>= gameIO . toGround 181 (fmap transform $ Model.loadModel file) >>= gameIO . toGround
177 182
178rotateModel :: Rotation -> Model -> Model 183rotateModel :: Rotation -> Model -> Model
179rotateModel (Rotation ax ay az order) model = 184rotateModel (Rotation ax ay az order) model =
180 let mat = case order of 185 let mat = case order of
181 XYZ -> rotZ az * rotY ay * rotX ax 186 XYZ -> rotZ az * rotY ay * rotX ax
182 XZY -> rotY ay * rotZ az * rotX ax 187 XZY -> rotY ay * rotZ az * rotX ax
183 YXZ -> rotZ az * rotX ax * rotY ay 188 YXZ -> rotZ az * rotX ax * rotY ay
184 YZX -> rotX ax * rotZ az * rotY ay 189 YZX -> rotX ax * rotZ az * rotY ay
185 ZXY -> rotY ay * rotX ax * rotZ az 190 ZXY -> rotY ay * rotX ax * rotZ az
186 ZYX -> rotX ax * rotY ay * rotZ az 191 ZYX -> rotX ax * rotY ay * rotZ az
187 normalMat = fastNormalMatrix mat 192 normalMat = fastNormalMatrix mat
188 193
189 vTransform (Vec3 x' y' z') = 194 vTransform (Vec3 x' y' z') =
190 let v = mat `M4.mulp` (vec3 x' y' z') in Vec3 (x v) (y v) (z v) 195 let v = mat `M4.mulp` (vec3 x' y' z') in Vec3 (x v) (y v) (z v)
191 196
192 nTransform (Vec3 x' y' z') = 197 nTransform (Vec3 x' y' z') =
193 let v = normalMat `M3.mul` (vec3 x' y' z') in Vec3 (x v) (y v) (z v) 198 let v = normalMat `M3.mul` (vec3 x' y' z') in Vec3 (x v) (y v) (z v)
194 in 199 in flip Model.transformVerts vTransform . flip Model.transformNormals nTransform $ model
195 flip Model.transformVerts vTransform . flip Model.transformNormals nTransform $ model
196 200
197loadTexture :: FilePath -> Loader GL.Texture 201loadTexture :: FilePath -> Loader GL.Texture
198loadTexture file = 202loadTexture file =
199 loadResource file textures addTexture $ 203 loadResource file textures addTexture $
200 GL.loadTextureImage file GL.gl_LINEAR GL.gl_LINEAR 204 GL.loadTextureImage file GL.GL_LINEAR GL.GL_LINEAR
201 205
202newShaderProgram :: SceneGraph -> Loader () 206newShaderProgram :: SceneGraph -> Loader ()
203newShaderProgram (SceneLeaf _ props) = do 207newShaderProgram (SceneLeaf _ props) = do
204 (vsName, vertShader) <- Spear.Scene.Loader.loadShader GL.VertexShader props 208 (vsName, vertShader) <- Spear.Scene.Loader.loadShader GL.VertexShader props
205 (fsName, fragShader) <- Spear.Scene.Loader.loadShader GL.FragmentShader props 209 (fsName, fragShader) <- Spear.Scene.Loader.loadShader GL.FragmentShader props
206 name <- asString $ mandatory' "name" props 210 name <- asString $ mandatory' "name" props
207 stype <- asString $ mandatory' "type" props 211 stype <- asString $ mandatory' "type" props
208 prog <- GL.newProgram [vertShader, fragShader] 212 prog <- GL.newProgram [vertShader, fragShader]
209 213
210 let getUniformLoc name = (gameIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name 214 let getUniformLoc name = (gameIO . SV.get $ GL.uniformLocation prog name) `GL.assertGL` name
211 215
212 case stype of 216 case stype of
213 "static" -> do 217 "static" -> do
214 ambient <- asString $ mandatory' "ambient" props 218 ambient <- asString $ mandatory' "ambient" props
215 diffuse <- asString $ mandatory' "diffuse" props 219 diffuse <- asString $ mandatory' "diffuse" props
216 specular <- asString $ mandatory' "specular" props 220 specular <- asString $ mandatory' "specular" props
217 shininess <- asString $ mandatory' "shininess" props 221 shininess <- asString $ mandatory' "shininess" props
218 texture <- asString $ mandatory' "texture" props 222 texture <- asString $ mandatory' "texture" props
219 modelview <- asString $ mandatory' "modelview" props 223 modelview <- asString $ mandatory' "modelview" props
220 normalmat <- asString $ mandatory' "normalmat" props 224 normalmat <- asString $ mandatory' "normalmat" props
221 projection <- asString $ mandatory' "projection" props 225 projection <- asString $ mandatory' "projection" props
222 226
223 ka <- getUniformLoc ambient 227 ka <- getUniformLoc ambient
224 kd <- getUniformLoc diffuse 228 kd <- getUniformLoc diffuse
225 ks <- getUniformLoc specular 229 ks <- getUniformLoc specular
226 shi <- getUniformLoc shininess 230 shi <- getUniformLoc shininess
227 tex <- getUniformLoc texture 231 tex <- getUniformLoc texture
228 mview <- getUniformLoc modelview 232 mview <- getUniformLoc modelview
229 nmat <- getUniformLoc normalmat 233 nmat <- getUniformLoc normalmat
230 proj <- getUniformLoc projection 234 proj <- getUniformLoc projection
231 235
232 vertChan <- fmap read $ asString $ mandatory' "vertex-channel" props 236 vertChan <- fmap read $ asString $ mandatory' "vertex-channel" props
233 normChan <- fmap read $ asString $ mandatory' "normal-channel" props 237 normChan <- fmap read $ asString $ mandatory' "normal-channel" props
234 texChan <- fmap read $ asString $ mandatory' "texture-channel" props 238 texChan <- fmap read $ asString $ mandatory' "texture-channel" props
235 239
236 let channels = StaticProgramChannels vertChan normChan texChan 240 let channels = StaticProgramChannels vertChan normChan texChan
237 uniforms = StaticProgramUniforms ka kd ks shi tex mview nmat proj 241 uniforms = StaticProgramUniforms ka kd ks shi tex mview nmat proj
238 242
239 loadResource name staticPrograms addStaticProgram $ 243 loadResource name staticPrograms addStaticProgram $
240 return $ StaticProgram prog channels uniforms 244 return $ StaticProgram prog channels uniforms
241 return () 245 return ()
242 246 "animated" -> do
243 "animated" -> do 247 ambient <- asString $ mandatory' "ambient" props
244 ambient <- asString $ mandatory' "ambient" props 248 diffuse <- asString $ mandatory' "diffuse" props
245 diffuse <- asString $ mandatory' "diffuse" props 249 specular <- asString $ mandatory' "specular" props
246 specular <- asString $ mandatory' "specular" props 250 shininess <- asString $ mandatory' "shininess" props
247 shininess <- asString $ mandatory' "shininess" props 251 texture <- asString $ mandatory' "texture" props
248 texture <- asString $ mandatory' "texture" props 252 modelview <- asString $ mandatory' "modelview" props
249 modelview <- asString $ mandatory' "modelview" props 253 normalmat <- asString $ mandatory' "normalmat" props
250 normalmat <- asString $ mandatory' "normalmat" props 254 projection <- asString $ mandatory' "projection" props
251 projection <- asString $ mandatory' "projection" props 255
252 256 ka <- getUniformLoc ambient
253 ka <- getUniformLoc ambient 257 kd <- getUniformLoc diffuse
254 kd <- getUniformLoc diffuse 258 ks <- getUniformLoc specular
255 ks <- getUniformLoc specular 259 shi <- getUniformLoc shininess
256 shi <- getUniformLoc shininess 260 tex <- getUniformLoc texture
257 tex <- getUniformLoc texture 261 mview <- getUniformLoc modelview
258 mview <- getUniformLoc modelview 262 nmat <- getUniformLoc normalmat
259 nmat <- getUniformLoc normalmat 263 proj <- getUniformLoc projection
260 proj <- getUniformLoc projection 264
261 265 vertChan1 <- fmap read $ asString $ mandatory' "vertex-channel1" props
262 vertChan1 <- fmap read $ asString $ mandatory' "vertex-channel1" props 266 vertChan2 <- fmap read $ asString $ mandatory' "vertex-channel2" props
263 vertChan2 <- fmap read $ asString $ mandatory' "vertex-channel2" props 267 normChan1 <- fmap read $ asString $ mandatory' "normal-channel1" props
264 normChan1 <- fmap read $ asString $ mandatory' "normal-channel1" props 268 normChan2 <- fmap read $ asString $ mandatory' "normal-channel2" props
265 normChan2 <- fmap read $ asString $ mandatory' "normal-channel2" props 269 texChan <- fmap read $ asString $ mandatory' "texture-channel" props
266 texChan <- fmap read $ asString $ mandatory' "texture-channel" props 270 fp <- asString $ mandatory' "fp" props
267 fp <- asString $ mandatory' "fp" props 271 p <- getUniformLoc fp
268 p <- getUniformLoc fp 272
269 273 let channels = AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan
270 let channels = AnimatedProgramChannels vertChan1 vertChan2 normChan1 normChan2 texChan 274 uniforms = AnimatedProgramUniforms ka kd ks shi tex p mview nmat proj
271 uniforms = AnimatedProgramUniforms ka kd ks shi tex p mview nmat proj 275
272 276 loadResource name animatedPrograms addAnimatedProgram $
273 loadResource name animatedPrograms addAnimatedProgram $ 277 return $ AnimatedProgram prog channels uniforms
274 return $ AnimatedProgram prog channels uniforms 278 return ()
275 return () 279 _ -> do
276 280 loadResource name customPrograms addCustomProgram $ return prog
277 _ -> do 281 return ()
278 loadResource name customPrograms addCustomProgram $ return prog
279 return ()
280 282
281loadShader :: GL.ShaderType -> [Property] -> Loader (String, GL.GLSLShader) 283loadShader :: GL.ShaderType -> [Property] -> Loader (String, GL.GLSLShader)
282loadShader _ [] = gameError $ "Loader::vertexShader: empty list" 284loadShader _ [] = gameError $ "Loader::vertexShader: empty list"
283loadShader shaderType ((stype, file):xs) = 285loadShader shaderType ((stype, file) : xs) =
284 if shaderType == GL.VertexShader && stype == "vertex-shader" || 286 if shaderType == GL.VertexShader && stype == "vertex-shader"
285 shaderType == GL.FragmentShader && stype == "fragment-shader" 287 || shaderType == GL.FragmentShader && stype == "fragment-shader"
286 then let f = concat file 288 then
287 in loadShader' f shaderType >>= \shader -> return (f, shader) 289 let f = concat file
290 in loadShader' f shaderType >>= \shader -> return (f, shader)
288 else Spear.Scene.Loader.loadShader shaderType xs 291 else Spear.Scene.Loader.loadShader shaderType xs
289 292
290loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader 293loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader
@@ -297,17 +300,17 @@ loadShader' file shaderType = loadResource file shaders addShader $ GL.loadShade
297-- Get the value of the given key. 300-- Get the value of the given key.
298value :: String -> [Property] -> Maybe [String] 301value :: String -> [Property] -> Maybe [String]
299value name props = case L.find ((==) name . fst) props of 302value name props = case L.find ((==) name . fst) props of
300 Nothing -> Nothing 303 Nothing -> Nothing
301 Just prop -> Just . snd $ prop 304 Just prop -> Just . snd $ prop
302 305
303unspecified :: Maybe a -> a -> a 306unspecified :: Maybe a -> a -> a
304unspecified (Just x) _ = x 307unspecified (Just x) _ = x
305unspecified Nothing x = x 308unspecified Nothing x = x
306 309
307mandatory :: String -> [Property] -> Game s [String] 310mandatory :: String -> [Property] -> Game s [String]
308mandatory name props = case value name props of 311mandatory name props = case value name props of
309 Nothing -> gameError $ "Loader::mandatory: key not found: " ++ name 312 Nothing -> gameError $ "Loader::mandatory: key not found: " ++ name
310 Just x -> return x 313 Just x -> return x
311 314
312mandatory' :: String -> [Property] -> Loader [String] 315mandatory' :: String -> [Property] -> Loader [String]
313mandatory' name props = mandatory name props 316mandatory' name props = mandatory name props
@@ -320,31 +323,35 @@ asFloat = fmap (read . concat)
320 323
321asVec2 :: Functor f => f [String] -> f Vector2 324asVec2 :: Functor f => f [String] -> f Vector2
322asVec2 val = fmap toVec2 val 325asVec2 val = fmap toVec2 val
323 where toVec2 (x:y:_) = vec2 (read x) (read y) 326 where
324 toVec2 (x:[]) = let x' = read x in vec2 x' x' 327 toVec2 (x : y : _) = vec2 (read x) (read y)
328 toVec2 (x : []) = let x' = read x in vec2 x' x'
325 329
326asVec3 :: Functor f => f [String] -> f Vector3 330asVec3 :: Functor f => f [String] -> f Vector3
327asVec3 val = fmap toVec3 val 331asVec3 val = fmap toVec3 val
328 where toVec3 (x:y:z:_) = vec3 (read x) (read y) (read z) 332 where
329 toVec3 (x:[]) = let x' = read x in vec3 x' x' x' 333 toVec3 (x : y : z : _) = vec3 (read x) (read y) (read z)
334 toVec3 (x : []) = let x' = read x in vec3 x' x' x'
330 335
331asVec4 :: Functor f => f [String] -> f Vector4 336asVec4 :: Functor f => f [String] -> f Vector4
332asVec4 val = fmap toVec4 val 337asVec4 val = fmap toVec4 val
333 where toVec4 (x:y:z:w:_) = vec4 (read x) (read y) (read z) (read w) 338 where
334 toVec4 (x:[]) = let x' = read x in vec4 x' x' x' x' 339 toVec4 (x : y : z : w : _) = vec4 (read x) (read y) (read z) (read w)
340 toVec4 (x : []) = let x' = read x in vec4 x' x' x' x'
335 341
336asRotation :: Functor f => f [String] -> f Rotation 342asRotation :: Functor f => f [String] -> f Rotation
337asRotation val = fmap parseRotation val 343asRotation val = fmap parseRotation val
338 where parseRotation (ax:ay:az:order:_) = Rotation (read ax) (read ay) (read az) (readOrder order) 344 where
345 parseRotation (ax : ay : az : order : _) = Rotation (read ax) (read ay) (read az) (readOrder order)
339 346
340data Rotation = Rotation 347data Rotation = Rotation
341 { ax :: Float 348 { ax :: Float,
342 , ay :: Float 349 ay :: Float,
343 , az :: Float 350 az :: Float,
344 , order :: RotationOrder 351 order :: RotationOrder
345 } 352 }
346 353
347data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving Eq 354data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving (Eq)
348 355
349readOrder :: String -> RotationOrder 356readOrder :: String -> RotationOrder
350readOrder "xyz" = XYZ 357readOrder "xyz" = XYZ
diff --git a/Spear/Step.hs b/Spear/Step.hs
index 26dfdc0..7419d9e 100644
--- a/Spear/Step.hs
+++ b/Spear/Step.hs
@@ -1,52 +1,60 @@
1{-# LANGUAGE FlexibleInstances #-} 1{-# LANGUAGE FlexibleInstances #-}
2
2module Spear.Step 3module Spear.Step
3( 4 ( -- * Definitions
4 -- * Definitions 5 Step,
5 Step 6 Elapsed,
6, Elapsed 7 Dt,
7, Dt 8
8 -- * Running 9 -- * Running
9, runStep 10 runStep,
11
10 -- * Constructors 12 -- * Constructors
11, step 13 step,
12, sid 14 sid,
13, spure 15 spure,
14, sfst 16 sfst,
15, ssnd 17 ssnd,
16, sfold 18 sfold,
19
17 -- * Combinators 20 -- * Combinators
18, (.>) 21 (.>),
19, (<.) 22 (<.),
20, szip 23 szip,
21, switch 24 switch,
22, multiSwitch 25 multiSwitch,
23) 26 )
24where 27where
25 28
26import Data.List (foldl') 29import Data.List (foldl')
27import qualified Data.Map as Map
28import Data.Map (Map) 30import Data.Map (Map)
31import qualified Data.Map as Map
29import Data.Monoid 32import Data.Monoid
30 33
31type Elapsed = Double 34type Elapsed = Double
35
32type Dt = Float 36type Dt = Float
33 37
34-- | A step function. 38-- | A step function.
35data Step s e a b = 39newtype Step state events input a = Step
36 Step { runStep :: Elapsed -> Dt -> s -> e -> a -> (b, Step s e a b) } 40 { runStep :: Elapsed -> Dt -> state -> events -> input -> (a, Step state events input a)
41 }
37 42
38instance Functor (Step s e a) where 43instance Functor (Step s e a) where
39 fmap f (Step s1) = Step $ \elapsed dt g e x -> 44 fmap f (Step s1) = Step $ \elapsed dt g e x ->
40 let (a, s') = s1 elapsed dt g e x 45 let (a, s') = s1 elapsed dt g e x
41 in (f a, fmap f s') 46 in (f a, fmap f s')
47
48instance Semigroup (Step s e a a) where
49 (<>) = (.>)
42 50
43instance Monoid (Step s e a a) where 51instance Monoid (Step s e a a) where
44 mempty = sid 52 mempty = sid
45 53
46 mappend (Step s1) (Step s2) = Step $ \elapsed dt g e a -> 54 mappend (Step s1) (Step s2) = Step $ \elapsed dt g e a ->
47 let (b, s1') = s1 elapsed dt g e a 55 let (b, s1') = s1 elapsed dt g e a
48 (c, s2') = s2 elapsed dt g e b 56 (c, s2') = s2 elapsed dt g e b
49 in (c, mappend s1' s2') 57 in (c, mappend s1' s2')
50 58
51-- | Construct a step from a function. 59-- | Construct a step from a function.
52step :: (Elapsed -> Dt -> s -> e -> a -> (b, Step s e a b)) -> Step s e a b 60step :: (Elapsed -> Dt -> s -> e -> a -> (b, Step s e a b)) -> Step s e a b
@@ -61,40 +69,47 @@ spure :: (a -> b) -> Step s e a b
61spure f = Step $ \_ _ _ _ x -> (f x, spure f) 69spure f = Step $ \_ _ _ _ x -> (f x, spure f)
62 70
63-- | The step that returns the first component in the tuple. 71-- | The step that returns the first component in the tuple.
64sfst :: Step s e (a,b) a 72sfst :: Step s e (a, b) a
65sfst = spure $ \(a,_) -> a 73sfst = spure $ \(a, _) -> a
66 74
67-- | The step that returns the second component in the tuple. 75-- | The step that returns the second component in the tuple.
68ssnd :: Step s e (a,b) b 76ssnd :: Step s e (a, b) b
69ssnd = spure $ \(_,b) -> b 77ssnd = spure $ \(_, b) -> b
70 78
71-- | Construct a step that folds a given list of inputs. 79-- | Construct a step that folds a given list of inputs.
72-- 80--
73-- The step is run N+1 times, where N is the size of the input list. 81-- The step is run N+1 times, where N is the size of the input list.
74sfold :: Step s (Maybe e) a a -> Step s [e] a a 82sfold :: Step s (Maybe e) a a -> Step s [e] a a
75sfold s = Step $ \elapsed dt g es a -> 83sfold s = Step $ \elapsed dt g es a ->
76 case es of 84 case es of
77 [] -> 85 [] ->
78 let (b',s') = runStep s elapsed dt g Nothing a 86 let (b', s') = runStep s elapsed dt g Nothing a
79 in (b', sfold s') 87 in (b', sfold s')
80 es -> 88 es ->
81 let (b',s') = sfold' elapsed dt g s a es 89 let (b', s') = sfold' elapsed dt g s a es
82 in (b', sfold s') 90 in (b', sfold s')
83 91
84sfold' :: Elapsed -> Dt -> s -> Step s (Maybe e) a a -> a -> [e] 92sfold' ::
85 -> (a, Step s (Maybe e) a a) 93 Elapsed ->
86sfold' elapsed dt g s a es = foldl' f (a',s') es 94 Dt ->
87 where f (a,s) e = runStep s elapsed dt g (Just e) a 95 s ->
88 (a',s') = runStep s elapsed dt g Nothing a 96 Step s (Maybe e) a a ->
97 a ->
98 [e] ->
99 (a, Step s (Maybe e) a a)
100sfold' elapsed dt g s a es = foldl' f (a', s') es
101 where
102 f (a, s) e = runStep s elapsed dt g (Just e) a
103 (a', s') = runStep s elapsed dt g Nothing a
89 104
90-- Combinators 105-- Combinators
91 106
92-- | Compose two steps. 107-- | Compose two steps.
93(.>) :: Step s e a b -> Step s e b c -> Step s e a c 108(.>) :: Step s e a b -> Step s e b c -> Step s e a c
94(Step s1) .> (Step s2) = Step $ \elapsed dt g e a -> 109(Step s1) .> (Step s2) = Step $ \elapsed dt g e a ->
95 let (b, s1') = s1 elapsed dt g e a 110 let (b, s1') = s1 elapsed dt g e a
96 (c, s2') = s2 elapsed dt g e b 111 (c, s2') = s2 elapsed dt g e b
97 in (c, s1' .> s2') 112 in (c, s1' .> s2')
98 113
99-- | Compose two steps. 114-- | Compose two steps.
100(<.) :: Step s e a b -> Step s e c a -> Step s e c b 115(<.) :: Step s e a b -> Step s e c a -> Step s e c b
@@ -103,53 +118,67 @@ sfold' elapsed dt g s a es = foldl' f (a',s') es
103-- | Evaluate two steps and zip their results. 118-- | Evaluate two steps and zip their results.
104szip :: (a -> b -> c) -> Step s e d a -> Step s e d b -> Step s e d c 119szip :: (a -> b -> c) -> Step s e d a -> Step s e d b -> Step s e d c
105szip f (Step s1) (Step s2) = Step $ \elapsed dt g e d -> 120szip f (Step s1) (Step s2) = Step $ \elapsed dt g e d ->
106 let (a, s1') = s1 elapsed dt g e d 121 let (a, s1') = s1 elapsed dt g e d
107 (b, s2') = s2 elapsed dt g e d 122 (b, s2') = s2 elapsed dt g e d
108 in (f a b, szip f s1' s2') 123 in (f a b, szip f s1' s2')
109 124
110-- | Construct a step that switches between two steps based on input. 125-- | Construct a step that switches between two steps based on input.
111-- 126--
112-- The initial step is the first one. 127-- The initial step is the first one.
113switch :: Eq e 128switch ::
114 => e -> (Step s (Maybe e) a a) 129 Eq e =>
115 -> e -> (Step s (Maybe e) a a) 130 e ->
116 -> Step s (Maybe e) a a 131 (Step s (Maybe e) a a) ->
132 e ->
133 (Step s (Maybe e) a a) ->
134 Step s (Maybe e) a a
117switch flag1 s1 flag2 s2 = switch' s1 flag1 s1 flag2 s2 135switch flag1 s1 flag2 s2 = switch' s1 flag1 s1 flag2 s2
118 136
119switch' :: Eq e 137switch' ::
120 => (Step s (Maybe e) a a) 138 Eq e =>
121 -> e -> (Step s (Maybe e) a a) 139 (Step s (Maybe e) a a) ->
122 -> e -> (Step s (Maybe e) a a) 140 e ->
123 -> Step s (Maybe e) a a 141 (Step s (Maybe e) a a) ->
142 e ->
143 (Step s (Maybe e) a a) ->
144 Step s (Maybe e) a a
124switch' cur flag1 s1 flag2 s2 = Step $ \elapsed dt g e a -> 145switch' cur flag1 s1 flag2 s2 = Step $ \elapsed dt g e a ->
125 case e of 146 case e of
126 Nothing -> 147 Nothing ->
127 let (a',s') = runStep cur elapsed dt g Nothing a 148 let (a', s') = runStep cur elapsed dt g Nothing a
128 in (a', switch' s' flag1 s1 flag2 s2) 149 in (a', switch' s' flag1 s1 flag2 s2)
129 Just e' -> 150 Just e' ->
130 let next = if e' == flag1 then s1 151 let next =
131 else if e' == flag2 then s2 152 if e' == flag1
132 else cur 153 then s1
133 (a',s') = runStep next elapsed dt g e a 154 else
134 in (a', switch' s' flag1 s1 flag2 s2) 155 if e' == flag2
156 then s2
157 else cur
158 (a', s') = runStep next elapsed dt g e a
159 in (a', switch' s' flag1 s1 flag2 s2)
135 160
136-- | Construct a step that switches among multiple steps based on input. 161-- | Construct a step that switches among multiple steps based on input.
137multiSwitch :: (Eq e, Ord e) => [(e, Step s (Maybe e) a a)] -> Step s (Maybe e) a a 162multiSwitch :: (Eq e, Ord e) => [(e, Step s (Maybe e) a a)] -> Step s (Maybe e) a a
138multiSwitch xs = multiSwitch' Nothing sid (Map.fromList xs) 163multiSwitch xs = multiSwitch' Nothing sid (Map.fromList xs)
139 164
140multiSwitch' :: (Eq e, Ord e) 165multiSwitch' ::
141 => Maybe e -> Step s (Maybe e) a a -> Map e (Step s (Maybe e) a a) 166 (Eq e, Ord e) =>
142 -> Step s (Maybe e) a a 167 Maybe e ->
168 Step s (Maybe e) a a ->
169 Map e (Step s (Maybe e) a a) ->
170 Step s (Maybe e) a a
143multiSwitch' curKey cur m = Step $ \elapsed dt g e a -> 171multiSwitch' curKey cur m = Step $ \elapsed dt g e a ->
144 let singleStep = let (a',s') = runStep cur elapsed dt g e a 172 let singleStep =
145 in (a', multiSwitch' curKey s' m) 173 let (a', s') = runStep cur elapsed dt g e a
146 in case e of 174 in (a', multiSwitch' curKey s' m)
147 Nothing -> singleStep 175 in case e of
148 Just e' -> case Map.lookup e' m of 176 Nothing -> singleStep
149 Nothing -> singleStep 177 Just e' -> case Map.lookup e' m of
150 Just s -> 178 Nothing -> singleStep
151 let (a',s') = runStep s elapsed dt g e a 179 Just s ->
152 m' = case curKey of 180 let (a', s') = runStep s elapsed dt g e a
153 Nothing -> m 181 m' = case curKey of
154 Just key -> Map.insert key cur m 182 Nothing -> m
155 in (a', multiSwitch' e s' m') \ No newline at end of file 183 Just key -> Map.insert key cur m
184 in (a', multiSwitch' e s' m')
diff --git a/Spear/Sys/Timer.hsc b/Spear/Sys/Timer.hsc
index 60ae9d7..85718ce 100644
--- a/Spear/Sys/Timer.hsc
+++ b/Spear/Sys/Timer.hsc
@@ -45,7 +45,7 @@ instance Storable Timer where
45 45
46 peek ptr = do 46 peek ptr = do
47 baseTime <- #{peek Timer, baseTime} ptr 47 baseTime <- #{peek Timer, baseTime} ptr
48 pausedTime <- #{peek Timer, pausedTime} ptr 48 pausedTime <- #{peek Timer, pausedTime} ptr
49 stopTime <- #{peek Timer, stopTime} ptr 49 stopTime <- #{peek Timer, stopTime} ptr
50 prevTime <- #{peek Timer, prevTime} ptr 50 prevTime <- #{peek Timer, prevTime} ptr
51 curTime <- #{peek Timer, curTime} ptr 51 curTime <- #{peek Timer, curTime} ptr
@@ -63,31 +63,31 @@ instance Storable Timer where
63 #{poke Timer, stopped} ptr stopped 63 #{poke Timer, stopped} ptr stopped
64 64
65foreign import ccall unsafe "Timer.h timer_init" 65foreign import ccall unsafe "Timer.h timer_init"
66 c_timer_init :: Ptr Timer -> IO () 66 c_timer_init :: Ptr Timer -> IO ()
67 67
68foreign import ccall unsafe "Timer.h timer_tick" 68foreign import ccall unsafe "Timer.h timer_tick"
69 c_timer_tick :: Ptr Timer -> IO () 69 c_timer_tick :: Ptr Timer -> IO ()
70 70
71foreign import ccall unsafe "Timer.h timer_start" 71foreign import ccall unsafe "Timer.h timer_start"
72 c_timer_start :: Ptr Timer -> IO () 72 c_timer_start :: Ptr Timer -> IO ()
73 73
74foreign import ccall unsafe "Timer.h timer_stop" 74foreign import ccall unsafe "Timer.h timer_stop"
75 c_timer_stop :: Ptr Timer -> IO () 75 c_timer_stop :: Ptr Timer -> IO ()
76 76
77foreign import ccall unsafe "Timer.h timer_reset" 77foreign import ccall unsafe "Timer.h timer_reset"
78 c_timer_reset :: Ptr Timer -> IO () 78 c_timer_reset :: Ptr Timer -> IO ()
79 79
80foreign import ccall unsafe "Timer.h timer_get_time" 80foreign import ccall unsafe "Timer.h timer_get_time"
81 c_timer_get_time :: Ptr Timer -> IO (CDouble) 81 c_timer_get_time :: Ptr Timer -> IO (CDouble)
82 82
83foreign import ccall unsafe "Timer.h timer_get_delta" 83foreign import ccall unsafe "Timer.h timer_get_delta"
84 c_timer_get_delta :: Ptr Timer -> IO (CFloat) 84 c_timer_get_delta :: Ptr Timer -> IO (CFloat)
85 85
86foreign import ccall unsafe "Timer.h timer_is_running" 86foreign import ccall unsafe "Timer.h timer_is_running"
87 c_timer_is_running :: Ptr Timer -> IO (CChar) 87 c_timer_is_running :: Ptr Timer -> IO (CChar)
88 88
89foreign import ccall "Timer.h timer_sleep" 89foreign import ccall "Timer.h timer_sleep"
90 c_timer_sleep :: CFloat -> IO () 90 c_timer_sleep :: CFloat -> IO ()
91 91
92-- | Construct a new timer. 92-- | Construct a new timer.
93newTimer :: Timer 93newTimer :: Timer
@@ -105,10 +105,10 @@ tick t = alloca $ \tptr -> do
105-- | Start the timer. 105-- | Start the timer.
106start :: Timer -> IO (Timer) 106start :: Timer -> IO (Timer)
107start t = alloca $ \tptr -> do 107start t = alloca $ \tptr -> do
108 poke tptr t 108 poke tptr t
109 c_timer_start tptr 109 c_timer_start tptr
110 t' <- peek tptr 110 t' <- peek tptr
111 return t' 111 return t'
112 112
113-- | Stop the timer. 113-- | Stop the timer.
114stop :: Timer -> IO (Timer) 114stop :: Timer -> IO (Timer)
@@ -120,30 +120,30 @@ stop t = alloca $ \tptr -> do
120-- | Reset the timer. 120-- | Reset the timer.
121reset :: Timer -> IO (Timer) 121reset :: Timer -> IO (Timer)
122reset t = alloca $ \tptr -> do 122reset t = alloca $ \tptr -> do
123 poke tptr t 123 poke tptr t
124 c_timer_reset tptr 124 c_timer_reset tptr
125 peek tptr 125 peek tptr
126 126
127-- | Get the timer's total running time. 127-- | Get the timer's total running time.
128getTime :: Timer -> Double 128getTime :: Timer -> Double
129getTime t = unsafeDupablePerformIO . alloca $ \tptr -> do 129getTime t = unsafeDupablePerformIO . alloca $ \tptr -> do
130 poke tptr t 130 poke tptr t
131 time <- c_timer_get_time tptr 131 time <- c_timer_get_time tptr
132 return (realToFrac time) 132 return (realToFrac time)
133 133
134-- | Get the time elapsed between the last two ticks. 134-- | Get the time elapsed between the last two ticks.
135getDelta :: Timer -> Float 135getDelta :: Timer -> Float
136getDelta t = unsafeDupablePerformIO . alloca $ \tptr -> do 136getDelta t = unsafeDupablePerformIO . alloca $ \tptr -> do
137 poke tptr t 137 poke tptr t
138 dt <- c_timer_get_delta tptr 138 dt <- c_timer_get_delta tptr
139 return (realToFrac dt) 139 return (realToFrac dt)
140 140
141-- | Return true if the timer is running (not stopped), false otherwise. 141-- | Return true if the timer is running (not stopped), false otherwise.
142isRunning :: Timer -> Bool 142isRunning :: Timer -> Bool
143isRunning t = unsafeDupablePerformIO . alloca $ \tptr -> do 143isRunning t = unsafeDupablePerformIO . alloca $ \tptr -> do
144 poke tptr t 144 poke tptr t
145 running <- c_timer_is_running tptr 145 running <- c_timer_is_running tptr
146 return (running /= 0) 146 return (running /= 0)
147 147
148-- | Put the caller thread to sleep for the given number of seconds. 148-- | Put the caller thread to sleep for the given number of seconds.
149sleep :: Float -> IO () 149sleep :: Float -> IO ()
diff --git a/Spear/Window.hs b/Spear/Window.hs
index 2e06d72..85a3dc8 100644
--- a/Spear/Window.hs
+++ b/Spear/Window.hs
@@ -1,53 +1,55 @@
1module Spear.Window 1module Spear.Window
2( 2 ( -- * Setup
3 -- * Setup 3 Dimensions,
4 Dimensions 4 Context,
5, Context 5 WindowTitle,
6, WindowTitle 6 FrameCap,
7, FrameCap 7
8, DisplayBits(..)
9, WindowMode(..)
10 -- * Window 8 -- * Window
11, Window 9 Window,
12, Width 10 Width,
13, Height 11 Height,
14, Init 12 Init,
15, run 13 withWindow,
16, withWindow 14 events,
17, events 15
18 -- * Animation 16 -- * Animation
19, Elapsed 17 Elapsed,
20, Dt 18 Dt,
21, Step 19 Step,
22, loop 20 loop,
23, GLFW.swapBuffers 21 GLFW.swapBuffers,
22
24 -- * Input 23 -- * Input
25, whenKeyDown 24 whenKeyDown,
26, whenKeyUp 25 whenKeyUp,
27, processKeys 26 processKeys,
28, processButtons 27 processButtons,
29, InputEvent(..) 28 InputEvent (..),
30, Key(..) 29 Key (..),
31, MouseButton(..) 30 MouseButton (..),
32, MouseProp(..) 31 MouseProp (..),
33, MousePos 32 MousePos,
34, MouseDelta 33 MouseDelta,
35) 34 )
36where 35where
37 36
38import Spear.Game
39import Spear.Sys.Timer as Timer
40
41import Data.Char (ord)
42import Control.Concurrent.MVar 37import Control.Concurrent.MVar
43import Control.Monad (when, foldM) 38import Control.Exception
39import Control.Monad (foldM, unless, void, when)
44import Control.Monad.IO.Class 40import Control.Monad.IO.Class
41import Data.Char (ord)
42import Data.Maybe (fromJust, fromMaybe, isJust)
45import GHC.Float 43import GHC.Float
46import qualified Graphics.UI.GLFW as GLFW
47import Graphics.UI.GLFW (DisplayBits(..), WindowMode(..))
48import qualified Graphics.Rendering.OpenGL as GL 44import qualified Graphics.Rendering.OpenGL as GL
45import qualified Graphics.UI.GLFW as GLFW
46import Spear.Game
47import Spear.Sys.Timer as Timer
48
49maxFPS = 60
50
51type Width = Int
49 52
50type Width = Int
51type Height = Int 53type Height = Int
52 54
53-- | Window dimensions. 55-- | Window dimensions.
@@ -62,85 +64,75 @@ type CloseRequest = MVar Bool
62 64
63-- | A window. 65-- | A window.
64data Window = Window 66data Window = Window
65 { closeRequest :: CloseRequest 67 { glfwWindow :: GLFW.Window,
66 , inputEvents :: MVar [InputEvent] 68 closeRequest :: CloseRequest,
67 } 69 inputEvents :: MVar [InputEvent]
70 }
68 71
69-- | Poll the window's events. 72-- | Poll the window's events.
70events :: MonadIO m => Window -> m [InputEvent] 73events :: MonadIO m => Window -> m [InputEvent]
71events wnd = liftIO $ do 74events window = liftIO $ do
72 es <- tryTakeMVar (inputEvents wnd) >>= \xs -> case xs of 75 es <-
73 Nothing -> return [] 76 tryTakeMVar (inputEvents window) >>= \xs -> case xs of
74 Just es -> return es 77 Nothing -> return []
75 putMVar (inputEvents wnd) [] 78 Just es -> return es
76 return es 79 putMVar (inputEvents window) []
80 return es
77 81
78-- | Game initialiser. 82-- | Game initialiser.
79type Init s = Window -> Game () s 83type Init s = Window -> Game () s
80 84
81run :: MonadIO m => m (Either String a) -> m () 85withWindow ::
82run r = do 86 Dimensions ->
83 result <- r 87 Context ->
84 case result of 88 Maybe WindowTitle ->
85 Left err -> liftIO $ putStrLn err 89 Init s ->
86 Right _ -> return () 90 (Window -> Game s a) ->
87 91 IO a
88withWindow :: MonadIO m 92withWindow dim@(w, h) glVersion windowTitle init run = do
89 => Dimensions -> [DisplayBits] -> WindowMode -> Context 93 flip runGame' () $ do
90 -> Maybe WindowTitle 94 glfwInit
91 -> Init s 95 window <- setup dim glVersion windowTitle
92 -> (Window -> Game s a) 96 gameIO $ GLFW.makeContextCurrent (Just . glfwWindow $ window)
93 -> m (Either String a) 97 gameState <- init window
94withWindow dim@(w,h) displayBits windowMode glVersion windowTitle init run = 98 result <- evalSubGame (run window) gameState
95 liftIO $ flip runGame' () $ do 99 gameIO $ do
96 glfwInit 100 GLFW.destroyWindow $ glfwWindow window
97 wnd <- setup dim displayBits windowMode glVersion windowTitle 101 GLFW.terminate
98 gameState <- init wnd 102 return result
99 result <- evalSubGame (run wnd) gameState 103
100 gameIO GLFW.closeWindow 104setup ::
101 gameIO GLFW.terminate 105 Dimensions ->
102 return result 106 Context ->
103 107 Maybe WindowTitle ->
104setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle 108 Game s Window
105 -> Game s Window 109setup (w, h) (major, minor) windowTitle = do
106setup (w, h) displayBits windowMode (major, minor) wndTitle = do 110 closeRequest <- gameIO newEmptyMVar
107 closeRequest <- liftIO newEmptyMVar 111 inputEvents <- gameIO newEmptyMVar
108 inputEvents <- liftIO newEmptyMVar 112 let onResize' = onResize inputEvents
109 let onResize' = onResize inputEvents 113 let title = fromMaybe "" windowTitle
110 let dimensions = GL.Size (fromIntegral w) (fromIntegral h) 114 let monitor = Nothing
111 result <- liftIO $ do 115 maybeWindow <- gameIO $ do
112 GLFW.openWindowHint GLFW.OpenGLVersionMajor major 116 GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor major
113 GLFW.openWindowHint GLFW.OpenGLVersionMinor minor 117 GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor minor
114 compat (major, minor) 118 when (major >= 3) $ GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Compat
115 GLFW.disableSpecial GLFW.AutoPollEvent 119 GLFW.createWindow w h title monitor Nothing
116 GLFW.openWindow dimensions (defaultBits displayBits) windowMode 120 unless (isJust maybeWindow) $ gameError "GLFW.openWindow failed"
117 when (not result) $ gameError "GLFW.openWindow failed" 121 let window = fromJust maybeWindow
118 liftIO $ do 122 liftIO $ do
119 GLFW.windowTitle GL.$= case wndTitle of 123 GLFW.setWindowCloseCallback window . Just $ onWindowClose closeRequest
120 Nothing -> "Spear Game Framework" 124 GLFW.setWindowSizeCallback window . Just $ onResize'
121 Just title -> title 125 GLFW.setKeyCallback window . Just $ onKey inputEvents
122 GLFW.windowCloseCallback GL.$= (onWindowClose closeRequest) 126 GLFW.setCharCallback window . Just $ onChar inputEvents
123 GLFW.windowSizeCallback GL.$= onResize' 127 GLFW.setMouseButtonCallback window . Just $ onMouseButton inputEvents
124 GLFW.keyCallback GL.$= onKey inputEvents 128 onMouseMove inputEvents >>= GLFW.setCursorPosCallback window . Just
125 GLFW.charCallback GL.$= onChar inputEvents 129 onResize' window w h
126 GLFW.mouseButtonCallback GL.$= onMouseButton inputEvents 130 return $ Spear.Window.Window window closeRequest inputEvents
127 onMouseMove inputEvents >>= (GLFW.mousePosCallback GL.$=)
128 onResize' (GL.Size (fromIntegral w) (fromIntegral h))
129 return $ Spear.Window.Window closeRequest inputEvents
130
131defaultBits [] = [DisplayRGBBits 8 8 8]
132defaultBits xs = xs
133
134compat (major, minor)
135 | major >= 3 = GLFW.openWindowHint GLFW.OpenGLProfile GLFW.OpenGLCompatProfile
136 | otherwise = return ()
137 131
138glfwInit :: Game s () 132glfwInit :: Game s ()
139glfwInit = do 133glfwInit = do
140 result <- liftIO GLFW.initialize 134 result <- gameIO GLFW.init
141 case result of 135 if result then return () else gameError "GLFW.initialize failed"
142 False -> gameError "GLFW.initialize failed"
143 True -> return ()
144 136
145-- | Time elapsed since the application started. 137-- | Time elapsed since the application started.
146type Elapsed = Double 138type Elapsed = Double
@@ -149,279 +141,331 @@ type Elapsed = Double
149type Dt = Float 141type Dt = Float
150 142
151-- | Return true if the application should continue running, false otherwise. 143-- | Return true if the application should continue running, false otherwise.
152type Step s = Elapsed -> Dt -> Game s (Bool) 144type Step s = Elapsed -> Dt -> Game s Bool
153 145
154-- | Maximum frame rate. 146-- | Maximum frame rate.
155type FrameCap = Int 147type FrameCap = Int
156 148
157-- | Run the application's main loop. 149loop :: Step s -> Window -> Game s ()
158loop :: Maybe FrameCap -> Step s -> Window -> Game s () 150loop step window = do
159loop (Just maxFPS) step wnd = loopCapped maxFPS step wnd 151 let ddt = 1.0 / fromIntegral maxFPS
160loop Nothing step wnd = do 152 closeReq = closeRequest window
161 timer <- gameIO $ start newTimer 153 frameTimer <- gameIO $ start newTimer
162 loop' (closeRequest wnd) timer 0 step 154 controlTimer <- gameIO $ start newTimer
163 return () 155 loop' window closeReq ddt frameTimer controlTimer 0 step
164 156 return ()
165loop' :: CloseRequest -> Timer -> Elapsed -> Step s -> Game s () 157
166loop' closeRequest timer elapsed step = do 158loop' ::
167 timer' <- gameIO $ tick timer 159 Window ->
168 let dt = getDelta timer' 160 CloseRequest ->
169 let elapsed' = elapsed + float2Double dt 161 Float ->
170 continue <- step elapsed' dt 162 Timer ->
171 close <- gameIO $ getRequest closeRequest 163 Timer ->
172 when (continue && (not close)) $ loop' closeRequest timer' elapsed' step 164 Elapsed ->
173 165 Step s ->
174loopCapped :: Int -> Step s -> Window -> Game s () 166 Game s ()
175loopCapped maxFPS step wnd = do 167loop' window closeRequest ddt frameTimer controlTimer elapsed step = do
176 let ddt = 1.0 / (fromIntegral maxFPS) 168 controlTimer' <- gameIO $ tick controlTimer
177 closeReq = closeRequest wnd 169 frameTimer' <- gameIO $ tick frameTimer
178 frameTimer <- gameIO $ start newTimer 170 let dt = getDelta frameTimer'
179 controlTimer <- gameIO $ start newTimer 171 let elapsed' = elapsed + float2Double dt
180 loopCapped' closeReq ddt frameTimer controlTimer 0 step 172 gameIO GLFW.pollEvents
181 return () 173 continue <- step elapsed' dt
182 174 gameIO . GLFW.swapBuffers $ glfwWindow window
183loopCapped' :: CloseRequest -> Float -> Timer -> Timer -> Elapsed -> Step s 175 close <- gameIO $ getRequest closeRequest
184 -> Game s () 176 controlTimer'' <- gameIO $ tick controlTimer'
185loopCapped' closeRequest ddt frameTimer controlTimer elapsed step = do 177 let dt = getDelta controlTimer''
186 controlTimer' <- gameIO $ tick controlTimer 178 when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt)
187 frameTimer' <- gameIO $ tick frameTimer 179 when (continue && not close) $
188 let dt = getDelta frameTimer' 180 loop'
189 let elapsed' = elapsed + float2Double dt 181 window
190 continue <- step elapsed' dt 182 closeRequest
191 close <- gameIO $ getRequest closeRequest 183 ddt
192 controlTimer'' <- gameIO $ tick controlTimer' 184 frameTimer'
193 let dt = getDelta controlTimer'' 185 controlTimer''
194 when (dt < ddt) $ gameIO $ Timer.sleep (ddt - dt) 186 elapsed'
195 when (continue && (not close)) $ 187 step
196 loopCapped' closeRequest ddt frameTimer' controlTimer''
197 elapsed' step
198 188
199getRequest :: MVar Bool -> IO Bool 189getRequest :: MVar Bool -> IO Bool
200getRequest mvar = tryTakeMVar mvar >>= \x -> return $ case x of 190getRequest mvar =
201 Nothing -> False 191 tryTakeMVar mvar >>= \x -> return $ fromMaybe False x
202 Just x -> x
203 192
204onWindowClose :: MVar Bool -> GLFW.WindowCloseCallback 193onWindowClose :: MVar Bool -> GLFW.WindowCloseCallback
205onWindowClose closeRequest = putMVar closeRequest True >> return False 194onWindowClose closeRequest window = do putMVar closeRequest True
206 195
207onResize :: MVar [InputEvent] -> GLFW.WindowSizeCallback 196onResize :: MVar [InputEvent] -> GLFW.WindowSizeCallback
208onResize es (GL.Size w h) = addEvent es $ Resize (fromIntegral w) (fromIntegral h) 197onResize events window w h = addEvent events $ Resize w h
209 198
210onKey :: MVar [InputEvent] -> GLFW.KeyCallback 199onKey :: MVar [InputEvent] -> GLFW.KeyCallback
211onKey es key GLFW.Press = addEvent es $ KeyDown (fromGLFWkey key) 200onKey events window key _ GLFW.KeyState'Pressed _ = addEvent events $ KeyDown (fromGLFWkey key)
212onKey es key GLFW.Release = addEvent es $ KeyUp (fromGLFWkey key) 201onKey events window key _ GLFW.KeyState'Released _ = addEvent events $ KeyUp (fromGLFWkey key)
202onKey events window key _ GLFW.KeyState'Repeating _ = return ()
213 203
214onChar :: MVar [InputEvent] -> GLFW.CharCallback 204onChar :: MVar [InputEvent] -> GLFW.CharCallback
215onChar es c GLFW.Press = addEvent es $ KeyDown (fromGLFWkey (GLFW.CharKey c)) 205onChar events window char = addEvent events $ KeyDown . fromGLFWkey . read $ [char]
216onChar es c GLFW.Release = addEvent es $ KeyUp (fromGLFWkey (GLFW.CharKey c))
217 206
218onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback 207onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback
219onMouseButton es bt GLFW.Press = addEvent es $ MouseDown (fromGLFWbutton bt) 208onMouseButton events window button GLFW.MouseButtonState'Pressed _ = addEvent events $ MouseDown (fromGLFWbutton button)
220onMouseButton es bt GLFW.Release = addEvent es $ MouseUp (fromGLFWbutton bt) 209onMouseButton events window button GLFW.MouseButtonState'Released _ = addEvent events $ MouseUp (fromGLFWbutton button)
221 210
222onMouseMove :: MVar [InputEvent] -> IO GLFW.MousePosCallback 211onMouseMove :: MVar [InputEvent] -> IO GLFW.CursorPosCallback
223onMouseMove es = newEmptyMVar >>= return . flip onMouseMove' es 212onMouseMove events = newEmptyMVar >>= return . flip onMouseMove' events
224 213
225onMouseMove' :: MVar MousePos -> MVar [InputEvent] -> GLFW.MousePosCallback 214onMouseMove' :: MVar MousePos -> MVar [InputEvent] -> GLFW.CursorPosCallback
226onMouseMove' oldPos es (GL.Position x y) = do 215onMouseMove' oldPos events window x y = do
227 let (x',y') = (fromIntegral x, fromIntegral y) 216 (old_x, old_y) <-
228 (old_x, old_y) <- tryTakeMVar oldPos >>= \x -> case x of 217 tryTakeMVar oldPos >>= \old -> case old of
229 Nothing -> return (x',y') 218 Nothing -> return (x, y)
230 Just p -> return p 219 Just p -> return p
231 let delta = (x'-old_x, y'-old_y) 220 let delta = (x - old_x, y - old_y)
232 putMVar oldPos (x',y') 221 putMVar oldPos (x, y)
233 addEvent es $ MouseMove (x',y') delta 222 addEvent events $ MouseMove (x, y) delta
234 223
235replaceMVar :: MVar a -> a -> IO () 224replaceMVar :: MVar a -> a -> IO ()
236replaceMVar mvar val = tryTakeMVar mvar >> putMVar mvar val 225replaceMVar mvar val = tryTakeMVar mvar >> putMVar mvar val
237 226
238addEvent :: MVar [a] -> a -> IO () 227addEvent :: MVar [a] -> a -> IO ()
239addEvent mvar val = tryTakeMVar mvar >>= \xs -> case xs of 228addEvent mvar val =
240 Nothing -> putMVar mvar [val] 229 tryTakeMVar mvar >>= \xs -> case xs of
241 Just es -> putMVar mvar (val:es) 230 Nothing -> putMVar mvar [val]
231 Just events -> putMVar mvar (val : events)
242 232
243-- Input 233-- Input
244 234
245-- | Run the game action when the key is down. 235-- | Run the game action when the key is down.
246whenKeyDown :: Key -> Game s a -> Game s () 236whenKeyDown :: GLFW.Window -> Key -> Game s a -> Game s ()
247whenKeyDown = whenKey (==GLFW.Press) 237whenKeyDown = whenKeyInState (== GLFW.KeyState'Pressed)
248 238
249-- | Run the game action when the key is up. 239-- | Run the game action when the key is up.
250whenKeyUp :: Key -> Game s a -> Game s () 240whenKeyUp :: GLFW.Window -> Key -> Game s a -> Game s ()
251whenKeyUp = whenKey (==GLFW.Release) 241whenKeyUp = whenKeyInState (== GLFW.KeyState'Released)
252 242
253whenKey :: (GLFW.KeyButtonState -> Bool) -> Key -> Game s a -> Game s () 243whenKeyInState :: (GLFW.KeyState -> Bool) -> GLFW.Window -> Key -> Game s a -> Game s ()
254whenKey pred key game = do 244whenKeyInState pred window key game = do
255 isDown <- fmap pred $ gameIO . GLFW.getKey . toGLFWkey $ key 245 isDown <- fmap pred $ gameIO . GLFW.getKey window . toGLFWkey $ key
256 when isDown $ game >> return () 246 when isDown $ void game
257 247
258-- | Process the keyboard keys, returning those values for which their 248-- | Process the keyboard keys, returning those values for which their
259-- corresponding key is pressed. 249-- corresponding key is pressed.
260processKeys :: [(Key,a)] -> Game s [a] 250processKeys :: GLFW.Window -> [(Key, a)] -> Game s [a]
261processKeys = foldM f [] 251processKeys window = foldM f []
262 where f acc (key,res) = do 252 where
263 isDown <- fmap (==GLFW.Press) $ gameIO . GLFW.getKey 253 f acc (key, result) = do
264 . toGLFWkey $ key 254 isDown <-
265 return $ if isDown then (res:acc) else acc 255 fmap (== GLFW.KeyState'Pressed) $
256 gameIO . GLFW.getKey window . toGLFWkey $ key
257 return $ if isDown then result : acc else acc
266 258
267-- | Process the mouse buttons, returning those values for which their 259-- | Process the mouse buttons, returning those values for which their
268-- corresponding button is pressed. 260-- corresponding button is pressed.
269processButtons :: [(MouseButton,a)] -> Game s [a] 261processButtons :: GLFW.Window -> [(MouseButton, a)] -> Game s [a]
270processButtons = foldM f [] 262processButtons window = foldM f []
271 where f acc (bt,res) = do 263 where
272 isDown <- fmap (==GLFW.Press) $ gameIO . GLFW.getMouseButton 264 f acc (button, result) = do
273 . toGLFWbutton $ bt 265 isDown <-
274 return $ if isDown then (res:acc) else acc 266 fmap (== GLFW.MouseButtonState'Pressed) $
267 gameIO . GLFW.getMouseButton window . toGLFWbutton $ button
268 return $ if isDown then result : acc else acc
275 269
276data InputEvent 270data InputEvent
277 = Resize Width Height 271 = Resize Width Height
278 | KeyDown Key 272 | KeyDown Key
279 | KeyUp Key 273 | KeyUp Key
280 | MouseDown MouseButton 274 | MouseDown MouseButton
281 | MouseUp MouseButton 275 | MouseUp MouseButton
282 | MouseMove MousePos MouseDelta 276 | MouseMove MousePos MouseDelta
283 deriving (Eq, Show) 277 deriving (Eq, Show)
284 278
285data Key 279data Key
286 = KEY_A | KEY_B | KEY_C | KEY_D | KEY_E | KEY_F | KEY_G | KEY_H 280 = KEY_A
287 | KEY_I | KEY_J | KEY_K | KEY_L | KEY_M | KEY_N | KEY_O | KEY_P 281 | KEY_B
288 | KEY_Q | KEY_R | KEY_S | KEY_T | KEY_U | KEY_V | KEY_W | KEY_X 282 | KEY_C
289 | KEY_Y | KEY_Z | KEY_0 | KEY_1 | KEY_2 | KEY_3 | KEY_4 | KEY_5 283 | KEY_D
290 | KEY_6 | KEY_7 | KEY_8 | KEY_9 | KEY_F1 | KEY_F2 | KEY_F3 284 | KEY_E
291 | KEY_F4 | KEY_F5 | KEY_F6 | KEY_F7 | KEY_F8 | KEY_F9 | KEY_F10 285 | KEY_F
292 | KEY_F11 | KEY_F12 | KEY_ESC | KEY_SPACE | KEY_UP | KEY_DOWN 286 | KEY_G
293 | KEY_LEFT | KEY_RIGHT | KEY_UNKNOWN 287 | KEY_H
294 deriving (Eq, Enum, Bounded, Show) 288 | KEY_I
289 | KEY_J
290 | KEY_K
291 | KEY_L
292 | KEY_M
293 | KEY_N
294 | KEY_O
295 | KEY_P
296 | KEY_Q
297 | KEY_R
298 | KEY_S
299 | KEY_T
300 | KEY_U
301 | KEY_V
302 | KEY_W
303 | KEY_X
304 | KEY_Y
305 | KEY_Z
306 | KEY_0
307 | KEY_1
308 | KEY_2
309 | KEY_3
310 | KEY_4
311 | KEY_5
312 | KEY_6
313 | KEY_7
314 | KEY_8
315 | KEY_9
316 | KEY_F1
317 | KEY_F2
318 | KEY_F3
319 | KEY_F4
320 | KEY_F5
321 | KEY_F6
322 | KEY_F7
323 | KEY_F8
324 | KEY_F9
325 | KEY_F10
326 | KEY_F11
327 | KEY_F12
328 | KEY_ESC
329 | KEY_SPACE
330 | KEY_UP
331 | KEY_DOWN
332 | KEY_LEFT
333 | KEY_RIGHT
334 | KEY_UNKNOWN
335 deriving (Eq, Enum, Bounded, Show)
295 336
296data MouseButton = LMB | RMB | MMB 337data MouseButton = LMB | RMB | MMB
297 deriving (Eq, Enum, Bounded, Show) 338 deriving (Eq, Enum, Bounded, Show)
298 339
299data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta 340data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta
300 deriving (Eq, Enum, Bounded, Show) 341 deriving (Eq, Enum, Bounded, Show)
301 342
302type MousePos = (Int,Int) 343type MousePos = (Double, Double)
303type MouseDelta = (Int,Int) 344
345type MouseDelta = (Double, Double)
304 346
305fromGLFWkey :: GLFW.Key -> Key 347fromGLFWkey :: GLFW.Key -> Key
306fromGLFWkey (GLFW.CharKey 'A') = KEY_A 348fromGLFWkey GLFW.Key'A = KEY_A
307fromGLFWkey (GLFW.CharKey 'B') = KEY_B 349fromGLFWkey GLFW.Key'B = KEY_B
308fromGLFWkey (GLFW.CharKey 'C') = KEY_C 350fromGLFWkey GLFW.Key'C = KEY_C
309fromGLFWkey (GLFW.CharKey 'D') = KEY_D 351fromGLFWkey GLFW.Key'D = KEY_D
310fromGLFWkey (GLFW.CharKey 'E') = KEY_E 352fromGLFWkey GLFW.Key'E = KEY_E
311fromGLFWkey (GLFW.CharKey 'F') = KEY_F 353fromGLFWkey GLFW.Key'F = KEY_F
312fromGLFWkey (GLFW.CharKey 'G') = KEY_G 354fromGLFWkey GLFW.Key'G = KEY_G
313fromGLFWkey (GLFW.CharKey 'H') = KEY_H 355fromGLFWkey GLFW.Key'H = KEY_H
314fromGLFWkey (GLFW.CharKey 'I') = KEY_I 356fromGLFWkey GLFW.Key'I = KEY_I
315fromGLFWkey (GLFW.CharKey 'J') = KEY_J 357fromGLFWkey GLFW.Key'J = KEY_J
316fromGLFWkey (GLFW.CharKey 'K') = KEY_K 358fromGLFWkey GLFW.Key'K = KEY_K
317fromGLFWkey (GLFW.CharKey 'L') = KEY_L 359fromGLFWkey GLFW.Key'L = KEY_L
318fromGLFWkey (GLFW.CharKey 'M') = KEY_M 360fromGLFWkey GLFW.Key'M = KEY_M
319fromGLFWkey (GLFW.CharKey 'N') = KEY_N 361fromGLFWkey GLFW.Key'N = KEY_N
320fromGLFWkey (GLFW.CharKey 'O') = KEY_O 362fromGLFWkey GLFW.Key'O = KEY_O
321fromGLFWkey (GLFW.CharKey 'P') = KEY_P 363fromGLFWkey GLFW.Key'P = KEY_P
322fromGLFWkey (GLFW.CharKey 'Q') = KEY_Q 364fromGLFWkey GLFW.Key'Q = KEY_Q
323fromGLFWkey (GLFW.CharKey 'R') = KEY_R 365fromGLFWkey GLFW.Key'R = KEY_R
324fromGLFWkey (GLFW.CharKey 'S') = KEY_S 366fromGLFWkey GLFW.Key'S = KEY_S
325fromGLFWkey (GLFW.CharKey 'T') = KEY_T 367fromGLFWkey GLFW.Key'T = KEY_T
326fromGLFWkey (GLFW.CharKey 'U') = KEY_U 368fromGLFWkey GLFW.Key'U = KEY_U
327fromGLFWkey (GLFW.CharKey 'V') = KEY_V 369fromGLFWkey GLFW.Key'V = KEY_V
328fromGLFWkey (GLFW.CharKey 'W') = KEY_W 370fromGLFWkey GLFW.Key'W = KEY_W
329fromGLFWkey (GLFW.CharKey 'X') = KEY_X 371fromGLFWkey GLFW.Key'X = KEY_X
330fromGLFWkey (GLFW.CharKey 'Y') = KEY_Y 372fromGLFWkey GLFW.Key'Y = KEY_Y
331fromGLFWkey (GLFW.CharKey 'Z') = KEY_Z 373fromGLFWkey GLFW.Key'Z = KEY_Z
332fromGLFWkey (GLFW.CharKey '0') = KEY_0 374fromGLFWkey GLFW.Key'0 = KEY_0
333fromGLFWkey (GLFW.CharKey '1') = KEY_1 375fromGLFWkey GLFW.Key'1 = KEY_1
334fromGLFWkey (GLFW.CharKey '2') = KEY_2 376fromGLFWkey GLFW.Key'2 = KEY_2
335fromGLFWkey (GLFW.CharKey '3') = KEY_3 377fromGLFWkey GLFW.Key'3 = KEY_3
336fromGLFWkey (GLFW.CharKey '4') = KEY_4 378fromGLFWkey GLFW.Key'4 = KEY_4
337fromGLFWkey (GLFW.CharKey '5') = KEY_5 379fromGLFWkey GLFW.Key'5 = KEY_5
338fromGLFWkey (GLFW.CharKey '6') = KEY_6 380fromGLFWkey GLFW.Key'6 = KEY_6
339fromGLFWkey (GLFW.CharKey '7') = KEY_7 381fromGLFWkey GLFW.Key'7 = KEY_7
340fromGLFWkey (GLFW.CharKey '8') = KEY_8 382fromGLFWkey GLFW.Key'8 = KEY_8
341fromGLFWkey (GLFW.CharKey '9') = KEY_9 383fromGLFWkey GLFW.Key'9 = KEY_9
342fromGLFWkey (GLFW.CharKey ' ') = KEY_SPACE 384fromGLFWkey GLFW.Key'Space = KEY_SPACE
343fromGLFWkey (GLFW.SpecialKey GLFW.F1) = KEY_F1 385fromGLFWkey GLFW.Key'F1 = KEY_F1
344fromGLFWkey (GLFW.SpecialKey GLFW.F2) = KEY_F2 386fromGLFWkey GLFW.Key'F2 = KEY_F2
345fromGLFWkey (GLFW.SpecialKey GLFW.F3) = KEY_F3 387fromGLFWkey GLFW.Key'F3 = KEY_F3
346fromGLFWkey (GLFW.SpecialKey GLFW.F4) = KEY_F4 388fromGLFWkey GLFW.Key'F4 = KEY_F4
347fromGLFWkey (GLFW.SpecialKey GLFW.F5) = KEY_F5 389fromGLFWkey GLFW.Key'F5 = KEY_F5
348fromGLFWkey (GLFW.SpecialKey GLFW.F6) = KEY_F6 390fromGLFWkey GLFW.Key'F6 = KEY_F6
349fromGLFWkey (GLFW.SpecialKey GLFW.F7) = KEY_F7 391fromGLFWkey GLFW.Key'F7 = KEY_F7
350fromGLFWkey (GLFW.SpecialKey GLFW.F8) = KEY_F8 392fromGLFWkey GLFW.Key'F8 = KEY_F8
351fromGLFWkey (GLFW.SpecialKey GLFW.F9) = KEY_F9 393fromGLFWkey GLFW.Key'F9 = KEY_F9
352fromGLFWkey (GLFW.SpecialKey GLFW.F10) = KEY_F10 394fromGLFWkey GLFW.Key'F10 = KEY_F10
353fromGLFWkey (GLFW.SpecialKey GLFW.F11) = KEY_F11 395fromGLFWkey GLFW.Key'F11 = KEY_F11
354fromGLFWkey (GLFW.SpecialKey GLFW.F12) = KEY_F12 396fromGLFWkey GLFW.Key'F12 = KEY_F12
355fromGLFWkey (GLFW.SpecialKey GLFW.ESC) = KEY_ESC 397fromGLFWkey GLFW.Key'Escape = KEY_ESC
356fromGLFWkey (GLFW.SpecialKey GLFW.UP) = KEY_UP 398fromGLFWkey GLFW.Key'Up = KEY_UP
357fromGLFWkey (GLFW.SpecialKey GLFW.DOWN) = KEY_DOWN 399fromGLFWkey GLFW.Key'Down = KEY_DOWN
358fromGLFWkey (GLFW.SpecialKey GLFW.LEFT) = KEY_LEFT 400fromGLFWkey GLFW.Key'Left = KEY_LEFT
359fromGLFWkey (GLFW.SpecialKey GLFW.RIGHT) = KEY_RIGHT 401fromGLFWkey GLFW.Key'Right = KEY_RIGHT
360fromGLFWkey _ = KEY_UNKNOWN 402fromGLFWkey _ = KEY_UNKNOWN
361 403
404-- https://www.glfw.org/docs/3.3/group__buttons.html
362fromGLFWbutton :: GLFW.MouseButton -> MouseButton 405fromGLFWbutton :: GLFW.MouseButton -> MouseButton
363fromGLFWbutton GLFW.ButtonLeft = LMB 406fromGLFWbutton GLFW.MouseButton'1 = LMB
364fromGLFWbutton GLFW.ButtonRight = RMB 407fromGLFWbutton GLFW.MouseButton'2 = RMB
365fromGLFWbutton GLFW.ButtonMiddle = MMB 408fromGLFWbutton GLFW.MouseButton'3 = MMB
366 409
367toGLFWkey :: Key -> GLFW.Key 410toGLFWkey :: Key -> GLFW.Key
368toGLFWkey KEY_A = GLFW.CharKey 'A' 411toGLFWkey KEY_A = GLFW.Key'A
369toGLFWkey KEY_B = GLFW.CharKey 'B' 412toGLFWkey KEY_B = GLFW.Key'B
370toGLFWkey KEY_C = GLFW.CharKey 'C' 413toGLFWkey KEY_C = GLFW.Key'C
371toGLFWkey KEY_D = GLFW.CharKey 'D' 414toGLFWkey KEY_D = GLFW.Key'D
372toGLFWkey KEY_E = GLFW.CharKey 'E' 415toGLFWkey KEY_E = GLFW.Key'E
373toGLFWkey KEY_F = GLFW.CharKey 'F' 416toGLFWkey KEY_F = GLFW.Key'F
374toGLFWkey KEY_G = GLFW.CharKey 'G' 417toGLFWkey KEY_G = GLFW.Key'G
375toGLFWkey KEY_H = GLFW.CharKey 'H' 418toGLFWkey KEY_H = GLFW.Key'H
376toGLFWkey KEY_I = GLFW.CharKey 'I' 419toGLFWkey KEY_I = GLFW.Key'I
377toGLFWkey KEY_J = GLFW.CharKey 'J' 420toGLFWkey KEY_J = GLFW.Key'J
378toGLFWkey KEY_K = GLFW.CharKey 'K' 421toGLFWkey KEY_K = GLFW.Key'K
379toGLFWkey KEY_L = GLFW.CharKey 'L' 422toGLFWkey KEY_L = GLFW.Key'L
380toGLFWkey KEY_M = GLFW.CharKey 'M' 423toGLFWkey KEY_M = GLFW.Key'M
381toGLFWkey KEY_N = GLFW.CharKey 'N' 424toGLFWkey KEY_N = GLFW.Key'N
382toGLFWkey KEY_O = GLFW.CharKey 'O' 425toGLFWkey KEY_O = GLFW.Key'O
383toGLFWkey KEY_P = GLFW.CharKey 'P' 426toGLFWkey KEY_P = GLFW.Key'P
384toGLFWkey KEY_Q = GLFW.CharKey 'Q' 427toGLFWkey KEY_Q = GLFW.Key'Q
385toGLFWkey KEY_R = GLFW.CharKey 'R' 428toGLFWkey KEY_R = GLFW.Key'R
386toGLFWkey KEY_S = GLFW.CharKey 'S' 429toGLFWkey KEY_S = GLFW.Key'S
387toGLFWkey KEY_T = GLFW.CharKey 'T' 430toGLFWkey KEY_T = GLFW.Key'T
388toGLFWkey KEY_U = GLFW.CharKey 'U' 431toGLFWkey KEY_U = GLFW.Key'U
389toGLFWkey KEY_V = GLFW.CharKey 'V' 432toGLFWkey KEY_V = GLFW.Key'V
390toGLFWkey KEY_W = GLFW.CharKey 'W' 433toGLFWkey KEY_W = GLFW.Key'W
391toGLFWkey KEY_X = GLFW.CharKey 'X' 434toGLFWkey KEY_X = GLFW.Key'X
392toGLFWkey KEY_Y = GLFW.CharKey 'Y' 435toGLFWkey KEY_Y = GLFW.Key'Y
393toGLFWkey KEY_Z = GLFW.CharKey 'Z' 436toGLFWkey KEY_Z = GLFW.Key'Z
394toGLFWkey KEY_0 = GLFW.CharKey '0' 437toGLFWkey KEY_0 = GLFW.Key'0
395toGLFWkey KEY_1 = GLFW.CharKey '1' 438toGLFWkey KEY_1 = GLFW.Key'1
396toGLFWkey KEY_2 = GLFW.CharKey '2' 439toGLFWkey KEY_2 = GLFW.Key'2
397toGLFWkey KEY_3 = GLFW.CharKey '3' 440toGLFWkey KEY_3 = GLFW.Key'3
398toGLFWkey KEY_4 = GLFW.CharKey '4' 441toGLFWkey KEY_4 = GLFW.Key'4
399toGLFWkey KEY_5 = GLFW.CharKey '5' 442toGLFWkey KEY_5 = GLFW.Key'5
400toGLFWkey KEY_6 = GLFW.CharKey '6' 443toGLFWkey KEY_6 = GLFW.Key'6
401toGLFWkey KEY_7 = GLFW.CharKey '7' 444toGLFWkey KEY_7 = GLFW.Key'7
402toGLFWkey KEY_8 = GLFW.CharKey '8' 445toGLFWkey KEY_8 = GLFW.Key'8
403toGLFWkey KEY_9 = GLFW.CharKey '9' 446toGLFWkey KEY_9 = GLFW.Key'9
404toGLFWkey KEY_SPACE = GLFW.CharKey ' ' 447toGLFWkey KEY_SPACE = GLFW.Key'Space
405toGLFWkey KEY_F1 = GLFW.SpecialKey GLFW.F1 448toGLFWkey KEY_F1 = GLFW.Key'F1
406toGLFWkey KEY_F2 = GLFW.SpecialKey GLFW.F2 449toGLFWkey KEY_F2 = GLFW.Key'F2
407toGLFWkey KEY_F3 = GLFW.SpecialKey GLFW.F3 450toGLFWkey KEY_F3 = GLFW.Key'F3
408toGLFWkey KEY_F4 = GLFW.SpecialKey GLFW.F4 451toGLFWkey KEY_F4 = GLFW.Key'F4
409toGLFWkey KEY_F5 = GLFW.SpecialKey GLFW.F5 452toGLFWkey KEY_F5 = GLFW.Key'F5
410toGLFWkey KEY_F6 = GLFW.SpecialKey GLFW.F6 453toGLFWkey KEY_F6 = GLFW.Key'F6
411toGLFWkey KEY_F7 = GLFW.SpecialKey GLFW.F7 454toGLFWkey KEY_F7 = GLFW.Key'F7
412toGLFWkey KEY_F8 = GLFW.SpecialKey GLFW.F8 455toGLFWkey KEY_F8 = GLFW.Key'F8
413toGLFWkey KEY_F9 = GLFW.SpecialKey GLFW.F9 456toGLFWkey KEY_F9 = GLFW.Key'F9
414toGLFWkey KEY_F10 = GLFW.SpecialKey GLFW.F10 457toGLFWkey KEY_F10 = GLFW.Key'F10
415toGLFWkey KEY_F11 = GLFW.SpecialKey GLFW.F11 458toGLFWkey KEY_F11 = GLFW.Key'F11
416toGLFWkey KEY_F12 = GLFW.SpecialKey GLFW.F12 459toGLFWkey KEY_F12 = GLFW.Key'F12
417toGLFWkey KEY_ESC = GLFW.SpecialKey GLFW.ESC 460toGLFWkey KEY_ESC = GLFW.Key'Escape
418toGLFWkey KEY_UP = GLFW.SpecialKey GLFW.UP 461toGLFWkey KEY_UP = GLFW.Key'Up
419toGLFWkey KEY_DOWN = GLFW.SpecialKey GLFW.DOWN 462toGLFWkey KEY_DOWN = GLFW.Key'Down
420toGLFWkey KEY_LEFT = GLFW.SpecialKey GLFW.LEFT 463toGLFWkey KEY_LEFT = GLFW.Key'Left
421toGLFWkey KEY_RIGHT = GLFW.SpecialKey GLFW.RIGHT 464toGLFWkey KEY_RIGHT = GLFW.Key'Right
422toGLFWkey KEY_UNKNOWN = GLFW.SpecialKey GLFW.UNKNOWN 465toGLFWkey KEY_UNKNOWN = GLFW.Key'Unknown
423 466
467-- https://www.glfw.org/docs/3.3/group__buttons.html
424toGLFWbutton :: MouseButton -> GLFW.MouseButton 468toGLFWbutton :: MouseButton -> GLFW.MouseButton
425toGLFWbutton LMB = GLFW.ButtonLeft 469toGLFWbutton LMB = GLFW.MouseButton'1
426toGLFWbutton RMB = GLFW.ButtonRight 470toGLFWbutton RMB = GLFW.MouseButton'2
427toGLFWbutton MMB = GLFW.ButtonMiddle 471toGLFWbutton MMB = GLFW.MouseButton'3
diff --git a/demos/pong/Main.hs b/demos/pong/Main.hs
index d0664b7..3563c30 100644
--- a/demos/pong/Main.hs
+++ b/demos/pong/Main.hs
@@ -1,79 +1,82 @@
1module Main where 1module Main where
2 2
3import Data.Maybe (mapMaybe)
4import Graphics.Rendering.OpenGL.GL (($=))
5import qualified Graphics.Rendering.OpenGL.GL as GL
3import Pong 6import Pong
4 7import Spear.Game
5import Spear.Math.AABB 8import Spear.Math.AABB
6import Spear.Math.Spatial2 9import Spear.Math.Spatial2
7import Spear.Math.Vector 10import Spear.Math.Vector
8import Spear.Game
9import Spear.Window 11import Spear.Window
10 12
11import Data.Maybe (mapMaybe)
12import qualified Graphics.Rendering.OpenGL.GL as GL
13import Graphics.Rendering.OpenGL.GL (($=))
14
15data GameState = GameState 13data GameState = GameState
16 { wnd :: Window 14 { window :: Window,
17 , world :: [GameObject] 15 world :: [GameObject]
18 } 16 }
19 17
20main = run 18main =
21 $ withWindow (640,480) [] Window (2,0) (Just "Pong") initGame 19 withWindow (900, 600) (2, 0) (Just "Pong") initGame $
22 $ loop (Just 30) step 20 loop step
23 21
24initGame wnd = do 22initGame :: Window -> Game () GameState
25 gameIO $ do 23initGame window = do
26 GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0 24 gameIO $ do
27 GL.matrixMode $= GL.Modelview 0 25 GL.clearColor $= GL.Color4 0.7 0.5 0.7 1.0
28 GL.loadIdentity 26 GL.matrixMode $= GL.Modelview 0
29 return $ GameState wnd newWorld 27 GL.loadIdentity
28 return $ GameState window newWorld
30 29
31step :: Elapsed -> Dt -> Game GameState Bool 30step :: Elapsed -> Dt -> Game GameState Bool
32step elapsed dt = do 31step elapsed dt = do
33 gs <- getGameState 32 --gameIO $ putStrLn "Tick"
34 evts <- events (wnd gs) 33 gs <- getGameState
35 gameIO . process $ evts 34 evts <- events (window gs)
36 let evts' = translate evts 35 gameIO . process $ evts
37 modifyGameState $ \ gs -> gs 36 let evts' = translate evts
38 { world = stepWorld elapsed dt evts' (world gs) } 37 modifyGameState $ \gs ->
39 getGameState >>= \gs -> gameIO . render $ world gs 38 gs
40 return (not $ exitRequested evts) 39 { world = stepWorld elapsed dt evts' (world gs)
40 }
41 getGameState >>= \gs -> gameIO . render $ world gs
42 return (not $ exitRequested evts)
41 43
42render world = do 44render world = do
43 GL.clear [GL.ColorBuffer] 45 GL.clear [GL.ColorBuffer]
44 mapM_ renderGO world 46 mapM_ renderGO world
45 swapBuffers
46 47
47renderGO :: GameObject -> IO () 48renderGO :: GameObject -> IO ()
48renderGO go = do 49renderGO go = do
49 let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go 50 let (AABB2 (Vector2 xmin' ymin') (Vector2 xmax' ymax')) = aabb go
50 (Vector2 xcenter ycenter) = pos go 51 (Vector2 xcenter ycenter) = pos go
51 (xmin,ymin,xmax,ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax') 52 (xmin, ymin, xmax, ymax) = (f2d xmin', f2d ymin', f2d xmax', f2d ymax')
52 GL.preservingMatrix $ do 53 GL.preservingMatrix $ do
53 GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0) 54 GL.translate (GL.Vector3 (f2d xcenter) (f2d ycenter) 0)
54 GL.renderPrimitive (GL.TriangleStrip) $ do 55 GL.renderPrimitive (GL.TriangleStrip) $ do
55 GL.vertex (GL.Vertex2 xmin ymax) 56 GL.vertex (GL.Vertex2 xmin ymax)
56 GL.vertex (GL.Vertex2 xmin ymin) 57 GL.vertex (GL.Vertex2 xmin ymin)
57 GL.vertex (GL.Vertex2 xmax ymax) 58 GL.vertex (GL.Vertex2 xmax ymax)
58 GL.vertex (GL.Vertex2 xmax ymin) 59 GL.vertex (GL.Vertex2 xmax ymin)
59 60
60process = mapM_ procEvent 61process = mapM_ procEvent
62
61procEvent (Resize w h) = do 63procEvent (Resize w h) = do
62 GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) 64 GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
63 GL.matrixMode $= GL.Projection 65 GL.matrixMode $= GL.Projection
64 GL.loadIdentity 66 GL.loadIdentity
65 GL.ortho 0 1 0 1 (-1) 1 67 GL.ortho 0 1 0 1 (-1) 1
66 GL.matrixMode $= GL.Modelview 0 68 GL.matrixMode $= GL.Modelview 0
67procEvent _ = return () 69procEvent _ = return ()
68 70
69translate = mapMaybe translate' 71translate = mapMaybe translate'
70translate' (KeyDown KEY_LEFT) = Just MoveLeft 72
73translate' (KeyDown KEY_LEFT) = Just MoveLeft
71translate' (KeyDown KEY_RIGHT) = Just MoveRight 74translate' (KeyDown KEY_RIGHT) = Just MoveRight
72translate' (KeyUp KEY_LEFT) = Just StopLeft 75translate' (KeyUp KEY_LEFT) = Just StopLeft
73translate' (KeyUp KEY_RIGHT) = Just StopRight 76translate' (KeyUp KEY_RIGHT) = Just StopRight
74translate' _ = Nothing 77translate' _ = Nothing
75 78
76exitRequested = any (==(KeyDown KEY_ESC)) 79exitRequested = any (== (KeyDown KEY_ESC))
77 80
78f2d :: Float -> GL.GLdouble 81f2d :: Float -> GL.GLdouble
79f2d = realToFrac 82f2d = realToFrac
diff --git a/demos/pong/Pong.hs b/demos/pong/Pong.hs
index 1761823..232c69a 100644
--- a/demos/pong/Pong.hs
+++ b/demos/pong/Pong.hs
@@ -1,66 +1,64 @@
1module Pong 1module Pong
2( 2 ( GameEvent (..),
3 GameEvent(..) 3 GameObject,
4, GameObject 4 newWorld,
5, newWorld 5 stepWorld,
6, stepWorld 6 aabb,
7, aabb 7 )
8)
9where 8where
10 9
10import Data.Monoid (mconcat)
11import GHC.Float (double2Float)
11import Spear.Math.AABB 12import Spear.Math.AABB
12import Spear.Math.Spatial2 13import Spear.Math.Spatial2
13import Spear.Math.Vector 14import Spear.Math.Vector
14import Spear.Step 15import Spear.Step
15 16
16import Data.Monoid (mconcat)
17import GHC.Float (double2Float)
18
19-- Game events 17-- Game events
20 18
21data GameEvent 19data GameEvent
22 = MoveLeft 20 = MoveLeft
23 | MoveRight 21 | MoveRight
24 | StopLeft 22 | StopLeft
25 | StopRight 23 | StopRight
26 deriving (Eq, Ord) 24 deriving (Eq, Ord)
27 25
28-- Game objects 26-- Game objects
29 27
30data GameObject = GameObject 28data GameObject = GameObject
31 { aabb :: AABB2 29 { aabb :: AABB2,
32 , obj :: Obj2 30 obj :: Obj2,
33 , gostep :: Step [GameObject] [GameEvent] GameObject GameObject 31 gostep :: Step [GameObject] [GameEvent] GameObject GameObject
34 } 32 }
35 33
36instance Spatial2 GameObject where 34instance Spatial2 GameObject where
37 getObj2 = obj 35 getObj2 = obj
38 setObj2 s o = s { obj = o } 36 setObj2 s o = s {obj = o}
39 37
40stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] 38stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject]
41stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos 39stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos
42 40
43update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject 41update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
44update elapsed dt evts gos go = 42update elapsed dt evts gos go =
45 let (go', s') = runStep (gostep go) elapsed dt gos evts go 43 let (go', s') = runStep (gostep go) elapsed dt gos evts go
46 in go' { gostep = s' } 44 in go' {gostep = s'}
47 45
48ballBox :: AABB2 46ballBox :: AABB2
49ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = 0.01 47ballBox = AABB2 (vec2 (- s) (- s)) (vec2 s s) where s = 0.01
50 48
51padSize = vec2 0.05 0.02 49padSize = vec2 0.05 0.02
52 50
53padBox = AABB2 (-padSize) padSize 51padBox = AABB2 (- padSize) padSize
54 52
55obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y) 53obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y)
56 54
57ballVelocity = Vector2 0.3 0.3 55ballVelocity = Vector2 0.3 0.3
58 56
59newWorld = 57newWorld =
60 [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity 58 [ GameObject ballBox (obj2 0.5 0.5) $ stepBall ballVelocity,
61 , GameObject padBox (obj2 0.5 0.9) stepEnemy 59 GameObject padBox (obj2 0.5 0.9) stepEnemy,
62 , GameObject padBox (obj2 0.5 0.1) stepPlayer 60 GameObject padBox (obj2 0.5 0.1) stepPlayer
63 ] 61 ]
64 62
65-- Ball steppers 63-- Ball steppers
66 64
@@ -68,27 +66,30 @@ stepBall vel = collideBall vel .> moveBall
68 66
69collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) 67collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
70collideBall vel = step $ \_ _ gos _ ball -> 68collideBall vel = step $ \_ _ gos _ ball ->
71 let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball 69 let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball
72 collideCol = x pmin < 0 || x pmax > 1 70 collideCol = x pmin < 0 || x pmax > 1
73 collideRow = y pmin < 0 || y pmax > 1 71 collideRow =
74 || any (collide ball) (tail gos) 72 y pmin < 0 || y pmax > 1
75 negx v@(Vector2 x y) = if collideCol then vec2 (-x) y else v 73 || any (collide ball) (tail gos)
76 negy v@(Vector2 x y) = if collideRow then vec2 x (-y) else v 74 negx v@(Vector2 x y) = if collideCol then vec2 (- x) y else v
77 vel' = negx . negy $ vel 75 negy v@(Vector2 x y) = if collideRow then vec2 x (- y) else v
78 in ((vel', ball), collideBall vel') 76 vel' = negx . negy $ vel
77 in ((vel', ball), collideBall vel')
79 78
80collide go1 go2 = 79collide go1 go2 =
81 let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) 80 let (AABB2 (Vector2 xmin1 ymin1) (Vector2 xmax1 ymax1)) =
82 = aabb go1 `aabbAdd` pos go1 81 aabb go1 `aabbAdd` pos go1
83 (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) 82 (AABB2 (Vector2 xmin2 ymin2) (Vector2 xmax2 ymax2)) =
84 = aabb go2 `aabbAdd` pos go2 83 aabb go2 `aabbAdd` pos go2
85 in not $ xmax1 < xmin2 || xmin1 > xmax2 84 in not $
86 || ymax1 < ymin2 || ymin1 > ymax2 85 xmax1 < xmin2 || xmin1 > xmax2
86 || ymax1 < ymin2
87 || ymin1 > ymax2
87 88
88aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax) 89aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax)
89 90
90moveBall :: Step s e (Vector2, GameObject) GameObject 91moveBall :: Step s e (Vector2, GameObject) GameObject
91moveBall = step $ \_ dt _ _ (vel,ball) -> (move (scale dt vel) ball, moveBall) 92moveBall = step $ \_ dt _ _ (vel, ball) -> (move (scale dt vel) ball, moveBall)
92 93
93-- Enemy stepper 94-- Enemy stepper
94 95
@@ -96,32 +97,34 @@ stepEnemy = movePad
96 97
97movePad :: Step s e GameObject GameObject 98movePad :: Step s e GameObject GameObject
98movePad = step $ \elapsed _ _ _ pad -> 99movePad = step $ \elapsed _ _ _ pad ->
99 let p = vec2 px 0.9 100 let p = vec2 px 0.9
100 px = double2Float (sin elapsed * 0.5 + 0.5) 101 px =
101 * (1 - 2 * x padSize) 102 double2Float (sin elapsed * 0.5 + 0.5)
102 + x padSize 103 * (1 - 2 * x padSize)
103 in (setPos p pad, movePad) 104 + x padSize
105 in (setPos p pad, movePad)
104 106
105-- Player stepper 107-- Player stepper
106 108
107stepPlayer = sfold moveGO .> clamp 109stepPlayer = sfold moveGO .> clamp
108 110
109moveGO = mconcat 111moveGO =
110 [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-1) 0) 112 mconcat
111 , switch StopRight sid MoveRight (moveGO' $ vec2 1 0) 113 [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-1) 0),
112 ] 114 switch StopRight sid MoveRight (moveGO' $ vec2 1 0)
115 ]
113 116
114moveGO' :: Vector2 -> Step s e GameObject GameObject 117moveGO' :: Vector2 -> Step s e GameObject GameObject
115moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) 118moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir)
116 119
117clamp :: Step s e GameObject GameObject 120clamp :: Step s e GameObject GameObject
118clamp = spure $ \go -> 121clamp = spure $ \go ->
119 let p' = vec2 (clamp' x s (1 - s)) y 122 let p' = vec2 (clamp' x s (1 - s)) y
120 (Vector2 x y) = pos go 123 (Vector2 x y) = pos go
121 clamp' x a b = if x < a then a else if x > b then b else x 124 clamp' x a b = if x < a then a else if x > b then b else x
122 (Vector2 s _) = padSize 125 (Vector2 s _) = padSize
123 in setPos p' go 126 in setPos p' go
124 127
125toDir True MoveLeft = vec2 (-1) 0 128toDir True MoveLeft = vec2 (-1) 0
126toDir True MoveRight = vec2 1 0 129toDir True MoveRight = vec2 1 0
127toDir _ _ = vec2 0 0 \ No newline at end of file 130toDir _ _ = vec2 0 0
diff --git a/demos/pong/Setup.hs b/demos/pong/Setup.hs
index 9a994af..e8ef27d 100644
--- a/demos/pong/Setup.hs
+++ b/demos/pong/Setup.hs
@@ -1,2 +1,3 @@
1import Distribution.Simple 1import Distribution.Simple
2
2main = defaultMain 3main = defaultMain
diff --git a/demos/pong/cabal.project b/demos/pong/cabal.project
new file mode 100644
index 0000000..3dc1fca
--- /dev/null
+++ b/demos/pong/cabal.project
@@ -0,0 +1,2 @@
1packages: .
2 ../../
diff --git a/demos/pong/pong.cabal b/demos/pong/pong.cabal
index bebedb9..23ada51 100644
--- a/demos/pong/pong.cabal
+++ b/demos/pong/pong.cabal
@@ -1,15 +1,15 @@
1-- Initial pong.cabal generated by cabal init. For further documentation, 1-- Initial pong.cabal generated by cabal init. For further documentation,
2-- see http://haskell.org/cabal/users-guide/ 2-- see http://haskell.org/cabal/users-guide/
3 3
4name: pong 4name: pong
5version: 0.1.0.0 5version: 0.1.0.0
6synopsis: A pong clone 6synopsis: A pong clone
7-- description: 7-- description:
8license: BSD3 8license: BSD3
9license-file: LICENSE 9license-file: LICENSE
10author: Marc Sunet 10author: Marc Sunet
11-- maintainer: 11-- maintainer:
12-- copyright: 12-- copyright:
13category: Game 13category: Game
14build-type: Simple 14build-type: Simple
15cabal-version: >=1.8 15cabal-version: >=1.8
@@ -17,5 +17,5 @@ cabal-version: >=1.8
17executable pong 17executable pong
18 -- hs-source-dirs: src 18 -- hs-source-dirs: src
19 main-is: Main.hs 19 main-is: Main.hs
20 -- other-modules: 20 -- other-modules:
21 build-depends: base ==4.6.*, Spear, OpenGL 21 build-depends: base, Spear, OpenGL
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-24 10:07:12 +0000