module Graphics.LambdaCube.RenderSystem.GL.VertexBuffer where
import Control.Monad
import Control.Applicative
import Data.IORef
import Data.Maybe
import Data.Ord
import Data.Word
import Foreign
import Graphics.Rendering.OpenGL.Raw.Core31
import Graphics.LambdaCube.HardwareBuffer
import Graphics.LambdaCube.HardwareVertexBuffer
import Graphics.LambdaCube.RenderSystem.GL.Utils
data GLVertexBuffer
= GLVertexBuffer
{ glvbNumVertices :: Int
, glvbVertexSize :: Int
, glvbUsage :: Usage
, glvbLockInfo :: IORef (Maybe (Int,Int,Bool))
, glvbShadowBuffer :: Maybe (Ptr Word8)
, glvbBufferObject :: GLuint
}
deriving Eq
instance Ord GLVertexBuffer where
compare = comparing glvbBufferObject
instance HardwareVertexBuffer GLVertexBuffer where
getVertexSize = glvbVertexSize
getNumVertices = glvbNumVertices
instance HardwareBuffer GLVertexBuffer where
getSizeInBytes b = glvbVertexSize b * glvbNumVertices b
isSystemMemory b = 0 == glvbBufferObject b
hasShadowBuffer b = (isJust $ glvbShadowBuffer b) && (glvbBufferObject b /= 0)
getUsage = glvbUsage
isLocked = glvbIsLocked
unlock = glvbUnlock
lock = glvbLock
glvbIsLocked :: GLVertexBuffer -> IO Bool
glvbIsLocked b = do
i <- readIORef $ glvbLockInfo b
return $ isJust i
glvbLock :: GLVertexBuffer -> Int -> Int -> LockOptions -> IO (Ptr Word8)
glvbLock a offs len opts = do
lockinfo <- readIORef (glvbLockInfo a)
when (isJust lockinfo) $ error "Cannot lock this buffer, it is already locked!"
writeIORef (glvbLockInfo a) $ Just (offs,len,opts /= HBL_READ_ONLY)
case glvbShadowBuffer a of
Just b -> do
return $ plusPtr b offs
Nothing -> do
glBindBuffer gl_ARRAY_BUFFER $ glvbBufferObject a
when (opts == HBL_DISCARD) $ glBufferData gl_ARRAY_BUFFER (fromIntegral $ getSizeInBytes a) nullPtr (getGLUsage $ getUsage a)
let isWriteOnly = case getUsage a of
HBU_WRITE_ONLY -> True
HBU_STATIC_WRITE_ONLY -> True
HBU_DYNAMIC_WRITE_ONLY -> True
HBU_DYNAMIC_WRITE_ONLY_DISCARDABLE -> True
_ -> False
access = case (isWriteOnly,opts == HBL_READ_ONLY) of
(False,False) -> gl_READ_WRITE
(False,True) -> gl_READ_ONLY
(True,_) -> gl_WRITE_ONLY
b <- glMapBuffer gl_ARRAY_BUFFER access
case b == nullPtr of
True -> error "Vertex Buffer: Out of memory"
False -> return $ plusPtr b offs
glvbUnlock :: GLVertexBuffer -> IO ()
glvbUnlock a = do
lockinfo <- readIORef (glvbLockInfo a)
let (lockStart,lockSize,reqUpdate) = case lockinfo of
Just li -> li
Nothing -> error "Cannot unlock this buffer, it is not locked!"
writeIORef (glvbLockInfo a) Nothing
case glvbShadowBuffer a of
Just b -> when reqUpdate $ do
glBindBuffer gl_ARRAY_BUFFER $ glvbBufferObject a
case lockStart == 0 && lockSize == getSizeInBytes a of
True -> glBufferData gl_ARRAY_BUFFER (fromIntegral lockSize) b (getGLUsage $ getUsage a)
False -> glBufferSubData gl_ARRAY_BUFFER (fromIntegral lockStart) (fromIntegral lockSize) b
Nothing -> do
glBindBuffer gl_ARRAY_BUFFER $ glvbBufferObject a
ok <- glUnmapBuffer gl_ARRAY_BUFFER
unless (ok /= (fromIntegral gl_FALSE)) $ error "Buffer data corrupted, please reload"
mkGLVertexBuffer :: Int -> Int -> Usage -> Bool -> IO GLVertexBuffer
mkGLVertexBuffer vertexSize numVerts usage useShadowBuffer = do
let bufferSize = numVerts * vertexSize
bufferObject <- alloca $ \buf -> glGenBuffers 1 buf >> peek buf
lockinfo <- newIORef Nothing
glBindBuffer gl_ARRAY_BUFFER bufferObject
glBufferData gl_ARRAY_BUFFER (fromIntegral bufferSize) nullPtr (getGLUsage usage)
shadowBuffer <- case useShadowBuffer of
True -> Just <$> mallocBytes bufferSize
False -> return Nothing
return $ GLVertexBuffer
{ glvbNumVertices = numVerts
, glvbVertexSize = vertexSize
, glvbUsage = usage
, glvbLockInfo = lockinfo
, glvbShadowBuffer = shadowBuffer
, glvbBufferObject = bufferObject
}
rmGLVertexBuffer :: GLVertexBuffer -> IO ()
rmGLVertexBuffer a = do
case glvbBufferObject a of
0 -> return ()
b -> with b $ \buf -> glDeleteBuffers 1 buf
case glvbShadowBuffer a of
Just b -> free b
Nothing -> return ()