Continue to work on pathfinding

This commit is contained in:
2025-10-21 15:35:37 +01:00
parent 0b997579ad
commit 6742241e5d
22 changed files with 296 additions and 298 deletions
+18 -12
View File
@@ -4,13 +4,14 @@ module Dodge.Block (
destroyDoor,
) where
import Dodge.Zoning.Wall
import Dodge.Base.Collide
import Control.Monad
import Dodge.Path
import Control.Lens
import Data.Foldable
import qualified Data.Graph.Inductive as FGL
import qualified Data.IntSet as IS
import Data.Maybe
import Data.Set (Set)
import Dodge.Base.Collide
import Dodge.Block.Debris
import Dodge.Data.MountedObject
import Dodge.Data.World
@@ -20,7 +21,6 @@ import Dodge.Material.Sound
import Dodge.Wall.Delete
import Dodge.Wall.Zone
import Dodge.WorldEvent.Sound
import Dodge.Zoning.Wall
import qualified IntMapHelp as IM
splinterBlock :: Block -> World -> World
@@ -66,16 +66,22 @@ destroyBlock bl w =
-- ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
-- this does not handle eg doors blocking the path as well
maybeClearPaths :: Set PathEdgeNodes -> World -> World
maybeClearPaths :: [(Int,Int)] -> World -> World
maybeClearPaths ps w = foldl' maybeClearPath w ps
maybeClearPath :: World -> PathEdgeNodes -> World
maybeClearPath w (PathEdgeNodes 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) -> World
maybeClearPath w (i,j) = fromMaybe w $ do
x <- getNodePos i w
y <- getNodePos j w
guard $ null $ overlapSegWalls x y $ wlsNearSeg x y w
return $ w & cWorld . incGraph %~ updateEdge f (i,j)
where
f = at BlockObstacle .~ Nothing
---- | 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 =
+1 -3
View File
@@ -1,8 +1,6 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Combine.Graph
( combinationsDotGraph
) where
module Dodge.Combine.Graph ( combinationsDotGraph) where
import Dodge.Data.CombAmount
import Data.Bifunctor
+2 -1
View File
@@ -48,7 +48,8 @@ doCrWdAc :: CrWdAc -> Creature -> World -> Action
doCrWdAc cw = case cw of
CrWdBFSThenReturn t -> \cr w -> fromMaybe NoAction $ do
n <- walkableNodeNear w (cr ^. crPos . _xy)
let as = take 20 $ map PathTo $ bfsNodePoints n w
-- let as = take 20 $ map PathTo $ bfsNodePoints n w
let as = []
return $ DoActionThen (DoImpulses [ChangeStrategy Search])
$
DoReplicate t $
+2 -2
View File
@@ -7,7 +7,6 @@ module Dodge.Data.Block (
module Dodge.Data.PathGraph,
) where
import Data.Set (Set)
import Color
import Control.Lens
import Data.Aeson
@@ -29,7 +28,8 @@ data Block = Block
, _blHeight :: Float
, _blMaterial :: Material
, _blDraw :: BlockDraw --Block -> SPic
, _blObstructs :: Set PathEdgeNodes
-- , _blObstructs :: Set PathEdgeNodes
, _blObstructs :: [(Int,Int)]
}
deriving (Eq, Ord, Show, Read) --Generic, Flat)
+1 -1
View File
@@ -25,7 +25,7 @@ data CWorld = CWorld
, _cwGen :: CWGen
, _cClock :: Int
, _cwTiles :: [Tile]
, _pathGraph :: Gr Point2 PathEdge
-- , _pathGraph :: Gr Point2 PathEdge
, _incGraph :: V.Vector [(Int,SimpleEdge)]
, _incNode :: UV.Vector Point2
, _numberFloorVerxs :: Int
+1 -2
View File
@@ -8,7 +8,6 @@ module Dodge.Data.Door (
module Dodge.Data.WorldEffect,
) where
import Data.Set (Set)
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
@@ -42,7 +41,7 @@ data Door = Door
, _drPushedBy :: PushSource
, _drPushes :: Maybe Int
, _drMounts :: [MountedObject]
, _drObstructs :: Set PathEdgeNodes
-- , _drObstructs :: [(Int,Int)]
, _drObstacleType :: EdgeObstacle
}
+18 -18
View File
@@ -24,20 +24,20 @@ import Geometry.Data
-- }
-- deriving (Eq, Show, Read) --, Generic)
data PathEdgeNodes = PathEdgeNodes
{ _penStart :: Int
, _penEnd :: Int
, _penPathEdge :: PathEdge
}
deriving (Eq, Ord, Show, Read) --Generic, Flat)
data PathEdge = PathEdge
{ _peStart :: Point2
, _peEnd :: Point2
, _peDist :: Float
, _peObstacles :: Set.Set EdgeObstacle
}
deriving (Eq, Ord, Show, Read) --Generic, Flat)
--data PathEdgeNodes = PathEdgeNodes
-- { _penStart :: Int
-- , _penEnd :: Int
-- , _penPathEdge :: PathEdge
-- }
-- deriving (Eq, Ord, Show, Read) --Generic, Flat)
--
--data PathEdge = PathEdge
-- { _peStart :: Point2
-- , _peEnd :: Point2
-- , _peDist :: Float
-- , _peObstacles :: Set.Set EdgeObstacle
-- }
-- deriving (Eq, Ord, Show, Read) --Generic, Flat)
data SimpleEdge = SimpleEdge
{ _seDist :: Float
@@ -61,12 +61,12 @@ data EdgeObstacle
--deriving instance (Flat (Gr Point2 PathEdge))
--makeLenses ''PathGraph
makeLenses ''PathEdge
makeLenses ''PathEdgeNodes
--makeLenses ''PathEdge
--makeLenses ''PathEdgeNodes
makeLenses ''SimpleEdge
deriveJSON defaultOptions ''EdgeObstacle
deriveJSON defaultOptions ''PathEdge
deriveJSON defaultOptions ''PathEdgeNodes
--deriveJSON defaultOptions ''PathEdge
--deriveJSON defaultOptions ''PathEdgeNodes
deriveJSON defaultOptions ''Gr
deriveJSON defaultOptions ''SimpleEdge
--deriveJSON defaultOptions ''PathGraph
+2 -2
View File
@@ -47,8 +47,8 @@ data World = World
, _clZoning :: IntMap (IntMap [Cloud])
, _dsZoning :: IntMap (IntMap [Dust])
, _wlZoning :: IntMap (IntMap IntSet) -- Zoning IM.IntMap Wall
, _pnZoning :: IntMap (IntMap [(Int, Point2)]) --Zoning IM.IntMap Creature
, _peZoning :: IntMap (IntMap (Set PathEdgeNodes))
-- , _pnZoning :: IntMap (IntMap [(Int, Point2)]) --Zoning IM.IntMap Creature
-- , _peZoning :: IntMap (IntMap (Set PathEdgeNodes))
, _incNodeZoning :: IntMap (IntMap [(Int, Point2)]) --Zoning IM.IntMap Creature
, _incEdgeZoning :: IntMap (IntMap [(Int,Int)]) --Zoning IM.IntMap Creature
, _gsZoning :: IntMap (IntMap IntSet)
+12 -27
View File
@@ -251,22 +251,20 @@ drawInspectWalls w = concat $ do
)
drawInspectWall :: World -> Wall -> Picture
drawInspectWall w wl =
drawInspectWall _ wl =
setLayer DebugLayer $
color rose (thickLine 3 [a, b])
<> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor)
-- <> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor)
where
(a, b) = _wlLine wl
drawDoorPaths :: World -> Int -> Picture
drawDoorPaths w drid = concat $ do
paths <- w ^? cWorld . lWorld . doors . ix drid . drObstructs
return $ foldMap' (drawPathEdge . (^. penPathEdge)) paths
--drawDoorPaths :: World -> Int -> Picture
--drawDoorPaths w drid = concat $ do
-- paths <- w ^? cWorld . lWorld . doors . ix drid . drObstructs
-- return $ foldMap' (drawPathEdge . (^. penPathEdge)) paths
drawPathEdge :: PathEdge -> Picture
drawPathEdge pe =
setLayer DebugLayer $
multiArrow (_peStart pe) (_peEnd pe) green (S.map obstacleColor (_peObstacles pe))
drawPathEdge :: Point2 -> Point2 -> S.Set EdgeObstacle -> Picture
drawPathEdge x y pe = setLayer DebugLayer $ multiArrow x y green (S.map obstacleColor pe)
obstacleColor :: EdgeObstacle -> Color
obstacleColor eo = case eo of
@@ -403,16 +401,6 @@ drawWlIDs w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls
where
p = worldPosToScreen (w ^. wCam) $ 0.5 *.* uncurry (+.+) (_wlLine wl)
drawPathing' :: Config -> World -> Picture
drawPathing' cfig w =
setLayer DebugLayer $
foldMap (edgeToPic (screenPolygon cfig (w ^. wCam)) . (^?! _3)) (FGL.labEdges gr)
<> foldMap dispInc (graphToIncidence gr)
where
dispInc (p, n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
gr = w ^. cWorld . pathGraph
drawPathing :: Config -> World -> Picture
drawPathing cfig w =
setLayer DebugLayer $ ifoldMap f $ w ^. cWorld . incGraph
@@ -420,12 +408,9 @@ drawPathing cfig w =
inodes = w ^. cWorld . incNode
f i = foldMap (g i)
g i (j,se) = edgeToPic (screenPolygon cfig (w ^.wCam))
(PathEdge (inodes ^?! ix i) (inodes ^?! ix j) 0 (se ^. seObstacles))
(inodes ^?! ix i) (inodes ^?! ix j) (se ^. seObstacles)
edgeToPic :: [Point2] -> PathEdge -> Picture
edgeToPic poly pe
edgeToPic :: [Point2] -> Point2 -> Point2 -> S.Set EdgeObstacle -> Picture
edgeToPic poly sp ep pe
| not (pointInPoly sp poly) && not (pointInPoly ep poly) = mempty
| otherwise = drawPathEdge pe
where
sp = _peStart pe
ep = _peEnd pe
| otherwise = drawPathEdge sp ep pe
+1 -1
View File
@@ -43,6 +43,6 @@ defaultDoor =
, _drPushedBy = PushesItself
, _drPushes = Nothing
, _drMounts = mempty
, _drObstructs = mempty
-- , _drObstructs = mempty
, _drObstacleType = DoorObstacle
}
+3 -3
View File
@@ -47,8 +47,8 @@ defaultWorld =
, _clZoning = mempty
, _dsZoning = mempty
, _wlZoning = mempty
, _pnZoning = mempty
, _peZoning = mempty
-- , _pnZoning = mempty
-- , _peZoning = mempty
, _incNodeZoning = mempty
, _incEdgeZoning = mempty
, _gsZoning = mempty --Zoning IM.empty clZoneSize (zonePos _guPos)
@@ -87,7 +87,7 @@ defaultCWorld =
{ _lWorld = defaultLWorld
, _cwGen = defaultCWGen
, _cClock = 0
, _pathGraph = Data.Graph.Inductive.Graph.empty
-- , _pathGraph = Data.Graph.Inductive.Graph.empty
, _cwTiles = mempty
, _numberFloorVerxs = 0
, _chasms = mempty
+2 -2
View File
@@ -7,7 +7,7 @@ import Dodge.Base
import Dodge.Block.Debris
import Dodge.Data.World
import Dodge.LevelGen.DoorPane
import Dodge.Placement.PlaceSpot.TriggerDoor
--import Dodge.Placement.PlaceSpot.TriggerDoor
import Dodge.SoundLogic
import Dodge.Wall.Move
import Dodge.WorldBool
@@ -28,7 +28,7 @@ doorMechanism dr w = case mvDir of
& flip (IS.foldl' (flip (`translateWallID` d))) (_drWallIDs dr)
& moveUpdate
& cWorld . lWorld . doors . ix drid . drPos . each %~ (+.+ d)
& maybeClearDoorPaths (_drObstacleType dr) (_drObstructs dr)
-- & updateDoorEdges (_drObstacleType dr) (_drObstructs dr)
Nothing -> w
where
toOpen = doWdBl (_drTrigger dr) w
+6 -6
View File
@@ -6,12 +6,12 @@ module Dodge.Layout (
) where
import qualified Data.Vector.Unboxed as UV
import Dodge.Path.Translate
--import Dodge.Path.Translate
import qualified Control.Foldl as L
import Control.Lens
import Data.Foldable
import Data.Function
import Data.Graph.Inductive (labEdges, labNodes)
--import Data.Graph.Inductive (labEdges, labNodes)
import Data.List (nubBy,sortOn)
import Data.Maybe
import Data.Tile
@@ -45,16 +45,16 @@ generateLevelFromRoomList gr' w =
. worldToGenWorld rs'
$ w & cWorld . lWorld . walls .~ wallsFromRooms rs
& cWorld . cwGen . cwgGameRooms .~ gameRoomsFromRooms (IM.elems rs')
& cWorld . pathGraph .~ path
-- & cWorld . pathGraph .~ path
& cWorld . incNode .~ inodes
& cWorld . incGraph .~ igraph
& pnZoning .~ foldl' (flip zonePn) mempty (labNodes path)
& peZoning .~ foldl' (flip zonePe) mempty (map fromEdgeTuple $ labEdges path)
-- & pnZoning .~ foldl' (flip zonePn) mempty (labNodes path)
-- & peZoning .~ foldl' (flip zonePe) mempty (map fromEdgeTuple $ labEdges path)
& incNodeZoning .~ UV.ifoldl' (\m i p -> zonePn (i,p) m) mempty inodes
& incEdgeZoning .~ foldl' (flip (zoneIncPe inodes)) mempty ipairs
where
pairs = snapToGrid $ foldMap _rmPath rs
(_, path) = pairsToGraph pairs
-- (_, path) = pairsToGraph pairs
(inodes,igraph,ipairs) = pairsToIncGraph pairs
rs = map doRoomShift $ IM.elems rs'
rs' = mapM shuffleRoomPos gr' & evalState $ _randGen w
+103 -87
View File
@@ -5,19 +5,18 @@ module Dodge.Path (
makePathBetweenPs,
-- , removePathsCrossing
obstructPathsCrossing,
pairsToGraph,
-- pairsToGraph,
getNodePos,
walkableNodeNear,
bfsNodePoints,
-- bfsNodePoints,
snapToGrid,
pairsToIncGraph,
updateEdge,
getEdgesCrossing,
) where
import Control.Lens
import qualified Algorithm.Search as AS
import Dodge.Zoning.Common
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as UV
import Control.Lens
--import Data.Bifunctor
import Data.Foldable
import Data.Graph.Inductive hiding ((&))
@@ -27,22 +26,36 @@ import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as UV
import Dodge.Base.Collide
import Dodge.Data.World
import Dodge.Zoning.Base
import Dodge.Zoning.Common
import Dodge.Zoning.Pathing
import Geometry
import Linear
import qualified IntMapHelp as IM
import Linear
getNodePos :: Int -> World -> Maybe Point2
getNodePos i w = (w ^. cWorld . pathGraph) `lab` i
getNodePos i w = w ^? cWorld . incNode . ix i
--makePathUsing' :: (PathEdge -> Bool) -> Point2 -> Point2 -> World -> Maybe [Int]
--makePathUsing' t s e w = do
-- na <- walkableNodeNear w s
-- nb <- walkableNodeNear w e
-- sp na nb . second _peDist . efilter (^. _3 . to t) $ w ^. cWorld . pathGraph
getEdgesCrossing :: Point2 -> Point2 -> World -> [(Int,Int)]
getEdgesCrossing s e w = filter inedgecrosses $ nearSeg peZoneSize _incEdgeZoning s e w
where
inedgecrosses (i, j) = isJust $ intersectSegSeg s e (f i) (f j)
f i = w ^?! cWorld . incNode . ix i
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)
makePathUsing :: (Set.Set EdgeObstacle -> Bool) -> Point2 -> Point2 -> World -> Maybe [Int]
makePathUsing t s e w = do
@@ -50,24 +63,24 @@ makePathUsing t s e w = do
nb <- walkableNodeNear w e
let f i = getes i
h i = distance (getn nb) (getn i)
(na :) . snd <$> AS.aStarAssoc f h (==nb) na
(na :) . snd <$> AS.aStarAssoc f h (== nb) na
where
g (i,SimpleEdge c o)
| t o = Just (i,c)
g (i, SimpleEdge c o)
| t o = Just (i, c)
| otherwise = Nothing
getes i = mapMaybe g $ w ^?! cWorld . incGraph . ix i
getn i = w ^?! cWorld . incNode . ix i
-- sp na nb . second _peDist . efilter (^. _3 . to t) $ w ^. cWorld . pathGraph
makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
makePathBetween = makePathUsing $ not . pathEdgeObstructed
pathEdgeObstructed' :: PathEdge -> Bool
pathEdgeObstructed' pe =
any
(`Set.member` _peObstacles pe)
[DoorObstacle, BlockObstacle, ChasmObstacle]
--pathEdgeObstructed' :: PathEdge -> Bool
--pathEdgeObstructed' pe =
-- any
-- (`Set.member` _peObstacles pe)
-- [DoorObstacle, BlockObstacle, ChasmObstacle]
pathEdgeObstructed :: Set.Set EdgeObstacle -> Bool
pathEdgeObstructed pe =
@@ -81,11 +94,11 @@ walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
where
nodesNear = zonesExtract (w ^. incNodeZoning) . snailAround $ zoneOfPoint pnZoneSize p
walkableNodeNear' :: World -> Point2 -> Maybe Int
{-# INLINE walkableNodeNear' #-}
walkableNodeNear' w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
where
nodesNear = zonesExtract (w ^. pnZoning) . snailAround $ zoneOfPoint pnZoneSize p
--walkableNodeNear' :: World -> Point2 -> Maybe Int
--{-# INLINE walkableNodeNear' #-}
--walkableNodeNear' w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
-- where
-- nodesNear = zonesExtract (w ^. pnZoning) . snailAround $ zoneOfPoint pnZoneSize p
snailAround :: Int2 -> [Int2]
snailAround x = (x +) <$> smallSnailInt2
@@ -97,17 +110,18 @@ smallSnailInt2 =
[V2 x y | x <- [-2 .. 2], y <- [-2 .. 2]]
makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
makePathBetweenPs a b w = mapMaybe (lab $ w ^. cWorld . pathGraph) <$> makePathBetween a b w
--makePathBetweenPs a b w = mapMaybe (lab $ w ^. cWorld . pathGraph) <$> makePathBetween a b w
makePathBetweenPs a b w = mapMaybe (flip getNodePos w) <$> makePathBetween a b w
bfsNodePoints :: Int -> World -> [Point2]
bfsNodePoints n w = mapMaybe (lab g) $ bfs n g
where
g = w ^. cWorld . pathGraph
--bfsNodePoints :: Int -> World -> [Point2]
--bfsNodePoints n w = mapMaybe (lab g) $ bfs n g
-- where
-- g = w ^. cWorld . pathGraph
pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2
pointTowardsImpulse a b w =
-- (find (flip (isWalkable a) w) . reverse)
-- =<< (makePathBetweenPs a b w <&> (<> [b]))
-- (find (flip (isWalkable a) w) . reverse)
-- =<< (makePathBetweenPs a b w <&> (<> [b]))
(find (flip (isWalkable a) w) . reverse)
=<< makePathBetweenPs a b w -- <&> (<> [b]))
@@ -155,78 +169,80 @@ pointTowardsImpulse a b w =
-- _ -> return $ Just $ ns !! i
--
pairsToIncGraph :: Set.Set (Point2,Point2)
-> (UV.Vector Point2
, V.Vector [(Int,SimpleEdge)]
, [(Int,Int)]
pairsToIncGraph ::
Set.Set (Point2, Point2) ->
( UV.Vector Point2
, V.Vector [(Int, SimpleEdge)]
, [(Int, Int)]
)
pairsToIncGraph pairs =
( inodes
, incgraph
, Set.toList pairs & each . each %~ (\i -> pstons ^?! ix i . _head)
)
pairsToIncGraph pairs = (inodes,incgraph
,Set.toList pairs & each . each %~ (\i -> pstons ^?! ix i . _head))
where
incgraph = V.generate (length im) (\i -> im ^?! ix i)
im = IM.fromListWith (<>) . fmap toedge $ Set.toList pairs
toedge (x,y) = (pstons ^?! ix x . _head
, [(pstons ^?! ix y . _head, SimpleEdge (distance x y) mempty)])
pstons = IM.invertIntMap . IM.fromList $ zip [0..] ps
toedge (x, y) =
( pstons ^?! ix x . _head
, [(pstons ^?! ix y . _head, SimpleEdge (distance x y) mempty)]
)
pstons = IM.invertIntMap . IM.fromList $ zip [0 ..] ps
inodes = UV.generate (length ps) (ps !!)
ps = Set.toList $ Set.map fst pairs <> Set.map snd pairs
pairsToGraph ::
Set.Set (Point2, Point2) ->
(Map (V2 Point2) PathEdgeNodes, Gr Point2 PathEdge)
pairsToGraph pairs = addEdges nodemap gr pairs
where
(nodemap, _, gr) = addNodes $ Set.toList $ Set.map fst pairs <> Set.map snd pairs
--pairsToGraph ::
-- Set.Set (Point2, Point2) ->
-- (Map (V2 Point2) PathEdgeNodes, Gr Point2 PathEdge)
--pairsToGraph pairs = addEdges nodemap gr pairs
-- where
-- (nodemap, _, gr) = addNodes $ Set.toList $ Set.map fst pairs <> Set.map snd pairs
addNodes :: [Point2] -> (Map Point2 Int, Int, Gr Point2 PathEdge)
addNodes = foldl' f (mempty, 0, Data.Graph.Inductive.empty)
where
f (nodemap, i, gr) p = case nodemap M.!? p of
Just _ -> (nodemap, i, gr)
Nothing -> (nodemap & at p ?~ i, i + 1, insNode (i, p) gr)
--addNodes :: [Point2] -> (Map Point2 Int, Int, Gr Point2 PathEdge)
--addNodes = foldl' f (mempty, 0, Data.Graph.Inductive.empty)
-- where
-- f (nodemap, i, gr) p = case nodemap M.!? p of
-- Just _ -> (nodemap, i, gr)
-- Nothing -> (nodemap & at p ?~ i, i + 1, insNode (i, p) gr)
addEdges ::
Map Point2 Int ->
Gr Point2 PathEdge ->
Set.Set (Point2, Point2) ->
(Map (V2 Point2) PathEdgeNodes, Gr Point2 PathEdge)
addEdges nodemap gr = foldl' f (mempty, gr)
where
f (edgemap, gr') (a, b) =
( M.insert (V2 a b) theedgedata edgemap
, insEdge theedgetup gr'
)
where
theedgetup = (g a, g b, PathEdge a b (dist a b) mempty)
theedgedata = PathEdgeNodes (g a) (g b) (PathEdge a b (dist a b) mempty)
g a = nodemap M.! a
--addEdges ::
-- Map Point2 Int ->
-- Gr Point2 PathEdge ->
-- Set.Set (Point2, Point2) ->
-- (Map (V2 Point2) PathEdgeNodes, Gr Point2 PathEdge)
--addEdges nodemap gr = foldl' f (mempty, gr)
-- where
-- f (edgemap, gr') (a, b) =
-- ( M.insert (V2 a b) theedgedata edgemap
-- , insEdge theedgetup gr'
-- )
-- where
-- theedgetup = (g a, g b, PathEdge a b (dist a b) mempty)
-- theedgedata = PathEdgeNodes (g a) (g b) (PathEdge a b (dist a b) mempty)
-- g a = nodemap M.! a
obstructPathsCrossing ::
EdgeObstacle ->
Point2 ->
Point2 ->
World ->
(World, Set PathEdgeNodes)
obstructPathsCrossing obstacletype sp' ep w =
( w & cWorld . pathGraph %~ updateedges
& cWorld . incGraph %~ updateincedges
, es
(World, [(Int,Int)])
obstructPathsCrossing obstacletype s e w =
( w & cWorld . incGraph %~ updateincedges
, inces
)
where
updateincedge :: V.Vector [(Int,SimpleEdge)] -> (Int,Int) -> V.Vector [(Int,SimpleEdge)]
updateincedge gr (i,j) = gr & ix i . each %~ g j
g j (k,o) | j == k = (k,o & seObstacles . at obstacletype ?~ ())
| otherwise = (k,o)
updateincedge = flip $ updateEdge (at obstacletype ?~ ())
updateincedges gr = foldl' updateincedge gr inces
inces = filter inedgecrosses $ nearSeg peZoneSize _incEdgeZoning sp' ep w
inedgecrosses (i,j) = isJust $ intersectSegSeg sp' ep (f i) (f j)
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 sp' ep (_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
--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)))
+3 -3
View File
@@ -2,6 +2,6 @@ module Dodge.Path.Translate where
import Dodge.Data.PathGraph
fromEdgeTuple :: (Int, Int, PathEdge) -> PathEdgeNodes
{-# INLINE fromEdgeTuple #-}
fromEdgeTuple (a, b, pe) = PathEdgeNodes a b pe
--fromEdgeTuple :: (Int, Int, PathEdge) -> PathEdgeNodes
--{-# INLINE fromEdgeTuple #-}
--fromEdgeTuple (a, b, pe) = PathEdgeNodes a b pe
+2 -4
View File
@@ -4,8 +4,6 @@ module Dodge.Placement.PlaceSpot.Block (
plLineBlock,
) where
import Data.Set (Set)
import qualified Data.Set as Set
import Control.Lens
import qualified Data.IntSet as IS
import Data.List
@@ -115,11 +113,11 @@ plLineBlock basePane blwidth a b gw =
-- | Must be done after inserting the block
insertWalls :: Int -> [Wall] -> World -> World
insertWalls blid wls w = w' & cWorld . lWorld . blocks . ix blid . blObstructs .~ Set.unions paths
insertWalls blid wls w = w' & cWorld . lWorld . blocks . ix blid . blObstructs .~ concat paths
where
(w', paths) = mapAccumR (flip insertWall) w wls
insertWall :: Wall -> World -> (World, Set PathEdgeNodes)
insertWall :: Wall -> World -> (World, [(Int,Int)])
insertWall wl =
uncurry (obstructPathsCrossing BlockObstacle) (_wlLine wl)
. (cWorld . lWorld . walls . at (_wlID wl) ?~ wl)
+12 -15
View File
@@ -1,19 +1,15 @@
module Dodge.Placement.PlaceSpot.TriggerDoor (
plDoor,
plSlideDoor,
maybeClearDoorPaths,
updateDoorEdges,
) where
import Dodge.Data.GenWorld
import Data.Set (Set)
import qualified Data.Graph.Inductive as FGL
import qualified Data.IntSet as IS
import Data.List
import Dodge.Base
import Dodge.Default.Door
import Dodge.LevelGen.DoorPane
import Dodge.Path
import Dodge.Zoning.Wall
import Geometry
import qualified IntMapHelp as IM
import LensHelp
@@ -61,19 +57,20 @@ addDoorWall eo drid wl w (wlid, wlps) =
, _wlID = wlid
, _wlStructure = DoorPart drid
}
& cWorld . lWorld . doors . ix drid . drObstructs <>~ es
-- & cWorld . lWorld . doors . ix drid . drObstructs <>~ es
where
(w', es) = uncurry (obstructPathsCrossing eo) wlps w
(w', _) = uncurry (obstructPathsCrossing eo) wlps w
maybeClearDoorPaths :: EdgeObstacle -> Set PathEdgeNodes -> World -> World
maybeClearDoorPaths eo es w = foldl' (maybeClearDoorPath eo) w es
updateDoorEdges :: EdgeObstacle -> [(Int,Int)] -> World -> World
updateDoorEdges eo es w = foldl' (updateDoorEdge eo) w es
maybeClearDoorPath :: EdgeObstacle -> World -> PathEdgeNodes -> World
maybeClearDoorPath eo w (PathEdgeNodes x y pe)
| not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w =
w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles . at eo ?~ ()) . FGL.delEdge (x, y)
| otherwise =
w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles . at eo .~ Nothing) . FGL.delEdge (x, y)
updateDoorEdge :: EdgeObstacle -> World -> (Int,Int) -> World
--updateDoorEdge eo w (i,j) = w
updateDoorEdge _ w _ = w
-- | not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w =
-- w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles . at eo ?~ ()) . FGL.delEdge (x, y)
-- | otherwise =
-- w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles . at eo .~ Nothing) . FGL.delEdge (x, y)
plSlideDoor ::
Door ->
+3 -3
View File
@@ -399,9 +399,9 @@ critsRoom :: Int -> State LayoutVars (Tree Room)
critsRoom i =
join $
takeOne
-- [ return <$> roomCCrits i
-- , return <$> critsPillarRoom i
[ return <$> glassSwitchBackCrits i
[ return <$> roomCCrits i
, return <$> critsPillarRoom i
, return <$> glassSwitchBackCrits i
]
-- cor <- shuffleLinks corridor
+2 -2
View File
@@ -43,10 +43,10 @@ tutAnoTree = do
foldMTRS
[ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
, corDoor
, corDoor
, return $ tToBTree "cor" $ return $ cleatOnward corridor
, tToBTree "t" . return . cleatOnward <$> slowDoorRoom
, corDoor
, corDoor
, return $ tToBTree "cor" $ return $ cleatOnward corridor
, tutHub
, tutLight
, tutDrop
+10 -10
View File
@@ -13,10 +13,10 @@ module Dodge.Save (
import Control.Monad
import Data.Maybe
import Dodge.WorldLoad
import Dodge.Path.Translate
import Data.Graph.Inductive (labEdges, labNodes)
import Dodge.Zoning.Pathing
import Data.Foldable
--import Dodge.Path.Translate
--import Data.Graph.Inductive (labEdges, labNodes)
--import Dodge.Zoning.Pathing
--import Data.Foldable
import Dodge.Wall.Zone
import Dodge.Concurrent
import Control.Lens
@@ -51,14 +51,14 @@ readSaveSlot ss = do
return $ \uv -> Just
$ uv & uvWorld . cWorld .~ cw
& uvWorld %~ initWallZoning
& uvWorld . pnZoning .~ foldl' (flip zonePn) mempty
(labNodes $ path uv)
& uvWorld . peZoning .~ foldl' (flip zonePe) mempty
(map fromEdgeTuple $ labEdges $ path uv)
-- & uvWorld . pnZoning .~ foldl' (flip zonePn) mempty
-- (labNodes $ path uv)
-- & uvWorld . peZoning .~ foldl' (flip zonePe) mempty
-- (map fromEdgeTuple $ labEdges $ path uv)
& uvScreenLayers .~ []
& postUniverseLoadSideEffect
where
path uv = uv ^. uvWorld . cWorld . pathGraph
-- where
-- path uv = uv ^. uvWorld . cWorld . pathGraph
saveSlotPath :: SaveSlot -> String
saveSlotPath (SaveSlotNum i) = "generated/saves/" ++ show i
+25 -25
View File
@@ -11,17 +11,17 @@ import Geometry
import qualified IntMapHelp as IM
import Control.Lens
pnsNearPoint :: Point2 -> World -> [(Int, Point2)]
pnsNearPoint = nearPoint pnZoneSize _pnZoning
--pnsNearPoint :: Point2 -> World -> [(Int, Point2)]
--pnsNearPoint = nearPoint pnZoneSize _pnZoning
pnsNearSeg :: Point2 -> Point2 -> World -> [(Int, Point2)]
pnsNearSeg = nearSeg pnZoneSize _pnZoning
--pnsNearSeg :: Point2 -> Point2 -> World -> [(Int, Point2)]
--pnsNearSeg = nearSeg pnZoneSize _pnZoning
pnsNearRect :: Point2 -> Point2 -> World -> [(Int, Point2)]
pnsNearRect = nearRect pnZoneSize _pnZoning
--pnsNearRect :: Point2 -> Point2 -> World -> [(Int, Point2)]
--pnsNearRect = nearRect pnZoneSize _pnZoning
pnsNearCirc :: Point2 -> Float -> World -> [(Int, Point2)]
pnsNearCirc p r = pnsNearRect (p +.+ V2 r r) (p -.- V2 r r)
--pnsNearCirc :: Point2 -> Float -> World -> [(Int, Point2)]
--pnsNearCirc p r = pnsNearRect (p +.+ V2 r r) (p -.- V2 r r)
pnZoneSize :: Float
pnZoneSize = 50
@@ -32,19 +32,19 @@ zoneOfPn = zoneOfPoint pnZoneSize . snd
zonePn :: (Int, Point2) -> IM.IntMap (IM.IntMap [(Int, Point2)]) -> IM.IntMap (IM.IntMap [(Int, Point2)])
zonePn pn = zoneMonoid (zoneOfPn pn) [pn]
pesNearPoint :: Point2 -> World -> Set PathEdgeNodes
pesNearPoint = nearPoint peZoneSize _peZoning
--pesNearPoint :: Point2 -> World -> Set PathEdgeNodes
--pesNearPoint = nearPoint peZoneSize _peZoning
--pesNearPoint p w = zoneExtract (zoneOfPoint peZoneSize p) (w ^. cWorld . lWorld . peZoning)
pesNearSeg :: Point2 -> Point2 -> World -> Set PathEdgeNodes
pesNearSeg = nearSeg peZoneSize _peZoning
--pesNearSeg :: Point2 -> Point2 -> World -> Set PathEdgeNodes
--pesNearSeg = nearSeg peZoneSize _peZoning
pesNearRect :: Point2 -> Point2 -> World -> Set PathEdgeNodes
pesNearRect = nearRect peZoneSize _peZoning
--pesNearRect :: Point2 -> Point2 -> World -> Set PathEdgeNodes
--pesNearRect = nearRect peZoneSize _peZoning
pesNearCirc :: Point2 -> Float -> World -> Set PathEdgeNodes
pesNearCirc p r = pesNearRect (p +.+ V2 r r) (p -.- V2 r r)
--pesNearCirc :: Point2 -> Float -> World -> Set PathEdgeNodes
--pesNearCirc p r = pesNearRect (p +.+ V2 r r) (p -.- V2 r r)
peZoneSize :: Float
peZoneSize = 50
@@ -52,16 +52,16 @@ peZoneSize = 50
zoneOfIncPe :: UV.Vector Point2 -> (Int,Int) -> [Int2]
zoneOfIncPe m (i,j) = zoneOfSeg peZoneSize (m ^?! ix i) (m ^?! ix j)
zoneOfPe :: PathEdgeNodes -> [Int2]
zoneOfPe (PathEdgeNodes _ _ pe) = zoneOfSeg peZoneSize (_peStart pe) (_peEnd pe)
--zoneOfPe :: PathEdgeNodes -> [Int2]
--zoneOfPe (PathEdgeNodes _ _ pe) = zoneOfSeg peZoneSize (_peStart pe) (_peEnd pe)
zonePe ::
PathEdgeNodes ->
IM.IntMap (IM.IntMap (Set PathEdgeNodes)) ->
IM.IntMap (IM.IntMap (Set PathEdgeNodes))
zonePe pe im = foldl' f im (zoneOfPe pe)
where
f im' i2 = zoneMonoid i2 (Set.singleton pe) im'
--zonePe ::
-- PathEdgeNodes ->
-- IM.IntMap (IM.IntMap (Set PathEdgeNodes)) ->
-- IM.IntMap (IM.IntMap (Set PathEdgeNodes))
--zonePe pe im = foldl' f im (zoneOfPe pe)
-- where
-- f im' i2 = zoneMonoid i2 (Set.singleton pe) im'
zoneIncPe :: UV.Vector Point2 ->
(Int,Int) ->