loop/src/Dodge/Wall/Damage.hs

{-# LANGUAGE LambdaCase #-}

{- | Controls a walls response to external damage.
 - Indestructible walls may still produce sparks, dust etc
-}
module Dodge.Wall.Damage (
    damageWall,
) where

import Control.Monad
import Data.Foldable
import qualified Data.IntMap.Strict as IM
import Data.Maybe
import qualified Data.Set as S
import Dodge.Block
import Dodge.Block.Debris
import Dodge.Data.World
import Dodge.Door.DoorLerp
import Dodge.LightSource
import Dodge.Material.Damage
import Dodge.ShiftPoint
import Dodge.Wall.Delete
import Dodge.Zoning.Base
import Dodge.Zoning.Pathing
import Geometry.Data
import LensHelp
import Linear
--import qualified Data.IntSet as IS
import Dodge.Machine.Destroy

damageWall :: Int -> Damage -> World -> (S.Set Int2, World)
damageWall wlid dt w = fromMaybe (mempty,w) $ do
    wl <- w ^? cWorld . lWorld . walls . ix wlid 
    let (dmam, w') = damMatSideEffect dt (_wlMaterial wl) (Right wl) w
    return $ case wl ^. wlStructure of
        MachinePart mcid -> -- (,) mempty 
--            $ w' & cWorld . lWorld . machines . ix mcid . mcDamage .:~ dt
            w' & damageMachine dt dmam mcid
        BlockPart blid ->
            w' & damageBlock (wl ^. wlMaterial) dmam blid
        DoorPart drid _ ->
            w' & cWorld . lWorld . doors . ix drid . drHP -~ dmam
                & maybeDestroyDoor drid
        _ -> (mempty, w')

-- the way that sensor damage is registered is not yet ideal
damageMachine :: Damage -> Int -> Int -> World -> (S.Set Int2, World)
damageMachine dam x mcid w = case w ^? cWorld . lWorld . machines . ix mcid of
    Just mc | Just se <- mc ^? mcType . _McDamSensor
        , sensorTypeDamages (se ^. sensType) dam
        -> (mempty,mcDamSensorUpdate' (_dmAmount dam) se mc w)
    Just mc | McTurret{} <- mc ^. mcType
        , Electrical {_dmAmount=edam} <- dam
            -> (mempty, w & cWorld . lWorld . machines . ix mcid . mcType . mctTurretStun %~ (min 100 . (+ edam)))
    Just mc | _mcHP mc < x -> destroyMachine' mc w
    _ -> (mempty, w & cWorld . lWorld . machines . ix mcid . mcHP -~ x)

mcDamSensorUpdate' :: Int -> DamageSensor -> Machine -> World -> World
mcDamSensorUpdate' x se = senseDamage' x (damageTypeThreshold' (se ^. sensType))

senseDamage' :: Int -> Int -> Machine -> World -> World
senseDamage' x threshold mc =
    (cWorld . lWorld . machines . ix mcid %~ upmc)
        . updatels
  where
    upmc =
        mcType
            . _McDamSensor
            . sensAmount
            %~ min (100 * threshold)
            . max 0
            . (+ newsense)
    mcid = _mcID mc
    newsense
        | x > 0 = x
        | otherwise = -5
--      where
--        f = sensorTypeDamages dt
--        x = sum . map _dmAmount $ filter f (_mcDamage mc)
    ni = fromIntegral (mc ^?! mcType . _McDamSensor . sensAmount) / fromIntegral threshold
    updatels = fromMaybe id $ do
        lsid <- mc ^? mcMounts . ix OTLightSource
        return $ cWorld . lWorld . lightSources . ix lsid . lsParam . lsCol .~ V3 ni ni ni

damageTypeThreshold' :: SensorType -> Int
damageTypeThreshold' = \case
    LaserSensor -> 1000
    ElectricSensor -> 500
    ThermalSensor -> 1000
    PhysicalSensor -> 1000

sensorTypeDamages :: SensorType -> Damage -> Bool
sensorTypeDamages = \case
    LaserSensor -> \case
        Lasering{} -> True
        _ -> False
    ElectricSensor -> \case
        Electrical{} -> True
        _ -> False
    ThermalSensor -> \case
        Flaming{} -> True
        Sparking{} -> True
        Explosive{} -> True
        _ -> False
    PhysicalSensor -> \case
        Piercing{} -> True
        Blunt{} -> True
        Crushing{} -> True
        Explosive{} -> True
        _ -> False

destroyMachine' :: Machine -> World -> (S.Set Int2, World)
destroyMachine' mc w = (js, destroyMachine mc w)
  where
    wlids = IM.keys $ mc ^. mcFootPrint
    f wlid = w ^?! cWorld . lWorld . walls . ix wlid . wlLine
    js = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize) . f) wlids


-- block destruction is convoluted...
damageBlock :: Material -> Int -> Int -> World -> (S.Set Int2, World)
damageBlock = \case
    Glass -> damageGlassBlock
    _ -> maybeDestroyBlock

damageGlassBlock :: Int -> Int -> World -> (S.Set Int2, World)
damageGlassBlock x i w = fromMaybe (mempty,w) $ do
    guard $ x > 0
    bl <- w ^? cWorld . lWorld . blocks . ix i
    return $ case bl ^. blHP - x of
        y | y > 0 -> (mempty, w
            & flip (foldl' unshadowBlock) (_blShadows bl)
            & cWorld . lWorld . blocks . ix i . blHP .~ 1)
        _ -> destroyBlock bl w

maybeDestroyBlock :: Int ->  Int -> World -> (S.Set Int2, World)
maybeDestroyBlock x blid w = case w ^? cWorld . lWorld . blocks . ix blid of
    Just bl | _blHP bl < x -> destroyBlock bl w
    _ -> (mempty, w & cWorld . lWorld . blocks . ix blid . blHP -~ x)

maybeDestroyDoor :: Int -> World -> (S.Set Int2, World)
maybeDestroyDoor drid w = case w ^? cWorld . lWorld . doors . ix drid of
    Just dr | _drHP dr < 1 -> destroyDoor dr w
    _ -> (mempty, w)

destroyDoor :: Door -> World -> (S.Set Int2, World)
destroyDoor dr w =
    ( is
    , w
        & makeDoorDebris dr
        & deleteWallIDs wlids
        & cWorld . lWorld . doors . at (dr ^. drID) .~ Nothing -- %~ IM.delete (_drID dr)
        --        & muchWlDustAt awl (0.5 * uncurry (+) (_drPos dr))
        --        & flip (foldl' (flip $ muchWlDustAt awl)) (map (pos +.+) ps)
        & stopPushing (dr ^. drPushes)
        & destroyMounts pa (dr ^. drMounts)
    )
  where
    pa = doDoorLerp dr (dr ^. drLerp)
    is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
    ps = (dr ^. drFootPrint) & each . each %~ shiftPointBy pa
    wlids = IM.keysSet $ _drFootPrint dr

destroyMounts :: Point2A -> [MountedObject] -> World -> World
destroyMounts pa mos w = foldl' (flip $ destroyMount pa) w mos

destroyMount :: Point2A -> MountedObject -> World -> World
destroyMount pa = \case
    MountedLight x _ _ -> destroyLSFlashAt $ x & _xy %~ shiftPointBy pa
    MountedSPic{} -> id -- make debris?

stopPushing :: Maybe Int -> World -> World
stopPushing mdrid w = fromMaybe w $ do
    drid <- mdrid
    dr <- w ^? cWorld . lWorld . doors . ix drid
    return $
        w & cWorld . lWorld . doors . ix drid . drUpdate .~ DoorDoNothing
            & stopPushing (_drPushes dr)