Move flame into its own datatype

2022-07-18 22:41:40 +01:00
parent c14b3ff787
commit 54ba0fbedc
29 changed files with 444 additions and 318 deletions
@@ -0,0 +1,127 @@
+module Dodge.Flame 
+    ( aFlameParticle
+    , makeFlame
+    , moveFlame
+    ) where
+import Dodge.Data
+import Dodge.LightSource
+import Dodge.Zone
+import Dodge.WorldEvent.ThingsHit
+import Dodge.WorldEvent.Cloud
+import Dodge.SoundLogic
+import RandomHelp
+import Picture
+import Geometry
+import qualified IntMapHelp as IM
+import LensHelp
+import StreamingHelp
+
+import Data.Foldable
+import Data.Tuple
+import qualified Streaming.Prelude as S
+
+aFlameParticle 
+    :: Int      -- ^ Timer
+    -> Point2   -- ^ Position
+    -> Point2   -- ^ Velocity
+    -> Flame
+aFlameParticle t pos vel = Flame
+    { _flVel        = vel
+    , _flColor      = red
+    , _flPos        = pos
+    , _flWidth      = 4
+    , _flTimer      = t
+    , _flZ           = 20
+    , _flOriginalVel = vel
+    }
+simpleDamFL :: DamageType -> Int -> Flame -> Point2 -> [Damage]
+simpleDamFL dt amount bt p = [ Damage dt amount sp p ep NoDamageEffect ]
+  where
+    sp = _flPos bt
+    bulVel = _flVel bt
+    ep = sp +.+ bulVel
+expireAndDamageFL :: (Flame -> Point2 -> [Damage])
+    -> Flame
+    -> Stream (Of (Point2, Either Creature Wall)) Identity ()
+    -> World
+    -> (World, Maybe Flame)
+expireAndDamageFL fdm bt things w = case runIdentity $ S.head_ things of
+    Nothing -> (w, mvFlame bt)
+    Just x -> (doDamagesFL fdm x bt w, Nothing)
+doDamagesFL :: (Flame -> Point2 -> [Damage])
+    -> (Point2, Either Creature Wall)
+    -> Flame
+    -> World
+    -> World
+doDamagesFL fdm (p,thhit) bt = case thhit of
+    Left cr -> creatures . ix (_crID cr) . crState . csDamage .++~ dams
+    Right wl -> wallDamages %~ IM.insertWith (++) (_wlID wl) dams
+  where
+    dams = fdm bt p
+
+{- TODO: add generalised area damage particles/hiteffects.  -}
+moveFlame :: World 
+    -> Flame
+    -> (World, Maybe Flame)
+moveFlame w pt 
+    | time <= 0 = (makeFlamerSmokeAt (addZ 20 ep) w, Nothing)
+    | otherwise = case runIdentity . S.head_ $ thingsHit sp ep w of
+        Just (_,Left _)     -> (doSound $ dodamage w             , mvPt' 0.7)
+        Just (p,Right wl)   -> (doSound $ dodamage w  , rfl wl p)
+        _                   -> (flFlicker pt $ doSound $ dodamage w    , mvPt' 0.98)
+  where 
+    rotd = _flOriginalVel pt
+    time = _flTimer pt
+    doSound = soundContinue FlameSound (V2 x y) fireLoudS (Just 2)
+    sp@(V2 x y) = _flPos pt
+    vel = _flVel pt
+    ep = sp +.+ vel
+    mvPt' drag = Just $ pt
+        & flTimer -~ 1
+        & flPos .~ ep
+        & flVel %~ (drag *.*)
+    dodamage = flDamageInArea closeCrs closeWls pt
+    closeWls wl = uncurry segOnCirc (_wlLine wl) ep 5
+    closeCrs cr = dist ep (_crPos cr) 
+                    < _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80))
+                                + 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd)
+    angleCoeff x' = abs $ 1 - abs ( (x' * 2 - pi) / pi )
+    rfl wl p = Just $ pt 
+        { _flTimer = time - 1
+        , _flPos = pOut p
+        , _flVel = reflV wl
+        }
+    pOut p = p +.+ squashNormalizeV (sp -.- p)
+    reflV wall = (0.3 *.* reflectIn (uncurry (-.-) . swap $ _wlLine wall) vel )
+        +.+ (0.2 *.* vel)
+
+flDamageInArea :: (Creature -> Bool) -> (Wall -> Bool) -> Flame -> World -> World
+{-# INLINE flDamageInArea #-}
+flDamageInArea crt wlt pt w = damwls damcrs
+  where
+    p = _flPos pt
+    damcrs = foldl' (flip $ \cr -> fst . hiteff (S.yield (p,Left cr))) w $ IM.filter crt $ _creatures w
+    damwls w' = runIdentity
+        . S.fold_ 
+            (flip $ \wl -> fst . hiteff (S.yield (p,Right wl))) 
+            w' 
+            id
+        . S.filter wlt
+        $ wlsNearPoint p w'
+    hiteff = expireAndDamageFL (simpleDamFL FLAMING 1) pt
+
+mvFlame :: Flame -> Maybe Flame
+mvFlame pt = Just $ pt
+    & flTimer -~ 1
+
+flFlicker :: Flame -> World -> World
+flFlicker pt 
+    | _flTimer pt `mod` 7 == 0 = tempLightSources 
+        .:~ tlsTimeRadColPos 1 70 (0.5 *.*.* xyzV4 (_flColor pt)) (addZ 10 $ _flPos pt)
+    | otherwise = id
+makeFlame :: Point2 -> Point2 -> World -> World
+makeFlame pos vel w = w 
+    & flames .:~ aFlameParticle t pos vel
+    & randGen .~ g
+  where 
+    (t,g) = randomR (99,101) (_randGen w)