First pass implementing exponentially fading lighting

2021-02-22 13:45:59 +01:00
parent c75cda639b
commit e855d303e8
10 changed files with 117 additions and 49 deletions
@@ -17,7 +17,7 @@ lightAt p i =
       ,_lsPos = p
       ,_lsDir = 0
       ,_lsRad = 300
-       ,_lsIntensity = 0.25
+       ,_lsIntensity = 0.5
       }

 basicLS = PutLS ls dec
@@ -513,7 +513,7 @@ wallsForGloom' w = map (wallPairToFour . _wlLine) $ filter (not . _wlIsSeeThroug
                                $ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w

    where wallPairToFour (x:y:_) = (ss x,ss y,ss $ x +.+ n,ss $ y+.+ n)
-            where n = 20 *.* (normalizeV $ vNormal $ y -.- x)
+            where n = 15 *.* (normalizeV $ vNormal $ y -.- x)
          ss' v = rotateV (0 - _cameraRot w) (v -.- _cameraPos w)
          ss'' (a,b) = (a*2*zoom / _windowX w,b*2*zoom / _windowY w)
          ss = ss'' . ss'
@@ -521,6 +521,17 @@ wallsForGloom' w = map (wallPairToFour . _wlLine) $ filter (not . _wlIsSeeThroug
 -- shader
          zoom = _cameraZoom w

+lightsForGloom' :: World -> [(Point4)]
+lightsForGloom' w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)
+    where getLS ls  = ( fst $ ssls ls, snd $ ssls ls,  _lsRad ls , _lsIntensity ls)
+          getTLS ls = ( fst $ sstls ls,snd $ sstls ls, _tlsRad ls, _tlsIntensity ls)
+          ss' v = rotateV (0 - _cameraRot w) (v -.- _cameraPos w)
+          ss'' (a,b) = (a*2*zoom / _windowX w,b*2*zoom / _windowY w)
+          ss = ss'' . ss'
+          ssls = ss . _lsPos 
+          sstls = ss . _tlsPos 
+          zoom = _cameraZoom w
+
 lightsForGloom :: World -> [(Point2,Float,Float)]
 lightsForGloom w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)
    where getLS ls = (screenShift $ _lsPos ls, _lsRad ls * zoom, _lsIntensity ls)
@@ -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]
@@ -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