loop/src/Dodge/Render.hs

{- |
Contains the central drawing functions for the dodge loop. -}
module Dodge.Render 
    ( module Dodge.Render.Picture
    , doDrawing
    )
  where
import Dodge.Data
import Dodge.Config.Data
import Dodge.Base
--import Dodge.Render.HUD
--import Dodge.Render.MenuScreen
import Dodge.Render.Picture
--import Dodge.Render.PerspectiveMatrix
import Geometry
--import Picture
import Picture.Render
import Picture.Preload
import Shader
import MatrixHelper

import Foreign (Word32)
--import Control.Applicative
--import Control.Monad.State
import Control.Lens
import Control.Monad
import qualified Control.Foldl as F
import Data.Tuple.Extra
--import Data.List
--import Data.Bifunctor
--import Data.Function
--import qualified Data.IntMap.Strict as IM
--import qualified Data.Map as M
--import qualified Data.Set as S
import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
import qualified SDL

{- |
Central drawing function.
Returns a 'Word32' that should give the number of ticks it took to evaluate.
 -}
doDrawing :: RenderData -> World -> IO Word32
doDrawing pdata w = do
    sTicks <- SDL.ticks
    clear [ColorBuffer,DepthBuffer]
    let rot     = _cameraRot w
        camzoom    = _cameraZoom w
        trans = _cameraCenter w
        wins    = (getWindowX w,getWindowY w)
        wallPointsCol   = wallsPointsAndCols w
        windowPoints    = wallsWindows w
        lightPoints     = lightsForGloom' w
        viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w
        pic = worldPictures w
        wallPoints = map fst wallPointsCol
    -- set the coordinate uniforms ready for drawing elements using world coordinates
    setCommonUniforms pdata rot camzoom trans wins
    depthFunc $= Just Less
    pmat <- (newMatrix RowMajor $ perspectiveMatrix rot camzoom trans wins viewFroms) 
        :: IO (GLmatrix GLfloat)
    -- draw the lightmap. Probably changes the bound framebufferObject
    createLightMap pdata (w ^. config . shadow_resolution) wallPoints lightPoints viewFroms pmat
        (foregroundPics w)

--    -- set the coordinate uniforms ready for drawing elements using world coordinates
--    setCommonUniforms pdata rot camzoom trans wins

    -- draw the background. Assumes that depth testing is not enabled or that
    -- the depth buffer is ready to be drawn on
    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
    renderBackground pdata rot camzoom trans wins
    -- draw the walls
    depthFunc $= Just Less
    if w ^. config . wall_textured
        then renderTextureWalls pdata wallPointsCol pmat
        else renderBlankWalls pdata wallPointsCol pmat
    -- I believe a more apt name would be setCeilingDepth: stops drawing of objects
    -- at points that are behind the extension of walls to the screen edge
    _ <- setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat
    -- draw the first layer of pictures
    -- these will probably all be opaque
    _ <- renderFoldable pdata $ picToLTree (Just 0) pic
    -- reset blend so that light map doesn't apply
    -- useful for drawing vivid projectiles
    blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha) , (Zero,One))
    depthFunc $= Just Lequal
    _ <- renderFoldable pdata $ picToLTree (Just 1) pic
    -- reset blend so that light map applies again
    -- allows us to be certain these elements are drawn on top of those before,
    -- in case we want transparency effects
    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
    _ <- renderFoldable pdata $ picToLTree (Just 2) pic
    depthMask $= Disabled
    -- render transparent walls
    -- the ordering between these and transparent clouds perhaps presents a challenge
    renderBlankWalls pdata windowPoints pmat

    depthMask $= Enabled
    forM_ (_pictureShaders pdata) $ setPerpMatUniform rot camzoom trans wins viewFroms
    depthFunc $= Just Lequal
    _ <- renderFoldable pdata $ picToLTree (Just 0) (foregroundPics w)

    -- draw the fbo to the screen
    -- allows for post-processing
    -- first, bind the screen fbo
    bindFramebuffer Framebuffer $= defaultFramebufferObject
    -- we probably do not want to blend during this step
    blend $= Disabled
    depthFunc $= Just Always
    textureBinding Texture2D $= Just (snd3 $ _fbo2 pdata)
--    textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
--    generateMipmap' Texture2D
    if _crHP (you w) > 0 
        then do
            bindShaderBuffers [_fullscreenShader pdata] [4]
            drawShader (_fullscreenShader pdata) 4
        else do
            bindShaderBuffers [_grayscaleShader pdata] [4]
            drawShader (_grayscaleShader pdata) 4
    blend $= Enabled
    
    -- reset the coordinate uniforms for pictures that are drawn wrt to window
    -- coordinates
    resetShaderUniforms (map extractProgAndUnis $ _pictureShaders pdata)
    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
    _ <- renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w)
    eTicks <- SDL.ticks
    return (eTicks - sTicks)

--------------------------------------------------------------------------------

renderBlankWalls 
    :: RenderData 
    -> [((Point2,Point2),Point4)]   -- ^ List: wall positions and color
    -> GLmatrix GLfloat 
    -> IO ()
renderBlankWalls pdata wps pmat = do
    n <- F.foldM (pokeShader $ _wallBlankShader pdata) wps
    bindShaderBuffers [_wallBlankShader pdata] [n]
    currentProgram $= Just (_shaderProgram $ _wallBlankShader pdata)
    uniform (( _shaderMatrixUniform $ _wallBlankShader pdata) )
        $= pmat
    cullFace $= Just Back
    drawShader (_wallBlankShader pdata) n
    cullFace $= Nothing

renderTextureWalls 
    :: RenderData 
    -> [((Point2,Point2),Point4)]   -- ^ List: wall positions and color
    -> GLmatrix GLfloat 
    -> IO ()
renderTextureWalls pdata wps pmat = do
    n <- F.foldM (pokeShader $ _wallTextureShader pdata) wps
    bindShaderBuffers [_wallTextureShader pdata] [n]
    currentProgram $= Just (_shaderProgram $ _wallTextureShader pdata)
    uniform (( _shaderMatrixUniform $ _wallTextureShader pdata) )
        $= pmat
    cullFace $= Just Back
    drawShader (_wallTextureShader pdata) n
    cullFace $= Nothing