Progress towards downscaling bloom texture

src/Data/Preload/Render.hs

@@ -17,7 +17,9 @@ data RenderData = RenderData
     , _textureArrayShader       :: FullShader
     , _fullscreenShader         :: FullShader
     , _fullscreenAlphaHalveShader         :: FullShader
-    , _boxBlurShader            :: FullShader
+    --, _boxBlurShader            :: FullShader
+    , _bloomBlurShader          :: FullShader
+    , _colorBlurShader          :: FullShader
     , _grayscaleShader          :: FullShader
     , _pictureShaders           :: [FullShader]
     , _spareFBO                 :: FramebufferObject
@@ -25,9 +27,11 @@ data RenderData = RenderData
     , _fboRenderbufferObject    :: RenderbufferObject
     , _fbo2                     :: (FramebufferObject, TextureObject, RenderbufferObject)
     , _fbo3                     :: (FramebufferObject, TextureObject, RenderbufferObject)
-    , _fbos :: ( [(FramebufferObject, TextureObject) ] , RenderbufferObject )
+    , _fboFourth1 :: (FramebufferObject, TextureObject)
+    , _fboFourth2 :: (FramebufferObject, TextureObject)
     , _fboBase                  :: (FramebufferObject, TextureObject)
     , _fboBloom                 :: (FramebufferObject, TextureObject)
+    , _fboColor                 :: (FramebufferObject, TextureObject)
     , _rboBaseBloom             :: RenderbufferObject
     , _fboLighting              :: (FramebufferObject, TextureObject)
     , _rboLighting              :: RenderbufferObject

src/Dodge/Render.hs

@@ -31,7 +31,7 @@ import Foreign
 import Control.Lens
 import Control.Monad
 import qualified Control.Foldl as F
-import Data.Tuple.Extra
+--import Data.Tuple.Extra
 --import Data.List
 --import Data.Bifunctor
 --import Data.Function
@@ -73,30 +73,31 @@ doDrawing pdata w = do
     clear [ColorBuffer]
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
     _ <- renderFoldable pdata $ picToLTree (Just 1) pic
+    bindFramebuffer Framebuffer $= (fst $ _fboColor pdata)
+    clear [ColorBuffer]
     depthMask $= Disabled
     _ <- renderFoldable pdata $ picToLTree (Just 3) pic
     _ <- renderFoldable pdata $ picToLTree (Just 4) pic
     _ <- renderFoldable pdata $ picToLTree (Just 5) pic
     depthMask $= Enabled
-    bindFramebuffer Framebuffer $= (fst3 $ _fbo3 pdata)
+    --bindFramebuffer Framebuffer $= (fst3 $ _fbo2 pdata)
-    clear [ColorBuffer]
+    bindFramebuffer Framebuffer $= (fst $ _fboFourth1 pdata)
-    bindFramebuffer Framebuffer $= (fst3 $ _fbo2 pdata)
+    viewport $= (Position 0 0, Size 600 600)
     depthFunc $= Just Always
     --blend $= Disabled
     textureBinding Texture2D $= Just (snd $ _fboBloom pdata)
     --clear [ColorBuffer]
     --blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    blendFuncSeparate $= ((Zero,One), (Zero,SrcAlpha))
+    --blendFuncSeparate $= ((Zero,One), (Zero,SrcAlpha))
-    bindShaderBuffers [_fullscreenAlphaHalveShader pdata] [4]
+    --drawShader (_fullscreenAlphaHalveShader pdata) 4
-    drawShader (_fullscreenAlphaHalveShader pdata) 4
+    --blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+    --drawShader (_bloomBlurShader pdata) 4
     blendFunc $= (One,Zero)
-    bindShaderBuffers [_boxBlurShader pdata] [4]
+    drawShader (_fullscreenShader pdata) 4
-    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+    --replicateM_ 5 $ pingPongBetween (_fboFourth1 pdata) (_fboFourth2 pdata) (_bloomBlurShader pdata)
-    drawShader (_boxBlurShader pdata) 4
+    --replicateM_ 5 $ pingPongBlur pdata
-    blendFunc $= (One,Zero)
-    pingPongBlur pdata
-    replicateM_ 5 $ pingPongBlur pdata
     --blend $= Enabled
+    viewport $= (Position 0 0, Size (round $ fst wins) (round $ snd wins))
 
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
 
@@ -126,8 +127,11 @@ doDrawing pdata w = do
     blendFunc $= (Zero, OneMinusSrcAlpha)
     drawShader (_fullscreenShader pdata) 4
     blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
-    --textureBinding Texture2D $= Just (snd $ _fboBloom pdata)
+
-    textureBinding Texture2D $= Just (snd3 $ _fbo2 pdata)
+    textureBinding Texture2D $= Just (snd $ _fboColor pdata)
+    drawShader (_colorBlurShader pdata) 4
+    --textureBinding Texture2D $= Just (snd3 $ _fbo2 pdata)
+    textureBinding Texture2D $= Just (snd $ _fboFourth1 pdata)
     drawShader (_fullscreenShader pdata) 4
 
     depthFunc $= Just Lequal
@@ -151,133 +155,6 @@ doDrawing pdata w = do
     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 ()

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -57,13 +57,13 @@ drawFlame rotd pt = thePic
     ep = _btPos' pt
     thePic = pictures 
         [ glow 
-        , aPic prot2 18 (scaleChange + 1,2) red
+        , aPic 3 prot2 18 (scaleChange + 1,2) red
-        , aPic prot  19 (scaleChange + 0.5,1.5) orange
+        , aPic 4 prot  19 (scaleChange + 0.5,1.5) orange
-        , aPic prot3 20 (scaleChange,1) white
+        , aPic 5 prot3 20 (scaleChange,1) white
         ]
-    aPic :: (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
+    aPic :: Int -> (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
-    aPic offset depth (scalex,scaley) col
+    aPic lay offset depth (scalex,scaley) col
-        = setLayer 1 
+        = setLayer lay 
         . setDepth depth 
         . uncurry translate (offset ep)
         . rotate (pi * 0.5 + argV rotd)

src/Preload/Render.hs

@@ -55,8 +55,10 @@ preloadRender = do
     fsShad <- makeShader "texture/simple" [vert,frag] [2,2] ETriangleStrip $ const cornerList
     -- note we directly poke the shader vertex data here
     pokeArray (_vboPointer $ _vaoVBO $ _shaderVAO fsShad) $ concat cornerList
-    boxBlurShad <- makeShader "texture/bloomBlur" [vert,frag] [2,2] ETriangleStrip $ const cornerList
+    bloomBlurShad <- makeShader "texture/bloomBlur" [vert,frag] [2,2] ETriangleStrip $ const cornerList
-    pokeArray (_vboPointer $ _vaoVBO $ _shaderVAO boxBlurShad) $ concat cornerList
+    pokeArray (_vboPointer $ _vaoVBO $ _shaderVAO bloomBlurShad) $ concat cornerList
+    colorBlurShad <- makeShader "texture/colorBlur" [vert,frag] [2,2] ETriangleStrip $ const cornerList
+    pokeArray (_vboPointer $ _vaoVBO $ _shaderVAO colorBlurShad) $ concat cornerList
     grayscaleShad <- makeShader "texture/grayscale" [vert,frag] [2,2] ETriangleStrip $ const cornerList
     pokeArray (_vboPointer $ _vaoVBO $ _shaderVAO grayscaleShad) $ concat cornerList
 -- blank wallShader
@@ -70,13 +72,13 @@ preloadRender = do
 ---- texture array shader
     textArrayShad <- makeShader "texture/array" [vert,frag] [3,3] ETriangles poke33
         >>= addTextureArray "data/texture/ayene_wooden_floor.png"
+    -- bind fixed vertex data
+    bindShaderBuffers [bloomBlurShad,colorBlurShad,fullscreenAlphaHalveShad ] [4,4,4]
 -- framebuffer for lighting
     (fbo,fboTO,fboRBO) <- setupFramebufferWithStencil
     framebuf2 <- setupFramebufferWithStencil
     framebuf3 <- setupFramebufferWithStencil
 
-    frameBufs <- setupFramebuffersSharedStencil 6
-
     rboLightingName <- genObjectName
     bindRenderbuffer Renderbuffer $= rboLightingName
     renderbufferStorage Renderbuffer Depth24Stencil8 (RenderbufferSize 800 600)
@@ -88,6 +90,10 @@ preloadRender = do
 
     fboBaseName <- newFramebufferGivenStencil rboBaseBloomName
     fboBloomName <- newFramebufferGivenStencil rboBaseBloomName
+    fboColorName <- newFramebufferGivenStencil rboBaseBloomName
+
+    fboFourth1Name <- setupTextureFramebuffer 600 600
+    fboFourth2Name <- setupTextureFramebuffer 600 600
 
 -- reset to default framebuffer, ready for drawing direct to screen
     bindFramebuffer Framebuffer $= defaultFramebufferObject
@@ -108,18 +114,21 @@ preloadRender = do
         , _textureArrayShader       = textArrayShad
         , _fullscreenShader         = fsShad
         , _fullscreenAlphaHalveShader = fullscreenAlphaHalveShad
-        , _boxBlurShader            = boxBlurShad
+        , _bloomBlurShader            = bloomBlurShad
+        , _colorBlurShader            = colorBlurShad
         , _grayscaleShader          = grayscaleShad
         , _spareFBO                 = fbo
         , _fboTexture               = fboTO
         , _fboRenderbufferObject    = fboRBO
         , _fbo2                     = framebuf2
         , _fbo3                     = framebuf3
-        , _fbos = frameBufs
+        , _fboFourth1 = fboFourth1Name
+        , _fboFourth2 = fboFourth2Name
         , _fboLighting = fboLightingName
         , _rboLighting = rboLightingName
         , _fboBase = fboBaseName
         , _fboBloom = fboBloomName
+        , _fboColor = fboColorName
         , _rboBaseBloom = rboBaseBloomName
         , _matUBO = theUBO
         }
@@ -186,27 +195,23 @@ newFramebufferGivenStencil rboName = do
     print fboStatus
     return (fboName,toName)
     
-
+setupTextureFramebuffer 
-setupFramebuffer :: IO (FramebufferObject, TextureObject)
+    :: GLsizei
-setupFramebuffer = do
+    -> GLsizei
+    -> IO (FramebufferObject, TextureObject)
+setupTextureFramebuffer x y = do
     fboName <- genObjectName
     bindFramebuffer Framebuffer $= fboName
 
     fboTO <- genObjectName
     textureBinding Texture2D $= Just fboTO
-    texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D 600 600) 0 (PixelData RGBA UnsignedByte nullPtr)
+    texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D x y) 0 (PixelData RGBA UnsignedByte nullPtr)
     textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
+    --textureFilter Texture2D $= ((Nearest,Just Nearest) , Nearest)
     generateMipmap' Texture2D
     framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D fboTO 0
-
-    fboRBO <- genObjectName
-    bindRenderbuffer Renderbuffer $= fboRBO
-    renderbufferStorage Renderbuffer Depth24Stencil8 (RenderbufferSize 600 600)
-    framebufferRenderbuffer Framebuffer DepthStencilAttachment Renderbuffer fboRBO
-
     fboStatus <- framebufferStatus Framebuffer
     print fboStatus
-
     return (fboName, fboTO)
 
 cleanUpRenderPreload :: RenderData -> IO ()

src/Preload/Update.hs

@@ -36,11 +36,10 @@ resizeSpareFBO xsize ysize xfull yfull pdata = do
     putStrLn $ "after resize, framebuffer status:" ++ show fboStatus
     resizeTextureFBO (_fbo2 rdata) xfull yfull
     resizeTextureFBO (_fbo3 rdata) xfull yfull
-    resizeRBO (snd $ _fbos rdata) xfull yfull
-    mapM_ (\p -> resizeFBOTO p xfull yfull) (fst $ _fbos rdata)
     resizeRBO (_rboBaseBloom rdata) xfull yfull
     resizeFBOTO (_fboBase rdata) xfull yfull
     resizeFBOTO (_fboBloom rdata) xfull yfull
+    resizeFBOTO (_fboColor rdata) xfull yfull
     resizeRBO (_rboLighting rdata)   xsize ysize
     resizeFBOTO (_fboLighting rdata) xsize ysize
     

src/Render.hs

@@ -168,15 +168,34 @@ pingPongBlur :: RenderData -> IO ()
 pingPongBlur pdata = do
     bindFramebuffer Framebuffer $= fst3 (_fbo3 pdata)
     textureBinding Texture2D $= Just (snd3 $ _fbo2 pdata)
-    textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
+    --textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
-    generateMipmap' Texture2D
+    --generateMipmap' Texture2D
-    drawShader (_boxBlurShader pdata) 4
+    drawShader (_bloomBlurShader pdata) 4
 
     bindFramebuffer Framebuffer $= fst3 (_fbo2 pdata)
     textureBinding Texture2D $= Just (snd3 $ _fbo3 pdata)
-    textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
+    --textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
-    generateMipmap' Texture2D
+    --generateMipmap' Texture2D
-    drawShader (_boxBlurShader pdata) 4
+    drawShader (_bloomBlurShader pdata) 4
+
+-- assumes that vertices have already been sent to the shader
+pingPongBetween 
+    :: (FramebufferObject,TextureObject)
+    -> (FramebufferObject,TextureObject)
+    -> FullShader
+    -> IO ()
+pingPongBetween (fb1,to1) (fb2,to2) fs = do
+    bindFramebuffer Framebuffer $= fb2
+    textureBinding Texture2D $= Just to1
+--    textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
+--    generateMipmap' Texture2D
+    drawShader fs 4
+
+    bindFramebuffer Framebuffer $= fb1
+    textureBinding Texture2D $= Just to2
+--    textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
+--    generateMipmap' Texture2D
+    drawShader fs 4
 
 renderShader
     :: Foldable f