Add toggle for shadows on clouds

2021-09-03 23:47:22 +01:00
parent fd85093833
commit 1ab3f1773c
6 changed files with 38 additions and 43 deletions
@@ -8,6 +8,7 @@ module Dodge.Config.Data (
    , volume_sound
    , volume_music
    , wall_textured
+    , cloud_shadows
    , resolution_factor
    , windowX
    , windowY
@@ -23,6 +24,7 @@ data Configuration = Configuration
    , _volume_sound         :: Float
    , _volume_music         :: Float
    , _wall_textured        :: Bool
+    , _cloud_shadows        :: Bool
    , _resolution_factor    :: Int -- ^ Higher values divide screen size, i.e. make the resolution worse
    , _windowX              :: Float
    , _windowY              :: Float
@@ -42,6 +44,7 @@ defaultConfig = Configuration
    , _volume_sound         = 1
    , _volume_music         = 1
    , _wall_textured        = False
+    , _cloud_shadows        = True
    , _resolution_factor    = 1
    , _windowX              = 800
    , _windowY              = 600
@@ -100,13 +100,12 @@ moveLaser phaseV pos dir w pt
      = case thHit of
          Just (p,E3x1 cr) 
              -> over (creatures . ix (_crID cr) . crState . crDamage) ((:) $ Lasering 19 pos p xp)
--                  . over worldEvents ((.) $ flareAt yellow (flarePos p))
          Just (p,E3x2 wl) -> createSparkCol 8 (V4 20 (-5) 0 1) (p +.+ safeNormalizeV (pos -.- p))
-                                                      (reflectDir wl) Nothing
+                                                      (reflectDir wl)
          _   -> id
    pic = setLayer 1 $ pictures
-        [ setDepth 19 . color (brightX 0 0.5 yellow) $ lineOfThickness 20 (pos:ps)
-        , setDepth 19.5 . color (brightX 10 1 yellow) $ lineOfThickness 3 (pos:ps)
+        [ setDepth 19   . color (brightX 0 0.5 yellow) $ lineOfThickness 20 (pos:ps)
+        , setDepth 19.5 . color (brightX 10 1 yellow)  $ lineOfThickness 3  (pos:ps)
        ]
        -- $ pictures 
        --[ fadeLine pos (head ps) 0.2 40 yellow
@@ -32,7 +32,6 @@ data MenuOption
        { _moKey    :: Scancode
        , _moEff    :: World -> Maybe World
        }
-
 optionsOptions :: [MenuOption]
 optionsOptions =
    [ Toggle ScancodeV (pushMenu SoundOptionMenu) (const "VOLUME")
@@ -73,11 +72,13 @@ graphicsMenuOptions :: [MenuOption]
 graphicsMenuOptions =
    [ Toggle ScancodeW (Just . (config . wall_textured %~ not))  wtextstring
    , Toggle ScancodeS upf resostring
+    , Toggle ScancodeD (Just . (config . cloud_shadows %~ not)) cshadstring
    ]
  where
    wtextstring w = "WALL TEXTURES:" ++ show (_wall_textured $ _config w)
    resostring w  = "RESOLUTION: 1/" ++ show (_resolution_factor $ _config w)
    upf w = Just $ updateFramebufferSize $ w & config . resolution_factor %~ cycleResolution
+    cshadstring w = "CLOUD SHADOWS:" ++ show (_cloud_shadows $ _config w)

 cycleResolution :: (Eq a, Num a, Num p) => a -> p
 cycleResolution 1 = 2
@@ -26,7 +26,7 @@ import Control.Monad.State
 bulHitCr :: Particle -> Point2 -> Creature -> World -> World
 bulHitCr bt p cr w 
    | crIsArmouredFrom p cr
-        = createSparkCol 8 colID p1 (argV (p1 -.- p) + d1) Nothing . addDamageArmoured $ w
+        = createSparkCol 8 colID p1 (argV (p1 -.- p) + d1) . addDamageArmoured $ w
    | otherwise = addDamage . makeHitSound . flashEff $ w
  where
    sp = head $ _btTrail' bt
@@ -135,7 +135,7 @@ bulConCr' bt p cr w
 {- | Hitting wall effects: create a spark, damage blocks.  -}
 bulHitWall' :: Particle -> Point2 -> Wall -> World -> World
 bulHitWall' bt p x w = damageBlocksBy 5 x
-    $ createSparkCol 8 theCol pOut (reflectDir x) Nothing
+    $ createSparkCol 8 theCol pOut (reflectDir x)
    $ set randGen g
    w
  where 
@@ -202,7 +202,7 @@ hvBulHitWall' bt p x w =  damageBlocksBy 5 x $ set randGen g $ foldr ($) w (spar
    cs      = map (brightX 100 1.5 . numColor) cs'
    ds      = randomRs (-0.7,0.7) $ _randGen w
    ts      = randomRs (4,8) $ _randGen w
-    sparks pos vel = zipWith3 (\t c d -> createSparkCol t c pos (argV vel + d) Nothing) ts cs ds
+    sparks pos vel = zipWith3 (\t c d -> createSparkCol t c pos (argV vel + d)) ts cs ds

 bulHitFF' :: Particle -> Point2 -> ForceField -> World -> World
 bulHitFF' _ _ _ = id
@@ -56,10 +56,8 @@ doDrawing pdata w = do
    -- poke wall points and colors
    nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol
    nSils <- pokePoint3s (shadVBOptr $ _lightingLineShadowShader pdata) 
-                $ 
-                --youSil w ++
-                creatureSilhouettes w ++
-                _foregroundEdgeVerx w
+        $ creatureSilhouettes w
+        ++ _foregroundEdgeVerx w
    -- poke foreground geometry for caps
    nCaps <- pokePoint3s (shadVBOptr $ _lightingCapShader pdata)
        $ concatMap polyToGeoRender (foregroundPics w)
@@ -132,30 +130,29 @@ doDrawing pdata w = do
    depthMask $= Disabled
    clearColor $= Color4 0.5 0.5 0.5 0
    --blendFunc $= (SrcAlphaSaturate,One)
-    blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha),(One,OneMinusSrcAlpha))
+    --blendColor $= Color4 0.5 0.5 0.5 0.5
+    blendFuncSeparate $= ((SrcAlphaSaturate,One) , (One,OneMinusSrcAlpha))
+    --blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha),(One,OneMinusSrcAlpha))
    drawBuffers $= [FBOColorAttachment 0,NoBuffers]
    clear [ColorBuffer]
    renderLayer 2 shadV layerCounts
    renderWindows pdata windowPoints
-    ----render transparency depths
-    depthMask $= Enabled
-    blend $= Disabled
-    drawBuffers $= [NoBuffers,FBOColorAttachment 1]
-    renderLayer 2 shadV layerCounts
-    renderWindows pdata windowPoints
-   -- --downscale transparency depths
-   -- bindFramebuffer Framebuffer $= fst (_fboHalf3 pdata)
-   -- bindTO (snd $ snd $ _fboCloud pdata)
-   -- depthFunc $= Just Always
-   -- drawShader (_fullscreenShader pdata) 4
-    ----draw lightmap for cloud buffer
-    depthMask $= Disabled
-    blend $= Enabled
-    bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
-    createLightMap pdata lightPoints nWalls nSils nCaps (snd $ snd $ _fboCloud pdata)
-   -- createLightMap pdata lightPoints nWalls nSils nCaps (snd $ _fboHalf3 pdata)
-    colorMask $= Color4 Enabled Enabled Enabled Enabled
-    clearColor $= Color4 0 0 0 0
+    if (_cloud_shadows $ _config w)
+        then do
+            ----render transparency depths
+            depthMask $= Enabled
+            blend $= Disabled
+            drawBuffers $= [NoBuffers,FBOColorAttachment 1]
+            renderLayer 2 shadV layerCounts
+            renderWindows pdata windowPoints
+            ----draw lightmap for cloud buffer
+            depthMask $= Disabled
+            blend $= Enabled
+            bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
+            createLightMap pdata lightPoints nWalls nSils nCaps (snd $ snd $ _fboCloud pdata)
+            colorMask $= Color4 Enabled Enabled Enabled Enabled
+            clearColor $= Color4 0 0 0 0
+        else return ()
    --apply lightmap to cloud buffer
    clearColor $= Color4 0 0 0 0
    bindFramebuffer Framebuffer $= fst (_fboCloud pdata)
@@ -192,12 +189,11 @@ doDrawing pdata w = do
        rds -> do
            let bindDrawDist :: (Point2,Point2,Point2,Float) -> IO ()
                bindDrawDist ( V2 a b , V2 c d , V2 e f , g) = do
-                    pokeArray (shadVBOptr $ _barrelShader pdata)
-                        [a,b,c,d,e,f,g]
+                    pokeArray (shadVBOptr $ _barrelShader pdata) [a,b,c,d,e,f,g]
                    bindShaderBuffers [_barrelShader pdata] [1]
                    drawShader (_barrelShader pdata) 1
                fboList = take (length rds - 1) (concat (repeat [fst $ _fbo2 pdata,fst $ _fbo3 pdata]))
-                        ++ [defaultFramebufferObject]
+                    ++ [defaultFramebufferObject]
                toList = fst (snd (_fboBase pdata)) : concat (repeat [snd $ _fbo2 pdata,snd $ _fbo3 pdata])
                bindings = zipWith (>>) (map bindFBO fboList) (map bindTO toList)
            activeTexture $= TextureUnit 1
@@ -209,13 +205,10 @@ doDrawing pdata w = do
    depthMask $= Disabled
    blend $= Enabled
    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-
    renderFoldable shadV $ fixedCoordPictures w
    depthMask $= Enabled
-
    eTicks <- SDL.ticks
    return (eTicks - sTicks)
-
 --------------------------------------------------------------------------------
 -- note: currently assume there is only one UBO, we only bind it once at setup
 bufferUBO :: [Float] -> IO ()
@@ -34,7 +34,6 @@ import Data.Function (on)
 import Data.List
 import Data.Maybe
 import Data.Tuple
-
 aFlameParticle 
    :: Int      -- ^ Timer
    -> Point2   -- ^ Position
@@ -330,7 +329,7 @@ moveTeslaArc
 moveTeslaArc p d w pt
    | t == 2 = 
        (foldr damCrs w hitCrs & randGen .~ g
-            & createSparkCol 8 nc q2 (argV sv + d1) Nothing
+            & createSparkCol 8 nc q2 (argV sv + d1)
        , Just $ pt 
            & ptTimer -~ 1
            & ptPoints .~ ps'
@@ -453,8 +452,8 @@ crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (V2 arcLen 0))
 -- | Create a spark. 
 -- If the spark is created by another Particle, it cannot be directly added to
 -- the list, hence the redirect through worldEvents.
-createSparkCol :: Int -> Color -> Point2 -> Float -> Maybe Int -> World -> World
-createSparkCol time col pos dir maycid w 
+createSparkCol :: Int -> Color -> Point2 -> Float -> World -> World
+createSparkCol time col pos dir w 
    = w & worldEvents %~ ( over particles (spark :) . )
  where 
    spark = BulletPt
@@ -463,7 +462,7 @@ createSparkCol time col pos dir maycid w
        , _btVel' = rotateV dir (V2 5 0)
        , _btColor' = col
        , _btTrail' = [pos]
-        , _btPassThrough' = maycid
+        , _btPassThrough' = Nothing
        , _btWidth' = 1
        , _btTimer' = time
        , _btHitEffect' = destroyOnImpact sparkEff noEff noEff