diff --git a/renderer-tutorial.cabal b/renderer-tutorial.cabal index af3ce78..4c298c2 100644 --- a/renderer-tutorial.cabal +++ b/renderer-tutorial.cabal @@ -43,5 +43,6 @@ executable renderer-tutorial , EventHandler , Scenes.SceneClass , Scenes.ClearColor + , Scenes.Texture2D hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Main.hs b/src/Main.hs index 44cbdc6..e89d2b1 100644 --- a/src/Main.hs +++ b/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 Texture +import IndexBuffer + 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) diff --git a/src/Scenes/ClearColor.hs b/src/Scenes/ClearColor.hs index cedd272..e021953 100644 --- a/src/Scenes/ClearColor.hs +++ b/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 = diff --git a/src/Scenes/SceneClass.hs b/src/Scenes/SceneClass.hs index 045426b..d3ba717 100644 --- a/src/Scenes/SceneClass.hs +++ b/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 () diff --git a/src/Scenes/Texture2D.hs b/src/Scenes/Texture2D.hs new file mode 100644 index 0000000..953e4bd --- /dev/null +++ b/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 + )