Refactor flash lighting, determine (projected) namespace

2021-03-23 17:39:34 +01:00
parent e0d49cdf57
commit 3e2eaeece2
4 changed files with 53 additions and 122 deletions
@@ -663,7 +663,7 @@ aTeslaArc cid w = aTeslaArc' cid

 aTeslaArc' :: Int -> World -> World
 aTeslaArc' cid w = 
-                flareAt' cyan 0.03 0.1 (pos +.+ 5 *.* unitVectorAtAngle dir)
+                teslaGunFlashAt (pos +.+ 5 *.* unitVectorAtAngle dir)
                $ over projectiles (IM.insert i (makeTeslaArcAt i pos dir)) 
                $ set randGen g w
    where cr  = (_creatures w IM.! cid)
@@ -676,7 +676,7 @@ aTeslaArc' cid w =
 aLaser :: Int -> World -> World
 aLaser cid w = over particles' ( (:) (makeLaserAt phaseV pos dir (Just cid)))
                $ soundFrom LasSound 24 1 0 
-                $ flareAt' yellow 0.02 0.05 (pos +.+ 5 *.* unitVectorAtAngle dir)
+                $ laserGunFlashAt (pos +.+ 5 *.* unitVectorAtAngle dir)
                w
    where cr  = (_creatures w IM.! cid)
          i = newProjectileKey w
@@ -28,7 +28,7 @@ bulHitCr' bt p cr w =
                addDamageArmoured = over (creatures . ix cid . crState . crDamage)
                                    (\dams -> mvDams ++ dams)
                hitSound = soundMultiFrom [CrHitSound 0] 15 10 0
-                flashEff = over worldEvents ((.) $ flareAt' red 0.02 0.05 p)
+                flashEff = over worldEvents ((.) $ bloodFlashAt p)
                bulVel = _btVel' bt
                ck cid  = (+.+) (crKnockBack cid *.* bulVel)
                crKnockBack cid = (/) 1 $ (+) 2 $ _crMass $ _creatures w IM.! cid
@@ -170,7 +170,8 @@ moveInverseShockWave t p r push pushexp w pt
 createSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
 createSpark time colid pos dir maycid w = over worldEvents 
                                        ((.) $ ( over particles' ((:) spark) 
-                                               . flareAt' white 0.02 0.05 pos')
+--                                               . flareAt' white 0.02 0.05 pos')
+                                               . sparkFlashAt pos')
                                        ) w
    where spark = Bul'  { _ptPict' = blank
                        , _ptUpdate' = mvGenBullet'
@@ -192,8 +193,7 @@ createSpark time colid pos dir maycid w = over worldEvents
 createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
 createBarrelSpark time colid pos dir maycid w = over worldEvents 
                                        ((.) $ ( over particles' ((:) spark) 
-                                               . flareAt' white 0.005 0.03 pos')
-                                               -- . lowLightAt' pos)
+                                               . sparkFlashAt pos')
                                        ) w
    where spark = Bul'  { _ptPict' = blank
                        , _ptUpdate' = mvGenBullet'
@@ -216,8 +216,8 @@ noEff _ _ _ = id

 makeFlameletTimed :: Point2 -> Point2 -> Int -> Maybe Int -> Float -> Int -> World -> World
 makeFlameletTimed  pos vel levelInt maycid size time w
-    = set randGen g $ over particles' ((:) theFlamelet) 
-        $ flareAt' white 0.01 0.1 pos w
+    = set randGen g $ over particles' ((:) theFlamelet) w
+--        $ flareAt' white 0.01 0.1 pos w
    where   theFlamelet =
                Pt' { _ptPict'         = blank
                     , _ptUpdate'      = moveFlamelet levelInt rot
@@ -13,20 +13,43 @@ import Geometry
 import Data.Maybe (maybeToList)

 import Control.Lens
+-- projected naming: three base types of light:
+-- glare : "low lighting", draws lines around creatures and walls
+-- flare : coloured light drawn on top of picture in fixed shapes
+-- light : removal of shadows
+-- duration (subject to modification):
+-- flash   : short, abrupt changes in alpha
+-- glow    : continuous, potentially long, fading, slow changes in alpha
+-- flicker : potentially long, moving, abrupt changes in alpha

-flareAt' :: Color -> Float -> Float -> Point2 -> World -> World
-flareAt' col alphax alphay p 
-    = -- over particles' ((:) (flashColAt col alphax p))
-      -- . 
-      lowLightColAt col alphay p
+sparkFlashAt :: Point2 -> World -> World
+sparkFlashAt p =
+    over particles' ((:) (flashFlareAt white 0.2 p))
+        . glareAt 2 10 5 white 0.05 20 30 p

-lowLightColAt :: Color -> Float ->  Point2 -> World -> World
-lowLightColAt col alphay p w = foldr (lowLightWidthHit 10 5 col alphay p) w ps
-    where ps = map ((+.+) p) $ nRaysRad 20 30
+bloodFlashAt :: Point2 -> World -> World
+bloodFlashAt p = 
+    over particles' ((:) (flashFlareAt red 0.2 p))
+        . glareAt 2 10 5 red 0.05 20 30 p

-lowLightWidthForHit :: Float -> Float -> Color -> Float -> Int -> Point2 -> Point2 -> World -> World
-lowLightWidthForHit len wdth col alphay t a b w = w & particles' %~ (maybeToList glareLine ++)
-    where glareLine = glareBetween t len wdth col alphay a b w
+teslaGunFlashAt :: Point2 -> World -> World
+teslaGunFlashAt p =
+    over particles' ((:) (flashFlareAt cyan 0.3 p))
+        . glareAt 2 10 5 cyan 0.1 20 30 p
+
+laserGunFlashAt :: Point2 -> World -> World
+laserGunFlashAt p =
+    over particles' ((:) (flashFlareAt yellow 0.2 p))
+        . glareAt 2 10 5 yellow 0.05 20 30 p
+
+glareAt :: Int -> Float -> Float -> Color -> Float -> Int -> Float -> Point2 -> World -> World
+glareAt t len wdth col alphay nrays rad p w = foldr (glareLine t len wdth col alphay p) w ps
+    where ps = map ((+.+) p) $ nRaysRad nrays rad
+
+glareLine :: Int -> Float -> Float -> Color -> Float -> Point2 -> Point2 -> World -> World
+glareLine t len wdth col alphay a b w = w & particles' %~ (maybeToList linePt ++)
+    where linePt :: Maybe Particle'
+          linePt = glareBetween t len wdth col alphay a b w

 glareBetween :: Int -> Float -> Float -> Color -> Float -> Point2 -> Point2 -> World -> Maybe Particle'
 glareBetween 0 _   _    _   _      _ _ _ = Nothing
@@ -49,92 +72,23 @@ lowLightPic len wdth col alphay a b w
        _   -> blank
    where setCol = color (withAlpha alphay col) . setDepth 0 . setLayer 1

-lowLightWidthHit :: Float -> Float -> Color -> Float -> Point2 -> Point2 -> World -> World
-lowLightWidthHit len wdth col alphay a b w 
-    = case thingsHitLongLine a b w of
-        ((p, E3x2 wall):_) 
-            -> over particles' ((:) (wallGlareWidth len wdth col alphay p wall)) w
-        ((p, E3x1 cr):_) 
-            -> over particles' ((:) (crGlareWidth wdth col alphay p cr)) w
-        _  -> w
-
-flashColAt :: Color -> Float -> Point2 -> Particle'
-flashColAt col alphax (x,y) =
+flashFlareAt :: Color -> Float -> Point2 -> Particle'
+flashFlareAt col alphax (x,y) =
    Particle' 
-        { _ptPict' = pictures $
-                         map (\i -> onLayerL [levLayer PtLayer] 
-                                    $ color (withAlpha alphax col) $ translate x y $ circleSolid i
-                         )
-                         [20,25,30,35,40,45,50]
+        { _ptPict' = setLayer 2 . setDepth (-0.9) . translate x y 
+                            $ circleSolidCol (withAlpha 0 col) (withAlpha alphax col) 30
        , _ptUpdate' = ptTimer' 1
        }
-wallGlareFor :: Int -> Float -> Float -> Color -> Float -> Point2 -> Wall -> Particle'
-wallGlareFor t len wdth col alphay p wl = 
-    Particle'
-        { _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l
-        , _ptUpdate' = ptTimer' t
-        }
-    where l = color (withAlpha alphay col) $ lineOfThickness wdth $ [p +.+ x, p -.- x]
-          x = len *.* ( normalizeV $ a -.- b)
-          (a:b:_) = _wlLine wl
-
-wallGlareWidth :: Float -> Float -> Color -> Float -> Point2 -> Wall -> Particle'
-wallGlareWidth len wdth col alphay p wl = 
-    Particle'
-        { _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l
-        , _ptUpdate' = ptTimer' 1
-        }
-    where l = color (withAlpha alphay col) $ lineOfThickness wdth $ [p +.+ x, p -.- x]
-          x = len *.* ( normalizeV $ a -.- b)
-          (a:b:_) = _wlLine wl
-
-crGlareFor :: Int -> Float -> Color -> Float -> Point2 -> Creature -> Particle'
-crGlareFor t wdth col alphay p cr =
-    Particle'
-        { _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l cp
-        , _ptUpdate' = \w pt -> (w, Just $ pt {_ptPict' = onLayerL [levLayer GloomLayer + 2] $ upp cid w
-                                              ,_ptUpdate' = ptTimer' (t - 1)
-                                              }
-                                )
-        }
-    where l x = uncurry translate x
-                $ rotate (-0.25*pi + argV (p -.- x))
-                $ color (withAlpha alphay col) 
-                $ thickArc 0 (pi/2) (_crRad cr) wdth
-          cp = _crPos cr
-          cid = _crID cr
-          upp cid' w' = case w' ^? creatures . ix cid . crPos of
-                            Just y -> l y 
-                            _      -> blank
-
-crGlareWidth :: Float -> Color -> Float -> Point2 -> Creature -> Particle'
-crGlareWidth wdth col alphay p cr =
-    Particle'
-        { _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l cp
-        , _ptUpdate' = \w pt -> (w, Just $ pt {_ptPict' = onLayerL [levLayer GloomLayer + 2] $ upp cid w
-                                              ,_ptUpdate' = ptTimer' 0
-                                              }
-                                )
-        }
-    where l x = uncurry translate x
-                $ rotate (-0.25*pi + argV (p -.- x))
-                $ color (withAlpha alphay col) 
-                $ thickArc 0 (pi/2) (_crRad cr) wdth
-          cp = _crPos cr
-          cid = _crID cr
-          upp cid' w' = case w' ^? creatures . ix cid . crPos of
-                            Just y -> l y 
-                            _      -> blank

 flareWidth :: Float -> Float -> Float -> Int -> Color -> Float -> Float -> Point2 -> World -> World
 flareWidth len wdth rad rays col ax ay p
    = over particles' ((:) (flashRadAt rad col ax p))
-      . lowLightWidthAt len wdth col ay rays rad p
+      . glareAt 2 len wdth col ay rays rad p

 flareRad :: Float -> Int -> Color -> Float -> Float -> Point2 -> World -> World
 flareRad rad rays col ax ay p
    = over particles' ((:) (flashRadAt rad col ax p))
-      . lowLightWidthAt 10 5 col ay rays rad p
+      . glareAt 2 10 5 col ay rays rad p

 flashRadAt :: Float -> Color -> Float -> Point2 -> Particle'
 flashRadAt rad col alphax (x,y) =
@@ -147,33 +101,23 @@ flashRadAt rad col alphax (x,y) =
        , _ptUpdate' = ptTimer' 1
        }

-lowLightWidthAt :: Float -> Float -> Color -> Float -> Int -> Float -> Point2 -> World -> World
-lowLightWidthAt len wdth col alphay rays rad p w = foldr (lowLightWidthHit len wdth col alphay p) w ps
-    where ps = map ((+.+) p) $ nRaysRad rays rad
-
-lowLightAtFor :: Float -> Float -> Color -> Float -> Int -> Float -> Point2 -> Int -> World -> World
-lowLightAtFor len wdth col alphay rays rad p t w 
-    = foldr (lowLightWidthForHit len wdth col alphay t p) w ps
-    where ps = map ((+.+) p) $ nRaysRad rays rad
-
-
 explosionFlashAt :: Point2 -> World -> World
 explosionFlashAt p =  over tempLightSources ((:) $ tLightFade 20 150 intensityFunc p)
-                    . lowLightAtFor 10 5 white 0.3 75 150 p 20 
+                    . glareAt 20 10 5 white 0.3 75 150 p
    where intensityFunc x 
            | x < 10 = 1 / (10 - fromIntegral x)
            | otherwise = 1

-flameGlareAt = lowLightWidthAt 10 5 orange 0.05 8 50
+flameGlareAt = glareAt 2 10 5 orange 0.05 8 50

 lowLightDirected :: Color -> Float -> Point2 -> Point2 -> [Float] -> World -> World
 lowLightDirected col alpha a b angles w
-    = foldr (\angle w' -> lowLightWidthHit 10 5 col alpha a (a +.+ rotateV angle b) w') w angles
+    = foldr (\angle w' -> glareLine 2 10 5 col alpha a (a +.+ rotateV angle b) w') w angles


 muzFlareAt :: Point2 -> World -> World
 muzFlareAt p = over particles' ((:) (muzzleFlarePt p))
-                . lowLightWidthAt 10 5 white 0.5 20 30 p
+                . glareAt 2 10 5 white 0.5 20 30 p

 muzzleFlarePt :: Point2 -> Particle'
 muzzleFlarePt (x,y) =
@@ -187,18 +131,5 @@ muzzleFlarePt (x,y) =


 lowLightAt :: Point2 -> World -> World
-lowLightAt p w = lowLightWidthAt 10 5 white 0.5 20 30 p w
+lowLightAt p w = glareAt 2 10 5 white 0.5 20 30 p w

-lowLightAt' :: Point2 -> World -> World
-lowLightAt' p w = foldr (lowLightHit' p) w ps
-    where ps = map ((+.+) p) $ nRaysRad 20 30
-
-lowLightHit' :: Point2 -> Point2 -> World -> World
-lowLightHit' a b w 
-    = case thingsHitLongLine a b w of
-        ((p, E3x2 wall):_) 
-            -> over particles' ((:) (wallGlare' p wall)) w
-        _  -> w
-
-wallGlare' :: Point2 -> Wall -> Particle'
-wallGlare' p wl = wallGlareWidth 5 5 white 0.1 p wl