too much in too little time

app/Classes/Renderable.hs

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

app/Main.hs

@@ -1,10 +1,73 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Main where
 
 import Affection
 
+import SDL (($=))
+import qualified SDL
+
+import qualified Rendering.Graphics.OpenGL as GL
+
+import Codec.Picture
+
+import Control.Monad (void)
+
+import Control.Concurrent.STM
+
+import qualified Data.Map.Strict as M
+
 -- internal imports
 
 import Types
 
 main :: IO ()
-main = putStrLn "Hello, Haskell!"
+main =
+  withAffection AffectionConfig
+    { initComponents = All
+    , windowTitle = "canvas"
+    , windowConfigs =
+      [ ( 0
+        , SDL.DefaultWindow
+          { SDL.windowInitialSize = SDL.V2 1600 900
+          , SDL.windowGraphicsContext = SL.OpenGLContext SDL.defaultOpenGL
+            { SDL.glProfile = SDL.Core SDL.Normal 3 3
+            }
+          }
+        )
+      ]
+    , initScreenMode = SDL.FullscreenDesktop
+    , preLoop = return ()
+    , eventLoop = MapM_ handle
+    , updateLoop = updateLoop
+    , drawLoop = drawLoop
+    , loadState = loadState
+    , cleanUp = (\_ -> return ())
+    , canvasSize = Nothing
+    }
+
+loadState :: IO UserData
+loadState = do
+  void $ SDL.setMouseLocationMode SDL.RelativeLocation
+  GL.depthFunc $= Just GL.Less
+
+  subs <- Subsystms
+    <$> (SubWindow <$> newTVarIO [])
+    <*> (SubMouse <$> newTVarIO [])
+  
+  rawImg <- readImage "assets/img/lynx.jpg"
+  let img = case eRawImg of
+    Left err -> error err
+    Right dynImg -> convertRGBA8 dynImg
+
+  return UserData
+    { udSubsystems = subs
+    , udAssetSprites = M.singleton "lynx" (Sprite (V2 0 0) img)
+    }
+
+handle = return ()
+
+updateLoop = return ()
+
+drawLoop = do
+  ud@(UserData subs sprites) <- getAffection
+  draw

app/Renderer.hs

@@ -4,9 +4,15 @@ import SDL (($=))
 
 import qualified Graphics.Rendering.OpenGL as GL
 
+import qualified Data.ByteString as BS
+
 import Foreign
 
-initSpriteRenderData = do
+-- internal imports
+
+import Types
+
+initSpriteRenderObjects = do
   quadVAO <- GL.genObjectName
   quadVBO <- GL.genObjectName
 
@@ -29,6 +35,8 @@ initSpriteRenderData = do
 
   GL.bindBuffer GL.ArrayBuffer $= Nothing
   GL.bindVertexArrayObject $= Nothing
+
+  return (RenderObjects quadVAO quadVBO)
   where
     rawVertices :: [Float]
     rawVertices =
@@ -40,3 +48,23 @@ initSpriteRenderData = do
       , 1, 1, 1, 1
       , 1, 0, 1, 0
       ]
+
+initSpriteShaderObjects = do
+  vertexShaderSrc <- BS.readFile "shader/vertex.sl"
+  fragmentShaderSrc <- BS.readFile "shader/fragment.sl"
+
+  vertexShader <- GL.createShader Gl.VertexShader
+  fragmentShader <- GL.createShader Gl.FragmentShader
+
+  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

app/Types.hs

@@ -3,3 +3,4 @@ module Types
   ) where
 
 import Types.UserData as T
+import Types.Sprite as T

app/Types/Renderer.hs

@@ -1,15 +0,0 @@
-module Types.Renderer where
-
-import Graphics.Rendering.OpenGL as GL
-
-data RenderObjects = RenderObjects
-  { roVAO :: GL.VertexArrayObject
-  , roVBO :: GL.BufferObject
-  }
-
-data GL.Uniform u => ShaderObjects u = Shaderobjects
-  { soVertexShader   :: GL.Shader
-  , soFragmentShader :: GL.Shader
-  , soProgram        :: GL.Program
-  , soUniforms       :: [(String, u)]
-  }

app/Types/Sprite.hs

@@ -0,0 +1,55 @@
+module Types.Sprite where
+
+import SDL (get, ($=))
+
+import qualified Graphics.Rendering.OpenGL as GL
+import qualified Graphics.GLUtil as GLUtil
+
+import Codec.Picture
+
+import Linear
+
+-- internal imports
+
+import Classes.Renderable
+
+data SpriteRenderObjects = SpriteRenderObjects
+  { roVAO :: GL.VertexArrayObject
+  , roVBO :: GL.BufferObject
+  }
+
+data SpriteShaderObjects = SpriteShaderobjects
+  { soVertexShader   :: GL.Shader
+  , soFragmentShader :: GL.Shader
+  , soProgram        :: GL.Program
+  }
+
+data Sprite = Sprite
+  { spritePosition :: V2 Int
+  , SpriteImage    :: Image PixelRGBA8
+  }
+
+instance Renderable Sprite where
+  type VertexObjects Sprite = SpriteRenderObjects
+
+  type ShaderObjects Sprite = SpriteShaderObjects
+
+  init (SpriteRenderObjects vao vbo) = do
+    GL.currenProgram $= Just prog
+    GL.bindVertexArrayObject $= Just vao
+
+  draw
+    (SpriteRenderObjects vao vbo)
+    (SpriteShaderObjects vs fs prog)
+    (Sprite pos@(V2 px py) img) = do
+      let model = mkTransformation
+            (Quaternion (V3 0 0 0) 1 :: 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
+      GL.drawArrays GL.Triangles 0 6
+
+  clean =
+    GL.currenProgram $= Nothing
+    GL.bindVertexArrayObject $= Nothing

app/Types/UserData.hs

@@ -12,9 +12,13 @@ import qualified Data.Map.Strict as M
 
 import Codec.Picture
 
+-- internal imports
+
+import Types.Sprite
+
 data UserData = UserData
   { udSubsystems  :: Subsystems
-  , udAssetImages :: M.Map ImgId (Image PixelRGBA8)
+  , udAssetSprites :: M.Map ImgId Sprite
   }
 
 type ImgId = String

canvas.cabal

@@ -21,6 +21,7 @@ executable canvas
   main-is:             Main.hs
   other-modules:       Types
                        Types.UserData
+                       Types.Sprite
                        Classes.Renderable
                        Renderer
   -- other-extensions:
@@ -30,7 +31,8 @@ executable canvas
                      , OpenGL
                      , JuicyPixels
                      , JuicyPixels-extra
-		     , stm
-		     , containers
+                     , stm
+                     , containers
+                     , linear
   hs-source-dirs:      app
   default-language:    Haskell2010

shader/fragment.sl

@@ -3,9 +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);
 }