justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Refactor, try to limit dependencies

Browse Source
This commit is contained in:
justin
2022-07-28 00:59:56 +01:00
parent 8aa5c17ab9
commit 160560af5f
418 changed files with 15104 additions and 13342 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Block.hs
+51 -45
View File
@@ -1,42 +1,45 @@
module Dodge.Block where
import Dodge.DrWdWd
import Dodge.Zoning.Wall
import Dodge.Data
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.Material.Sound
import Dodge.Block.Debris
import Dodge.Data.World
import Dodge.DrWdWd
import Dodge.LightSource
import Dodge.Wall.Zone
import Dodge.WorldEvent.Sound
import Dodge.Material.Sound
import Dodge.Wall.Delete
import Dodge.Wall.Dust
import RandomHelp
import Dodge.Wall.Zone
import Dodge.WorldEvent.Sound
import Dodge.Zoning.Wall
import Geometry
--import Geometry.ConvexPoly
import Data.Foldable
import Data.Function
import Data.Maybe
import qualified Data.IntSet as IS
import qualified IntMapHelp as IM
import Control.Lens
import qualified Data.Graph.Inductive as FGL
import RandomHelp
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)
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 ^? cWorld . blocks . ix (_blID bl) . blWallIDs
(wlid,_) <- IS.minView wlids
(wlid, _) <- IS.minView wlids
w ^? cWorld . walls . ix wlid . wlMaterial
unshadowBlock :: Int -> World -> World
unshadowBlock wlid w = case w ^? cWorld . walls . ix wlid of
Just wl -> w
& cWorld . walls . ix wlid . wlUnshadowed .~ True
& insertWallInZones (wl & wlUnshadowed .~ True)
Just wl ->
w
& cWorld . walls . ix wlid . wlUnshadowed .~ True
& insertWallInZones (wl & wlUnshadowed .~ True)
Nothing -> w
checkBlockHP :: Block -> World -> World
@@ -45,14 +48,15 @@ checkBlockHP 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
& cWorld . blocks %~ IM.delete (_blID bl)
-- & matDesSound (_blMaterial bl) pos
& flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
destroyBlock bl w =
w
& flip (foldr 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 (foldr (wlDustAt awl)) (map (pos +.+) ps)
where
wlids = _blWallIDs bl
awl = _walls (_cWorld w) IM.! IS.findMin wlids
@@ -60,23 +64,24 @@ destroyBlock bl w = w
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 :: [(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)
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 (foldr (wlDustAt awl)) (map (pos +.+) ps)
& stopPushing (_drPushes dr)
& destroyMounts (_drMounts dr)
destroyDoor dr w =
w
& doDrWdWd (_drDeath dr) dr
& deleteWallIDs wlids
& cWorld . doors %~ IM.delete (_drID dr)
& flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
& stopPushing (_drPushes dr)
& destroyMounts (_drMounts dr)
where
wlids = _drWallIDs dr
awl = _walls (_cWorld w) IM.! IS.findMin wlids
@@ -95,5 +100,6 @@ 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)
return $
w & cWorld . doors . ix drid . drMech .~ DrWdId
& stopPushing (_drPushes dr)