loop/src/Dodge/Render.hs

{- |
Contains the central drawing functions for the dodge loop. -}
module Dodge.Render 
    ( 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 Geometry.Data
--import Picture
import Picture.Render
import Data.Preload.Render
import Picture.Data
import Picture.Tree
import Shader
import Shader.Data
import Shader.Poke
import MatrixHelper

import Foreign
--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 uniform ready for drawing elements using world coordinates
    bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms

    -- store floor position into buffer
    let addC (xx,yy) = (xx,yy,0.1)
    nsurfVs <- F.foldM (pokeShader (_lightingSurfaceShader pdata)) [Render3 
        $ polyToTris $ map addC $ screenPolygon w ]
    bindShaderBuffers [_lightingSurfaceShader pdata] [nsurfVs]


    depthFunc $= Just Less
    -- draw the lightmap. Probably changes the bound framebufferObject
    createLightMap pdata (w ^. config . shadow_resolution) wallPoints lightPoints viewFroms
        (foregroundPics w)
    clear [DepthBuffer]
    depthFunc $= Just Less
    -- set blending to depend upon the alpha level already present
    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
    _ <- renderShader (_textureArrayShader pdata) (_floorTiles w)

    -- draw the walls
    if w ^. config . wall_textured
        then renderTextureWalls pdata wallPointsCol
        else renderBlankWalls pdata wallPointsCol
    -- 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)
    -- 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

    depthMask $= Enabled
    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
    
    bufferUBO $ perspectiveMatrixc 0 1 (0,0) (2,2)

    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
    _ <- renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w)
    eTicks <- SDL.ticks
    return (eTicks - sTicks)

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

-- note we currently assume there is only one UBO, we only bind it once at setup
bufferUBO :: [Float] -> IO ()
bufferUBO mat = withArray mat $ \ptr ->
    bufferSubData UniformBuffer WriteToBuffer 0 64 ptr

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

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