82 lines
2.7 KiB
Haskell
82 lines
2.7 KiB
Haskell
module Dodge.Block (
|
|
splinterBlock,
|
|
destroyBlock,
|
|
) where
|
|
|
|
import Dodge.Zoning.Wall
|
|
import Dodge.Base.Collide
|
|
import Control.Monad
|
|
import Dodge.Path
|
|
import Control.Lens
|
|
import Data.Foldable
|
|
import qualified Data.IntSet as IS
|
|
import Data.Maybe
|
|
import Dodge.Block.Debris
|
|
import Dodge.Data.World
|
|
import Dodge.Material.Sound
|
|
import Dodge.Wall.Delete
|
|
import Dodge.Wall.Zone
|
|
import Dodge.WorldEvent.Sound
|
|
import qualified IntMapHelp as IM
|
|
|
|
splinterBlock :: Block -> World -> World
|
|
splinterBlock bl w =
|
|
foldl' unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
|
|
& soundOriginsIDsAt
|
|
[MaterialSound bm 0, MaterialSound bm 1, MaterialSound bm 2]
|
|
(weakenMatS bm)
|
|
(_blPos bl)
|
|
where
|
|
bm = fromMaybe Stone $ do
|
|
wlids <- w ^? cWorld . lWorld . blocks . ix (_blID bl) . blWallIDs
|
|
(wlid, _) <- IS.minView wlids
|
|
w ^? cWorld . lWorld . walls . ix wlid . wlMaterial
|
|
|
|
unshadowBlock :: World -> Int -> World
|
|
unshadowBlock w wlid = case w ^? cWorld . lWorld . walls . ix wlid of
|
|
Just wl ->
|
|
w
|
|
& cWorld . lWorld . 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 . lWorld . blocks %~ IM.delete (_blID bl)
|
|
-- & muchWlDustAt awl (_blPos bl)
|
|
-- & flip (foldl' $ flip (muchWlDustAt awl)) (map (pos +.+) ps)
|
|
where
|
|
wlids = _blWallIDs bl
|
|
-- awl = w ^?! cWorld . lWorld . walls . ix (IS.findMin wlids)
|
|
-- pos = fst . _wlLine $ awl
|
|
-- ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
|
|
|
|
-- this does not handle eg doors blocking the path as well
|
|
maybeClearPaths :: [(Int,Int)] -> World -> World
|
|
maybeClearPaths ps w = foldl' maybeClearPath w ps
|
|
|
|
maybeClearPath :: World -> (Int,Int) -> World
|
|
maybeClearPath w (i,j) = fromMaybe w $ do
|
|
x <- getNodePos i w
|
|
y <- getNodePos j w
|
|
guard $ null $ overlapSegWalls x y $ wlsNearSeg x y w
|
|
return $ w & cWorld . incGraph %~ updateEdge f (i,j)
|
|
where
|
|
f = at BlockObstacle .~ Nothing
|
|
---- | 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)
|
|
|