112 lines
3.7 KiB
Haskell
112 lines
3.7 KiB
Haskell
module Dodge.Block (
|
|
splinterBlock,
|
|
destroyBlock,
|
|
destroyDoor,
|
|
) where
|
|
|
|
import Control.Lens
|
|
import Data.Foldable
|
|
import qualified Data.Graph.Inductive as FGL
|
|
import qualified Data.IntSet as IS
|
|
import Data.Maybe
|
|
import Data.Set (Set)
|
|
import Dodge.Base.Collide
|
|
import Dodge.Block.Debris
|
|
import Dodge.Data.MountedObject
|
|
import Dodge.Data.World
|
|
import Dodge.DrWdWd
|
|
import Dodge.LightSource
|
|
import Dodge.Material.Sound
|
|
import Dodge.Wall.Delete
|
|
import Dodge.Wall.Zone
|
|
import Dodge.WorldEvent.Sound
|
|
import Dodge.Zoning.Wall
|
|
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 :: Set PathEdgeNodes -> World -> World
|
|
maybeClearPaths ps w = foldl' maybeClearPath w ps
|
|
|
|
maybeClearPath :: World -> PathEdgeNodes -> World
|
|
maybeClearPath w (PathEdgeNodes 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 . lWorld . doors %~ IM.delete (_drID dr)
|
|
-- & muchWlDustAt awl (0.5 * uncurry (+) (_drPos dr))
|
|
-- & flip (foldl' (flip $ muchWlDustAt awl)) (map (pos +.+) ps)
|
|
& stopPushing (_drPushes dr)
|
|
& destroyMounts (_drMounts dr)
|
|
where
|
|
wlids = _drWallIDs dr
|
|
--awl = _walls (_cWorld w) IM.! IS.findMin wlids
|
|
-- awl = w ^?! cWorld . lWorld . walls . ix (IS.findMin wlids)
|
|
-- pos = fst . _wlLine $ awl
|
|
-- 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 . lWorld . props . at prid .~ Nothing
|
|
|
|
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 . drMech .~ DrWdId
|
|
& stopPushing (_drPushes dr)
|