finished episode 26

This commit is contained in:
nek0 2020-08-29 07:13:49 +02:00
parent 9fca6a7617
commit 055a12e94f
5 changed files with 266 additions and 11 deletions

View File

@ -43,5 +43,6 @@ executable renderer-tutorial
, EventHandler
, Scenes.SceneClass
, Scenes.ClearColor
, Scenes.Texture2D
hs-source-dirs: src
default-language: Haskell2010

View File

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE Strict #-}
module Main where
@ -34,18 +35,15 @@ import Linear
-- internal imports
import BindableClass
import BufferClass
import VertexArray
import VertexBuffer
import IndexBuffer
import Shader
import Renderer
import Texture
import IndexBuffer
import EventHandler
import Scenes.SceneClass
import Scenes.ClearColor
import Scenes.Texture2D
main :: IO ()
main = do
@ -169,11 +167,12 @@ sceneSwitch curScene evs = mapM_ (switch . SDL.eventPayload) evs
isEmpty <- isEmptyMVar curScene
when isEmpty $ do
void $ tryTakeMVar curScene
putMVar curScene =<< scene1
putMVar curScene =<< fmap Scene (initScene @ClearColor)
SDL.KeycodeF2 -> do
isEmpty <- isEmptyMVar curScene
when isEmpty $ do
void $ tryTakeMVar curScene
putMVar curScene =<< fmap Scene (initScene @Texture2D)
_ ->
return ()
switch _ = return ()
-- initialize scenes
scene1 = Scene <$> ClearColor <$> newMVar (V4 0 0.2 0.3 1)

View File

@ -14,6 +14,15 @@ import Linear
-- internal imports
import BindableClass
import BufferClass
import VertexArray
import VertexBuffer
import IndexBuffer
import Shader
import Renderer
import Texture
import Scenes.SceneClass
data ClearColor = ClearColor
@ -22,6 +31,9 @@ data ClearColor = ClearColor
instance SceneClass ClearColor where
initScene = do
ClearColor <$> newMVar (V4 0 0.2 0.3 1)
update _ _ = return ()
onEvents (ClearColor col) evs =

View File

@ -5,6 +5,9 @@ import qualified SDL
class SceneClass a where
-- | Perform initialization.
initScene :: IO a
-- | Run updates on the data given the time elapsed since last frame
update :: a -> Float -> IO ()

240
src/Scenes/Texture2D.hs Normal file
View File

@ -0,0 +1,240 @@
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
-- 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
-- push vertex positions
pushElements layout GL.Float 3
-- pusht texture coordinates
pushElements layout GL.Float 2
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"
]
[ "u_color"
, "u_texture"
, "u_mvp"
]
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
)