223 lines
6 KiB
Haskell
223 lines
6 KiB
Haskell
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
module Types.Graphics.VertexBuffer where
|
|
|
|
import qualified Graphics.Rendering.OpenGL as GL
|
|
|
|
import SDL (($=), get)
|
|
|
|
import Control.Monad.Loops (whileM_)
|
|
|
|
import Control.Concurrent.STM
|
|
|
|
import qualified Data.Vector.Storable as VS
|
|
|
|
import Linear
|
|
|
|
import Foreign
|
|
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)
|
|
|
|
-- | 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 a@(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
|