Add file

2021-03-25 13:28:57 +01:00
parent 45e02d0752
commit de31daf21e
1 changed files with 58 additions and 0 deletions
@@ -0,0 +1,58 @@
+module Dodge.WorldEvent.HitEffect
+    where
+import Dodge.Data
+
+import Geometry
+
+import Data.Bifunctor
+import Data.Maybe
+
+import Control.Lens
+
+type HitCreatureEffect   = Particle' -> Point2 -> Creature   -> World -> World
+type HitWallEffect       = Particle' -> Point2 -> Wall       -> World -> World
+type HitForceFieldEffect = Particle' -> Point2 -> ForceField -> World -> World
+
+passThroughAll :: HitCreatureEffect -> HitWallEffect -> HitForceFieldEffect ->
+     Particle' -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle')
+passThroughAll crEff wlEff ffEff pt hitThings w = (w, mvPt)
+  where 
+    mvPt = Just $ pt & btTrail' .~ (newP : trl)
+                     & btTimer' %~ (\t -> t - 1)
+                     & btPassThrough' .~ Nothing
+    trl = _btTrail' pt
+    newP = head trl +.+ _btVel' pt
+
+destroyOnImpact :: HitCreatureEffect -> HitWallEffect -> HitForceFieldEffect ->
+     Particle' -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle')
+destroyOnImpact crEff wlEff ffEff pt hitThings w = case hitThings of
+        []              -> (              w, mvPt)
+        ((p,E3x1 cr):_) -> (crEff pt p cr w, destroyAt p)
+        ((p,E3x2 wl):_) -> (wlEff pt p wl w, destroyAt p)
+        ((p,E3x3 ff):_) -> (ffEff pt p ff w, destroyAt p)
+    where destroyAt hitp = Just $ pt & btTrail' .~ (hitp : trl)
+                                     & btTimer' .~ 3
+          mvPt = Just $ pt & btTrail' .~ (newP : trl)
+                           & btTimer' %~ (\t -> t - 1)
+                           & btPassThrough' .~ Nothing
+          trl = _btTrail' pt
+          wth = _btWidth' pt
+          newP = head trl +.+ _btVel' pt
+
+penWalls :: HitCreatureEffect -> HitWallEffect -> HitForceFieldEffect ->
+     Particle' -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle')
+penWalls crEff wlEff ffEff pt hitThings w = case hitThings of
+        []              -> (              w, mvPt)
+        ((p,E3x1 cr):_)  -> (crEff pt p cr w, destroyAt p)
+        ((p,E3x3 ff):_)  -> (ffEff pt p ff w, destroyAt p)
+        ((p,E3x2 wl):hs) | isJust (wl ^? blHP) 
+                                     -> first (wlEff pt p wl) $ penWalls crEff wlEff ffEff pt hs w
+        ((p,E3x2 wl):_)  | otherwise -> (wlEff pt p wl w, destroyAt p)
+    where destroyAt hitp = Just $ pt & btTrail' .~ (hitp : trl)
+                                     & btTimer' .~ 3
+          mvPt = Just $ pt & btTrail' .~ (newP : trl)
+                           & btTimer' %~ (\t -> t - 1)
+                           & btPassThrough' .~ Nothing
+          trl = _btTrail' pt
+          wth = _btWidth' pt
+          newP = head trl +.+ _btVel' pt