get something on screen. finally.

This commit is contained in:
nek0 2020-12-06 08:14:50 +01:00
parent 7e3fbd45c7
commit b3e1d204c5
12 changed files with 483 additions and 94 deletions

View file

@ -0,0 +1,18 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Classes.Graphics.VertexLayout where
import qualified Graphics.Rendering.OpenGL as GL
-- internal imports
import Classes.Graphics.Bindable
class (Bindable (VertBuffer v)) => VertexLayout v where
type VertBuffer v :: *
layoutElements :: v -> [(GL.GLuint, GL.VertexArrayDescriptor GL.GLfloat)]
addBuffer :: v -> VertBuffer v -> IO ()

View file

@ -5,14 +5,22 @@ import Affection
import qualified Data.Text as T
import SDL (($=), get)
import qualified SDL
import qualified SDL.Internal.Numbered as SDL
import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL
import qualified Graphics.Rendering.OpenGL as GL
import Control.Monad (when, void)
import Control.Concurrent.STM
import qualified Data.Map.Strict as M
import Data.String (fromString)
import Data.Maybe (isJust)
import Linear
@ -54,10 +62,7 @@ main = do
withAffection config
preLoad :: GameData -> Affection ()
preLoad gd =
liftIO $ do
scene <- liftIO $ (initScene :: IO Test)
atomically $ putTMVar (gameScene gd) (Stage scene)
preLoad _ = return ()
handle :: GameData -> [SDL.EventPayload] -> Affection ()
handle gd evs = do
@ -66,37 +71,49 @@ handle gd evs = do
update :: GameData -> Double -> Affection ()
update gd dt = do
liftIO ((logIO Verbose) =<< (atomically $
(("Progress: " <>) . snd) <$> (readTMVar $ gameStateLoadProgress gd)))
state <- liftIO $ atomically $ readTVar $ gameState gd
isStagePresent <- liftIO $ atomically $ isEmptyTMVar $ gameScene gd
isStagePresent <- liftIO $ atomically $ fmap not $ isEmptyTMVar $ gameScene gd
if isStagePresent
then do
hasLoadThreadId <- isJust <$> (liftIO $ atomically $ readTVar $ gameLoadThread gd)
liftIO $ logIO Verbose "Stage is present"
(Stage sceneContainer) <- liftIO $ atomically $ readTMVar $ gameScene gd
sceneLoaded <- isSceneLoaded sceneContainer
if not sceneLoaded && not hasLoadThreadId
then
if not sceneLoaded
then do
liftIO $ logIO Verbose "Loading scene"
smLoad state gd
else
smUpdate state gd dt
else
return ()
liftIO $ logIO Error "No Stage to play on"
draw :: GameData -> Affection ()
draw gd = do
state <- liftIO (atomically $ readTVar $ gameState gd)
liftIO $ logIO Verbose (fromString $ "now drawing: " <> show state)
GL.clearColor $= GL.Color4 0 0 1 1
smDraw state gd
err <- SDL.get GL.errors
when (not $ null err) (liftIO $ logIO Error ("loop errors: " <> fromString (show err)))
init :: IO GameData
init = GameData
<$> newEmptyTMVarIO
<*> newTVarIO Loading
<*> newTMVarIO (0, "Ohai!")
<*> (Subsystems
<$> (SubWindow <$> newTVarIO [])
<*> (SubMouse <$> newTVarIO [])
<*> (SubKeyboard <$> newTVarIO [])
<*> (SubTranslator <$> newTVarIO [])
)
<*> newTVarIO (M.fromList [])
<*> newTVarIO True
<*> newTVarIO Nothing
init = do
GL.blend $= GL.Enabled
GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
GameData
<$> (newTMVarIO =<< (Stage <$> (initScene :: IO Test)))
<*> newTVarIO Loading
<*> newTMVarIO (0, "Ohai!")
<*> (Subsystems
<$> (SubWindow <$> newTVarIO [])
<*> (SubMouse <$> newTVarIO [])
<*> (SubKeyboard <$> newTVarIO [])
<*> (SubTranslator <$> newTVarIO [])
)
<*> newTVarIO (M.fromList [])
<*> newTVarIO True
<*> newTVarIO Nothing
<*> newTVarIO Nothing

30
src/Renderer.hs Normal file
View file

@ -0,0 +1,30 @@
{-# LANGUAGE OverloadedStrings #-}
module Renderer where
import Affection
import SDL (($=), get)
import qualified Graphics.Rendering.OpenGL as GL
import Data.String (fromString)
import Control.Concurrent.STM
import Foreign.Ptr
-- internal imports
import Classes.Graphics
import Types.Graphics
draw :: VertexArray -> IndexBuffer -> Shader -> IO ()
draw va ib sp = do
bind sp
bind va
bind ib
count <- atomically $ readTVar $ iBufCount ib
GL.drawElements GL.Triangles count GL.UnsignedInt nullPtr
-- clear :: IO ()
-- clear = GL.clear [GL.ColorBuffer]

View file

@ -8,6 +8,8 @@ import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import qualified Data.Vector.Storable as VS
import Control.Concurrent.STM
import Control.Monad (void)
@ -17,17 +19,30 @@ import Linear
-- internal imports
import Types
import Map
import Classes
import Map
import Renderer as R
data Test = Test
{ testMap :: TMVar LevelMap
, testGraphics :: TMVar GLAssets
, testLoaded :: TVar Bool
}
data GLAssets = GLAssets
{ glVA :: VertexArray
, glVB :: VertexBuffer
, glIB :: IndexBuffer
, glSP :: Shader
}
instance Scene Test where
initScene = Test <$> newEmptyTMVarIO <*> newTVarIO False
initScene =
Test
<$> newEmptyTMVarIO
<*> newEmptyTMVarIO
<*> newTVarIO False
loadScene level progress = do
atomically $ do
@ -48,6 +63,42 @@ instance Scene Test where
bind vertexArray
vertexBuffer <- newVertexBuffer 1024
bind vertexBuffer
let vertices = VS.fromList (createQuad (V2 (400 - 16) (300 - 16)) 0)
write vertexBuffer 0 vertices
indexBuffer <- newIndexBuffer 1024
bind indexBuffer
let indices = VS.fromList [0, 1, 2, 2, 3, 0]
write indexBuffer 0 indices
addBuffer (undefined :: Vertex) vertexBuffer
shader <- newShader
[ ShaderSource GL.VertexShader "./res/shaders/vert.shader"
, ShaderSource GL.FragmentShader "./res/shaders/frag.shader"
]
bind shader
setUniform shader "u_mvp" (projection !*! view !*! model)
unbind vertexArray
unbind vertexBuffer
unbind indexBuffer
unbind shader
atomically $ do
putTMVar (testGraphics level)
(GLAssets vertexArray vertexBuffer indexBuffer shader)
writeTVar (testLoaded level) True
void $ atomically $ do
void $ takeTMVar progress
putTMVar progress (1, "Loaded graphics!")
@ -59,7 +110,10 @@ instance Scene Test where
onEvents _ _ = return ()
render _ = return ()
render level = liftIO $ do
(GLAssets va vb ib sh) <- atomically (readTMVar $ testGraphics level)
bind vb
R.draw va ib sh
testLevelDesc :: LevelDescriptor
testLevelDesc = LevelDescriptor
@ -69,3 +123,10 @@ testLevelDesc = LevelDescriptor
"res/tiles/00_test/00_test.png"
(3, 3)
createQuad :: V2 GL.GLfloat -> Int -> [Vertex]
createQuad pos@(V2 x y) index =
[ newVertex (V3 x y 0) (V4 0 1 0 1) (V2 0 1) (fromIntegral index)
, newVertex (V3 (x + 32) y 0) (V4 0 1 0 1) (V2 0 1) (fromIntegral index)
, newVertex (V3 (x + 32) (y + 32) 0) (V4 0 1 0 1) (V2 0 1) (fromIntegral index)
, newVertex (V3 x (y + 32) 0) (V4 0 1 0 1) (V2 0 1) (fromIntegral index)
]

View file

@ -16,15 +16,20 @@ import Foreign.Marshal.Array
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Control.Concurrent (forkIO)
import Control.Concurrent.STM
-- internal imports
import Types
import Classes
import Map
initLoad
:: GameData
-> Affection ()
initLoad gd =
liftIO $ atomically $ writeTVar (gameState gd) Running
initLoad gd = do
(Stage scene) <- liftIO $ atomically $ readTMVar $ gameScene gd
tid <- liftIO $ forkIO $ loadScene scene (gameStateLoadProgress gd)
liftIO $ atomically $ writeTVar (gameLoadThread gd) (Just tid)

View file

@ -4,25 +4,55 @@ module StateMachine where
import Affection
import Control.Monad (void)
import qualified SDL
import Data.Maybe (isNothing, fromJust)
import Control.Monad (void, when)
import Control.Concurrent (forkIO)
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.TMVar
-- internal imports
import Types
import Classes
import State.Loading
import State.MainGame
-- import State.Loading
-- import State.MainGame
instance StateMachine GameData State where
smLoad Loading = initLoad
smLoad x = error ("State load not yet implemented: " <> show x)
smLoad Loading gd = do
mThreadId <- liftIO $ atomically $ readTVar (gameLoadThread gd)
when (isNothing mThreadId) $ do
(Stage scene) <- liftIO $ atomically $ readTMVar $ gameScene gd
-- ctx <- liftIO $ atomically $ fromJust <$>
-- (readTVar $ gameLoadContext gd)
ad <- get -- get inner state of engine
let win = ((\(_, y, _) -> y) $ head $ drawWindows ad)
liftIO $
loadScene scene (gameStateLoadProgress gd)
-- SDL.glMakeCurrent win (snd $ head $ glContext ad)
-- liftIO $ atomically $ writeTVar (gameLoadThread gd) (Just tid)
smUpdate Loading = initLoadUpdate
smUpdate x = error ("State update not yet implemented: " <> show x)
smLoad x _ = error ("State load not yet implemented: " <> show x)
smUpdate Loading _ _ = return ()
smUpdate x _ _ = error ("State update not yet implemented: " <> show x)
smDraw Loading gd = do
(Stage scene) <- liftIO $ atomically $ readTMVar $ gameScene gd
render scene
smDraw x _ = error ("State draw not yet implemented: " <> show x)
smDraw Loading = initLoadDraw
smDraw x = error ("State draw not yet implemented: " <> show x)
smEvent _ gd evs = do
let Subsystems w m k _ = gameSubsystems gd
@ -30,4 +60,5 @@ instance StateMachine GameData State where
consumeSDLEvents m =<<
consumeSDLEvents w evs
smClean x = error ("State clean not yet implemented: " <> show x)
smClean x _ = error ("State clean not yet implemented: " <> show x)

View file

@ -28,6 +28,7 @@ data GameData = GameData
, gameActionTranslation :: TVar ActionTranslation
, gameRunning :: TVar Bool
, gameLoadThread :: TVar (Maybe ThreadId)
, gameLoadContext :: TVar (Maybe SDL.GLContext)
}
-- Existential type wrapper to make all Scenes implementing Scene

View file

@ -4,3 +4,5 @@ module Types.Graphics
import Types.Graphics.VertexArray as G
import Types.Graphics.VertexBuffer as G
import Types.Graphics.IndexBuffer as G
import Types.Graphics.Shader as G

View file

@ -1,17 +1,25 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module Types.Graphics.IndexBuffer where
import Affection
import qualified Graphics.Rendering.OpenGL as GL
import SDL (($=), get)
import SDL (($=))
import Data.String (fromString)
import qualified Data.Vector.Storable as VS
import Control.Monad (when)
import Control.Monad.Loops (whileM_)
import Control.Concurent.STM
import Control.Concurrent.STM
import Foreign
import Foreign.C.Types
-- internal imports
@ -23,7 +31,7 @@ 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
, iBufCount :: TVar GL.GLint -- number of data elements
}
-- instanciate typeclass from Buffer and fill in missing implementations
@ -40,9 +48,10 @@ instance Buffer IndexBuffer where
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) $=
( iBufSize buf
( size
, nullPtr
, GL.DynamicDraw
)
@ -52,12 +61,13 @@ instance Buffer IndexBuffer where
write buf offset dat = do
currentBufSize <- readTVarIO (iBufSize buf)
whileM_
(pure $ (offset + VS.length dat) *
(pure $ (fromIntegral offset + VS.length dat) *
sizeOf (undefined :: StoreType IndexBuffer)
> currentBufSize) $ do
> fromIntegral currentBufSize) $ do
allocaArray
(currentBufSize `div` sizeOf (undefined :: StoreType IndexBuffer))
$ \ ptr -> do
(fromIntegral currentBufSize `div`
sizeOf (undefined :: StoreType IndexBuffer))
$ \ (ptr :: Ptr (StoreType IndexBuffer)) -> do
GL.bufferSubData
(target buf)
GL.ReadFromBuffer
@ -74,12 +84,17 @@ instance Buffer IndexBuffer where
ptr
-- bind buffer, just to be safe
bind buf
VS unsafeWith dat $ \ ptr ->
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 *
sizeOf (undefined :: StoreType IndexBuffer))
fromIntegral (sizeOf (undefined :: StoreType IndexBuffer)))
(CPtrdiff $ fromIntegral $
VS.length dat * sizeOf (undefined :: StoreType IndexBuffer))
ptr
@ -90,19 +105,20 @@ instance Buffer IndexBuffer where
newId <- GL.genObjectName
newSize <- (2 *) <$> readTVarIO (iBufSize buf)
atomically $ do
writeTvar (iBufId buf) newId
writeTvar (iBUfSize buf) newSize
writeTVar (iBufId buf) newId
writeTVar (iBufSize buf) newSize
initialize buf
delete buf = do
unbind buf
GL.deleteObjectname ==< (readTVarIO $ vBufId buf)
GL.deleteObjectName =<< (readTVarIO $ iBufId buf)
instance Bindable (IndexBuffer a) where
instance Bindable IndexBuffer where
-- bind the buffer
bind buf = GL.bindBuffer (target buf) $= Just (glId buf)
bind buf =
(\ a -> GL.bindBuffer (target buf) $= Just a) =<< glId buf
-- unbind the buffer
unbind buf = GL.bindBuffer (target buf) $= Nothing
@ -114,13 +130,14 @@ newIndexBuffer initLength = do
-- create the buffer object in applicative style
buf <- IndexBuffer
-- generate the ID
<$> GL.genObjectName
<$> (newTVarIO =<< GL.genObjectName)
-- compute buffer size
<*> pure (fromIntegral initLength)
<*> newTVarIO (CPtrdiff (fromIntegral $
(fromIntegral initLength * sizeOf (undefined :: StoreType IndexBuffer))))
-- -- make pointer out of list
-- <*> newArray list
-- -- get count
-- <*> pure (fromIntegral $ length list)
<*> newTVarIO 0
-- fill the data in to the buffer
initialize buf
-- return the data object

View file

@ -0,0 +1,209 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Types.Graphics.Shader where
import SDL (($=), get)
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GL as GLRaw
import Data.List as L
import Data.StateVar
import qualified Data.ByteString as B
import Data.Maybe (fromJust)
import Control.Concurrent.MVar
import Linear
import Foreign.Marshal.Utils (with)
import Foreign.Marshal.Array (withArray)
import Foreign.Storable
import Foreign.Ptr
-- internal imports
import Classes.Graphics.Bindable
data Shader = Shader
{ shaderId :: GL.Program
, shaderSources :: [ShaderSource]
, shaderUniforms :: MVar [ShaderUniform]
}
-- make Shader Bindable
instance Bindable Shader where
bind s = GL.currentProgram $= Just (shaderId s)
unbind _ = GL.currentProgram $= Nothing
data ShaderSource = ShaderSource
{ shaderSourceType :: GL.ShaderType
, shaderPath :: FilePath
}
data ShaderUniform = ShaderUniform
{ shaderUniformName :: String
, shaderUniformLocation :: GL.UniformLocation
}
-- orphan instance to make linear's M44 uniforms
instance GL.Uniform (M44 GL.GLfloat) where
uniform loc@(GL.UniformLocation ul) = makeStateVar getter setter
where
getter = error "cannot implement: get uniform M44 GLfloat"
-- GL.withNewMatrix GL.RowMajor $ getUniformWith GLRaw.glGetUniformfv loc
setter (V4
(V4 a b c d)
(V4 e f g h)
(V4 i j k l)
(V4 m n o p)) = do
mat <- GL.newMatrix GL.RowMajor [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p] :: IO (GL.GLmatrix GL.GLfloat)
GL.withMatrix mat $ GLRaw.glUniformMatrix4fv ul 1 . isRowMajor
uniformv (GL.UniformLocation ul) count buf = error "can not implement uniformv for M44 GLfloat"
-- GLRaw.glUniformMatrix4fv ul count 0 (castPtr buf `asTypeOf` elemType buf)
-- where
-- elemType = undefined :: GL.MatrixComponent c => Ptr (GL.GLmatrix c) -> Ptr c
-- getUniformWith :: (GL.GLuint -> GL.GLint -> Ptr a -> IO ()) -> GL.UniformLocation -> Ptr a -> IO ()
-- getUniformWith getter (GL.UniformLocation ul) buf = do
-- program <- fmap (GL.programID . fromJust) $ get GL.currentProgram
-- getter program ul buf
isRowMajor :: GL.MatrixOrder -> GL.GLboolean
isRowMajor p = if (GL.RowMajor == p) then 1 else 0
-- create new data object of type Shader
newShader :: [ShaderSource] -> IO Shader
newShader shaderSrc = do
-- create program Object
program <- GL.createProgram
-- create shaders from the source codes given
compilates <- mapM
(\(ShaderSource type_ path) -> do
-- read in shader source from File
source<- B.readFile path
-- compile the shader
compiledShader <- compileShaderSource type_ source
return (type_, compiledShader)
)
shaderSrc
-- attach, link and validate the shader program
GL.attachedShaders program $= map snd compilates
GL.linkProgram program
GL.validateProgram program
ok <- get (GL.validateStatus program)
if ok
then
putStrLn "Shaderprogram linked successfully!"
else do
info <- get (GL.programInfoLog program)
putStrLn "Shaderprogram linking failed!\nInfo log says:"
putStrLn info
GL.deleteObjectName program
-- throw away the shaders, since they are linked into the shader program
mapM_ (\s -> GL.deleteObjectName s) (map snd compilates)
-- return data object
Shader program shaderSrc <$> newMVar []
-- pass uniform values into Shader program
setUniformList :: (Storable a, GL.Uniform a) => Shader -> String -> [a] -> IO ()
setUniformList (Shader shaderProgram _ shaderUniforms) uniname data_ = do
-- check if uniform location is already cached
locs <- readMVar shaderUniforms
-- retrieve uniform location
let unilocs = filter
(\(ShaderUniform name _) -> name == uniname)
locs
case unilocs of
[] -> do
print ("Unknown uniform: " <> uniname)
print "Retrieving uniform location from shader program"
loc@(GL.UniformLocation locNum) <- get $ GL.uniformLocation shaderProgram uniname
if locNum < 0
then
print ("Uniform does not exist in shader program: " <> uniname)
else do
-- set the data
withArray data_ $ \ptr ->
GL.uniformv loc (fromIntegral $ length data_) ptr
--GL.uniform loc $= data_
-- add uniform to cache
modifyMVar_ shaderUniforms
(\list -> return $ ShaderUniform uniname loc : list)
[ShaderUniform _ loc] ->
-- set the data
withArray data_ $ \ptr ->
GL.uniformv loc (fromIntegral $ length data_) ptr
setUniform :: (GL.Uniform a) => Shader -> String -> a -> IO ()
setUniform (Shader shaderProgram _ shaderUniforms) uniname data_ = do
-- check if uniform location is already cached
locs <- readMVar shaderUniforms
-- retrieve uniform location
let unilocs = filter
(\(ShaderUniform name _) -> name == uniname)
locs
case unilocs of
[] -> do
print ("Unknown uniform: " <> uniname)
print "Retrieving uniform location from shader program"
loc@(GL.UniformLocation locNum) <- get $ GL.uniformLocation shaderProgram uniname
if locNum < 0
then
print ("Uniform does not exist in shader program: " <> uniname)
else do
-- set the data
--withArray data_ $ \ptr ->
-- GL.uniformv loc (length data_) ptr
GL.uniform loc $= data_
-- add uniform to cache
modifyMVar_ shaderUniforms
(\list -> return $ ShaderUniform uniname loc : list)
[ShaderUniform _ loc] ->
-- set the data
GL.uniform loc $= data_
-- | compile a shader from source
compileShaderSource
:: GL.ShaderType -- ^ what type of shader we are compiling
-> B.ByteString -- ^ its source code
-> IO GL.Shader
compileShaderSource type_ source = do
-- create shader object of specified type
shaderObject <- GL.createShader type_
-- assign source code to shader object
GL.shaderSourceBS shaderObject $= source
-- actually compile the shader
GL.compileShader shaderObject
-- error handling
ok <- GL.compileStatus shaderObject
if ok
then
putStrLn (show type_ ++ ": compilation successful!")
else do
info <- get (GL.shaderInfoLog shaderObject)
putStrLn (show type_ ++ ": compilation failed!\nInfo log says:")
putStrLn info
GL.deleteObjectName shaderObject
return shaderObject

View file

@ -18,7 +18,6 @@ import Control.Monad (void)
import Classes.Graphics.Bindable
import Classes.Graphics.Buffer
import Classes.Graphics.VertexLayout
import Types.Graphics.VertexBuffer
newtype VertexArray = VertexArray
@ -35,40 +34,3 @@ instance Bindable VertexArray where
newVertexArray :: IO VertexArray
newVertexArray = VertexArray
<$> GL.genObjectName
instance VertexLayout Vertex where
type VertArray Vertex = VertexArray
layoutElements vert =
foldr
(\a@(index, count) acc ->
( 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 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

View file

@ -27,6 +27,7 @@ import GHC.Generics
import Classes.Graphics.Bindable
import Classes.Graphics.Buffer
import Classes.Graphics.VertexLayout
-- | layout of the VertexBuffer data object
data VertexBuffer = VertexBuffer
@ -174,10 +175,45 @@ newVertexBuffer initSize = do
<$> (newTVarIO =<< GL.genObjectName)
-- compute buffer size
<*> (newTVarIO (CPtrdiff (fromIntegral $
fromIntegral initSize * sizeOf (undefined :: StoreType VertexBuffer))))
(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