GLIndexBuffer.hs

module Graphics.LambdaCube.RenderSystem.GL.GLIndexBuffer 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.HardwareIndexBuffer
import Graphics.LambdaCube.RenderSystem.GL.GLUtils


-- | Specialisation of HardwareIndexBuffer for GL
data GLIndexBuffer
    = GLIndexBuffer
    { glibType         :: IndexType
    , glibNumIndexes   :: Int
           
    , glibUsage        :: Usage
    , glibLockInfo     :: IORef (Maybe (Int,Int,Bool)) -- LockStart LockSize RequireUpdate

    , glibShadowBuffer :: Maybe (Ptr Word8)
    , glibBufferObject :: Maybe GL.BufferObject
    }
    deriving Eq
    
instance HardwareIndexBuffer GLIndexBuffer where
    getIndexType    = glibType
    getNumIndexes   = glibNumIndexes
    getIndexSize b  = case getIndexType b of
        { IT_16BIT -> 2
        ; IT_32BIT -> 4
        }

instance HardwareBuffer GLIndexBuffer where
    getSizeInBytes b    = getIndexSize b * glibNumIndexes b
    isSystemMemory      = isNothing . glibBufferObject
    hasShadowBuffer b   = (isJust $ glibShadowBuffer b) && (isJust $ glibBufferObject b)
    getUsage            = glibUsage
    isLocked            = glibIsLocked
    unlock              = glibUnlock
    lock                = glibLock

glibIsLocked b = do
    i <- readIORef $ glibLockInfo b
    return $ isJust i

glibLock a offs len opts = do
    lockinfo <- readIORef (glibLockInfo a)
    when (isJust lockinfo) $ error "Cannot lock this buffer, it is already locked!"
    writeIORef (glibLockInfo a) $ Just (offs,len,opts /= HBL_READ_ONLY)
    case glibShadowBuffer a of
        { Just b    -> return $ plusPtr b offs
        ; Nothing   -> do
            GL.bindBuffer GL.ElementArrayBuffer $= (glibBufferObject a)
            -- Discard if required
            when (opts == HBL_DISCARD) $ GL.bufferData GL.ElementArrayBuffer $= (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.ElementArrayBuffer access
            case mb of
                { Just b    -> return $ plusPtr b offs
                ; Nothing   -> error "Index Buffer: Out of memory"
                }
        }

glibUnlock a = do
    lockinfo <- readIORef (glibLockInfo a)
    let (lockStart,lockSize,reqUpdate) = case lockinfo of
            { Just li   -> li
            ; Nothing   -> error "Cannot unlock this buffer, it is not locked!"
            }
    writeIORef (glibLockInfo a) Nothing
    case glibShadowBuffer a of
        { Just b    -> when reqUpdate $ do -- If we used the shadow buffer this time...
            GL.bindBuffer GL.ElementArrayBuffer $= (glibBufferObject a)
            case lockStart == 0 && lockSize == getSizeInBytes a of
                { True  -> GL.bufferData GL.ElementArrayBuffer $= (fromIntegral lockSize, b, getGLUsage $ getUsage a)
                ; False -> GL.bufferSubData GL.ElementArrayBuffer GL.WriteToBuffer (fromIntegral lockStart) (fromIntegral lockSize) b
                }
        ; Nothing   -> do
            GL.bindBuffer GL.ElementArrayBuffer $= (glibBufferObject a)
            ok <- GL.unmapBuffer GL.ElementArrayBuffer
            unless ok $ error "Buffer data corrupted, please reload"
        }

--mkGLIndexBuffer :: RenderSystem rs vb _ _ => rs -> IndexType -> Int -> Usage -> Bool -> IO GLIndexBuffer
mkGLIndexBuffer rs itype numIndexes usage useShadowBuffer = do
    let isize = case itype of
        { IT_16BIT -> 2
        ; IT_32BIT -> 4
        }
    lockinfo <- newIORef Nothing
    [bufferObject] <- GL.genObjectNames 1
    GL.bindBuffer GL.ElementArrayBuffer $= Just bufferObject
    GL.bufferData GL.ElementArrayBuffer $= (fromIntegral $ numIndexes * isize, nullPtr, getGLUsage usage)
    shadowBuffer <- case useShadowBuffer of
        { True  -> do
            b <- mallocBytes $ numIndexes * isize
            return $ Just b
        ; False -> return Nothing
        }
    return $ GLIndexBuffer
        { glibType         = itype
        , glibNumIndexes   = numIndexes
                
        , glibUsage        = usage
        , glibLockInfo     = lockinfo

        , glibShadowBuffer = shadowBuffer
        , glibBufferObject = Just bufferObject
        }

rmGLIndexBuffer :: GLIndexBuffer -> IO ()
rmGLIndexBuffer a = do
    case glibBufferObject a of
        { Just b    -> GL.deleteObjectNames [b]
        ; Nothing   -> return ()
        }
    case glibShadowBuffer a of
        { Just b    -> free b
        ; Nothing   -> return ()
        }