loop/src/Picture/Render.hs

--{-# LANGUAGE Strict #-}
{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
module Picture.Render
    ( module Picture.Render
    , picToLTree
    )
    where

import Shader

import Control.Lens
import Control.Monad

import qualified Control.Applicative as Ap

import Linear.Matrix
import Linear.V4

import qualified Control.Foldl as F

import Data.Bifunctor

import Picture.Data
import Picture.Tree
import Geometry

import Picture.Preload

import Foreign hiding (rotate)

import Codec.Picture

import Graphics.GL.Core43

import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,imageWidth,Polygon,Color,T)
import qualified Graphics.Rendering.OpenGL as GL

import Data.Foldable
import Data.List
import Data.Maybe (fromJust)

--import qualified Data.Vector.Storable as V
import qualified Data.IntMap as IM
--import qualified Data.DList as DL

--import Control.DeepSeq

import qualified SDL as SDL

pokeTwoOff :: Ptr Float -> Int -> (Float,Float) -> IO ()
{-# INLINE pokeTwoOff #-}
pokeTwoOff ptr n (x,y) = do
    pokeElemOff ptr (2*n+0) x
    pokeElemOff ptr (2*n+1) y
pokeThreeOff :: Ptr Float -> Int -> (Float,Float,Float) -> IO ()
{-# INLINE pokeThreeOff #-}
pokeThreeOff ptr n (x,y,z) = do
    pokeElemOff ptr (3*n+0) x
    pokeElemOff ptr (3*n+1) y
    pokeElemOff ptr (3*n+2) z
pokeFourOff :: Ptr Float -> Int -> (Float,Float,Float,Float) -> IO ()
{-# INLINE pokeFourOff #-}
pokeFourOff ptr n (x,y,z,w) = do
    pokeElemOff ptr (4*n+0) x
    pokeElemOff ptr (4*n+1) y
    pokeElemOff ptr (4*n+2) z
    pokeElemOff ptr (4*n+3) w

renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) ->
                    [(Point2,Point2,Point2,Point2)] -> [Point4] -> Picture -> IO (Word32,Word32)
renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do
    wallPokeStart <- SDL.ticks

-- setting the depth function to less, instead of lequal, 
-- seems to stop a lot of unecessary drawing
-- of wall shadows when creating the light map
    depthFunc $= Just Less

-- set common uniforms
    setShaderUniforms rot zoom (tranx,trany) (winx,winy) 
        ( (extractProgAndUnis $ _lightSourceShader pdata) 
        : (extractProgAndUnis $ _wallShadowShader pdata) 
        : (extractProgAndUnis $ _backgroundShader pdata) 
        : (map extractProgAndUnis $ _listShaders pdata)
        )

-- draw lightmap

    nWalls <- F.foldM (pokeShader (_wallShadowShader pdata)) wallPoints
    bindShaderBuffers [_wallShadowShader pdata] [nWalls]

    forM_ lightPoints $ \(x,y,r,lum) -> do
        cullFace $= Just Front
        clear [DepthBuffer]

-- currentProgram does get called twice: here and inside drawShader below
        currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
        uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
            $= Vector2 (x) (y)
        blendFunc $= (Zero,One)
        drawShader (_wallShadowShader pdata) nWalls

        cullFace $= Nothing
        
        let lightPtr = (\(_,ptr,_) -> ptr) $ head 
                            $ _vaoBufferTargets $ _shaderVAO $ _lightSourceShader pdata
        pokeFourOff lightPtr 0 (x,y,r,lum)
        bindShaderBuffers [_lightSourceShader pdata] [1]
        
        blendFuncSeparate    $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
        drawShader (_lightSourceShader pdata) 1

    startWallTicks <- SDL.ticks
    wallPokeEnd <- SDL.ticks
    ticksS <- SDL.ticks
    ticksAfterL <- SDL.ticks

-- draw picture on top of light/shadow map
-- set drawing for on top
    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
    clear [DepthBuffer]
-- draw background
    bindArrayBuffers 1 $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata
    depthFunc $= Just Less

    currentProgram $= Just (_shaderProgram $ _backgroundShader pdata)
    bindVertexArrayObject $= Just (_vao $ _shaderVAO $ _backgroundShader pdata)
    let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata
        backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata) !! 1
    pokeFourOff backPtr 0 (tranx,trany,rot,zoom)
    pokeTwoOff backPtr2 0  (winx,winy)
    textureBinding Texture2D $= (fmap _textureObject $ _shaderTexture $ _backgroundShader pdata)
    drawArrays Points (fromIntegral 0) (fromIntegral 1)

    depthFunc $= Just Lequal

-- draw layer 0
    ticks2 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 0) pic
                                                        --((picToAlt 0 pic) :: [RenderType])
-- reset blend so that light map doesn't apply
    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
    ticks3 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 1) pic
-- set drawing for on top
    aticks <- SDL.ticks
    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
    ticks4 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic
    bticks <- SDL.ticks

    resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)

    endWallTicks <- SDL.ticks
    --return (ticksAfterL, ticks2+ticks3+ticks4, endWallTicks - startWallTicks)
    ticksE <- SDL.ticks
    --return (ticksAfterL, ticksE - ticksS)
    --return (ticksAfterL, ticks2 + ticks3 + ticks4)
    return (ticksAfterL, wallPokeEnd - wallPokeStart)

bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral

renderFoldable :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
                    -> f RenderType -> IO Word32
renderFoldable pdata rot zoom (tranx,trany) (winx,winy) tree = do
    pokeStartTicks <- SDL.ticks

    let slist = _listShaders pdata

-- poke data, returns list of number of vertices for each shader
    is <- F.foldM (pokeShaders slist) tree

-- the idea of doing as binding of buffers at once, rather than interweaving with draw
-- calls, is to prevent opengl from waiting for a draw call to finish
-- before it performs another state change
    bindShaderBuffers slist is

    drawShaders slist is
    
    pokeEndTicks <- SDL.ticks
    return $ pokeEndTicks - pokeStartTicks