lots of plumbing to automate stuff
This commit is contained in:
parent
de5e692305
commit
0fb10b0981
8 changed files with 203 additions and 132 deletions
|
|
@ -31,6 +31,7 @@ executable pituicat
|
|||
, Classes.Graphics
|
||||
, Classes.Graphics.Bindable
|
||||
, Classes.Graphics.Buffer
|
||||
, Classes.Graphics.VertexLayout
|
||||
, State.Loading
|
||||
, State.Loading.Load
|
||||
, State.Loading.Update
|
||||
|
|
@ -59,5 +60,6 @@ executable pituicat
|
|||
, JuicyPixels-extra
|
||||
, bytestring
|
||||
, derive-storable
|
||||
, monad-loops
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -26,8 +26,8 @@ let
|
|||
}) {};
|
||||
|
||||
f = { mkDerivation, aeson, base, bytestring, containers, derive-storable
|
||||
, JuicyPixels, JuicyPixels-extra, linear, OpenGL, OpenGLRaw, stdenv
|
||||
, sdl2, stm, text, vector}:
|
||||
, JuicyPixels, JuicyPixels-extra, linear, monad-loops, OpenGL, OpenGLRaw
|
||||
, stdenv, sdl2, stm, text, vector}:
|
||||
mkDerivation {
|
||||
pname = "pituicat";
|
||||
version = "0.0.0.0";
|
||||
|
|
|
|||
|
|
@ -3,3 +3,5 @@ module Classes.Graphics
|
|||
) where
|
||||
|
||||
import Classes.Graphics.Bindable as G
|
||||
import Classes.Graphics.Buffer as G
|
||||
import Classes.Graphics.VertexLayout as G
|
||||
|
|
|
|||
|
|
@ -1,10 +1,13 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Classes.Graphics.Buffer where
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
|
||||
import SDL (($=), get)
|
||||
|
||||
import Foreign.Storable
|
||||
|
||||
-- internal imports
|
||||
|
||||
import Classes.Graphics.Bindable
|
||||
|
|
@ -12,28 +15,35 @@ import Classes.Graphics.Bindable
|
|||
-- | this aims to be a typeclass for all used buffer objects throughout the
|
||||
-- game. all buffer objects have to instanciate the Bindable typeclass.
|
||||
-- think of it as some kind of interface in the object oriented context
|
||||
class (Bindable a) => Buffer a where
|
||||
class (Bindable a, Storable (StoreType a)) =>
|
||||
Buffer a where
|
||||
|
||||
type ObjName a :: *
|
||||
-- | datatype inside the buffer
|
||||
type StoreType a :: *
|
||||
|
||||
-- | what buffer target does the buffer bind to
|
||||
target :: a -> GL.BufferTarget
|
||||
-- | container datatype for 'StoreType's
|
||||
type StoreContainer a :: * -> *
|
||||
|
||||
-- | retrieve ID from buffer object
|
||||
glId :: a -> IO (ObjName a)
|
||||
-- | what buffer target does the buffer bind to
|
||||
target :: a -> GL.BufferTarget
|
||||
|
||||
-- | bind the buffer object and fill it with null data
|
||||
initialize :: a -> IO ()
|
||||
-- | retrieve ID from buffer object
|
||||
glId :: a -> IO (GL.BufferObject)
|
||||
|
||||
-- | fill the buffer with actual data
|
||||
write
|
||||
:: a
|
||||
-> Word -- ^ write offset from beginning of buffer in bytes
|
||||
-> b -- ^ Data to write
|
||||
-> IO ()
|
||||
-- | bind the buffer object and fill it with null data
|
||||
initialize :: a -> IO ()
|
||||
|
||||
-- | expand the buffer to double of it's previous size.
|
||||
expand :: a -> IO ()
|
||||
-- | fill the buffer with actual data
|
||||
write
|
||||
:: a
|
||||
-> Word
|
||||
-- ^ write offset from beginning of buffer in bytes
|
||||
-> StoreContainer a (StoreType a)
|
||||
-- ^ Data to write
|
||||
-> IO ()
|
||||
|
||||
-- | free resources and delete the object
|
||||
delete :: a -> IO ()
|
||||
-- | expand the buffer to double of it's previous size.
|
||||
expand :: a -> IO ()
|
||||
|
||||
-- | free resources and delete the object
|
||||
delete :: a -> IO ()
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ import Linear
|
|||
|
||||
import Types
|
||||
import Map
|
||||
import Classes.Scene
|
||||
import Classes
|
||||
|
||||
data Test = Test
|
||||
{ testMap :: TMVar LevelMap
|
||||
|
|
@ -44,10 +44,9 @@ instance Scene Test where
|
|||
view = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
|
||||
model = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
|
||||
|
||||
vertexArrayObject <- GL.genObjectName
|
||||
vertexArray <- newVertexArray
|
||||
|
||||
GL.bindVertexArrayObject $= Just vertexArrayObject
|
||||
bind vertexArray
|
||||
|
||||
void $ atomically $ do
|
||||
void $ takeTMVar progress
|
||||
|
|
|
|||
|
|
@ -5,6 +5,12 @@ import qualified Graphics.Rendering.OpenGL as GL
|
|||
|
||||
import SDL (($=), get)
|
||||
|
||||
import qualified Data.Vector.Storable as VS
|
||||
|
||||
import Control.Monad.Loops (whileM_)
|
||||
|
||||
import Control.Concurent.STM
|
||||
|
||||
import Foreign
|
||||
|
||||
-- internal imports
|
||||
|
|
@ -13,21 +19,23 @@ import Classes.Graphics.Bindable
|
|||
import Classes.Graphics.Buffer
|
||||
|
||||
-- layout of the IndexBuffer data object
|
||||
data IndexBuffer a = IndexBuffer
|
||||
{ iBufId :: GL.BufferObject -- buffer id
|
||||
, iBufSize :: GL.GLsizeiptr -- size of data
|
||||
, iBufData :: Ptr a -- pointer to data
|
||||
, iBufCount :: GL.GLint -- number of data elements
|
||||
data IndexBuffer = IndexBuffer
|
||||
{ iBufId :: TVar GL.BufferObject -- buffer id
|
||||
, iBufSize :: TVar GL.GLsizeiptr -- size of data
|
||||
-- , iBufData :: Ptr a -- pointer to data
|
||||
-- , iBufCount :: GL.GLint -- number of data elements
|
||||
}
|
||||
|
||||
-- instanciate typeclass from BufferClass and fill in missing implementations
|
||||
instance Buffer (IndexBuffer a) where
|
||||
-- instanciate typeclass from Buffer and fill in missing implementations
|
||||
instance Buffer IndexBuffer where
|
||||
|
||||
type ObjName (IndexBuffer a) = GL.BufferObject
|
||||
type StoreType IndexBuffer = GL.GLuint
|
||||
|
||||
type StoreContainer IndexBuffer = VS.Vector
|
||||
|
||||
target _ = GL.ElementArrayBuffer
|
||||
|
||||
glId = iBufId
|
||||
glId = readTVarIO . iBufId
|
||||
|
||||
initialize buf = do
|
||||
-- bind the buffer using the default iplementation of the typeclass
|
||||
|
|
@ -35,12 +43,60 @@ instance Buffer (IndexBuffer a) where
|
|||
-- fill in the data
|
||||
GL.bufferData (target buf) $=
|
||||
( iBufSize buf
|
||||
, iBufData buf
|
||||
, 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 $ offset + VS.length dat * sizeOf (undefined :: StoreType IndexBuffer)
|
||||
> currentBufSize) $ do
|
||||
allocaArray
|
||||
(currentBufSize `div` sizeOf (undefined :: StoreType IndexBuffer))
|
||||
$ \ ptr -> do
|
||||
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)
|
||||
GL.WriteToBuffer
|
||||
(CPtrdiff $ fromIntegral offset)
|
||||
(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 $ vBufId buf)
|
||||
|
||||
|
||||
instance Bindable (IndexBuffer a) where
|
||||
|
||||
-- bind the buffer
|
||||
|
|
@ -49,21 +105,20 @@ instance Bindable (IndexBuffer a) where
|
|||
-- unbind the buffer
|
||||
unbind buf = GL.bindBuffer (target buf) $= Nothing
|
||||
|
||||
newIndexBuffer ::
|
||||
(Storable a) => -- we have to be able to get a pointer to provided data
|
||||
[a] -> -- list of data elements
|
||||
IO (IndexBuffer a) -- newly built IndexBuffer data object
|
||||
newIndexBuffer list = do
|
||||
newIndexBuffer
|
||||
:: Word
|
||||
-> IO IndexBuffer -- newly built IndexBuffer data object
|
||||
newIndexBuffer initLength = do
|
||||
-- create the buffer object in applicative style
|
||||
buf <- IndexBuffer
|
||||
-- generate the ID
|
||||
<$> GL.genObjectName
|
||||
-- compute buffer size
|
||||
<*> pure (fromIntegral (length list * sizeOf (head list)))
|
||||
-- make pointer out of list
|
||||
<*> newArray list
|
||||
-- get count
|
||||
<*> pure (fromIntegral $ length list)
|
||||
<*> pure (fromIntegral initLength)
|
||||
-- -- make pointer out of list
|
||||
-- <*> newArray list
|
||||
-- -- get count
|
||||
-- <*> pure (fromIntegral $ length list)
|
||||
-- fill the data in to the buffer
|
||||
initialize buf
|
||||
-- return the data object
|
||||
|
|
|
|||
|
|
@ -5,32 +5,27 @@ import qualified Graphics.Rendering.OpenGL as GL
|
|||
|
||||
import SDL (($=), get)
|
||||
|
||||
import Foreign
|
||||
import qualified Data.Vector as V
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Foreign (sizeOf)
|
||||
import Foreign.Ptr
|
||||
|
||||
import Control.Concurrent.STM
|
||||
|
||||
import Control.Monad (void)
|
||||
|
||||
-- internal imports
|
||||
|
||||
import Classes.Graphics.Bindable
|
||||
import Classes.Graphics.Buffer
|
||||
import Classes.Graphics.VertexLayout
|
||||
import Types.Graphics.VertexBuffer
|
||||
|
||||
data VertexArray = VertexArray
|
||||
newtype VertexArray = VertexArray
|
||||
{ vArrId :: GL.VertexArrayObject
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Buffer VertexArray where
|
||||
|
||||
type ObjName VertexArray = GL.VertexArrayObject
|
||||
|
||||
target _ = undefined
|
||||
|
||||
glId = return . vArrId
|
||||
|
||||
initialize va = return ()
|
||||
|
||||
|
||||
instance Bindable VertexArray where
|
||||
|
||||
bind va = GL.bindVertexArrayObject $= Just (vArrId va)
|
||||
|
|
@ -41,76 +36,39 @@ newVertexArray :: IO VertexArray
|
|||
newVertexArray = VertexArray
|
||||
<$> GL.genObjectName
|
||||
|
||||
addBuffer
|
||||
:: (Buffer buf)
|
||||
=> VertexArray
|
||||
-> buf
|
||||
-> VertexBufferLayout
|
||||
-> IO ()
|
||||
addBuffer va vb layout = do
|
||||
-- bind the provided vertex buffer
|
||||
bind va
|
||||
bind vb
|
||||
-- enable and fill out the vertex attrib pointer(s)
|
||||
list <- readMVar (vblElements layout)
|
||||
let dataElementSize e = case e of
|
||||
GL.Float -> sizeOf (undefined :: GL.GLfloat)
|
||||
x -> error ("No size computation implemented fof: " <> show x)
|
||||
mapM_
|
||||
(\(VertexBufferLayoutElement index type_ count offset handling) -> do
|
||||
GL.vertexAttribArray (GL.AttribLocation index) $=
|
||||
GL.Enabled
|
||||
GL.vertexAttribPointer (GL.AttribLocation index) $=
|
||||
( handling
|
||||
instance VertexLayout Vertex where
|
||||
|
||||
type VertArray Vertex = VertexArray
|
||||
|
||||
layoutElements vert =
|
||||
foldr
|
||||
(\a@(index, count) acc ->
|
||||
( index
|
||||
, GL.VertexArrayDescriptor
|
||||
-- number of components to our attribute
|
||||
count
|
||||
-- datatype of elements
|
||||
type_
|
||||
-- Stride (How big is one Vertex in bytes)
|
||||
(vblStride layout)
|
||||
-- offset from beginnning of vertex in bytes
|
||||
(plusPtr nullPtr offset)
|
||||
GL.Float
|
||||
(fromIntegral $ sizeOf (undefined :: Vertex))
|
||||
(nullPtr `plusPtr` (sizeOf (undefined :: GL.GLfloat) * fromIntegral
|
||||
(sum (map ((\(GL.VertexArrayDescriptor c _ _ _) -> c) . snd) acc))))
|
||||
) : acc
|
||||
)
|
||||
)
|
||||
list
|
||||
unbind va
|
||||
unbind vb
|
||||
[]
|
||||
(zip [0 ..] [3, 4, 2, 1])
|
||||
|
||||
data VertexBufferLayout = VertexBufferLayout
|
||||
{ vblElements :: MVar [VertexBufferLayoutElement]
|
||||
, vblStride :: GL.GLsizei
|
||||
}
|
||||
|
||||
data VertexBufferLayoutElement = VertexBufferLayoutElement
|
||||
{ vbleIndex :: GL.GLuint
|
||||
, vbleType :: GL.DataType
|
||||
, vbleCount :: GL.GLint
|
||||
, vbleOffset :: Int
|
||||
, vbleHandling :: GL.IntegerHandling
|
||||
}
|
||||
|
||||
newVertexBufferLayout :: GL.GLsizei -> IO VertexBufferLayout
|
||||
newVertexBufferLayout stride = VertexBufferLayout
|
||||
<$> newMVar []
|
||||
<*> pure stride
|
||||
|
||||
pushElements
|
||||
:: VertexBufferLayout
|
||||
-> GL.GLuint
|
||||
-> GL.DataType
|
||||
-> GL.GLint
|
||||
-> Int
|
||||
-> IO ()
|
||||
pushElements vbl index type_ count offset = do
|
||||
modifyMVar_ (vblElements vbl) $ \list ->
|
||||
return
|
||||
(list ++
|
||||
[VertexBufferLayoutElement
|
||||
index
|
||||
type_
|
||||
count
|
||||
offset
|
||||
GL.ToNormalizedFloat
|
||||
]
|
||||
addBuffer vert va vb = do
|
||||
-- bind vertex array and vertex buffer ot associate them
|
||||
bind va
|
||||
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 va
|
||||
unbind vb
|
||||
|
|
|
|||
|
|
@ -1,16 +1,22 @@
|
|||
{-# 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
|
||||
|
|
@ -34,7 +40,6 @@ data Vertex = Vertex
|
|||
, vertColor :: V4 GL.GLfloat
|
||||
, vertTexCoord :: V2 GL.GLfloat
|
||||
, vertTexID :: GL.GLfloat
|
||||
, vertSize :: GL.GLsizei
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
|
|
@ -57,12 +62,13 @@ newVertex pos color texcoord index =
|
|||
color
|
||||
texcoord
|
||||
index
|
||||
(fromIntegral $ 10 * (sizeOf (undefined :: GL.GLfloat)))
|
||||
|
||||
-- | Instanciate typeclass Buffer and fill in missing implementations
|
||||
instance Buffer VertexBuffer where
|
||||
|
||||
type ObjName VertexBuffer = GL.BufferObject
|
||||
type StoreType VertexBuffer = Vertex
|
||||
|
||||
type StoreContainer VertexBuffer = VS.Vector
|
||||
|
||||
target _ = GL.ArrayBuffer
|
||||
|
||||
|
|
@ -81,7 +87,47 @@ instance Buffer VertexBuffer where
|
|||
-- release the buffer using the default implementation of the typeclass
|
||||
unbind buf
|
||||
|
||||
-- | expand the buffer to double of it's previous size.
|
||||
write buf offset dat = do
|
||||
currentBufSize <- readTVarIO (vBufSize buf)
|
||||
whileM_
|
||||
(pure $ fromIntegral offset +
|
||||
VS.length dat * sizeOf (undefined :: StoreType VertexBuffer)
|
||||
> fromIntegral currentBufSize) $ do
|
||||
allocaArray
|
||||
(fromIntegral currentBufSize `div`
|
||||
sizeOf (undefined :: StoreType VertexBuffer))
|
||||
$ \ (ptr :: Ptr (StoreType VertexBuffer)) -> do
|
||||
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)
|
||||
-- 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
|
||||
|
|
@ -118,9 +164,8 @@ instance Bindable VertexBuffer where
|
|||
-- | smart constructor for a VertexBuffer data object
|
||||
newVertexBuffer
|
||||
:: Word -- ^ initial Buffer size
|
||||
-> Vertex -- ^ (empty) dummy vertex for determining buffer size
|
||||
-> IO VertexBuffer -- ^ newly built VertexBuffer data object
|
||||
newVertexBuffer initSize dummyVertex = do
|
||||
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
|
||||
|
|
@ -128,7 +173,7 @@ newVertexBuffer initSize dummyVertex = do
|
|||
<$> (newTVarIO =<< GL.genObjectName)
|
||||
-- compute buffer size
|
||||
<*> (newTVarIO (CPtrdiff (fromIntegral $
|
||||
fromIntegral initSize * vertSize dummyVertex)))
|
||||
fromIntegral initSize * sizeOf (undefined :: StoreType VertexBuffer))))
|
||||
-- make pointer out of list
|
||||
-- <*> newArray list
|
||||
-- fill the data in to the buffer
|
||||
|
|
|
|||
Loading…
Reference in a new issue