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

Cleanup door mounts, noticed space leak when no debug-display paths

Browse Source
This commit is contained in:
justin
2025-10-25 22:49:37 +01:00
parent cbf0f47b9b
commit 61910785c4
16 changed files with 217550 additions and 864094 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/CWorld.hs
+3 -2
View File
@@ -10,7 +10,6 @@ module Dodge.Data.CWorld (
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
--import Data.Graph.Inductive
import Data.Tile
import Dodge.Data.Camera
import Dodge.Data.LWorld
@@ -19,13 +18,15 @@ import Geometry.ConvexPoly
import Geometry.Data
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as UV
import qualified Data.IntMap.Strict as IM
data CWorld = CWorld
{ _lWorld :: LWorld
, _cwGen :: CWGen
, _cClock :: Int
, _cwTiles :: [Tile]
, _incGraph :: V.Vector [(Int,SimpleEdge)]
-- , _incGraph :: V.Vector [(Int,SimpleEdge)]
, _incGraph :: V.Vector (IM.IntMap SimpleEdge)
, _incNode :: UV.Vector Point2
, _incEdges :: [(Int,Int)]
, _numberFloorVerxs :: Int
src/Dodge/Data/GenWorld.hs
+1 -1
View File
@@ -55,7 +55,7 @@ data PSType
| PutDoor {_putDoorDoor :: Door, _putDoorWall :: Wall}
| RandPS (State StdGen PSType)
| PutForeground ForegroundShape
| PutWorldUpdate (Int -> PlacementSpot -> GenWorld -> GenWorld)
| PutWorldUpdate (Int -> PlacementSpot -> GenWorld -> GenWorld) -- the Int is the roomid
| PutNothing
| PutID {_putID :: Int}
| PutChasm {_putChasmPoly :: [Point2]}
src/Dodge/Data/MountedObject.hs
+1 -3
View File
@@ -9,9 +9,7 @@ import Data.Aeson
import Data.Aeson.TH
data MountedObject
= MountedLS Int
| MountedProp Int
| MountedLight Point3 Float Point3
= MountedLight Point3 Float Point3
| MountedSPic SPic
deriving (Eq, Ord, Show, Read) --Generic, Flat)
src/Dodge/Debug/Picture.hs
+6 -2
View File
@@ -404,8 +404,12 @@ drawPathing :: Config -> World -> Picture
drawPathing cfig w = setLayer DebugLayer $ ifoldMap f $ w ^. cWorld . incGraph
where
inodes = w ^. cWorld . incNode
f i = foldMap (g i)
g i (j,se) = edgeToPic (screenPolygon cfig (w ^.wCam))
--f i = foldMap (g i)
--g i (j,se) = edgeToPic (screenPolygon cfig (w ^.wCam))
-- (inodes ^?! ix i) (inodes ^?! ix j) (se ^. seObstacles)
f :: Int -> IM.IntMap SimpleEdge -> Picture
f i = ifoldMap (g i)
g i j se = edgeToPic (screenPolygon cfig (w ^.wCam))
(inodes ^?! ix i) (inodes ^?! ix j) (se ^. seObstacles)
edgeToPic :: [Point2] -> Point2 -> Point2 -> S.Set EdgeObstacle -> Picture
src/Dodge/DrWdWd.hs
+3 -4
View File
@@ -9,7 +9,7 @@ import qualified Data.Set as S
import Dodge.Block.Debris
import Dodge.Data.World
import Dodge.Door.DoorLerp
import Dodge.LightSource
--import Dodge.LightSource
import Dodge.ShiftPoint
import Dodge.SoundLogic
import Dodge.Wall.Delete
@@ -42,7 +42,6 @@ doDoorMount pa w = \case
<>~ ( x & _1 . each . sfVs . each . _xy %~ shiftPointBy pa
& _2 . each . vxPos . _xy %~ shiftPointBy pa
)
_ -> w
doorLerp :: Float -> Door -> World -> (S.Set Int2, World)
doorLerp speed dr w = fromMaybe (mempty,domounts (dr ^. drLerp) w) $ do
@@ -95,8 +94,8 @@ 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
-- MountedLS lsid -> destroyLS lsid
-- MountedProp prid -> cWorld . lWorld . props . at prid .~ Nothing
MountedLight{} -> id -- should make sound + flash
MountedSPic{} -> id -- make debris?
src/Dodge/Path.hs
+24 -14
View File
@@ -55,13 +55,16 @@ getEdgesCrossing s e w = filter inedgecrosses $ nearSeg peZoneSize _incEdgeZonin
updateEdge ::
(Set.Set EdgeObstacle -> Set.Set EdgeObstacle) ->
(Int, Int) ->
V.Vector [(Int, SimpleEdge)] ->
V.Vector [(Int, SimpleEdge)]
updateEdge f (i, j) = ix i . each %~ g
where
g (k, o)
| j == k = (k, o & seObstacles %~ f)
| otherwise = (k, o)
-- V.Vector [(Int, SimpleEdge)] ->
-- V.Vector [(Int, SimpleEdge)]
V.Vector (IM.IntMap SimpleEdge) ->
V.Vector (IM.IntMap SimpleEdge)
updateEdge f (i, j) = ix i . ix j . seObstacles %~ f
--updateEdge f (i, j) = ix i . each %~ g
-- where
-- g (k, o)
-- | j == k = (k, o & seObstacles %~ f)
-- | otherwise = (k, o)
makePathUsing :: (Set.Set EdgeObstacle -> Bool) -> Point2 -> Point2 -> World -> Maybe [Int]
makePathUsing t s e w = do
@@ -70,10 +73,13 @@ makePathUsing t s e w = do
let h i = distance (getn nb) (getn i)
(na :) . snd <$> AS.aStarAssoc getes h (== nb) na
where
g (i, SimpleEdge c o)
| t o = Just (i, c)
| otherwise = Nothing
getes i = mapMaybe g $ w ^?! cWorld . incGraph . ix i
-- g (i, SimpleEdge c o)
-- | t o = Just (i, c)
-- | otherwise = Nothing
--getes i = mapMaybe g $ w ^?! cWorld . incGraph . ix i
getes i = IM.toList
. IM.map (^. seDist)
. IM.filter (^. seObstacles . to t) $ w ^?! cWorld . incGraph . ix i
getn i = w ^?! cWorld . incNode . ix i
makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
@@ -107,7 +113,8 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs b
pairsToIncGraph ::
Set.Set (Point2, Point2) ->
( UV.Vector Point2
, V.Vector [(Int, SimpleEdge)]
--, V.Vector [(Int, SimpleEdge)]
, V.Vector (IM.IntMap SimpleEdge)
, [(Int, Int)]
)
pairsToIncGraph pairs =
@@ -116,11 +123,14 @@ pairsToIncGraph pairs =
, Set.toList pairs & each . each %~ (\i -> pToNode ^?! ix i)
)
where
incgraph :: V.Vector (IM.IntMap SimpleEdge)
incgraph = V.generate (length im) (im IM.!)
im = IM.fromListWith (++) . fmap toedge $ Set.toList pairs
-- I'm not fully happy with using the monoidal instance of IntMap here
-- especially seeing as there are two levels of IntMaps.
im = IM.fromListWith (<>) . fmap toedge $ Set.toList pairs
toedge (x, y) =
( pToNode ^?! ix x
, [(pToNode ^?! ix y, SimpleEdge (distance x y) mempty)]
, IM.fromList [(pToNode ^?! ix y, SimpleEdge (distance x y) mempty)]
)
pToNode = IM.invertIntMapUnique . IM.fromDistinctAscList $ zip [0 ..] ps
inodes = UV.generate (length ps) (ps !!)
src/Dodge/Placement/Instance/LightSource.hs
+1 -2
View File
@@ -116,8 +116,7 @@ liShape wallpos (V3 x y z) =
turnpos = V2 x y +.+ n
aShape :: Point2 -> Point3 -> Shape
aShape wallpos (V3 x y z) =
girder (z + 2) 20 10 pout wallpos
aShape wallpos (V3 x y z) = girder (z + 2) 20 10 pout wallpos
where
pout = V2 x y -.- 2 *.* squashNormalizeV (V2 x y -.- wallpos)
src/Dodge/Render/ShapePicture.hs
-1
View File
@@ -26,7 +26,6 @@ worldSPic cfig u =
<> foldMap' debrisSPic (filtOn' (xyV3 . _dbPos) _debris)
<> foldup drawProjectile (filtOn (^. pjPos . _xy) _projectiles)
<> foldup drawPulseBall (filtOn _pbPos _pulseBalls)
-- <> foldup (shiftDraw _blPos _blDir (const $ drawBlock . _blDraw))
<> foldup (shiftDraw _blPos _blDir (const $ noPic . _blDraw))
(filtOn _blPos _blocks)
<> foldMap' (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _foreShapes)
src/Dodge/Room/LongDoor.hs
+39 -21
View File
@@ -2,6 +2,7 @@
-- | Rooms containing long doors, probably with a big reveal behind them.
module Dodge.Room.LongDoor where
import ShapePicture
import Linear
import Dodge.Door.PutSlideDoor
import Dodge.Default.Wall
@@ -97,7 +98,7 @@ addButtonSlowDoor x h rm = do
setOutLinksPD (f (> h + 40)) $
setInLinksPD (f (< h - 40)) $
rm
& rmPmnts .++~ [butDoor, theterminal]
& rmPmnts <>~ [butDoor, theterminal]
& rmBound .:~ openDoorBound
where
f g y = g $ y ^. _1 . _y
@@ -107,18 +108,18 @@ addButtonSlowDoor x h rm = do
(shiftByV2 (V2 0 (-10)) <&> (,S.singleton UsedPosLow))
themessage = [ "WARNING:" , "LARGE BIOMASS DETECTED" ]
openDoorBound = reverse $ rectNSWE (h + 5) (h - 5) (3 * x / 2) (- x / 2)
amountedlight dr xoff mpl = Just
. moveLSThen
(WdP2fDoorPosition (fromJust $ _plMID dr))
(V3 15 xoff 89)
(aShape (V2 15 0) (V3 15 xoff 90))
$ \plls plpr ->
Just $
ptCont (PutWorldUpdate (const $ const $ over gwWorld $ setmount dr plls plpr)) $
const mpl
setmount pldr plls plpr =
cWorld . lWorld . doors . ix (fromJust $ _plMID pldr) . drMounts
.++~ [MountedLS (fromJust $ _plMID plls), MountedProp (fromJust $ _plMID plpr)]
-- amountedlight dr xoff mpl = Just
-- . moveLSThen
-- (WdP2fDoorPosition (fromJust $ _plMID dr))
-- (V3 15 xoff 89)
-- (aShape (V2 15 0) (V3 15 xoff 90))
-- $ \plls plpr ->
-- Just $
-- ptCont (PutWorldUpdate (const $ const $ over gwWorld $ setmount dr plls plpr)) $
-- const mpl
-- setmount pldr plls plpr =
-- cWorld . lWorld . doors . ix (fromJust $ _plMID pldr) . drMounts
-- <>~ [MountedLS (fromJust $ _plMID plls), MountedProp (fromJust $ _plMID plpr)]
butDoor = putLitButOnPos
(dim $ light red)
(rprBool (isUnusedLnkType InLink))
@@ -130,14 +131,31 @@ addButtonSlowDoor x h rm = do
(V2 0 h)
(V2 x h)
0.5
$ \dr1 dr2 ->
amountedlight dr1 50 $
amountedlight dr1 (-50) $
amountedlight dr2 50 $
amountedlight
dr2
(-50)
Nothing
$ \dr1 dr2 ->
Just
$ sps0 $ PutWorldUpdate $ const $ const
$ (gwWorld . cWorld . lWorld . doors . ix (dr1 ^?! plMID . _Just)
. drMounts .~
[MountedSPic (noPic $ aShape (V2 25 0) (V3 25 50 50))
, MountedSPic (noPic $ aShape (V2 25 0) (V3 25 (-50) 50))
, MountedLight (V3 25 (-50) 50) 200 0.5
, MountedLight (V3 25 50 50) 200 0.5
])
. (gwWorld . cWorld . lWorld . doors . ix (dr2 ^?! plMID . _Just)
. drMounts .~
[MountedSPic (noPic $ aShape (V2 (-25) 0) (V3 (-25) 50 50))
, MountedSPic (noPic $ aShape (V2 (-25) 0) (V3 (-25) (-50) 50))
, MountedLight (V3 (-25) (-50) 50) 200 0.5
, MountedLight (V3 (-25) 50 50) 200 0.5
])
-- amountedlight dr1 50 $
-- amountedlight dr1 (-50) $
-- amountedlight dr2 50 $
-- amountedlight
-- dr2
-- (-50)
-- Nothing
slowDoorRoom :: RandomGen g => State g Room
slowDoorRoom = do
src/Dodge/Room/Tutorial.hs
+8 -8
View File
@@ -45,9 +45,9 @@ tutAnoTree = do
foldMTRS
[ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
, corDoor
, return $ tToBTree "cor" $ return $ cleatOnward $ corridor & rmPmnts .~ mempty
, return $ tToBTree "cor" $ return $ cleatOnward airlock90
, corDoor
-- , return $ tToBTree "cor" $ return $ cleatOnward $ corridor & rmPmnts .~ mempty
-- , return $ tToBTree "cor" $ return $ cleatOnward airlock90
-- , corDoor
-- , return $ tToBTree "cor" $ return $ cleatOnward (twinSlowDoorRoom 80 200 40)
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward airlock0
@@ -61,16 +61,16 @@ tutAnoTree = do
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward airlockSimple
, 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
, tToBTree "asdf" . return . cleatOnward <$> airlockZ
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , tToBTree "asdf" . return . cleatOnward <$> airlockZ
--, return . tToBTree "asdf" . return . cleatOnward $ airlockCrystal
, 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 "t" . return . cleatOnward <$> slowDoorRoom
, return $ tToBTree "cor" $ return $ cleatOnward corridor
, return $ tToBTree "cor" $ return $ cleatOnward corridor
src/Dodge/Update/WallDamage.hs
+4
View File
@@ -32,6 +32,9 @@ updateEdgesWall is w = updateEdgesWall'
updateEdgesWall' :: S.Set (Int, Int) -> World -> World
updateEdgesWall' = flip $ foldl' updateEdgeWallObs
--updateEdgeWallObs :: World -> (Int, Int) -> World
--updateEdgeWallObs w (i, j) = w
updateEdgeWallObs :: World -> (Int, Int) -> World
updateEdgeWallObs w (i, j) = fromMaybe w $ do
s <- getNodePos i w
@@ -39,5 +42,6 @@ updateEdgeWallObs w (i, j) = fromMaybe w $ do
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]))