From fa0c6c4670d7f8ac106526899f795c82985e67f6 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 29 Aug 2020 04:41:23 +0200 Subject: [PATCH] finished episode 24 --- README.md | 9 ++- renderer-tutorial.cabal | 2 + src/EventHandler.hs | 1 - src/Main.hs | 153 +++++++++++---------------------------- src/Scenes/ClearColor.hs | 65 +++++++++++++++++ src/Scenes/SceneClass.hs | 20 +++++ 6 files changed, 136 insertions(+), 114 deletions(-) create mode 100644 src/Scenes/ClearColor.hs create mode 100644 src/Scenes/SceneClass.hs diff --git a/README.md b/README.md index 05e22bb..df72a22 100644 --- a/README.md +++ b/README.md @@ -24,6 +24,9 @@ to peruse it. ### Keyboard -* `1`, `2`: Switch input focus between the two displayed objects -* `X`/`Shift`+`X`: Move the focused object right/left -* `Y`/`Shift`+`Y`: Move the focused object up/down +To switch to a scene, press one of the buttons below + +## `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. diff --git a/renderer-tutorial.cabal b/renderer-tutorial.cabal index b015181..af3ce78 100644 --- a/renderer-tutorial.cabal +++ b/renderer-tutorial.cabal @@ -41,5 +41,7 @@ executable renderer-tutorial , Renderer , Texture , EventHandler + , Scenes.SceneClass + , Scenes.ClearColor hs-source-dirs: src default-language: Haskell2010 diff --git a/src/EventHandler.hs b/src/EventHandler.hs index 880dcca..d5f187b 100644 --- a/src/EventHandler.hs +++ b/src/EventHandler.hs @@ -84,7 +84,6 @@ switchObject focus elems evs = (SDL.Keysym code _ mod) )) -> do - print code let selectIndex = fromIntegral (SDL.toNumber code) - 30 if ((selectIndex < 10) && (selectIndex >= 0)) && (SDL.toNumber mod == 0) && diff --git a/src/Main.hs b/src/Main.hs index 583d941..5f5429e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,6 +4,7 @@ module Main where import SDL (($=), get) import qualified SDL +import qualified SDL.Internal.Numbered as SDL import qualified SDL.Raw.Video as SDL (glSetAttribute) import qualified SDL.Raw.Enum as SDL @@ -43,6 +44,9 @@ import Renderer import Texture import EventHandler +import Scenes.SceneClass +import Scenes.ClearColor + main :: IO () main = do @@ -78,93 +82,13 @@ main = do version <- peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_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 print $ "pre-loop errors: " <> show err - -- -- EVENTING AND DRAWING + -- -- Constructing Scenes - switch <- newMVar model1 - - -- -- UNBINDING ALL BUFFERS AND VERTEX ARRAYS - - unbind vao - unbind vbo - unbind ibo - unbind sp + -- Construct state machine for the Scenes + curScene <- newEmptyMVar :: IO (MVar Scene) -- -- LOOPING @@ -177,6 +101,8 @@ main = do -- poll again void $ swapMVar evs =<< SDL.pollEvents + currentEvents <- readMVar evs + -- -- OBEY THE HYPNOTOAD! -- clearcol <- GL.Color4 -- <$> (randomRIO (0, 1)) @@ -185,35 +111,19 @@ main = do -- <*> pure 1 -- GL.clearColor $= clearcol - -- clear previous frame - clear + hasSelect <- not <$> isEmptyMVar curScene + 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 - mproj <- readMVar proj - mview <- readMVar view + -- Switch to different scene on keyboard presses F1 thourgh F? - -- modify the mvars based on keystrokes - 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 + sceneSwitch curScene currentEvents err <- get GL.errors when (not $ null err) (print $ "loop errors: " <> show err) @@ -237,3 +147,26 @@ main = do -- This is the end. 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) diff --git a/src/Scenes/ClearColor.hs b/src/Scenes/ClearColor.hs new file mode 100644 index 0000000..cedd272 --- /dev/null +++ b/src/Scenes/ClearColor.hs @@ -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] diff --git a/src/Scenes/SceneClass.hs b/src/Scenes/SceneClass.hs new file mode 100644 index 0000000..045426b --- /dev/null +++ b/src/Scenes/SceneClass.hs @@ -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