Fix bloom resize bug, bloom itself could use improvement

src/Framebuffer/Setup.hs

@@ -0,0 +1,40 @@
+module Framebuffer.Setup
+    ( setupTextureFramebuffer
+    , newFramebufferGivenStencil
+    ) where
+import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
+import Graphics.GL.Core43
+
+setupTextureFramebuffer 
+    :: GLsizei
+    -> GLsizei
+    -> IO (FramebufferObject, TextureObject)
+{-# INLINE setupTextureFramebuffer #-}
+setupTextureFramebuffer x y = do
+    fboName <- genObjectName
+    bindFramebuffer Framebuffer $= fboName
+
+    fboTO <- genObjectName
+    textureBinding Texture2D $= Just fboTO
+    glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 x y
+    textureFilter Texture2D $= minMagFilter
+    framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D fboTO 0
+    fboStatus <- framebufferStatus Framebuffer
+    print fboStatus
+    return (fboName, fboTO)
+
+newFramebufferGivenStencil 
+    :: RenderbufferObject 
+    -> IO (FramebufferObject, TextureObject)
+{-# INLINE newFramebufferGivenStencil #-}
+newFramebufferGivenStencil rboName = do
+    fboName <- genObjectName
+    bindFramebuffer Framebuffer $= fboName
+    toName <- genObjectName
+    framebufferRenderbuffer Framebuffer DepthStencilAttachment Renderbuffer rboName
+    fboStatus <- framebufferStatus Framebuffer
+    print fboStatus
+    return (fboName,toName)
+
+minMagFilter :: ((TextureFilter, Maybe TextureFilter),TextureFilter)
+minMagFilter = ((Nearest,Nothing),Nearest)

src/Framebuffer/Update.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-| Concerns resizing framebuffers on the fly.
+ - Seems to need to be called at least once.
+ -}
+module Framebuffer.Update
+    ( sizeFBOs
+    )
+where
+import Data.Preload.Render
+
+import Graphics.Rendering.OpenGL
+import Graphics.GL.Core43
+--import Foreign
+import Control.Lens
+import Control.Monad
+
+sizeFBOs 
+    :: Int  -- ^ Scaled width
+    -> Int  -- ^ Scaled height
+    -> Int  -- ^ Full width
+    -> Int  -- ^ Full height
+    -> RenderData
+    -> IO (RenderData)
+sizeFBOs xsize ysize xfull yfull rdata = do
+    resizeRBO (_rboBaseBloom rdata) xsize ysize
+    resizeRBO (_rboLighting rdata)   xsize ysize
+    rdata' <- foldM (updateFBOTO xsize ysize) rdata [fboBase, fboBloom, fboColor,fboFourth1,fboFourth2]
+    rdata'' <- foldM (updateFBOTO xfull yfull) rdata' [fbo2, fbo3]
+    updateFBOTO xsize ysize rdata'' fboLighting
+
+resizeRBO
+    :: RenderbufferObject
+    -> Int
+    -> Int
+    -> IO ()
+resizeRBO rboName xsize ysize = do
+    let xsize' = fromIntegral xsize
+        ysize' = fromIntegral ysize
+    bindRenderbuffer Renderbuffer $= rboName
+    renderbufferStorage Renderbuffer Depth24Stencil8 (RenderbufferSize xsize' ysize')
+
+updateFBOTO
+    :: Int
+    -> Int
+    -> RenderData
+    -> ALens' RenderData (FramebufferObject, TextureObject)
+    -> IO (RenderData)
+updateFBOTO xsize ysize pdata target = do
+    newfbo2 <- resizeFBOTO (pdata ^# target) xsize ysize
+    return $ storing target newfbo2 pdata
+
+resizeFBOTO
+    :: (FramebufferObject , TextureObject)
+    -> Int
+    -> Int
+    -> IO (FramebufferObject, TextureObject)
+resizeFBOTO (fboName,toOld) xsize ysize = do
+    bindFramebuffer Framebuffer $= fboName
+    let xsize' = fromIntegral xsize
+        ysize' = fromIntegral ysize
+    deleteObjectName toOld
+    toName <- genObjectName
+    textureBinding Texture2D $= Just toName
+    glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 xsize' ysize'
+    textureFilter Texture2D $= minMagFilter
+    framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D toName 0
+    fboStatus <- framebufferStatus Framebuffer
+    putStrLn $ "after resize, framebuffer status:" ++ show fboStatus
+    return (fboName, toName)
+
+minMagFilter :: ((TextureFilter, Maybe TextureFilter),TextureFilter)
+minMagFilter = ((Nearest,Nothing),Nearest)
+