diff --git a/Graphics/GL/Low.hs b/Graphics/GL/Low.hs new file mode 100644 --- /dev/null +++ b/Graphics/GL/Low.hs @@ -0,0 +1,1409 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE PatternSynonyms #-} +module Graphics.GL.Low ( + + -- * In a Nutshell + -- + -- ** Overview + -- | OpenGL is a graphics rendering interface. This library exposes a vastly + -- simplified subset of OpenGL that is hopefully still complete enough for + -- many purposes, such as following tutorials, making simple games, and + -- demos. In particular the intention is to concentrate on a subset of + -- OpenGL 3.2 (Core Profile) roughly corresponding to ES 2.0. + -- + -- A second primary purpose is to document the complex model behind the + -- interface in a way that is more elaborate than tutorials and more concise + -- than the spec. As such, this is an experimental project to aid my own + -- process of understanding OpenGL. It seems that understanding the entire + -- picture up-front is the only way to get started, so this should also serve + -- as a quick reference guide to the core commands and concepts. + -- + -- This library uses the `gl' package for raw bindings to OpenGL and the + -- `linear' package for matrices. + -- + -- (include link to example programs) + + -- ** Objects + -- | Objects may be created and destroyed by client code. They include: + -- + -- - Vertex Array Object ('VAO') + -- - Buffer Objects ('VBO', 'ElementArray') + -- - Textures ('Tex2D', 'CubeMap') + -- - Shader 'Program's + -- - Framebuffer Objects ('FBO') + -- - Renderbuffer Objects ('RBO') + + -- ** Binding Targets + -- | Objects are referenced with integers (called names in GL), so binding + -- targets can be thought of as global variables to put those references. + -- Many operations implicitly read from these globals to determine what the + -- target object of the operation is. They include: + -- + -- - Vertex array binding target (for VAO) + -- - Buffer binding targets (ARRAY_BUFFER and ELEMENT_ARRAY_BUFFER) + -- - Texture binding targets (TEXTURE_2D and TEXTURE_CUBE_MAP) + -- - Framebuffer binding target (for FBO) + -- + -- (not binding targets but similar) + -- + -- - Shader program "in use" + -- - Texture units + -- - Current active texture unit + -- - Image attachment points of an FBO + + -- ** Shader Programs + -- | The role of the second half of a program, the fragment shader, is to + -- compute the color and depth of pixels covered by rasterized primitives + -- (points, lines, and triangles) in the process of rendering. The role of + -- the /first/ half of the program (vertex program) is to arrange the vertices + -- of those primitives somewhere in clip space. Where these vertices and + -- their attributes come from in the first place is determined by the VAO + -- bound to the vertex array binding target. The program may also make use + -- of uniform variables and texture units assigned by client code before + -- rendering (but in a process separate from configuring the VAO). At most + -- one Program can be "in use" at a time. + + -- ** VAO + -- | The VAO is essential. At least one VAO must be created and bound to the + -- vertex array binding target before rendering, before configuring a + -- program's vertex attributes. Here is why: the VAO stores the association + -- between input variables in the program and a VBO from which to pipe input + -- from. It also stores the format of the VBO data, which is otherwise just + -- a big blob. Finally, the VAO stores the state of the element array binding + -- target used for indexed rendering. + -- + -- After installing a program with 'useProgram' and binding a source VBO + -- to the array buffer binding target ('bindVBO') then the bound VAO can be + -- updated ('setVertexAttributeLayout') with new vertex attribute information. + -- After this, the VBO can be rebound to configure a different set of inputs + -- with a different source. Many VAOs can be created and swapped out to pipe + -- vertex data in different ways to different programs (or the same program). + -- + -- When a VAO is bound it restores the state of the element array binding + -- target. For this reason you can think of that binding target as simply + -- being a function of the VAO itself rather than a separate global state. + + -- ** Uniforms and Samplers (Textures) + -- | Programs may have uniform variables and "sampler uniforms" as input. + -- Uniforms are accessible from the vertex or fragment shader part of the + -- program but their values are fixed during the course of a rendering command. + -- They can be set and reset with the setUniform family (ex. 'setUniform1f'), + -- which updates a program object with new uniform values. Among other + -- things, updating the uniforms each frame is the main way to animate a + -- scene. + -- + -- Samplers are textures that the shader can interpolate to get "in between" + -- values. The texture a sampler uses is determined by the contents of the + -- texture unit that that sampler points to. The sampler is a uniform with + -- an integer type. This integer is the texture unit to use. The word texture + -- should not be construed to mean a color image. Shaders can make use of + -- many kinds of multi-dimensional data that happen to be available through + -- the samplers. + + -- ** Texture Objects and Texture Units + -- | Before a shader can use a texture it must be assigned to a texture unit. + -- First set the active texture unit to the desired unit number + -- ('setActiveTextureUnit') then bind the texture object to one of the + -- two texture binding targets, depending on what kind of texture it is (2D + -- or cubemap). Binding a texture has the side effect of assigning it to the + -- active texture unit. + + -- ** Custom Framebuffers + -- | It is possible (and important to many techniques) to utilize an + -- off-screen render target. To do this create an FBO ('newFBO'), bind it to + -- the framebuffer binding target ('bindFramebuffer') and attach a color + -- /image/ object (texture or renderbuffer object). If necessary a depth + -- image or combination depth-stencil image can be attached as well. If no + -- color image is attached then the FBO is incomplete and rendering will be + -- an error. After rendering to an FBO any textures that were attached can + -- be used for a second pass by assigning them to a texture unit. Watch out + -- for feedback loops accidentally sampling a texture that is also being + -- rendered to at the same time! + -- + -- A renderbuffer object is a minor character to be used when you do not + -- expect to use the results of rendering but need an image anyway. For + -- example you may need a depth buffer to do depth testing, or you may want + -- to ignore the (required for rendering to work at all) color buffer. + + -- ** Images and Image Formats + -- | FBOs have attachment points for /images/. A texture serves as an image + -- and a renderbuffer object serves as an image. Images have an "internal + -- format" which describes the size and interpretation of pixel components. + -- There are seven internal formats, five of which are color image formats + -- such as grayscale and RGB. The other two are the depth buffer format and + -- the combination depth-stencil format. RBOs ('newRBO') and empty textures + -- ('newEmptyTexture2D', 'newEmptyCubeMap') can be created with any of these + -- formats. + -- + -- (The above is a gross simplification of OpenGL's image formats. I should + -- probably revise, because it may greatly improve performance to use some + -- of the 16-bit color formats rather than 32.) + + -- ** Depth Testing, Stencil Testing, Scissor Testing, Facet Culling + -- | The depth buffer and stencil buffers, if present in the current + -- framebuffer, can be used to avoid rendering to points of the screen by + -- testing against the value stored at those points. For example if commanded + -- to show a triangle in a region of the framebuffer with a depth greater + -- than current depth buffer values, then the triangle may not be rendered to + -- the color buffer or anywhere else (depending on settings). There are many + -- global settings to switch on and off these tests and the ability to + -- modify the buffers involved. The stencil test in particular is highly + -- configurable. The scissor test is the simplest: when activated nothing + -- outside the scissor box (in screen space) will be rendered. The only + -- other configuration is to set that scissor box ('setScissorBox'). + -- Polygons facing toward or away from the viewer can be dropped (or culled) + -- from rendering with 'enableCulling'. + + -- ** Coordinate Systems + -- | - Screen space is simply the 2D coordinate system of your window. + -- The viewport transformation (see 'setViewport') determines where in the + -- window the mapping of the NDS cube (see below) will appear. + -- - NDS, normalized device coordinates, or sometimes viewport space is a + -- cube 2x2x2 centered at the origin the inside of which is your final scene, + -- before it is mapped to the screen via the viewport setting (see + -- 'setViewport'). If an orthographic projection was used to put the scene in + -- clip space then clip space and NDS are the same. + -- - Clip space is the destination of vertices transformed by the + -- vertex program. Objects here are mapped to NDS using the perspective + -- division technique to account for the case that the vertex shader used + -- a perspective matrix. + -- - Model space is the name for positions of raw vertices as present in + -- the VBOs. The vertex program will want to somehow move these vertexes + -- into clip space, representing generally the position and direction the + -- user is viewing the scene from. + + -- ** Rendering Points, Lines, and Triangles + -- | The draw family (ex. 'drawTriangles') of commands commissions the + -- rendering of a certain number of vertices worth of primitives. The + -- current program will get input from the current VAO, the current texture + -- units, and execute on all the potentially affected pixels in the current + -- framebuffer. Vertexes are consumed in the order they appear in their + -- respective source VBOs. If the VAO is missing, the program is missing, or + -- the current framebuffer has no color attachment, then rendering will not + -- work. + -- + -- The drawIndexed family (ex. 'drawIndexedTriangles') of commands carries + -- out the same effects as the non-indexed rendering commands but traverses + -- vertices in an order determined by the sequence of indexes packed in the + -- ElementArray currently bound to the element array binding target. This + -- mainly allows a huge reuse of vertex data in the case that the object + -- being rendered forms a closed mesh. + + + + + -- * VAO + VAO, + newVAO, + bindVAO, + deleteVAO, + + -- * Buffer Objects + -- ** VBO + VBO, + UsageHint(..), + newVBO, + bindVBO, + updateVBO, + deleteVBO, + + -- ** Element Array + ElementArray, + IndexFormat(..), + newElementArray, + bindElementArray, + updateElementArray, + deleteElementArray, + + -- * Shader Program + Program, + ProgramError(..), + newProgram, + newProgramSafe, + useProgram, + deleteProgram, + + -- ** Vertex Attributes + VertexAttributeLayout(..), + LayoutElement(..), + ComponentFormat(..), + setVertexAttributeLayout, + + -- ** Uniform Variables + -- + -- | Set uniform variables for the current program. To set an array of + -- uniforms pass a list of more than one value. + + -- *** Float Uniforms + -- | These call glUniformNfv. + setUniform1f, + setUniform2f, + setUniform3f, + setUniform4f, + + -- *** Int Uniforms + -- | These call glUniformNiv. + setUniform1i, + setUniform2i, + setUniform3i, + setUniform4i, + + -- *** Matrix Uniforms + -- | These call glUniformMatrixNfv. + setUniform22, + setUniform33, + setUniform44, + + -- * Textures + Tex2D, + CubeMap, + Dimensions(..), + Cube(..), + Side, + newTexture2D, + newCubeMap, + newEmptyTexture2D, + newEmptyCubeMap, + deleteTexture, + setActiveTextureUnit, + bindTexture2D, + bindTextureCubeMap, + Filtering(..), + setTex2DFiltering, + setCubeMapFiltering, + Wrapping(..), + setTex2DWrapping, + setCubeMapWrapping, + + -- * Rendering + + -- ** Primitives + -- | Draw primitives to the framebuffer currently bound to the framebuffer + -- binding target. Each primitive drawing command takes the number of vertices + -- in the VBOs to render. The vertices are traversed in order. + drawPoints, + drawLines, + drawLineStrip, + drawLineLoop, + drawTriangles, + drawTriangleStrip, + drawTriangleFan, + + -- ** Primitives by Index + -- | Draw primitives as above, but use the order of vertices defined in + -- the ElementArray currently bound to the element array buffer binding + -- target. + drawIndexedPoints, + drawIndexedLines, + drawIndexedLineStrip, + drawIndexedLineLoop, + drawIndexedTriangles, + drawIndexedTriangleStrip, + drawIndexedTriangleFan, + + -- ** Color Buffer + enableColorWriting, + disableColorWriting, + clearColorBuffer, + + -- ** Depth Test + enableDepthTest, + disableDepthTest, + clearDepthBuffer, + enableDepthWriting, + disableDepthWriting, + + -- ** Stencil Test + enableStencilTest, + disableStencilTest, + clearStencilBuffer, + enableStencilWriting, + disableStencilWriting, + + -- ** Scissor Test + setScissorBox, + enableScissorTest, + disableScissorTest, + + -- ** Facet Culling + Culling(..), + enableCulling, + disableCulling, + + -- ** Blending + -- | When blending is enabled, colors written to the color buffer will be + -- blended with the color already there using a formula. The three options + -- for the formula are ('setBlendEquation'): + -- + -- - Xs + Yd (FuncAdd, the default) + -- - Xs - Yd (FuncSub) + -- - Yd - Xs (FuncReverseSubtract) + -- + -- where X and Y are source and destination color components respetively. + -- The factors s and d are blending factors which can be configured + -- ('setBlendFactors') and should depend on the alpha channel to get a correct + -- transparency effect. The typical choice is + -- + -- @ + -- setBlendFactors BlendSourceAlpha BlendOneMinusSourceAlpha + -- @ + -- + -- When using blending the order of rendering matters. The farther away + -- primitives should be rendered first to get transparent materials to look + -- right. This means a depth test is unhelpful when using this technique. + -- Also blending many layers of transparent primitives can significantly + -- degrade performance. For these reasons transparency effects may be better + -- accomplished with an off-screen rendering pass followed by a suitable shader. + + BlendFactor(..), + BlendEquation(..), + enableBlending, + disableBlending, + setBlendFactors, + setBlendEquation, + + -- ** Viewport + Viewport(..), + setViewport, + + -- * Framebuffers + DefaultFramebuffer, + FBO, + bindFramebuffer, + newFBO, + attachTex2D, + attachCubeMap, + attachRBO, + deleteFBO, + + -- * Renderbuffers + RBO, + newRBO, + deleteRBO, + + -- * Errors + GLError(..), + getGLError, + + -- * Image Formats + Alpha, + Luminance, + LuminanceAlpha, + RGB, + RGBA, + Depth24, + Depth24Stencil8, + + -- * Classes + InternalFormat(..), + Framebuffer(..), + Texture(..), + Attachable(..) + +) where + +import Prelude hiding (sum) +import Control.Exception +import Data.Typeable +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal +import Foreign.C.String +import Data.Vector.Storable (Vector, unsafeWith) +import qualified Data.Vector.Storable as V (length) +import Control.Monad hiding (forM_) +import Data.Word +import Data.Int +import Data.Functor +import Control.Applicative +import Data.Traversable +import Data.Foldable +import Data.Default + +import Linear +import Graphics.GL + +-- | A VAO stores vertex attribute layouts and the VBO source of vertices +-- for those attributes. It also stores the state of the element array binding +-- target. The vertex array binding target admits one VAO at a time. +newtype VAO = VAO GLuint deriving Show + +-- | A Program object is the combination of a compiled vertex shader and fragment +-- shader. Programs have three kinds of inputs: vertex attributes, uniforms, +-- and samplers. Programs have two outputs: fragment color and fragment depth. +-- At most one program can be "in use" at a time. Same idea as binding targets +-- it's just not called that. +newtype Program = Program GLuint deriving Show + +-- | A VBO is a buffer object which has vertex data. Shader programs use VBOs +-- as input to their vertex attributes according to the configuration of the +-- bound VAO. +data VBO = VBO GLuint deriving Show + +-- | A buffer object which has a packed sequence of vertex indices. Indexed +-- rendering uses the ElementArray bound to the element array binding target. +data ElementArray = ElementArray GLuint deriving Show + +-- | A 2D texture. A program can sample a texture if it has been bound to +-- the appropriate texture unit. +newtype Tex2D a = Tex2D GLuint deriving Show + +-- | A cubemap texture is just six 2D textures. A program can sample a cubemap +-- texture if it has been bound to the appropriate texture unit. +newtype CubeMap a = CubeMap GLuint deriving Show + +-- | A framebuffer object is an alternative rendering destination. Once an FBO +-- is bound to framebuffer binding target, it is possible to attach images +-- (textures or RBOs) for color, depth, or stencil rendering. +newtype FBO = FBO GLuint deriving Show + + +-- | Texture filtering modes. +data Filtering = + Nearest | -- ^ No interpolation. + Linear -- ^ Linear interpolation. + deriving Show + +instance ToGL Filtering where + toGL Nearest = GL_NEAREST + toGL Linear = GL_LINEAR + +-- | Texture wrapping modes. +data Wrapping = + Repeat | -- ^ Tile the texture past the boundary. + MirroredRepeat | -- ^ Tile the texture but mirror every other tile. + ClampToEdge -- ^ Use the edge color for anything past the boundary. + deriving Show + +instance ToGL Wrapping where + toGL Repeat = GL_REPEAT + toGL MirroredRepeat = GL_MIRRORED_REPEAT + toGL ClampToEdge = GL_CLAMP_TO_EDGE + +-- | Facet culling modes. +data Culling = + CullFront | + CullBack | + CullFrontAndBack + deriving Show + +instance ToGL Culling where + toGL CullFront = GL_FRONT + toGL CullBack = GL_BACK + toGL CullFrontAndBack = GL_FRONT_AND_BACK + +-- | The name of a vertex input to a program combined with the +-- component format and number of components for that attribute in the +-- vertex data. Alternatively the size of an unused section of the data +-- in bytes. +data LayoutElement = + Attrib String Int ComponentFormat | -- ^ Name, component count and component format of a vertex attribute. + Unused Int -- ^ Size in bytes of an unused section of the vertex data. + deriving Show + +-- | The layout of interleaved vertex attribute data. +type VertexAttributeLayout = [LayoutElement] + +-- | The size and interpretation of a vertex attribute component. Normalized +-- components will be mapped to floats in the range [0, 1]. +data ComponentFormat = + VFloat | -- ^ 4-byte float + VByte | + VUByte | + VByteNormalized | + VUByteNormalized | + VShort | -- ^ 2-byte signed integer + VUShort | -- ^ 2-byte unsigned integer + VShortNormalized | + VUShortNormalized | + VInt | -- ^ 4-byte signed integer + VUInt | -- ^ 4-byte unsigned integer + VIntNormalized | + VUIntNormalized + deriving (Eq, Show) + +instance ToGL ComponentFormat where + toGL VFloat = GL_FLOAT + toGL VByte = GL_BYTE + toGL VUByte = GL_UNSIGNED_BYTE + toGL VByteNormalized = GL_BYTE + toGL VUByteNormalized = GL_UNSIGNED_BYTE + toGL VShort = GL_SHORT + toGL VUShort = GL_UNSIGNED_SHORT + toGL VShortNormalized = GL_SHORT + toGL VUShortNormalized = GL_UNSIGNED_SHORT + toGL VInt = GL_INT + toGL VUInt = GL_UNSIGNED_INT + toGL VIntNormalized = GL_INT + toGL VUIntNormalized = GL_UNSIGNED_INT + + +-- | Usage hint for allocation of buffer object storage. +data UsageHint = StaticDraw -- ^ Data will seldomly change. + | DynamicDraw -- ^ Data will change. + | StreamDraw -- ^ Data will change very often. + deriving Show + +instance ToGL UsageHint where + toGL StaticDraw = GL_STATIC_DRAW + toGL DynamicDraw = GL_DYNAMIC_DRAW + toGL StreamDraw = GL_STREAM_DRAW + + +-- | 1-byte alpha channel only. +data Alpha = Alpha deriving Show + +-- | 1-byte grayscale pixel format. +data Luminance = Luminance deriving Show + +-- | 2-byte luminance and alpha channel format. +data LuminanceAlpha = Luminancealpha deriving Show + +-- | 3-byte true color pixel format. +data RGB = RGB deriving Show + +-- | 4-byte true color plus alpha channel format. +data RGBA = RGBA deriving Show + +-- | 24-bit depth format. +data Depth24 = Depth24 deriving Show + +-- | Combination depth and stencil format. +data Depth24Stencil8 = Depth24Stencil8 deriving Show + +-- | OpenGL internal image formats. +class InternalFormat a where + internalFormat :: (Eq b, Num b) => proxy a -> b +instance InternalFormat RGB where + internalFormat _ = GL_RGB8 +instance InternalFormat RGBA where + internalFormat _ = GL_RGBA +instance InternalFormat Alpha where + internalFormat _ = GL_ALPHA +instance InternalFormat Luminance where + internalFormat _ = GL_LUMINANCE +instance InternalFormat LuminanceAlpha where + internalFormat _ = GL_LUMINANCE_ALPHA +instance InternalFormat Depth24 where + internalFormat _ = GL_DEPTH_COMPONENT24 +instance InternalFormat Depth24Stencil8 where + internalFormat _ = GL_DEPTH24_STENCIL8 + +-- | The allowed attachment point for images with an internal format. +class InternalFormat a => Attachable a where + attachPoint :: (Eq b, Num b) => proxy a -> b +instance Attachable RGB where + attachPoint _ = GL_COLOR_ATTACHMENT0 +instance Attachable RGBA where + attachPoint _ = GL_COLOR_ATTACHMENT0 +instance Attachable Luminance where + attachPoint _ = GL_COLOR_ATTACHMENT0 +instance Attachable LuminanceAlpha where + attachPoint _ = GL_COLOR_ATTACHMENT0 +instance Attachable Alpha where + attachPoint _ = GL_COLOR_ATTACHMENT0 +instance Attachable Depth24 where + attachPoint _ = GL_DEPTH_ATTACHMENT +instance Attachable Depth24Stencil8 where + attachPoint _ = GL_DEPTH_STENCIL_ATTACHMENT + +-- | How indices are packed in an ElementArray buffer object. +data IndexFormat = + UByteIndices | -- ^ Each index is one unsigned byte. + UShortIndices | -- ^ Each index is a two byte unsigned int. + UIntIndices -- ^ Each index is a four byte unsigned int. + deriving Show + +instance ToGL IndexFormat where + toGL UByteIndices = GL_UNSIGNED_BYTE + toGL UShortIndices = GL_UNSIGNED_SHORT + toGL UIntIndices = GL_UNSIGNED_INT + + +-- | An RBO is a kind of image object used for rendering. The only thing +-- you can do with an RBO is attach it to an FBO. +data RBO a = RBO { unRBO :: GLuint } deriving Show + +-- | A rectangular section of the window. +data Viewport = Viewport + { viewportX :: Int + , viewportY :: Int + , viewportW :: Int + , viewportH :: Int } + deriving (Eq, Show) + +-- | The size of an image in pixels, parameterized by an image format type. +data Dimensions = Dimensions + { imageWidth :: Int + , imageHeight :: Int } + deriving (Show) + +-- | Six values, one on each side. +data Cube a = Cube + { cubeRight :: a + , cubeLeft :: a + , cubeTop :: a + , cubeBottom :: a + , cubeFront :: a + , cubeBack :: a } + deriving (Show, Functor, Foldable, Traversable) + +-- | A type to pick one of the sides of a cube. See the accessors of the +-- type 'Cube'. +type Side = forall a . Cube a -> a + +instance Applicative Cube where + pure x = Cube x x x x x x + (Cube f1 f2 f3 f4 f5 f6) <*> (Cube x1 x2 x3 x4 x5 x6) = + Cube (f1 x1) (f2 x2) (f3 x3) (f4 x4) (f5 x5) (f6 x6) + +-- | Either a vertex shader or a fragment shader. +data ShaderType = VertexShader | FragmentShader deriving Show + +instance ToGL ShaderType where + toGL VertexShader = GL_VERTEX_SHADER + toGL FragmentShader = GL_FRAGMENT_SHADER + +-- | The error message emitted by the driver when shader compilation or +-- linkage fails. +data ProgramError = + VertexShaderError String | + FragmentShaderError String | + LinkError String + deriving (Show, Typeable) + +instance Exception ProgramError + +-- | Detectable errors. +data GLError = + InvalidEnum | -- ^ Enum argument out of range. + InvalidValue | -- ^ Integer argument out of range. + InvalidOperation | -- ^ Operation illegal in current state. + InvalidFramebufferOperation | -- ^ Framebuffer is not complete. + OutOfMemory + deriving Typeable + +instance Exception GLError + +instance Show GLError where + show InvalidEnum = "INVALID_ENUM enum argument out of range" + show InvalidValue = "INVALID_VALUE Numeric argument out of range" + show InvalidOperation = "INVALID_OPERATION Illegal in current state" + show InvalidFramebufferOperation = "INVALID_FRAMEBUFFER_OPERATION Framebuffer object is not complete" + show OutOfMemory = "Not enough memory left to execute command" + +class ToGL a where + toGL :: (Num b, Eq b) => a -> b + +-- | Textures have an internal numeric name. +class Texture a where + textureName :: Num b => a -> b + +instance Texture (Tex2D a) where + textureName (Tex2D n) = fromIntegral n + +instance Texture (CubeMap a) where + textureName (CubeMap n) = fromIntegral n + + +-- | Blending functions for alpha blending. +data BlendEquation = + FuncAdd | -- ^ the default + FuncSubtract | + FuncReverseSubtract + deriving Show + +instance Default BlendEquation where + def = FuncAdd + +instance ToGL BlendEquation where + toGL FuncAdd = GL_FUNC_ADD + toGL FuncSubtract = GL_FUNC_SUBTRACT + toGL FuncReverseSubtract = GL_FUNC_REVERSE_SUBTRACT + + +-- | Blending factors. +data BlendFactor = + BlendOne | + BlendZero | + BlendSourceAlpha | + BlendOneMinusSourceAlpha + deriving Show + +instance ToGL BlendFactor where + toGL BlendOne = GL_ONE + toGL BlendZero = GL_ZERO + toGL BlendSourceAlpha = GL_SRC_ALPHA + toGL BlendOneMinusSourceAlpha = GL_ONE_MINUS_SRC_ALPHA + +-- | The default framebuffer. Bind this to render to the screen as usual. +-- Use the Default instance method 'def' to construct it. +data DefaultFramebuffer = DefaultFramebuffer deriving Show + +instance Default DefaultFramebuffer where + def = DefaultFramebuffer + +-- | Framebuffers can be bound to the framebuffer binding target. There is +-- a default framebuffer and the client may create an arbitrary number of +-- new framebuffer objects. +class Framebuffer a where + framebufferName :: Num b => a -> b + +instance Framebuffer DefaultFramebuffer where + framebufferName _ = 0 + +instance Framebuffer FBO where + framebufferName (FBO n) = fromIntegral n + + + +-- | Create a new VAO. The only thing you can do with a VAO is bind it to +-- the vertex array binding target. +newVAO :: IO VAO +newVAO = do + n <- alloca (\ptr -> glGenVertexArrays 1 ptr >> peek ptr) + return (VAO n) + +-- | Delete a VAO. +deleteVAO :: VAO -> IO () +deleteVAO (VAO n) = withArray [n] (\ptr -> glDeleteVertexArrays 1 ptr) + +-- | Assign the VAO to the vertex array binding target. The VAO already bound +-- will be replaced, if any. +bindVAO :: VAO -> IO () +bindVAO (VAO n) = glBindVertexArray n + + +-- | Create a buffer object from a blob of bytes. The usage argument hints +-- at how often you will modify the data. +newVBO :: Vector Word8 -> UsageHint -> IO VBO +newVBO src usage = do + n <- alloca (\ptr -> glGenBuffers 1 ptr >> peek ptr) + let len = V.length src + glBindBuffer GL_ARRAY_BUFFER n + unsafeWith src $ \ptr -> glBufferData + GL_ARRAY_BUFFER + (fromIntegral len) + (castPtr ptr) + (toGL usage) + return (VBO n) + +-- | Delete a VBO. +deleteVBO :: VBO -> IO () +deleteVBO (VBO n) = withArray [n] (\ptr -> glDeleteBuffers 1 ptr) + +-- | Modify the data in the currently bound VBO starting from the specified +-- index in bytes. +updateVBO :: Vector Word8 -> Int -> IO () +updateVBO src offset = do + let len = V.length src + unsafeWith src $ \ptr -> glBufferSubData + GL_ARRAY_BUFFER + (fromIntegral offset) + (fromIntegral len) + (castPtr ptr) + +-- | Bind a VBO to the array buffer binding target. The buffer object bound +-- there will be replaced, if any. +bindVBO :: VBO -> IO () +bindVBO (VBO n) = glBindBuffer GL_ARRAY_BUFFER n + + +-- | Create a new ElementArray buffer object from the blob of packed indices. +-- The usage argument hints at how often you plan to modify the data. +newElementArray :: Vector Word8 -> UsageHint -> IO ElementArray +newElementArray bytes usage = do + n <- alloca (\ptr -> glGenBuffers 1 ptr >> peek ptr) + glBindBuffer GL_ELEMENT_ARRAY_BUFFER n + let len = V.length bytes + unsafeWith bytes $ \ptr -> do + glBufferData + GL_ELEMENT_ARRAY_BUFFER + (fromIntegral len) + (castPtr ptr) + (toGL usage) + return (ElementArray n) + +-- | Delete an ElementArray +deleteElementArray :: ElementArray -> IO () +deleteElementArray (ElementArray n) = withArray [n] (\ptr -> glDeleteBuffers 1 ptr) + +-- | Modify contents in the currently bound ElementArray starting at the +-- specified index in bytes. +updateElementArray :: Vector Word8 -> Int -> IO () +updateElementArray bytes offset = unsafeWith bytes $ \ptr -> do + glBufferSubData + GL_ELEMENT_ARRAY_BUFFER + (fromIntegral offset) + (fromIntegral (V.length bytes)) + (castPtr ptr) + + +-- | Assign an ElementArray to the element array binding target. It will +-- replace the ElementArray already bound there, if any. Note that the state +-- of the element array binding target is a function of the current VAO. +bindElementArray :: ElementArray -> IO () +bindElementArray (ElementArray n) = glBindBuffer GL_ELEMENT_ARRAY_BUFFER n + + +-- | Same as 'newProgram' but does not throw exceptions. +newProgramSafe :: String -> String -> IO (Either ProgramError Program) +newProgramSafe vcode fcode = try $ newProgram vcode fcode + +-- | Delete a program. +deleteProgram :: Program -> IO () +deleteProgram (Program n) = glDeleteProgram n + +-- | Compile the code for a vertex shader and a fragment shader, then link +-- them into a new program. If the compiler or linker fails it will throw +-- a ProgramError. +newProgram :: String -- ^ vertex shader source code + -> String -- ^ fragment shader source code + -> IO Program +newProgram vcode fcode = do + vertexShaderId <- compileShader vcode VertexShader + fragmentShaderId <- compileShader fcode FragmentShader + programId <- glCreateProgram + glAttachShader programId vertexShaderId + glAttachShader programId fragmentShaderId + glLinkProgram programId + result <- alloca $ \ptr -> + glGetProgramiv programId GL_LINK_STATUS ptr >> peek ptr + when (result == GL_FALSE) $ do + len <- fmap fromIntegral $ alloca $ \ptr -> + glGetProgramiv programId GL_INFO_LOG_LENGTH ptr >> peek ptr + errors <- allocaArray len $ \ptr -> do + glGetProgramInfoLog programId (fromIntegral len) nullPtr ptr + peekCString ptr + throwIO (LinkError errors) + glDeleteShader vertexShaderId + glDeleteShader fragmentShaderId + return (Program programId) + +-- | Install a program into the rendering pipeline. Replaces the program +-- already in use, if any. +useProgram :: Program -> IO () +useProgram (Program n) = glUseProgram n + +compileShader :: String -> ShaderType -> IO GLuint +compileShader code vertOrFrag = do + shaderId <- glCreateShader (toGL vertOrFrag) + withCString code $ \ptr -> with ptr $ \pptr -> do + glShaderSource shaderId 1 pptr nullPtr + glCompileShader shaderId + result <- with GL_FALSE $ \ptr -> + glGetShaderiv shaderId GL_COMPILE_STATUS ptr >> peek ptr + when (result == GL_FALSE) $ do + len <- fmap fromIntegral $ alloca $ \ptr -> + glGetShaderiv shaderId GL_INFO_LOG_LENGTH ptr >> peek ptr + errors <- allocaArray len $ \ptr -> do + glGetShaderInfoLog shaderId (fromIntegral len) nullPtr ptr + peekCString ptr + case vertOrFrag of + VertexShader -> throwIO (VertexShaderError errors) + FragmentShader -> throwIO (FragmentShaderError errors) + return shaderId + + +-- | This configures the currently bound VAO. It calls glVertexAttribPointer +-- and glEnableVertexAttribArray. +setVertexAttributeLayout :: Program -> VertexAttributeLayout -> IO () +setVertexAttributeLayout (Program p) layout = do + let layout' = elaborateLayout 0 layout + let total = totalLayout layout + forM_ layout' $ \(name, size, offset, fmt) -> do + attrib <- withCString name $ \ptr -> glGetAttribLocation p (castPtr ptr) + let norm = isNormalized fmt + glVertexAttribPointer + (fromIntegral attrib) + (fromIntegral size) + (toGL fmt) + (fromIntegral . fromEnum $ norm) + (fromIntegral offset) + (castPtr (nullPtr `plusPtr` offset)) + glEnableVertexAttribArray (fromIntegral attrib) + +elaborateLayout :: Int -> VertexAttributeLayout -> [(String, Int, Int, ComponentFormat)] +elaborateLayout here layout = case layout of + [] -> [] + (Unused n):xs -> elaborateLayout (here+n) xs + (Attrib name n fmt):xs -> + let size = n * sizeOfVertexComponent fmt in + (name, n, here, fmt) : elaborateLayout (here+size) xs + +totalLayout :: VertexAttributeLayout -> Int +totalLayout layout = sum (map arraySize layout) where + arraySize (Unused n) = n + arraySize (Attrib _ n fmt) = n * sizeOfVertexComponent fmt + +sizeOfVertexComponent :: ComponentFormat -> Int +sizeOfVertexComponent c = case c of + VByte -> 1 + VUByte -> 1 + VByteNormalized -> 1 + VUByteNormalized -> 1 + VShort -> 2 + VUShort -> 2 + VShortNormalized -> 2 + VUShortNormalized -> 2 + VInt -> 4 + VUInt -> 4 + VIntNormalized -> 4 + VUIntNormalized -> 4 + VFloat -> 4 + +isNormalized :: ComponentFormat -> Bool +isNormalized c = case c of + VByte -> False + VUByte -> False + VByteNormalized -> True + VUByteNormalized -> True + VShort -> False + VUShort -> False + VShortNormalized -> True + VUShortNormalized -> True + VInt -> False + VUInt -> False + VIntNormalized -> True + VUIntNormalized -> True + VFloat -> False + + +setUniform1f :: Program -> String -> [Float] -> IO () +setUniform1f = setUniform glUniform1fv + +setUniform2f :: Program -> String -> [V2 Float] -> IO () +setUniform2f = setUniform + (\loc cnt val -> glUniform2fv loc cnt (castPtr val)) + +setUniform3f :: Program -> String -> [V3 Float] -> IO () +setUniform3f = setUniform + (\loc cnt val -> glUniform3fv loc cnt (castPtr val)) + +setUniform4f :: Program -> String -> [V4 Float] -> IO () +setUniform4f = setUniform + (\loc cnt val -> glUniform4fv loc cnt (castPtr val)) + +setUniform1i :: Program -> String -> [Int] -> IO () +setUniform1i = setUniform + (\loc cnt val -> glUniform1iv loc cnt (castPtr val)) + +setUniform2i :: Program -> String -> [V2 Int] -> IO () +setUniform2i = setUniform + (\loc cnt val -> glUniform2iv loc cnt (castPtr val)) + +setUniform3i :: Program -> String -> [V3 Int] -> IO () +setUniform3i = setUniform + (\loc cnt val -> glUniform3iv loc cnt (castPtr val)) + +setUniform4i :: Program -> String -> [V4 Int] -> IO () +setUniform4i = setUniform + (\loc cnt val -> glUniform4iv loc cnt (castPtr val)) + +setUniform44 :: Program -> String -> [M44 Float] -> IO () +setUniform44 = setUniform + (\loc cnt val -> glUniformMatrix4fv loc cnt GL_FALSE (castPtr val)) + +setUniform33 :: Program -> String -> [M33 Float] -> IO () +setUniform33 = setUniform + (\loc cnt val -> glUniformMatrix3fv loc cnt GL_FALSE (castPtr val)) + +setUniform22 :: Program -> String -> [M22 Float] -> IO () +setUniform22 = setUniform + (\loc cnt val -> glUniformMatrix2fv loc cnt GL_FALSE (castPtr val)) + +setUniform :: Storable a => (GLint -> GLsizei -> Ptr a -> IO ()) + -> Program -> String -> [a] + -> IO () +setUniform glAction (Program p) name xs = withArrayLen xs $ \n bytes -> do + loc <- withCString name (\ptr -> glGetUniformLocation p ptr) + glAction loc (fromIntegral n) bytes + + + + +drawPoints :: Int -> IO () +drawPoints = drawArrays GL_POINTS + +drawLines :: Int -> IO () +drawLines = drawArrays GL_LINES + +drawLineStrip :: Int -> IO () +drawLineStrip = drawArrays GL_LINE_STRIP + +drawLineLoop :: Int -> IO () +drawLineLoop = drawArrays GL_LINE_LOOP + +drawTriangles :: Int -> IO () +drawTriangles = drawArrays GL_TRIANGLES + +drawTriangleStrip :: Int -> IO () +drawTriangleStrip = drawArrays GL_TRIANGLE_STRIP + +drawTriangleFan :: Int -> IO () +drawTriangleFan = drawArrays GL_TRIANGLE_FAN + +drawArrays :: GLenum -> Int -> IO () +drawArrays mode n = glDrawArrays mode (fromIntegral n) 0 + +drawIndexedPoints :: Int -> IndexFormat -> IO () +drawIndexedPoints = drawIndexed GL_POINTS + +drawIndexedLines :: Int -> IndexFormat -> IO () +drawIndexedLines = drawIndexed GL_LINES + +drawIndexedLineStrip :: Int -> IndexFormat -> IO () +drawIndexedLineStrip = drawIndexed GL_LINE_STRIP + +drawIndexedLineLoop :: Int -> IndexFormat -> IO () +drawIndexedLineLoop = drawIndexed GL_LINE_LOOP + +drawIndexedTriangles :: Int -> IndexFormat -> IO () +drawIndexedTriangles = drawIndexed GL_TRIANGLES + +drawIndexedTriangleStrip :: Int -> IndexFormat -> IO () +drawIndexedTriangleStrip = drawIndexed GL_TRIANGLE_STRIP + +drawIndexedTriangleFan :: Int -> IndexFormat -> IO () +drawIndexedTriangleFan = drawIndexed GL_TRIANGLE_FAN + +drawIndexed :: GLenum -> Int -> IndexFormat -> IO () +drawIndexed mode n fmt = glDrawElements mode (fromIntegral n) (toGL fmt) nullPtr + +-- | Create a new 2D texture from a blob and its image format. +-- Dimensions should be powers of two. +newTexture2D :: InternalFormat a => Vector Word8 -> Dimensions -> IO (Tex2D a) +newTexture2D bytes (Dimensions w h) = do + n <- alloca (\ptr -> glGenTextures 1 ptr >> peek ptr) + glBindTexture GL_TEXTURE_2D n + tex <- return (Tex2D n) + unsafeWith bytes $ \ptr -> glTexImage2D + GL_TEXTURE_2D + 0 + (internalFormat tex) + (fromIntegral w) + (fromIntegral h) + 0 + (internalFormat tex) + GL_UNSIGNED_BYTE + (castPtr ptr) + return tex + +-- | Delete a texture. +deleteTexture :: Texture a => a -> IO () +deleteTexture x = withArray [textureName x] (\ptr -> glDeleteTextures 1 ptr) + +-- | Create a new cube map texture from six blobs and their respective formats. +-- Dimensions should be powers of two. +newCubeMap :: InternalFormat a + => Cube (Vector Word8, Dimensions) + -> IO (CubeMap a) +newCubeMap images = do + n <- alloca (\ptr -> glGenTextures 1 ptr >> peek ptr) + glBindTexture GL_TEXTURE_CUBE_MAP n + cm <- return (CubeMap n) + let fmt = internalFormat cm + sequenceA (liftA2 (loadCubeMapSide fmt) images cubeSideCodes) + return cm + +loadCubeMapSide :: GLenum -> (Vector Word8, Dimensions) -> GLenum -> IO () +loadCubeMapSide fmt (bytes, (Dimensions w h)) side = do + unsafeWith bytes $ \ptr -> glTexImage2D + side + 0 + (fromIntegral fmt) + (fromIntegral w) + (fromIntegral h) + 0 + fmt + GL_UNSIGNED_BYTE + (castPtr ptr) + +-- | Create an empty texture with the specified dimensions and format. +newEmptyTexture2D :: InternalFormat a => Int -> Int -> IO (Tex2D a) +newEmptyTexture2D w h = do + let w' = fromIntegral w + let h' = fromIntegral h + n <- alloca (\ptr -> glGenTextures 1 ptr >> peek ptr) + tex <- return (Tex2D n) + let fmt = internalFormat tex + let fmt' = internalFormat tex + glBindTexture GL_TEXTURE_2D n + glTexImage2D GL_TEXTURE_2D 0 fmt w' h' 0 fmt' GL_UNSIGNED_BYTE nullPtr + return tex + +-- | Create a cubemap texture where each of the six sides has the specified +-- dimensions and format. +newEmptyCubeMap :: InternalFormat a => Int -> Int -> IO (CubeMap a) +newEmptyCubeMap w h = do + let w' = fromIntegral w + let h' = fromIntegral h + n <- alloca (\ptr -> glGenTextures 1 ptr >> peek ptr) + tex <- return (CubeMap n) + let fmt = internalFormat tex + let fmt' = internalFormat tex + glBindTexture GL_TEXTURE_CUBE_MAP n + glTexImage2D GL_TEXTURE_CUBE_MAP_POSITIVE_X 0 fmt w' h' 0 fmt' GL_UNSIGNED_BYTE nullPtr + glTexImage2D GL_TEXTURE_CUBE_MAP_NEGATIVE_X 0 fmt w' h' 0 fmt' GL_UNSIGNED_BYTE nullPtr + glTexImage2D GL_TEXTURE_CUBE_MAP_POSITIVE_Y 0 fmt w' h' 0 fmt' GL_UNSIGNED_BYTE nullPtr + glTexImage2D GL_TEXTURE_CUBE_MAP_NEGATIVE_Y 0 fmt w' h' 0 fmt' GL_UNSIGNED_BYTE nullPtr + glTexImage2D GL_TEXTURE_CUBE_MAP_POSITIVE_Z 0 fmt w' h' 0 fmt' GL_UNSIGNED_BYTE nullPtr + glTexImage2D GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 0 fmt w' h' 0 fmt' GL_UNSIGNED_BYTE nullPtr + return tex + + +-- | Bind a 2D texture to the 2D texture binding target and the currently +-- active texture unit. +bindTexture2D :: Tex2D a -> IO () +bindTexture2D (Tex2D n) = glBindTexture GL_TEXTURE_2D n + +-- | Bind a cubemap texture to the cubemap texture binding target and +-- the currently active texture unit. +bindTextureCubeMap :: CubeMap a -> IO () +bindTextureCubeMap (CubeMap n) = glBindTexture GL_TEXTURE_CUBE_MAP n + +-- | Set the active texture unit. The default is zero. +setActiveTextureUnit :: Enum a => a -> IO () +setActiveTextureUnit n = + (glActiveTexture . fromIntegral) (GL_TEXTURE0 + fromEnum n) + +-- | Set the filtering for the 2D texture currently bound to the 2D texture +-- binding target. +setTex2DFiltering :: Filtering -> IO () +setTex2DFiltering filt = do + glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER (toGL filt) + glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER (toGL filt) + +-- | Set the filtering for the cubemap texture currently bound to the cubemap +-- texture binding target. +setCubeMapFiltering :: Filtering -> IO () +setCubeMapFiltering filt = do + glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MIN_FILTER (toGL filt) + glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAG_FILTER (toGL filt) + +-- | Set the wrapping mode for the 2D texture currently bound to the 2D +-- texture binding target. +setTex2DWrapping :: Wrapping -> IO () +setTex2DWrapping wrap = do + glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S (toGL wrap) + glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T (toGL wrap) + +-- | Set the wrapping mode for the cubemap texture currently bound to the +-- cubemap texture binding target. Because no blending occurs between cube +-- faces you probably want ClampToEdge. +setCubeMapWrapping :: Wrapping -> IO () +setCubeMapWrapping wrap = do + glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S (toGL wrap) + glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T (toGL wrap) + glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R (toGL wrap) + + + +-- | Allow rendering commands to modify the color buffer of the current +-- framebuffer. +enableColorWriting :: IO () +enableColorWriting = glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE + +-- | Disable rendering to color buffer. +disableColorWriting :: IO () +disableColorWriting = glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE + +-- | Clear the color buffer of the current framebuffer with the specified +-- color. Has no effect if writing to the color buffer is disabled. +clearColorBuffer :: (Float, Float, Float) -> IO () +clearColorBuffer (r, g, b) = do + glClearColor (realToFrac r) (realToFrac g) (realToFrac b) 1.0 + glClear GL_COLOR_BUFFER_BIT + +-- | Enable the depth test. Attempting to render pixels with a depth value +-- greater than the depth buffer at those pixels will have no effect. +enableDepthTest :: IO () +enableDepthTest = glEnable GL_DEPTH_TEST + +-- | Disable the depth test. Rendering will not be affected by the depth. +-- Use this to render graphics even if they are behind something. +disableDepthTest :: IO () +disableDepthTest = glDisable GL_DEPTH_TEST + +-- | Enable writing depth values to the depth buffer of the current framebuffer. +-- It is enabled by default. +enableDepthWriting :: IO () +enableDepthWriting = glDepthMask GL_TRUE + +-- | Disable writing to the depth buffer. +disableDepthWriting :: IO () +disableDepthWriting = glDepthMask GL_FALSE + +-- | Clear the depth buffer with the maximum depth value. +clearDepthBuffer :: IO () +clearDepthBuffer = glClear GL_DEPTH_BUFFER_BIT + +-- | Enable the stencil test. Any pixels rendered to the screen where the +-- stencil buffer is 1 will not be rendered. This disables writing to the +-- stencil buffer. +enableStencilTest :: IO () +enableStencilTest = do + glStencilFunc GL_LESS 1 maxBound + glStencilOp GL_KEEP GL_KEEP GL_KEEP + glEnable GL_STENCIL_TEST + +-- | Disable the stencil test. +disableStencilTest :: IO () +disableStencilTest = glDisable GL_STENCIL_TEST + +-- | Clear the stencil buffer with all zeros. +clearStencilBuffer :: IO () +clearStencilBuffer = glClear GL_STENCIL_BUFFER_BIT + +-- | Allow rendering to modify the stencil buffer. Any pixels rendered to +-- the screen will set the stencil buffer to 1 at that location. +enableStencilWriting :: IO () +enableStencilWriting = do + glStencilFunc GL_ALWAYS 1 maxBound + glStencilOp GL_KEEP GL_KEEP GL_REPLACE + glStencilMask 1 + +-- | Disable rendering to the stencil buffer. +disableStencilWriting :: IO () +disableStencilWriting = glStencilMask 0 + + + +-- | Set the scissor box. Graphics outside this box will not be rendered as +-- long as the scissor test is enabled. +setScissorBox :: Viewport -> IO () +setScissorBox (Viewport x y w h) = + glScissor (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + +-- | Enable the scissor test. Graphics outside the scissor box will not be +-- rendered. +enableScissorTest :: IO () +enableScissorTest = glEnable GL_SCISSOR_TEST + +-- | Disable the scissor test. +disableScissorTest :: IO () +disableScissorTest = glDisable GL_SCISSOR_TEST + + +-- | Enable facet culling. The argument specifies whether front faces, back +-- faces, or both will be omitted from rendering. If both front and back +-- faces are culled you can still render points and lines. +enableCulling :: Culling -> IO () +enableCulling c = do + case c of + CullFront -> glCullFace GL_FRONT + CullBack -> glCullFace GL_BACK + CullFrontAndBack -> glCullFace GL_FRONT_AND_BACK + glEnable GL_CULL_FACE + +-- | Disable facet culling. Front and back faces will now be rendered. +disableCulling :: IO () +disableCulling = glDisable GL_CULL_FACE + +-- | Set the viewport. The default viewport simply covers the entire window. +setViewport :: Viewport -> IO () +setViewport (Viewport x y w h) = + glViewport (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + +-- | Binds an FBO or the default framebuffer to the framebuffer binding target. +-- Replaces the framebuffer already bound there. +bindFramebuffer :: Framebuffer a => a -> IO () +bindFramebuffer x = glBindFramebuffer GL_FRAMEBUFFER (framebufferName x) + +-- | Create a new framebuffer object. Before the framebuffer can be used for +-- rendering it must have a color image attachment. +newFBO :: IO FBO +newFBO = do + n <- alloca (\ptr -> glGenFramebuffers 1 ptr >> peek ptr) + return (FBO n) + +-- | Delete an FBO. +deleteFBO :: FBO -> IO () +deleteFBO (FBO n) = withArray [n] (\ptr -> glDeleteFramebuffers 1 ptr) + +-- | Attach a 2D texture to the FBO currently bound to the +-- framebuffer binding target. +attachTex2D :: Attachable a => Tex2D a -> IO () +attachTex2D t@(Tex2D n) = + glFramebufferTexture2D GL_FRAMEBUFFER (attachPoint t) GL_TEXTURE_2D n 0 + +-- | Attach one of the sides of a cubemap texture to the FBO currently bound +-- to the framebuffer binding target. +attachCubeMap :: Attachable a => CubeMap a -> Side -> IO () +attachCubeMap cm@(CubeMap n) side = + glFramebufferTexture2D + GL_FRAMEBUFFER + (attachPoint cm) + (side cubeSideCodes) + n + 0 + +cubeSideCodes :: Cube GLenum +cubeSideCodes = Cube + { cubeLeft = GL_TEXTURE_CUBE_MAP_NEGATIVE_X + , cubeRight = GL_TEXTURE_CUBE_MAP_POSITIVE_X + , cubeTop = GL_TEXTURE_CUBE_MAP_POSITIVE_Y + , cubeBottom = GL_TEXTURE_CUBE_MAP_NEGATIVE_Y + , cubeFront = GL_TEXTURE_CUBE_MAP_POSITIVE_Z + , cubeBack = GL_TEXTURE_CUBE_MAP_NEGATIVE_Z } + +-- | Attach an RBO to the FBO currently bound to the framebuffer binding +-- target. +attachRBO :: Attachable a => RBO a -> IO () +attachRBO rbo = glFramebufferRenderbuffer + GL_FRAMEBUFFER (attachPoint rbo) GL_RENDERBUFFER (unRBO rbo) + +-- | Create a new renderbuffer with the specified dimensions. +newRBO :: InternalFormat a => Int -> Int -> IO (RBO a) +newRBO w h = do + n <- alloca (\ptr -> glGenRenderbuffers 1 ptr >> peek ptr) + rbo <- return (RBO n) + glBindRenderbuffer GL_RENDERBUFFER n + glRenderbufferStorage + GL_RENDERBUFFER + (internalFormat rbo) + (fromIntegral w) + (fromIntegral h) + return rbo + +-- | Delete an RBO. +deleteRBO :: RBO a -> IO () +deleteRBO (RBO n) = withArray [n] (\ptr -> glDeleteRenderbuffers 1 ptr) + + +-- | Enable alpha blending. +enableBlending :: IO () +enableBlending = glEnable GL_BLEND + +-- | Disable alpha blending. +disableBlending :: IO () +disableBlending = glDisable GL_BLEND + +-- | Set the computation for source and destination blending factors. +setBlendFactors :: BlendFactor -> BlendFactor -> IO () +setBlendFactors s d = glBlendFunc (toGL s) (toGL d) + +-- | Set the overall blending function. +setBlendEquation :: BlendEquation -> IO () +setBlendEquation e = glBlendEquation (toGL e) + + + +-- | Check for a GL Error. +getGLError :: IO (Maybe GLError) +getGLError = do + n <- glGetError + return $ case n of + GL_NO_ERROR -> Nothing + GL_INVALID_ENUM -> Just InvalidEnum + GL_INVALID_VALUE -> Just InvalidValue + GL_INVALID_OPERATION -> Just InvalidOperation + GL_INVALID_FRAMEBUFFER_OPERATION -> Just InvalidFramebufferOperation + GL_OUT_OF_MEMORY -> Just OutOfMemory + _ -> error ("unknown GL error " ++ show n) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2015 Evan Rinehart + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lowgl.cabal b/lowgl.cabal new file mode 100644 --- /dev/null +++ b/lowgl.cabal @@ -0,0 +1,76 @@ +-- Initial lowgl.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: lowgl + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Basic gl wrapper and reference + +-- A longer description of the package. +description: This library exposes a vastly simplified subset of OpenGL that is hopefully still complete enough for many purposes, such as following tutorials, making simple games, and demos. + +-- The license under which the package is released. +license: BSD2 + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Evan Rinehart + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: evanrinehart@gmail.com + +-- A copyright notice. +-- copyright: + +category: Graphics + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +-- extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +library + -- Modules exported by the library. + exposed-modules: Graphics.GL.Low + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base >=4.7 && <4.8, vector >=0.10 && <0.11, linear >=1.16 && <1.17, gl >=0.6 && <0.7, data-default + + -- Directories containing source files. + -- hs-source-dirs: + + -- Base language which the package is written in. + default-language: Haskell2010 + + +source-repository head + type: git + location: https://github.com/evanrinehart/lowgl + +source-repository this + type: git + location: https://github.com/evanrinehart/lowgl + tag: 0.1.0.0