canvas/app/Types/Sprite.hs

{-# 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