finished episode 26

renderer-tutorial.cabal

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

src/Main.hs

@@ -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 IndexBuffer
-import Texture
+
 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)

src/Scenes/ClearColor.hs

@@ -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 =

src/Scenes/SceneClass.hs

@@ -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 ()
 

src/Scenes/Texture2D.hs

@@ -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
+    )