100 lines
3.3 KiB
Haskell
100 lines
3.3 KiB
Haskell
module Dodge.Block where
|
|
import Dodge.Data
|
|
import Dodge.Base.Collide
|
|
import Dodge.Material.Sound
|
|
import Dodge.Block.Debris
|
|
import Dodge.Zone
|
|
import Dodge.LightSource
|
|
import Dodge.Wall.Zone
|
|
import Dodge.WorldEvent.Sound
|
|
import Dodge.Wall.Delete
|
|
import Dodge.Wall.Dust
|
|
import RandomHelp
|
|
import Geometry
|
|
--import Geometry.ConvexPoly
|
|
|
|
import Data.Foldable
|
|
import Data.Function
|
|
import Data.Maybe
|
|
import qualified Data.IntSet as IS
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Control.Lens
|
|
import qualified Streaming.Prelude as S
|
|
import qualified Data.Graph.Inductive as FGL
|
|
|
|
splinterBlock :: Block -> World -> World
|
|
splinterBlock bl w = foldr 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 ^? blocks . ix (_blID bl) . blWallIDs
|
|
(wlid,_) <- IS.minView wlids
|
|
w ^? walls . ix wlid . wlMaterial
|
|
|
|
unshadowBlock :: Int -> World -> World
|
|
unshadowBlock wlid w = case w ^? walls . ix wlid of
|
|
Just wl -> w
|
|
& 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 (foldr unshadowBlock) (_blShadows bl)
|
|
& makeBlockDebris bl
|
|
& deleteWallIDs wlids
|
|
& maybeClearPaths (_blObstructs bl) -- must happen after the walls are deleted
|
|
& blocks %~ IM.delete (_blID bl)
|
|
-- & matDesSound (_blMaterial bl) pos
|
|
& flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
|
|
where
|
|
wlids = _blWallIDs bl
|
|
awl = _walls w IM.! IS.findMin wlids
|
|
pos = fst . _wlLine $ _walls 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 :: [(Int,Int,PathEdge)] -> World -> World
|
|
maybeClearPaths ps w = foldl' maybeClearPath w ps
|
|
|
|
maybeClearPath :: World -> (Int,Int,PathEdge) -> World
|
|
maybeClearPath w (x,y,pe)
|
|
| runIdentity . S.any_ (const True) $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w
|
|
= w
|
|
| otherwise = w & pathGraph %~ FGL.insEdge (x,y,pe & peObstacles .~ mempty) . FGL.delEdge (x,y)
|
|
|
|
destroyDoor :: Door -> World -> World
|
|
destroyDoor dr w = w
|
|
& _drDeath dr dr
|
|
& deleteWallIDs wlids
|
|
& doors %~ IM.delete (_drID dr)
|
|
& flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
|
|
& stopPushing (_drPushes dr)
|
|
& destroyMounts (_drMounts dr)
|
|
where
|
|
wlids = _drWallIDs dr
|
|
awl = _walls w IM.! IS.findMin wlids
|
|
pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids
|
|
ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
|
|
|
|
destroyMounts :: [MountedObject] -> World -> World
|
|
destroyMounts mos w = foldr destroyMount w mos
|
|
|
|
destroyMount :: MountedObject -> World -> World
|
|
destroyMount mo = case mo of
|
|
MountedLS lsid -> destroyLS lsid
|
|
MountedProp prid -> props . at prid .~ Nothing
|
|
|
|
stopPushing :: Maybe Int -> World -> World
|
|
stopPushing mdrid w = fromMaybe w $ do
|
|
drid <- mdrid
|
|
dr <- w ^? doors . ix drid
|
|
return $ w & doors . ix drid . drMech .~ const id
|
|
& stopPushing (_drPushes dr)
|