{- | 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