pituicat/src/Graphics/Types/IndexBuffer.hs

149 lines
4.1 KiB
Haskell

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Graphics.Types.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 Graphics.Classes.Bindable
import Graphics.Classes.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
whileM_
(do
currentSize <- readTVarIO (iBufSize buf)
pure $ (fromIntegral offset + VS.length dat) *
sizeOf (undefined :: StoreType IndexBuffer)
> fromIntegral currentSize)
$ do
currentBufSize <- readTVarIO (iBufSize buf)
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