Implement multiple radial distortion rendering

src/Dodge/Creature/Action.hs

@@ -59,10 +59,12 @@ blinkAction
     -> World 
     -> World
 blinkAction cr w = soundOnce teleSound 
+    . set radDistortion distortionBulge
     . set (creatures . ix cid . crPos) p3
     . blinkShockwave cid p3
     $ inverseShockwaveAt cpos 40 2 2 2 w
   where
+    distortionBulge = [(p3,p3 +.+ (40,0), p3 +.+ (0,40),0.5)]
     cid  = _crID cr
     p1 = mouseWorldPos w
     cpos = _crPos cr

src/Dodge/Default/World.hs

@@ -78,7 +78,7 @@ defaultWorld = World
     , _inventoryMode = TopInventory
     , _lClickHammer = HammerUp
     , _foregroundDecorations = []
-    , _radDistortion = [((-20,120),(60,120),(-20,40),0.5)]
+    , _radDistortion = []
     }
 defaultDebugFlags :: DebugFlags
 defaultDebugFlags = DebugFlags

src/Dodge/Render.hs

@@ -142,15 +142,45 @@ doDrawing pdata w = do
     renderBlankWalls pdata windowPoints
 
     depthFunc $= Just Always
-    bindFramebuffer Framebuffer $= defaultFramebufferObject
-    clear [ColorBuffer]
-    activeTexture $= TextureUnit 1
-    textureBinding Texture2D $= Just (snd $ _fboBase pdata)
-    bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms
-    nraddist <- F.foldM (pokeShader $ _barrelShader pdata) (map Render2221 $ _radDistortion w)
-    bindShaderBuffers [_barrelShader pdata] [nraddist]
-    drawShader (_barrelShader pdata) nraddist
-    activeTexture $= TextureUnit 0
+    blendFunc $= (One,Zero)
+
+    case _radDistortion w of
+        [] -> do
+            bindTO $ snd $ _fboBase pdata
+            bindFramebuffer Framebuffer $= defaultFramebufferObject
+            --bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms
+            drawShader (_fullscreenShader pdata) 4
+        rds -> do
+            let bindDrawDist :: (Point2,Point2,Point2,Float) -> IO ()
+                bindDrawDist distParam = do
+                    _ <- F.foldM (pokeShader $ _barrelShader pdata) [Render2221 distParam]
+                    bindShaderBuffers [_barrelShader pdata] [1]
+                    drawShader (_barrelShader pdata) 1
+                fboList = take (length rds - 1) (concat (repeat [fst3 $ _fbo2 pdata,fst3 $ _fbo3 pdata]))
+                        ++ [defaultFramebufferObject]
+                toList = snd (_fboBase pdata) : concat (repeat [snd3 $ _fbo2 pdata,snd3 $ _fbo3 pdata])
+                bindings = zipWith (>>) (map bindFBO fboList) (map bindTO toList)
+            activeTexture $= TextureUnit 1
+            sequence_ $ zipWith (>>) bindings $ map bindDrawDist rds
+            activeTexture $= TextureUnit 0
+    --activeTexture $= TextureUnit 1
+    --bindTO $ snd $ _fboBase pdata
+
+    --let fbolist = 
+
+    --let bindDrawDist :: (Point2,Point2,Point2,Float) -> IO ()
+    --    bindDrawDist distParam = do
+    --        _ <- F.foldM (pokeShader $ _barrelShader pdata) [Render2221 distParam]
+    --        bindShaderBuffers [_barrelShader pdata] [1]
+    --        drawShader (_barrelShader pdata) 1
+    --sequence_ $ zipWith (>>) 
+    --    (map bindFBO $ concat $ repeat [fst3 $ _fbo2 pdata, fst3 $ _fbo3 pdata])
+    --    $ zipWith (>>) 
+    --        (map bindDrawDist (_radDistortion w) ++ [activeTexture $= TextureUnit 0])
+    --        (map bindTO $ concat $ repeat [snd3 $ _fbo2 pdata, snd3 $ _fbo3 pdata]) 
+    --bindFramebuffer Framebuffer $= defaultFramebufferObject
+    ----bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms
+    --drawShader (_fullscreenShader pdata) 4
 
     -- draw overlay
     bufferUBO $ isoMatrix 0 1 (0,0) (2,2)
@@ -163,6 +193,17 @@ doDrawing pdata w = do
     eTicks <- SDL.ticks
     return (eTicks - sTicks)
 
+bindTO :: TextureObject -> IO ()
+bindTO t = textureBinding Texture2D $= Just t
+
+bindFBO :: FramebufferObject -> IO ()
+bindFBO fb = bindFramebuffer Framebuffer $= fb
+
+fst3 :: (a,b,c) -> a
+fst3 (x,_,_) = x
+snd3 :: (a,b,c) -> b
+snd3 (_,x,_) = x
+
 --------------------------------------------------------------------------------
 -- note: currently assume there is only one UBO, we only bind it once at setup
 bufferUBO :: [Float] -> IO ()

src/Dodge/Update.hs

@@ -53,6 +53,7 @@ update' w = case _menuLayers w of
         w
     (_ : _) -> w
     []  -> checkEndGame 
+        . updateRadialDistortions
         . updateTriggers
         . ppEvents 
         . updateCamera
@@ -89,6 +90,17 @@ updateCreatureGroups :: World -> World
 updateCreatureGroups w = w & creatureGroups %~ 
     IM.mapMaybe (\cgp -> _crGroupUpdate cgp w cgp)
 
+updateRadialDistortions :: World -> World
+updateRadialDistortions = radDistortion %~ mapMaybe decreaseBulge
+
+decreaseBulge 
+    :: (Point2,Point2,Point2,Float) 
+    -> Maybe (Point2,Point2,Point2,Float)
+decreaseBulge (a,b,c,v)
+    | v > 1 = Just (a,b,c,max 1 (v - 0.05) )
+    | v < 1 = Just (a,b,c,min 1 (v + 0.05) )
+    | otherwise = Nothing
+
 updateTriggers :: World -> World
 updateTriggers w 
     | ResetLevel 1 `S.member` _worldTriggers w = generateLevelFromRoomList levx $ initialWorld 

src/Render.hs

@@ -187,6 +187,16 @@ pingPongBetween (fb1,to1) (fb2,to2) fs = do
     textureBinding Texture2D $= Just to2
     drawShader fs 4
 
+drawTextureOnFramebuffer
+    :: FullShader
+    -> FramebufferObject
+    -> TextureObject
+    -> IO ()
+drawTextureOnFramebuffer fs fbo to = do
+    bindFramebuffer Framebuffer $= fbo
+    textureBinding Texture2D $= Just to
+    drawShader fs 4
+
 renderShader
     :: Foldable f
     => FullShader