290 lines
11 KiB
Haskell
290 lines
11 KiB
Haskell
{- |
|
|
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 Render
|
|
import Data.Preload.Render
|
|
import Picture.Data
|
|
import Picture.Tree
|
|
import Shader
|
|
import Shader.Data
|
|
import Shader.Poke
|
|
import MatrixHelper
|
|
--import Polyhedra.Data
|
|
import Polyhedra
|
|
|
|
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
|
|
|
|
doDrawing :: RenderData -> World -> IO Word32
|
|
doDrawing pdata w = do
|
|
sTicks <- SDL.ticks
|
|
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
|
|
viewFroms = _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
|
|
bindFramebuffer Framebuffer $= (fst $ head $ fst $ _fbos pdata)
|
|
clearColor $= Color4 0 0 0 0
|
|
clear [ColorBuffer,DepthBuffer]
|
|
depthFunc $= Just Less
|
|
if w ^. config . wall_textured
|
|
then renderTextureWalls pdata wallPointsCol
|
|
else renderBlankWalls pdata wallPointsCol
|
|
-- _ <- setWallDepth pdata wallPoints (viewFromx,viewFromy)
|
|
_ <- renderFoldable pdata $ picToLTree (Just 0) (polysToPic $ foregroundPics w)
|
|
_ <- renderFoldable pdata $ picToLTree (Just 0) pic
|
|
_ <- renderShader (_textureArrayShader pdata) (_floorTiles w)
|
|
|
|
bindFramebuffer Framebuffer $= (fst $ (fst $ _fbos pdata) !! 1)
|
|
clear [ColorBuffer]
|
|
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
|
_ <- renderFoldable pdata $ picToLTree (Just 1) pic
|
|
depthMask $= Disabled
|
|
_ <- renderFoldable pdata $ picToLTree (Just 3) pic
|
|
_ <- renderFoldable pdata $ picToLTree (Just 4) pic
|
|
_ <- renderFoldable pdata $ picToLTree (Just 5) pic
|
|
|
|
depthMask $= Enabled
|
|
|
|
bindFramebuffer Framebuffer $= (fst $ (fst $ _fbos pdata) !! 2)
|
|
let scPol = screenPolygon w
|
|
createLightMap pdata (w ^. config . shadow_resolution) wallPoints lightPoints
|
|
(foregroundPics w) scPol
|
|
colorMask $= Color4 Enabled Enabled Enabled Enabled
|
|
depthMask $= Enabled
|
|
clearColor $= Color4 0 0 0 0
|
|
|
|
bindShaderBuffers [_fullscreenShader pdata] [4]
|
|
|
|
--bindFramebuffer Framebuffer $= defaultFramebufferObject
|
|
blend $= Disabled
|
|
depthFunc $= Just Always
|
|
--textureBinding Texture2D $= Just (snd $ head $ fst $ _fbos pdata)
|
|
--drawShader (_fullscreenShader pdata) 4
|
|
|
|
bindFramebuffer Framebuffer $= (fst $ head $ fst $ _fbos pdata)
|
|
--drawShader (_fullscreenShader pdata) 4
|
|
--textureBinding Texture2D $= Just (snd3 $ _fbo2 pdata)
|
|
textureBinding Texture2D $= Just (snd $ (fst $ _fbos pdata) !! 2)
|
|
textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
|
|
generateMipmap' Texture2D
|
|
blend $= Enabled
|
|
blendFunc $= (Zero, OneMinusSrcAlpha)
|
|
drawShader (_fullscreenShader pdata) 4
|
|
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
|
|
textureBinding Texture2D $= Just (snd $ (fst $ _fbos pdata) !! 1)
|
|
drawShader (_fullscreenShader pdata) 4
|
|
|
|
depthFunc $= Just Less
|
|
--_ <- renderFoldable pdata $ picToLTree (Just 2) pic
|
|
renderBlankWalls pdata windowPoints
|
|
|
|
depthFunc $= Just Always
|
|
bindFramebuffer Framebuffer $= defaultFramebufferObject
|
|
clear [ColorBuffer]
|
|
textureBinding Texture2D $= Just (snd $ head $ fst $ _fbos pdata)
|
|
drawShader (_fullscreenShader pdata) 4
|
|
|
|
-- draw overlay
|
|
bufferUBO $ isoMatrix 0 1 (0,0) (2,2)
|
|
--depthFunc $= Just Always
|
|
depthMask $= Enabled
|
|
blend $= Enabled
|
|
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
|
_ <- renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w)
|
|
|
|
eTicks <- SDL.ticks
|
|
return (eTicks - sTicks)
|
|
|
|
{- | 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
|
|
clearColor $= Color4 0 0 0 1
|
|
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
|
|
|
|
depthFunc $= Just Less
|
|
let scPol = screenPolygon w
|
|
-- draw the lightmap. Probably changes the bound framebufferObject
|
|
createLightMap pdata (w ^. config . shadow_resolution) wallPoints lightPoints
|
|
(foregroundPics w) scPol
|
|
clear [DepthBuffer]
|
|
|
|
nWalls <- F.foldM (pokeShader $ _lightingOccludeShader pdata) (map Render22 wallPoints)
|
|
bindShaderBuffers [_lightingOccludeShader pdata] [nWalls]
|
|
currentProgram $= Just (_shaderProgram $ _lightingOccludeShader pdata)
|
|
uniform (head $ _shaderCustomUnis $ _lightingOccludeShader pdata)
|
|
$= Vector2 viewFromx viewFromy
|
|
drawShader (_lightingOccludeShader pdata) nWalls
|
|
|
|
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)
|
|
_ <- renderFoldable pdata $ picToLTree (Just 0) (polysToPic $ foregroundPics w)
|
|
-- draw the first layer of pictures
|
|
-- these will probably all be opaque
|
|
_ <- renderFoldable pdata $ picToLTree (Just 0) pic
|
|
|
|
-- draw opaque background to screen
|
|
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
|
|
bindFramebuffer Framebuffer $= fst3 (_fbo2 pdata)
|
|
|
|
depthFunc $= Just Less
|
|
clearColor $= Color4 0 0 0 0
|
|
clear [ColorBuffer]
|
|
|
|
-- reset blend so that light map doesn't apply
|
|
-- useful for drawing vivid projectiles
|
|
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
|
_ <- renderFoldable pdata $ picToLTree (Just 1) pic
|
|
depthMask $= Disabled
|
|
_ <- renderFoldable pdata $ picToLTree (Just 3) pic
|
|
_ <- renderFoldable pdata $ picToLTree (Just 4) pic
|
|
_ <- renderFoldable pdata $ picToLTree (Just 5) pic
|
|
--depthFunc $= Just Lequal
|
|
--_ <- renderFoldable pdata $ picToLTree (Just 0) (polysToPic $ foregroundPics w)
|
|
--(Pictures $ concatmap (Poly3D 0 . _pyFaces) (foregroundPics w))
|
|
|
|
-- draw the fbo to the screen
|
|
-- allows for post-processing
|
|
-- first, bind the screen fbo
|
|
bindFramebuffer Framebuffer $= defaultFramebufferObject
|
|
blend $= Enabled
|
|
blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha),(Zero,One))
|
|
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
|
|
--depthMask $= Enabled
|
|
depthMask $= Disabled
|
|
depthFunc $= Just Less
|
|
-- 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
|
|
-- render transparent walls
|
|
-- the ordering between these and transparent clouds perhaps presents a challenge
|
|
renderBlankWalls pdata windowPoints
|
|
|
|
--depthMask $= Enabled
|
|
|
|
bufferUBO $ isoMatrix 0 1 (0,0) (2,2)
|
|
depthFunc $= Just Always
|
|
|
|
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
|
_ <- renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w)
|
|
eTicks <- SDL.ticks
|
|
depthMask $= Enabled
|
|
return (eTicks - sTicks)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- note: 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
|