canvas/app/Types/Sprite.hs
2020-05-13 05:42:32 +02:00

86 lines
2.3 KiB
Haskell

{-# LANGUAGE TypeFamilies #-}
module Types.Sprite where
import Data.Maybe (maybe)
import qualified Data.Map.Strict as M
import SDL (get, ($=))
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GL.Core33 as GLRaw
-- import qualified Graphics.GLUtil as GLU
import Codec.Picture
import Linear
import Foreign.Ptr
import Foreign.Marshal.Utils (with)
import Unsafe.Coerce (unsafeCoerce)
-- internal imports
import Classes.Renderable
import Types.CanvasShader
data SpriteRenderObjects = SpriteRenderObjects
{ roVAO :: GL.VertexArrayObject
, roVBO :: GL.BufferObject
}
data SpriteShaderObjects = SpriteShaderObjects
{ soProgram :: CanvasShader
}
data Sprite = Sprite
{ spritePosition :: V2 Int
, spriteSize :: V2 Int
}
instance Renderable Sprite where
type VertexObjects Sprite = SpriteRenderObjects
type ShaderObjects Sprite = SpriteShaderObjects
init
(SpriteRenderObjects vao vbo)
(SpriteShaderObjects (CanvasShader att uni prog))
texture
_ = do
GL.currentProgram $= Just prog
GL.bindVertexArrayObject $= Just vao
GL.activeTexture $= GL.TextureUnit 0
GL.textureBinding GL.Texture2D $= Just texture
-- let projection = ortho (-960) 960 (-540) 540 (-1) 1 :: M44 Float
-- GLU.setUniform prog "projection" (projection)
draw
(SpriteRenderObjects vao vbo)
(SpriteShaderObjects (CanvasShader att uni prog))
(Sprite pos@(V2 px py) size) = do
let (V2 sx sy) = fmap fromIntegral size
model = fmap (fmap fromIntegral) $ V4
(V4 sx 0 0 px)
(V4 0 sy 0 py)
(V4 0 0 1 0)
(V4 0 0 0 1)
:: M44 Float
projection = ortho (-960) 960 (-540) 540 (-1) 1
-- putStrLn $ show model
maybe
(const (putStrLn warn >> return ()))
(flip asUniform . fst)
(M.lookup "pm" uni)
(projection !*! model)
GL.drawArrays GL.Triangles 0 6
where
warn = "WARNING: uniform pm is not active"
v `asUniform` loc = with v $ GLRaw.glUniformMatrix4fv (unsafeCoerce loc) 1 1 . castPtr
clean _ = do
GL.currentProgram $= (Nothing :: Maybe GL.Program)
GL.bindVertexArrayObject $= (Nothing :: Maybe GL.VertexArrayObject)
GL.texture GL.Texture2D $= GL.Disabled