pituicat/src/Graphics/Types/IndexBuffer.hs

149 lines
4.1 KiB
Haskell
Raw Normal View History

2020-10-17 14:18:42 +00:00
{-# LANGUAGE TypeFamilies #-}
2020-12-06 07:14:50 +00:00
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Graphics.Types.IndexBuffer where
2020-10-17 14:18:42 +00:00
2020-12-06 07:14:50 +00:00
import Affection
2020-10-17 14:18:42 +00:00
import qualified Graphics.Rendering.OpenGL as GL
2020-12-06 07:14:50 +00:00
import SDL (($=))
import Data.String (fromString)
2020-10-17 14:18:42 +00:00
2020-12-05 09:10:37 +00:00
import qualified Data.Vector.Storable as VS
2020-12-06 07:14:50 +00:00
import Control.Monad (when)
2020-12-05 09:10:37 +00:00
import Control.Monad.Loops (whileM_)
2020-12-06 07:14:50 +00:00
import Control.Concurrent.STM
2020-12-05 09:10:37 +00:00
2020-10-17 14:18:42 +00:00
import Foreign
2020-12-06 07:14:50 +00:00
import Foreign.C.Types
2020-10-17 14:18:42 +00:00
-- internal imports
import Graphics.Classes.Bindable
import Graphics.Classes.Buffer
2020-10-17 14:18:42 +00:00
-- layout of the IndexBuffer data object
2020-12-05 09:10:37 +00:00
data IndexBuffer = IndexBuffer
{ iBufId :: TVar GL.BufferObject -- buffer id
, iBufSize :: TVar GL.GLsizeiptr -- size of data
-- , iBufData :: Ptr a -- pointer to data
2020-12-06 07:14:50 +00:00
, iBufCount :: TVar GL.GLint -- number of data elements
2020-10-17 14:18:42 +00:00
}
2020-12-05 09:10:37 +00:00
-- instanciate typeclass from Buffer and fill in missing implementations
instance Buffer IndexBuffer where
2020-10-17 14:18:42 +00:00
2020-12-05 09:10:37 +00:00
type StoreType IndexBuffer = GL.GLuint
type StoreContainer IndexBuffer = VS.Vector
2020-10-17 14:18:42 +00:00
target _ = GL.ElementArrayBuffer
2020-12-05 09:10:37 +00:00
glId = readTVarIO . iBufId
2020-10-17 14:18:42 +00:00
initialize buf = do
-- bind the buffer using the default iplementation of the typeclass
bind buf
2020-12-06 07:14:50 +00:00
size <- readTVarIO $ iBufSize buf
2020-10-17 14:18:42 +00:00
-- fill in the data
GL.bufferData (target buf) $=
2020-12-06 07:14:50 +00:00
( size
2020-12-05 09:10:37 +00:00
, nullPtr
2020-10-17 14:18:42 +00:00
, GL.DynamicDraw
)
-- release the buffer using the default implementation of the typeclass
unbind buf
2020-12-05 09:10:37 +00:00
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
2020-12-05 09:10:37 +00:00
-- bind buffer, just to be safe
bind buf
2020-12-06 07:14:50 +00:00
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 ->
2020-12-05 09:10:37 +00:00
GL.bufferSubData
(target buf)
GL.WriteToBuffer
(CPtrdiff $ fromIntegral offset *
2020-12-06 07:14:50 +00:00
fromIntegral (sizeOf (undefined :: StoreType IndexBuffer)))
2020-12-05 09:10:37 +00:00
(CPtrdiff $ fromIntegral $
VS.length dat * sizeOf (undefined :: StoreType IndexBuffer))
2020-12-05 09:10:37 +00:00
ptr
expand buf = do
unbind buf
delete buf
newId <- GL.genObjectName
newSize <- (2 *) <$> readTVarIO (iBufSize buf)
atomically $ do
2020-12-06 07:14:50 +00:00
writeTVar (iBufId buf) newId
writeTVar (iBufSize buf) newSize
2020-12-05 09:10:37 +00:00
initialize buf
delete buf = do
unbind buf
2020-12-06 07:14:50 +00:00
GL.deleteObjectName =<< (readTVarIO $ iBufId buf)
2020-12-05 09:10:37 +00:00
2020-12-06 07:14:50 +00:00
instance Bindable IndexBuffer where
2020-10-17 14:18:42 +00:00
-- bind the buffer
2020-12-06 07:14:50 +00:00
bind buf =
(\ a -> GL.bindBuffer (target buf) $= Just a) =<< glId buf
2020-10-17 14:18:42 +00:00
-- unbind the buffer
unbind buf = GL.bindBuffer (target buf) $= Nothing
2020-12-05 09:10:37 +00:00
newIndexBuffer
:: Word
-> IO IndexBuffer -- newly built IndexBuffer data object
newIndexBuffer initLength = do
2020-10-17 14:18:42 +00:00
-- create the buffer object in applicative style
buf <- IndexBuffer
-- generate the ID
2020-12-06 07:14:50 +00:00
<$> (newTVarIO =<< GL.genObjectName)
2020-10-17 14:18:42 +00:00
-- compute buffer size
2020-12-06 07:14:50 +00:00
<*> newTVarIO (CPtrdiff (fromIntegral $
(fromIntegral initLength * sizeOf (undefined :: StoreType IndexBuffer))))
2020-12-05 09:10:37 +00:00
-- -- make pointer out of list
-- <*> newArray list
-- -- get count
2020-12-06 07:14:50 +00:00
<*> newTVarIO 0
2020-10-17 14:18:42 +00:00
-- fill the data in to the buffer
initialize buf
-- return the data object
return buf