schnell schnell

app/Classes/Renderable.hs

@@ -7,6 +7,8 @@ class Renderable a where
 
   type ShaderObjects a :: *
 
-  init :: IO ()
+  init :: VertexObjects a -> ShaderObjects a -> a -> IO ()
 
   draw :: VertexObjects a -> ShaderObjects a -> a -> IO ()
+
+  clean :: a -> IO ()

app/Main.hs

@@ -6,11 +6,12 @@ import Affection
 import SDL (($=))
 import qualified SDL
 
-import qualified Rendering.Graphics.OpenGL as GL
+import qualified Graphics.Rendering.OpenGL as GL
 
 import Codec.Picture
 
 import Control.Monad (void)
+import Control.Monad.IO.Class (liftIO)
 
 import Control.Concurrent.STM
 
@@ -19,6 +20,9 @@ import qualified Data.Map.Strict as M
 -- internal imports
 
 import Types
+import Types.Sprite
+import Renderer
+import Classes.Renderable as CR
 
 main :: IO ()
 main =
@@ -27,9 +31,9 @@ main =
     , windowTitle = "canvas"
     , windowConfigs =
       [ ( 0
-        , SDL.DefaultWindow
+        , SDL.defaultWindow
           { SDL.windowInitialSize = SDL.V2 1600 900
-          , SDL.windowGraphicsContext = SL.OpenGLContext SDL.defaultOpenGL
+          , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
             { SDL.glProfile = SDL.Core SDL.Normal 3 3
             }
           }
@@ -37,20 +41,20 @@ main =
       ]
     , initScreenMode = SDL.FullscreenDesktop
     , preLoop = return ()
-    , eventLoop = MapM_ handle
-    , updateLoop = updateLoop
-    , drawLoop = drawLoop
-    , loadState = loadState
+    , eventLoop = mapM_ handle
+    , updateLoop = updateLoopImpl
+    , drawLoop = drawLoopImpl
+    , loadState = loadStateImpl
     , cleanUp = (\_ -> return ())
     , canvasSize = Nothing
     }
 
-loadState :: IO UserData
-loadState = do
+loadStateImpl :: IO UserData
+loadStateImpl = do
   void $ SDL.setMouseLocationMode SDL.RelativeLocation
   GL.depthFunc $= Just GL.Less
 
-  subs <- Subsystms
+  subs <- Subsystems
     <$> (SubWindow <$> newTVarIO [])
     <*> (SubMouse <$> newTVarIO [])
   
@@ -63,11 +67,17 @@ loadState = do
       }
     }
 
-handle = return ()
+handle event = return ()
 
-updateLoop = return ()
+updateLoopImpl dt = return ()
 
-drawLoop = do
+drawLoopImpl = do
   ud@(UserData subs rassets) <- getAffection
-  let (RenderAssets sDetails@(svo sso sdo)) = rassets
-  mapM_ (draw svo sso) (assocs sdo)
+  let (RenderAssets sDetails@(AssetDetails svo sso sdo)) = rassets
+  liftIO $ do
+    CR.init
+      (svo :: VertexObjects Sprite)
+      (sso :: ShaderObjects Sprite)
+      (head $ M.elems sdo)
+    mapM_ (draw (svo :: VertexObjects Sprite) (sso :: ShaderObjects Sprite)) (M.elems sdo)
+    clean (head $ M.elems sdo)

app/Renderer.hs

@@ -3,9 +3,16 @@ module Renderer where
 import SDL (($=))
 
 import qualified Graphics.Rendering.OpenGL as GL
+import qualified Graphics.GLUtil as GLU
+
+import qualified Data.Map.Strict as M
 
 import qualified Data.ByteString as BS
 
+import Codec.Picture
+
+import Linear
+
 import Foreign
 
 -- internal imports
@@ -36,7 +43,7 @@ initSpriteRenderObjects = do
   GL.bindBuffer GL.ArrayBuffer $= Nothing
   GL.bindVertexArrayObject $= Nothing
 
-  return (RenderObjects quadVAO quadVBO)
+  return (SpriteRenderObjects quadVAO quadVBO)
   where
     rawVertices :: [Float]
     rawVertices =
@@ -53,33 +60,19 @@ initSpriteShaderObjects = do
   vertexShaderSrc <- BS.readFile "shader/vertex.sl"
   fragmentShaderSrc <- BS.readFile "shader/fragment.sl"
 
-  vertexShader <- GL.createShader Gl.VertexShader
-  fragmentShader <- GL.createShader Gl.FragmentShader
+  shaderProgram <- GLU.simpleShaderProgramBS vertexShaderSrc fragmentShaderSrc
 
-  GL.shaderSourceBS vertexShader $= vertexShaderSrc
-  GL.ShaderSourceBS fragmentShader $= fragmentShaderSrc
-
-  GL.compileShader vertexShader
-  GL.compileShader fragmentShader
-
-  shaderProgram <- GL.createProgram
-
-  GL.attachShader shaderProgram vertexShader
-  GL.attachShader shaderProgram fragmentShader
-
-  GL.linkProgram shaderProgram
-
-  return (SpriteShaderObjects vertexShader fragmentShader shaderProgram)
+  return (SpriteShaderObjects shaderProgram)
 
 loadSprites :: IO (AssetDetails SpriteRenderObjects SpriteShaderObjects Sprite)
 loadSprites = do
   rawImg <- readImage "assets/img/lynx.jpg"
-  let img = case eRawImg of
-    Left err -> error err
-    Right dynImg -> convertRGBA8 dynImg
+  let img = case rawImg of
+        Left err -> error err
+        Right dynImg -> convertRGBA8 dynImg
 
   vertObj <- initSpriteRenderObjects
-  shadObj <- initSpriteShaderobjects
+  shadObj <- initSpriteShaderObjects
 
   return AssetDetails
     { adVertObj = vertObj

app/Types/Sprite.hs

@@ -1,9 +1,10 @@
+{-# LANGUAGE TypeFamilies #-}
 module Types.Sprite where
 
 import SDL (get, ($=))
 
 import qualified Graphics.Rendering.OpenGL as GL
-import qualified Graphics.GLUtil as GLUtil
+import qualified Graphics.GLUtil as GLU
 
 import Codec.Picture
 
@@ -18,15 +19,13 @@ data SpriteRenderObjects = SpriteRenderObjects
   , roVBO :: GL.BufferObject
   }
 
-data SpriteShaderObjects = SpriteShaderobjects
-  { soVertexShader   :: GL.Shader
-  , soFragmentShader :: GL.Shader
-  , soProgram        :: GL.Program
+data SpriteShaderObjects = SpriteShaderObjects
+  { soProgram        :: GLU.ShaderProgram
   }
 
 data Sprite = Sprite
   { spritePosition :: V2 Int
-  , SpriteImage    :: Image PixelRGBA8
+  , spriteImage    :: Image PixelRGBA8
   }
 
 instance Renderable Sprite where
@@ -34,22 +33,20 @@ instance Renderable Sprite where
 
   type ShaderObjects Sprite = SpriteShaderObjects
 
-  init (SpriteRenderObjects vao vbo) = do
-    GL.currenProgram $= Just prog
+  init (SpriteRenderObjects vao vbo) (SpriteShaderObjects prog) _ = do
+    GL.currentProgram $= Just (GLU.program prog)
     GL.bindVertexArrayObject $= Just vao
 
   draw
     (SpriteRenderObjects vao vbo)
-    (SpriteShaderObjects vs fs prog)
+    (SpriteShaderObjects prog)
     (Sprite pos@(V2 px py) img) = do
       let model = mkTransformation
-            (Quaternion (V3 0 0 0) 1 :: Quaternion Float)
+            (Quaternion 1 (V3 0 0 0) :: Quaternion Float)
             (fmap fromIntegral $ V3 px py 0 :: V3 Float)
-      GLU.setUniform program "model" model
-      uLoc <- get (GL.uniformLocation prog "model")
-      GL.uniform uLoc $= model
+      GLU.setUniform prog "model" model
       GL.drawArrays GL.Triangles 0 6
 
-  clean =
-    GL.currenProgram $= Nothing
-    GL.bindVertexArrayObject $= Nothing
+  clean _ = do
+    GL.currentProgram $= (Nothing :: Maybe GL.Program)
+    GL.bindVertexArrayObject $= (Nothing :: Maybe GL.VertexArrayObject)

app/Types/UserData.hs

@@ -16,6 +16,8 @@ import Codec.Picture
 
 import Types.Sprite
 
+import Classes.Renderable
+
 data UserData = UserData
   { udSubsystems   :: Subsystems
   , udRenderAssets :: RenderAssets

canvas.cabal

@@ -29,10 +29,12 @@ executable canvas
                      , affection
                      , sdl2 ^>=2.5.0.0
                      , OpenGL
+                     , GLUtil
                      , JuicyPixels
                      , JuicyPixels-extra
                      , stm
                      , containers
                      , linear
+                     , bytestring
   hs-source-dirs:      app
   default-language:    Haskell2010

shader/fragment.sl

@@ -3,10 +3,10 @@ in vec2 TexCoords;
 out vec4 color;
 
 uniform sampler2D image;
-#uniform vec3 spriteColor;
+//uniform vec3 spriteColor;
 
 void main()
 {    
-    #color = vec4(spriteColor, 1.0) * texture(image, TexCoords);
+    //color = vec4(spriteColor, 1.0) * texture(image, TexCoords);
     color = texture(image, TexCoords);
 }