Generalise flame flicker, cleanup

2021-10-31 14:18:57 +00:00
parent 49db8f804e
commit c443cc4372
3 changed files with 37 additions and 104 deletions
@@ -13,6 +13,7 @@ import Geometry.Data
 import Picture

 import Control.Lens
+import System.Random

 makeCloudAt 
    :: (Cloud -> Picture) -- ^ draw function
@@ -64,8 +65,10 @@ makeStartCloudAt = makeCloudAt (drawCloudWith 2 800 white) 10 400 5
 shellTrailCloud :: Point3 -> World -> World
 shellTrailCloud = makeCloudAt (drawCloudWith (4/3) 800 (greyN 0.5)) 15 400 40

-makeFlamerSmokeAt :: Float -> Point3 -> World -> World
-makeFlamerSmokeAt x = makeCloudAt (drawCloudWith 4 300 (greyN x)) 6 200 40
+makeFlamerSmokeAt :: Point3 -> World -> World
+makeFlamerSmokeAt p w = makeCloudAt (drawCloudWith 4 300 (greyN x)) 6 200 40 p w
+  where
+    x = fst $ randomR (0.5,0.8) (_randGen w)

 spawnSmokeAtCursor :: World -> World
 spawnSmokeAtCursor w = shellTrailCloud (V3 x y 20) w
@@ -14,11 +14,13 @@ module Dodge.WorldEvent.Flash
    , laserGunFlashAt
    , teslaGunFlashAt
    , muzFlareAt
+    , flameFlicker
    )
    where
 import Dodge.Data
 import Dodge.LightSources.Lamp
 import Dodge.WorldEvent.HelperParticle
+import Dodge.Default
 import Picture
 import Geometry

@@ -65,3 +67,15 @@ explosionFlashAt p = tempLightSources %~ (tLightTimedIntensity 20 150 intensityF

 sparkFlashAt :: Point2 -> World -> World
 sparkFlashAt _ = id
+
+flameFlicker :: Particle -> World -> World
+flameFlicker pt 
+    | _btTimer' pt `mod` 5 == 0 = tempLightSources %~ (theLight :)
+    | otherwise = id
+  where
+    V2 x y = _btPos' pt
+    theLight = defaultTLS
+        { _tlsPos = V3 x y 10
+        , _tlsRad = 70
+        , _tlsIntensity = V3 0.5 0 0
+        }
@@ -11,7 +11,6 @@ module Dodge.WorldEvent.SpawnParticle
 import Dodge.Data
 import Dodge.Data.DamageType
 import Dodge.Data.SoundOrigin
-import Dodge.Default
 import Dodge.Creature.State.Data
 import Dodge.Base
 import Dodge.Zone
@@ -21,7 +20,7 @@ import Dodge.Picture
 import Dodge.WorldEvent.HitEffect
 import Dodge.WorldEvent.ThingsHit
 import Dodge.WorldEvent.Cloud
--import Dodge.WorldEvent.Flash
+import Dodge.WorldEvent.Flash
 import Dodge.Particle.Bullet.Draw
 import Dodge.Particle.Bullet.Update
 import Dodge.SoundLogic
@@ -49,7 +48,7 @@ aFlameParticle
    -> Particle
 aFlameParticle t pos vel maycid = PtZ
    { _ptDraw         = drawFlame vel
-    , _ptUpdate      = moveFlame vel
+    , _ptUpdate       = moveFlame vel
    , _btVel'         = vel
    , _btColor'       = red
    , _btPos'         = pos
@@ -97,35 +96,24 @@ moveFlame
    -> Particle
    -> (World, Maybe Particle)
 moveFlame rotd w pt 
-    | time <= 0 = (smokeGen w, Nothing)
+    | time <= 0 = (makeFlamerSmokeAt (addZ 20 ep) w, Nothing)
    | otherwise = case thingsHitExceptCr (_btPassThrough' pt) sp ep w of
-        ((_,E3x1 _):_)       -> (doSound damcrs        , mvPt')
-        (thing@(p,E3x2 wl):_) -> (fst $ hiteff [thing] damcrs , rfl wl p)
-        _                     -> (glare $ doSound damcrs        , mvPt)
+        ((_,E3x1 _):_)       -> (doSound damcrs        , mvPt 0.7)
+        (thing@(p,E3x2 wl):_) -> (doSound . fst $ hiteff [thing] damcrs , rfl wl p)
+        _                     -> (flameFlicker pt $ doSound damcrs        , mvPt 0.98)
  where 
    time = _btTimer' pt
-    doSound = soundContinue Flame (V2 x y) fireLoudS (Just 2) -- . over worldEvents ((.) $ flameGlareAt ep)
-    glare 
-        | time `mod` 5 == 0
-                    = tempLightSources %~ (theTLS :)
-        | otherwise = id
-    theTLS = defaultTLS
-        { _tlsPos = V3 x y 10
-        , _tlsRad = 70
-        , _tlsIntensity = V3 0.5 0 0
-        }
+    doSound = soundContinue Flame (V2 x y) fireLoudS (Just 2)
    sp@(V2 x y) = _btPos' pt
    vel = _btVel' pt
    ep = sp +.+ vel
-    mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep
-                     , _btPassThrough' = Nothing
-                     ,_btVel' = 0.98 *.* vel}
-    mvPt' = Just $ pt {_btTimer' = time - 1, _btPos' = ep
-                     , _btPassThrough' = Nothing
-                     ,_btVel' = 0.7 *.* vel}
+    mvPt speed = Just $ pt 
+        { _btTimer' = time - 1
+        , _btPos' = ep
+        , _btPassThrough' = Nothing
+        , _btVel' = speed *.* vel    }
    damcrs = foldr (\cr -> fst . hiteff [(ep,E3x1 cr)]) w 
-        $ filter closeCrs 
-        $ IM.elems $ _creatures w
+        $ IM.filter closeCrs $ _creatures w
    closeCrs cr = dist ep (_crPos cr) 
                    < _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80))
                                + 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd)
@@ -139,8 +127,6 @@ moveFlame rotd w pt
    pOut p = p +.+ safeNormalizeV (sp -.- p)
    reflV wall = (0.3 *.* reflectIn (uncurry (-.-) . swap $ _wlLine wall) vel )
        +.+ (0.2 *.* vel)
-    smokeCol = fst $ randomR (0.5,0.8) (_randGen w)
-    smokeGen = makeFlamerSmokeAt smokeCol (addZ 20 ep)

 makeFlameletTimed 
    :: Point2       -- ^ Position
@@ -152,12 +138,12 @@ makeFlameletTimed
    -> World 
    -> World
 makeFlameletTimed (V2 x y) z vel maycid size time w = w
-    & randGen   .~ g 
+    & randGen   .~ g
    & particles %~ (theFlamelet :)
  where   
    theFlamelet = PtZ 
        { _ptDraw         = drawFlameletZ rot
-        , _ptUpdate      = moveFlamelet
+        , _ptUpdate       = moveFlamelet
        , _btVel'         = vel
        , _btColor'       = red
        , _btPos'         = V2 x y
@@ -188,7 +174,6 @@ drawFlameletZ rot pt = pictures
    time = _btTimer' pt
    piu = setDepth (z + 25)
        .  uncurryV translate ep 
-        -- . color (V4 2 (-0.5) (-0.5) 1) 
        . color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) 
                           (V4 2 0 0 1)                          (V4 2 0 0 0)
                   )
@@ -215,53 +200,12 @@ drawFlameletZ rot pt = pictures
    s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
    s2 = 0.5 * (sc + s1)

-drawFlamelet 
-    :: Float    -- ^ Rotation
-    -> Particle
-    -> Picture
-drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow]
-  where
-    sp = _btPos' pt
-    vel = _btVel' pt
-    ep = sp +.+ vel
-    size = _btWidth' pt
-    siz2 = size + 0.2
-    time = _btTimer' pt
-    glow = setDepth 19 $ uncurryV translate ep
-                $ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30
-    piu = setDepth 20
-        .  uncurryV translate ep 
-        . color (dark red) 
-        . rotate (negate (rot - 0.1 * fromIntegral time))
-        . scale s1 s1
-        . polygon 
-        $ rectNSWE siz2 (-siz2) (-siz2) siz2
-    pi2 = setDepth 20.2
-        . uncurryV translate ep
-        . color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) 
-                           orange                          (dark red)
-                   )
-        . rotate (negate (rot + 0.2 * fromIntegral time))
-        . scale s2 s2
-        . polygon 
-        $ rectNSWE siz2 (-siz2) (-siz2) siz2
-    pic = setDepth 20.4
-        . uncurryV translate ep
-        . color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) 
-                           white                           (dark red)
-                )
-        . rotate (negate ( 0.1 * fromIntegral time + rot))
-        . scale sc sc
-        $ polygon $ map toV2 [(-size,-size),(size,-size),(size,size),(-size,size)]
-    sc = (*) 2 $ log $ 1 + fromIntegral time / 20
-    s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
-    s2 = 0.5 * (sc + s1)
 {- Update of a flamelet.
 Applies movement and attaches damage to nearby creatures.  -}
 moveFlamelet :: World -> Particle -> (World, Maybe Particle)
 moveFlamelet w pt 
    | _btTimer' pt <= 0 = (     w, Nothing)
-    | otherwise         = (damcrs,    mvPt)
+    | otherwise         = (flameFlicker pt $ damcrs,    mvPt)
  where   
    sp = _btPos' pt
    vel = _btVel' pt
@@ -298,7 +242,6 @@ makeGasCloud pos vel w = w
        , _clEffect = cloudPoisonDamage
        }
    (col, g) = runState (takeOne [green,yellow]) $ _randGen w
-
 {-
 Attach poison cloud damage to creatures near cloud.
 -}
@@ -307,7 +250,7 @@ cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedC
  where 
    damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint (stripZ $ _clPos c) w
    f cr = dist3 (addZ 20 $ _crPos cr) (_clPos c) < _crRad cr + _clRad c + 10
-    doDam cr = cr & crState . crDamage %~ (:) (PoisonDam 1)
+    doDam cr = cr & crState . crDamage %~ (PoisonDam 1 :)
 makeTeslaArcAt :: Color -> Point2 -> Float -> Particle
 makeTeslaArcAt col pos dir = LinearParticle
    { _ptPoints = [pos]
@@ -431,37 +374,11 @@ crOrWallSensitive p dir wlAttract w =
    g _ = 0
    (arcLen,_) = randomR (25,50) $ _randGen w
 -- BUG: can hit crs through walls
-{- Finds whether a creature or wall is in front of a given point and direction.
-Evaluates to a creature as an 'E3x1' or a wall as an 'E3x2'.  -}
-crOrWall :: Point2 -> Float -> World -> Either3 Creature Point2 Point2
-crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (V2 arcLen 0))
-                        $ listToMaybe $ sortBy (compare `on` g)
-                                        $ catMaybes [cr,wlp]
-  where 
-    cr  = E3x1 <$> nearestCrInFront p dir 100 w
-    wlp = fmap E3x2 
-        $ listToMaybe
-        $ sortBy (compare `on` dist p)
-        $ mapMaybe 
-            ( fmap fst
-            . (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
-            . (+.+) p
-            . (\d -> rotateV d (V2 100 0))
-            . (+) dir
-            )
-            [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8]
-            --[-pi/4,-pi/8,0,pi/8,pi/4]
-    g (E3x2 p1)  = 100 + dist p p1 -- tweak makes it more likely to hit crs first
-    --g (E3x2 p1)  = dist p p1 - 100 -- tweak makes it more likely to hit walls first
-    g (E3x1 cr1) = dist p $ _crPos cr1
-    g _ = 0
-    (arcLen,_) = randomR (25,50) $ _randGen w
 -- | 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 -> World -> World
-createSparkCol time col pos dir w 
-    = w & worldEvents %~ ( over particles (spark :) . )
+createSparkCol time col pos dir = worldEvents %~ ( over particles (spark :) . )
  where 
    spark = BulletPt
        { _ptDraw = drawBul
@@ -479,4 +396,3 @@ createSparkCol time col pos dir w
      where 
        sp = head (_btTrail' bt)
        ep = sp +.+ _btVel' bt
-