Continue bullet refactor

src/Dodge/Bullet.hs

@@ -2,7 +2,6 @@ module Dodge.Bullet where
 import Dodge.WorldEvent.SpawnParticle
 import Dodge.Creature.Test
 import Dodge.Data
-import Dodge.Particle.HitEffect.ExpireAndDamage
 import Dodge.Creature.HandPos
 import Dodge.Base.Coordinate
 import Dodge.Base.Wall
@@ -10,13 +9,13 @@ import Geometry
 import LensHelp
 import StreamingHelp
 
+import qualified Data.IntMap.Strict as IM
 import qualified Streaming.Prelude as S
 import Data.Maybe
 import Dodge.Movement.Turn
 import Dodge.WorldEvent.ThingsHit
 import Control.Monad.State
 import System.Random
-
 --import Data.Bifunctor
 
 updateBullet :: World -> Bullet -> (World,Maybe Bullet)
@@ -30,7 +29,6 @@ aBulAt
     -> Point2   -- ^ Start position
     -> Point2  -- ^ Velocity
     -> Float    -- ^ Drag
---    -> HitEffect' 
     -> Float    -- ^ Bullet width
     -> BulletTrajectory
     -> BulletEffect
@@ -55,38 +53,33 @@ aBulAt vfact pos vel drag width butraj be bs dams = Bullet
     bulstate = maybe NormalBulletState DelayedBullet vfact
 
 useAmmoParams :: Maybe Float -> Item -> Creature -> World -> World
-useAmmoParams vfact it cr w = w & instantBullets .:~ aBulAt 
-    vfact 
-    sp
-    (rotateV dir (muzvel *.* _amBulVel bultype))           -- vel
-    (_rifling $ _itParams it)   -- drag
-    (_amBulWth bultype) 
-    thetraj
-    (_amBulEffect bultype)
-    (_amBulSpawn bultype)
-    (_amBulDams bultype)
+useAmmoParams vfact it cr w = w & instantBullets .:~ (_amBullet bultype
+    & buPos .~ sp 
+    & buTrajectory %~ settrajectory
+    & buVel %~ (rotateV dir . (muzvel *.*))
+    & buDrag *~ _rifling (_itParams it)
+    & buState %~ setstate
+    )
   where
+    setstate = case vfact of
+        Nothing -> id
+        Just x  -> const $ DelayedBullet x
     sp = _crPos cr +.+ (muzlength + 10) *.* unitVectorAtAngle dir
     dir = _crDir cr
     bultype = _laAmmoType $ _itConsumption it
     muzvel = _muzVel $ _itParams it
     muzlength = aimingMuzzlePos cr it
-    thetraj = case _amBulTraj bultype of
+    settrajectory traj = case traj of
         BasicBulletTrajectory -> BasicBulletTrajectory
         MagnetTrajectory{} -> fromMaybe BasicBulletTrajectory $ do
             tpos <- it ^? itTargeting . tgPos . _Just
             return $ MagnetTrajectory tpos
-            --return $ \pt -> pt & buVel .+.+~ 5 *.* normalizeV (tpos -.- _buPos pt)
         FlechetteTrajectory{} -> fromMaybe BasicBulletTrajectory $ do
             tpos <- it ^? itTargeting . tgPos . _Just
             return $ FlechetteTrajectory tpos
-            --return $ \pt -> pt & buVel %~ vecTurnTo 0.2 (_buPos pt) tpos
         BezierTrajectory{} -> fromMaybe BasicBulletTrajectory $ do
             tpos <- it ^? itTargeting . tgPos . _Just
             return $ BezierTrajectory sp tpos (mouseWorldPos w)
---            let bf t = bQuadToF (sp,mouseWorldPos w,tpos) $ (100 - t) * 0.05
---            return $ \pt -> pt 
---                & buVel .~ bf (fromIntegral $ _buTimer pt - 1) -.- bf (fromIntegral $ _buTimer pt)
 
 {- Update for a generic bullet.  -}
 mvBullet :: World -> Bullet -> (World, Maybe Bullet)
@@ -168,3 +161,66 @@ mvBulletSlow x w bt'
     vel     = x *.* _buVel bt
     hiteff  = hitEffFromBul
     t       = _buTimer bt
+expireAndDamage' :: (Bullet -> Point2 -> [Damage])
+    -> Bullet
+    -> Stream (Of (Point2, Either Creature Wall)) Identity ()
+    -> World
+    -> (World, Maybe Bullet)
+expireAndDamage' fdm bt things w = case runIdentity $ S.head_ things of
+    Nothing -> (w, mvPt bt)
+    Just x -> (doDamages' fdm x bt w, destroyAt' (fst x) bt)
+mvPt :: Bullet -> Maybe Bullet
+mvPt pt = Just $ pt
+    & buPos %~ (+.+ _buVel pt)
+    & buOldPos .~ _buPos pt
+    & buTimer -~ 1
+
+destroyAt' :: Point2 -> Bullet -> Maybe Bullet
+destroyAt' hitp pt = Just $ pt 
+    & buState  .~ DyingBulletState
+    & buPos     .~ hitp
+    & buOldPos  .~ _buPos pt
+    & buTimer   %~ (min 3 . subtract 1)
+
+penWalls 
+    :: HitCreatureEffect' 
+    -> HitWallEffect' 
+    -> Bullet 
+    -> [(Point2, Either Creature Wall)] 
+    -> World 
+    -> (World, Maybe Bullet)
+penWalls crEff wlEff pt hitThings w = case hitThings of
+    []              -> (              w, mvPt pt)
+    ((p,Left cr):_) -> (crEff pt p cr w, destroyAt' p pt)
+    ((p,Right wl):hs) | _wlFireThrough wl 
+                    -> first (wlEff pt p wl) $ penWalls crEff wlEff pt hs w
+    ((p,Right wl):_) -> (wlEff pt p wl w, destroyAt' p pt)
+
+type HitCreatureEffect'   = Bullet -> Point2 -> Creature   -> World -> World
+type HitWallEffect'       = Bullet -> Point2 -> Wall       -> World -> World
+
+doDamages' :: (Bullet -> Point2 -> [Damage])
+    -> (Point2, Either Creature Wall)
+    -> Bullet
+    -> World
+    -> World
+doDamages' 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
+
+penetrate 
+    :: ((Point2,Either Creature Wall) -> Bullet -> Maybe Bullet) 
+        -- | penetration test, can update particle if it penetrates
+    -> (Bullet -> Point2 -> [Damage]) -- | damages when penetrating
+    -> (Bullet -> Point2 -> [Damage]) -- | damages when not penetrating
+    -> Bullet
+    -> Stream (Of (Point2, Either Creature Wall)) Identity ()
+    -> World
+    -> (World, Maybe Bullet)
+penetrate t pendam stopdam pt hitThings w = case runIdentity $ S.uncons hitThings of
+    Nothing -> (w, mvPt pt)
+    Just (x,xs) -> case t x pt of
+        Nothing -> expireAndDamage' stopdam pt hitThings w
+        Just pt' -> first (doDamages' pendam x pt) $ penetrate t pendam stopdam pt' xs w