too much in too little time

This commit is contained in:
nek0 2020-02-07 05:50:19 +01:00
parent 6c2b46751b
commit 5a9fa0300e
10 changed files with 163 additions and 24 deletions

View file

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

View file

@ -1,10 +1,73 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where module Main where
import Affection 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 -- internal imports
import Types import Types
main :: IO () 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

View file

@ -4,9 +4,15 @@ import SDL (($=))
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import qualified Data.ByteString as BS
import Foreign import Foreign
initSpriteRenderData = do -- internal imports
import Types
initSpriteRenderObjects = do
quadVAO <- GL.genObjectName quadVAO <- GL.genObjectName
quadVBO <- GL.genObjectName quadVBO <- GL.genObjectName
@ -29,6 +35,8 @@ initSpriteRenderData = do
GL.bindBuffer GL.ArrayBuffer $= Nothing GL.bindBuffer GL.ArrayBuffer $= Nothing
GL.bindVertexArrayObject $= Nothing GL.bindVertexArrayObject $= Nothing
return (RenderObjects quadVAO quadVBO)
where where
rawVertices :: [Float] rawVertices :: [Float]
rawVertices = rawVertices =
@ -40,3 +48,23 @@ initSpriteRenderData = do
, 1, 1, 1, 1 , 1, 1, 1, 1
, 1, 0, 1, 0 , 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

View file

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

View file

@ -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)]
}

55
app/Types/Sprite.hs Normal file
View file

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

View file

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

BIN
assets/img/lynx.jpg Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 227 KiB

View file

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

View file

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