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 , EventHandler
, Scenes.SceneClass , Scenes.SceneClass
, Scenes.ClearColor , Scenes.ClearColor
, Scenes.Texture2D
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

View file

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE Strict #-} {-# LANGUAGE Strict #-}
module Main where module Main where
@ -34,18 +35,15 @@ import Linear
-- internal imports -- internal imports
import BindableClass
import BufferClass
import VertexArray import VertexArray
import VertexBuffer
import IndexBuffer
import Shader import Shader
import Renderer import IndexBuffer
import Texture
import EventHandler import EventHandler
import Scenes.SceneClass import Scenes.SceneClass
import Scenes.ClearColor import Scenes.ClearColor
import Scenes.Texture2D
main :: IO () main :: IO ()
main = do main = do
@ -169,11 +167,12 @@ sceneSwitch curScene evs = mapM_ (switch . SDL.eventPayload) evs
isEmpty <- isEmptyMVar curScene isEmpty <- isEmptyMVar curScene
when isEmpty $ do when isEmpty $ do
void $ tryTakeMVar curScene 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 () return ()
switch _ = 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 -- internal imports
import BindableClass
import BufferClass
import VertexArray
import VertexBuffer
import IndexBuffer
import Shader
import Renderer
import Texture
import Scenes.SceneClass import Scenes.SceneClass
data ClearColor = ClearColor data ClearColor = ClearColor
@ -22,6 +31,9 @@ data ClearColor = ClearColor
instance SceneClass ClearColor where instance SceneClass ClearColor where
initScene = do
ClearColor <$> newMVar (V4 0 0.2 0.3 1)
update _ _ = return () update _ _ = return ()
onEvents (ClearColor col) evs = onEvents (ClearColor col) evs =

View file

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