canvas/app/Renderer.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
module Renderer where

import SDL (($=))

import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GL.Functions as GLRaw (glVertexAttribDivisor)
-- 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

import Control.Monad (replicateM)

import System.Random

-- internal imports

import Types

initSpriteRenderObjects aggModel = do
  quadVAO <- GL.genObjectName
  quadVBO <- GL.genObjectName
  quadInstances <- GL.genObjectName


  GL.bindBuffer GL.ArrayBuffer $= Just quadInstances

  withArray aggModel $ \ptr ->
    GL.bufferData GL.ArrayBuffer $=
      ( fromIntegral $ length aggModel * sizeOf (undefined :: Float)
      , ptr
      , GL.StaticDraw
      )

  GL.bindBuffer GL.ArrayBuffer $= Nothing

  GL.bindBuffer GL.ArrayBuffer $= Just quadVBO

  withArray rawVertices $ \ptr ->
    GL.bufferData GL.ArrayBuffer $=
      ( fromIntegral $ length rawVertices * sizeOf (undefined :: Float)
      , ptr
      , GL.StaticDraw
      )

  GL.bindVertexArrayObject $= Just quadVAO

  GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Enabled

  GL.vertexAttribPointer (GL.AttribLocation 0) $=
    ( GL.ToFloat
    , GL.VertexArrayDescriptor 4 GL.Float 0 (nullPtr)
    )

  mapM_
    (\intId -> do
      GL.bindBuffer GL.ArrayBuffer $= Just quadInstances

      GL.vertexAttribArray (GL.AttribLocation (3 + fromIntegral intId)) $=
        GL.Enabled
 
      GL.vertexAttribPointer (GL.AttribLocation (3 + fromIntegral intId)) $=
        ( GL.ToFloat
        , GL.VertexArrayDescriptor
          4
          GL.Float
          (fromIntegral $ 4 * 4 * (sizeOf (undefined :: GL.GLfloat)))
          (nullPtr `plusPtr` (intId * 4 * sizeOf (undefined :: GL.GLfloat)))
        )

      GL.bindBuffer GL.ArrayBuffer $= Nothing

      GLRaw.glVertexAttribDivisor (3 + fromIntegral intId) 1
      )
    ([ 0 .. 3 ] :: [Int])


  -- GL.bindBuffer GL.ArrayBuffer $= Nothing
  GL.bindVertexArrayObject $= Nothing

  return (SpriteRenderObjects quadVAO quadVBO)

rawVertices :: [Float]
rawVertices =
  [ 0, 1, 0, 1
  , 1, 0, 1, 0
  , 0, 0, 0, 0

  , 0, 1, 0, 1
  , 1, 1, 1, 1
  , 1, 0, 1, 0
  ]

initSpriteShaderObjects = do
  -- vertexShaderSrc <- BS.readFile "shader/vertex.sl"
  -- fragmentShaderSrc <- BS.readFile "shader/fragment.sl"

  vertexShader <- createShader VertexShader
  fragmentShader <- createShader FragmentShader

  vertexShaderSrc <- BS.readFile "shader/vertex.sl"
  fragmentShaderSrc <- BS.readFile "shader/fragment.sl"

  shaderSourceBS vertexShader $= vertexShaderSrc
  shaderSourceBS fragmentShader $= fragmentShaderSrc

  compileShader vertexShader
  get errors >>= mapM_ (hPutStrLn stderr . ("GL: "++) . show)
  vOK <- get (compileStatus vertexShader)
  infoLog <- get (shaderInfoLog vertexShader)
  unless (null infoLog || infoLog == "\NUL")
    (mapM_
      putStrLn
      ["Shader info log for '" ++ filePath ++ "':", infoLog, ""]
      )
  unless vOK $ do
    deleteObjectName vertexShader
    ioError (userError "vertexShader compilation failed")
  compileShader fragmentShader
  get errors >>= mapM_ (hPutStrLn stderr . ("GL: "++) . show)
  fOK <- get (compileStatus fragmentShader)
  infoLog <- get (shaderInfoLog fragmentShader)
  unless (null infoLog || infoLog == "\NUL")
    (mapM_
      putStrLn
      ["Shader info log for '" ++ filePath ++ "':", infoLog, ""]
      )
  unless fOK $ do
    deleteObjectName fragmentShader
    ioError (userError "fragmentShader compilation failed")

  -- shaderProgram <- GLU.simpleShaderProgramBS vertexShaderSrc fragmentShaderSrc

  shaderProgram <- createProgram
  attachShaders shaderProgram $= [vertexShader, fragmentShader]
  linkProgram shaderProgram
  get errors >>= mapM_ (hPutStrLn stderr . ("GL: "++) . show)


  return (SpriteShaderObjects shaderProgram)

initSpriteTextureObjects
  :: [(String, FilePath)]
  -> IO (M.Map AssetId (GL.TextureObject, V2 Int))
initSpriteTextureObjects lookupList = do
  M.fromList <$> mapM
    (\(name, fp) -> do
      -- texture <- Gl.genObjectName
      -- GL.bindBuffer GL.ArrayBuffer $= Just texture
      -- withArray rawVertices $ \ptr ->
      --   GL.bufferData GL.ArrayBuffer $=
      --     ( fromIntegral $ length rawVertices * sizeof (0 :: Float)
      --     , ptr
      --     , GL.StaticDraw
      --     )
      -- GL.vertexAttribPointer (GL.AttribLocation 1) $=
      --   ( GL.ToFloat
      --   , GL.VertexArrayDescriptor 2 GL.Float 0 (plusPtr nullPtr 0)
      --   )
      ts <- loadTex fp
      return (name, ts)
      )
    lookupList

loadTex :: FilePath -> IO (GL.TextureObject, V2 Int)
loadTex fp = do
  t <- either error id <$> GLU.readTexture fp
  img <- convertRGBA8 <$> either error id <$> readImage fp
  let size = V2 (imageWidth img) (imageHeight img)
  return (t, size)

loadSprites
  :: Int
  -> IO (AssetDetails SpriteRenderObjects SpriteShaderObjects Sprite)
loadSprites amount = do
  let lookups =
        [ ("lynx", "assets/img/lynx.png")
        ]
      -- positions =
      --   [ (V2 0 0)
      --   ]

  GL.texture GL.Texture2D $= GL.Enabled
  GLU.texture2DWrap $= (GL.Repeated, GL.ClampToEdge)
  GL.textureFilter GL.Texture2D $= ((GL.Nearest, Just GL.Nearest), GL.Nearest)
  GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat)
  GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Repeat)

  textObj <- initSpriteTextureObjects lookups

  positions <- replicateM amount $ do
    x <- randomRIO (-1, 1)
    y <- randomRIO (-1, 1)
    return (V2 x y)
  sizes <- mapM
    (\origSize -> do
      scale <- randomRIO (0.1, (2 :: Float))
      return (fmap (scale *) $
        (fmap fromIntegral origSize) / (V2 980 540))
      )
    (replicate amount (snd $ snd $ head $ M.assocs textObj))

  let aggModel :: [Float]
      !aggModel = foldl
        (\acc (pos@(V2 px py), size@(V2 sx sy)) ->
          let qMatrix =
                [ sx,  0,  0,  0
                , 0,  sy,  0,  0
                , 0,  0,  1,  0
                , fromIntegral px, fromIntegral py,  0,  1
                ]
          in (acc ++ qMatrix)
          )
        []
        (zip positions sizes)

  vertObj <- initSpriteRenderObjects aggModel
  shadObj <- initSpriteShaderObjects

  return AssetDetails
    { adVertObj = vertObj
    , adShadObj = shadObj
    , adTextObj = M.fromList $ map (\(k, v) -> (k, fst v)) (M.assocs textObj)
    , adDataObj = M.fromList $
      map
        (\(k, v) ->
          ( k
          , map (\pos -> Sprite pos (snd v)) positions
          )
          )
        (M.assocs textObj)
    }