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.Render.Picture
|
|
import Dodge.Render.ShapePicture
|
|
import Dodge.Render.Walls
|
|
import Dodge.Render.Lights
|
|
import Geometry
|
|
import Render
|
|
import Data.Preload.Render
|
|
import Shader
|
|
import Shader.Poke
|
|
import Shader.Bind
|
|
import Shader.Data
|
|
import MatrixHelper
|
|
import Shader.ExtraPrimitive
|
|
import Shader.Parameters
|
|
import Picture.Data
|
|
|
|
import Foreign
|
|
import Control.Lens
|
|
import Control.Monad
|
|
import qualified Control.Monad.Parallel as MP
|
|
import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
|
|
import qualified SDL
|
|
import qualified Data.Vector.Unboxed.Mutable as UMV
|
|
import Graphics.GL.Core43
|
|
|
|
doDrawing :: RenderData -> Universe -> IO Word32
|
|
doDrawing pdata u = do
|
|
sTicks <- SDL.ticks
|
|
let w = _uvWorld u
|
|
cfig = _config u
|
|
rot = _cameraRot w
|
|
camzoom = _cameraZoom w
|
|
trans = _cameraCenter w
|
|
wins@(V2 winx winy) = V2 (_windowX cfig) (_windowY cfig)
|
|
resFact = resFactorNum $ cfig ^. graphics_resolution_factor
|
|
(wallPointsCol,windowPoints) = wallsAndWindows cfig w
|
|
lightPoints = lightsForGloom w
|
|
viewFroms@(V2 vfx vfy) = _cameraViewFrom w
|
|
viewFrom3d = Vector3 vfx vfy 20
|
|
shadV = _pictureShaders pdata
|
|
lwShad = _lightingWallShadShader pdata
|
|
-- bind as much data into vbos as feasible at this point
|
|
-- count mutable vectors setup
|
|
layerCounts <- UMV.replicate (numLayers*6) 0
|
|
shapeCounts <- UMV.replicate 3 0
|
|
wlwiflCounts <- UMV.replicate 3 0
|
|
-- attempt to poke in parallel
|
|
let (ws,wp) = worldSPic cfig w
|
|
MP.bindM3 (\ _ _ _ -> return ())
|
|
( pokeBindFoldableLayer shadV layerCounts wp)
|
|
( pokeWallsWindowsFloor
|
|
(shadVBOptr $ _wallTextureShader pdata)
|
|
(shadVBOptr $ _windowShader pdata)
|
|
(shadVBOptr $ _textureArrayShader pdata)
|
|
wlwiflCounts
|
|
wallPointsCol
|
|
windowPoints
|
|
(_floorTiles w)
|
|
)
|
|
( pokeShape
|
|
(_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
|
|
(_eboPtr $ _shapeEBO pdata)
|
|
(_eboPtr $ _silhouetteEBO pdata)
|
|
shapeCounts
|
|
ws
|
|
)
|
|
nShapeVs <- UMV.read shapeCounts 0
|
|
nIndices <- UMV.read shapeCounts 1
|
|
nSilIndices <- UMV.read shapeCounts 2
|
|
nWalls <- UMV.read wlwiflCounts 0
|
|
nWins <- UMV.read wlwiflCounts 1
|
|
nFls <- UMV.read wlwiflCounts 2
|
|
-- bind wall points, silhouette data, surface geometry
|
|
uncurry bindShaderBuffers $ unzip
|
|
[ ( _wallTextureShader pdata, nWalls)
|
|
, (_shapeShader pdata, nShapeVs)
|
|
, (_windowShader pdata, nWins)
|
|
, (_textureArrayShader pdata, nFls)
|
|
]
|
|
bindBuffer ElementArrayBuffer $= Just (_ebo $ _shapeEBO pdata)
|
|
bufferSubData
|
|
ElementArrayBuffer
|
|
WriteToBuffer
|
|
0
|
|
(fromIntegral $ glushortSize * nIndices)
|
|
(_eboPtr $ _shapeEBO pdata)
|
|
bindBuffer ElementArrayBuffer $= Just (_ebo $ _silhouetteEBO pdata)
|
|
bufferSubData
|
|
ElementArrayBuffer
|
|
WriteToBuffer
|
|
0
|
|
(fromIntegral $ glushortSize * nSilIndices)
|
|
(_eboPtr $ _silhouetteEBO pdata)
|
|
-- set the coordinate uniform ready for drawing elements using world coordinates
|
|
bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms
|
|
setViewportSize (round winx `div` resFact) (round winy `div` resFact)
|
|
bindFramebuffer Framebuffer $= fst (_fboBase pdata)
|
|
clearColor $= Color4 0 0 0 0
|
|
clear [ColorBuffer,DepthBuffer]
|
|
depthFunc $= Just Less
|
|
-- draw wall occlusions from the camera's point of view
|
|
currentProgram $= Just (_shadProg lwShad)
|
|
uniform (head $ _shadUnis lwShad) $= viewFrom3d
|
|
bindVertexArrayObject $= Just (_vao $ _shadVAO lwShad)
|
|
glDrawArrays
|
|
(marshalEPrimitiveMode $ _shadPrim lwShad)
|
|
0
|
|
(fromIntegral nWalls)
|
|
--draw walls onto base buffer
|
|
if cfig ^. graphics_wall_textured
|
|
then renderTextureWalls pdata nWalls
|
|
else renderBlankWalls pdata nWalls
|
|
--draw object pictures onto base buffer
|
|
renderLayer BottomLayer shadV layerCounts
|
|
--draw object shapes onto base buffer
|
|
let fs = _shapeShader pdata
|
|
currentProgram $= Just (_shadProg fs)
|
|
bindVertexArrayObject $= Just (_vao $ _shadVAO fs)
|
|
glDrawElements
|
|
(marshalEPrimitiveMode $ _shadPrim fs)
|
|
(fromIntegral nIndices)
|
|
GL_UNSIGNED_SHORT
|
|
nullPtr
|
|
--draw floor onto base buffer
|
|
-- nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w)
|
|
drawShader (_textureArrayShader pdata) nFls
|
|
--draw lightmap into its own buffer
|
|
bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
|
|
createLightMap
|
|
pdata
|
|
lightPoints
|
|
nWalls
|
|
nSilIndices
|
|
nIndices
|
|
(_graphics_object_shadows $ _config u)
|
|
(snd $ snd $ _fboBase pdata)
|
|
colorMask $= Color4 Enabled Enabled Enabled Enabled
|
|
clearColor $= Color4 0 0 0 0
|
|
--apply lightmap to base buffer
|
|
bindFramebuffer Framebuffer $= fst (_fboBase pdata)
|
|
textureBinding Texture2D $= Just (snd $ _fboLighting pdata)
|
|
blend $= Enabled
|
|
blendFunc $= (Zero, OneMinusSrcColor)
|
|
drawShader (_fullscreenShader pdata) 4
|
|
--draw bloom onto bloom buffer
|
|
bindFramebuffer Framebuffer $= fst (_fboBloom pdata)
|
|
clear [ColorBuffer]
|
|
depthFunc $= Just Less
|
|
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
|
depthMask $= Disabled
|
|
renderLayer BloomNoZWrite shadV layerCounts
|
|
depthMask $= Enabled
|
|
renderLayer BloomLayer shadV layerCounts
|
|
--depthMask $= Enabled
|
|
--setup downscale viewport for blurring bloom
|
|
setViewportSize (round winx `div` (2*resFact)) (round winy `div` (2*resFact))
|
|
bindFramebuffer Framebuffer $= fst (_fboHalf1 pdata)
|
|
depthFunc $= Just Always
|
|
textureBinding Texture2D $= Just (snd $ _fboBloom pdata)
|
|
blend $= Disabled
|
|
drawShader (_bloomBlurShader pdata) 4
|
|
replicateM_ 9 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata)
|
|
blend $= Enabled
|
|
setViewportSize (round winx `div` resFact) (round winy `div` resFact)
|
|
--draw clouds
|
|
bindFramebuffer Framebuffer $= fst (_fboCloud pdata)
|
|
depthFunc $= Just Lequal
|
|
depthMask $= Disabled
|
|
clearColor $= Color4 0.5 0.5 0.5 0
|
|
--blendFunc $= (SrcAlphaSaturate,One)
|
|
--blendColor $= Color4 0.5 0.5 0.5 0.5
|
|
--blendFuncSeparate $= ((SrcAlphaSaturate,One) , (One,OneMinusSrcAlpha))
|
|
blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha),(One,OneMinusSrcAlpha))
|
|
drawBuffers $= [FBOColorAttachment 0,NoBuffers]
|
|
clear [ColorBuffer]
|
|
renderLayer MidLayer shadV layerCounts
|
|
--renderWindows pdata windowPoints
|
|
drawShader (_windowShader pdata) nWins
|
|
when (_graphics_cloud_shadows cfig) $ do
|
|
----render transparency depths
|
|
depthMask $= Enabled
|
|
blend $= Disabled
|
|
drawBuffers $= [NoBuffers,FBOColorAttachment 1]
|
|
renderLayer MidLayer shadV layerCounts
|
|
drawShader (_windowShader pdata) nWins
|
|
----draw lightmap for cloud buffer
|
|
depthMask $= Disabled
|
|
blend $= Enabled
|
|
bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
|
|
createLightMap pdata lightPoints nWalls nSilIndices nIndices
|
|
(_graphics_object_shadows $ _config u)
|
|
(snd $ snd $ _fboCloud pdata)
|
|
colorMask $= Color4 Enabled Enabled Enabled Enabled
|
|
clearColor $= Color4 0 0 0 0
|
|
--apply lightmap to cloud buffer
|
|
clearColor $= Color4 0 0 0 0
|
|
bindFramebuffer Framebuffer $= fst (_fboCloud pdata)
|
|
depthMask $= Disabled
|
|
drawBuffers $= [FBOColorAttachment 0,NoBuffers]
|
|
depthFunc $= Just Always
|
|
textureBinding Texture2D $= Just (snd $ _fboLighting pdata)
|
|
blend $= Enabled
|
|
--blendFunc $= (Zero, OneMinusSrcAlpha)
|
|
blendFuncSeparate $= ((Zero, OneMinusSrcColor),(Zero, One))
|
|
drawShader (_fullscreenShader pdata) 4
|
|
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
|
|
--Draw blurred bloom onto base buffer
|
|
bindFramebuffer Framebuffer $= fst (_fboBase pdata)
|
|
blend $= Enabled
|
|
blendFunc $= (SrcAlpha, One)
|
|
textureBinding Texture2D $= Just (snd $ _fboHalf1 pdata)
|
|
drawShader (_fullscreenShader pdata) 4
|
|
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
|
|
--draw shadowed clouds onto base buffer
|
|
textureBinding Texture2D $= Just (fst $ snd $ _fboCloud pdata)
|
|
drawShader (_fullscreenShader pdata) 4
|
|
--set viewport for radial distortion
|
|
setViewportSize (round winx) (round winy)
|
|
depthFunc $= Just Always
|
|
blendFunc $= (One,Zero)
|
|
-- perform any radial distortion
|
|
case _distortions w of
|
|
[] -> do
|
|
bindTO $ fst $ snd $ _fboBase pdata
|
|
bindFramebuffer Framebuffer $= defaultFramebufferObject
|
|
--bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms
|
|
drawShader (_fullscreenShader pdata) 4
|
|
rds -> do
|
|
let bindDrawDist :: Distortion -> IO ()
|
|
bindDrawDist (RadialDistortion (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 = fst (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
|
|
depthFunc $= Just Always
|
|
blend $= Enabled
|
|
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
|
renderLayer DebugLayer shadV layerCounts
|
|
-- draw overlay
|
|
depthFunc $= Just Always
|
|
depthMask $= Disabled
|
|
blend $= Enabled
|
|
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
|
bufferUBO $ isoMatrix 0 1 (V2 0 0) (V2 2 2)
|
|
renderLayer FixedCoordLayer shadV layerCounts
|
|
renderFoldable shadV $ fixedCoordPictures u
|
|
depthMask $= Enabled
|
|
eTicks <- SDL.ticks
|
|
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
|
|
|
|
setViewportSize :: Int -> Int -> IO ()
|
|
setViewportSize x y = viewport $=
|
|
( Position 0 0
|
|
, Size (fromIntegral x) (fromIntegral y)
|
|
)
|
|
|
|
renderBlankWalls
|
|
:: RenderData
|
|
-> Int -- ^ number of walls
|
|
-> IO ()
|
|
renderBlankWalls pdata nWalls = do
|
|
cullFace $= Just Back
|
|
drawShader (_wallBlankShader pdata) nWalls
|
|
cullFace $= Nothing
|
|
|
|
renderTextureWalls
|
|
:: RenderData
|
|
-> Int -- ^ number of walls
|
|
-> IO ()
|
|
renderTextureWalls pdata nWalls = do
|
|
cullFace $= Just Back
|
|
drawShader (_wallTextureShader pdata) nWalls
|
|
cullFace $= Nothing
|