finished episode 24

This commit is contained in:
nek0 2020-08-29 04:41:23 +02:00
parent ad1e3579e8
commit fa0c6c4670
6 changed files with 136 additions and 114 deletions

View file

@ -24,6 +24,9 @@ to peruse it.
### Keyboard ### Keyboard
* `1`, `2`: Switch input focus between the two displayed objects To switch to a scene, press one of the buttons below
* `X`/`Shift`+`X`: Move the focused object right/left
* `Y`/`Shift`+`Y`: Move the focused object up/down ## `F1` - Colour changer
Use the keys `1` through `4` to increase the values of R, G, B or A of the
background colour. Press `Left Shift` and the number key to decrease it.

View file

@ -41,5 +41,7 @@ executable renderer-tutorial
, Renderer , Renderer
, Texture , Texture
, EventHandler , EventHandler
, Scenes.SceneClass
, Scenes.ClearColor
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

View file

@ -84,7 +84,6 @@ switchObject focus elems evs =
(SDL.Keysym code _ mod) (SDL.Keysym code _ mod)
)) ))
-> do -> do
print code
let selectIndex = fromIntegral (SDL.toNumber code) - 30 let selectIndex = fromIntegral (SDL.toNumber code) - 30
if ((selectIndex < 10) && (selectIndex >= 0)) && if ((selectIndex < 10) && (selectIndex >= 0)) &&
(SDL.toNumber mod == 0) && (SDL.toNumber mod == 0) &&

View file

@ -4,6 +4,7 @@ module Main where
import SDL (($=), get) import SDL (($=), get)
import qualified SDL import qualified SDL
import qualified SDL.Internal.Numbered as SDL
import qualified SDL.Raw.Video as SDL (glSetAttribute) import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL import qualified SDL.Raw.Enum as SDL
@ -43,6 +44,9 @@ import Renderer
import Texture import Texture
import EventHandler import EventHandler
import Scenes.SceneClass
import Scenes.ClearColor
main :: IO () main :: IO ()
main = do main = do
@ -78,93 +82,13 @@ main = do
version <- peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION version <- peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
print (B.pack version) print (B.pack version)
-- -- VERTICES
-- first, create and bind a vertex array object
vao <- GL.genObjectName
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]
-- construct new VertexBuffer and fill it with data
vao <- newVertexArray
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 vao vbo layout
-- -- 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)
-- store the mtrices for later adjustments
proj <- newMVar mproj
view <- newMVar mview
model1 <- newMVar mmodel1
model2 <- newMVar mmodel2
-- -- TEXTURE
-- generate and bind texture
tex <- newTexture "res/textures/lynx.jpg" 0
bind tex
-- construct new IndexBuffer and fill it with data
ibo <- newIndexBuffer indices
-- -- SHADERS
sp <- newShader
[ ShaderSource GL.VertexShader "./res/shaders/vert.shader"
, ShaderSource GL.FragmentShader "./res/shaders/frag.shader"
]
[ "u_color"
, "u_texture"
, "u_mvp"
]
-- -- tell the shader where to find the texture
bind sp
setUniform sp "u_texture" (texSlot tex)
-- -- UNIFORMS
err <- get GL.errors err <- get GL.errors
print $ "pre-loop errors: " <> show err print $ "pre-loop errors: " <> show err
-- -- EVENTING AND DRAWING -- -- Constructing Scenes
switch <- newMVar model1 -- Construct state machine for the Scenes
curScene <- newEmptyMVar :: IO (MVar Scene)
-- -- UNBINDING ALL BUFFERS AND VERTEX ARRAYS
unbind vao
unbind vbo
unbind ibo
unbind sp
-- -- LOOPING -- -- LOOPING
@ -177,6 +101,8 @@ main = do
-- poll again -- poll again
void $ swapMVar evs =<< SDL.pollEvents void $ swapMVar evs =<< SDL.pollEvents
currentEvents <- readMVar evs
-- -- OBEY THE HYPNOTOAD! -- -- OBEY THE HYPNOTOAD!
-- clearcol <- GL.Color4 -- clearcol <- GL.Color4
-- <$> (randomRIO (0, 1)) -- <$> (randomRIO (0, 1))
@ -185,35 +111,19 @@ main = do
-- <*> pure 1 -- <*> pure 1
-- GL.clearColor $= clearcol -- GL.clearColor $= clearcol
-- clear previous frame hasSelect <- not <$> isEmptyMVar curScene
clear if hasSelect
then do
(Scene sceneObject) <- readMVar curScene
onEvents sceneObject currentEvents
update sceneObject 0
render sceneObject
else do
GL.clear [GL.ColorBuffer]
-- retrieve matrices from MVars -- Switch to different scene on keyboard presses F1 thourgh F?
mproj <- readMVar proj
mview <- readMVar view
-- modify the mvars based on keystrokes sceneSwitch curScene currentEvents
switchObject switch [model1, model2] evs
focus <- readMVar switch
moveObj proj view focus evs
-- -- bind shader and provide mvp for object1 and draw it
mmodel1 <- readMVar model1
bind sp
setUniform sp "u_mvp" (mproj !*! mview !*! mmodel1)
-- the actual drawing happens here
draw vao 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 vao ibo sp
err <- get GL.errors err <- get GL.errors
when (not $ null err) (print $ "loop errors: " <> show err) when (not $ null err) (print $ "loop errors: " <> show err)
@ -237,3 +147,26 @@ main = do
-- This is the end. -- This is the end.
putStrLn "Bye!" putStrLn "Bye!"
sceneSwitch :: MVar Scene -> [SDL.Event] -> IO ()
sceneSwitch curScene evs = mapM_ (switch . SDL.eventPayload) evs
where
switch (SDL.KeyboardEvent
(SDL.KeyboardEventData
_
SDL.Pressed
_
(SDL.Keysym _ code mod))) =
when (SDL.toNumber mod == 0) $
case code of
SDL.KeycodeF1 -> do
void $ tryTakeMVar curScene
putMVar curScene =<< scene1
_ ->
return ()
switch _ = return ()
-- initialize scenes
scene1 = Scene <$> ClearColor <$> newMVar (V4 0 0.2 0.3 1)

65
src/Scenes/ClearColor.hs Normal file
View file

@ -0,0 +1,65 @@
module Scenes.ClearColor 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
-- internal imports
import Scenes.SceneClass
data ClearColor = ClearColor
{ ccColor :: MVar (V4 GL.GLfloat)
}
instance SceneClass ClearColor where
update _ _ = return ()
onEvents (ClearColor col) evs =
modifyMVar_ col (\(V4 r g b a) -> do
[nr, ng, nb, na] <- foldM
(\acc ev -> case SDL.eventPayload ev of
(SDL.KeyboardEvent
(SDL.KeyboardEventData
_
SDL.Pressed
_
(SDL.Keysym _ code mod)
)) -> do
-- Scancode for key "1" 1 is 30
let alter =
map
-- flip direction on pressed "Shift" key
(if SDL.keyModifierLeftShift mod
then ((-1) *)
else id
)
-- alter colors only for key 1 to 4, ignore all others
(case code of
SDL.Keycode1 -> [1, 0, 0, 0]
SDL.Keycode2 -> [0, 1, 0, 0]
SDL.Keycode3 -> [0, 0, 1, 0]
SDL.Keycode4 -> [0, 0, 0, 1]
_ -> [0, 0, 0, 0]
)
return $ zipWith (+) acc (map (/ 256) alter)
_ -> return acc
)
[r, g, b, a]
evs
return (V4 nr ng nb na)
)
render (ClearColor col) = do
(V4 r g b a) <- readMVar col
GL.clearColor $= GL.Color4 r g b a
GL.clear [GL.ColorBuffer]

20
src/Scenes/SceneClass.hs Normal file
View file

@ -0,0 +1,20 @@
{-# LANGUAGE ExistentialQuantification #-}
module Scenes.SceneClass where
import qualified SDL
class SceneClass a where
-- | Run updates on the data given the time elapsed since last frame
update :: a -> Float -> IO ()
-- | Handle input events
onEvents :: a -> [SDL.Event] -> IO ()
-- | perform the drawing
render :: a -> IO ()
-- Existential type wrapper to make all Scenes implementing SceneClass
-- homogenous.
-- See more at https://wiki.haskell.org/Existential_type#Dynamic_dispatch_mechanism_of_OOP
data Scene = forall a. SceneClass a => Scene a