aboutsummaryrefslogtreecommitdiff
path: root/Spear/GL.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Spear/GL.hs')
-rw-r--r--Spear/GL.hs827
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
2module Spear.GL 3module Spear.GL
3( 4 ( -- * Programs
4 -- * Programs 5 GLSLProgram,
5 GLSLProgram 6 newProgram,
6, newProgram 7 linkProgram,
7, linkProgram 8 useProgram,
8, useProgram 9 unuseProgram,
9, unuseProgram 10 withGLSLProgram,
10, withGLSLProgram 11
11 -- ** Locations 12 -- ** Locations
12, attribLocation 13 attribLocation,
13, fragLocation 14 fragLocation,
14, uniformLocation 15 uniformLocation,
16
15 -- ** Uniforms 17 -- ** Uniforms
16, Uniform(..) 18 Uniform (..),
19
17 -- * Shaders 20 -- * Shaders
18, GLSLShader 21 GLSLShader,
19, ShaderType(..) 22 ShaderType (..),
20, attachShader 23 attachShader,
21, detachShader 24 detachShader,
22, loadShader 25 loadShader,
23, newShader 26 newShader,
27
24 -- ** Source loading 28 -- ** Source loading
25, loadSource 29 loadSource,
26, shaderSource 30 shaderSource,
27, readSource 31 readSource,
28, compile 32 compile,
33
29 -- * Helper functions 34 -- * Helper functions
30, ($=) 35 ($=),
31, Data.StateVar.get 36 Data.StateVar.get,
37
32 -- * VAOs 38 -- * VAOs
33, VAO 39 VAO,
34, newVAO 40 newVAO,
35, bindVAO 41 bindVAO,
36, unbindVAO 42 unbindVAO,
37, enableVAOAttrib 43 enableVAOAttrib,
38, attribVAOPointer 44 attribVAOPointer,
45
39 -- ** Rendering 46 -- ** Rendering
40, drawArrays 47 drawArrays,
41, drawElements 48 drawElements,
49
42 -- * Buffers 50 -- * Buffers
43, GLBuffer 51 GLBuffer,
44, TargetBuffer(..) 52 TargetBuffer (..),
45, BufferUsage(..) 53 BufferUsage (..),
46, newBuffer 54 newBuffer,
47, bindBuffer 55 bindBuffer,
48, unbindBuffer 56 unbindBuffer,
49, BufferData(..) 57 BufferData (..),
50, bufferData' 58 bufferData',
51, withGLBuffer 59 withGLBuffer,
60
52 -- * Textures 61 -- * Textures
53, Texture 62 Texture,
54, SettableStateVar 63 SettableStateVar,
55, ($) 64 ($),
65
56 -- ** Creation and destruction 66 -- ** Creation and destruction
57, newTexture 67 newTexture,
58, loadTextureImage 68 loadTextureImage,
69
59 -- ** Manipulation 70 -- ** Manipulation
60, bindTexture 71 bindTexture,
61, unbindTexture 72 unbindTexture,
62, loadTextureData 73 loadTextureData,
63, texParami 74 texParami,
64, texParamf 75 texParamf,
65, activeTexture 76 activeTexture,
77
66 -- * Error Handling 78 -- * Error Handling
67, getGLError 79 getGLError,
68, printGLError 80 printGLError,
69, assertGL 81 assertGL,
82
70 -- * OpenGL 83 -- * OpenGL
71, module Graphics.Rendering.OpenGL.Raw.Core32 84 module Graphics.GL.Core46,
72, Ptr 85 Ptr,
73, nullPtr 86 nullPtr,
74) 87 )
75where 88where
76 89
77import Spear.Assets.Image
78import Spear.Game
79import Spear.Math.Matrix3 (Matrix3)
80import Spear.Math.Matrix4 (Matrix4)
81import Spear.Math.Vector
82
83import Control.Monad 90import Control.Monad
84import Control.Monad.Trans.Class 91import Control.Monad.Trans.Class
85import Control.Monad.Trans.Error
86import Control.Monad.Trans.State as State 92import Control.Monad.Trans.State as State
87import qualified Data.ByteString.Char8 as B 93import qualified Data.ByteString.Char8 as B
88import Data.StateVar 94import Data.StateVar
89import Data.Word 95import Data.Word
90import Foreign.C.String 96import Foreign.C.String
91import Foreign.C.Types 97import Foreign.C.Types
92import Foreign.Ptr
93import Foreign.Storable
94import Foreign.Marshal.Utils as Foreign (with)
95import Foreign.Marshal.Alloc (alloca) 98import Foreign.Marshal.Alloc (alloca)
96import Foreign.Marshal.Array (withArray) 99import Foreign.Marshal.Array (withArray)
100import Foreign.Marshal.Utils as Foreign (with)
101import Foreign.Ptr
102import Foreign.Storable
97import Foreign.Storable (peek) 103import Foreign.Storable (peek)
98import Graphics.Rendering.OpenGL.Raw.Core32 104import Graphics.GL.Core46
105import Spear.Assets.Image
106import Spear.Game
107import Spear.Math.Matrix3 (Matrix3)
108import Spear.Math.Matrix4 (Matrix4)
109import Spear.Math.Vector
99import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory) 110import System.Directory (doesFileExist, getCurrentDirectory, setCurrentDirectory)
100import System.IO (hPutStrLn, stderr) 111import System.IO (hPutStrLn, stderr)
101import Unsafe.Coerce 112import Unsafe.Coerce
@@ -105,30 +116,30 @@ import Unsafe.Coerce
105-- 116--
106 117
107-- | A GLSL shader handle. 118-- | A GLSL shader handle.
108data GLSLShader = GLSLShader 119data GLSLShader = GLSLShader
109 { getShader :: GLuint 120 { getShader :: GLuint,
110 , getShaderKey :: Resource 121 getShaderKey :: Resource
111 } 122 }
112 123
113instance ResourceClass GLSLShader where 124instance ResourceClass GLSLShader where
114 getResource = getShaderKey 125 getResource = getShaderKey
115 126
116-- | A GLSL program handle. 127-- | A GLSL program handle.
117data GLSLProgram = GLSLProgram 128data GLSLProgram = GLSLProgram
118 { getProgram :: GLuint 129 { getProgram :: GLuint,
119 , getProgramKey :: Resource 130 getProgramKey :: Resource
120 } 131 }
121 132
122instance ResourceClass GLSLProgram where 133instance ResourceClass GLSLProgram where
123 getResource = getProgramKey 134 getResource = getProgramKey
124 135
125-- | Supported shader types. 136-- | Supported shader types.
126data ShaderType = VertexShader | FragmentShader | GeometryShader deriving (Eq, Show) 137data ShaderType = VertexShader | FragmentShader | GeometryShader deriving (Eq, Show)
127 138
128toGLShader :: ShaderType -> GLenum 139toGLShader :: ShaderType -> GLenum
129toGLShader VertexShader = gl_VERTEX_SHADER 140toGLShader VertexShader = GL_VERTEX_SHADER
130toGLShader FragmentShader = gl_FRAGMENT_SHADER 141toGLShader FragmentShader = GL_FRAGMENT_SHADER
131toGLShader GeometryShader = gl_GEOMETRY_SHADER 142toGLShader GeometryShader = GL_GEOMETRY_SHADER
132 143
133-- | Apply the given function to the program's id. 144-- | Apply the given function to the program's id.
134withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a 145withGLSLProgram :: GLSLProgram -> (GLuint -> a) -> a
@@ -137,58 +148,58 @@ withGLSLProgram prog f = f $ getProgram prog
137-- | Get the location of the given uniform variable within the given program. 148-- | Get the location of the given uniform variable within the given program.
138uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint 149uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint
139uniformLocation prog var = makeGettableStateVar $ 150uniformLocation prog var = makeGettableStateVar $
140 withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str) 151 withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str)
141 152
142-- | Get or set the location of the given variable to a fragment shader colour number. 153-- | Get or set the location of the given variable to a fragment shader colour number.
143fragLocation :: GLSLProgram -> String -> StateVar GLint 154fragLocation :: GLSLProgram -> String -> StateVar GLint
144fragLocation prog var = makeStateVar get set 155fragLocation prog var = makeStateVar get set
145 where 156 where
146 get = withCString var $ \str -> glGetFragDataLocation (getProgram prog) (unsafeCoerce str) 157 get = withCString var $ \str -> glGetFragDataLocation (getProgram prog) (unsafeCoerce str)
147 set idx = withCString var $ \str -> 158 set idx = withCString var $ \str ->
148 glBindFragDataLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str) 159 glBindFragDataLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str)
149 160
150-- | Get or set the location of the given attribute within the given program. 161-- | Get or set the location of the given attribute within the given program.
151attribLocation :: GLSLProgram -> String -> StateVar GLint 162attribLocation :: GLSLProgram -> String -> StateVar GLint
152attribLocation prog var = makeStateVar get set 163attribLocation prog var = makeStateVar get set
153 where 164 where
154 get = withCString var $ \str -> glGetAttribLocation (getProgram prog) (unsafeCoerce str) 165 get = withCString var $ \str -> glGetAttribLocation (getProgram prog) (unsafeCoerce str)
155 set idx = withCString var $ \str -> 166 set idx = withCString var $ \str ->
156 glBindAttribLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str) 167 glBindAttribLocation (getProgram prog) (unsafeCoerce idx) (unsafeCoerce str)
157 168
158-- | Create a new program. 169-- | Create a new program.
159newProgram :: [GLSLShader] -> Game s GLSLProgram 170newProgram :: [GLSLShader] -> Game s GLSLProgram
160newProgram shaders = do 171newProgram shaders = do
161 h <- gameIO glCreateProgram 172 h <- gameIO glCreateProgram
162 when (h == 0) $ gameError "glCreateProgram failed" 173 when (h == 0) $ gameError "glCreateProgram failed"
163 rkey <- register $ deleteProgram h 174 rkey <- register $ deleteProgram h
164 let program = GLSLProgram h rkey 175 let program = GLSLProgram h rkey
165 mapM_ (gameIO . attachShader program) shaders 176 mapM_ (gameIO . attachShader program) shaders
166 linkProgram program 177 linkProgram program
167 return program 178 return program
168 179
169-- Delete the program. 180-- Delete the program.
170deleteProgram :: GLuint -> IO () 181deleteProgram :: GLuint -> IO ()
171--deleteProgram = glDeleteProgram 182--deleteProgram = glDeleteProgram
172deleteProgram prog = do 183deleteProgram prog = do
173 putStrLn $ "Deleting shader program " ++ show prog 184 putStrLn $ "Deleting shader program " ++ show prog
174 glDeleteProgram prog 185 glDeleteProgram prog
175 186
176-- | Link the program. 187-- | Link the program.
177linkProgram :: GLSLProgram -> Game s () 188linkProgram :: GLSLProgram -> Game s ()
178linkProgram prog = do 189linkProgram prog = do
179 let h = getProgram prog 190 let h = getProgram prog
180 err <- gameIO $ do 191 err <- gameIO $ do
181 glLinkProgram h 192 glLinkProgram h
182 alloca $ \statptr -> do 193 alloca $ \statptr -> do
183 glGetProgramiv h gl_LINK_STATUS statptr 194 glGetProgramiv h GL_LINK_STATUS statptr
184 status <- peek statptr 195 status <- peek statptr
185 case status of 196 case status of
186 0 -> getStatus glGetProgramiv glGetProgramInfoLog h 197 0 -> getStatus glGetProgramiv glGetProgramInfoLog h
187 _ -> return "" 198 _ -> return ""
188 199
189 case length err of 200 case length err of
190 0 -> return () 201 0 -> return ()
191 _ -> gameError err 202 _ -> gameError err
192 203
193-- | Use the program. 204-- | Use the program.
194useProgram :: GLSLProgram -> IO () 205useProgram :: GLSLProgram -> IO ()
@@ -212,82 +223,84 @@ detachShader prog shader = glDetachShader (getProgram prog) (getShader shader)
212-- see 'loadSource', 'shaderSource' and 'readSource'. 223-- see 'loadSource', 'shaderSource' and 'readSource'.
213loadShader :: ShaderType -> FilePath -> Game s GLSLShader 224loadShader :: ShaderType -> FilePath -> Game s GLSLShader
214loadShader shaderType file = do 225loadShader shaderType file = do
215 shader <- newShader shaderType 226 shader <- newShader shaderType
216 loadSource file shader 227 loadSource file shader
217 compile file shader 228 compile file shader
218 return shader 229 return shader
219 230
220-- | Create a new shader. 231-- | Create a new shader.
221newShader :: ShaderType -> Game s GLSLShader 232newShader :: ShaderType -> Game s GLSLShader
222newShader shaderType = do 233newShader shaderType = do
223 h <- gameIO $ glCreateShader (toGLShader shaderType) 234 h <- gameIO $ glCreateShader (toGLShader shaderType)
224 case h of 235 case h of
225 0 -> gameError "glCreateShader failed" 236 0 -> gameError "glCreateShader failed"
226 _ -> do 237 _ -> do
227 rkey <- register $ deleteShader h 238 rkey <- register $ deleteShader h
228 return $ GLSLShader h rkey 239 return $ GLSLShader h rkey
229 240
230-- | Free the shader. 241-- | Free the shader.
231deleteShader :: GLuint -> IO () 242deleteShader :: GLuint -> IO ()
232--deleteShader = glDeleteShader 243--deleteShader = glDeleteShader
233deleteShader shader = do 244deleteShader shader = do
234 putStrLn $ "Deleting shader " ++ show shader 245 putStrLn $ "Deleting shader " ++ show shader
235 glDeleteShader shader 246 glDeleteShader shader
236 247
237-- | Load a shader source from the file specified by the given string 248-- | Load a shader source from the file specified by the given string
238-- into the shader. 249-- into the shader.
239loadSource :: FilePath -> GLSLShader -> Game s () 250loadSource :: FilePath -> GLSLShader -> Game s ()
240loadSource file h = do 251loadSource file h = do
241 exists <- gameIO $ doesFileExist file 252 exists <- gameIO $ doesFileExist file
242 case exists of 253 case exists of
243 False -> gameError "the specified shader file does not exist" 254 False -> gameError "the specified shader file does not exist"
244 True -> gameIO $ do 255 True -> gameIO $ do
245 code <- readSource file 256 code <- readSource file
246 withCString code $ shaderSource h 257 withCString code $ shaderSource h
247 258
248-- | Load the given shader source into the shader. 259-- | Load the given shader source into the shader.
249shaderSource :: GLSLShader -> CString -> IO () 260shaderSource :: GLSLShader -> CString -> IO ()
250shaderSource shader str = 261shaderSource shader str =
251 let ptr = unsafeCoerce str 262 let ptr = unsafeCoerce str
252 in withArray [ptr] $ flip (glShaderSource (getShader shader) 1) nullPtr 263 in withArray [ptr] $ flip (glShaderSource (getShader shader) 1) nullPtr
253 264
254-- | Compile the shader. 265-- | Compile the shader.
255compile :: FilePath -> GLSLShader -> Game s () 266compile :: FilePath -> GLSLShader -> Game s ()
256compile file shader = do 267compile file shader = do
257 let h = getShader shader 268 let h = getShader shader
258 269
259 -- Compile 270 -- Compile
260 gameIO $ glCompileShader h 271 gameIO $ glCompileShader h
261 272
262 -- Verify status 273 -- Verify status
263 err <- gameIO $ alloca $ \statusPtr -> do 274 err <- gameIO $
264 glGetShaderiv h gl_COMPILE_STATUS statusPtr 275 alloca $ \statusPtr -> do
265 result <- peek statusPtr 276 glGetShaderiv h GL_COMPILE_STATUS statusPtr
266 case result of 277 result <- peek statusPtr
267 0 -> getStatus glGetShaderiv glGetShaderInfoLog h 278 case result of
268 _ -> return "" 279 0 -> getStatus glGetShaderiv glGetShaderInfoLog h
280 _ -> return ""
269 281
270 case length err of 282 case length err of
271 0 -> return () 283 0 -> return ()
272 _ -> gameError $ "Unable to compile shader " ++ file ++ ":\n" ++ err 284 _ -> gameError $ "Unable to compile shader " ++ file ++ ":\n" ++ err
273 285
274type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO () 286type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO ()
275type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO () 287
288type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO ()
276 289
277getStatus :: StatusCall -> LogCall -> GLuint -> IO String 290getStatus :: StatusCall -> LogCall -> GLuint -> IO String
278getStatus getStatus getLog h = do 291getStatus getStatus getLog h = do
279 alloca $ \lenPtr -> do 292 alloca $ \lenPtr -> do
280 getStatus h gl_INFO_LOG_LENGTH lenPtr 293 getStatus h GL_INFO_LOG_LENGTH lenPtr
281 len <- peek lenPtr 294 len <- peek lenPtr
282 case len of 295 case len of
283 0 -> return "" 296 0 -> return ""
284 _ -> withCString (replicate (unsafeCoerce len) '\0') $ getErrorString getLog h (unsafeCoerce len) 297 _ -> withCString (replicate (unsafeCoerce len) '\0') $ getErrorString getLog h (unsafeCoerce len)
285 298
286getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String 299getErrorString :: LogCall -> GLuint -> GLsizei -> CString -> IO String
287getErrorString getLog h len str = do 300getErrorString getLog h len str = do
288 let ptr = unsafeCoerce str 301 let ptr = unsafeCoerce str
289 getLog h len nullPtr ptr 302 getLog h len nullPtr ptr
290 peekCString str 303 peekCString str
291 304
292-- | Load the shader source specified by the given file. 305-- | Load the shader source specified by the given file.
293-- 306--
@@ -298,110 +311,121 @@ readSource = fmap B.unpack . readSource'
298 311
299readSource' :: FilePath -> IO B.ByteString 312readSource' :: FilePath -> IO B.ByteString
300readSource' file = do 313readSource' file = do
301 let includeB = B.pack "#include" 314 let includeB = B.pack "#include"
302 newLineB = B.pack "\n" 315 newLineB = B.pack "\n"
303 isInclude = ((==) includeB) . B.take 8 316 isInclude = ((==) includeB) . B.take 8
304 clean = B.dropWhile (\c -> c == ' ') 317 clean = B.dropWhile (\c -> c == ' ')
305 cleanInclude = B.filter (\c -> c /= '"') . B.dropWhile (\c -> c /= ' ') 318 cleanInclude = B.filter (\c -> c /= '"') . B.dropWhile (\c -> c /= ' ')
306 toLines = B.splitWith (\c -> c == '\n' || c == '\r') 319 toLines = B.splitWith (\c -> c == '\n' || c == '\r')
307 addNewLine s = if (B.last s /= '\n') then B.append s newLineB else s 320 addNewLine s = if (B.last s /= '\n') then B.append s newLineB else s
308 parse = fmap B.concat . (fmap . fmap $ flip B.append newLineB) . sequence . 321 parse =
309 fmap (processLine . clean) . toLines 322 fmap B.concat . (fmap . fmap $ flip B.append newLineB) . sequence
310 processLine l = 323 . fmap (processLine . clean)
311 if isInclude l 324 . toLines
312 then readSource' $ B.unpack . clean . cleanInclude $ l 325 processLine l =
313 else return l 326 if isInclude l
314 327 then readSource' $ B.unpack . clean . cleanInclude $ l
315 contents <- B.readFile file 328 else return l
316 329
317 dir <- getCurrentDirectory 330 contents <- B.readFile file
318 let dir' = dir ++ "/" ++ (reverse . dropWhile (\c -> c /= '/') . reverse) file 331
319 332 dir <- getCurrentDirectory
320 setCurrentDirectory dir' 333 let dir' = dir ++ "/" ++ (reverse . dropWhile (\c -> c /= '/') . reverse) file
321 code <- parse contents 334
322 setCurrentDirectory dir 335 setCurrentDirectory dir'
323 336 code <- parse contents
324 return code 337 setCurrentDirectory dir
338
339 return code
325 340
326class Uniform a where 341class Uniform a where
327 -- | Load a list of uniform values. 342 -- | Load a list of uniform values.
328 uniform :: GLint -> a -> IO () 343 uniform :: GLint -> a -> IO ()
329 344
330instance Uniform Int where uniform loc a = glUniform1i loc (fromIntegral a) 345instance Uniform Int where uniform loc a = glUniform1i loc (fromIntegral a)
331instance Uniform Float where uniform loc a = glUniform1f loc (unsafeCoerce a)
332instance Uniform CFloat where uniform loc a = glUniform1f loc a
333 346
334instance Uniform (Int,Int) where 347instance Uniform Float where uniform loc a = glUniform1f loc a
335 uniform loc (x,y) = glUniform2i loc (fromIntegral x) (fromIntegral y)
336 348
337instance Uniform (Float,Float) where 349instance Uniform CFloat where uniform loc a = glUniform1f loc (unsafeCoerce a)
338 uniform loc (x,y) = glUniform2f loc (unsafeCoerce x) (unsafeCoerce y)
339 350
340instance Uniform (Int,Int,Int) where 351instance Uniform (Int, Int) where
341 uniform loc (x,y,z) = glUniform3i loc (fromIntegral x) (fromIntegral y) (fromIntegral z) 352 uniform loc (x, y) = glUniform2i loc (fromIntegral x) (fromIntegral y)
342 353
343instance Uniform (Float,Float,Float) where 354instance Uniform (Float, Float) where
344 uniform loc (x,y,z) = glUniform3f loc (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z) 355 uniform loc (x, y) = glUniform2f loc x y
345 356
346instance Uniform (Int,Int,Int,Int) where 357instance Uniform (Int, Int, Int) where
347 uniform loc (x,y,z,w) = glUniform4i loc 358 uniform loc (x, y, z) = glUniform3i loc (fromIntegral x) (fromIntegral y) (fromIntegral z)
348 (fromIntegral x) (fromIntegral y) (fromIntegral z) (fromIntegral w)
349 359
350instance Uniform (Float,Float,Float,Float) where 360instance Uniform (Float, Float, Float) where
351 uniform loc (x,y,z,w) = glUniform4f loc 361 uniform loc (x, y, z) = glUniform3f loc x y z
352 (unsafeCoerce x) (unsafeCoerce y) (unsafeCoerce z) (unsafeCoerce w) 362
363instance Uniform (Int, Int, Int, Int) where
364 uniform loc (x, y, z, w) =
365 glUniform4i
366 loc
367 (fromIntegral x)
368 (fromIntegral y)
369 (fromIntegral z)
370 (fromIntegral w)
371
372instance Uniform (Float, Float, Float, Float) where
373 uniform loc (x, y, z, w) = glUniform4f loc x y z w
353 374
354instance Uniform Vector2 where 375instance Uniform Vector2 where
355 uniform loc v = glUniform2f loc x' y' 376 uniform loc v = glUniform2f loc x' y'
356 where x' = unsafeCoerce $ x v 377 where
357 y' = unsafeCoerce $ y v 378 x' = unsafeCoerce $ x v
379 y' = unsafeCoerce $ y v
358 380
359instance Uniform Vector3 where 381instance Uniform Vector3 where
360 uniform loc v = glUniform3f loc x' y' z' 382 uniform loc v = glUniform3f loc x' y' z'
361 where x' = unsafeCoerce $ x v 383 where
362 y' = unsafeCoerce $ y v 384 x' = unsafeCoerce $ x v
363 z' = unsafeCoerce $ z v 385 y' = unsafeCoerce $ y v
386 z' = unsafeCoerce $ z v
364 387
365instance Uniform Vector4 where 388instance Uniform Vector4 where
366 uniform loc v = glUniform4f loc x' y' z' w' 389 uniform loc v = glUniform4f loc x' y' z' w'
367 where x' = unsafeCoerce $ x v 390 where
368 y' = unsafeCoerce $ y v 391 x' = unsafeCoerce $ x v
369 z' = unsafeCoerce $ z v 392 y' = unsafeCoerce $ y v
370 w' = unsafeCoerce $ w v 393 z' = unsafeCoerce $ z v
394 w' = unsafeCoerce $ w v
371 395
372instance Uniform Matrix3 where 396instance Uniform Matrix3 where
373 uniform loc mat = 397 uniform loc mat =
374 with mat $ \ptrMat -> 398 with mat $ \ptrMat ->
375 glUniformMatrix3fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) 399 glUniformMatrix3fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
376 400
377instance Uniform Matrix4 where 401instance Uniform Matrix4 where
378 uniform loc mat = 402 uniform loc mat =
379 with mat $ \ptrMat -> 403 with mat $ \ptrMat ->
380 glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) 404 glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
381 405
382instance Uniform [Float] where 406instance Uniform [Float] where
383 uniform loc vals = withArray (map unsafeCoerce vals) $ \ptr -> 407 uniform loc vals = withArray (map unsafeCoerce vals) $ \ptr ->
384 case length vals of 408 case length vals of
385 1 -> glUniform1fv loc 1 ptr 409 1 -> glUniform1fv loc 1 ptr
386 2 -> glUniform2fv loc 1 ptr 410 2 -> glUniform2fv loc 1 ptr
387 3 -> glUniform3fv loc 1 ptr 411 3 -> glUniform3fv loc 1 ptr
388 4 -> glUniform4fv loc 1 ptr 412 4 -> glUniform4fv loc 1 ptr
389 413
390instance Uniform [CFloat] where 414instance Uniform [CFloat] where
391 uniform loc vals = withArray vals $ \ptr -> 415 uniform loc vals = withArray vals $ \ptr ->
392 case length vals of 416 case length vals of
393 1 -> glUniform1fv loc 1 ptr 417 1 -> glUniform1fv loc 1 $ castPtr ptr
394 2 -> glUniform2fv loc 1 ptr 418 2 -> glUniform2fv loc 1 $ castPtr ptr
395 3 -> glUniform3fv loc 1 ptr 419 3 -> glUniform3fv loc 1 $ castPtr ptr
396 4 -> glUniform4fv loc 1 ptr 420 4 -> glUniform4fv loc 1 $ castPtr ptr
397 421
398instance Uniform [Int] where 422instance Uniform [Int] where
399 uniform loc vals = withArray (map fromIntegral vals) $ \ptr -> 423 uniform loc vals = withArray (map fromIntegral vals) $ \ptr ->
400 case length vals of 424 case length vals of
401 1 -> glUniform1iv loc 1 ptr 425 1 -> glUniform1iv loc 1 ptr
402 2 -> glUniform2iv loc 1 ptr 426 2 -> glUniform2iv loc 1 ptr
403 3 -> glUniform3iv loc 1 ptr 427 3 -> glUniform3iv loc 1 ptr
404 4 -> glUniform4iv loc 1 ptr 428 4 -> glUniform4iv loc 1 ptr
405 429
406-- 430--
407-- VAOs 431-- VAOs
@@ -409,28 +433,29 @@ instance Uniform [Int] where
409 433
410-- | A vertex array object. 434-- | A vertex array object.
411data VAO = VAO 435data VAO = VAO
412 { getVAO :: GLuint 436 { getVAO :: GLuint,
413 , vaoKey :: Resource 437 vaoKey :: Resource
414 } 438 }
415 439
416instance ResourceClass VAO where 440instance ResourceClass VAO where
417 getResource = vaoKey 441 getResource = vaoKey
418 442
419instance Eq VAO where 443instance Eq VAO where
420 vao1 == vao2 = getVAO vao1 == getVAO vao2 444 vao1 == vao2 = getVAO vao1 == getVAO vao2
421 445
422instance Ord VAO where 446instance Ord VAO where
423 vao1 < vao2 = getVAO vao1 < getVAO vao2 447 vao1 < vao2 = getVAO vao1 < getVAO vao2
448 vao1 <= vao2 = getVAO vao1 <= getVAO vao2
424 449
425-- | Create a new vao. 450-- | Create a new vao.
426newVAO :: Game s VAO 451newVAO :: Game s VAO
427newVAO = do 452newVAO = do
428 h <- gameIO . alloca $ \ptr -> do 453 h <- gameIO . alloca $ \ptr -> do
429 glGenVertexArrays 1 ptr 454 glGenVertexArrays 1 ptr
430 peek ptr 455 peek ptr
431 456
432 rkey <- register $ deleteVAO h 457 rkey <- register $ deleteVAO h
433 return $ VAO h rkey 458 return $ VAO h rkey
434 459
435-- | Delete the vao. 460-- | Delete the vao.
436deleteVAO :: GLuint -> IO () 461deleteVAO :: GLuint -> IO ()
@@ -447,38 +472,54 @@ unbindVAO = glBindVertexArray 0
447-- | Enable the given vertex attribute of the bound vao. 472-- | Enable the given vertex attribute of the bound vao.
448-- 473--
449-- See also 'bindVAO'. 474-- See also 'bindVAO'.
450enableVAOAttrib :: GLuint -- ^ Attribute index. 475enableVAOAttrib ::
451 -> IO () 476 -- | Attribute index.
477 GLuint ->
478 IO ()
452enableVAOAttrib = glEnableVertexAttribArray 479enableVAOAttrib = glEnableVertexAttribArray
453 480
454-- | Bind the bound buffer to the given point. 481-- | Bind the bound buffer to the given point.
455attribVAOPointer 482attribVAOPointer ::
456 :: GLuint -- ^ The index of the generic vertex attribute to be modified. 483 -- | The index of the generic vertex attribute to be modified.
457 -> GLint -- ^ The number of components per generic vertex attribute. Must be 1,2,3,4. 484 GLuint ->
458 -> GLenum -- ^ The data type of each component in the array. 485 -- | The number of components per generic vertex attribute. Must be 1,2,3,4.
459 -> Bool -- ^ Whether fixed-point data values should be normalized. 486 GLint ->
460 -> GLsizei -- ^ Stride. Byte offset between consecutive generic vertex attributes. 487 -- | The data type of each component in the array.
461 -> Int -- ^ Offset to the first component in the array. 488 GLenum ->
462 -> IO () 489 -- | Whether fixed-point data values should be normalized.
490 Bool ->
491 -- | Stride. Byte offset between consecutive generic vertex attributes.
492 GLsizei ->
493 -- | Offset to the first component in the array.
494 Int ->
495 IO ()
463attribVAOPointer idx ncomp dattype normalise stride off = 496attribVAOPointer idx ncomp dattype normalise stride off =
464 glVertexAttribPointer idx ncomp dattype normalise' stride (unsafeCoerce off) 497 glVertexAttribPointer idx ncomp dattype normalise' stride (unsafeCoerce off)
465 where normalise' = if normalise then 1 else 0 498 where
499 normalise' = if normalise then 1 else 0
466 500
467-- | Draw the bound vao. 501-- | Draw the bound vao.
468drawArrays 502drawArrays ::
469 :: GLenum -- ^ The kind of primitives to render. 503 -- | The kind of primitives to render.
470 -> Int -- ^ Starting index in the enabled arrays. 504 GLenum ->
471 -> Int -- ^ The number of indices to be rendered. 505 -- | Starting index in the enabled arrays.
472 -> IO () 506 Int ->
507 -- | The number of indices to be rendered.
508 Int ->
509 IO ()
473drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count) 510drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoerce count)
474 511
475-- | Draw the bound vao, indexed mode. 512-- | Draw the bound vao, indexed mode.
476drawElements 513drawElements ::
477 :: GLenum -- ^ The kind of primitives to render. 514 -- | The kind of primitives to render.
478 -> Int -- ^ The number of elements to be rendered. 515 GLenum ->
479 -> GLenum -- ^ The type of the index values. Must be one of gl_UNSIGNED_BYTE, gl_UNSIGNED_SHORT, or gl_UNSIGNED_INT. 516 -- | The number of elements to be rendered.
480 -> Ptr a -- ^ Pointer to the location where indices are stored, or offset into the index array when there is a bound ElementArrayBuffer. 517 Int ->
481 -> IO () 518 -- | The type of the index values. Must be one of gl_UNSIGNED_BYTE, gl_UNSIGNED_SHORT, or gl_UNSIGNED_INT.
519 GLenum ->
520 -- | Pointer to the location where indices are stored, or offset into the index array when there is a bound ElementArrayBuffer.
521 Ptr a ->
522 IO ()
482drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs 523drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs
483 524
484-- 525--
@@ -487,60 +528,60 @@ drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs
487 528
488-- | An OpenGL buffer. 529-- | An OpenGL buffer.
489data GLBuffer = GLBuffer 530data GLBuffer = GLBuffer
490 { getBuffer :: GLuint 531 { getBuffer :: GLuint,
491 , rkey :: Resource 532 rkey :: Resource
492 } 533 }
493 534
494instance ResourceClass GLBuffer where 535instance ResourceClass GLBuffer where
495 getResource = rkey 536 getResource = rkey
496 537
497-- | The type of target buffer. 538-- | The type of target buffer.
498data TargetBuffer 539data TargetBuffer
499 = ArrayBuffer 540 = ArrayBuffer
500 | ElementArrayBuffer 541 | ElementArrayBuffer
501 | PixelPackBuffer 542 | PixelPackBuffer
502 | PixelUnpackBuffer 543 | PixelUnpackBuffer
503 deriving (Eq, Show) 544 deriving (Eq, Show)
504 545
505fromTarget :: TargetBuffer -> GLenum 546fromTarget :: TargetBuffer -> GLenum
506fromTarget ArrayBuffer = gl_ARRAY_BUFFER 547fromTarget ArrayBuffer = GL_ARRAY_BUFFER
507fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER 548fromTarget ElementArrayBuffer = GL_ELEMENT_ARRAY_BUFFER
508fromTarget PixelPackBuffer = gl_PIXEL_PACK_BUFFER 549fromTarget PixelPackBuffer = GL_PIXEL_PACK_BUFFER
509fromTarget PixelUnpackBuffer = gl_PIXEL_UNPACK_BUFFER 550fromTarget PixelUnpackBuffer = GL_PIXEL_UNPACK_BUFFER
510 551
511-- | A buffer usage. 552-- | A buffer usage.
512data BufferUsage 553data BufferUsage
513 = StreamDraw 554 = StreamDraw
514 | StreamRead 555 | StreamRead
515 | StreamCopy 556 | StreamCopy
516 | StaticDraw 557 | StaticDraw
517 | StaticRead 558 | StaticRead
518 | StaticCopy 559 | StaticCopy
519 | DynamicDraw 560 | DynamicDraw
520 | DynamicRead 561 | DynamicRead
521 | DynamicCopy 562 | DynamicCopy
522 deriving (Eq, Show) 563 deriving (Eq, Show)
523 564
524fromUsage :: BufferUsage -> GLenum 565fromUsage :: BufferUsage -> GLenum
525fromUsage StreamDraw = gl_STREAM_DRAW 566fromUsage StreamDraw = GL_STREAM_DRAW
526fromUsage StreamRead = gl_STREAM_READ 567fromUsage StreamRead = GL_STREAM_READ
527fromUsage StreamCopy = gl_STREAM_COPY 568fromUsage StreamCopy = GL_STREAM_COPY
528fromUsage StaticDraw = gl_STATIC_DRAW 569fromUsage StaticDraw = GL_STATIC_DRAW
529fromUsage StaticRead = gl_STATIC_READ 570fromUsage StaticRead = GL_STATIC_READ
530fromUsage StaticCopy = gl_STATIC_COPY 571fromUsage StaticCopy = GL_STATIC_COPY
531fromUsage DynamicDraw = gl_DYNAMIC_DRAW 572fromUsage DynamicDraw = GL_DYNAMIC_DRAW
532fromUsage DynamicRead = gl_DYNAMIC_READ 573fromUsage DynamicRead = GL_DYNAMIC_READ
533fromUsage DynamicCopy = gl_DYNAMIC_COPY 574fromUsage DynamicCopy = GL_DYNAMIC_COPY
534 575
535-- | Create a new buffer. 576-- | Create a new buffer.
536newBuffer :: Game s GLBuffer 577newBuffer :: Game s GLBuffer
537newBuffer = do 578newBuffer = do
538 h <- gameIO . alloca $ \ptr -> do 579 h <- gameIO . alloca $ \ptr -> do
539 glGenBuffers 1 ptr 580 glGenBuffers 1 ptr
540 peek ptr 581 peek ptr
541 582
542 rkey <- register $ deleteBuffer h 583 rkey <- register $ deleteBuffer h
543 return $ GLBuffer h rkey 584 return $ GLBuffer h rkey
544 585
545-- | Delete the buffer. 586-- | Delete the buffer.
546deleteBuffer :: GLuint -> IO () 587deleteBuffer :: GLuint -> IO ()
@@ -555,21 +596,30 @@ unbindBuffer :: TargetBuffer -> IO ()
555unbindBuffer target = glBindBuffer (fromTarget target) 0 596unbindBuffer target = glBindBuffer (fromTarget target) 0
556 597
557class Storable a => BufferData a where 598class Storable a => BufferData a where
558 -- | Set the buffer's data. 599 -- | Set the buffer's data.
559 bufferData :: TargetBuffer -> [a] -> BufferUsage -> IO () 600 bufferData :: TargetBuffer -> [a] -> BufferUsage -> IO ()
560 bufferData tgt vals usage = 601 bufferData tgt vals usage =
561 let n = sizeOf (head vals) * length vals 602 let n = sizeOf (head vals) * length vals
562 in withArray vals $ \ptr -> bufferData' tgt n ptr usage 603 in withArray vals $ \ptr -> bufferData' tgt n ptr usage
563 604
564instance BufferData Word8 605instance BufferData Word8
606
565instance BufferData Word16 607instance BufferData Word16
608
566instance BufferData Word32 609instance BufferData Word32
610
567instance BufferData CChar 611instance BufferData CChar
612
568instance BufferData CInt 613instance BufferData CInt
614
569instance BufferData CFloat 615instance BufferData CFloat
616
570instance BufferData CDouble 617instance BufferData CDouble
618
571instance BufferData Int 619instance BufferData Int
620
572instance BufferData Float 621instance BufferData Float
622
573instance BufferData Double 623instance BufferData Double
574 624
575{-bufferData :: Storable a 625{-bufferData :: Storable a
@@ -582,11 +632,13 @@ bufferData target n bufData usage = withArray bufData $
582 \ptr -> bufferData target (n * length bufData) ptr usage-} 632 \ptr -> bufferData target (n * length bufData) ptr usage-}
583 633
584-- | Set the buffer's data. 634-- | Set the buffer's data.
585bufferData' :: TargetBuffer 635bufferData' ::
586 -> Int -- ^ Buffer size in bytes. 636 TargetBuffer ->
587 -> Ptr a 637 -- | Buffer size in bytes.
588 -> BufferUsage 638 Int ->
589 -> IO () 639 Ptr a ->
640 BufferUsage ->
641 IO ()
590bufferData' target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage) 642bufferData' target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage)
591 643
592-- | Apply the given function the buffer's id. 644-- | Apply the given function the buffer's id.
@@ -599,88 +651,102 @@ withGLBuffer buf f = f $ getBuffer buf
599 651
600-- | Represents a texture resource. 652-- | Represents a texture resource.
601data Texture = Texture 653data Texture = Texture
602 { getTex :: GLuint 654 { getTex :: GLuint,
603 , texKey :: Resource 655 texKey :: Resource
604 } 656 }
605 657
606instance Eq Texture where 658instance Eq Texture where
607 t1 == t2 = getTex t1 == getTex t2 659 t1 == t2 = getTex t1 == getTex t2
608 660
609instance Ord Texture where 661instance Ord Texture where
610 t1 < t2 = getTex t1 < getTex t2 662 t1 < t2 = getTex t1 < getTex t2
663 t1 <= t2 = getTex t1 <= getTex t2
611 664
612instance ResourceClass Texture where 665instance ResourceClass Texture where
613 getResource = texKey 666 getResource = texKey
614 667
615-- | Create a new texture. 668-- | Create a new texture.
616newTexture :: Game s Texture 669newTexture :: Game s Texture
617newTexture = do 670newTexture = do
618 tex <- gameIO . alloca $ \ptr -> do 671 tex <- gameIO . alloca $ \ptr -> do
619 glGenTextures 1 ptr 672 glGenTextures 1 ptr
620 peek ptr 673 peek ptr
621 674
622 rkey <- register $ deleteTexture tex 675 rkey <- register $ deleteTexture tex
623 return $ Texture tex rkey 676 return $ Texture tex rkey
624 677
625-- | Delete the texture. 678-- | Delete the texture.
626deleteTexture :: GLuint -> IO () 679deleteTexture :: GLuint -> IO ()
627--deleteTexture tex = with tex $ glDeleteTextures 1 680--deleteTexture tex = with tex $ glDeleteTextures 1
628deleteTexture tex = do 681deleteTexture tex = do
629 putStrLn $ "Releasing texture " ++ show tex 682 putStrLn $ "Releasing texture " ++ show tex
630 with tex $ glDeleteTextures 1 683 with tex $ glDeleteTextures 1
631 684
632-- | Load the 'Texture' specified by the given file. 685-- | Load the 'Texture' specified by the given file.
633loadTextureImage :: FilePath 686loadTextureImage ::
634 -> GLenum -- ^ Texture's min filter. 687 FilePath ->
635 -> GLenum -- ^ Texture's mag filter. 688 -- | Texture's min filter.
636 -> Game s Texture 689 GLenum ->
690 -- | Texture's mag filter.
691 GLenum ->
692 Game s Texture
637loadTextureImage file minFilter magFilter = do 693loadTextureImage file minFilter magFilter = do
638 image <- loadImage file 694 image <- loadImage file
639 tex <- newTexture 695 tex <- newTexture
640 gameIO $ do 696 gameIO $ do
641 let w = width image 697 let w = width image
642 h = height image 698 h = height image
643 pix = pixels image 699 pix = pixels image
644 rgb = fromIntegral . fromEnum $ gl_RGB 700 rgb = fromIntegral . fromEnum $ GL_RGB
645 701
646 bindTexture tex 702 bindTexture tex
647 loadTextureData gl_TEXTURE_2D 0 rgb w h 0 gl_RGB gl_UNSIGNED_BYTE pix 703 loadTextureData GL_TEXTURE_2D 0 rgb w h 0 GL_RGB GL_UNSIGNED_BYTE pix
648 texParami gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $= minFilter 704 texParami GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $= minFilter
649 texParami gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $= magFilter 705 texParami GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $= magFilter
650 706
651 return tex 707 return tex
652 708
653-- | Bind the texture. 709-- | Bind the texture.
654bindTexture :: Texture -> IO () 710bindTexture :: Texture -> IO ()
655bindTexture = glBindTexture gl_TEXTURE_2D . getTex 711bindTexture = glBindTexture GL_TEXTURE_2D . getTex
656 712
657-- | Unbind the bound texture. 713-- | Unbind the bound texture.
658unbindTexture :: IO () 714unbindTexture :: IO ()
659unbindTexture = glBindTexture gl_TEXTURE_2D 0 715unbindTexture = glBindTexture GL_TEXTURE_2D 0
660 716
661-- | Load data onto the bound texture. 717-- | Load data onto the bound texture.
662-- 718--
663-- See also 'bindTexture'. 719-- See also 'bindTexture'.
664loadTextureData :: GLenum 720loadTextureData ::
665 -> Int -- ^ Target 721 GLenum ->
666 -> Int -- ^ Level 722 -- | Target
667 -> Int -- ^ Internal format 723 Int ->
668 -> Int -- ^ Width 724 -- | Level
669 -> Int -- ^ Height 725 Int ->
670 -> GLenum -- ^ Border 726 -- | Internal format
671 -> GLenum -- ^ Texture type 727 Int ->
672 -> Ptr a -- ^ Texture data 728 -- | Width
673 -> IO () 729 Int ->
730 -- | Height
731 Int ->
732 -- | Border
733 GLenum ->
734 -- | Texture type
735 GLenum ->
736 -- | Texture data
737 Ptr a ->
738 IO ()
674loadTextureData target level internalFormat width height border format texType texData = do 739loadTextureData target level internalFormat width height border format texType texData = do
675 glTexImage2D target 740 glTexImage2D
676 (fromIntegral level) 741 target
677 (fromIntegral internalFormat) 742 (fromIntegral level)
678 (fromIntegral width) 743 (fromIntegral internalFormat)
679 (fromIntegral height) 744 (fromIntegral width)
680 (fromIntegral border) 745 (fromIntegral height)
681 (fromIntegral format) 746 (fromIntegral border)
682 texType 747 (fromIntegral format)
683 texData 748 texType
749 texData
684 750
685-- | Set the bound texture's parameter to the given value. 751-- | Set the bound texture's parameter to the given value.
686texParami :: GLenum -> GLenum -> SettableStateVar GLenum 752texParami :: GLenum -> GLenum -> SettableStateVar GLenum
@@ -701,19 +767,20 @@ activeTexture = makeSettableStateVar glActiveTexture
701-- | Get the last OpenGL error. 767-- | Get the last OpenGL error.
702getGLError :: IO (Maybe String) 768getGLError :: IO (Maybe String)
703getGLError = fmap translate glGetError 769getGLError = fmap translate glGetError
704 where 770 where
705 translate err 771 translate err
706 | err == gl_NO_ERROR = Nothing 772 | err == GL_NO_ERROR = Nothing
707 | err == gl_INVALID_ENUM = Just "Invalid enum" 773 | err == GL_INVALID_ENUM = Just "Invalid enum"
708 | err == gl_INVALID_VALUE = Just "Invalid value" 774 | err == GL_INVALID_VALUE = Just "Invalid value"
709 | err == gl_INVALID_OPERATION = Just "Invalid operation" 775 | err == GL_INVALID_OPERATION = Just "Invalid operation"
710 | err == gl_OUT_OF_MEMORY = Just "Out of memory" 776 | err == GL_OUT_OF_MEMORY = Just "Out of memory"
711 | otherwise = Just "Unknown error" 777 | otherwise = Just "Unknown error"
712 778
713-- | Print the last OpenGL error. 779-- | Print the last OpenGL error.
714printGLError :: IO () 780printGLError :: IO ()
715printGLError = getGLError >>= \err -> case err of 781printGLError =
716 Nothing -> return () 782 getGLError >>= \err -> case err of
783 Nothing -> return ()
717 Just str -> hPutStrLn stderr str 784 Just str -> hPutStrLn stderr str
718 785
719-- | Run the given setup action and check for OpenGL errors. 786-- | Run the given setup action and check for OpenGL errors.
@@ -722,8 +789,8 @@ printGLError = getGLError >>= \err -> case err of
722-- the given string appended to the string describing the error. 789-- the given string appended to the string describing the error.
723assertGL :: Game s a -> String -> Game s a 790assertGL :: Game s a -> String -> Game s a
724assertGL action err = do 791assertGL action err = do
725 result <- action 792 result <- action
726 status <- gameIO getGLError 793 status <- gameIO getGLError
727 case status of 794 case status of
728 Just str -> gameError $ "OpenGL error raised: " ++ err ++ "; " ++ str 795 Just str -> gameError $ "OpenGL error raised: " ++ err ++ "; " ++ str
729 Nothing -> return result 796 Nothing -> return result