diff options
Diffstat (limited to 'Spear/GL.hs')
-rw-r--r-- | Spear/GL.hs | 827 |
1 files changed, 447 insertions, 380 deletions
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 |