231 lines
8.4 KiB
Haskell
231 lines
8.4 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.Window
|
|
import Dodge.Render.Picture
|
|
import Geometry
|
|
import Render
|
|
import Data.Preload.Render
|
|
import Shader
|
|
import Shader.Poke
|
|
import Shader.Bind
|
|
import Shader.Data
|
|
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
|
|
import qualified Data.Vector.Unboxed.Mutable as UMV
|
|
|
|
doDrawing :: RenderData -> World -> IO Word32
|
|
doDrawing pdata w = do
|
|
sTicks <- SDL.ticks
|
|
let rot = _cameraRot w
|
|
camzoom = _cameraZoom w
|
|
trans = _cameraCenter w
|
|
wins = V2 (getWindowX w) (getWindowY w)
|
|
(wallPointsCol,windowPoints) = wallsAndWindows w
|
|
lightPoints = lightsForGloom w
|
|
viewFroms = _cameraViewFrom w
|
|
shadV = _pictureShaders pdata
|
|
-- bind as much data into vbos as feasible at this point
|
|
-- poke wall points and colors
|
|
nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol
|
|
nSils <- pokePoint3s (shadVBOptr $ _lightingLineShadowShader pdata)
|
|
(_foregroundEdgeVerx w)
|
|
-- poke foreground geometry and floor
|
|
let addC (V2 xx yy) = V3 xx yy 0
|
|
nsurfVs <- pokePoint3s (shadVBOptr $ _lightingSurfaceShader pdata)
|
|
$ polyToTris (map addC $ screenPolygon w)
|
|
++ concatMap polyToGeoRender (foregroundPics w)
|
|
-- bind wall points, silhouette data, surface geometry
|
|
uncurry bindShaderBuffers $ unzip
|
|
[ ( _wallTextureShader pdata, nWalls)
|
|
, (_lightingLineShadowShader pdata, nSils)
|
|
, (_lightingSurfaceShader pdata, nsurfVs)
|
|
]
|
|
-- set the coordinate uniform ready for drawing elements using world coordinates
|
|
bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms
|
|
viewport $= (Position 0 0
|
|
, divideSize (w ^. config . shadow_resolution) $ Size (round $ fstV2 wins) (round $ sndV2 wins))
|
|
bindFramebuffer Framebuffer $= fst (_fboBase pdata)
|
|
clearColor $= Color4 0 0 0 0
|
|
clear [ColorBuffer,DepthBuffer]
|
|
depthFunc $= Just Less
|
|
if w ^. config . wall_textured
|
|
then renderTextureWalls pdata nWalls
|
|
else renderBlankWalls pdata nWalls
|
|
|
|
-- draw wall occlusions from your point of view
|
|
drawShader (_lightingOccludeShader pdata) nWalls
|
|
-- this might only work because the uniform has been correctly set
|
|
-- elsewhere, beware
|
|
|
|
renderFoldable shadV $ polysToPic $ foregroundPics w
|
|
|
|
layerCounts <- UMV.replicate (6*6) 0
|
|
pokeBindFoldableLayer shadV layerCounts $ worldPictures w
|
|
renderLayer 0 shadV layerCounts
|
|
|
|
nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w)
|
|
bindShaderBuffers [_textureArrayShader pdata] [nTextArrayVs]
|
|
drawShader (_textureArrayShader pdata) nTextArrayVs
|
|
|
|
bindFramebuffer Framebuffer $= fst (_fboBloom pdata)
|
|
clear [ColorBuffer]
|
|
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
|
|
|
renderLayer 1 shadV layerCounts
|
|
bindFramebuffer Framebuffer $= fst (_fboColor pdata)
|
|
clear [ColorBuffer]
|
|
depthMask $= Disabled
|
|
|
|
renderLayer 3 shadV layerCounts
|
|
renderLayer 4 shadV layerCounts
|
|
renderLayer 5 shadV layerCounts
|
|
|
|
depthMask $= Enabled
|
|
-- this is not ideal if the original is not divisible by 2
|
|
viewport $= (Position 0 0
|
|
, divideSize (2 * (w ^. config . shadow_resolution)) $ Size (round $ fstV2 wins) (round $ sndV2 wins))
|
|
bindFramebuffer Framebuffer $= fst (_fboFourth1 pdata)
|
|
depthFunc $= Just Always
|
|
textureBinding Texture2D $= Just (snd $ _fboBloom pdata)
|
|
blend $= Disabled
|
|
drawShader (_bloomBlurShader pdata) 4
|
|
replicateM_ 3 $ pingPongBetween (_fboFourth1 pdata) (_fboFourth2 pdata) (_bloomBlurShader pdata)
|
|
blend $= Enabled
|
|
viewport $= (Position 0 0
|
|
, divideSize (w ^. config . shadow_resolution) $ Size (round $ fstV2 wins) (round $ sndV2 wins))
|
|
|
|
bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
|
|
createLightMap pdata lightPoints nWalls nSils nsurfVs
|
|
colorMask $= Color4 Enabled Enabled Enabled Enabled
|
|
clearColor $= Color4 0 0 0 0
|
|
|
|
--blend $= Disabled
|
|
depthMask $= Disabled
|
|
depthFunc $= Just Always
|
|
|
|
bindFramebuffer Framebuffer $= fst (_fboBase pdata)
|
|
--drawShader (_fullscreenShader pdata) 4
|
|
--textureBinding Texture2D $= Just (snd3 $ _fbo2 pdata)
|
|
textureBinding Texture2D $= Just (snd $ _fboLighting pdata)
|
|
blend $= Enabled
|
|
blendFunc $= (Zero, OneMinusSrcAlpha)
|
|
drawShader (_fullscreenShader pdata) 4
|
|
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
|
|
|
|
textureBinding Texture2D $= Just (snd $ _fboColor pdata)
|
|
drawShader (_colorBlurShader pdata) 4
|
|
--textureBinding Texture2D $= Just (snd3 $ _fbo2 pdata)
|
|
blendFunc $= (SrcAlpha, One)
|
|
textureBinding Texture2D $= Just (snd $ _fboFourth1 pdata)
|
|
drawShader (_fullscreenShader pdata) 4
|
|
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
|
|
textureBinding Texture2D $= Just (snd $ _fboBloom pdata)
|
|
drawShader (_fullscreenShader pdata) 4
|
|
|
|
depthFunc $= Just Lequal
|
|
--mapM_ (uncurry $ drawShaderLay 2) (vnums IM.! 2)
|
|
renderLayer 2 shadV layerCounts
|
|
renderWindows pdata windowPoints
|
|
|
|
viewport $= (Position 0 0, Size (round $ fstV2 wins) (round $ sndV2 wins))
|
|
depthFunc $= Just Always
|
|
blendFunc $= (One,Zero)
|
|
-- perform any radial distortion
|
|
case _radDistortion w of
|
|
[] -> do
|
|
bindTO $ snd $ _fboBase pdata
|
|
bindFramebuffer Framebuffer $= defaultFramebufferObject
|
|
--bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms
|
|
drawShader (_fullscreenShader pdata) 4
|
|
rds -> do
|
|
let bindDrawDist :: (Point2,Point2,Point2,Float) -> IO ()
|
|
bindDrawDist ( V2 a b , V2 c d , V2 e f , g) = do
|
|
pokeArray (shadVBOptr $ _barrelShader pdata)
|
|
[a,b,c,d,e,f,g]
|
|
bindShaderBuffers [_barrelShader pdata] [1]
|
|
drawShader (_barrelShader pdata) 1
|
|
fboList = take (length rds - 1) (concat (repeat [fst $ _fbo2 pdata,fst $ _fbo3 pdata]))
|
|
++ [defaultFramebufferObject]
|
|
toList = snd (_fboBase pdata) : concat (repeat [snd $ _fbo2 pdata,snd $ _fbo3 pdata])
|
|
bindings = zipWith (>>) (map bindFBO fboList) (map bindTO toList)
|
|
activeTexture $= TextureUnit 1
|
|
zipWithM_ (>>) bindings $ map bindDrawDist rds
|
|
activeTexture $= TextureUnit 0
|
|
-- draw overlay
|
|
bufferUBO $ isoMatrix 0 1 (V2 0 0) (V2 2 2)
|
|
depthFunc $= Just Always
|
|
depthMask $= Disabled
|
|
blend $= Enabled
|
|
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
|
|
|
renderFoldable shadV $ fixedCoordPictures w
|
|
depthMask $= Enabled
|
|
|
|
eTicks <- SDL.ticks
|
|
return (eTicks - sTicks)
|
|
|
|
bindTO :: TextureObject -> IO ()
|
|
bindTO t = textureBinding Texture2D $= Just t
|
|
|
|
bindFBO :: FramebufferObject -> IO ()
|
|
bindFBO fb = bindFramebuffer Framebuffer $= fb
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- 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
|
|
-> Int -- ^ number of walls
|
|
-> IO ()
|
|
renderBlankWalls pdata nWalls = do
|
|
cullFace $= Just Back
|
|
drawShader (_wallBlankShader pdata) nWalls
|
|
cullFace $= Nothing
|
|
|
|
renderWindows
|
|
:: RenderData
|
|
-> [((Point2,Point2),Point4)] -- ^ List: wall positions and color
|
|
-> IO ()
|
|
renderWindows pdata wps = do
|
|
n <- poke224s (shadVBOptr $ _wallBlankShader pdata) wps
|
|
bindShaderBuffers [_wallBlankShader pdata] [n]
|
|
currentProgram $= Just (_shaderProgram $ _wallBlankShader pdata)
|
|
cullFace $= Just Back
|
|
drawShader (_wallBlankShader pdata) n
|
|
cullFace $= Nothing
|
|
|
|
renderTextureWalls
|
|
:: RenderData
|
|
-> Int -- ^ number of walls
|
|
-> IO ()
|
|
renderTextureWalls pdata nWalls = do
|
|
cullFace $= Just Back
|
|
drawShader (_wallTextureShader pdata) nWalls
|
|
cullFace $= Nothing
|