145 lines
4 KiB
Haskell
145 lines
4 KiB
Haskell
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Types.Graphics.IndexBuffer where
|
|
|
|
import Affection
|
|
|
|
import qualified Graphics.Rendering.OpenGL as GL
|
|
|
|
import SDL (($=))
|
|
|
|
import Data.String (fromString)
|
|
|
|
import qualified Data.Vector.Storable as VS
|
|
|
|
import Control.Monad (when)
|
|
import Control.Monad.Loops (whileM_)
|
|
|
|
import Control.Concurrent.STM
|
|
|
|
import Foreign
|
|
import Foreign.C.Types
|
|
|
|
-- internal imports
|
|
|
|
import Classes.Graphics.Bindable
|
|
import Classes.Graphics.Buffer
|
|
|
|
-- layout of the IndexBuffer data object
|
|
data IndexBuffer = IndexBuffer
|
|
{ iBufId :: TVar GL.BufferObject -- buffer id
|
|
, iBufSize :: TVar GL.GLsizeiptr -- size of data
|
|
-- , iBufData :: Ptr a -- pointer to data
|
|
, iBufCount :: TVar GL.GLint -- number of data elements
|
|
}
|
|
|
|
-- instanciate typeclass from Buffer and fill in missing implementations
|
|
instance Buffer IndexBuffer where
|
|
|
|
type StoreType IndexBuffer = GL.GLuint
|
|
|
|
type StoreContainer IndexBuffer = VS.Vector
|
|
|
|
target _ = GL.ElementArrayBuffer
|
|
|
|
glId = readTVarIO . iBufId
|
|
|
|
initialize buf = do
|
|
-- bind the buffer using the default iplementation of the typeclass
|
|
bind buf
|
|
size <- readTVarIO $ iBufSize buf
|
|
-- fill in the data
|
|
GL.bufferData (target buf) $=
|
|
( size
|
|
, nullPtr
|
|
, GL.DynamicDraw
|
|
)
|
|
-- release the buffer using the default implementation of the typeclass
|
|
unbind buf
|
|
|
|
write buf offset dat = do
|
|
currentBufSize <- readTVarIO (iBufSize buf)
|
|
whileM_
|
|
(pure $ (fromIntegral offset + VS.length dat) *
|
|
sizeOf (undefined :: StoreType IndexBuffer)
|
|
> fromIntegral currentBufSize) $ do
|
|
allocaArray
|
|
(fromIntegral currentBufSize `div`
|
|
sizeOf (undefined :: StoreType IndexBuffer))
|
|
$ \ (ptr :: Ptr (StoreType IndexBuffer)) -> do
|
|
bind buf
|
|
GL.bufferSubData
|
|
(target buf)
|
|
GL.ReadFromBuffer
|
|
0
|
|
currentBufSize
|
|
ptr
|
|
expand buf
|
|
bind buf
|
|
GL.bufferSubData
|
|
(target buf)
|
|
GL.WriteToBuffer
|
|
0
|
|
currentBufSize
|
|
ptr
|
|
-- bind buffer, just to be safe
|
|
bind buf
|
|
let elemCount = fromIntegral offset + VS.length dat
|
|
logIO Verbose ("elemCount: " <> (fromString $ show elemCount))
|
|
currentCount <- atomically $ readTVar (iBufCount buf)
|
|
when (fromIntegral elemCount > currentCount) $
|
|
atomically $ writeTVar (iBufCount buf) (fromIntegral elemCount)
|
|
VS.unsafeWith dat $ \ ptr ->
|
|
GL.bufferSubData
|
|
(target buf)
|
|
GL.WriteToBuffer
|
|
(CPtrdiff $ fromIntegral offset *
|
|
fromIntegral (sizeOf (undefined :: StoreType IndexBuffer)))
|
|
(CPtrdiff $ fromIntegral $
|
|
VS.length dat * sizeOf (undefined :: StoreType IndexBuffer))
|
|
ptr
|
|
|
|
expand buf = do
|
|
unbind buf
|
|
delete buf
|
|
newId <- GL.genObjectName
|
|
newSize <- (2 *) <$> readTVarIO (iBufSize buf)
|
|
atomically $ do
|
|
writeTVar (iBufId buf) newId
|
|
writeTVar (iBufSize buf) newSize
|
|
initialize buf
|
|
|
|
delete buf = do
|
|
unbind buf
|
|
GL.deleteObjectName =<< (readTVarIO $ iBufId buf)
|
|
|
|
|
|
instance Bindable IndexBuffer where
|
|
|
|
-- bind the buffer
|
|
bind buf =
|
|
(\ a -> GL.bindBuffer (target buf) $= Just a) =<< glId buf
|
|
|
|
-- unbind the buffer
|
|
unbind buf = GL.bindBuffer (target buf) $= Nothing
|
|
|
|
newIndexBuffer
|
|
:: Word
|
|
-> IO IndexBuffer -- newly built IndexBuffer data object
|
|
newIndexBuffer initLength = do
|
|
-- create the buffer object in applicative style
|
|
buf <- IndexBuffer
|
|
-- generate the ID
|
|
<$> (newTVarIO =<< GL.genObjectName)
|
|
-- compute buffer size
|
|
<*> newTVarIO (CPtrdiff (fromIntegral $
|
|
(fromIntegral initLength * sizeOf (undefined :: StoreType IndexBuffer))))
|
|
-- -- make pointer out of list
|
|
-- <*> newArray list
|
|
-- -- get count
|
|
<*> newTVarIO 0
|
|
-- fill the data in to the buffer
|
|
initialize buf
|
|
-- return the data object
|
|
return buf
|