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 |
