diff --git a/GLUtil.cabal b/GLUtil.cabal new file mode 100644 --- /dev/null +++ b/GLUtil.cabal @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/examples/TGA.hs b/examples/TGA.hs new file mode 100644 --- /dev/null +++ b/examples/TGA.hs @@ -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 diff --git a/examples/example1.hs b/examples/example1.hs new file mode 100644 --- /dev/null +++ b/examples/example1.hs @@ -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 diff --git a/examples/images/hello1.tga b/examples/images/hello1.tga new file mode 100644 Binary files /dev/null and b/examples/images/hello1.tga differ diff --git a/examples/images/hello2.tga b/examples/images/hello2.tga new file mode 100644 Binary files /dev/null and b/examples/images/hello2.tga differ diff --git a/examples/shaders/hello-gl.frag b/examples/shaders/hello-gl.frag new file mode 100644 --- /dev/null +++ b/examples/shaders/hello-gl.frag @@ -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); +} diff --git a/examples/shaders/hello-gl.vert b/examples/shaders/hello-gl.vert new file mode 100644 --- /dev/null +++ b/examples/shaders/hello-gl.vert @@ -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); +} diff --git a/src/Graphics/GLUtil.hs b/src/Graphics/GLUtil.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/GLUtil.hs @@ -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 diff --git a/src/Graphics/GLUtil/BufferObjects.hs b/src/Graphics/GLUtil/BufferObjects.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/GLUtil/BufferObjects.hs @@ -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 diff --git a/src/Graphics/GLUtil/GLError.hs b/src/Graphics/GLUtil/GLError.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/GLUtil/GLError.hs @@ -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)) diff --git a/src/Graphics/GLUtil/Shaders.hs b/src/Graphics/GLUtil/Shaders.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/GLUtil/Shaders.hs @@ -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 diff --git a/src/Graphics/GLUtil/Textures.hs b/src/Graphics/GLUtil/Textures.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/GLUtil/Textures.hs @@ -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) diff --git a/src/Graphics/GLUtil/VertexArrayObjects.hs b/src/Graphics/GLUtil/VertexArrayObjects.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/GLUtil/VertexArrayObjects.hs @@ -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