Reorganise rendering in Dodge

2021-04-01 11:28:53 +02:00
parent e62ff391a5
commit 1e9a07d1c8
13 changed files with 217 additions and 113 deletions
@@ -0,0 +1,122 @@
+module Dodge.Render 
+    ( module Dodge.Render.Picture
+    , doDrawing
+    , doDrawing'
+    )
+  where
+import Dodge.Data
+import Dodge.Base
+
+import Dodge.Render.HUD
+import Dodge.Render.MenuScreen
+import Dodge.Render.Picture
+import Dodge.Render.PerspectiveMatrix
+
+import Geometry
+import Picture
+import Shader
+
+import Picture.Render
+import Picture.Preload
+
+import Data.Graph.Inductive.Query.DFS
+import Data.Graph.Inductive.Graph
+
+import Control.Monad.State
+import Data.List
+import Data.Bifunctor
+
+import Foreign (Word32)
+import Data.Function
+import Control.Applicative
+import Control.Lens
+import Data.Maybe
+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
+    clear [ColorBuffer,DepthBuffer]
+    let rot     = _cameraRot w
+        zoom    = _cameraZoom w
+        trans@(tranx,trany) = _cameraCenter w
+        wins@(winx,winy)    = (_windowX w,_windowY w)
+        wallPointsCol   = wallsPointsAndCols w
+        windowPoints    = wallsWindows w
+        lightPoints     = lightsForGloom' w
+        viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w
+        pic = worldPictures w
+        wallPoints = map fst wallPointsCol
+    setCommonUniforms pdata rot zoom trans wins
+    depthFunc $= Just Less
+    pmat <- (newMatrix RowMajor $ perspectiveMatrix w) :: IO (GLmatrix GLfloat)
+    createLightMap pdata rot zoom trans wins wallPoints lightPoints viewFroms pmat
+    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
+--    clear [DepthBuffer]
+    depthFunc $= Just Always
+    renderBackground pdata rot zoom trans wins
+    depthFunc $= Just Lequal
+    renderWalls pdata wallPointsCol pmat
+    setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat
+--    depthFunc $= Just Lequal
+    renderFoldable pdata $ picToLTree (Just 0) pic
+-- reset blend so that light map doesn't apply
+--    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+    blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha) , (Zero,One))
+--    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+    renderFoldable pdata $ picToLTree (Just 1) pic
+
+-- set drawing for on top
+    blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
+
+    renderFoldable pdata $ picToLTree (Just 2) pic
+
+    depthMask $= Disabled
+    renderWalls pdata windowPoints pmat
+    depthMask $= Enabled
+
+    resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)
+----------------------
+    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+    renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w)
+    eTicks <- SDL.ticks
+    return (eTicks - sTicks)
+doDrawing' :: RenderData -> World -> IO (Word32)
+doDrawing' pdata w = do
+    bindFramebuffer Framebuffer $= defaultFramebufferObject
+    sTicks <- SDL.ticks
+    clear [ColorBuffer,DepthBuffer]
+    let rot     = _cameraRot w
+        zoom    = _cameraZoom w
+        trans@(tranx,trany) = _cameraCenter w
+        wins@(winx,winy)    = (_windowX w,_windowY w)
+        wallPointsCol   = wallsPointsAndCols w
+        windowPoints    = wallsWindows w
+        lightPoints     = lightsForGloom' w
+        viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w
+        pic = worldPictures w
+        wallPoints = map fst wallPointsCol
+    pmat <- (newMatrix RowMajor 
+                $ perspectiveMatrix w) :: IO (GLmatrix GLfloat)
+    setCommonUniforms pdata rot zoom trans wins
+
+    depthMask $= Disabled
+    renderBackground pdata rot zoom trans wins
+    depthMask $= Enabled
+    blend $= Enabled
+    blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
+    -- not sure why renderWalls and setWallDepth aren't combined
+    renderWalls pdata wallPointsCol pmat
+    setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat
+    depthFunc $= Just Lequal
+    renderFoldable pdata $ picToLTree (Just 0) pic
+    renderFoldable pdata $ picToLTree (Just 1) pic
+    renderFoldable pdata $ picToLTree (Just 2) pic
+    eTicks <- SDL.ticks
+    return (eTicks - sTicks)
+