First pass implementing exponentially fading lighting

src/Picture/Preload.hs

@@ -33,6 +33,7 @@ data PreloadData = PreloadData
     , _arcVAO  :: VAO
     , _backVAO :: VAO
     , _wallVAO :: VAO
+    , _fadeCircVAO :: VAO
     , _posVBO :: BufferObject
     , _colVBO :: BufferObject
     , _texVBO :: BufferObject
@@ -40,6 +41,9 @@ data PreloadData = PreloadData
     , _csZoomUni :: UniformLocation
     , _asWinUni :: UniformLocation
     , _asZoomUni :: UniformLocation
+    , _fcsWinUni  :: UniformLocation
+    , _fcsZoomUni :: UniformLocation
+    , _wssLightPos :: UniformLocation
     , _dummyVBO :: BufferObject
     , _dummyPtr :: Ptr Float
     }
@@ -112,6 +116,8 @@ doPreload' = do
     asWinSizeUniLoc <- GL.uniformLocation as "winSize"
     asZoomUniLoc    <- GL.uniformLocation as "zoom"
     wssLightPosUniLoc   <- GL.uniformLocation wss "lightPos"
+    fcsWinSizeUniLoc <- GL.uniformLocation fcs "winSize"
+    fcsZoomUniLoc    <- GL.uniformLocation fcs "zoom"
 -- get uniform locations
 
 --setup vbos
@@ -164,6 +170,7 @@ doPreload' = do
     arcvao  <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,4)]
     backgroundvao <- setupVAO [(posVBO,0,4),(colVBO,1,2)]
     wallvao <- setupVAO [(posVBO,0,4),(colVBO,1,4)]
+    fadecircvao <- setupVAO [(posVBO,0,4)]
     
     return $ PreloadData
         { -- _charMap      = convertRGBA8 cmap
@@ -182,6 +189,7 @@ doPreload' = do
         , _lineVAO = linevao
         , _backVAO = backgroundvao
         , _wallVAO = wallvao
+        , _fadeCircVAO = fadecircvao
         , _posVBO = posVBO
         , _colVBO = colVBO
         , _texVBO = texVBO
@@ -191,6 +199,9 @@ doPreload' = do
         , _csZoomUni  = zoomUni
         , _asWinUni = asWinSizeUniLoc
         , _asZoomUni = asZoomUniLoc
+        , _wssLightPos = wssLightPosUniLoc
+        , _fcsWinUni = fcsWinSizeUniLoc
+        , _fcsZoomUni = fcsZoomUniLoc
         }
 
 vaoPointers :: VAO -> [Ptr Float]

src/Picture/Render.hs

@@ -248,8 +248,44 @@ threePtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
     (a:b:c:_) -> (a,b,c)
 
 renderPicture' :: PreloadData -> Float -> Float -> (Float,Float) -> (Float,Float) ->
-                    [(Point2,Point2,Point2,Point2)] -> Picture -> IO ()
-renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints pic = do
+                    [(Point2,Point2,Point2,Point2)] -> [Point4] -> Picture -> IO ()
+renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do
+    depthFunc $= Just Lequal
+
+    bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
+    let wallPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _wallVAO pdata
+        wallPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _wallVAO pdata) !! 1
+        foldWalls n ((x,y),(z,w),(a,b),(c,d)) = do
+                pokeFourOff wallPtr  n (x,y,z,w)
+                pokeFourOff wallPtr2 n (a,b,c,d)
+                return $ n+1
+    nWalls <- foldM foldWalls 0 wallPoints 
+
+    forM_ lightPoints $ \(x,y,r,lum) -> do
+        cullFace $= Just Front
+        clear [DepthBuffer]
+        currentProgram $= Just (_wallShadowShader pdata)
+        bindArrayBuffers (length wallPoints) $ _vaoBufferTargets $ _wallVAO pdata
+        bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
+        uniform (_wssLightPos pdata)  $= Vector2 (x) (y)
+        blendFunc $= (Zero,One)
+        drawArrays Points (fromIntegral 0) (fromIntegral $ length wallPoints)
+        cullFace $= Nothing
+        currentProgram $= Just (_fadeCircleShader pdata)
+        bindVertexArrayObject $= Just (_vao $ _fadeCircVAO pdata)
+        let fadeCircPtr = (\(_,ptr,_) -> ptr) $ head $ _vaoBufferTargets $ _fadeCircVAO pdata
+        pokeFourOff fadeCircPtr 0 (x,y,r,lum)
+        bindArrayBuffers (1) $ _vaoBufferTargets $ _fadeCircVAO pdata
+        uniform (_fcsWinUni pdata) $= Vector2 winx winy
+        uniform (_fcsZoomUni pdata)  $= zoom
+    -- to refactor: put these uniforms in a ubo
+        blendFuncSeparate    $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
+        drawArrays Points (fromIntegral 0) (fromIntegral 1)
+
+-- set drawing for on top
+        blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
+        clear [DepthBuffer]
+
     let firstIndex = 0
 
     (nTriVs,nTextVs,numCircVs,nLineVs,nArcVs) 
@@ -263,18 +299,6 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints pic = do
 
     depthFunc $= Just Less
 
-    currentProgram $= Just (_wallShadowShader pdata)
-    bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
-    let wallPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _wallVAO pdata
-        wallPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _wallVAO pdata) !! 1
-        foldWalls n ((x,y),(z,w),(a,b),(c,d)) = do
-                pokeFourOff wallPtr  n (x,y,z,w)
-                pokeFourOff wallPtr2 n (a,b,c,d)
-                return $ n+1
-    nWalls <- foldM foldWalls 0 wallPoints 
-    bindArrayBuffers (length wallPoints) $ _vaoBufferTargets $ _wallVAO pdata
-    drawArrays Points (fromIntegral 0) (fromIntegral $ length wallPoints)
-    
     currentProgram $= Just (_backShader pdata)
     bindVertexArrayObject $= Just (_vao $ _backVAO pdata)
     let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _backVAO pdata
@@ -316,6 +340,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints pic = do
     bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
     textureBinding Texture2D $= Just (_textures pdata !! 0)
     drawArrays Points (fromIntegral firstIndex) (fromIntegral $ nTextVs)
+    
 
 bufferOffset :: Integral a => a -> Ptr b
 bufferOffset = plusPtr nullPtr . fromIntegral