Refactor framebuffer update

appDodge/Main.hs

@@ -27,9 +27,10 @@ import Music
 import Preload
 import Preload.Render
 --import Render
+
+import SDL (($=))
 import qualified SDL
 import qualified SDL.Mixer as Mix
-import SDL (($=))
 import Sound
 import System.Directory
 
@@ -77,27 +78,25 @@ firstWorldLoad :: Configuration -> IO Universe
 firstWorldLoad theConfig = do
     SDL.cursorVisible $= False
     pdata <- doPreload >>= applyWorldConfig theConfig
-    --return $ startNewGame $ Universe
     cancontinue <- doesFileExist "saveSlot/0"
     mseed <- loadSeed
-    let u = Universe
+    let u =
-            { --{_uvWorld = initialWorld
+            Universe
-              _uvWorld = splashScreen
+                { _uvWorld = splashScreen
-            , _uvConfig = theConfig
+                , _uvConfig = theConfig
-            , _preloadData = pdata
+                , _preloadData = pdata
-            , _uvScreenLayers = []
+                , _uvScreenLayers = []
-            , _uvIOEffects = return
+                , _uvIOEffects = return
-            , _uvTestString = testStringInit
+                , _uvTestString = testStringInit
-            , _uvSideEffects = mempty
+                , _uvSideEffects = mempty
-            , _uvCanContinue = cancontinue
+                , _uvCanContinue = cancontinue
-            , _uvMSeed = mseed
+                , _uvMSeed = mseed
-            , _uvLastFrameTicks = 0
+                , _uvLastFrameTicks = 0
-            , _uvFrameTicks = 0
+                , _uvFrameTicks = 0
-            }
+                }
     return $
         Universe
-            { --{_uvWorld = initialWorld
+            { _uvWorld = splashScreen
-              _uvWorld = splashScreen
             , _uvConfig = theConfig
             , _preloadData = pdata
             , _uvScreenLayers = [splashMenu u]
@@ -115,8 +114,7 @@ theUpdateStep win = doSideEffects <=< updateRenderSplit win
 
 updateRenderSplit :: SDL.Window -> Universe -> IO Universe
 updateRenderSplit win u = do
-    let preData = _preloadData u
+    updateUniverse u `par` void (doDrawing win u)
-    updateUniverse u `par` void (doDrawing win (_renderData preData) u)
     return $! updateUniverse u
 
 playSoundUnlessRewinding :: Universe -> IO (M.Map SoundOrigin Sound)

src/Data/Preload/Render.hs

@@ -40,6 +40,7 @@ data RenderData = RenderData
     , _fboCloud :: (FBO, (TO, TO, TO))
     , _fboBloom :: (FBO, TO)
     , _fboPos :: (FBO, TO)
+    , _fboOverlay :: (FBO, TO)
     , _fboLighting :: (FBO, TO)
     , _fboShadow :: (FBO, (TO, TO))
     , _rboBaseBloom :: GLuint -- RenderbufferObject id

src/Dodge/Config/Update.hs

@@ -3,7 +3,6 @@ IO actions that apply config side effects and save configuration settings to dis
 -}
 module Dodge.Config.Update (
     saveConfig,
-    setVolThen,
     applyWorldConfig,
     setVol,
 ) where
@@ -33,12 +32,6 @@ setVol cfig = do
     setSoundVolume (_volume_master cfig * _volume_sound cfig)
     setMusicVolume (_volume_master cfig * _volume_music cfig)
 
--- what?
-setVolThen :: Configuration -> (a -> IO a) -> a -> IO a
-setVolThen cfig f a = do
-    setVol cfig
-    f a
-
 {- |
 Apply /all/ of the values in the world configuration to the running game.
 -}

src/Dodge/Render.hs

@@ -31,10 +31,12 @@ import Shader.Data
 import Shader.Poke
 import Shader.Poke.Cloud
 
-doDrawing :: SDL.Window -> RenderData -> Universe -> IO ()
+doDrawing :: SDL.Window -> Universe -> IO ()
-doDrawing window rdata u
+doDrawing window u
     | SDL.ScancodeT `M.member` (u ^. uvWorld . input . pressedKeys) = doTestDrawing rdata u
     | otherwise = doDrawing' window rdata u
+  where
+    rdata = u ^. preloadData . renderData
 
 doTestDrawing :: RenderData -> Universe -> IO ()
 doTestDrawing _ _ = do
@@ -49,9 +51,7 @@ doDrawing' win pdata u = do
         rot = w ^. cWorld . camPos . camRot
         camzoom = w ^. cWorld . camPos . camZoom
         trans = w ^. cWorld . camPos . camCenter
-        wins@(V2 winx winy) = V2 (_windowX cfig) (_windowY cfig)
+        wins = V2 (_windowX cfig) (_windowY cfig)
-        worldres = resFactorNum $ cfig ^. graphics_world_resolution
-        downres = resFactorNum $ cfig ^. graphics_downsize_resolution
         (windowPoints, wallSPics, wallsToPoke) = wallsToDraw w
         lightPoints = lightsToRender cfig (w ^. cWorld . camPos) (w ^. cWorld . lWorld)
         viewFroms@(V2 vfx vfy) = w ^. cWorld . camPos . camViewFrom
@@ -107,7 +107,7 @@ doDrawing' win pdata u = do
     glBindBufferBase GL_UNIFORM_BUFFER 0 (pdata ^. matUBO)
     withArray (perspectiveMatrixb rot camzoom trans wins viewFroms) $ \ptr ->
         glNamedBufferSubData (pdata ^. matUBO) 0 64 ptr
-    setViewportSize (round winx `div` worldres) (round winy `div` worldres)
+    setViewport _graphics_world_resolution cfig
     glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboBase ._1 . unFBO)
     glDepthMask GL_TRUE
     glDisable GL_BLEND
@@ -218,7 +218,7 @@ doDrawing' win pdata u = do
     renderLayer BloomLayer shadV layerCounts
     --setup downscale viewport for blurring bloom
     --setViewportSize (round winx `div` (2 * resFact)) (round winy `div` (2 * resFact))
-    setViewportSize (round winx `div` downres) (round winy `div` downres)
+    setViewport _graphics_downsize_resolution cfig
     glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboHalf1 pdata)))
     glDepthFunc GL_ALWAYS
     glBindTextureUnit 0 (pdata ^. fboBloom . _2 . unTO)
@@ -226,7 +226,7 @@ doDrawing' win pdata u = do
     drawShader (_bloomBlurShader pdata) 4
     replicateM_ 2 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata)
     glEnable GL_BLEND
-    setViewportSize (round winx `div` worldres) (round winy `div` worldres)
+    setViewport _graphics_world_resolution cfig
     --draw clouds onto cloud buffer
     glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata)))
     glDepthFunc GL_LEQUAL
@@ -335,7 +335,7 @@ doDrawing' win pdata u = do
     drawShader (_fullscreenShader pdata) 4
     --set viewport for radial distortion
     --setViewportSize (round winx) (round winy)
-    setViewportType _graphics_overlay_resolution cfig
+    setViewport _graphics_overlay_resolution cfig
     glDepthFunc GL_ALWAYS
     glBlendFunc GL_ONE GL_ZERO
     -- perform any radial distortion
@@ -372,8 +372,5 @@ getDistortions cfig w
     | cfig ^. graphics_distortions = w ^. cWorld . lWorld . distortions
     | otherwise = []
 
-setViewportSize :: Int -> Int -> IO ()
+setViewport :: (Configuration -> ResFactor) -> Configuration -> IO ()
-setViewportSize x y = glViewport 0 0 (fromIntegral x) (fromIntegral y)
+setViewport f = uncurry (glViewport 0 0) . getWindowSize f
-
-setViewportType :: (Configuration -> ResFactor) -> Configuration -> IO ()
-setViewportType f = uncurry (glViewport 0 0) . getWindowSize f

src/Framebuffer/Setup.hs

@@ -1,6 +1,6 @@
 -- | For initialising framebuffers.
 module Framebuffer.Setup (
-    setupTextureFramebuffer,
+    newTextureFramebuffer,
     setupFramebufferGivenStencil,
     setupFramebuffer2GivenStencil,
     setupFramebuffer3GivenStencil,
@@ -9,41 +9,23 @@ module Framebuffer.Setup (
 
 import Shader.Data
 import Framebuffer.Check
-import Unsafe.Coerce
 import GLHelp
 import Graphics.GL.Core45
 
-setupTextureFramebuffer ::
+-- the framebuffer is not complete after this
-    GLsizei ->
+newTextureFramebuffer :: IO (FBO, TO)
-    GLsizei ->
+{-# INLINE newTextureFramebuffer #-}
-    IO (FBO, TO)
+newTextureFramebuffer = do
-{-# INLINE setupTextureFramebuffer #-}
-setupTextureFramebuffer x y = do
-    --fboName <- genObjectName
-    --bindFramebuffer Framebuffer $= fboName
     fboName <- mglCreate glCreateFramebuffers
-    --fboTO <- genObjectName
     to <- mglCreate (glCreateTextures GL_TEXTURE_2D)
-    --textureBinding Texture2D $= Just fboTO
-    --glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 x y
-    glTextureStorage2D to 1 GL_RGBA8 x y
-    glTextureParameteri to GL_TEXTURE_MIN_FILTER (unsafeCoerce GL_NEAREST)
-    glTextureParameteri to GL_TEXTURE_MAG_FILTER (unsafeCoerce GL_NEAREST)
-    --textureFilter Texture2D $= minMagFilter
-    --framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D fboTO 0
-    glNamedFramebufferTexture fboName GL_COLOR_ATTACHMENT0 to 0
-    checkFBO $ FBO fboName
     return (FBO fboName, TO to)
 
+-- the framebuffer is not complete after this
 setupShadowFramebuffer :: IO (FBO, (TO, TO))
 setupShadowFramebuffer = do
-    --fboName <- genObjectName
-    --bindFramebuffer Framebuffer $= fboName
     fboName <- mglCreate glCreateFramebuffers
     to1 <- mglCreate (glCreateTextures GL_TEXTURE_2D_ARRAY)
     to2 <- mglCreate (glCreateTextures GL_TEXTURE_2D_ARRAY)
-    --textureBinding Texture2DArray $= Just toName
-    --framebufferRenderbuffer Framebuffer DepthStencilAttachment Renderbuffer rboName
     return (FBO fboName, (TO to1,TO to2))
 
 setupFramebufferGivenStencil ::

src/Framebuffer/Update.hs

@@ -46,9 +46,7 @@ sizeFBOs cfig rdata = do
             (uncurry updateFBOTO (getWindowSize _graphics_downsize_resolution cfig) GL_LINEAR_MIPMAP_LINEAR GL_LINEAR GL_RGBA16F)
             rdata'''
             [fboHalf1, fboHalf2, fboHalf3]
-    newShadowFBO <- uncurry (resizeShadowFBO (rdata ^. fboShadow)) 
+    resizeShadowFBO' cfig rdata4
-        (getWindowSize _graphics_world_resolution cfig)
-    return $ rdata4 & fboShadow .~ newShadowFBO
 
 resizeRBO ::
     GLuint -> -- RenderbufferObject
@@ -113,13 +111,16 @@ updateFBOTO3 xsize ysize minfilt magfilt inFormat1 inFormat2 inFormat3 pdata tar
     newfbo2 <- resizeFBOTO3 (pdata ^# target) xsize ysize minfilt magfilt inFormat1 inFormat2 inFormat3
     return $ storing target newfbo2 pdata
 
+resizeShadowFBO' :: Configuration -> RenderData -> IO RenderData
+resizeShadowFBO' cfig = fboShadow (uncurry resizeShadowFBO (getWindowSize _graphics_world_resolution cfig))
+
 -- note we only really "change" the texture objects
 resizeShadowFBO ::
+    Int ->
+    Int ->
     (FBO, (TO, TO)) ->
-    Int ->
-    Int ->
     IO (FBO, (TO, TO))
-resizeShadowFBO (fbo, (oldto1, oldto2)) x y = do
+resizeShadowFBO x y (fbo, (oldto1, oldto2)) = do
     glBindFramebuffer GL_FRAMEBUFFER (_unFBO fbo)
     mglDelete glDeleteTextures $ _unTO oldto1
     mglDelete glDeleteTextures $ _unTO oldto2

src/Preload/Render.hs

@@ -115,8 +115,8 @@ preloadRender = do
     cloudvbo <- setupVBO (sum cloudverxsizes)
     (cloudshader, cloudebo)
         <- makeShaderEBO "cloud/basic" [vert, frag] cloudverxsizes pmTriangles cloudvbo
-    framebuf2 <- setupTextureFramebuffer 800 600
+    framebuf2 <- newTextureFramebuffer
-    framebuf3 <- setupTextureFramebuffer 800 600
+    framebuf3 <- newTextureFramebuffer
 
     rboBaseBloomName <- mglCreate glCreateRenderbuffers
     glNamedRenderbufferStorage 
@@ -133,9 +133,11 @@ preloadRender = do
 
     fboShadowName <- setupShadowFramebuffer
 
-    fboHalf1Name <- setupTextureFramebuffer 300 300
+    fbooverlay <- newTextureFramebuffer
-    fboHalf2Name <- setupTextureFramebuffer 300 300
+
-    fboHalf3Name <- setupTextureFramebuffer 300 300
+    fboHalf1Name <- newTextureFramebuffer
+    fboHalf2Name <- newTextureFramebuffer
+    fboHalf3Name <- newTextureFramebuffer
 
     -- reset to default framebuffer, ready for drawing direct to screen
     glBindFramebuffer GL_FRAMEBUFFER 0
@@ -183,6 +185,7 @@ preloadRender = do
             , _fboCloud = fboCloudName
             , _fboBloom = fboBloomName
             , _fboPos = fboPosName
+            , _fboOverlay = fbooverlay
             , _rboBaseBloom = rboBaseBloomName
             , _matUBO = theUBO
             , _orthonormalMatUBO = orthonormalUBO

src/Preload/Update.hs

@@ -5,12 +5,12 @@ module Preload.Update (
     renderDataResizeUpdate,
 ) where
 
-import Dodge.WindowSize
-import Dodge.Data.Universe
 import Control.Lens
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BSC
 import Data.Preload.Render
+import Dodge.Data.Universe
+import Dodge.WindowSize
 import Framebuffer.Update
 import Shader.Compile
 import Shader.Data
@@ -18,9 +18,10 @@ import Shader.Data
 -- i don't like this being here pulling in the dodge universe dependency, but
 -- splitting it out would be overkill
 updatePreload :: Universe -> IO Universe
-updatePreload u = do
+updatePreload u =
-    pdata <- renderDataResizeUpdate (u ^. uvConfig) (u ^. preloadData . renderData)
+    (preloadData . renderData)
-    return $ u & preloadData . renderData .~ pdata
+        (renderDataResizeUpdate (u ^. uvConfig))
+        u
 
 renderDataResizeUpdate ::
     Configuration ->
@@ -30,7 +31,7 @@ renderDataResizeUpdate cfig rdata = do
     rdata' <- sizeFBOs cfig rdata
     bbVert <- BS.readFile "shader/texture/bloomBlur.vert"
     bbFrag <- BS.readFile "shader/texture/bloomBlur.frag"
-    let (xsize,ysize) = getWindowSize _graphics_downsize_resolution cfig :: (Int,Int)
+    let (xsize, ysize) = getWindowSize _graphics_downsize_resolution cfig :: (Int, Int)
         (bh, bmid) = BS.breakSubstring "(" bbFrag
         (_, btt) = BS.breakSubstring ")" bmid
         bbFrag' = BS.append bh $ BS.append (BSC.pack $ '(' : show xsize ++ "," ++ show ysize) btt
@@ -40,4 +41,4 @@ renderDataResizeUpdate cfig rdata = do
             [(vert, bbVert), (frag, bbFrag')]
             pmTriangleStrip
             (rdata ^. screenTextureVAO)
-    return (rdata'{_bloomBlurShader = bbShad})
+    return rdata'{_bloomBlurShader = bbShad}