diff --git a/src/Dodge/WorldEvent/HitEffect.hs b/src/Dodge/WorldEvent/HitEffect.hs new file mode 100644 index 000000000..ddcd9988d --- /dev/null +++ b/src/Dodge/WorldEvent/HitEffect.hs @@ -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