Fix bloom resize bug, bloom itself could use improvement

src/Dodge/Config/Update.hs

@@ -7,7 +7,7 @@ import Dodge.Data.SoundOrigin
 import Dodge.Config.Data
 import Sound
 import Data.Preload
-import Framebuffer.Update
+import Preload.Update
 
 import Data.Aeson (encodeFile)
 --import Control.Monad (when)
@@ -37,7 +37,7 @@ applyWorldConfig
     -> PreloadData SoundOrigin 
     -> IO (PreloadData SoundOrigin)
 applyWorldConfig cfig pdata = do
-    setVol cfig pdata >>= sizeFBOs (x `div` divRes) (y `div` divRes) x y
+    setVol cfig pdata >>= pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y
   where
     x = round $ _windowX cfig
     y = round $ _windowY cfig

src/Dodge/Event.hs

@@ -23,7 +23,7 @@ import Dodge.SoundLogic
 import Dodge.Inventory
 import Dodge.Config.Data
 --import Geometry
-import Framebuffer.Update
+import Preload.Update
 import qualified IntMapHelp as IM
 
 import Control.Lens
@@ -65,7 +65,7 @@ handleResizeEvent :: WindowSizeChangedEventData -> World -> Maybe World
 handleResizeEvent sev w = Just 
     . set (config . windowX) (fromIntegral x)
     . set (config . windowY) (fromIntegral y)
-    $ over sideEffects ( sizeFBOs (x `div` divRes) (y `div` divRes) x y : )
+    $ over sideEffects (pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y : )
     w
   where 
     x = fromIntegral x'

src/Dodge/Event/Menu.hs

@@ -10,7 +10,7 @@ import Dodge.SoundLogic
 import Dodge.Config.Data
 import Dodge.Config.Update
 import Dodge.Layout
-import Framebuffer.Update
+import Preload.Update
 import Dodge.Debug.Terminal
 
 import Data.Maybe
@@ -90,7 +90,7 @@ scodeToChar = toEnum . (+ 61) . fromIntegral . toNumber
 
 updateFramebufferSize :: World -> World
 updateFramebufferSize w = w & sideEffects 
-    %~ (sizeFBOs (x `div` divRes) (y `div` divRes) x y : )
+    %~ (pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y : )
   where 
     (x,y) = (round $ getWindowX w, round $ getWindowY w)
     divRes = w ^. config . shadow_resolution

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)
+

src/Preload/Update.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Preload.Update
+    (pdataResizeUpdate
+    ) where
+import Data.Preload
+import Framebuffer.Update
+import Shader.Compile
+import Shader.Data
+import Data.Preload.Render
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BSC
+pdataResizeUpdate
+    :: Int  -- ^ Scaled width
+    -> Int  -- ^ Scaled height
+    -> Int  -- ^ Full width
+    -> Int  -- ^ Full height
+    -> PreloadData a
+    -> IO (PreloadData a)
+pdataResizeUpdate xsize ysize xfull yfull pdata = do
+    rd <- renderDataResizeUpdate xsize ysize xfull yfull (_renderData pdata)
+    return (pdata {_renderData = rd})
+
+renderDataResizeUpdate
+    :: Int  -- ^ Scaled width
+    -> Int  -- ^ Scaled height
+    -> Int  -- ^ Full width
+    -> Int  -- ^ Full height
+    -> RenderData
+    -> IO RenderData
+renderDataResizeUpdate xsize ysize xfull yfull rdata = do
+    rdata' <- sizeFBOs xsize ysize xfull yfull rdata
+    bbVert <- BS.readFile "shader/texture/bloomBlur.vert"
+    bbFrag <- BS.readFile "shader/texture/bloomBlur.frag"
+    let (bh,bmid) = BS.breakSubstring "(" bbFrag
+        (_,btt) = BS.breakSubstring ")" bmid
+        bbFrag' = BS.append bh $ BS.append (BSC.pack $ '(' : show xfull ++ "," ++ show yfull) btt
+    --BSC.putStrLn bbFrag'
+    bbShad <- makeByteStringShaderUsingVAO "bloomBlur" [(vert,bbVert),(frag,bbFrag')] ETriangleStrip
+                (_fullscreenShader rdata)
+    return (rdata' {_bloomBlurShader = bbShad})
+

src/Shader/Compile.hs

@@ -1,6 +1,7 @@
 module Shader.Compile
     ( makeShader
-    --, makeVShader
+    , makeByteStringShader
+    , makeByteStringShaderUsingVAO
     , makeShaderSized
     , makeShaderUsingShaderVAO
     , makeSourcedShader
@@ -15,43 +16,6 @@ import qualified Data.ByteString as BS
 import Control.Monad
 --import Control.Lens
 import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
-
---{- | 
---Compiles a vertex shader found within the shader directory.
---The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.
----}
---makeVShader 
---    :: String       -- ^ First part of the name of the shader
---    -> [ShaderType] -- ^ Filetype extensions
---    -> [Int]   -- ^ The input vertex sizes
---    -> EPrimitiveMode
---    -> IO VShader
---makeVShader s shaderlist sizes pm = do
---    prog <- makeSourcedShader s shaderlist
---    vaob <- setupVAO sizes
---    return $ VShader 
---        { _vshaderProgram = prog
---        , _vshaderVAO = vaob
---        , _vshaderTexture = Nothing
---        , _vshaderCustomUnis = []
---        , _vshaderDrawPrimitive = pm
---        }
-
--- | Takes the VAO from another shader
-makeShaderUsingShaderVAO
-    :: String       -- ^ First part of the name of the shader
-    -> [ShaderType] -- ^ Filetype extensions
-    -> EPrimitiveMode
-    -> FullShader
-    -> IO FullShader
-makeShaderUsingShaderVAO s shaderlist pm fs = do
-    prog <- makeSourcedShader s shaderlist
-    return $ fs 
-        { _shaderProgram = prog
-        , _shaderDrawPrimitive = pm
-        , _shaderTexture = Nothing
-        , _shaderCustomUnis = []
-        }
 {- | 
 Compiles a full shader found within the shader directory.
 The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.
@@ -72,6 +36,52 @@ makeShader s shaderlist sizes pm = do
         , _shaderTexture = Nothing
         , _shaderCustomUnis = []
         }
+makeByteStringShader
+    :: String       -- ^ (Arbitrary) name of the shader
+    -> [(ShaderType,BS.ByteString)] -- ^ Filetype extensions and shader data
+    -> [Int]        -- ^ The input vertex sizes
+    -> EPrimitiveMode 
+    -> IO FullShader
+makeByteStringShader s shaderlist sizes pm = do
+    prog <- makeShaderProgram s shaderlist
+    vaob <- setupVAO sizes
+    return $ FullShader 
+        { _shaderProgram = prog
+        , _shaderVAO = vaob
+        , _shaderDrawPrimitive = pm
+        , _shaderTexture = Nothing
+        , _shaderCustomUnis = []
+        }
+makeByteStringShaderUsingVAO
+    :: String       -- ^ (Arbitrary) name of the shader
+    -> [(ShaderType,BS.ByteString)] -- ^ Filetype extensions and shader data
+    -> EPrimitiveMode 
+    -> FullShader
+    -> IO FullShader
+makeByteStringShaderUsingVAO s shaderlist pm fs = do
+    prog <- makeShaderProgram s shaderlist
+    return $ fs 
+        { _shaderProgram = prog
+        , _shaderDrawPrimitive = pm
+        , _shaderTexture = Nothing
+        , _shaderCustomUnis = []
+        }
+
+-- | Takes the VAO from another shader
+makeShaderUsingShaderVAO
+    :: String       -- ^ First part of the name of the shader
+    -> [ShaderType] -- ^ Filetype extensions
+    -> EPrimitiveMode
+    -> FullShader
+    -> IO FullShader
+makeShaderUsingShaderVAO s shaderlist pm fs = do
+    prog <- makeSourcedShader s shaderlist
+    return $ fs 
+        { _shaderProgram = prog
+        , _shaderDrawPrimitive = pm
+        , _shaderTexture = Nothing
+        , _shaderCustomUnis = []
+        }
 {- | 
 Compiles a full shader found within the shader directory.
 The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.