aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Spear/GL.hs164
-rw-r--r--Spear/Render/AnimatedModel.hs20
-rw-r--r--Spear/Render/StaticModel.hs18
3 files changed, 108 insertions, 94 deletions
diff --git a/Spear/GL.hs b/Spear/GL.hs
index d3a42f0..65f985b 100644
--- a/Spear/GL.hs
+++ b/Spear/GL.hs
@@ -1,24 +1,11 @@
1module Spear.GL 1module Spear.GL
2( 2(
3 -- * General Management 3 -- * Programs
4 GLSLShader 4 GLSLProgram
5, GLSLProgram
6, ShaderType(..)
7 -- ** Programs
8, newProgram 5, newProgram
9, linkProgram 6, linkProgram
10, useProgram 7, useProgram
11, withGLSLProgram 8, withGLSLProgram
12 -- ** Shaders
13, attachShader
14, detachShader
15, loadShader
16, newShader
17 -- *** Source loading
18, loadSource
19, shaderSource
20, readSource
21, compile
22 -- ** Locations 9 -- ** Locations
23, attribLocation 10, attribLocation
24, fragLocation 11, fragLocation
@@ -29,16 +16,25 @@ module Spear.GL
29, uniformVec4 16, uniformVec4
30, uniformMat3 17, uniformMat3
31, uniformMat4 18, uniformMat4
32, uniformfl 19, LoadUniforms(..)
33, uniformil 20 -- * Shaders
34 -- ** Helper functions 21, GLSLShader
22, ShaderType(..)
23, attachShader
24, detachShader
25, loadShader
26, newShader
27 -- ** Source loading
28, loadSource
29, shaderSource
30, readSource
31, compile
32 -- * Helper functions
35, ($=) 33, ($=)
36, Data.StateVar.get 34, Data.StateVar.get
37 -- * VAOs 35 -- * VAOs
38, VAO 36, VAO
39 -- ** Creation and destruction
40, newVAO 37, newVAO
41 -- ** Manipulation
42, bindVAO 38, bindVAO
43, enableVAOAttrib 39, enableVAOAttrib
44, attribVAOPointer 40, attribVAOPointer
@@ -49,12 +45,10 @@ module Spear.GL
49, GLBuffer 45, GLBuffer
50, TargetBuffer(..) 46, TargetBuffer(..)
51, BufferUsage(..) 47, BufferUsage(..)
52 -- ** Creation and destruction
53, newBuffer 48, newBuffer
54 -- ** Manipulation
55, bindBuffer 49, bindBuffer
56, bufferData 50, BufferData(..)
57, bufferDatal 51, bufferData'
58, withGLBuffer 52, withGLBuffer
59 -- * Textures 53 -- * Textures
60, Texture 54, Texture
@@ -92,7 +86,9 @@ import Control.Monad.Trans.Error
92import Control.Monad.Trans.State as State 86import Control.Monad.Trans.State as State
93import qualified Data.ByteString.Char8 as B 87import qualified Data.ByteString.Char8 as B
94import Data.StateVar 88import Data.StateVar
89import Data.Word
95import Foreign.C.String 90import Foreign.C.String
91import Foreign.C.Types
96import Foreign.Ptr 92import Foreign.Ptr
97import Foreign.Storable 93import Foreign.Storable
98import Foreign.Marshal.Utils as Foreign (with) 94import Foreign.Marshal.Utils as Foreign (with)
@@ -140,9 +136,8 @@ withGLSLProgram prog f = f $ getProgram prog
140 136
141-- | Get the location of the given uniform variable within the given program. 137-- | Get the location of the given uniform variable within the given program.
142uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint 138uniformLocation :: GLSLProgram -> String -> GettableStateVar GLint
143uniformLocation prog var = makeGettableStateVar get 139uniformLocation prog var = makeGettableStateVar $
144 where 140 withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str)
145 get = withCString var $ \str -> glGetUniformLocation (getProgram prog) (unsafeCoerce str)
146 141
147-- | Get or set the location of the given variable to a fragment shader colour number. 142-- | Get or set the location of the given variable to a fragment shader colour number.
148fragLocation :: GLSLProgram -> String -> StateVar GLint 143fragLocation :: GLSLProgram -> String -> StateVar GLint
@@ -167,10 +162,10 @@ newProgram shaders = do
167 when (h == 0) $ gameError "glCreateProgram failed" 162 when (h == 0) $ gameError "glCreateProgram failed"
168 rkey <- register $ deleteProgram h 163 rkey <- register $ deleteProgram h
169 let program = GLSLProgram h rkey 164 let program = GLSLProgram h rkey
170 165
171 mapM_ (gameIO . attachShader program) shaders 166 mapM_ (gameIO . attachShader program) shaders
172 linkProgram program 167 linkProgram program
173 168
174 return program 169 return program
175 170
176-- | Delete the program. 171-- | Delete the program.
@@ -192,7 +187,7 @@ linkProgram prog = do
192 case status of 187 case status of
193 0 -> getStatus glGetProgramiv glGetProgramInfoLog h 188 0 -> getStatus glGetProgramiv glGetProgramInfoLog h
194 _ -> return "" 189 _ -> return ""
195 190
196 case length err of 191 case length err of
197 0 -> return () 192 0 -> return ()
198 _ -> gameError err 193 _ -> gameError err
@@ -258,10 +253,10 @@ shaderSource shader str =
258compile :: FilePath -> GLSLShader -> Game s () 253compile :: FilePath -> GLSLShader -> Game s ()
259compile file shader = do 254compile file shader = do
260 let h = getShader shader 255 let h = getShader shader
261 256
262 -- Compile 257 -- Compile
263 gameIO $ glCompileShader h 258 gameIO $ glCompileShader h
264 259
265 -- Verify status 260 -- Verify status
266 err <- gameIO $ alloca $ \statusPtr -> do 261 err <- gameIO $ alloca $ \statusPtr -> do
267 glGetShaderiv h gl_COMPILE_STATUS statusPtr 262 glGetShaderiv h gl_COMPILE_STATUS statusPtr
@@ -269,11 +264,11 @@ compile file shader = do
269 case result of 264 case result of
270 0 -> getStatus glGetShaderiv glGetShaderInfoLog h 265 0 -> getStatus glGetShaderiv glGetShaderInfoLog h
271 _ -> return "" 266 _ -> return ""
272 267
273 case length err of 268 case length err of
274 0 -> return () 269 0 -> return ()
275 _ -> gameError $ "Unable to compile shader " ++ file ++ ":\n" ++ err 270 _ -> gameError $ "Unable to compile shader " ++ file ++ ":\n" ++ err
276 271
277type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO () 272type StatusCall = GLuint -> GLenum -> Ptr GLint -> IO ()
278type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO () 273type LogCall = GLuint -> GLsizei -> Ptr GLsizei -> Ptr GLchar -> IO ()
279 274
@@ -314,16 +309,16 @@ readSource' file = do
314 if isInclude l 309 if isInclude l
315 then readSource' $ B.unpack . clean . cleanInclude $ l 310 then readSource' $ B.unpack . clean . cleanInclude $ l
316 else return l 311 else return l
317 312
318 contents <- B.readFile file 313 contents <- B.readFile file
319 314
320 dir <- getCurrentDirectory 315 dir <- getCurrentDirectory
321 let dir' = dir ++ "/" ++ (reverse . dropWhile (\c -> c /= '/') . reverse) file 316 let dir' = dir ++ "/" ++ (reverse . dropWhile (\c -> c /= '/') . reverse) file
322 317
323 setCurrentDirectory dir' 318 setCurrentDirectory dir'
324 code <- parse contents 319 code <- parse contents
325 setCurrentDirectory dir 320 setCurrentDirectory dir
326 321
327 return code 322 return code
328 323
329-- | Load a 2D vector. 324-- | Load a 2D vector.
@@ -338,7 +333,7 @@ uniformVec3 loc v = glUniform3f loc x' y' z'
338 where x' = unsafeCoerce $ x v 333 where x' = unsafeCoerce $ x v
339 y' = unsafeCoerce $ y v 334 y' = unsafeCoerce $ y v
340 z' = unsafeCoerce $ z v 335 z' = unsafeCoerce $ z v
341 336
342-- | Load a 4D vector. 337-- | Load a 4D vector.
343uniformVec4 :: GLint -> Vector4 -> IO () 338uniformVec4 :: GLint -> Vector4 -> IO ()
344uniformVec4 loc v = glUniform4f loc x' y' z' w' 339uniformVec4 loc v = glUniform4f loc x' y' z' w'
@@ -359,23 +354,25 @@ uniformMat4 loc mat =
359 with mat $ \ptrMat -> 354 with mat $ \ptrMat ->
360 glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat) 355 glUniformMatrix4fv loc 1 (toEnum 0) (unsafeCoerce ptrMat)
361 356
362-- | Load a list of floats. 357class LoadUniforms a where
363uniformfl :: GLint -> [GLfloat] -> IO () 358 -- | Load a list of uniform values.
364uniformfl loc vals = withArray vals $ \ptr -> 359 uniforml :: GLint -> [a] -> IO ()
365 case length vals of 360
366 1 -> glUniform1fv loc 1 ptr 361instance LoadUniforms Float where
367 2 -> glUniform2fv loc 1 ptr 362 uniforml loc vals = withArray (map unsafeCoerce vals) $ \ptr ->
368 3 -> glUniform3fv loc 1 ptr 363 case length vals of
369 4 -> glUniform4fv loc 1 ptr 364 1 -> glUniform1fv loc 1 ptr
370 365 2 -> glUniform2fv loc 1 ptr
371-- | Load a list of integers. 366 3 -> glUniform3fv loc 1 ptr
372uniformil :: GLint -> [GLint] -> IO () 367 4 -> glUniform4fv loc 1 ptr
373uniformil loc vals = withArray vals $ \ptr -> 368
374 case length vals of 369instance LoadUniforms Int where
375 1 -> glUniform1iv loc 1 ptr 370 uniforml loc vals = withArray (map fromIntegral vals) $ \ptr ->
376 2 -> glUniform2iv loc 1 ptr 371 case length vals of
377 3 -> glUniform3iv loc 1 ptr 372 1 -> glUniform1iv loc 1 ptr
378 4 -> glUniform4iv loc 1 ptr 373 2 -> glUniform2iv loc 1 ptr
374 3 -> glUniform3iv loc 1 ptr
375 4 -> glUniform4iv loc 1 ptr
379 376
380-- 377--
381-- VAOs 378-- VAOs
@@ -402,7 +399,7 @@ newVAO = do
402 h <- gameIO . alloca $ \ptr -> do 399 h <- gameIO . alloca $ \ptr -> do
403 glGenVertexArrays 1 ptr 400 glGenVertexArrays 1 ptr
404 peek ptr 401 peek ptr
405 402
406 rkey <- register $ deleteVAO h 403 rkey <- register $ deleteVAO h
407 return $ VAO h rkey 404 return $ VAO h rkey
408 405
@@ -415,7 +412,7 @@ bindVAO :: VAO -> IO ()
415bindVAO = glBindVertexArray . getVAO 412bindVAO = glBindVertexArray . getVAO
416 413
417-- | Enable the given vertex attribute of the bound vao. 414-- | Enable the given vertex attribute of the bound vao.
418-- 415--
419-- See also 'bindVAO'. 416-- See also 'bindVAO'.
420enableVAOAttrib :: GLuint -- ^ Attribute index. 417enableVAOAttrib :: GLuint -- ^ Attribute index.
421 -> IO () 418 -> IO ()
@@ -445,7 +442,7 @@ drawArrays mode first count = glDrawArrays mode (unsafeCoerce first) (unsafeCoer
445drawElements 442drawElements
446 :: GLenum -- ^ The kind of primitives to render. 443 :: GLenum -- ^ The kind of primitives to render.
447 -> Int -- ^ The number of elements to be rendered. 444 -> Int -- ^ The number of elements to be rendered.
448 -> GLenum -- ^ The type of the index values. Must be one of gl_UNSIGNED_BYTE, gl_UNSIGNED_SHORT, or gl_UNSIGNED_INT. 445 -> GLenum -- ^ The type of the index values. Must be one of gl_UNSIGNED_BYTE, gl_UNSIGNED_SHORT, or gl_UNSIGNED_INT.
449 -> Ptr a -- ^ Pointer to the location where indices are stored, or offset into the index array when there is a bound ElementArrayBuffer. 446 -> Ptr a -- ^ Pointer to the location where indices are stored, or offset into the index array when there is a bound ElementArrayBuffer.
450 -> IO () 447 -> IO ()
451drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs 448drawElements mode count t idxs = glDrawElements mode (unsafeCoerce count) t idxs
@@ -470,7 +467,7 @@ data TargetBuffer
470 | PixelPackBuffer 467 | PixelPackBuffer
471 | PixelUnpackBuffer 468 | PixelUnpackBuffer
472 deriving (Eq, Show) 469 deriving (Eq, Show)
473 470
474fromTarget :: TargetBuffer -> GLenum 471fromTarget :: TargetBuffer -> GLenum
475fromTarget ArrayBuffer = gl_ARRAY_BUFFER 472fromTarget ArrayBuffer = gl_ARRAY_BUFFER
476fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER 473fromTarget ElementArrayBuffer = gl_ELEMENT_ARRAY_BUFFER
@@ -507,7 +504,7 @@ newBuffer = do
507 h <- gameIO . alloca $ \ptr -> do 504 h <- gameIO . alloca $ \ptr -> do
508 glGenBuffers 1 ptr 505 glGenBuffers 1 ptr
509 peek ptr 506 peek ptr
510 507
511 rkey <- register $ deleteBuffer h 508 rkey <- register $ deleteBuffer h
512 return $ GLBuffer h rkey 509 return $ GLBuffer h rkey
513 510
@@ -519,23 +516,40 @@ deleteBuffer buf = Foreign.with buf $ glDeleteBuffers 1
519bindBuffer :: GLBuffer -> TargetBuffer -> IO () 516bindBuffer :: GLBuffer -> TargetBuffer -> IO ()
520bindBuffer buf target = glBindBuffer (fromTarget target) $ getBuffer buf 517bindBuffer buf target = glBindBuffer (fromTarget target) $ getBuffer buf
521 518
522-- | Set the buffer's data. 519class Storable a => BufferData a where
523bufferData :: TargetBuffer 520 -- | Set the buffer's data.
524 -> Int -- ^ Buffer size in bytes. 521 bufferData :: TargetBuffer -> [a] -> BufferUsage -> IO ()
525 -> Ptr a 522 bufferData tgt vals usage =
523 let n = sizeOf (undefined :: Word8) * length vals
524 in withArray vals $ \ptr -> bufferData' tgt n ptr usage
525
526instance BufferData Word8
527instance BufferData Word16
528instance BufferData Word32
529instance BufferData CChar
530instance BufferData CInt
531instance BufferData CFloat
532instance BufferData CDouble
533instance BufferData Int
534instance BufferData Float
535instance BufferData Double
536
537{-bufferData :: Storable a
538 => TargetBuffer
539 -> Int -- ^ The size in bytes of an element in the data list.
540 -> [a] -- ^ The data list.
526 -> BufferUsage 541 -> BufferUsage
527 -> IO () 542 -> IO ()
528bufferData target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage) 543bufferData target n bufData usage = withArray bufData $
544 \ptr -> bufferData target (n * length bufData) ptr usage-}
529 545
530-- | Set the buffer's data. 546-- | Set the buffer's data.
531bufferDatal :: Storable a 547bufferData' :: TargetBuffer
532 => TargetBuffer 548 -> Int -- ^ Buffer size in bytes.
533 -> Int -- ^ The size in bytes of an element in the data list. 549 -> Ptr a
534 -> [a] -- ^ The data list.
535 -> BufferUsage 550 -> BufferUsage
536 -> IO () 551 -> IO ()
537bufferDatal target n bufData usage = withArray bufData $ 552bufferData' target n bufData usage = glBufferData (fromTarget target) (unsafeCoerce n) bufData (fromUsage usage)
538 \ptr -> bufferData target (n * length bufData) ptr usage
539 553
540-- | Apply the given function the buffer's id. 554-- | Apply the given function the buffer's id.
541withGLBuffer :: GLBuffer -> (GLuint -> a) -> a 555withGLBuffer :: GLBuffer -> (GLuint -> a) -> a
@@ -566,7 +580,7 @@ newTexture = do
566 tex <- gameIO . alloca $ \ptr -> do 580 tex <- gameIO . alloca $ \ptr -> do
567 glGenTextures 1 ptr 581 glGenTextures 1 ptr
568 peek ptr 582 peek ptr
569 583
570 rkey <- register $ deleteTexture tex 584 rkey <- register $ deleteTexture tex
571 return $ Texture tex rkey 585 return $ Texture tex rkey
572 586
@@ -590,12 +604,12 @@ loadTextureImage file minFilter magFilter = do
590 h = height image 604 h = height image
591 pix = pixels image 605 pix = pixels image
592 rgb = fromIntegral . fromEnum $ gl_RGB 606 rgb = fromIntegral . fromEnum $ gl_RGB
593 607
594 bindTexture tex 608 bindTexture tex
595 loadTextureData gl_TEXTURE_2D 0 rgb w h 0 gl_RGB gl_UNSIGNED_BYTE pix 609 loadTextureData gl_TEXTURE_2D 0 rgb w h 0 gl_RGB gl_UNSIGNED_BYTE pix
596 texParami gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $= minFilter 610 texParami gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER $= minFilter
597 texParami gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $= magFilter 611 texParami gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER $= magFilter
598 612
599 return tex 613 return tex
600 614
601-- | Bind the texture. 615-- | Bind the texture.
diff --git a/Spear/Render/AnimatedModel.hs b/Spear/Render/AnimatedModel.hs
index 9c05109..aa202ec 100644
--- a/Spear/Render/AnimatedModel.hs
+++ b/Spear/Render/AnimatedModel.hs
@@ -107,35 +107,35 @@ animatedModelResource
107 elementBuf <- newBuffer 107 elementBuf <- newBuffer
108 vao <- newVAO 108 vao <- newVAO
109 boxes <- gameIO $ modelBoxes model 109 boxes <- gameIO $ modelBoxes model
110 110
111 gameIO $ do 111 gameIO $ do
112 112
113 let elemSize = 56 113 let elemSize = 56
114 elemSize' = fromIntegral elemSize 114 elemSize' = fromIntegral elemSize
115 n = numVertices * numFrames 115 n = numVertices * numFrames
116 116
117 bindVAO vao 117 bindVAO vao
118 118
119 bindBuffer elementBuf ArrayBuffer 119 bindBuffer elementBuf ArrayBuffer
120 bufferData ArrayBuffer (unsafeCoerce $ elemSize * n) elements StaticDraw 120 bufferData' ArrayBuffer (unsafeCoerce $ elemSize * n) elements StaticDraw
121 121
122 attribVAOPointer vertChan1 3 gl_FLOAT False elemSize' 0 122 attribVAOPointer vertChan1 3 gl_FLOAT False elemSize' 0
123 attribVAOPointer vertChan2 3 gl_FLOAT False elemSize' 12 123 attribVAOPointer vertChan2 3 gl_FLOAT False elemSize' 12
124 attribVAOPointer normChan1 3 gl_FLOAT False elemSize' 24 124 attribVAOPointer normChan1 3 gl_FLOAT False elemSize' 24
125 attribVAOPointer normChan2 3 gl_FLOAT False elemSize' 36 125 attribVAOPointer normChan2 3 gl_FLOAT False elemSize' 36
126 attribVAOPointer texChan 2 gl_FLOAT False elemSize' 48 126 attribVAOPointer texChan 2 gl_FLOAT False elemSize' 48
127 127
128 enableVAOAttrib vertChan1 128 enableVAOAttrib vertChan1
129 enableVAOAttrib vertChan2 129 enableVAOAttrib vertChan2
130 enableVAOAttrib normChan1 130 enableVAOAttrib normChan1
131 enableVAOAttrib normChan2 131 enableVAOAttrib normChan2
132 enableVAOAttrib texChan 132 enableVAOAttrib texChan
133 133
134 rkey <- register $ do 134 rkey <- register $ do
135 putStrLn "Releasing animated model resource" 135 putStrLn "Releasing animated model resource"
136 clean vao 136 clean vao
137 clean elementBuf 137 clean elementBuf
138 138
139 return $ AnimatedModelResource 139 return $ AnimatedModelResource
140 model vao (unsafeCoerce numFrames) (unsafeCoerce numVertices) 140 model vao (unsafeCoerce numFrames) (unsafeCoerce numVertices)
141 material texture boxes rkey 141 material texture boxes rkey
diff --git a/Spear/Render/StaticModel.hs b/Spear/Render/StaticModel.hs
index cadf350..700414f 100644
--- a/Spear/Render/StaticModel.hs
+++ b/Spear/Render/StaticModel.hs
@@ -69,31 +69,31 @@ staticModelResource (StaticProgramChannels vertChan normChan texChan) material t
69 elementBuf <- newBuffer 69 elementBuf <- newBuffer
70 vao <- newVAO 70 vao <- newVAO
71 boxes <- gameIO $ modelBoxes model 71 boxes <- gameIO $ modelBoxes model
72 72
73 gameIO $ do 73 gameIO $ do
74 74
75 let elemSize = 32 75 let elemSize = 32
76 elemSize' = fromIntegral elemSize 76 elemSize' = fromIntegral elemSize
77 n = numVertices 77 n = numVertices
78 78
79 bindVAO vao 79 bindVAO vao
80 80
81 bindBuffer elementBuf ArrayBuffer 81 bindBuffer elementBuf ArrayBuffer
82 bufferData ArrayBuffer (fromIntegral $ elemSize*n) elements StaticDraw 82 bufferData' ArrayBuffer (fromIntegral $ elemSize*n) elements StaticDraw
83 83
84 attribVAOPointer vertChan 3 gl_FLOAT False elemSize' 0 84 attribVAOPointer vertChan 3 gl_FLOAT False elemSize' 0
85 attribVAOPointer normChan 3 gl_FLOAT False elemSize' 12 85 attribVAOPointer normChan 3 gl_FLOAT False elemSize' 12
86 attribVAOPointer texChan 2 gl_FLOAT False elemSize' 24 86 attribVAOPointer texChan 2 gl_FLOAT False elemSize' 24
87 87
88 enableVAOAttrib vertChan 88 enableVAOAttrib vertChan
89 enableVAOAttrib normChan 89 enableVAOAttrib normChan
90 enableVAOAttrib texChan 90 enableVAOAttrib texChan
91 91
92 rkey <- register $ do 92 rkey <- register $ do
93 putStrLn "Releasing static model resource" 93 putStrLn "Releasing static model resource"
94 clean vao 94 clean vao
95 clean elementBuf 95 clean elementBuf
96 96
97 return $ StaticModelResource 97 return $ StaticModelResource
98 vao (unsafeCoerce numVertices) material texture boxes rkey 98 vao (unsafeCoerce numVertices) material texture boxes rkey
99 99