From ccb809a090f60c74004ff603166a344ae6622661 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 24 Oct 2025 18:50:09 +0100 Subject: [PATCH] Cleanup --- src/Dodge/Data/Wall.hs | 2 -- src/Dodge/Default/Wall.hs | 37 ++++------------------------ src/Dodge/Path.hs | 13 +--------- src/Dodge/Placement/Instance/Wall.hs | 27 +++++++++++--------- src/Dodge/Placement/PlaceSpot.hs | 11 +++------ src/Dodge/Room/Airlock.hs | 3 +-- src/Dodge/Room/Tutorial.hs | 13 +++++----- src/Dodge/Update/WallDamage.hs | 6 ++--- src/Dodge/WorldEvent/ThingsHit.hs | 2 +- 9 files changed, 36 insertions(+), 78 deletions(-) diff --git a/src/Dodge/Data/Wall.hs b/src/Dodge/Data/Wall.hs index 05a7db92e..a462df717 100644 --- a/src/Dodge/Data/Wall.hs +++ b/src/Dodge/Data/Wall.hs @@ -13,13 +13,11 @@ import Data.Aeson.TH import Dodge.Data.Material import Dodge.Data.Wall.Structure import Geometry -import qualified Data.Set as S data Wall = Wall { _wlLine :: (Point2, Point2) , _wlID :: Int , _wlOpacity :: Opacity --- , _wlPathFlag :: S.Set WallFlag , _wlTouchThrough :: Bool , _wlUnshadowed :: Bool , _wlRotateTo :: Bool diff --git a/src/Dodge/Default/Wall.hs b/src/Dodge/Default/Wall.hs index a6bea5c82..852d03302 100644 --- a/src/Dodge/Default/Wall.hs +++ b/src/Dodge/Default/Wall.hs @@ -9,18 +9,14 @@ module Dodge.Default.Wall ( ) where import Control.Lens -import qualified Data.Set as S import Dodge.Data.Wall import Geometry.Data -{- Indestructible wall. -} defaultWall :: Wall defaultWall = Wall { _wlLine = (V2 0 0, V2 50 0) , _wlID = 0 --- , _wlPathFlag = --- S.fromList [minBound .. maxBound] , _wlOpacity = Opaque 11 , _wlUnshadowed = True , _wlRotateTo = True @@ -31,23 +27,13 @@ defaultWall = } defaultDoorWall :: Wall -defaultDoorWall = - defaultWall --- & wlPathFlag . at WallNotDestrucable .~ Nothing - & wlMaterial .~ Metal - & wlOpacity .~ Opaque 0 +defaultDoorWall = defaultWall & wlMaterial .~ Metal & wlOpacity .~ Opaque 0 defaultAutoWall :: Wall -defaultAutoWall = - defaultDoorWall - & wlOpacity .~ Opaque 9 --- & wlPathFlag . at WallNotAutoOpen .~ Nothing +defaultAutoWall = defaultDoorWall & wlOpacity .~ Opaque 9 -{- Indestructible see-through wall. -} defaultCrystalWall :: Wall -defaultCrystalWall = - defaultWall & wlOpacity .~ SeeThrough & wlMaterial .~ Crystal --- & wlPathFlag . at WallBlockVisibility .~ Nothing +defaultCrystalWall = defaultWall & wlOpacity .~ SeeThrough & wlMaterial .~ Crystal defaultMachineWall :: Wall defaultMachineWall = @@ -58,27 +44,14 @@ defaultMachineWall = , _wlMaterial = Metal , _wlTouchThrough = True } --- & wlPathFlag . at WallBlockVisibility .~ Nothing --- & wlPathFlag . at WallNotDestrucable .~ Nothing defaultDirtWall :: Wall defaultDirtWall = defaultWall - { _wlLine = (V2 0 0, V2 50 0) - , _wlID = 0 - , _wlOpacity = Opaque 6 + { _wlOpacity = Opaque 6 , _wlRotateTo = False , _wlMaterial = Dirt } --- & wlPathFlag . at WallNotDestrucable .~ Nothing defaultWindow :: Wall -defaultWindow = - defaultWall - { _wlLine = (V2 0 0, V2 50 0) - , _wlID = 0 - , _wlOpacity = SeeThrough - , _wlMaterial = Glass - } --- & wlPathFlag . at WallNotDestrucable .~ Nothing --- & wlPathFlag . at WallBlockVisibility .~ Nothing +defaultWindow = defaultWall & wlOpacity .~ SeeThrough & wlMaterial .~ Glass diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index e2b32e26d..a065d75ea 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -126,12 +126,7 @@ pairsToIncGraph pairs = inodes = UV.generate (length ps) (ps !!) ps = Set.toList $ Set.map fst pairs <> Set.map snd pairs -obstructPathsCrossing :: - S.Set EdgeObstacle -> - Point2 -> - Point2 -> - World -> - World +obstructPathsCrossing :: S.Set EdgeObstacle -> Point2 -> Point2 -> World -> World obstructPathsCrossing obs s e w = w & cWorld . incGraph %~ updateincedges where updateincedge = flip $ updateEdge (S.union obs) @@ -139,12 +134,6 @@ obstructPathsCrossing obs s e w = w & cWorld . incGraph %~ updateincedges inces = filter inedgecrosses $ nearSeg peZoneSize _incEdgeZoning s e w inedgecrosses (i, j) = isJust $ intersectSegSeg s e (f i) (f j) f i = w ^?! cWorld . incNode . ix i - --es = Set.filter edgecrosses $ pesNearSeg sp ep w --- edgecrosses (PathEdgeNodes _ _ pe) = --- isJust $ intersectSegSeg s e (_peStart pe) (_peEnd pe) --- updateedges gr = foldl' updateedge gr es --- updateedge gr (PathEdgeNodes x y pe) = --- insEdge (x, y, pe & peObstacles . at obstacletype ?~ ()) $ delEdge (x, y) gr snapToGrid :: Set (Point2, Point2) -> Set (Point2, Point2) snapToGrid = Set.map (over each (fmap (fromIntegral . f))) diff --git a/src/Dodge/Placement/Instance/Wall.hs b/src/Dodge/Placement/Instance/Wall.hs index 0c7ddc3fc..e6e8a2107 100644 --- a/src/Dodge/Placement/Instance/Wall.hs +++ b/src/Dodge/Placement/Instance/Wall.hs @@ -1,21 +1,23 @@ -module Dodge.Placement.Instance.Wall - (invisibleWall, crystalLine, blockLine, putBlockRect - ,baseBlockPane - ,midWall - ,windowLine - ,putBlockN - ,putBlockV - ,heightWallPS - ,replacePutID - ) where +module Dodge.Placement.Instance.Wall ( + invisibleWall, + crystalLine, + blockLine, + putBlockRect, + baseBlockPane, + midWall, + windowLine, + putBlockN, + putBlockV, + heightWallPS, + replacePutID, +) where -import qualified Data.Set as S -import Dodge.Material.Color import Control.Lens import Data.List import Dodge.Data.GenWorld import Dodge.Default.Wall import Dodge.LevelGen.PlacementHelper +import Dodge.Material.Color import Dodge.Placement.Instance.Block import Geometry @@ -95,6 +97,7 @@ crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall 7 a b baseBlockPane :: Wall baseBlockPane = defaultWall & wlOpacity .~ Opaque 17 + -- & wlPathFlag .~ S.fromList [WallBlockVisibility, WallNotAutoOpen] -- TODO find home for this diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 85d904979..3f1e32a3c 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -1,5 +1,5 @@ --{-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- | deals with placement of objects within the world after they have had their coordinates set by the layout @@ -174,13 +174,10 @@ placeChasm gw rid ps shiftps = -- where -- (evaluatedType, g) = runState rgen (_randGen $ _gwWorld w) --- this function is the reason for the warning suppression --- remove the warning suppression if it changes placeWallPoly :: [Point2] -> Wall -> World -> World -placeWallPoly qs wl w = foldl' (addPane wl) w pairs - where - (p : ps) = orderPolygon qs - pairs = zip (ps ++ [p]) (p : ps) +placeWallPoly qs wl w + | (p : ps) <- orderPolygon qs = foldl' (addPane wl) w $ zip (ps ++ [p]) (p : ps) + | otherwise = error "tried to place wall poly with too few points" addPane :: Wall -> World -> (Point2, Point2) -> World addPane wl w l = diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index af271dc63..cdb60fcfd 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -179,8 +179,7 @@ airlockZ = do l2 x2 y2 - , -- outDoorps inDoorps - sps0 $ PutWall (reverse $ rectNSWE 70 50 60 120) defaultWall + , sps0 $ PutWall (reverse $ rectNSWE 70 50 60 120) defaultWall , lighting ] , _rmBound = diff --git a/src/Dodge/Room/Tutorial.hs b/src/Dodge/Room/Tutorial.hs index 4b95be74f..575f88240 100644 --- a/src/Dodge/Room/Tutorial.hs +++ b/src/Dodge/Room/Tutorial.hs @@ -43,13 +43,12 @@ tutAnoTree = do foldMTRS [ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox , corDoor - , return $ tToBTree "cor" $ return $ cleatOnward corridor - , return $ tToBTree "cor" $ return $ cleatOnward corridor - , tToBTree "lastun" . return . cleatOnward <$> cenLasTur - , return $ tToBTree "cor" $ return $ cleatOnward corridor - , return $ tToBTree "cor" $ return $ cleatOnward corridor - , return $ tToBTree "cor" $ return $ cleatOnward corridor - +-- , return $ tToBTree "cor" $ return $ cleatOnward corridor +-- , return $ tToBTree "cor" $ return $ cleatOnward corridor +-- , tToBTree "lastun" . return . cleatOnward <$> cenLasTur +-- , return $ tToBTree "cor" $ return $ cleatOnward corridor +-- , return $ tToBTree "cor" $ return $ cleatOnward corridor +-- , return $ tToBTree "cor" $ return $ cleatOnward corridor , return $ tToBTree "cor" $ return $ cleatOnward corridor -- , return $ tToBTree "cor" $ return $ cleatOnward corridor -- , return $ tToBTree "cor" $ return $ cleatOnward corridor diff --git a/src/Dodge/Update/WallDamage.hs b/src/Dodge/Update/WallDamage.hs index f8cbe0406..f0d3f36ba 100644 --- a/src/Dodge/Update/WallDamage.hs +++ b/src/Dodge/Update/WallDamage.hs @@ -36,8 +36,8 @@ updateEdgeWallObs :: World -> (Int, Int) -> World updateEdgeWallObs w (i, j) = fromMaybe w $ do s <- getNodePos i w e <- getNodePos j w - --let wlflags = foldMap (^. _2 . wlPathFlag) $ wlsHitUnsorted s e w - let wlflags = foldMap (getWallPathing . (^. _2)) $ wlsHitUnsorted s e w + let wlflags = foldMap (^. _2 . to getWallPathing) $ wlsHitUnsorted s e w return $ w & cWorld . incGraph %~ updateEdge (f wlflags) (i, j) where - f x _ = S.map WallObstacle x + f x y = (S.map WallObstacle x) `S.union` + (y S.\\ (S.fromList $ map WallObstacle [minBound..maxBound])) diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index f3a7909f9..0de749217 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -164,7 +164,7 @@ isFlyable :: Point2 -> Point2 -> World -> Bool {-# INLINE isFlyable #-} isFlyable p1 p2 = not . (WallNotAutoOpen `S.member`) - . foldMap (getWallPathing . (^. _2)) + . foldMap (^. _2 . to getWallPathing) . wlsHitUnsorted p1 p2 isWalkable :: Point2 -> Point2 -> World -> Bool