GLUtil (empty) → 0.1.4
raw patch · 15 files changed
+608/−0 lines, 15 filesdep +OpenGLdep +OpenGLRawdep +arraysetup-changedbinary-added
Dependencies added: OpenGL, OpenGLRaw, array, base, bytestring, vector
Files
- GLUtil.cabal +44/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- examples/TGA.hs +27/−0
- examples/example1.hs +111/−0
- examples/images/hello1.tga binary
- examples/images/hello2.tga binary
- examples/shaders/hello-gl.frag +14/−0
- examples/shaders/hello-gl.vert +10/−0
- src/Graphics/GLUtil.hs +13/−0
- src/Graphics/GLUtil/BufferObjects.hs +63/−0
- src/Graphics/GLUtil/GLError.hs +45/−0
- src/Graphics/GLUtil/Shaders.hs +113/−0
- src/Graphics/GLUtil/Textures.hs +100/−0
- src/Graphics/GLUtil/VertexArrayObjects.hs +36/−0
+ GLUtil.cabal view
@@ -0,0 +1,44 @@+Name: GLUtil+Version: 0.1.4+Synopsis: Miscellaneous OpenGL utilities.+License: BSD3+License-file: LICENSE+Author: Anthony Cowley+Maintainer: acowley@gmail.com+Copyright: (c) 2012 Anthony Cowley+Category: Graphics+Build-type: Simple+Description: Helpers for working with shaders, buffer objects, and + textures in OpenGL.++Cabal-version: >=1.6++Extra-Source-Files: examples/example1.hs,+ examples/TGA.hs,+ examples/images/hello1.tga,+ examples/images/hello2.tga,+ examples/shaders/hello-gl.frag,+ examples/shaders/hello-gl.vert++Library+ Exposed-modules: Graphics.GLUtil,+ Graphics.GLUtil.GLError,+ Graphics.GLUtil.Shaders, + Graphics.GLUtil.BufferObjects, + Graphics.GLUtil.Textures,+ Graphics.GLUtil.VertexArrayObjects+ + Build-depends: base >= 4.2 && < 5,+ bytestring,+ array,+ OpenGLRaw >= 1.1,+ OpenGL >= 2.4,+ vector >= 0.7++ GHC-Options: -Odph -Wall+ HS-Source-Dirs: src+ +Source-repository this+ type: git+ location: http://github.com/acowley/GLUtil.git+ tag: 0.1.0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Anthony Cowley++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Anthony Cowley nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++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+OWNER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/TGA.hs view
@@ -0,0 +1,27 @@+-- Working with textures will require loading images from disk. We will+-- use the TGA format since it is quite simple to work with.+module TGA (readTGA) where+import Control.Applicative ((<$>))+import Control.Monad ((<=<))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.Binary.Get++-- |The header structure contains quite a bit of information, but we are+-- only concerned with whether the image is RGB color or grayscale, and+-- what its dimensions are.+readImage :: Get (Int, Int, BS.ByteString)+readImage = do skip 2+ isColor <- (==2) <$> getWord8+ skip 9+ width <- fromIntegral <$> getWord16le+ height <- fromIntegral <$> getWord16le+ _bpp <- fromIntegral <$> getWord8 :: Get Int+ skip 1+ let bytesPerPixel = if isColor then 3 else 1+ pixels <- getByteString (width*height*bytesPerPixel)+ return (width, height, pixels)++-- |Read a TGA image from a file.+readTGA :: FilePath -> IO (Int, Int, BS.ByteString)+readTGA = return . runGet readImage <=< BL.readFile
+ examples/example1.hs view
@@ -0,0 +1,111 @@+-- | A port of the code presented at [Modern OpenGL with+-- Haskell](http://www.arcadianvisions.com/blog/?p=224) to use the+-- GLFW-b package.+import Control.Applicative+import Control.Monad (when)+import Graphics.Rendering.OpenGL+import Graphics.UI.GLFW+import Foreign.Storable (sizeOf)+import System.FilePath ((</>))+import TGA -- Small library for TGA file handling+import Graphics.GLUtil++-- | A value to carry around a shader program and its parameters.+data Shaders = Shaders { program :: Program+ , fadeFactorU :: UniformLocation+ , texturesU :: [UniformLocation] + , positionA :: AttribLocation }++-- | The resources used for drawing our scene.+data Resources = Resources { vertexBuffer :: BufferObject+ , elementBuffer :: BufferObject+ , textures :: [TextureObject]+ , shaders :: Shaders+ , fadeFactor :: GLfloat }++-- | Geometry data is a list of four 2D vertices.+vertexBufferData :: [GLfloat]+vertexBufferData = [-1, -1, 1, -1, -1, 1, 1, 1]++-- | Load a texture and set some texturing parameters.+makeTexture :: FilePath -> IO TextureObject+makeTexture filename = + do (width,height,pixels) <- readTGA filename+ tex <- loadTexture $ texInfo width height TexBGR pixels+ textureFilter Texture2D $= ((Linear', Nothing), Linear')+ textureWrapMode Texture2D S $= (Mirrored, ClampToEdge)+ textureWrapMode Texture2D T $= (Mirrored, ClampToEdge)+ return tex++-- | Load and compile our GLSL program, and pull out the parameters we+-- want.+initShaders :: IO Shaders+initShaders = do vs <- loadShader $ "shaders" </> "hello-gl.vert"+ fs <- loadShader $ "shaders" </> "hello-gl.frag"+ p <- linkShaderProgram [vs] [fs]+ Shaders p+ <$> get (uniformLocation p "fade_factor")+ <*> mapM (get . uniformLocation p)+ ["textures[0]", "textures[1]"]+ <*> get (attribLocation p "position")++-- | Load our geometry and textures into OpenGL.+makeResources :: IO Resources+makeResources = Resources+ <$> makeBuffer ArrayBuffer vertexBufferData+ <*> makeBuffer ElementArrayBuffer [0..3::GLuint]+ <*> mapM (makeTexture . ("images" </>)) + ["hello1.tga", "hello2.tga"]+ <*> initShaders+ <*> pure 0.0++-- | Bind textures to GLSL samplers.+setupTexturing :: Resources -> IO ()+setupTexturing r = let [t1, t2] = textures r+ [tu1, tu2] = texturesU (shaders r)+ in do activeTexture $= TextureUnit 0+ textureBinding Texture2D $= Just t1+ uniform tu1 $= Index1 (0::GLint)+ activeTexture $= TextureUnit 1+ textureBinding Texture2D $= Just t2+ uniform tu2 $= Index1 (1::GLint)++-- | Bind the geometry array and element buffers.+setupGeometry :: Resources -> IO ()+setupGeometry r = let posn = positionA (shaders r)+ stride = fromIntegral $ sizeOf (undefined::GLfloat) * 2+ vad = VertexArrayDescriptor 2 Float stride offset0+ in do bindBuffer ArrayBuffer $= Just (vertexBuffer r)+ vertexAttribPointer posn $= (ToFloat, vad)+ vertexAttribArray posn $= Enabled+ bindBuffer ElementArrayBuffer $= Just (elementBuffer r)++-- | Set drawing parameters that won't change during execution.+drawInit :: Resources -> IO ()+drawInit r = do clearColor $= Color4 1 1 1 1+ clear [ColorBuffer]+ currentProgram $= Just (program (shaders r))+ setupTexturing r+ setupGeometry r++draw :: Resources -> IO ()+draw r = do uniform (fadeFactorU (shaders r)) $= Index1 (fadeFactor r)+ drawElements TriangleStrip 4 UnsignedInt offset0++animate :: Resources -> IO Resources+animate r = do seconds <- getTime+ let fade = sin seconds * 0.5 + 0.5+ return r { fadeFactor = realToFrac fade }++main :: IO ()+main = do _ <- initialize+ _ <- openWindow opts+ setWindowTitle "Chapter 2"+ makeResources >>= (>>) <$> drawInit <*> go+ where opts = defaultDisplayOptions { displayOptions_width = 500+ , displayOptions_height = 500+ , displayOptions_refreshRate = Just 100 }+ go r = do draw r+ swapBuffers+ pollEvents+ keyIsPressed KeyEsc >>= flip when (animate r >>= go) . not
+ examples/images/hello1.tga view
binary file changed (absent → 360044 bytes)
+ examples/images/hello2.tga view
binary file changed (absent → 360044 bytes)
+ examples/shaders/hello-gl.frag view
@@ -0,0 +1,14 @@+#version 110++uniform float fade_factor;+uniform sampler2D textures[2];+varying vec2 texcoord;++void main()+{++ gl_FragColor = mix(+ texture2D(textures[0], texcoord),+ texture2D(textures[1], texcoord),+ fade_factor);+}
+ examples/shaders/hello-gl.vert view
@@ -0,0 +1,10 @@+#version 110++attribute vec2 position;+varying vec2 texcoord;++void main()+{+ gl_Position = vec4(position, 0.0, 1.0);+ texcoord = position * vec2(0.5) + vec2(0.5);+}
+ src/Graphics/GLUtil.hs view
@@ -0,0 +1,13 @@+-- |The main import that simply re-exports the various modules that+-- make up the @GLUtil@ library.+module Graphics.GLUtil (module Graphics.GLUtil.BufferObjects,+ module Graphics.GLUtil.Shaders,+ module Graphics.GLUtil.Textures,+ module Graphics.GLUtil.GLError,+ module Graphics.GLUtil.VertexArrayObjects) where++import Graphics.GLUtil.BufferObjects+import Graphics.GLUtil.Shaders+import Graphics.GLUtil.Textures+import Graphics.GLUtil.GLError+import Graphics.GLUtil.VertexArrayObjects
+ src/Graphics/GLUtil/BufferObjects.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |Utilities for filling 'BufferObject's.+module Graphics.GLUtil.BufferObjects where+import Graphics.Rendering.OpenGL+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable+import Data.Array.Storable+import qualified Data.Vector.Storable as V+import Data.ByteString (ByteString, useAsCStringLen)++-- |Allocate and fill a 'BufferObject' from a list of 'Storable's.+makeBuffer :: Storable a => BufferTarget -> [a] -> IO BufferObject+makeBuffer target elems = makeBufferLen target (length elems) elems++-- |Allocate and fill a 'BufferObject' from a list of 'Storable's+-- whose length is explicitly given. This is useful when the list is+-- of known length, as it avoids a traversal to find the length.+makeBufferLen :: Storable a => BufferTarget -> Int -> [a] -> IO BufferObject+makeBufferLen target len elems = + do [buffer] <- genObjectNames 1+ bindBuffer target $= Just buffer+ let n = fromIntegral $ len * sizeOf (head elems)+ arr <- newListArray (0, len - 1) elems+ withStorableArray arr $ \ptr -> + bufferData target $= (n, ptr, StaticDraw)+ return buffer++-- |Allocate and fill a 'BufferObject' with the given number of bytes+-- from the supplied pointer.+fromPtr :: BufferTarget -> Int -> Ptr a -> IO BufferObject+fromPtr target numBytes ptr = + do [buffer] <- genObjectNames 1+ bindBuffer target $= Just buffer+ bufferData target $= (fromIntegral numBytes, ptr, StaticDraw)+ return buffer++-- |Fill a buffer with a 'ByteString'.+fromByteString :: BufferTarget -> ByteString -> IO BufferObject+fromByteString target b = useAsCStringLen b (uncurry . flip $ fromPtr target)++-- |Fill a buffer with data from a 'ForeignPtr'. The application+-- @fromForeignPtr target len fptr@ fills a @target@ 'BufferTarget'+-- with @len@ elements starting from @fptr@.+fromForeignPtr :: forall a. Storable a => + BufferTarget -> Int -> ForeignPtr a -> IO BufferObject+fromForeignPtr target len fptr = withForeignPtr fptr $ fromPtr target numBytes+ where numBytes = sizeOf (undefined::a) * len++-- |Fill a buffer with data from a 'V.Vector'.+fromVector :: forall a. Storable a => + BufferTarget -> V.Vector a -> IO BufferObject+fromVector target v = V.unsafeWith v $ fromPtr target numBytes+ where numBytes = fromIntegral $ V.length v * sizeOf (undefined::a)++-- |Produce a 'Ptr' value to be used as an offset of the given number+-- of bytes.+offsetPtr :: Int -> Ptr a+offsetPtr = wordPtrToPtr . fromIntegral++-- |A zero-offset 'Ptr'.+offset0 :: Ptr a+offset0 = offsetPtr 0
+ src/Graphics/GLUtil/GLError.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- |Miscellaneous utilities for dealing with OpenGL errors.+module Graphics.GLUtil.GLError (printError, printErrorMsg, throwError, + GLError, throwErrorMsg) where+import Control.Exception (Exception, throwIO)+import Control.Monad (when)+import Data.List (intercalate)+import Data.Typeable (Typeable)+import Graphics.Rendering.OpenGL+import System.IO (hPutStrLn, stderr)++-- |Check OpenGL error flags and print them on 'stderr'.+printError :: IO ()+printError = get errors >>= mapM_ (hPutStrLn stderr . ("GL: "++) . show)++-- |Check OpenGL error flags and print them on 'stderr' with the given+-- message as a prefix. If there are no errors, nothing is printed.+printErrorMsg :: String -> IO ()+printErrorMsg msg = do errs <- get errors+ when (not (null errs))+ (putStrLn msg >> mapM_ printErr errs)+ where printErr = hPutStrLn stderr . (" GL: "++) . show++-- |An exception type for OpenGL errors.+data GLError = GLError String deriving (Typeable)+instance Exception GLError where+instance Show GLError where+ show (GLError msg) = "GLError " ++ msg++-- |Prefix each of a list of messages with "GL: ".+printGLErrors :: Show a => [a] -> String+printGLErrors = intercalate "\n GL: " . ("" :) . map show++-- |Throw an exception if there is an OpenGL error.+throwError :: IO ()+throwError = do errs <- get errors+ when (not (null errs))+ (throwIO . GLError . tail $ printGLErrors errs)++-- |Throw an exception if there is an OpenGL error. The exception's+-- error message is prefixed with the supplied 'String'.+throwErrorMsg :: String -> IO ()+throwErrorMsg msg = do errs <- get errors+ when (not (null errs))+ (throwIO $ GLError (msg++printGLErrors errs))
+ src/Graphics/GLUtil/Shaders.hs view
@@ -0,0 +1,113 @@+-- |Utilities for working with fragment and vertex shader programs.+module Graphics.GLUtil.Shaders (loadShader, linkShaderProgram, namedUniform, + uniformScalar, uniformVec, uniformMat, + namedUniformMat, uniformGLMat4) where+import Control.Monad (unless)+import Graphics.Rendering.OpenGL+import Graphics.Rendering.OpenGL.Raw.Core31+import Graphics.GLUtil.GLError+import Foreign.Ptr (Ptr)+import Unsafe.Coerce (unsafeCoerce)++-- This module is based on the ogl2brick example in the GLUT package.++-- |Load a shader program from a file.+loadShader :: Shader s => FilePath -> IO s+loadShader filePath = do+ src <- readFile filePath+ [shader] <- genObjectNames 1+ shaderSource shader $= [src]+ compileShader shader+ printError+ ok <- get (compileStatus shader)+ infoLog <- get (shaderInfoLog shader)+ unless (null infoLog)+ (mapM_ putStrLn + ["Shader info log for '" ++ filePath ++ "':", infoLog, ""])+ unless ok $ do+ deleteObjectNames [shader]+ ioError (userError "shader compilation failed")+ return shader++-- |Link vertex and fragment shaders into a 'Program'.+linkShaderProgram :: [VertexShader] -> [FragmentShader] -> IO Program+linkShaderProgram vs fs = do+ [prog] <- genObjectNames 1+ attachedShaders prog $= (vs, fs)+ linkProgram prog+ printError+ ok <- get (linkStatus prog)+ infoLog <- get (programInfoLog prog)+ unless (null infoLog)+ (mapM_ putStrLn ["Program info log:", infoLog, ""])+ unless ok $ do+ deleteObjectNames [prog]+ ioError (userError "GLSL linking failed")+ return prog++-- |Work with a named uniform shader parameter. Note that this looks+-- up the variable name on each access, so uniform parameters that+-- will be accessed frequently should instead be resolved to a+-- 'UniformLocation'.+namedUniform :: (Uniform a) => String -> StateVar a+namedUniform name = makeStateVar (loc >>= get) (\x -> loc >>= ($= x))+ where loc = do Just p <- get currentProgram+ l <- get (uniformLocation p name)+ printError+ return $ uniform l++-- Allocate an OpenGL matrix from a nested list matrix, and pass a+-- pointer to that matrix to an 'IO' action.+withHMatrix :: [[GLfloat]] -> (Ptr GLfloat -> IO a) -> IO a+withHMatrix lstMat m = do+ mat <- newMatrix RowMajor (concat lstMat) :: IO (GLmatrix GLfloat)+ withMatrix mat (\_ -> m)++-- Not all raw uniform setters are wrapped by the OpenGL interface,+-- but the UniformLocation newtype is still helpful for type+-- discipline.+unUL :: UniformLocation -> GLint+unUL = unsafeCoerce++-- |Set a 'UniformLocation' to a scalar value.+uniformScalar :: UniformComponent a => UniformLocation -> SettableStateVar a+uniformScalar loc = makeSettableStateVar $ (uniform loc $=) . Index1++-- |Set a 'UniformLocation' from a list representation of a+-- low-dimensional vector of 'GLfloat's. Only 2, 3, and 4 dimensional+-- vectors are supported.+uniformVec :: UniformLocation -> SettableStateVar [GLfloat]+uniformVec loc = makeSettableStateVar aux+ where aux [x,y] = glUniform2f loc' x y+ aux [x,y,z] = glUniform3f loc' x y z+ aux [x,y,z,w] = glUniform4f loc' x y z w+ aux _ = ioError . userError $+ "Only 2, 3, and 4 dimensional vectors are supported"+ loc' = unUL loc++-- |Set a named uniform shader parameter from a nested list matrix+-- representation. Only 3x3 and 4x4 matrices are supported.+namedUniformMat :: String -> SettableStateVar [[GLfloat]]+namedUniformMat var = makeSettableStateVar (\m -> loc >>= ($= m) . uniformMat)+ where loc = do Just p <- get currentProgram+ location <- get (uniformLocation p var)+ printError+ return location++-- |Set a uniform shader location from a nested list matrix+-- representation. Only 3x3 and 4x4 matrices are supported.+uniformMat :: UniformLocation -> SettableStateVar [[GLfloat]]+uniformMat loc = makeSettableStateVar aux+ where aux mat = do withHMatrix mat $ \ptr ->+ case length mat of+ 4 -> glUniformMatrix4fv loc' 1 1 ptr+ 3 -> glUniformMatrix3fv loc' 1 1 ptr+ _ -> ioError . userError $ + "Only 3x3 and 4x4 matrices are supported"+ loc' = unUL loc++-- |Set a uniform shader location with a 4x4 'GLmatrix'.+uniformGLMat4 :: UniformLocation -> SettableStateVar (GLmatrix GLfloat)+uniformGLMat4 loc = makeSettableStateVar aux+ where aux m = withMatrix m $ \_ -> glUniformMatrix4fv loc' 1 1+ loc' = unUL loc
+ src/Graphics/GLUtil/Textures.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, + ScopedTypeVariables, TypeFamilies, FlexibleContexts #-}+-- |Utilities for loading texture data.+module Graphics.GLUtil.Textures where+import Graphics.Rendering.OpenGL+import qualified Graphics.Rendering.OpenGL.GL.VertexArrays as GL+import Data.Array.Storable (StorableArray, withStorableArray)+import Data.ByteString.Internal (ByteString, toForeignPtr)+import Data.Vector.Storable (Vector, unsafeWith)+import Data.Word (Word8, Word16)+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)+import Foreign.Ptr (Ptr, plusPtr, castPtr)+import Foreign.Marshal.Array (withArray)+import Foreign.Storable (Storable)++-- |Pixel format of image data.+data TexColor = TexMono | TexRGB | TexBGR++-- |A basic texture information record.+data TexInfo a = TexInfo { texWidth :: GLsizei+ , texHeight :: GLsizei+ , texColor :: TexColor+ , texData :: a }++-- |Helper for constructing a 'TexInfo' using Haskell 'Int's for image+-- dimensions.+texInfo :: Int -> Int -> TexColor -> a -> TexInfo a+texInfo w h = TexInfo (fromIntegral w) (fromIntegral h)++-- |Open mapping from Haskell types to OpenGL types.+class Storable a => HasGLType a where+ glType :: a -> DataType++instance HasGLType Int where glType _ = GL.Int+instance HasGLType Word8 where glType _ = GL.UnsignedByte+instance HasGLType Word16 where glType _ = GL.UnsignedShort+instance HasGLType Float where glType _ = GL.Float++-- |Class for containers of texture data.+class HasGLType (Elem a) => IsPixelData a where+ type Elem a+ withPixels :: a -> (Ptr (Elem a) -> IO c) -> IO c++instance HasGLType b => IsPixelData [b] where+ type Elem [b] = b+ withPixels = withArray++instance HasGLType b => IsPixelData (Ptr b) where+ type Elem (Ptr b) = b+ withPixels = flip ($)++instance HasGLType b => IsPixelData (ForeignPtr b) where+ type Elem (ForeignPtr b) = b+ withPixels = withForeignPtr++instance HasGLType b => IsPixelData (StorableArray i b) where+ type Elem (StorableArray i b) = b+ withPixels = withStorableArray++instance HasGLType b => IsPixelData (Vector b) where+ type Elem (Vector b) = b+ withPixels = unsafeWith++instance IsPixelData ByteString where+ type Elem ByteString = Word8+ withPixels b m = aux . toForeignPtr $ b+ where aux (fp,o,_) = withForeignPtr fp $ \p ->+ m (plusPtr p o)++-- |Wrapper whose 'IsPixelData' instance treats the pointer underlying+-- a 'ByteString' as an array of 'Word16's.+newtype ShortString = ShortString ByteString++instance IsPixelData ShortString where+ type Elem ShortString = Word16+ withPixels (ShortString b) m = aux. toForeignPtr $ b+ where aux (fp,o,_) = withForeignPtr fp $ \p ->+ m (plusPtr (castPtr p :: Ptr Word16) o)++-- |Create a new 2D texture with data from a 'TexInfo'.+loadTexture :: IsPixelData a => TexInfo a -> IO (TextureObject)+loadTexture tex = do [obj] <- genObjectNames 1+ reloadTexture obj tex+ return obj++-- |Replace a 2D texture's pixel data with data from a 'TexInfo'.+reloadTexture :: forall a. IsPixelData a => + TextureObject -> TexInfo a -> IO ()+reloadTexture obj tex = do textureBinding Texture2D $= Just obj+ loadTex $ texColor tex+ where loadTex TexMono = case pixelType of+ GL.UnsignedShort -> loadAux Luminance16 Luminance+ _ -> loadAux Luminance' Luminance+ loadTex TexRGB = loadAux RGBA' RGB+ loadTex TexBGR = loadAux RGBA' BGR+ sz = TextureSize2D (texWidth tex) (texHeight tex)+ pixelType = glType (undefined::Elem a)+ loadAux i e = withPixels (texData tex) $ + (texImage2D Nothing NoProxy 0 i sz 0 .+ PixelData e pixelType)
+ src/Graphics/GLUtil/VertexArrayObjects.hs view
@@ -0,0 +1,36 @@+-- | A thin layer over OpenGL 3.1+ vertex array objects.+module Graphics.GLUtil.VertexArrayObjects + (VertexArrayObject(..), VAO, makeVAO, deleteVAO, bindVertexArray) where+import Foreign.Marshal.Array (allocaArray)+import Foreign.Marshal.Utils (with)+import Foreign.Storable (peek)+import Graphics.Rendering.OpenGL.Raw.Core31++-- |A vertex array object captures OpenGL state needed for drawing a+-- vertex array. It encapsulates the binding of an array buffer and an+-- element buffer, as well as vertex attribute setup.+newtype VertexArrayObject = VertexArrayObject GLuint++-- |Short alias.+type VAO = VertexArrayObject++-- |Allocate a 'VertexArrayObject', and initialize it with the+-- provided action. This action should bind the buffer data, index+-- data (if necessary), and setup vertex attributes.+makeVAO :: IO () -> IO VertexArrayObject+makeVAO m = do vao <- allocaArray 1 $ \ptr -> + glGenVertexArrays 1 ptr >> peek ptr+ glBindVertexArray vao+ m+ glBindVertexArray 0+ return $ VertexArrayObject vao++-- |Delete a 'VertexArrayObject'. Do not use the VAO after running+-- this action!+deleteVAO :: VertexArrayObject -> IO ()+deleteVAO (VertexArrayObject i) = with i $ glDeleteVertexArrays 1++-- |Bind a 'VertexArrayObject', or ensure that no VAO is bound.+bindVertexArray :: Maybe VertexArrayObject -> IO ()+bindVertexArray (Just (VertexArrayObject i)) = glBindVertexArray i+bindVertexArray Nothing = glBindVertexArray 0