renderer-tutorial/src/Scenes/Texture2DBatched.hs

225 lines
6.0 KiB
Haskell

module Scenes.Texture2DBatched where
import SDL (($=), get)
import qualified SDL
import qualified SDL.Internal.Numbered as SDL
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GL.Functions as GLRaw
import Control.Monad
import Control.Concurrent.MVar
import Linear
import qualified Control.Lens as Lens
import Foreign.Storable (sizeOf)
-- internal imports
import BindableClass
import BufferClass
import VertexArray
import VertexBuffer
import IndexBuffer
import Shader
import Renderer
import Texture
import Scenes.SceneClass
data Texture2DBatched = Texture2DBatched
{ texModels :: MVar (M44 GL.GLfloat)
, texView :: MVar (M44 GL.GLfloat)
, texProj :: MVar (M44 GL.GLfloat)
, texVertArrObj :: GL.VertexArrayObject
, texVertArray :: VertexArray
, texIdxBUfObj :: IndexBuffer GL.GLuint
, texShaderProg :: Shader
}
instance SceneClass Texture2DBatched where
initScene = do
-- -- MATRICES
let mproj = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat
mview = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
mmodel = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 400 400 0)
vao <- GL.genObjectName
va <- newVertexArray
GL.bindVertexArrayObject $= Just vao
-- define vertices (positions of the rectangle corners) as List of Floats
-- with added in texture coordinates
let vertexPositions =
-- 3D positions | VertexColor | tex coords | tex indx
[ -67, -100, 0, 0.9, 0.8, 0, 1, 0, 0, 0
, 67, -100, 0, 0.9, 0.8, 0, 1, 1, 0, 0
, 67, 100, 0, 0.9, 0.8, 0, 1, 1, 1, 0
, -67, 100, 0, 0.9, 0.8, 0, 1, 0, 1, 0
, 133, -100, 0, 0, 0.5, 0.9, 1, 0, 0, 1
, 267, -100, 0, 0, 0.5, 0.9, 1, 1, 0, 1
, 267, 100, 0, 0, 0.5, 0.9, 1, 1, 1, 1
, 133, 100, 0, 0, 0.5, 0.9, 1, 0, 1, 1
] :: [GL.GLfloat]
-- create draw order indices
indices = [0, 1, 2, 2, 3, 0, 4, 5, 6, 6, 7, 4] :: [GL.GLuint]
ibo <- newIndexBuffer indices
GL.blend $= GL.Enabled
GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
-- construct new VertexBuffer and fill it with data
vbo <- newVertexBuffer vertexPositions
-- rebind the vertex buffer
bind vbo
-- enable and specify data layout of the in-memory vertices
layout <- newVertexBufferLayout
(fromIntegral $ 10 * sizeOf (undefined :: GL.GLfloat))
-- push vertex positions
pushElements
layout
0
GL.Float
3
(0 * (sizeOf (undefined :: GL.GLfloat)))
-- push vertex colors
pushElements
layout
1
GL.Float
4
(3 * (sizeOf (undefined :: GL.GLfloat)))
-- pusht texture coordinates
pushElements
layout
2
GL.Float
2
(7 * (sizeOf (undefined :: GL.GLfloat)))
-- pusht texture index
pushElements
layout
3
GL.Float
1
(9 * (sizeOf (undefined :: GL.GLfloat)))
addBuffer va vbo layout
-- -- TEXTURE
-- generate and bind texture
tex1 <- newTexture "res/textures/lynx.jpg" 0
tex2 <- newTexture "res/textures/brainbulb_on.flat.png" 1
bind tex1
bind tex2
-- -- tell the shader where to find the texture
sp <- newShader
[ ShaderSource GL.VertexShader "./res/shaders/vertbatch.shader"
, ShaderSource GL.FragmentShader "./res/shaders/fragbatch.shader"
]
bind sp
-- setUniform sp "u_texture" (texSlot tex)
-- unbind everything again
setUniformList sp "u_textures" [0 :: GL.GLint, 1]
unbind va
unbind vbo
unbind ibo
unbind sp
-- store the mtrices for later adjustments
proj <- newMVar mproj
view <- newMVar mview
model <- newMVar mmodel
return $ Texture2DBatched model view proj vao va ibo sp
update _ _ = return ()
onEvents (Texture2DBatched model view proj vao va ibo sp) evs = do
-- modify the mvars based on keystrokes
moveObj proj view model evs
render (Texture2DBatched model view proj vao va ibo sp) = do
-- retrieve matrices from MVars
mproj <- readMVar proj
mview <- readMVar view
GL.clearColor $= GL.Color4 0 0 0 1
clear
mmodel <- readMVar model
bind sp
setUniform sp "u_mvp" (mproj !*! mview !*! mmodel)
-- the actual drawing happens here
draw va ibo sp
moveObj
:: MVar (M44 GL.GLfloat)
-> MVar (M44 GL.GLfloat)
-> MVar (M44 GL.GLfloat)
-> [SDL.Event]
-> IO ()
moveObj proj view model evs =
modifyMVar_ proj (\mproj -> do
modifyMVar_ view (\mview -> do
modifyMVar_ model (\mmodel -> do
let plusModel = foldl (\acc ev -> case SDL.eventPayload ev of
(SDL.KeyboardEvent
( SDL.KeyboardEventData
_
SDL.Pressed
_
(SDL.Keysym _ code mod)
))
->
let trans =
mkTransformationMat
(identity :: M33 GL.GLfloat)
( ( if SDL.keyModifierLeftShift mod
then (-1)
else 1
)
*
( case code of
SDL.KeycodeX ->
V3 1 0 0
SDL.KeycodeY ->
V3 0 1 0
_ ->
V3 0 0 0
)
)
!-!
(identity :: M44 GL.GLfloat)
in acc !+! trans
_ -> acc
)
zero
evs
let retval = mmodel !+! plusModel
when (not $ plusModel == zero) $
print ("Current Position of object: " <>
show (Lens.view translation $ retval))
return retval
)
return mview
)
return mproj
)