finished episode 24

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.

renderer-tutorial.cabal

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

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) &&

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)

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]

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