loop/src/Dodge/Bullet.hs

module Dodge.Bullet 
    ( updateBullet
    , useAmmoParams
    ) where
import Dodge.EnergyBall
import Dodge.Creature.Test
import Dodge.Data
import Dodge.Creature.HandPos
import Dodge.Base.Coordinate
import Dodge.WorldEvent.SpawnParticle
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

updateBullet :: World -> Bullet -> (World,Maybe Bullet)
updateBullet w bu = case _buState bu of
    DyingBulletState -> (w,Nothing)
    DelayedBullet x -> mvBullet x w bu
    _ -> mvBullet 1 w bu

useAmmoParams :: Item -> Creature -> World -> World
useAmmoParams it cr w = w & instantBullets .:~ (_amBullet bultype
    & buPos .~ sp 
    & buTrajectory %~ settrajectory
    & buVel %~ (rotateV dir . (muzvel *.*))
    & buDrag *~ _rifling (_itParams it)
    )
  where
    sp = _crPos cr +.+ (muzlength + 10) *.* unitVectorAtAngle dir
    dir = _crDir cr
    bultype = _laAmmoType $ _itConsumption it
    muzvel = _muzVel $ _itParams it
    muzlength = aimingMuzzlePos cr it
    settrajectory traj = case traj of
        BasicBulletTrajectory -> BasicBulletTrajectory
        MagnetTrajectory{} -> fromMaybe BasicBulletTrajectory $ do
            tpos <- it ^? itTargeting . tgPos . _Just
            return $ MagnetTrajectory tpos
        FlechetteTrajectory{} -> fromMaybe BasicBulletTrajectory $ do
            tpos <- it ^? itTargeting . tgPos . _Just
            return $ FlechetteTrajectory tpos
        BezierTrajectory{} -> fromMaybe BasicBulletTrajectory $ do
            tpos <- it ^? itTargeting . tgPos . _Just
            return $ BezierTrajectory sp tpos (mouseWorldPos w)

{- Update for a generic bullet.  -}
mvBullet :: Float -> World -> Bullet -> (World, Maybe Bullet)
mvBullet x w bt' 
    | t <= 0 || magV (_buVel bt) < 1 = (endspawn w,Nothing)
    | otherwise = bimap (maybespawn . maybebounce) (fmap dodrag) $ 
        hiteff bt hitstream w
  where
    endspawn w' = fromMaybe w' $ do
        partspawn <- bulletSpawn bt'
        return $ partspawn p w'
    maybespawn w' = fromMaybe w' $ do
        (hp,_) <- runIdentity (S.head_ hitstream)
        partspawn <- bulletSpawn bt'
        return $ partspawn (hp +.+ normalizeV (_buPos bt' -.- hp)) w'
    maybebounce = fromMaybe id $ do
        guard (_buEffect bt' == BounceBullet)
        (hp,crwl) <- runIdentity (S.head_ hitstream)
        dir <- bounceDir (hp,crwl)
        return $ instantBullets .:~ (bt
            & buPos .~ hp +.+ normalizeV (_buPos bt' -.- hp)
            & buVel %~ reflectIn dir
            & buTrajectory .~ BasicBulletTrajectory
            & buTimer -~ 1
            )
    hitstream = thingsHit p (p +.+ vel) w
    bt = foldr (\mg b -> _mgField mg mg b) bt' (_magnets w)
        & buState .~ NormalBulletState
    dodrag = case _buTrajectory bt of
        BasicBulletTrajectory -> buVel .*.*~ drag
        MagnetTrajectory tpos -> buVel .+.+~ 5 *.* normalizeV (tpos -.- _buPos bt)
        FlechetteTrajectory tpos -> buVel %~ vecTurnTo 0.2 (_buPos bt) tpos
        BezierTrajectory spos tpos xpos -> 
            let bf tm = bQuadToF (spos,xpos,tpos) $ (100 - tm) * 0.05
            in buVel .~ bf (fromIntegral $ _buTimer bt - 1) -.- bf (fromIntegral $ _buTimer bt)
    drag = _buDrag bt
    p       = _buPos bt
    vel     = _buVel bt
    hiteff  = hitEffFromBul x
    t       = _buTimer bt

bounceDir :: (Point2, Either Creature Wall) -> Maybe Point2
bounceDir (_,Right wl) = Just $ uncurry (-.-) (_wlLine wl)
bounceDir (p,Left  cr) | crIsArmouredFrom p cr = Just $ vNormal $ p -.- _crPos cr
bounceDir _ = Nothing

bulletSpawn :: Bullet -> Maybe (Point2 -> World -> World)
bulletSpawn bu = case _buSpawn bu of
    BulSpark -> Nothing
    BulBall IncBall -> Just incBallAt
    BulBall ConcBall -> Just $ randParticleAt concBall
    BulBall TeslaBall -> Just makeStaticBall
--  where
--    dosatate st p w = w'
--        & 
--      where
--        (pt,g) = runState do
--        partspawn <- bulletSpawn bt'
--        let (thepart,g) = runState (partspawn hp) $ _randGen w'
--        return $ w' & instantParticles .:~ thepart
--            & randGen .~ g

hitEffFromBul :: Float -> Bullet
    -> Stream (Of (Point2, Either Creature Wall)) Identity ()
    -> World 
    -> (World,Maybe Bullet)
hitEffFromBul x = expireAndDamage' x setfromtodams
  where
    setfromtodams bu p = map f (_buDamages bu)
      where
        f = (dmFrom .~ _buPos bu) . (dmAt .~ p) . (dmTo .~ _buPos bu +.+ _buVel bu)

expireAndDamage' :: Float -> (Bullet -> Point2 -> [Damage])
    -> Bullet
    -> Stream (Of (Point2, Either Creature Wall)) Identity ()
    -> World
    -> (World, Maybe Bullet)
expireAndDamage' y fdm bt things w = case runIdentity $ S.head_ things of
    Nothing -> (w, moveBullet y bt)
    Just x -> (doDamages' fdm x bt w, destroyAt' (fst x) bt)

moveBullet :: Float -> Bullet -> Maybe Bullet
moveBullet x pt = Just $ pt
    & buPos %~ (+.+ x *.* _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, moveBullet 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, moveBullet 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