art with code


Haskell OpenGL utilities

In order to get back into the gear for writing this Haskell OpenGL application, I'll write here a small library of OpenGL utilities for roughly OpenGL 3.0 -style code. That is, no fixed-function stuff, each drawable is a struct with a shader program, streams (a.k.a. attributes), textures and uniforms.

Maybe something like the following (only works on Haskell OpenGL 2.2.3 and above.)
The code for Models and Shaders compiles but I haven't tested it. The snippets for loading textures and VBOs [see below] are working code.

First some matrix helpers (this is a snippet from a ~100-line matrix math lib):

module Matrix where
import Data.List
import Graphics.Rendering.OpenGL
import Foreign.Ptr

type Matrix4x4 = [Vec4]
type Vec4 = [GLfloat]

glMatrix :: Matrix4x4 -> IO (GLmatrix GLfloat)
glMatrix m = newMatrix ColumnMajor $ flatten m :: IO (GLmatrix GLfloat)

withMatrix4x4 :: Matrix4x4 -> (MatrixOrder -> Ptr GLfloat -> IO a) -> IO a
withMatrix4x4 matrix m = do
mat <- glMatrix matrix
withMatrix mat m

flatten :: [[a]] -> [a]
flatten = foldl1 (++)

Then the drawable definition. Drawables are structs with a program, uniforms, streams and samplers. You could think of them as curried GPU function calls, kinda like Drawable = GPU ().

module Models where
import Graphics.Rendering.OpenGL
import VBO
import Texture
import Foreign.Ptr (Ptr, castPtr)
import Matrix
import Data.Int

data Vbo a = Vbo (NumArrayIndices, BufferObject, (IntegerHandling, VertexArrayDescriptor a))
data Stream a = Stream (AttribLocation, Vbo a)
data Sampler = Sampler (UniformLocation, TextureTarget, TextureObject)

data UniformSetting = UniformSetting (UniformLocation, UniformValue)
data UniformValue =
UniformMatrix4 (Matrix4x4)
| UniformVertex4 (Vertex4 GLfloat)
| UniformVertex3 (Vertex3 GLfloat)
| UniformVertex2 (Vertex2 GLfloat)
| UniformFloat (TexCoord1 GLfloat)
| UniformInt (TexCoord1 GLint)

data Drawable = Drawable {
program :: Program,
uniforms :: [UniformSetting],
streamMode :: PrimitiveMode,
streams :: [Stream GLfloat],
indices :: Maybe (Vbo GLushort),
samplers :: [Sampler]

uniformSetting :: UniformSetting -> IO ()
uniformSetting (UniformSetting(location, UniformMatrix4 value)) =
withMatrix4x4 value (\order ptr -> uniformv location 16 (castPtr ptr :: Ptr (TexCoord1 GLfloat)))
uniformSetting (UniformSetting(location, UniformVertex4 value)) = uniform location $= value
uniformSetting (UniformSetting(location, UniformVertex3 value)) = uniform location $= value
uniformSetting (UniformSetting(location, UniformVertex2 value)) = uniform location $= value
uniformSetting (UniformSetting(location, UniformFloat value)) = uniform location $= value
uniformSetting (UniformSetting(location, UniformInt value)) = uniform location $= value

drawDrawable :: Drawable -> IO ()
drawDrawable d = do
currentProgram $= Just (program d)
setUniforms (uniforms d)
setSamplers (samplers d)
withStreams (streams d) (do
case indices d of
Just (Vbo (num, vbo, (_,VertexArrayDescriptor numcomp datatype stride ptr))) -> do
bindBuffer ElementArrayBuffer $= Just vbo
drawElements (streamMode d) num datatype ptr
bindBuffer ElementArrayBuffer $= Nothing
Nothing -> drawArrays (streamMode d) 0 (minNum (streams d)))
currentProgram $= Nothing
where minNum streams = minimum $ map (\(Stream (_,Vbo(n,_,_))) -> n) streams

withStreams :: [Stream a] -> IO () -> IO ()
withStreams streams m = do
setStreams streams
disableStreams streams

setStreams :: [Stream a] -> IO ()
setStreams streams =
mapM_ (\(Stream (location, Vbo (_, vbo, value))) -> do
bindBuffer ArrayBuffer $= Just vbo
vertexAttribArray location $= Enabled
vertexAttribPointer location $= value) streams

disableStreams :: [Stream a] -> IO ()
disableStreams streams =
mapM_ (\(Stream (location,_)) -> vertexAttribArray location $= Disabled) streams

setUniforms :: [UniformSetting] -> IO ()
setUniforms uniforms = mapM_ uniformSetting uniforms

setSamplers :: [Sampler] -> IO ()
setSamplers samplers =
mapM_ (\(i, Sampler (location, texType, tex)) -> do
activeTexture $= TextureUnit i
textureBinding texType $= Just tex
uniform location $= TexCoord1 i) $ zip [0..] samplers

Then we also need loaders for shaders, textures and buffers. Shaders are pretty easy, this loader's copied from the OpenGL binding examples:

module Shaders where
import Control.Monad
import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT

loadProgram :: FilePath -> FilePath -> IO Program
loadProgram vertexShader fragmentShader =
loadProgramMulti [vertexShader] [fragmentShader]

loadProgramMulti :: [FilePath] -> [FilePath] -> IO Program
loadProgramMulti vertexShaders fragmentShaders = do
vs <- mapM readAndCompileShader vertexShaders
fs <- mapM readAndCompileShader fragmentShaders
createProgram vs fs

-- Make sure that GLSL is supported by the driver, either directly by the core
-- or via an extension.
checkGLSLSupport :: IO ()
checkGLSLSupport = do
version <- get (majorMinor glVersion)
unless (version >= (2,0)) $ do
extensions <- get glExtensions
unless ("GL_ARB_shading_language_100" `elem` extensions) $
ioError (userError "No GLSL support found.")

readAndCompileShader :: Shader s => FilePath -> IO s
readAndCompileShader filePath = do
src <- readFile filePath
[shader] <- genObjectNames 1
shaderSource shader $= [src]
compileShader shader
ok <- get (compileStatus shader)
infoLog <- get (shaderInfoLog shader)
mapM_ putStrLn ["Shader info log for '" ++ filePath ++ "':", infoLog, ""]
unless ok $ do
deleteObjectNames [shader]
ioError (userError "shader compilation failed")
return shader

createProgram :: [VertexShader] -> [FragmentShader] -> IO Program
createProgram vs fs = do
[program] <- genObjectNames 1
attachedShaders program $= (vs, fs)
linkProgram program
ok <- get (linkStatus program)
infoLog <- get (programInfoLog program)
mapM_ putStrLn ["Program info log:", infoLog, ""]
unless ok $ do
deleteObjectNames [program]
ioError (userError "linking failed")
return program

Buffers aren't much of a problem either:

module VBO where
import Foreign.Storable
import Data.Array.Storable
import Foreign.Ptr
import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT

createVBO :: Storable a => [a] -> IO BufferObject
createVBO elems = do
[vbo] <- genObjectNames 1
bindBuffer ArrayBuffer $= Just vbo
arr <- newListArray (0, length elems - 1) elems -- Data.Array.MArray
withStorableArray arr (\ptr -> -- Data.Array.Storable
bufferData ArrayBuffer $= (ptrsize elems, ptr, StaticDraw))
bindBuffer ArrayBuffer $= Nothing
return vbo
where ptrsize [] = toEnum 0
ptrsize x:xs = toEnum $ length elems * (sizeOf x)

offset x = plusPtr nullPtr x
-- for use with e.g. VertexArrayDescriptor 3 Float 0 $ offset 0

For textures I'm using Cairo and Gdk.Pixbuf. Turning Cairo surfaces into Ptrs edible by texImage2D is a bit of a bother but eh.

module Texture where
import Data.ByteString (ByteString)
import Data.ByteString.Internal (toForeignPtr)
import Directory (doesFileExist)
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Ptr
import Graphics.Rendering.OpenGL
import Graphics.Rendering.Cairo hiding (rotate, identityMatrix)
import Graphics.UI.Gtk.Gdk.Pixbuf
import Graphics.UI.Gtk.Cairo

loadTextureFromFile :: FilePath -> IO TextureObject
loadTextureFromFile filepath = do
assertFile filepath
createTexture Texture2D Enabled
(withImageSurfaceFromPixbuf filepath $ texImage2DSurface Nothing 0)

withImageSurfaceFromPixbuf :: FilePath -> (Surface -> IO a) -> IO a
withImageSurfaceFromPixbuf filepath m = do
pixbuf <- pixbufNewFromFile filepath
w <- pixbufGetWidth pixbuf
h <- pixbufGetHeight pixbuf
withImageSurface FormatARGB32 w h (\s -> do
renderWith s (do setSourcePixbuf pixbuf 0 0
setOperator OperatorSource
m s)

assertFile :: FilePath -> IO ()
assertFile filepath = do
fex <- doesFileExist filepath
if not fex
then fail (filepath ++ " does not exist")
else return ()

createTexture :: TextureTarget -> Capability -> IO () -> IO TextureObject
createTexture target mipmap m = do
[tex] <- genObjectNames 1
textureBinding target $= Just tex
texture target $= Enabled
textureFilter target $= ((Linear', Nothing), Linear')
textureWrapMode target S $= (Repeated, Clamp)
textureWrapMode target T $= (Repeated, Clamp)
generateMipmap target $= mipmap
if mipmap == Enabled
then textureFilter target $= ((Linear', Just Linear'), Linear')
else return ()
textureBinding target $= Nothing
return tex

texImage2DSurface :: Maybe CubeMapTarget -> Level -> Surface -> IO ()
texImage2DSurface cubemap level imageSurface = do
pixelData <- imageSurfaceGetData imageSurface
(w,h) <- renderWith imageSurface $ do
w <- imageSurfaceGetWidth imageSurface
h <- imageSurfaceGetHeight imageSurface
return (fromIntegral w :: GLsizei, fromIntegral h :: GLsizei)
texImage2DByteString cubemap level RGBA8 w h BGRA UnsignedByte pixelData

texImage2DByteString :: Maybe CubeMapTarget
-> Level
-> PixelInternalFormat
-> GLsizei
-> GLsizei
-> PixelFormat
-> DataType
-> ByteString
-> IO ()
texImage2DByteString cubemap level iformat w h format ptype bytestring = do
let (fptr, foffset, flength) = toForeignPtr bytestring
if (fromIntegral flength) /= w * h * 4
then fail "imageSurface dimensions don't match data length"
else return ()
withForeignPtr fptr $ \ptr -> do
let optr = plusPtr ptr foffset
texImage2D cubemap NoProxy
level iformat (TextureSize2D w h) 0
(PixelData format ptype optr)
Post a Comment

About Me

My photo

Built art installations, web sites, graphics libraries, web browsers, mobile apps, desktop apps, media player themes, many nutty prototypes, much bad code, much bad art.

Have freelanced for Verizon, Google, Mozilla, Warner Bros, Sony Pictures, Yahoo!, Microsoft, Valve Software, TDK Electronics.

Ex-Chrome Developer Relations.