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
m
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
reportErrors
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
reportErrors
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
reportErrors
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
paint)
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
m
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)
