lambdacube-engine-0.1.1: Graphics/LambdaCube/RenderSystem/GL/GLVertexBuffer.hs

module Graphics.LambdaCube.RenderSystem.GL.GLVertexBuffer where

import Data.Word
import Data.Maybe
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Foreign.Storable
import Foreign.C.Types
import Foreign.Ptr
import Data.IORef
import Control.Monad

import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.Rendering.OpenGL as GL

import Graphics.LambdaCube.RenderSystem
import Graphics.LambdaCube.HardwareBuffer
import Graphics.LambdaCube.HardwareVertexBuffer
import Graphics.LambdaCube.RenderSystem.GL.GLUtils

-- | Specialisation of HardwareVertexBuffer for GL
data GLVertexBuffer
    = GLVertexBuffer
    { glvbNumVertices      :: Int
    , glvbVertexSize       :: Int
            
    , glvbUsage            :: Usage
    , glvbLockInfo         :: IORef (Maybe (Int,Int,Bool)) -- LockStart LockSize RequireUpdate
    
    , glvbShadowBuffer     :: Maybe (Ptr Word8)
    , glvbBufferObject     :: Maybe GL.BufferObject
    }
    deriving Eq

instance HardwareVertexBuffer GLVertexBuffer where
    getVertexSize   = glvbVertexSize
    getNumVertices  = glvbNumVertices

instance HardwareBuffer GLVertexBuffer where
    getSizeInBytes b    = glvbVertexSize b * glvbNumVertices b
    isSystemMemory      = isNothing . glvbBufferObject
    hasShadowBuffer b   = (isJust $ glvbShadowBuffer b) && (isJust $ glvbBufferObject b)
    getUsage            = glvbUsage
    isLocked            = glvbIsLocked
    unlock              = glvbUnlock
    lock                = glvbLock

glvbIsLocked b = do
    i <- readIORef $ glvbLockInfo b
    return $ isJust i

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    -> return $ plusPtr b offs
        ; Nothing   -> do
            GL.bindBuffer GL.ArrayBuffer $= (glvbBufferObject a)
            -- Discard if required
            when (opts == HBL_DISCARD) $ GL.bufferData GL.ArrayBuffer $= (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.ReadWrite
                    ; (False,True)  -> GL.ReadOnly
                    ; (True,_)      -> GL.WriteOnly
                    }
            mb <- GL.mapBuffer GL.ArrayBuffer access
            case mb of
                { Just b    -> return $ plusPtr b offs
                ; Nothing   -> error "Vertex Buffer: Out of memory"
                }
        }

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 -- If we used the shadow buffer this time...
            GL.bindBuffer GL.ArrayBuffer $= (glvbBufferObject a)
            case lockStart == 0 && lockSize == getSizeInBytes a of
                { True  -> GL.bufferData GL.ArrayBuffer $= (fromIntegral lockSize, b, getGLUsage $ getUsage a)
                ; False -> GL.bufferSubData GL.ArrayBuffer GL.WriteToBuffer (fromIntegral lockStart) (fromIntegral lockSize) b
                }
        ; Nothing   -> do
            GL.bindBuffer GL.ArrayBuffer $= (glvbBufferObject a)
            ok <- GL.unmapBuffer GL.ArrayBuffer
            unless ok $ error "Buffer data corrupted, please reload"
        }
        
--mkGLVertexBuffer :: RenderSystem rs => rs -> Int -> Int -> Usage -> Bool -> IO GLVertexBuffer
mkGLVertexBuffer rs vertexSize numVerts usage useShadowBuffer = do
    lockinfo <- newIORef Nothing
    [bufferObject] <- GL.genObjectNames 1
    GL.bindBuffer GL.ArrayBuffer $= Just bufferObject
    GL.bufferData GL.ArrayBuffer $= (fromIntegral $ numVerts * vertexSize, nullPtr, getGLUsage usage)
    shadowBuffer <- case useShadowBuffer of
        { True  -> do
            b <- mallocBytes $ numVerts * vertexSize
            return $ Just b
        ; False -> return Nothing
        }
    return $ GLVertexBuffer
        { glvbNumVertices      = numVerts
        , glvbVertexSize       = vertexSize
                
        , glvbUsage            = usage
        , glvbLockInfo         = lockinfo

        , glvbShadowBuffer     = shadowBuffer
        , glvbBufferObject     = Just bufferObject
        }

rmGLVertexBuffer :: GLVertexBuffer -> IO ()
rmGLVertexBuffer a = do
    case glvbBufferObject a of
        { Just b    -> GL.deleteObjectNames [b]
        ; Nothing   -> return ()
        }
    case glvbShadowBuffer a of
        { Just b    -> free b
        ; Nothing   -> return ()
        }