250 lines
6.5 KiB
Haskell
250 lines
6.5 KiB
Haskell
module Scenes.Texture2D where
|
|
|
|
import SDL (($=), get)
|
|
import qualified SDL
|
|
import qualified SDL.Internal.Numbered as SDL
|
|
|
|
import qualified Graphics.Rendering.OpenGL as GL
|
|
|
|
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 Texture2D = Texture2D
|
|
{ texModels :: [MVar (M44 GL.GLfloat)]
|
|
, texView :: MVar (M44 GL.GLfloat)
|
|
, texProj :: MVar (M44 GL.GLfloat)
|
|
, texFocus :: MVar Int
|
|
, texVertArrObj :: GL.VertexArrayObject
|
|
, texVertArray :: VertexArray
|
|
, texIdxBUfObj :: IndexBuffer GL.GLuint
|
|
, texShaderProg :: Shader
|
|
}
|
|
|
|
instance SceneClass Texture2D 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)
|
|
mmodel1 = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 200 200 0)
|
|
mmodel2 = 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 | texture coordinates
|
|
[ -67, -100, 0, 0, 0
|
|
, 67, -100, 0, 1, 0
|
|
, 67, 100, 0, 1, 1
|
|
, -67, 100, 0, 0, 1
|
|
] :: [GL.GLfloat]
|
|
|
|
-- create draw order indices
|
|
indices = [0, 1, 2, 2, 3, 0] :: [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 $ 5 * sizeOf (undefined :: GL.GLfloat))
|
|
-- push vertex positions
|
|
pushElements
|
|
layout
|
|
0
|
|
GL.Float
|
|
3
|
|
(0 * (sizeOf (undefined :: GL.GLfloat)))
|
|
-- pusht texture coordinates
|
|
pushElements
|
|
layout
|
|
1
|
|
GL.Float
|
|
2
|
|
(3 * (sizeOf (undefined :: GL.GLfloat)))
|
|
|
|
addBuffer va vbo layout
|
|
|
|
-- -- TEXTURE
|
|
|
|
-- generate and bind texture
|
|
tex <- newTexture "res/textures/lynx.jpg" 0
|
|
bind tex
|
|
|
|
-- -- tell the shader where to find the texture
|
|
sp <- newShader
|
|
[ ShaderSource GL.VertexShader "./res/shaders/vert.shader"
|
|
, ShaderSource GL.FragmentShader "./res/shaders/frag.shader"
|
|
]
|
|
bind sp
|
|
setUniform sp "u_texture" (texSlot tex)
|
|
|
|
-- unbind everything again
|
|
|
|
unbind va
|
|
unbind vbo
|
|
unbind ibo
|
|
unbind sp
|
|
|
|
-- store the mtrices for later adjustments
|
|
proj <- newMVar mproj
|
|
view <- newMVar mview
|
|
model1 <- newMVar mmodel1
|
|
model2 <- newMVar mmodel2
|
|
|
|
focus <- newMVar 0
|
|
|
|
return $ Texture2D [model1, model2] view proj focus vao va ibo sp
|
|
|
|
update _ _ = return ()
|
|
|
|
onEvents (Texture2D models view proj focus vao va ibo sp) evs = do
|
|
-- modify the mvars based on keystrokes
|
|
switchObject focus models evs
|
|
foc <- readMVar focus
|
|
moveObj proj view (models !! foc) evs
|
|
|
|
render (Texture2D [model1, model2] 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
|
|
mmodel1 <- readMVar model1
|
|
bind sp
|
|
setUniform sp "u_mvp" (mproj !*! mview !*! mmodel1)
|
|
|
|
-- the actual drawing happens here
|
|
draw va ibo sp
|
|
|
|
-- -- bind shader and provide mvp for object2 and draw it
|
|
|
|
mmodel2 <- readMVar model2
|
|
bind sp
|
|
setUniform sp "u_mvp" (mproj !*! mview !*! mmodel2)
|
|
|
|
-- 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
|
|
)
|
|
|
|
switchObject
|
|
:: MVar Int
|
|
-> [MVar (M44 GL.GLfloat)]
|
|
-> [SDL.Event]
|
|
-> IO ()
|
|
switchObject focus elems evs =
|
|
modifyMVar_ focus (\foc -> do
|
|
foldM
|
|
(\acc ev -> case SDL.eventPayload ev of
|
|
(SDL.KeyboardEvent
|
|
(SDL.KeyboardEventData
|
|
_
|
|
SDL.Pressed
|
|
_
|
|
(SDL.Keysym code _ mod)
|
|
))
|
|
-> do
|
|
let selectIndex = fromIntegral (SDL.toNumber code) - 30
|
|
if ((selectIndex < 10) && (selectIndex >= 0)) &&
|
|
(SDL.toNumber mod == 0) &&
|
|
(selectIndex < length elems) &&
|
|
(acc /= selectIndex)
|
|
then do
|
|
print ("selected element number: " <> show selectIndex)
|
|
return $ selectIndex
|
|
else
|
|
return foc
|
|
_ -> return acc
|
|
)
|
|
foc
|
|
evs
|
|
)
|