diff options
-rw-r--r-- | .gitignore | 1 | ||||
-rw-r--r-- | Spear.cabal | 32 | ||||
-rw-r--r-- | Spear/GL.hs | 827 | ||||
-rw-r--r-- | Spear/Game.hs | 111 | ||||
-rw-r--r-- | Spear/Render/AnimatedModel.hs | 287 | ||||
-rw-r--r-- | Spear/Render/StaticModel.hs | 146 | ||||
-rw-r--r-- | Spear/Scene/Loader.hs | 457 | ||||
-rw-r--r-- | Spear/Step.hs | 201 | ||||
-rw-r--r-- | Spear/Sys/Timer.hsc | 52 | ||||
-rw-r--r-- | Spear/Window.hs | 710 | ||||
-rw-r--r-- | demos/pong/Main.hs | 99 | ||||
-rw-r--r-- | demos/pong/Pong.hs | 125 | ||||
-rw-r--r-- | demos/pong/Setup.hs | 1 | ||||
-rw-r--r-- | demos/pong/cabal.project | 2 | ||||
-rw-r--r-- | demos/pong/pong.cabal | 12 |
15 files changed, 1635 insertions, 1428 deletions
@@ -1,3 +1,4 @@ | |||
1 | demos/pong/dist/ | 1 | demos/pong/dist/ |
2 | demos/pong/pong | 2 | demos/pong/pong |
3 | dist/ | 3 | dist/ |
4 | dist-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 | |||
4 | build-type: Simple | 4 | build-type: Simple |
5 | license: BSD3 | 5 | license: BSD3 |
6 | license-file: LICENSE | 6 | license-file: LICENSE |
7 | maintainer: jeannekamikaze@gmail.com | 7 | maintainer: 3gg@shellblade.net |
8 | homepage: http://spear.shellblade.net | 8 | homepage: http://spear.shellblade.net |
9 | synopsis: A 2.5D game framework. | 9 | synopsis: A 2.5D game framework. |
10 | category: Game | 10 | category: Game |
@@ -12,13 +12,14 @@ author: Marc Sunet | |||
12 | data-dir: "" | 12 | data-dir: "" |
13 | 13 | ||
14 | library | 14 | library |
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 | |||
2 | module Spear.GL | 3 | module 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 | ) |
75 | where | 88 | where |
76 | 89 | ||
77 | import Spear.Assets.Image | ||
78 | import Spear.Game | ||
79 | import Spear.Math.Matrix3 (Matrix3) | ||
80 | import Spear.Math.Matrix4 (Matrix4) | ||
81 | import Spear.Math.Vector | ||
82 | |||
83 | import Control.Monad | 90 | import Control.Monad |
84 | import Control.Monad.Trans.Class | 91 | import Control.Monad.Trans.Class |
85 | import Control.Monad.Trans.Error | ||
86 | import Control.Monad.Trans.State as State | 92 | import Control.Monad.Trans.State as State |
87 | import qualified Data.ByteString.Char8 as B | 93 | import qualified Data.ByteString.Char8 as B |
88 | import Data.StateVar | 94 | import Data.StateVar |
89 | import Data.Word | 95 | import Data.Word |
90 | import Foreign.C.String | 96 | import Foreign.C.String |
91 | import Foreign.C.Types | 97 | import Foreign.C.Types |
92 | import Foreign.Ptr | ||
93 | import Foreign.Storable | ||
94 | import Foreign.Marshal.Utils as Foreign (with) | ||
95 | import Foreign.Marshal.Alloc (alloca) | 98 | import Foreign.Marshal.Alloc (alloca) |
96 | import Foreign.Marshal.Array (withArray) | 99 | import Foreign.Marshal.Array (withArray) |
100 | import Foreign.Marshal.Utils as Foreign (with) | ||
101 | import Foreign.Ptr | ||
102 | import Foreign.Storable | ||
97 | import Foreign.Storable (peek) | 103 | import Foreign.Storable (peek) |
98 | import Graphics.Rendering.OpenGL.Raw.Core32 | 104 | import Graphics.GL.Core46 |
105 | import Spear.Assets.Image | ||
106 | import Spear.Game | ||
107 | import Spear.Math.Matrix3 (Matrix3) | ||
108 | import Spear.Math.Matrix4 (Matrix4) | ||
109 | import Spear.Math.Vector | ||
99 | import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory) | 110 | import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory) |
100 | import System.IO (hPutStrLn, stderr) | 111 | import System.IO (hPutStrLn, stderr) |
101 | import Unsafe.Coerce | 112 | import Unsafe.Coerce |
@@ -105,30 +116,30 @@ import Unsafe.Coerce | |||
105 | -- | 116 | -- |
106 | 117 | ||
107 | -- | A GLSL shader handle. | 118 | -- | A GLSL shader handle. |
108 | data GLSLShader = GLSLShader | 119 | data GLSLShader = GLSLShader |
109 | { getShader :: GLuint | 120 | { getShader :: GLuint, |
110 | , getShaderKey :: Resource | 121 | getShaderKey :: Resource |
111 | } | 122 | } |
112 | 123 | ||
113 | instance ResourceClass GLSLShader where | 124 | instance ResourceClass GLSLShader where |
114 | getResource = getShaderKey | 125 | getResource = getShaderKey |
115 | 126 | ||
116 | -- | A GLSL program handle. | 127 | -- | A GLSL program handle. |
117 | data GLSLProgram = GLSLProgram | 128 | data GLSLProgram = GLSLProgram |
118 | { getProgram :: GLuint | 129 | { getProgram :: GLuint, |
119 | , getProgramKey :: Resource | 130 | getProgramKey :: Resource |
120 | } | 131 | } |
121 | 132 | ||
122 | instance ResourceClass GLSLProgram where | 133 | instance ResourceClass GLSLProgram where |
123 | getResource = getProgramKey | 134 | getResource = getProgramKey |
124 | 135 | ||
125 | -- | Supported shader types. | 136 | -- | Supported shader types. |
126 | data ShaderType = VertexShader | FragmentShader | GeometryShader deriving (Eq, Show) | 137 | data ShaderType = VertexShader | FragmentShader | GeometryShader deriving (Eq, Show) |
127 | 138 | ||
128 | toGLShader :: ShaderType -> GLenum | 139 | toGLShader :: ShaderType -> GLenum |
129 | toGLShader VertexShader = gl_VERTEX_SHADER | 140 | toGLShader VertexShader = GL_VERTEX_SHADER |
130 | toGLShader FragmentShader = gl_FRAGMENT_SHADER | 141 | toGLShader FragmentShader = GL_FRAGMENT_SHADER |
131 | toGLShader GeometryShader = gl_GEOMETRY_SHADER | 142 | toGLShader 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. |
134 | withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a | 145 | withGLSLProgram :: 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. |
138 | uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint | 149 | uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint |
139 | uniformLocation prog var = makeGettableStateVar $ | 150 | uniformLocation 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. |
143 | fragLocation :: GLSLProgram -> String -> StateVar GLint | 154 | fragLocation :: GLSLProgram -> String -> StateVar GLint |
144 | fragLocation prog var = makeStateVar get set | 155 | fragLocation 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. |
151 | attribLocation :: GLSLProgram -> String -> StateVar GLint | 162 | attribLocation :: GLSLProgram -> String -> StateVar GLint |
152 | attribLocation prog var = makeStateVar get set | 163 | attribLocation 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. |
159 | newProgram :: [GLSLShader] -> Game s GLSLProgram | 170 | newProgram :: [GLSLShader] -> Game s GLSLProgram |
160 | newProgram shaders = do | 171 | newProgram 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. |
170 | deleteProgram :: GLuint -> IO () | 181 | deleteProgram :: GLuint -> IO () |
171 | --deleteProgram = glDeleteProgram | 182 | --deleteProgram = glDeleteProgram |
172 | deleteProgram prog = do | 183 | deleteProgram 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. |
177 | linkProgram :: GLSLProgram -> Game s () | 188 | linkProgram :: GLSLProgram -> Game s () |
178 | linkProgram prog = do | 189 | linkProgram 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. |
194 | useProgram :: GLSLProgram -> IO () | 205 | useProgram :: 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'. |
213 | loadShader :: ShaderType -> FilePath -> Game s GLSLShader | 224 | loadShader :: ShaderType -> FilePath -> Game s GLSLShader |
214 | loadShader shaderType file = do | 225 | loadShader 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. |
221 | newShader :: ShaderType -> Game s GLSLShader | 232 | newShader :: ShaderType -> Game s GLSLShader |
222 | newShader shaderType = do | 233 | newShader 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. |
231 | deleteShader :: GLuint -> IO () | 242 | deleteShader :: GLuint -> IO () |
232 | --deleteShader = glDeleteShader | 243 | --deleteShader = glDeleteShader |
233 | deleteShader shader = do | 244 | deleteShader 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. |
239 | loadSource :: FilePath -> GLSLShader -> Game s () | 250 | loadSource :: FilePath -> GLSLShader -> Game s () |
240 | loadSource file h = do | 251 | loadSource 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. |
249 | shaderSource :: GLSLShader -> CString -> IO () | 260 | shaderSource :: GLSLShader -> CString -> IO () |
250 | shaderSource shader str = | 261 | shaderSource 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. |
255 | compile :: FilePath -> GLSLShader -> Game s () | 266 | compile :: FilePath -> GLSLShader -> Game s () |
256 | compile file shader = do | 267 | compile 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 | ||
274 | type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO () | 286 | type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO () |
275 | type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO () | 287 | |
288 | type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO () | ||
276 | 289 | ||
277 | getStatus :: StatusCall -> LogCall -> GLuint -> IO String | 290 | getStatus :: StatusCall -> LogCall -> GLuint -> IO String |
278 | getStatus getStatus getLog h = do | 291 | getStatus 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 | ||
286 | getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String | 299 | getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String |
287 | getErrorString getLog h len str = do | 300 | getErrorString 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 | ||
299 | readSource' :: FilePath -> IO B.ByteString | 312 | readSource' :: FilePath -> IO B.ByteString |
300 | readSource' file = do | 313 | readSource' 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 | ||
326 | class Uniform a where | 341 | class 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 | ||
330 | instance Uniform Int where uniform loc a = glUniform1i loc (fromIntegral a) | 345 | instance Uniform Int where uniform loc a = glUniform1i loc (fromIntegral a) |
331 | instance Uniform Float where uniform loc a = glUniform1f loc (unsafeCoerce a) | ||
332 | instance Uniform CFloat where uniform loc a = glUniform1f loc a | ||
333 | 346 | ||
334 | instance Uniform (Int,Int) where | 347 | instance Uniform Float where uniform loc a = glUniform1f loc a |
335 | uniform loc (x,y) = glUniform2i loc (fromIntegral x) (fromIntegral y) | ||
336 | 348 | ||
337 | instance Uniform (Float,Float) where | 349 | instance Uniform CFloat where uniform loc a = glUniform1f loc (unsafeCoerce a) |
338 | uniform loc (x,y) = glUniform2f loc (unsafeCoerce x) (unsafeCoerce y) | ||
339 | 350 | ||
340 | instance Uniform (Int,Int,Int) where | 351 | instance 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 | ||
343 | instance Uniform (Float,Float,Float) where | 354 | instance 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 | ||
346 | instance Uniform (Int,Int,Int,Int) where | 357 | instance 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 | ||
350 | instance Uniform (Float,Float,Float,Float) where | 360 | instance 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 | |
363 | instance 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 | |||
372 | instance Uniform (Float, Float, Float, Float) where | ||
373 | uniform loc (x, y, z, w) = glUniform4f loc x y z w | ||
353 | 374 | ||
354 | instance Uniform Vector2 where | 375 | instance 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 | ||
359 | instance Uniform Vector3 where | 381 | instance 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 | ||
365 | instance Uniform Vector4 where | 388 | instance 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 | ||
372 | instance Uniform Matrix3 where | 396 | instance 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 | ||
377 | instance Uniform Matrix4 where | 401 | instance 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 | ||
382 | instance Uniform [Float] where | 406 | instance 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 | ||
390 | instance Uniform [CFloat] where | 414 | instance 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 | ||
398 | instance Uniform [Int] where | 422 | instance 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. |
411 | data VAO = VAO | 435 | data VAO = VAO |
412 | { getVAO :: GLuint | 436 | { getVAO :: GLuint, |
413 | , vaoKey :: Resource | 437 | vaoKey :: Resource |
414 | } | 438 | } |
415 | 439 | ||
416 | instance ResourceClass VAO where | 440 | instance ResourceClass VAO where |
417 | getResource = vaoKey | 441 | getResource = vaoKey |
418 | 442 | ||
419 | instance Eq VAO where | 443 | instance Eq VAO where |
420 | vao1 == vao2 = getVAO vao1 == getVAO vao2 | 444 | vao1 == vao2 = getVAO vao1 == getVAO vao2 |
421 | 445 | ||
422 | instance Ord VAO where | 446 | instance 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. |
426 | newVAO :: Game s VAO | 451 | newVAO :: Game s VAO |
427 | newVAO = do | 452 | newVAO = 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. |
436 | deleteVAO :: GLuint -> IO () | 461 | deleteVAO :: 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'. |
450 | enableVAOAttrib :: GLuint -- ^ Attribute index. | 475 | enableVAOAttrib :: |
451 | -> IO () | 476 | -- | Attribute index. |
477 | GLuint -> | ||
478 | IO () | ||
452 | enableVAOAttrib = glEnableVertexAttribArray | 479 | enableVAOAttrib = glEnableVertexAttribArray |
453 | 480 | ||
454 | -- | Bind the bound buffer to the given point. | 481 | -- | Bind the bound buffer to the given point. |
455 | attribVAOPointer | 482 | attribVAOPointer :: |
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 () | ||
463 | attribVAOPointer idx ncomp dattype normalise stride off = | 496 | attribVAOPointer 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. |
468 | drawArrays | 502 | drawArrays :: |
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 () | ||
473 | drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count) | 510 | drawArrays 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. |
476 | drawElements | 513 | drawElements :: |
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 () | ||
482 | drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs | 523 | drawElements 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. |
489 | data GLBuffer = GLBuffer | 530 | data GLBuffer = GLBuffer |
490 | { getBuffer :: GLuint | 531 | { getBuffer :: GLuint, |
491 | , rkey :: Resource | 532 | rkey :: Resource |
492 | } | 533 | } |
493 | 534 | ||
494 | instance ResourceClass GLBuffer where | 535 | instance ResourceClass GLBuffer where |
495 | getResource = rkey | 536 | getResource = rkey |
496 | 537 | ||
497 | -- | The type of target buffer. | 538 | -- | The type of target buffer. |
498 | data TargetBuffer | 539 | data 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 | ||
505 | fromTarget :: TargetBuffer -> GLenum | 546 | fromTarget :: TargetBuffer -> GLenum |
506 | fromTarget ArrayBuffer = gl_ARRAY_BUFFER | 547 | fromTarget ArrayBuffer = GL_ARRAY_BUFFER |
507 | fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER | 548 | fromTarget ElementArrayBuffer = GL_ELEMENT_ARRAY_BUFFER |
508 | fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER | 549 | fromTarget PixelPackBuffer = GL_PIXEL_PACK_BUFFER |
509 | fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER | 550 | fromTarget PixelUnpackBuffer = GL_PIXEL_UNPACK_BUFFER |
510 | 551 | ||
511 | -- | A buffer usage. | 552 | -- | A buffer usage. |
512 | data BufferUsage | 553 | data 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 | ||
524 | fromUsage :: BufferUsage -> GLenum | 565 | fromUsage :: BufferUsage -> GLenum |
525 | fromUsage StreamDraw = gl_STREAM_DRAW | 566 | fromUsage StreamDraw = GL_STREAM_DRAW |
526 | fromUsage StreamRead = gl_STREAM_READ | 567 | fromUsage StreamRead = GL_STREAM_READ |
527 | fromUsage StreamCopy = gl_STREAM_COPY | 568 | fromUsage StreamCopy = GL_STREAM_COPY |
528 | fromUsage StaticDraw = gl_STATIC_DRAW | 569 | fromUsage StaticDraw = GL_STATIC_DRAW |
529 | fromUsage StaticRead = gl_STATIC_READ | 570 | fromUsage StaticRead = GL_STATIC_READ |
530 | fromUsage StaticCopy = gl_STATIC_COPY | 571 | fromUsage StaticCopy = GL_STATIC_COPY |
531 | fromUsage DynamicDraw = gl_DYNAMIC_DRAW | 572 | fromUsage DynamicDraw = GL_DYNAMIC_DRAW |
532 | fromUsage DynamicRead = gl_DYNAMIC_READ | 573 | fromUsage DynamicRead = GL_DYNAMIC_READ |
533 | fromUsage DynamicCopy = gl_DYNAMIC_COPY | 574 | fromUsage DynamicCopy = GL_DYNAMIC_COPY |
534 | 575 | ||
535 | -- | Create a new buffer. | 576 | -- | Create a new buffer. |
536 | newBuffer :: Game s GLBuffer | 577 | newBuffer :: Game s GLBuffer |
537 | newBuffer = do | 578 | newBuffer = 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. |
546 | deleteBuffer :: GLuint -> IO () | 587 | deleteBuffer :: GLuint -> IO () |
@@ -555,21 +596,30 @@ unbindBuffer :: TargetBuffer -> IO () | |||
555 | unbindBuffer target = glBindBuffer (fromTarget target) 0 | 596 | unbindBuffer target = glBindBuffer (fromTarget target) 0 |
556 | 597 | ||
557 | class Storable a => BufferData a where | 598 | class 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 | ||
564 | instance BufferData Word8 | 605 | instance BufferData Word8 |
606 | |||
565 | instance BufferData Word16 | 607 | instance BufferData Word16 |
608 | |||
566 | instance BufferData Word32 | 609 | instance BufferData Word32 |
610 | |||
567 | instance BufferData CChar | 611 | instance BufferData CChar |
612 | |||
568 | instance BufferData CInt | 613 | instance BufferData CInt |
614 | |||
569 | instance BufferData CFloat | 615 | instance BufferData CFloat |
616 | |||
570 | instance BufferData CDouble | 617 | instance BufferData CDouble |
618 | |||
571 | instance BufferData Int | 619 | instance BufferData Int |
620 | |||
572 | instance BufferData Float | 621 | instance BufferData Float |
622 | |||
573 | instance BufferData Double | 623 | instance 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. |
585 | bufferData' :: TargetBuffer | 635 | bufferData' :: |
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 () | ||
590 | bufferData' target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage) | 642 | bufferData' 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. |
601 | data Texture = Texture | 653 | data Texture = Texture |
602 | { getTex :: GLuint | 654 | { getTex :: GLuint, |
603 | , texKey :: Resource | 655 | texKey :: Resource |
604 | } | 656 | } |
605 | 657 | ||
606 | instance Eq Texture where | 658 | instance Eq Texture where |
607 | t1 == t2 = getTex t1 == getTex t2 | 659 | t1 == t2 = getTex t1 == getTex t2 |
608 | 660 | ||
609 | instance Ord Texture where | 661 | instance 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 | ||
612 | instance ResourceClass Texture where | 665 | instance ResourceClass Texture where |
613 | getResource = texKey | 666 | getResource = texKey |
614 | 667 | ||
615 | -- | Create a new texture. | 668 | -- | Create a new texture. |
616 | newTexture :: Game s Texture | 669 | newTexture :: Game s Texture |
617 | newTexture = do | 670 | newTexture = 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. |
626 | deleteTexture :: GLuint -> IO () | 679 | deleteTexture :: GLuint -> IO () |
627 | --deleteTexture tex = with tex $ glDeleteTextures 1 | 680 | --deleteTexture tex = with tex $ glDeleteTextures 1 |
628 | deleteTexture tex = do | 681 | deleteTexture 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. |
633 | loadTextureImage :: FilePath | 686 | loadTextureImage :: |
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 | ||
637 | loadTextureImage file minFilter magFilter = do | 693 | loadTextureImage 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. |
654 | bindTexture :: Texture -> IO () | 710 | bindTexture :: Texture -> IO () |
655 | bindTexture = glBindTexture gl_TEXTURE_2D . getTex | 711 | bindTexture = glBindTexture GL_TEXTURE_2D . getTex |
656 | 712 | ||
657 | -- | Unbind the bound texture. | 713 | -- | Unbind the bound texture. |
658 | unbindTexture :: IO () | 714 | unbindTexture :: IO () |
659 | unbindTexture = glBindTexture gl_TEXTURE_2D 0 | 715 | unbindTexture = 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'. |
664 | loadTextureData :: GLenum | 720 | loadTextureData :: |
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 () | ||
674 | loadTextureData target level internalFormat width height border format texType texData = do | 739 | loadTextureData 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. |
686 | texParami :: GLenum -> GLenum -> SettableStateVar GLenum | 752 | texParami :: GLenum -> GLenum -> SettableStateVar GLenum |
@@ -701,19 +767,20 @@ activeTexture = makeSettableStateVar glActiveTexture | |||
701 | -- | Get the last OpenGL error. | 767 | -- | Get the last OpenGL error. |
702 | getGLError :: IO (Maybe String) | 768 | getGLError :: IO (Maybe String) |
703 | getGLError = fmap translate glGetError | 769 | getGLError = 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. |
714 | printGLError :: IO () | 780 | printGLError :: IO () |
715 | printGLError = getGLError >>= \err -> case err of | 781 | printGLError = |
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. |
723 | assertGL :: Game s a -> String -> Game s a | 790 | assertGL :: Game s a -> String -> Game s a |
724 | assertGL action err = do | 791 | assertGL 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 @@ | |||
1 | module Spear.Game | 1 | module 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 | ) |
27 | where | 31 | where |
28 | 32 | ||
29 | import Control.Monad.Trans.Class (lift) | 33 | import Control.Monad.Catch |
30 | import Control.Monad.State.Strict | 34 | import Control.Monad.State.Strict |
31 | import Control.Monad.Error | 35 | import Control.Monad.Trans.Class (lift) |
32 | import qualified Control.Monad.Trans.Resource as R | 36 | import qualified Control.Monad.Trans.Resource as R |
33 | 37 | ||
34 | type Resource = R.ReleaseKey | 38 | type Resource = R.ReleaseKey |
35 | type Game s = StateT s (R.ResourceT (ErrorT String IO)) | 39 | |
40 | type Game s = StateT s (R.ResourceT IO) | ||
36 | 41 | ||
37 | class ResourceClass a where | 42 | class 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 () | 51 | newtype GameException = GameException String deriving (Show) |
41 | release = unregister . getResource | ||
42 | 52 | ||
43 | clean :: a -> IO () | 53 | instance Exception GameException |
44 | clean = R.release . getResource | ||
45 | 54 | ||
46 | -- | Retrieve the game state. | 55 | -- | Retrieve the game state. |
47 | getGameState :: Game s s | 56 | getGameState :: 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. |
67 | gameError :: String -> Game s a | 76 | gameError :: String -> Game s a |
68 | gameError = lift . lift . throwError | 77 | gameError = gameError' . GameException |
78 | |||
79 | -- | Throw an error from the 'Game' monad. | ||
80 | gameError' :: GameException -> Game s a | ||
81 | gameError' = lift . lift . throwM | ||
69 | 82 | ||
70 | -- | Throw the given error string if given 'Nothing'. | 83 | -- | Throw the given error if given 'Nothing'. |
71 | assertMaybe :: Maybe a -> String -> Game s a | 84 | assertMaybe :: Maybe a -> GameException -> Game s a |
72 | assertMaybe Nothing err = gameError err | 85 | assertMaybe Nothing err = gameError' err |
73 | assertMaybe (Just x) _ = return x | 86 | assertMaybe (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. |
76 | catchGameError :: Game s a -> (String -> Game s a) -> Game s a | 89 | catchGameError :: Game s a -> (GameException -> Game s a) -> Game s a |
77 | catchGameError game catch = catchError game catch | 90 | catchGameError = 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. |
80 | catchGameErrorFinally :: Game s a -> Game s a -> Game s a | 93 | catchGameErrorFinally :: Game s a -> Game s a -> Game s a |
81 | catchGameErrorFinally game finally = catchError game $ \err -> finally >> gameError err | 94 | catchGameErrorFinally game finally = catch game $ \err -> finally >> gameError' err |
82 | 95 | ||
83 | -- | Run the given game. | 96 | -- | Run the given game. |
84 | runGame :: Game s a -> s -> IO (Either String (a,s)) | 97 | runGame :: Game s a -> s -> IO (a, s) |
85 | runGame game state = runErrorT . R.runResourceT . runStateT game $ state | 98 | runGame 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. |
88 | runGame' :: Game s a -> s -> IO (Either String a) | 101 | runGame' :: Game s a -> s -> IO a |
89 | runGame' g s = runGame g s >>= \result -> return $ case result of | 102 | runGame' 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. |
94 | runSubGame :: Game s a -> s -> Game t (a,s) | 105 | runSubGame :: Game s a -> s -> Game t (a, s) |
95 | runSubGame game state = gameIO (runGame game state) >>= \result -> case result of | 106 | runSubGame 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. |
100 | runSubGame' :: Game s a -> s -> Game t () | 109 | runSubGame' :: Game s a -> s -> Game t () |
101 | runSubGame' game state = runSubGame game state >> return () | 110 | runSubGame' 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. |
104 | evalSubGame :: Game s a -> s -> Game t a | 113 | evalSubGame :: Game s a -> s -> Game t a |
105 | evalSubGame g s = runSubGame g s >>= \(a,_) -> return a | 114 | evalSubGame 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. |
108 | execSubGame :: Game s a -> s -> Game t s | 117 | execSubGame :: Game s a -> s -> Game t s |
109 | execSubGame g s = runSubGame g s >>= \(_,s) -> return s | 118 | execSubGame 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. |
112 | gameIO :: IO a -> Game s a | 121 | gameIO :: IO a -> Game s a |
113 | gameIO = lift . lift . lift | 122 | gameIO = 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 @@ | |||
1 | module Spear.Render.AnimatedModel | 1 | module 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 | ) |
28 | where | 32 | where |
29 | 33 | ||
34 | import Control.Applicative ((<$>), (<*>)) | ||
35 | import qualified Data.Vector as V | ||
30 | import Spear.Assets.Model | 36 | import Spear.Assets.Model |
31 | import Spear.Game | ||
32 | import Spear.GL | 37 | import Spear.GL |
38 | import Spear.Game | ||
33 | import Spear.Math.AABB | 39 | import Spear.Math.AABB |
34 | import Spear.Math.Collision | 40 | import Spear.Math.Collision |
35 | import Spear.Math.Matrix4 (Matrix4) | 41 | import Spear.Math.Matrix4 (Matrix4) |
@@ -37,9 +43,6 @@ import Spear.Math.Vector | |||
37 | import Spear.Render.Material | 43 | import Spear.Render.Material |
38 | import Spear.Render.Model | 44 | import Spear.Render.Model |
39 | import Spear.Render.Program | 45 | import Spear.Render.Program |
40 | |||
41 | import Control.Applicative ((<$>), (<*>)) | ||
42 | import qualified Data.Vector as V | ||
43 | import Unsafe.Coerce (unsafeCoerce) | 46 | import Unsafe.Coerce (unsafeCoerce) |
44 | 47 | ||
45 | type AnimationSpeed = Float | 48 | type 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. |
50 | data AnimatedModelResource = AnimatedModelResource | 53 | data 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 | ||
61 | instance Eq AnimatedModelResource where | 64 | instance Eq AnimatedModelResource where |
62 | m1 == m2 = vao m1 == vao m2 | 65 | m1 == m2 = vao m1 == vao m2 |
63 | 66 | ||
64 | instance Ord AnimatedModelResource where | 67 | instance 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 | ||
67 | instance ResourceClass AnimatedModelResource where | 71 | instance 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. |
80 | data AnimatedModelRenderer = AnimatedModelRenderer | 84 | data 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 | ||
90 | instance Eq AnimatedModelRenderer where | 97 | instance Eq AnimatedModelRenderer where |
91 | m1 == m2 = modelResource m1 == modelResource m2 | 98 | m1 == m2 = modelResource m1 == modelResource m2 |
92 | 99 | ||
93 | instance Ord AnimatedModelRenderer where | 100 | instance 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. |
97 | animatedModelResource :: AnimatedProgramChannels | 105 | animatedModelResource :: |
98 | -> Material | 106 | AnimatedProgramChannels -> |
99 | -> Texture | 107 | Material -> |
100 | -> Model | 108 | Texture -> |
101 | -> Game s AnimatedModelResource | 109 | Model -> |
102 | 110 | Game s AnimatedModelResource | |
103 | animatedModelResource | 111 | animatedModelResource |
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. |
144 | animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer | 160 | animatedModelRenderer :: AnimationSpeed -> AnimatedModelResource -> AnimatedModelRenderer |
145 | animatedModelRenderer animSpeed modelResource = | 161 | animatedModelRenderer 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. |
149 | update dt (AnimatedModelRenderer model curAnim startFrame endFrame curFrame fp s) = | 165 | update 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. |
160 | box :: Int -> AnimatedModelResource -> Box | 179 | box :: Int -> AnimatedModelResource -> Box |
@@ -171,65 +190,65 @@ modelRes = modelResource | |||
171 | -- | Get the renderer's next frame. | 190 | -- | Get the renderer's next frame. |
172 | nextFrame :: AnimatedModelRenderer -> Int | 191 | nextFrame :: AnimatedModelRenderer -> Int |
173 | nextFrame rend = | 192 | nextFrame 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. |
181 | setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer | 199 | setAnimation :: Enum a => a -> AnimatedModelRenderer -> AnimatedModelRenderer |
182 | setAnimation anim modelRend = | 200 | setAnimation 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. |
189 | setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer | 206 | setAnimationSpeed :: AnimationSpeed -> AnimatedModelRenderer -> AnimatedModelRenderer |
190 | setAnimationSpeed s r = r { animationSpeed = s } | 207 | setAnimationSpeed 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. |
193 | bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () | 210 | bind :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () |
194 | bind (AnimatedProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _ _) modelRend = | 211 | bind (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. |
203 | render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () | 220 | render :: AnimatedProgramUniforms -> AnimatedModelRenderer -> IO () |
204 | render uniforms (AnimatedModelRenderer model _ _ _ curFrame fp _) = | 221 | render 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. |
216 | mkColsFromAnimated | 233 | mkColsFromAnimated :: |
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] | ||
223 | mkColsFromAnimated f1 f2 fp modelview modelRes = | 244 | mkColsFromAnimated 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 @@ | |||
1 | module Spear.Render.StaticModel | 1 | module 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 | ) |
18 | where | 21 | where |
19 | 22 | ||
23 | import qualified Data.Vector as V | ||
20 | import Spear.Assets.Model | 24 | import Spear.Assets.Model |
21 | import Spear.Game | ||
22 | import Spear.GL | 25 | import Spear.GL |
26 | import Spear.Game | ||
23 | import Spear.Math.AABB | 27 | import Spear.Math.AABB |
24 | import Spear.Math.Collision | 28 | import Spear.Math.Collision |
25 | import Spear.Math.Matrix4 (Matrix4) | 29 | import Spear.Math.Matrix4 (Matrix4) |
@@ -27,75 +31,80 @@ import Spear.Math.Vector | |||
27 | import Spear.Render.Material | 31 | import Spear.Render.Material |
28 | import Spear.Render.Model | 32 | import Spear.Render.Model |
29 | import Spear.Render.Program | 33 | import Spear.Render.Program |
30 | |||
31 | import qualified Data.Vector as V | ||
32 | import Unsafe.Coerce (unsafeCoerce) | 34 | import Unsafe.Coerce (unsafeCoerce) |
33 | 35 | ||
34 | data StaticModelResource = StaticModelResource | 36 | data 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 | ||
43 | instance Eq StaticModelResource where | 45 | instance Eq StaticModelResource where |
44 | m1 == m2 = vao m1 == vao m2 | 46 | m1 == m2 = vao m1 == vao m2 |
45 | 47 | ||
46 | instance Ord StaticModelResource where | 48 | instance 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 | ||
49 | instance ResourceClass StaticModelResource where | 52 | instance ResourceClass StaticModelResource where |
50 | getResource = rkey | 53 | getResource = rkey |
51 | 54 | ||
52 | data StaticModelRenderer = StaticModelRenderer { model :: StaticModelResource } | 55 | data StaticModelRenderer = StaticModelRenderer {model :: StaticModelResource} |
53 | 56 | ||
54 | instance Eq StaticModelRenderer where | 57 | instance Eq StaticModelRenderer where |
55 | m1 == m2 = model m1 == model m2 | 58 | m1 == m2 = model m1 == model m2 |
56 | 59 | ||
57 | instance Ord StaticModelRenderer where | 60 | instance 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. |
61 | staticModelResource :: StaticProgramChannels | 65 | staticModelResource :: |
62 | -> Material | 66 | StaticProgramChannels -> |
63 | -> Texture | 67 | Material -> |
64 | -> Model | 68 | Texture -> |
65 | -> Game s StaticModelResource | 69 | Model -> |
66 | 70 | Game s StaticModelResource | |
67 | staticModelResource (StaticProgramChannels vertChan normChan texChan) material texture model = do | 71 | staticModelResource (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. |
101 | staticModelRenderer :: StaticModelResource -> StaticModelRenderer | 110 | staticModelRenderer :: 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. |
113 | bind :: StaticProgramUniforms -> StaticModelRenderer -> IO () | 122 | bind :: StaticProgramUniforms -> StaticModelRenderer -> IO () |
114 | bind (StaticProgramUniforms kaLoc kdLoc ksLoc shiLoc texLoc _ _ _) (StaticModelRenderer model) = | 123 | bind (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. |
123 | render :: StaticProgramUniforms -> StaticModelRenderer -> IO () | 132 | render :: StaticProgramUniforms -> StaticModelRenderer -> IO () |
124 | render uniforms (StaticModelRenderer model) = | 133 | render 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. |
134 | mkColsFromStatic | 143 | mkColsFromStatic :: |
135 | :: Matrix4 -- ^ Modelview matrix | 144 | -- | Modelview matrix |
136 | -> StaticModelResource | 145 | Matrix4 -> |
137 | -> [Collisioner2] | 146 | StaticModelResource -> |
147 | [Collisioner2] | ||
138 | mkColsFromStatic modelview modelRes = mkCols modelview (box 0 modelRes) | 148 | mkColsFromStatic 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 | |||
1 | module Spear.Scene.Loader | 3 | module 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 | ) | ||
15 | where | 16 | where |
16 | 17 | ||
18 | import Control.Monad.State.Strict | ||
19 | import Control.Monad.Trans (lift) | ||
20 | import Data.List as L (find) | ||
21 | import Data.Map as M | ||
22 | import qualified Data.StateVar as SV (get) | ||
17 | import Spear.Assets.Model as Model | 23 | import Spear.Assets.Model as Model |
18 | import Spear.Game | ||
19 | import qualified Spear.GL as GL | 24 | import qualified Spear.GL as GL |
25 | import Spear.Game | ||
20 | import Spear.Math.Collision | 26 | import Spear.Math.Collision |
21 | import Spear.Math.Matrix3 as M3 | 27 | import Spear.Math.Matrix3 as M3 |
22 | import Spear.Math.Matrix4 as M4 | 28 | import Spear.Math.Matrix4 as M4 |
@@ -28,12 +34,6 @@ import Spear.Render.Program | |||
28 | import Spear.Render.StaticModel as SM | 34 | import Spear.Render.StaticModel as SM |
29 | import Spear.Scene.Graph | 35 | import Spear.Scene.Graph |
30 | import Spear.Scene.SceneResources | 36 | import Spear.Scene.SceneResources |
31 | |||
32 | import Control.Monad.State.Strict | ||
33 | import Control.Monad.Trans (lift) | ||
34 | import Data.List as L (find) | ||
35 | import Data.Map as M | ||
36 | import qualified Data.StateVar as SV (get) | ||
37 | import Text.Printf (printf) | 37 | import Text.Printf (printf) |
38 | 38 | ||
39 | type Loader = Game SceneResources | 39 | type 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. |
42 | loadScene :: FilePath -> Game s (SceneResources, SceneGraph) | 42 | loadScene :: FilePath -> Game s (SceneResources, SceneGraph) |
43 | loadScene file = do | 43 | loadScene 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. |
54 | validate :: SceneGraph -> Maybe String | 54 | validate :: SceneGraph -> Maybe String |
@@ -60,59 +60,63 @@ resourceMap g = execSubGame (resourceMap' g) emptySceneResources | |||
60 | 60 | ||
61 | resourceMap' :: SceneGraph -> Loader () | 61 | resourceMap' :: SceneGraph -> Loader () |
62 | resourceMap' node@(SceneLeaf nid props) = do | 62 | resourceMap' 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 | |||
68 | resourceMap' node@(SceneNode nid props children) = do | 67 | resourceMap' 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. |
72 | loadResource :: String -- ^ Resource name. | 71 | loadResource :: |
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 | ||
77 | loadResource key field modifyResources load = do | 81 | loadResource 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 | ||
88 | addShader name shader = modify $ \sceneData -> | 92 | addShader name shader = modify $ \sceneData -> |
89 | sceneData { shaders = M.insert name shader $ shaders sceneData } | 93 | sceneData {shaders = M.insert name shader $ shaders sceneData} |
90 | 94 | ||
91 | addCustomProgram name prog = modify $ \sceneData -> | 95 | addCustomProgram name prog = modify $ \sceneData -> |
92 | sceneData { customPrograms = M.insert name prog $ customPrograms sceneData } | 96 | sceneData {customPrograms = M.insert name prog $ customPrograms sceneData} |
93 | 97 | ||
94 | addStaticProgram name prog = modify $ \sceneData -> | 98 | addStaticProgram name prog = modify $ \sceneData -> |
95 | sceneData { staticPrograms = M.insert name prog $ staticPrograms sceneData } | 99 | sceneData {staticPrograms = M.insert name prog $ staticPrograms sceneData} |
96 | 100 | ||
97 | addAnimatedProgram name prog = modify $ \sceneData -> | 101 | addAnimatedProgram name prog = modify $ \sceneData -> |
98 | sceneData { animatedPrograms = M.insert name prog $ animatedPrograms sceneData } | 102 | sceneData {animatedPrograms = M.insert name prog $ animatedPrograms sceneData} |
99 | 103 | ||
100 | addTexture name tex = modify $ \sceneData -> | 104 | addTexture name tex = modify $ \sceneData -> |
101 | sceneData { textures = M.insert name tex $ textures sceneData } | 105 | sceneData {textures = M.insert name tex $ textures sceneData} |
102 | 106 | ||
103 | addStaticModel name model = modify $ | 107 | addStaticModel 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 | ||
106 | addAnimatedModel name model = modify $ | 110 | addAnimatedModel 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. |
110 | getResource :: (SceneResources -> Map String a) -> String -> Loader a | 114 | getResource :: (SceneResources -> Map String a) -> String -> Loader a |
111 | getResource field key = do | 115 | getResource 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 | ||
121 | newModel :: SceneGraph -> Loader () | 125 | newModel :: SceneGraph -> Loader () |
122 | newModel (SceneLeaf _ props) = do | 126 | newModel (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 | ||
164 | loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Game s Model | 168 | loadModel' :: FilePath -> Maybe Rotation -> Maybe Vector3 -> Game s Model |
165 | loadModel' file rotation scale = do | 169 | loadModel' 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 | ||
178 | rotateModel :: Rotation -> Model -> Model | 183 | rotateModel :: Rotation -> Model -> Model |
179 | rotateModel (Rotation ax ay az order) model = | 184 | rotateModel (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 | ||
197 | loadTexture :: FilePath -> Loader GL.Texture | 201 | loadTexture :: FilePath -> Loader GL.Texture |
198 | loadTexture file = | 202 | loadTexture 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 | ||
202 | newShaderProgram :: SceneGraph -> Loader () | 206 | newShaderProgram :: SceneGraph -> Loader () |
203 | newShaderProgram (SceneLeaf _ props) = do | 207 | newShaderProgram (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 | ||
281 | loadShader :: GL.ShaderType -> [Property] -> Loader (String, GL.GLSLShader) | 283 | loadShader :: GL.ShaderType -> [Property] -> Loader (String, GL.GLSLShader) |
282 | loadShader _ [] = gameError $ "Loader::vertexShader: empty list" | 284 | loadShader _ [] = gameError $ "Loader::vertexShader: empty list" |
283 | loadShader shaderType ((stype, file):xs) = | 285 | loadShader 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 | ||
290 | loadShader' :: String -> GL.ShaderType -> Loader GL.GLSLShader | 293 | loadShader' :: 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. |
298 | value :: String -> [Property] -> Maybe [String] | 301 | value :: String -> [Property] -> Maybe [String] |
299 | value name props = case L.find ((==) name . fst) props of | 302 | value 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 | ||
303 | unspecified :: Maybe a -> a -> a | 306 | unspecified :: Maybe a -> a -> a |
304 | unspecified (Just x) _ = x | 307 | unspecified (Just x) _ = x |
305 | unspecified Nothing x = x | 308 | unspecified Nothing x = x |
306 | 309 | ||
307 | mandatory :: String -> [Property] -> Game s [String] | 310 | mandatory :: String -> [Property] -> Game s [String] |
308 | mandatory name props = case value name props of | 311 | mandatory 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 | ||
312 | mandatory' :: String -> [Property] -> Loader [String] | 315 | mandatory' :: String -> [Property] -> Loader [String] |
313 | mandatory' name props = mandatory name props | 316 | mandatory' name props = mandatory name props |
@@ -320,31 +323,35 @@ asFloat = fmap (read . concat) | |||
320 | 323 | ||
321 | asVec2 :: Functor f => f [String] -> f Vector2 | 324 | asVec2 :: Functor f => f [String] -> f Vector2 |
322 | asVec2 val = fmap toVec2 val | 325 | asVec2 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 | ||
326 | asVec3 :: Functor f => f [String] -> f Vector3 | 330 | asVec3 :: Functor f => f [String] -> f Vector3 |
327 | asVec3 val = fmap toVec3 val | 331 | asVec3 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 | ||
331 | asVec4 :: Functor f => f [String] -> f Vector4 | 336 | asVec4 :: Functor f => f [String] -> f Vector4 |
332 | asVec4 val = fmap toVec4 val | 337 | asVec4 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 | ||
336 | asRotation :: Functor f => f [String] -> f Rotation | 342 | asRotation :: Functor f => f [String] -> f Rotation |
337 | asRotation val = fmap parseRotation val | 343 | asRotation 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 | ||
340 | data Rotation = Rotation | 347 | data 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 | ||
347 | data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving Eq | 354 | data RotationOrder = XYZ | XZY | YXZ | YZX | ZXY | ZYX deriving (Eq) |
348 | 355 | ||
349 | readOrder :: String -> RotationOrder | 356 | readOrder :: String -> RotationOrder |
350 | readOrder "xyz" = XYZ | 357 | readOrder "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 | |||
2 | module Spear.Step | 3 | module 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 | ) |
24 | where | 27 | where |
25 | 28 | ||
26 | import Data.List (foldl') | 29 | import Data.List (foldl') |
27 | import qualified Data.Map as Map | ||
28 | import Data.Map (Map) | 30 | import Data.Map (Map) |
31 | import qualified Data.Map as Map | ||
29 | import Data.Monoid | 32 | import Data.Monoid |
30 | 33 | ||
31 | type Elapsed = Double | 34 | type Elapsed = Double |
35 | |||
32 | type Dt = Float | 36 | type Dt = Float |
33 | 37 | ||
34 | -- | A step function. | 38 | -- | A step function. |
35 | data Step s e a b = | 39 | newtype 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 | ||
38 | instance Functor (Step s e a) where | 43 | instance 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 | |||
48 | instance Semigroup (Step s e a a) where | ||
49 | (<>) = (.>) | ||
42 | 50 | ||
43 | instance Monoid (Step s e a a) where | 51 | instance 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. |
52 | step :: (Elapsed -> Dt -> s -> e -> a -> (b, Step s e a b)) -> Step s e a b | 60 | step :: (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 | |||
61 | spure f = Step $ \_ _ _ _ x -> (f x, spure f) | 69 | spure 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. |
64 | sfst :: Step s e (a,b) a | 72 | sfst :: Step s e (a, b) a |
65 | sfst = spure $ \(a,_) -> a | 73 | sfst = 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. |
68 | ssnd :: Step s e (a,b) b | 76 | ssnd :: Step s e (a, b) b |
69 | ssnd = spure $ \(_,b) -> b | 77 | ssnd = 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. |
74 | sfold :: Step s (Maybe e) a a -> Step s [e] a a | 82 | sfold :: Step s (Maybe e) a a -> Step s [e] a a |
75 | sfold s = Step $ \elapsed dt g es a -> | 83 | sfold 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 | ||
84 | sfold' :: Elapsed -> Dt -> s -> Step s (Maybe e) a a -> a -> [e] | 92 | sfold' :: |
85 | -> (a, Step s (Maybe e) a a) | 93 | Elapsed -> |
86 | sfold' 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) | ||
100 | sfold' 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. |
104 | szip :: (a -> b -> c) -> Step s e d a -> Step s e d b -> Step s e d c | 119 | szip :: (a -> b -> c) -> Step s e d a -> Step s e d b -> Step s e d c |
105 | szip f (Step s1) (Step s2) = Step $ \elapsed dt g e d -> | 120 | szip 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. |
113 | switch :: Eq e | 128 | switch :: |
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 | ||
117 | switch flag1 s1 flag2 s2 = switch' s1 flag1 s1 flag2 s2 | 135 | switch flag1 s1 flag2 s2 = switch' s1 flag1 s1 flag2 s2 |
118 | 136 | ||
119 | switch' :: Eq e | 137 | switch' :: |
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 | ||
124 | switch' cur flag1 s1 flag2 s2 = Step $ \elapsed dt g e a -> | 145 | switch' 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. |
137 | multiSwitch :: (Eq e, Ord e) => [(e, Step s (Maybe e) a a)] -> Step s (Maybe e) a a | 162 | multiSwitch :: (Eq e, Ord e) => [(e, Step s (Maybe e) a a)] -> Step s (Maybe e) a a |
138 | multiSwitch xs = multiSwitch' Nothing sid (Map.fromList xs) | 163 | multiSwitch xs = multiSwitch' Nothing sid (Map.fromList xs) |
139 | 164 | ||
140 | multiSwitch' :: (Eq e, Ord e) | 165 | multiSwitch' :: |
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 | ||
143 | multiSwitch' curKey cur m = Step $ \elapsed dt g e a -> | 171 | multiSwitch' 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 | ||
65 | foreign import ccall unsafe "Timer.h timer_init" | 65 | foreign import ccall unsafe "Timer.h timer_init" |
66 | c_timer_init :: Ptr Timer -> IO () | 66 | c_timer_init :: Ptr Timer -> IO () |
67 | 67 | ||
68 | foreign import ccall unsafe "Timer.h timer_tick" | 68 | foreign import ccall unsafe "Timer.h timer_tick" |
69 | c_timer_tick :: Ptr Timer -> IO () | 69 | c_timer_tick :: Ptr Timer -> IO () |
70 | 70 | ||
71 | foreign import ccall unsafe "Timer.h timer_start" | 71 | foreign import ccall unsafe "Timer.h timer_start" |
72 | c_timer_start :: Ptr Timer -> IO () | 72 | c_timer_start :: Ptr Timer -> IO () |
73 | 73 | ||
74 | foreign import ccall unsafe "Timer.h timer_stop" | 74 | foreign import ccall unsafe "Timer.h timer_stop" |
75 | c_timer_stop :: Ptr Timer -> IO () | 75 | c_timer_stop :: Ptr Timer -> IO () |
76 | 76 | ||
77 | foreign import ccall unsafe "Timer.h timer_reset" | 77 | foreign import ccall unsafe "Timer.h timer_reset" |
78 | c_timer_reset :: Ptr Timer -> IO () | 78 | c_timer_reset :: Ptr Timer -> IO () |
79 | 79 | ||
80 | foreign import ccall unsafe "Timer.h timer_get_time" | 80 | foreign 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 | ||
83 | foreign import ccall unsafe "Timer.h timer_get_delta" | 83 | foreign 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 | ||
86 | foreign import ccall unsafe "Timer.h timer_is_running" | 86 | foreign 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 | ||
89 | foreign import ccall "Timer.h timer_sleep" | 89 | foreign 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. |
93 | newTimer :: Timer | 93 | newTimer :: Timer |
@@ -105,10 +105,10 @@ tick t = alloca $ \tptr -> do | |||
105 | -- | Start the timer. | 105 | -- | Start the timer. |
106 | start :: Timer -> IO (Timer) | 106 | start :: Timer -> IO (Timer) |
107 | start t = alloca $ \tptr -> do | 107 | start 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. |
114 | stop :: Timer -> IO (Timer) | 114 | stop :: Timer -> IO (Timer) |
@@ -120,30 +120,30 @@ stop t = alloca $ \tptr -> do | |||
120 | -- | Reset the timer. | 120 | -- | Reset the timer. |
121 | reset :: Timer -> IO (Timer) | 121 | reset :: Timer -> IO (Timer) |
122 | reset t = alloca $ \tptr -> do | 122 | reset 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. |
128 | getTime :: Timer -> Double | 128 | getTime :: Timer -> Double |
129 | getTime t = unsafeDupablePerformIO . alloca $ \tptr -> do | 129 | getTime 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. |
135 | getDelta :: Timer -> Float | 135 | getDelta :: Timer -> Float |
136 | getDelta t = unsafeDupablePerformIO . alloca $ \tptr -> do | 136 | getDelta 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. |
142 | isRunning :: Timer -> Bool | 142 | isRunning :: Timer -> Bool |
143 | isRunning t = unsafeDupablePerformIO . alloca $ \tptr -> do | 143 | isRunning 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. |
149 | sleep :: Float -> IO () | 149 | sleep :: 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 @@ | |||
1 | module Spear.Window | 1 | module 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 | ) |
36 | where | 35 | where |
37 | 36 | ||
38 | import Spear.Game | ||
39 | import Spear.Sys.Timer as Timer | ||
40 | |||
41 | import Data.Char (ord) | ||
42 | import Control.Concurrent.MVar | 37 | import Control.Concurrent.MVar |
43 | import Control.Monad (when, foldM) | 38 | import Control.Exception |
39 | import Control.Monad (foldM, unless, void, when) | ||
44 | import Control.Monad.IO.Class | 40 | import Control.Monad.IO.Class |
41 | import Data.Char (ord) | ||
42 | import Data.Maybe (fromJust, fromMaybe, isJust) | ||
45 | import GHC.Float | 43 | import GHC.Float |
46 | import qualified Graphics.UI.GLFW as GLFW | ||
47 | import Graphics.UI.GLFW (DisplayBits(..), WindowMode(..)) | ||
48 | import qualified Graphics.Rendering.OpenGL as GL | 44 | import qualified Graphics.Rendering.OpenGL as GL |
45 | import qualified Graphics.UI.GLFW as GLFW | ||
46 | import Spear.Game | ||
47 | import Spear.Sys.Timer as Timer | ||
48 | |||
49 | maxFPS = 60 | ||
50 | |||
51 | type Width = Int | ||
49 | 52 | ||
50 | type Width = Int | ||
51 | type Height = Int | 53 | type 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. |
64 | data Window = Window | 66 | data 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. |
70 | events :: MonadIO m => Window -> m [InputEvent] | 73 | events :: MonadIO m => Window -> m [InputEvent] |
71 | events wnd = liftIO $ do | 74 | events 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. |
79 | type Init s = Window -> Game () s | 83 | type Init s = Window -> Game () s |
80 | 84 | ||
81 | run :: MonadIO m => m (Either String a) -> m () | 85 | withWindow :: |
82 | run 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 | |
88 | withWindow :: MonadIO m | 92 | withWindow 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 |
94 | withWindow 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 | 104 | setup :: |
101 | gameIO GLFW.terminate | 105 | Dimensions -> |
102 | return result | 106 | Context -> |
103 | 107 | Maybe WindowTitle -> | |
104 | setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle | 108 | Game s Window |
105 | -> Game s Window | 109 | setup (w, h) (major, minor) windowTitle = do |
106 | setup (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 | |||
131 | defaultBits [] = [DisplayRGBBits 8 8 8] | ||
132 | defaultBits xs = xs | ||
133 | |||
134 | compat (major, minor) | ||
135 | | major >= 3 = GLFW.openWindowHint GLFW.OpenGLProfile GLFW.OpenGLCompatProfile | ||
136 | | otherwise = return () | ||
137 | 131 | ||
138 | glfwInit :: Game s () | 132 | glfwInit :: Game s () |
139 | glfwInit = do | 133 | glfwInit = 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. |
146 | type Elapsed = Double | 138 | type Elapsed = Double |
@@ -149,279 +141,331 @@ type Elapsed = Double | |||
149 | type Dt = Float | 141 | type 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. |
152 | type Step s = Elapsed -> Dt -> Game s (Bool) | 144 | type Step s = Elapsed -> Dt -> Game s Bool |
153 | 145 | ||
154 | -- | Maximum frame rate. | 146 | -- | Maximum frame rate. |
155 | type FrameCap = Int | 147 | type FrameCap = Int |
156 | 148 | ||
157 | -- | Run the application's main loop. | 149 | loop :: Step s -> Window -> Game s () |
158 | loop :: Maybe FrameCap -> Step s -> Window -> Game s () | 150 | loop step window = do |
159 | loop (Just maxFPS) step wnd = loopCapped maxFPS step wnd | 151 | let ddt = 1.0 / fromIntegral maxFPS |
160 | loop 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 () | |
165 | loop' :: CloseRequest -> Timer -> Elapsed -> Step s -> Game s () | 157 | |
166 | loop' closeRequest timer elapsed step = do | 158 | loop' :: |
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 -> | |
174 | loopCapped :: Int -> Step s -> Window -> Game s () | 166 | Game s () |
175 | loopCapped maxFPS step wnd = do | 167 | loop' 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 | |
183 | loopCapped' :: CloseRequest -> Float -> Timer -> Timer -> Elapsed -> Step s | 175 | close <- gameIO $ getRequest closeRequest |
184 | -> Game s () | 176 | controlTimer'' <- gameIO $ tick controlTimer' |
185 | loopCapped' 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 | ||
199 | getRequest :: MVar Bool -> IO Bool | 189 | getRequest :: MVar Bool -> IO Bool |
200 | getRequest mvar = tryTakeMVar mvar >>= \x -> return $ case x of | 190 | getRequest mvar = |
201 | Nothing -> False | 191 | tryTakeMVar mvar >>= \x -> return $ fromMaybe False x |
202 | Just x -> x | ||
203 | 192 | ||
204 | onWindowClose :: MVar Bool -> GLFW.WindowCloseCallback | 193 | onWindowClose :: MVar Bool -> GLFW.WindowCloseCallback |
205 | onWindowClose closeRequest = putMVar closeRequest True >> return False | 194 | onWindowClose closeRequest window = do putMVar closeRequest True |
206 | 195 | ||
207 | onResize :: MVar [InputEvent] -> GLFW.WindowSizeCallback | 196 | onResize :: MVar [InputEvent] -> GLFW.WindowSizeCallback |
208 | onResize es (GL.Size w h) = addEvent es $ Resize (fromIntegral w) (fromIntegral h) | 197 | onResize events window w h = addEvent events $ Resize w h |
209 | 198 | ||
210 | onKey :: MVar [InputEvent] -> GLFW.KeyCallback | 199 | onKey :: MVar [InputEvent] -> GLFW.KeyCallback |
211 | onKey es key GLFW.Press = addEvent es $ KeyDown (fromGLFWkey key) | 200 | onKey events window key _ GLFW.KeyState'Pressed _ = addEvent events $ KeyDown (fromGLFWkey key) |
212 | onKey es key GLFW.Release = addEvent es $ KeyUp (fromGLFWkey key) | 201 | onKey events window key _ GLFW.KeyState'Released _ = addEvent events $ KeyUp (fromGLFWkey key) |
202 | onKey events window key _ GLFW.KeyState'Repeating _ = return () | ||
213 | 203 | ||
214 | onChar :: MVar [InputEvent] -> GLFW.CharCallback | 204 | onChar :: MVar [InputEvent] -> GLFW.CharCallback |
215 | onChar es c GLFW.Press = addEvent es $ KeyDown (fromGLFWkey (GLFW.CharKey c)) | 205 | onChar events window char = addEvent events $ KeyDown . fromGLFWkey . read $ [char] |
216 | onChar es c GLFW.Release = addEvent es $ KeyUp (fromGLFWkey (GLFW.CharKey c)) | ||
217 | 206 | ||
218 | onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback | 207 | onMouseButton :: MVar [InputEvent] -> GLFW.MouseButtonCallback |
219 | onMouseButton es bt GLFW.Press = addEvent es $ MouseDown (fromGLFWbutton bt) | 208 | onMouseButton events window button GLFW.MouseButtonState'Pressed _ = addEvent events $ MouseDown (fromGLFWbutton button) |
220 | onMouseButton es bt GLFW.Release = addEvent es $ MouseUp (fromGLFWbutton bt) | 209 | onMouseButton events window button GLFW.MouseButtonState'Released _ = addEvent events $ MouseUp (fromGLFWbutton button) |
221 | 210 | ||
222 | onMouseMove :: MVar [InputEvent] -> IO GLFW.MousePosCallback | 211 | onMouseMove :: MVar [InputEvent] -> IO GLFW.CursorPosCallback |
223 | onMouseMove es = newEmptyMVar >>= return . flip onMouseMove' es | 212 | onMouseMove events = newEmptyMVar >>= return . flip onMouseMove' events |
224 | 213 | ||
225 | onMouseMove' :: MVar MousePos -> MVar [InputEvent] -> GLFW.MousePosCallback | 214 | onMouseMove' :: MVar MousePos -> MVar [InputEvent] -> GLFW.CursorPosCallback |
226 | onMouseMove' oldPos es (GL.Position x y) = do | 215 | onMouseMove' 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 | ||
235 | replaceMVar :: MVar a -> a -> IO () | 224 | replaceMVar :: MVar a -> a -> IO () |
236 | replaceMVar mvar val = tryTakeMVar mvar >> putMVar mvar val | 225 | replaceMVar mvar val = tryTakeMVar mvar >> putMVar mvar val |
237 | 226 | ||
238 | addEvent :: MVar [a] -> a -> IO () | 227 | addEvent :: MVar [a] -> a -> IO () |
239 | addEvent mvar val = tryTakeMVar mvar >>= \xs -> case xs of | 228 | addEvent 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. |
246 | whenKeyDown :: Key -> Game s a -> Game s () | 236 | whenKeyDown :: GLFW.Window -> Key -> Game s a -> Game s () |
247 | whenKeyDown = whenKey (==GLFW.Press) | 237 | whenKeyDown = 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. |
250 | whenKeyUp :: Key -> Game s a -> Game s () | 240 | whenKeyUp :: GLFW.Window -> Key -> Game s a -> Game s () |
251 | whenKeyUp = whenKey (==GLFW.Release) | 241 | whenKeyUp = whenKeyInState (== GLFW.KeyState'Released) |
252 | 242 | ||
253 | whenKey :: (GLFW.KeyButtonState -> Bool) -> Key -> Game s a -> Game s () | 243 | whenKeyInState :: (GLFW.KeyState -> Bool) -> GLFW.Window -> Key -> Game s a -> Game s () |
254 | whenKey pred key game = do | 244 | whenKeyInState 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. |
260 | processKeys :: [(Key,a)] -> Game s [a] | 250 | processKeys :: GLFW.Window -> [(Key, a)] -> Game s [a] |
261 | processKeys = foldM f [] | 251 | processKeys 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. |
269 | processButtons :: [(MouseButton,a)] -> Game s [a] | 261 | processButtons :: GLFW.Window -> [(MouseButton, a)] -> Game s [a] |
270 | processButtons = foldM f [] | 262 | processButtons 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 | ||
276 | data InputEvent | 270 | data 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 | ||
285 | data Key | 279 | data 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 | ||
296 | data MouseButton = LMB | RMB | MMB | 337 | data MouseButton = LMB | RMB | MMB |
297 | deriving (Eq, Enum, Bounded, Show) | 338 | deriving (Eq, Enum, Bounded, Show) |
298 | 339 | ||
299 | data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta | 340 | data MouseProp = MouseX | MouseY | MouseDX | MouseDY | Wheel | WheelDelta |
300 | deriving (Eq, Enum, Bounded, Show) | 341 | deriving (Eq, Enum, Bounded, Show) |
301 | 342 | ||
302 | type MousePos = (Int,Int) | 343 | type MousePos = (Double, Double) |
303 | type MouseDelta = (Int,Int) | 344 | |
345 | type MouseDelta = (Double, Double) | ||
304 | 346 | ||
305 | fromGLFWkey :: GLFW.Key -> Key | 347 | fromGLFWkey :: GLFW.Key -> Key |
306 | fromGLFWkey (GLFW.CharKey 'A') = KEY_A | 348 | fromGLFWkey GLFW.Key'A = KEY_A |
307 | fromGLFWkey (GLFW.CharKey 'B') = KEY_B | 349 | fromGLFWkey GLFW.Key'B = KEY_B |
308 | fromGLFWkey (GLFW.CharKey 'C') = KEY_C | 350 | fromGLFWkey GLFW.Key'C = KEY_C |
309 | fromGLFWkey (GLFW.CharKey 'D') = KEY_D | 351 | fromGLFWkey GLFW.Key'D = KEY_D |
310 | fromGLFWkey (GLFW.CharKey 'E') = KEY_E | 352 | fromGLFWkey GLFW.Key'E = KEY_E |
311 | fromGLFWkey (GLFW.CharKey 'F') = KEY_F | 353 | fromGLFWkey GLFW.Key'F = KEY_F |
312 | fromGLFWkey (GLFW.CharKey 'G') = KEY_G | 354 | fromGLFWkey GLFW.Key'G = KEY_G |
313 | fromGLFWkey (GLFW.CharKey 'H') = KEY_H | 355 | fromGLFWkey GLFW.Key'H = KEY_H |
314 | fromGLFWkey (GLFW.CharKey 'I') = KEY_I | 356 | fromGLFWkey GLFW.Key'I = KEY_I |
315 | fromGLFWkey (GLFW.CharKey 'J') = KEY_J | 357 | fromGLFWkey GLFW.Key'J = KEY_J |
316 | fromGLFWkey (GLFW.CharKey 'K') = KEY_K | 358 | fromGLFWkey GLFW.Key'K = KEY_K |
317 | fromGLFWkey (GLFW.CharKey 'L') = KEY_L | 359 | fromGLFWkey GLFW.Key'L = KEY_L |
318 | fromGLFWkey (GLFW.CharKey 'M') = KEY_M | 360 | fromGLFWkey GLFW.Key'M = KEY_M |
319 | fromGLFWkey (GLFW.CharKey 'N') = KEY_N | 361 | fromGLFWkey GLFW.Key'N = KEY_N |
320 | fromGLFWkey (GLFW.CharKey 'O') = KEY_O | 362 | fromGLFWkey GLFW.Key'O = KEY_O |
321 | fromGLFWkey (GLFW.CharKey 'P') = KEY_P | 363 | fromGLFWkey GLFW.Key'P = KEY_P |
322 | fromGLFWkey (GLFW.CharKey 'Q') = KEY_Q | 364 | fromGLFWkey GLFW.Key'Q = KEY_Q |
323 | fromGLFWkey (GLFW.CharKey 'R') = KEY_R | 365 | fromGLFWkey GLFW.Key'R = KEY_R |
324 | fromGLFWkey (GLFW.CharKey 'S') = KEY_S | 366 | fromGLFWkey GLFW.Key'S = KEY_S |
325 | fromGLFWkey (GLFW.CharKey 'T') = KEY_T | 367 | fromGLFWkey GLFW.Key'T = KEY_T |
326 | fromGLFWkey (GLFW.CharKey 'U') = KEY_U | 368 | fromGLFWkey GLFW.Key'U = KEY_U |
327 | fromGLFWkey (GLFW.CharKey 'V') = KEY_V | 369 | fromGLFWkey GLFW.Key'V = KEY_V |
328 | fromGLFWkey (GLFW.CharKey 'W') = KEY_W | 370 | fromGLFWkey GLFW.Key'W = KEY_W |
329 | fromGLFWkey (GLFW.CharKey 'X') = KEY_X | 371 | fromGLFWkey GLFW.Key'X = KEY_X |
330 | fromGLFWkey (GLFW.CharKey 'Y') = KEY_Y | 372 | fromGLFWkey GLFW.Key'Y = KEY_Y |
331 | fromGLFWkey (GLFW.CharKey 'Z') = KEY_Z | 373 | fromGLFWkey GLFW.Key'Z = KEY_Z |
332 | fromGLFWkey (GLFW.CharKey '0') = KEY_0 | 374 | fromGLFWkey GLFW.Key'0 = KEY_0 |
333 | fromGLFWkey (GLFW.CharKey '1') = KEY_1 | 375 | fromGLFWkey GLFW.Key'1 = KEY_1 |
334 | fromGLFWkey (GLFW.CharKey '2') = KEY_2 | 376 | fromGLFWkey GLFW.Key'2 = KEY_2 |
335 | fromGLFWkey (GLFW.CharKey '3') = KEY_3 | 377 | fromGLFWkey GLFW.Key'3 = KEY_3 |
336 | fromGLFWkey (GLFW.CharKey '4') = KEY_4 | 378 | fromGLFWkey GLFW.Key'4 = KEY_4 |
337 | fromGLFWkey (GLFW.CharKey '5') = KEY_5 | 379 | fromGLFWkey GLFW.Key'5 = KEY_5 |
338 | fromGLFWkey (GLFW.CharKey '6') = KEY_6 | 380 | fromGLFWkey GLFW.Key'6 = KEY_6 |
339 | fromGLFWkey (GLFW.CharKey '7') = KEY_7 | 381 | fromGLFWkey GLFW.Key'7 = KEY_7 |
340 | fromGLFWkey (GLFW.CharKey '8') = KEY_8 | 382 | fromGLFWkey GLFW.Key'8 = KEY_8 |
341 | fromGLFWkey (GLFW.CharKey '9') = KEY_9 | 383 | fromGLFWkey GLFW.Key'9 = KEY_9 |
342 | fromGLFWkey (GLFW.CharKey ' ') = KEY_SPACE | 384 | fromGLFWkey GLFW.Key'Space = KEY_SPACE |
343 | fromGLFWkey (GLFW.SpecialKey GLFW.F1) = KEY_F1 | 385 | fromGLFWkey GLFW.Key'F1 = KEY_F1 |
344 | fromGLFWkey (GLFW.SpecialKey GLFW.F2) = KEY_F2 | 386 | fromGLFWkey GLFW.Key'F2 = KEY_F2 |
345 | fromGLFWkey (GLFW.SpecialKey GLFW.F3) = KEY_F3 | 387 | fromGLFWkey GLFW.Key'F3 = KEY_F3 |
346 | fromGLFWkey (GLFW.SpecialKey GLFW.F4) = KEY_F4 | 388 | fromGLFWkey GLFW.Key'F4 = KEY_F4 |
347 | fromGLFWkey (GLFW.SpecialKey GLFW.F5) = KEY_F5 | 389 | fromGLFWkey GLFW.Key'F5 = KEY_F5 |
348 | fromGLFWkey (GLFW.SpecialKey GLFW.F6) = KEY_F6 | 390 | fromGLFWkey GLFW.Key'F6 = KEY_F6 |
349 | fromGLFWkey (GLFW.SpecialKey GLFW.F7) = KEY_F7 | 391 | fromGLFWkey GLFW.Key'F7 = KEY_F7 |
350 | fromGLFWkey (GLFW.SpecialKey GLFW.F8) = KEY_F8 | 392 | fromGLFWkey GLFW.Key'F8 = KEY_F8 |
351 | fromGLFWkey (GLFW.SpecialKey GLFW.F9) = KEY_F9 | 393 | fromGLFWkey GLFW.Key'F9 = KEY_F9 |
352 | fromGLFWkey (GLFW.SpecialKey GLFW.F10) = KEY_F10 | 394 | fromGLFWkey GLFW.Key'F10 = KEY_F10 |
353 | fromGLFWkey (GLFW.SpecialKey GLFW.F11) = KEY_F11 | 395 | fromGLFWkey GLFW.Key'F11 = KEY_F11 |
354 | fromGLFWkey (GLFW.SpecialKey GLFW.F12) = KEY_F12 | 396 | fromGLFWkey GLFW.Key'F12 = KEY_F12 |
355 | fromGLFWkey (GLFW.SpecialKey GLFW.ESC) = KEY_ESC | 397 | fromGLFWkey GLFW.Key'Escape = KEY_ESC |
356 | fromGLFWkey (GLFW.SpecialKey GLFW.UP) = KEY_UP | 398 | fromGLFWkey GLFW.Key'Up = KEY_UP |
357 | fromGLFWkey (GLFW.SpecialKey GLFW.DOWN) = KEY_DOWN | 399 | fromGLFWkey GLFW.Key'Down = KEY_DOWN |
358 | fromGLFWkey (GLFW.SpecialKey GLFW.LEFT) = KEY_LEFT | 400 | fromGLFWkey GLFW.Key'Left = KEY_LEFT |
359 | fromGLFWkey (GLFW.SpecialKey GLFW.RIGHT) = KEY_RIGHT | 401 | fromGLFWkey GLFW.Key'Right = KEY_RIGHT |
360 | fromGLFWkey _ = KEY_UNKNOWN | 402 | fromGLFWkey _ = KEY_UNKNOWN |
361 | 403 | ||
404 | -- https://www.glfw.org/docs/3.3/group__buttons.html | ||
362 | fromGLFWbutton :: GLFW.MouseButton -> MouseButton | 405 | fromGLFWbutton :: GLFW.MouseButton -> MouseButton |
363 | fromGLFWbutton GLFW.ButtonLeft = LMB | 406 | fromGLFWbutton GLFW.MouseButton'1 = LMB |
364 | fromGLFWbutton GLFW.ButtonRight = RMB | 407 | fromGLFWbutton GLFW.MouseButton'2 = RMB |
365 | fromGLFWbutton GLFW.ButtonMiddle = MMB | 408 | fromGLFWbutton GLFW.MouseButton'3 = MMB |
366 | 409 | ||
367 | toGLFWkey :: Key -> GLFW.Key | 410 | toGLFWkey :: Key -> GLFW.Key |
368 | toGLFWkey KEY_A = GLFW.CharKey 'A' | 411 | toGLFWkey KEY_A = GLFW.Key'A |
369 | toGLFWkey KEY_B = GLFW.CharKey 'B' | 412 | toGLFWkey KEY_B = GLFW.Key'B |
370 | toGLFWkey KEY_C = GLFW.CharKey 'C' | 413 | toGLFWkey KEY_C = GLFW.Key'C |
371 | toGLFWkey KEY_D = GLFW.CharKey 'D' | 414 | toGLFWkey KEY_D = GLFW.Key'D |
372 | toGLFWkey KEY_E = GLFW.CharKey 'E' | 415 | toGLFWkey KEY_E = GLFW.Key'E |
373 | toGLFWkey KEY_F = GLFW.CharKey 'F' | 416 | toGLFWkey KEY_F = GLFW.Key'F |
374 | toGLFWkey KEY_G = GLFW.CharKey 'G' | 417 | toGLFWkey KEY_G = GLFW.Key'G |
375 | toGLFWkey KEY_H = GLFW.CharKey 'H' | 418 | toGLFWkey KEY_H = GLFW.Key'H |
376 | toGLFWkey KEY_I = GLFW.CharKey 'I' | 419 | toGLFWkey KEY_I = GLFW.Key'I |
377 | toGLFWkey KEY_J = GLFW.CharKey 'J' | 420 | toGLFWkey KEY_J = GLFW.Key'J |
378 | toGLFWkey KEY_K = GLFW.CharKey 'K' | 421 | toGLFWkey KEY_K = GLFW.Key'K |
379 | toGLFWkey KEY_L = GLFW.CharKey 'L' | 422 | toGLFWkey KEY_L = GLFW.Key'L |
380 | toGLFWkey KEY_M = GLFW.CharKey 'M' | 423 | toGLFWkey KEY_M = GLFW.Key'M |
381 | toGLFWkey KEY_N = GLFW.CharKey 'N' | 424 | toGLFWkey KEY_N = GLFW.Key'N |
382 | toGLFWkey KEY_O = GLFW.CharKey 'O' | 425 | toGLFWkey KEY_O = GLFW.Key'O |
383 | toGLFWkey KEY_P = GLFW.CharKey 'P' | 426 | toGLFWkey KEY_P = GLFW.Key'P |
384 | toGLFWkey KEY_Q = GLFW.CharKey 'Q' | 427 | toGLFWkey KEY_Q = GLFW.Key'Q |
385 | toGLFWkey KEY_R = GLFW.CharKey 'R' | 428 | toGLFWkey KEY_R = GLFW.Key'R |
386 | toGLFWkey KEY_S = GLFW.CharKey 'S' | 429 | toGLFWkey KEY_S = GLFW.Key'S |
387 | toGLFWkey KEY_T = GLFW.CharKey 'T' | 430 | toGLFWkey KEY_T = GLFW.Key'T |
388 | toGLFWkey KEY_U = GLFW.CharKey 'U' | 431 | toGLFWkey KEY_U = GLFW.Key'U |
389 | toGLFWkey KEY_V = GLFW.CharKey 'V' | 432 | toGLFWkey KEY_V = GLFW.Key'V |
390 | toGLFWkey KEY_W = GLFW.CharKey 'W' | 433 | toGLFWkey KEY_W = GLFW.Key'W |
391 | toGLFWkey KEY_X = GLFW.CharKey 'X' | 434 | toGLFWkey KEY_X = GLFW.Key'X |
392 | toGLFWkey KEY_Y = GLFW.CharKey 'Y' | 435 | toGLFWkey KEY_Y = GLFW.Key'Y |
393 | toGLFWkey KEY_Z = GLFW.CharKey 'Z' | 436 | toGLFWkey KEY_Z = GLFW.Key'Z |
394 | toGLFWkey KEY_0 = GLFW.CharKey '0' | 437 | toGLFWkey KEY_0 = GLFW.Key'0 |
395 | toGLFWkey KEY_1 = GLFW.CharKey '1' | 438 | toGLFWkey KEY_1 = GLFW.Key'1 |
396 | toGLFWkey KEY_2 = GLFW.CharKey '2' | 439 | toGLFWkey KEY_2 = GLFW.Key'2 |
397 | toGLFWkey KEY_3 = GLFW.CharKey '3' | 440 | toGLFWkey KEY_3 = GLFW.Key'3 |
398 | toGLFWkey KEY_4 = GLFW.CharKey '4' | 441 | toGLFWkey KEY_4 = GLFW.Key'4 |
399 | toGLFWkey KEY_5 = GLFW.CharKey '5' | 442 | toGLFWkey KEY_5 = GLFW.Key'5 |
400 | toGLFWkey KEY_6 = GLFW.CharKey '6' | 443 | toGLFWkey KEY_6 = GLFW.Key'6 |
401 | toGLFWkey KEY_7 = GLFW.CharKey '7' | 444 | toGLFWkey KEY_7 = GLFW.Key'7 |
402 | toGLFWkey KEY_8 = GLFW.CharKey '8' | 445 | toGLFWkey KEY_8 = GLFW.Key'8 |
403 | toGLFWkey KEY_9 = GLFW.CharKey '9' | 446 | toGLFWkey KEY_9 = GLFW.Key'9 |
404 | toGLFWkey KEY_SPACE = GLFW.CharKey ' ' | 447 | toGLFWkey KEY_SPACE = GLFW.Key'Space |
405 | toGLFWkey KEY_F1 = GLFW.SpecialKey GLFW.F1 | 448 | toGLFWkey KEY_F1 = GLFW.Key'F1 |
406 | toGLFWkey KEY_F2 = GLFW.SpecialKey GLFW.F2 | 449 | toGLFWkey KEY_F2 = GLFW.Key'F2 |
407 | toGLFWkey KEY_F3 = GLFW.SpecialKey GLFW.F3 | 450 | toGLFWkey KEY_F3 = GLFW.Key'F3 |
408 | toGLFWkey KEY_F4 = GLFW.SpecialKey GLFW.F4 | 451 | toGLFWkey KEY_F4 = GLFW.Key'F4 |
409 | toGLFWkey KEY_F5 = GLFW.SpecialKey GLFW.F5 | 452 | toGLFWkey KEY_F5 = GLFW.Key'F5 |
410 | toGLFWkey KEY_F6 = GLFW.SpecialKey GLFW.F6 | 453 | toGLFWkey KEY_F6 = GLFW.Key'F6 |
411 | toGLFWkey KEY_F7 = GLFW.SpecialKey GLFW.F7 | 454 | toGLFWkey KEY_F7 = GLFW.Key'F7 |
412 | toGLFWkey KEY_F8 = GLFW.SpecialKey GLFW.F8 | 455 | toGLFWkey KEY_F8 = GLFW.Key'F8 |
413 | toGLFWkey KEY_F9 = GLFW.SpecialKey GLFW.F9 | 456 | toGLFWkey KEY_F9 = GLFW.Key'F9 |
414 | toGLFWkey KEY_F10 = GLFW.SpecialKey GLFW.F10 | 457 | toGLFWkey KEY_F10 = GLFW.Key'F10 |
415 | toGLFWkey KEY_F11 = GLFW.SpecialKey GLFW.F11 | 458 | toGLFWkey KEY_F11 = GLFW.Key'F11 |
416 | toGLFWkey KEY_F12 = GLFW.SpecialKey GLFW.F12 | 459 | toGLFWkey KEY_F12 = GLFW.Key'F12 |
417 | toGLFWkey KEY_ESC = GLFW.SpecialKey GLFW.ESC | 460 | toGLFWkey KEY_ESC = GLFW.Key'Escape |
418 | toGLFWkey KEY_UP = GLFW.SpecialKey GLFW.UP | 461 | toGLFWkey KEY_UP = GLFW.Key'Up |
419 | toGLFWkey KEY_DOWN = GLFW.SpecialKey GLFW.DOWN | 462 | toGLFWkey KEY_DOWN = GLFW.Key'Down |
420 | toGLFWkey KEY_LEFT = GLFW.SpecialKey GLFW.LEFT | 463 | toGLFWkey KEY_LEFT = GLFW.Key'Left |
421 | toGLFWkey KEY_RIGHT = GLFW.SpecialKey GLFW.RIGHT | 464 | toGLFWkey KEY_RIGHT = GLFW.Key'Right |
422 | toGLFWkey KEY_UNKNOWN = GLFW.SpecialKey GLFW.UNKNOWN | 465 | toGLFWkey KEY_UNKNOWN = GLFW.Key'Unknown |
423 | 466 | ||
467 | -- https://www.glfw.org/docs/3.3/group__buttons.html | ||
424 | toGLFWbutton :: MouseButton -> GLFW.MouseButton | 468 | toGLFWbutton :: MouseButton -> GLFW.MouseButton |
425 | toGLFWbutton LMB = GLFW.ButtonLeft | 469 | toGLFWbutton LMB = GLFW.MouseButton'1 |
426 | toGLFWbutton RMB = GLFW.ButtonRight | 470 | toGLFWbutton RMB = GLFW.MouseButton'2 |
427 | toGLFWbutton MMB = GLFW.ButtonMiddle | 471 | toGLFWbutton 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 @@ | |||
1 | module Main where | 1 | module Main where |
2 | 2 | ||
3 | import Data.Maybe (mapMaybe) | ||
4 | import Graphics.Rendering.OpenGL.GL (($=)) | ||
5 | import qualified Graphics.Rendering.OpenGL.GL as GL | ||
3 | import Pong | 6 | import Pong |
4 | 7 | import Spear.Game | |
5 | import Spear.Math.AABB | 8 | import Spear.Math.AABB |
6 | import Spear.Math.Spatial2 | 9 | import Spear.Math.Spatial2 |
7 | import Spear.Math.Vector | 10 | import Spear.Math.Vector |
8 | import Spear.Game | ||
9 | import Spear.Window | 11 | import Spear.Window |
10 | 12 | ||
11 | import Data.Maybe (mapMaybe) | ||
12 | import qualified Graphics.Rendering.OpenGL.GL as GL | ||
13 | import Graphics.Rendering.OpenGL.GL (($=)) | ||
14 | |||
15 | data GameState = GameState | 13 | data GameState = GameState |
16 | { wnd :: Window | 14 | { window :: Window, |
17 | , world :: [GameObject] | 15 | world :: [GameObject] |
18 | } | 16 | } |
19 | 17 | ||
20 | main = run | 18 | main = |
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 | ||
24 | initGame wnd = do | 22 | initGame :: Window -> Game () GameState |
25 | gameIO $ do | 23 | initGame 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 | ||
31 | step :: Elapsed -> Dt -> Game GameState Bool | 30 | step :: Elapsed -> Dt -> Game GameState Bool |
32 | step elapsed dt = do | 31 | step 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 | ||
42 | render world = do | 44 | render world = do |
43 | GL.clear [GL.ColorBuffer] | 45 | GL.clear [GL.ColorBuffer] |
44 | mapM_ renderGO world | 46 | mapM_ renderGO world |
45 | swapBuffers | ||
46 | 47 | ||
47 | renderGO :: GameObject -> IO () | 48 | renderGO :: GameObject -> IO () |
48 | renderGO go = do | 49 | renderGO 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 | ||
60 | process = mapM_ procEvent | 61 | process = mapM_ procEvent |
62 | |||
61 | procEvent (Resize w h) = do | 63 | procEvent (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 |
67 | procEvent _ = return () | 69 | procEvent _ = return () |
68 | 70 | ||
69 | translate = mapMaybe translate' | 71 | translate = mapMaybe translate' |
70 | translate' (KeyDown KEY_LEFT) = Just MoveLeft | 72 | |
73 | translate' (KeyDown KEY_LEFT) = Just MoveLeft | ||
71 | translate' (KeyDown KEY_RIGHT) = Just MoveRight | 74 | translate' (KeyDown KEY_RIGHT) = Just MoveRight |
72 | translate' (KeyUp KEY_LEFT) = Just StopLeft | 75 | translate' (KeyUp KEY_LEFT) = Just StopLeft |
73 | translate' (KeyUp KEY_RIGHT) = Just StopRight | 76 | translate' (KeyUp KEY_RIGHT) = Just StopRight |
74 | translate' _ = Nothing | 77 | translate' _ = Nothing |
75 | 78 | ||
76 | exitRequested = any (==(KeyDown KEY_ESC)) | 79 | exitRequested = any (== (KeyDown KEY_ESC)) |
77 | 80 | ||
78 | f2d :: Float -> GL.GLdouble | 81 | f2d :: Float -> GL.GLdouble |
79 | f2d = realToFrac | 82 | f2d = 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 @@ | |||
1 | module Pong | 1 | module Pong |
2 | ( | 2 | ( GameEvent (..), |
3 | GameEvent(..) | 3 | GameObject, |
4 | , GameObject | 4 | newWorld, |
5 | , newWorld | 5 | stepWorld, |
6 | , stepWorld | 6 | aabb, |
7 | , aabb | 7 | ) |
8 | ) | ||
9 | where | 8 | where |
10 | 9 | ||
10 | import Data.Monoid (mconcat) | ||
11 | import GHC.Float (double2Float) | ||
11 | import Spear.Math.AABB | 12 | import Spear.Math.AABB |
12 | import Spear.Math.Spatial2 | 13 | import Spear.Math.Spatial2 |
13 | import Spear.Math.Vector | 14 | import Spear.Math.Vector |
14 | import Spear.Step | 15 | import Spear.Step |
15 | 16 | ||
16 | import Data.Monoid (mconcat) | ||
17 | import GHC.Float (double2Float) | ||
18 | |||
19 | -- Game events | 17 | -- Game events |
20 | 18 | ||
21 | data GameEvent | 19 | data 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 | ||
30 | data GameObject = GameObject | 28 | data 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 | ||
36 | instance Spatial2 GameObject where | 34 | instance 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 | ||
40 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] | 38 | stepWorld :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> [GameObject] |
41 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos | 39 | stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos |
42 | 40 | ||
43 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject | 41 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject |
44 | update elapsed dt evts gos go = | 42 | update 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 | ||
48 | ballBox :: AABB2 | 46 | ballBox :: AABB2 |
49 | ballBox = AABB2 (vec2 (-s) (-s)) (vec2 s s) where s = 0.01 | 47 | ballBox = AABB2 (vec2 (- s) (- s)) (vec2 s s) where s = 0.01 |
50 | 48 | ||
51 | padSize = vec2 0.05 0.02 | 49 | padSize = vec2 0.05 0.02 |
52 | 50 | ||
53 | padBox = AABB2 (-padSize) padSize | 51 | padBox = AABB2 (- padSize) padSize |
54 | 52 | ||
55 | obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y) | 53 | obj2 x y = obj2FromVectors unitx2 unity2 (vec2 x y) |
56 | 54 | ||
57 | ballVelocity = Vector2 0.3 0.3 | 55 | ballVelocity = Vector2 0.3 0.3 |
58 | 56 | ||
59 | newWorld = | 57 | newWorld = |
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 | ||
69 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) | 67 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) |
70 | collideBall vel = step $ \_ _ gos _ ball -> | 68 | collideBall 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 | ||
80 | collide go1 go2 = | 79 | collide 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 | ||
88 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax) | 89 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p + pmin) (p + pmax) |
89 | 90 | ||
90 | moveBall :: Step s e (Vector2, GameObject) GameObject | 91 | moveBall :: Step s e (Vector2, GameObject) GameObject |
91 | moveBall = step $ \_ dt _ _ (vel,ball) -> (move (scale dt vel) ball, moveBall) | 92 | moveBall = 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 | ||
97 | movePad :: Step s e GameObject GameObject | 98 | movePad :: Step s e GameObject GameObject |
98 | movePad = step $ \elapsed _ _ _ pad -> | 99 | movePad = 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 | ||
107 | stepPlayer = sfold moveGO .> clamp | 109 | stepPlayer = sfold moveGO .> clamp |
108 | 110 | ||
109 | moveGO = mconcat | 111 | moveGO = |
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 | ||
114 | moveGO' :: Vector2 -> Step s e GameObject GameObject | 117 | moveGO' :: Vector2 -> Step s e GameObject GameObject |
115 | moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) | 118 | moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) |
116 | 119 | ||
117 | clamp :: Step s e GameObject GameObject | 120 | clamp :: Step s e GameObject GameObject |
118 | clamp = spure $ \go -> | 121 | clamp = 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 | ||
125 | toDir True MoveLeft = vec2 (-1) 0 | 128 | toDir True MoveLeft = vec2 (-1) 0 |
126 | toDir True MoveRight = vec2 1 0 | 129 | toDir True MoveRight = vec2 1 0 |
127 | toDir _ _ = vec2 0 0 \ No newline at end of file | 130 | toDir _ _ = 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 @@ | |||
1 | import Distribution.Simple | 1 | import Distribution.Simple |
2 | |||
2 | main = defaultMain | 3 | main = 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 @@ | |||
1 | packages: . | ||
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 | ||
4 | name: pong | 4 | name: pong |
5 | version: 0.1.0.0 | 5 | version: 0.1.0.0 |
6 | synopsis: A pong clone | 6 | synopsis: A pong clone |
7 | -- description: | 7 | -- description: |
8 | license: BSD3 | 8 | license: BSD3 |
9 | license-file: LICENSE | 9 | license-file: LICENSE |
10 | author: Marc Sunet | 10 | author: Marc Sunet |
11 | -- maintainer: | 11 | -- maintainer: |
12 | -- copyright: | 12 | -- copyright: |
13 | category: Game | 13 | category: Game |
14 | build-type: Simple | 14 | build-type: Simple |
15 | cabal-version: >=1.8 | 15 | cabal-version: >=1.8 |
@@ -17,5 +17,5 @@ cabal-version: >=1.8 | |||
17 | executable pong | 17 | executable 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 |