{- | 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,wallSPics) = wallsToDraw w lightPoints = lightsToRender cfig 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 -- attempt to poke in parallel let (ws,wp) = wallSPics <> worldSPic cfig w ( (nWalls, nWins , nFls),(nShapeVs, nIndices, nSilIndices) ) <- MP.bindM3 (\ _ wlwifl counts -> return (wlwifl,counts)) ( pokeBindFoldableLayer shadV layerCounts wp) ( pokeWallsWindowsFloor (shadVBOptr $ _wallTextureShader pdata) (shadVBOptr $ _windowShader pdata) (shadVBOptr $ _textureArrayShader pdata) wallPointsCol windowPoints (_floorTiles w) ) ( pokeShape (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) (_eboPtr $ _shapeEBO pdata) (_eboPtr $ _silhouetteEBO pdata) ws ) -- 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) unless (debugOn Remove_LOS cfig) $ 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 onto cloud buffer 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) -- bind base buffer for drawing bloom then clouds bindFramebuffer Framebuffer $= fst (_fboBase pdata) --Draw blurred bloom onto base buffer 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