107 lines
3.5 KiB
Haskell
107 lines
3.5 KiB
Haskell
module Dodge.Block where
|
|
|
|
import Data.Set (Set)
|
|
import Dodge.Data.MountedObject
|
|
import Control.Lens
|
|
import Data.Foldable
|
|
import qualified Data.Graph.Inductive as FGL
|
|
import qualified Data.IntSet as IS
|
|
import Data.Maybe
|
|
import Dodge.Base.Collide
|
|
import Dodge.Block.Debris
|
|
import Dodge.Data.World
|
|
import Dodge.DrWdWd
|
|
import Dodge.LightSource
|
|
import Dodge.Material.Sound
|
|
import Dodge.Wall.Delete
|
|
import Dodge.Wall.Dust
|
|
import Dodge.Wall.Zone
|
|
import Dodge.WorldEvent.Sound
|
|
import Dodge.Zoning.Wall
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import RandomHelp
|
|
|
|
splinterBlock :: Block -> World -> World
|
|
splinterBlock bl w =
|
|
foldl' unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
|
|
& originsIDsAt
|
|
[MaterialSound bm 0, MaterialSound bm 1, MaterialSound bm 2]
|
|
(weakenMatS bm)
|
|
(_blPos bl)
|
|
where
|
|
bm = fromMaybe Stone $ do
|
|
wlids <- w ^? cWorld . blocks . ix (_blID bl) . blWallIDs
|
|
(wlid, _) <- IS.minView wlids
|
|
w ^? cWorld . walls . ix wlid . wlMaterial
|
|
|
|
unshadowBlock :: World -> Int -> World
|
|
unshadowBlock w wlid = case w ^? cWorld . walls . ix wlid of
|
|
Just wl ->
|
|
w
|
|
& cWorld . walls . ix wlid . wlUnshadowed .~ True
|
|
& insertWallInZones (wl & wlUnshadowed .~ True)
|
|
Nothing -> w
|
|
|
|
checkBlockHP :: Block -> World -> World
|
|
checkBlockHP bl
|
|
| _blHP bl < 1 = destroyBlock bl
|
|
| otherwise = id
|
|
|
|
destroyBlock :: Block -> World -> World
|
|
destroyBlock bl w =
|
|
w
|
|
& flip (foldl' unshadowBlock) (_blShadows bl)
|
|
& makeBlockDebris bl
|
|
& deleteWallIDs wlids
|
|
& maybeClearPaths (_blObstructs bl) -- must happen after the walls are deleted
|
|
& cWorld . blocks %~ IM.delete (_blID bl)
|
|
-- & matDesSound (_blMaterial bl) pos
|
|
& flip (foldl' $ flip (wlDustAt awl)) (map (pos +.+) ps)
|
|
where
|
|
wlids = _blWallIDs bl
|
|
awl = _walls (_cWorld w) IM.! IS.findMin wlids
|
|
pos = fst . _wlLine $ _walls (_cWorld w) IM.! IS.findMin wlids
|
|
ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
|
|
|
|
-- this does not handle eg doors blocking the path as well
|
|
maybeClearPaths :: Set (Int, Int, PathEdge) -> World -> World
|
|
maybeClearPaths ps w = foldl' maybeClearPath w ps
|
|
|
|
maybeClearPath :: World -> (Int, Int, PathEdge) -> World
|
|
maybeClearPath w (x, y, pe)
|
|
| not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w =
|
|
w
|
|
| otherwise = w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles .~ mempty) . FGL.delEdge (x, y)
|
|
|
|
destroyDoor :: Door -> World -> World
|
|
destroyDoor dr w =
|
|
w
|
|
& doDrWdWd (_drDeath dr) dr
|
|
& deleteWallIDs wlids
|
|
& cWorld . doors %~ IM.delete (_drID dr)
|
|
& flip (foldl' (flip $ wlDustAt awl)) (map (pos +.+) ps)
|
|
& stopPushing (_drPushes dr)
|
|
& destroyMounts (_drMounts dr)
|
|
where
|
|
wlids = _drWallIDs dr
|
|
awl = _walls (_cWorld w) IM.! IS.findMin wlids
|
|
pos = fst . _wlLine $ _walls (_cWorld w) IM.! IS.findMin wlids
|
|
ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
|
|
|
|
destroyMounts :: [MountedObject] -> World -> World
|
|
destroyMounts mos w = foldl' (flip destroyMount) w mos
|
|
|
|
destroyMount :: MountedObject -> World -> World
|
|
destroyMount mo = case mo of
|
|
MountedLS lsid -> destroyLS lsid
|
|
MountedProp prid -> cWorld . props . at prid .~ Nothing
|
|
|
|
stopPushing :: Maybe Int -> World -> World
|
|
stopPushing mdrid w = fromMaybe w $ do
|
|
drid <- mdrid
|
|
dr <- w ^? cWorld . doors . ix drid
|
|
return $
|
|
w & cWorld . doors . ix drid . drMech .~ DrWdId
|
|
& stopPushing (_drPushes dr)
|