{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} module Types.Graphics.VertexBuffer where import qualified Graphics.Rendering.OpenGL as GL import SDL (($=)) import Control.Monad.Loops (whileM_) import Control.Concurrent.STM import qualified Data.Vector.Storable as VS import Linear import Foreign import Foreign.C.Types import Foreign.Storable.Generic import GHC.Generics -- internal imports import Classes.Graphics.Bindable import Classes.Graphics.Buffer import Classes.Graphics.VertexLayout -- | layout of the VertexBuffer data object data VertexBuffer = VertexBuffer { vBufId :: TVar GL.BufferObject -- ^ buffer id , vBufSize :: TVar GL.GLsizeiptr -- ^ size of data -- , vBufData :: Ptr a -- pointer to data } data Vertex = Vertex { vertPosition :: V3 GL.GLfloat , vertColor :: V4 GL.GLfloat , vertTexCoord :: V2 GL.GLfloat , vertTexID :: GL.GLfloat } deriving (Generic, Show) -- | make vertices instances of 'Storable'. it's a kind of magic ^.^ instance GStorable Vertex instance GStorable (V2 GL.GLfloat) instance GStorable (V3 GL.GLfloat) instance GStorable (V4 GL.GLfloat) -- | Smart constructor for a new Vertex newVertex :: V3 GL.GLfloat -> V4 GL.GLfloat -> V2 GL.GLfloat -> GL.GLfloat -> Vertex newVertex pos color texcoord index = Vertex pos color texcoord index -- | Instanciate typeclass Buffer and fill in missing implementations instance Buffer VertexBuffer where type StoreType VertexBuffer = Vertex type StoreContainer VertexBuffer = VS.Vector target _ = GL.ArrayBuffer glId = readTVarIO . vBufId initialize buf = do -- bind the buffer using the default iplementation of the typeclass bind buf size <- readTVarIO (vBufSize 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 (vBufSize buf) pure $ (fromIntegral offset + VS.length dat) * sizeOf (undefined :: StoreType VertexBuffer) > fromIntegral currentSize) $ do currentBufSize <- readTVarIO (vBufSize buf) allocaArray (fromIntegral currentBufSize `div` sizeOf (undefined :: StoreType VertexBuffer)) $ \ (ptr :: Ptr (StoreType VertexBuffer)) -> 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 VS.unsafeWith dat $ \ ptr -> GL.bufferSubData (target buf) -- target buffer type GL.WriteToBuffer -- data access direction (CPtrdiff $ fromIntegral offset * fromIntegral (sizeOf (undefined :: StoreType VertexBuffer))) -- offset from buffer start (CPtrdiff $ fromIntegral $ VS.length dat * sizeOf (undefined :: StoreType VertexBuffer)) -- length of data to write ptr -- pointer to first data object --le | expand the buffer to double of it's previous size. -- This discards all previously written data and layouts, as internally the -- old buffer is discarded and a new buffer allocated. expand buf = do -- unbind the buffer before meddling with its innards unbind buf -- free the old buffer delete buf -- generate new buffer newId <- GL.genObjectName -- calculate new size newSize <- (2 *) <$> readTVarIO (vBufSize buf) -- update data object atomically $ do writeTVar (vBufId buf) newId writeTVar (vBufSize buf) newSize -- allocate and fill buffer with null data initialize buf delete buf = do unbind buf GL.deleteObjectName =<< (readTVarIO $ vBufId buf) -- | Instanciate Bindable typeclass required by Buffer typeclass implement it instance Bindable VertexBuffer 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 -- | smart constructor for a VertexBuffer data object newVertexBuffer :: Word -- ^ initial Buffer size -> IO VertexBuffer -- ^ newly built VertexBuffer data object newVertexBuffer initSize = do -- let dummyVertex = newVertex (V3 0 0 0) (V4 0 0 0 0) (V2 0 0) 0 -- create the buffer object in applicative style buf <- VertexBuffer -- generate the ID <$> (newTVarIO =<< GL.genObjectName) -- compute buffer size <*> (newTVarIO (CPtrdiff (fromIntegral $ (fromIntegral initSize * sizeOf (undefined :: StoreType VertexBuffer))))) -- make pointer out of list -- <*> newArray list -- fill the data in to the buffer initialize buf -- return the data object return buf instance VertexLayout Vertex where type VertBuffer Vertex = VertexBuffer layoutElements _ = foldl (\acc (index, count) -> ( index , GL.VertexArrayDescriptor count GL.Float (fromIntegral $ sizeOf (undefined :: Vertex)) (nullPtr `plusPtr` (sizeOf (undefined :: GL.GLfloat) * fromIntegral (sum (map ((\(GL.VertexArrayDescriptor c _ _ _) -> c) . snd) acc)))) ) : acc ) [] (zip [0 ..] [3, 4, 2, 1]) addBuffer vert vb = do -- bind vertex buffer to associate them bind vb -- enable and fill vertex attrib pointer(s) let list = layoutElements vert mapM_ (\(index, descriptor) -> do GL.vertexAttribArray (GL.AttribLocation index) $= GL.Enabled GL.vertexAttribPointer (GL.AttribLocation index) $= ( GL.ToNormalizedFloat , descriptor ) ) list unbind vb