Rename (indexed) particles to projectiles

2021-03-23 14:03:00 +01:00
parent 941fef134d
commit 885fa4a67e
11 changed files with 245 additions and 251 deletions
@@ -0,0 +1,55 @@
+module Dodge.WorldEvent.Projectile
+    where
+import Dodge.Data
+import Control.Lens
+
+import Data.Bifunctor
+import Data.Maybe
+
+import Picture
+
+import Geometry
+
+type HitCreatureEffect   = Particle' -> Point2 -> Creature   -> World -> World
+type HitWallEffect       = Particle' -> Point2 -> Wall       -> World -> World
+type HitForceFieldEffect = Particle' -> Point2 -> ForceField -> World -> World
+
+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)
+                                     & ptPict'  .~ drawBul wth (hitp: trl)
+                                     & btTimer' .~ 3
+          mvPt = Just $ pt & btTrail' .~ (newP : trl)
+                           & ptPict'  .~ drawBul wth (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)
+                                     & ptPict'  .~ drawBul wth (hitp: trl)
+                                     & btTimer' .~ 3
+          mvPt = Just $ pt & btTrail' .~ (newP : trl)
+                           & ptPict'  .~ drawBul wth (newP : trl)
+                           & btTimer' %~ (\t -> t - 1)
+                           & btPassThrough' .~ Nothing
+          trl = _btTrail' pt
+          wth = _btWidth' pt
+          newP = head trl +.+ _btVel' pt
+drawBul :: Float -> [Point2] -> Picture
+drawBul width (a:b:_) = setLayer 1 . color white $ thickLine [a,b] width
+drawBul _     _       = blank