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

Cleanup

Browse Source
This commit is contained in:
justin
2025-10-24 18:50:09 +01:00
parent 488428b1ef
commit ccb809a090
9 changed files with 36 additions and 78 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Wall.hs
-2
View File
@@ -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
src/Dodge/Default/Wall.hs
+5 -32
View File
@@ -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
src/Dodge/Path.hs
+1 -12
View File
@@ -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)))
src/Dodge/Placement/Instance/Wall.hs
+15 -12
View File
@@ -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
src/Dodge/Placement/PlaceSpot.hs
+4 -7
View File
@@ -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 =
src/Dodge/Room/Airlock.hs
+1 -2
View File
@@ -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 =
src/Dodge/Room/Tutorial.hs
+6 -7
View File
@@ -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
src/Dodge/Update/WallDamage.hs
+3 -3
View File
@@ -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]))
src/Dodge/WorldEvent/ThingsHit.hs
+1 -1
View File
@@ -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