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

Add pathing infrastructure

Browse Source
This commit is contained in:
justin
2022-06-30 23:33:48 +01:00
parent 3dfa6926cc
commit 56b063544c
13 changed files with 130 additions and 45 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+2 -1
View File
@@ -150,7 +150,8 @@ data World = World
, _clickMousePos :: Point2
, _pathGraph :: PathGraph
, _pathGraphP :: S.Set (Point2,Point2)
, _phZoning :: Zoning [] (Int,Point2)
, _pnZoning :: Zoning [] (Int,Point2)
, _peZoning :: Zoning [] (Int,Int,PathEdge)
, _hud :: HUD
, _lightSources :: IM.IntMap LightSource
, _tempLightSources :: [TempLightSource]
src/Dodge/Data/PathGraph.hs
+17 -2
View File
@@ -4,9 +4,24 @@ module Dodge.Data.PathGraph where
import Geometry.Data
import Control.Lens
import Data.Graph.Inductive
import qualified Data.Set as Set
import Data.Map.Strict (Map)
data PathGraph = PathGraph
{ _pgGraph :: Gr Point2 Float
, _pgNodeMap :: NodeMap Point2
{ _pgGraph :: Gr Point2 PathEdge
, _pgNodeMap :: Map Point2 Int
, _pgNodeCount :: Int
, _pgEdgeMap :: Map (V2 Point2) Int2
}
data PathEdge = PathEdge
{_peStart :: Point2
,_peEnd :: Point2
,_peObstacles :: Set.Set EdgeObstacle
}
deriving (Eq,Ord,Show)
data EdgeObstacle
= BlockObstacle
| DoorObstacle
| AutoDoorObstacle
deriving (Eq,Ord,Show,Bounded,Enum)
makeLenses ''PathGraph
src/Dodge/Data/Room.hs
+3 -3
View File
@@ -61,12 +61,12 @@ data RPLinkStatus
| UnusedLink { _rplsType :: S.Set RoomLinkType }
| NotLink
deriving (Eq,Ord,Show)
data PathEdge = PathFromEdge CardinalPoint Int
data PathFromEdge = PathFromEdge CardinalPoint Int
deriving (Eq,Ord,Show)
data RoomPosType
= RoomPosOnPath {_onPathEdges :: S.Set PathEdge}
| RoomPosOffPath {_offPathEdges :: S.Set PathEdge}
= RoomPosOnPath {_onPathFromEdges :: S.Set PathFromEdge}
| RoomPosOffPath {_offPathFromEdges :: S.Set PathFromEdge}
| RoomPosExLink
| RoomPosLab Int
deriving (Eq,Ord,Show)
src/Dodge/Default/World.hs
+4 -2
View File
@@ -4,6 +4,7 @@ import Dodge.Zone.Size
import Dodge.Zone.Object
import Dodge.Base
import Geometry.Vector3D
import Geometry.Zone
--import Dodge.Config.KeyConfig
--import Dodge.Menu
--import Picture
@@ -73,9 +74,10 @@ defaultWorld = World
--, _savedWorlds = M.empty
-- , _menuLayers = []
, _clickMousePos = V2 0 0
, _pathGraph = PathGraph Data.Graph.Inductive.Graph.empty new
, _pathGraph = PathGraph Data.Graph.Inductive.Graph.empty mempty 0 mempty
, _pathGraphP = mempty
, _phZoning = Zoning mempty phZoneSize (zonePos snd)
, _pnZoning = Zoning mempty pnZoneSize (zonePos snd)
, _peZoning = Zoning mempty pnZoneSize (\x (_,_,PathEdge p q _) -> zoneOfSeg x p q)
, _hud = HUD
{ _hudElement = DisplayInventory NoSubInventory
, _carteCenter = V2 0 0
src/Dodge/Floor.hs
+1 -1
View File
@@ -41,9 +41,9 @@ initialAnoTree :: Annotation
initialAnoTree = OnwardList
$ intersperse (AnTree corDoor)
[ IntAnno $ AnTree . startRoom
, AnRoom $ roomCCrits 10
, AnRoom $ return airlock0
, AnRoom slowDoorRoom
-- , AnRoom $ roomCCrits 10
, AnTree firstBreather
-- , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
-- ]
src/Dodge/Layout.hs
+5 -3
View File
@@ -22,7 +22,7 @@ import qualified IntMapHelp as IM
import Tile
import RandomHelp
import Data.Graph.Inductive (labNodes)
import Data.Graph.Inductive (labNodes,labEdges)
import Data.List (nubBy)
import Data.Traversable
import Control.Lens
@@ -46,8 +46,10 @@ generateLevelFromRoomList gr' w = initWallZoning
, _pathGraph = path
, _pathGraphP = pairPath
}
& phZoning %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
(labNodes (_pgGraph path))
& pnZoning %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
(labNodes (_pgGraph path)))
& peZoning %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
(labEdges (_pgGraph path)))
where
path = pairsToGraph'' pairPath
pairPath = foldMap _rmPath rs
src/Dodge/Path.hs
+68 -14
View File
@@ -9,6 +9,7 @@ module Dodge.Path
, walkableNodeNear
, nodesNearL
, getNodePos
, addObstacleCrossing'
) where
import Dodge.Data
import Dodge.Base.Collide
@@ -21,7 +22,10 @@ import Data.Maybe
import Data.List
--import qualified Data.IntMap.Strict as IM
import Data.Graph.Inductive hiding ((&))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map.Strict as M
import qualified Streaming.Prelude as S
import StreamingHelp
--import Data.Graph.Inductive.PatriciaTree
@@ -34,7 +38,10 @@ makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
(na,_) <- walkableNodeNear a w
(nb,_) <- walkableNodeNear b w
sp na nb (_pgGraph $ _pathGraph w)
sp na nb (second pathDist $ _pgGraph $ _pathGraph w)
pathDist :: PathEdge -> Float
pathDist pe = dist (_peStart pe) (_peEnd pe)
walkableNodeNear :: Point2 -> World -> Maybe (Int,Point2)
{-# INLINE walkableNodeNear #-}
@@ -43,7 +50,7 @@ walkableNodeNear p w = minStreamOn (dist p . snd)
nodesNear :: Point2 -> World -> StreamOf (Int,Point2)
{-# INLINE nodesNear #-}
nodesNear = aroundPoint _phZoning
nodesNear = aroundPoint _pnZoning
nodesNearL :: Point2 -> World -> [(Int,Point2)]
nodesNearL p = runIdentity . S.toList_ . nodesNear p
@@ -99,18 +106,45 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a
--
pairsToGraph'' :: Set.Set (Point2,Point2) -> PathGraph
pairsToGraph'' = uncurry PathGraph . pairsToGraph' dist
pairsToGraph' :: Ord a => (a -> a -> b) -> Set.Set (a,a) -> (Gr a b, NodeMap a)
pairsToGraph' f pairset = ngr'
pairsToGraph'' pairset = PathGraph gr' nodemap ncount edgemap
where
nodeset = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
getnode nodeset' (x,y) = Set.insert x $ Set.insert y nodeset'
ngr = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,new) id nodeset
ngr' = runIdentity $ S.fold_ insertedge ngr id $ S.each pairset
insertedge (gr,nm) (x,y) = (insMapEdge nm (x,y,f x y) gr, nm)
insertnode (gr,nm) n = fstsnd $ insMapNode nm n gr
fstsnd (a,b,_) = (a,b)
(gr,nodemap,ncount) = insertNodes pairset
(gr',edgemap) = insertEdges toPathEdge pairset gr nodemap
toPathEdge :: Point2 -> Point2 -> PathEdge
toPathEdge sp' ep = PathEdge sp' ep mempty
insertEdges :: (Point2 -> Point2 -> b)
-> Set (Point2,Point2) -> Gr Point2 b -> Map Point2 Int -> (Gr Point2 b,Map (V2 Point2) Int2)
insertEdges efunc pairset gr nm = runIdentity $ S.fold_ insertedge (gr,mempty) id $ (S.each pairset)
where
insertedge (gr',em) (a,b) = (insEdge (f a,f b,efunc a b) gr'
, M.insert (V2 a b) (V2 (f a) (f b)) em)
f a = nm M.! a
insertNodes :: Set (Point2,Point2) -> (Gr Point2 b, Map Point2 Int, Int)
insertNodes pairset = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,mempty,0) id nodestream
where
nodestream :: StreamOf Point2
nodestream = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
getnode strm (x,y) = Set.insert x $ Set.insert y strm
insertnode :: (Gr Point2 b,Map Point2 Int,Int) -> Point2 -> (Gr Point2 b,Map Point2 Int,Int)
insertnode (gr,nm,i) n = case M.lookup n nm of
Nothing -> (insNode (j,n) gr, M.insert n j nm, j)
Just _ -> (gr,nm,i)
where
j = i + 1
--pairsToGraph' :: (Ord a) => (a -> a -> b) -> Set (a,a) -> (Gr a b, Map a Int, Map (V2 a) Int2)
--pairsToGraph' f pairset = ngr'
-- where
-- nodeset = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
-- getnode nodeset' (x,y) = Set.insert x $ Set.insert y nodeset'
-- ngr = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,new) id nodeset
-- ngr' = runIdentity $ S.fold_ insertedge ngr id $ S.each pairset
-- insertedge (gr,nm) (x,y) = (insMapEdge nm (x,y,f x y) gr, nm)
-- insertnode (gr,nm) n = fstsnd $ insMapNode nm n gr
-- fstsnd (a,b,_) = (a,b)
pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
pairsToGraph f pairs = undir
@@ -120,6 +154,26 @@ pairsToGraph f pairs = undir
nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
--findEdgesCrossing :: Point2 -> Point2 -> Gr Point2 PathEdge ->
--
addObstacleCrossing :: World -> EdgeObstacle -> Point2 -> Point2
-> Gr Point2 PathEdge
-> Gr Point2 PathEdge
addObstacleCrossing w eo a b gr = runIdentity $ S.fold_ updateedge gr id paths
where
updateedge gr' (xi,yi,PathEdge x y obs) = insEdge (xi,yi,PathEdge x y (Set.insert eo obs))
$ delEdge (xi,yi) gr'
paths = S.filter f $ nearSeg _peZoning a b w
f (_,_,PathEdge x y _) = isJust $ intersectSegSeg x y a b
addObstacleCrossing' :: EdgeObstacle -> Point2 -> Point2
-> World
-> World
addObstacleCrossing' eo a b w = w & pathGraph . pgGraph %~ addObstacleCrossing w eo a b
where
paths = S.filter f $ nearSeg _peZoning a b w
f (_,_,PathEdge x y _) = isJust $ intersectSegSeg x y a b
removePathsCrossing :: Point2 -> Point2 -> World -> World
removePathsCrossing a b w = w
-- & pathGraph . pgGraph %~ deleteEdges
@@ -130,7 +184,7 @@ removePathsCrossing a b w = w
-- (labNodes newGraph)
where
thegr = _pgGraph (_pathGraph w)
ns = nearSeg _phZoning a b w
ns = nearSeg _pnZoning a b w
pairs = S.filter testEdge $ S.for ns (nodePairs thegr)
testEdge ((_,p),(_,q)) = isJust $ intersectSegSeg a b p q
deleteEdges gr = runIdentity $ S.fold_ deleteEdge gr id pairs
src/Dodge/Placement/PlaceSpot/Block.hs
+1 -1
View File
@@ -55,7 +55,7 @@ addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon"
placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World)
placeBlock poly bl wl w
= (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
= (0, foldr (uncurry (addObstacleCrossing' BlockObstacle)) wWithBlock pairs)
-- = (0, wWithBlock)
where
pairs = loopPairs poly
src/Dodge/PlacementSpot.hs
+8 -8
View File
@@ -3,8 +3,8 @@ module Dodge.PlacementSpot
( atFstLnkOut
, rpIsOnPath
, rpIsOffPath
, rpOffPathEdge
, rpOnPathEdge
, rpOffPathFromEdge
, rpOnPathFromEdge
, useUnusedLnk
, psRandRanges
, useRoomPosCond
@@ -82,16 +82,16 @@ rpIsOffPath = any f . _rpType
where
f RoomPosOffPath {} = True
f _ = False
rpOffPathEdge :: PathEdge -> RoomPos -> Bool
rpOffPathEdge pe = any f . _rpType
rpOffPathFromEdge :: PathFromEdge -> RoomPos -> Bool
rpOffPathFromEdge pe = any f . _rpType
where
f rt = maybe False (pe `elem`) (rt ^? offPathEdges)
f rt = maybe False (pe `elem`) (rt ^? offPathFromEdges)
-- test whether a roomPos is on the path with a given from edge value
rpOnPathEdge :: PathEdge -> RoomPos -> Bool
rpOnPathEdge pe = any f . _rpType
rpOnPathFromEdge :: PathFromEdge -> RoomPos -> Bool
rpOnPathFromEdge pe = any f . _rpType
where
f rt = maybe False (pe `elem`) (rt ^? onPathEdges)
f rt = maybe False (pe `elem`) (rt ^? onPathFromEdges)
resetPLUse :: PlacementSpot -> PlacementSpot
resetPLUse (PSPos f g fallback) = PSPos f' g fallback
src/Dodge/Render/ShapePicture.hs
+16 -5
View File
@@ -34,6 +34,7 @@ import qualified Data.Set as Set
import Control.Lens
import Data.Maybe
import qualified Streaming.Prelude as S
import qualified Data.Graph.Inductive as FGL
-- TODO only filter out shapes outside the range of the furthest shown light source
worldSPic :: Configuration -> World -> SPic
@@ -110,7 +111,7 @@ debugDraw' cfig w bl = case bl of
Cr_status -> Right $ drawCrInfo cfig w
Mouse_position -> Right $ drawMousePosition cfig w
Walls_info -> Right $ drawWlIDs cfig w
Pathing -> Right $ drawPathing w
Pathing -> Right $ drawPathing cfig w
Show_nodes_near_select -> Right $ drawNodesNearSelect w
drawCreatureDisplayTexts :: World -> Picture
@@ -118,7 +119,7 @@ drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
drawNodesNearSelect :: World -> Picture
drawNodesNearSelect w = setLayer DebugLayer $
runIdentity (S.foldMap_ (drawZone phZoneSize) (zoneAroundPoint phZoneSize sp))
runIdentity (S.foldMap_ (drawZone pnZoneSize) (zoneAroundPoint pnZoneSize sp))
<> color red (foldMap (drawCross . snd) $ nodesNearL sp w)
<> color green (drawCross sp)
<> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w)
@@ -264,9 +265,19 @@ drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
where
p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl)
drawPathing :: World -> Picture
drawPathing w = setLayer DebugLayer $
(color green . pictures . map (thickLine 5 . tflat2) $ graphToEdges gr)
edgeToPic :: [Point2] -> PathEdge -> Picture
edgeToPic poly pe
| not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
| null $ _peObstacles pe
= color green $ arrow sp ep
| otherwise = color red $ arrow sp ep
where
sp = _peStart pe
ep = _peEnd pe
drawPathing :: Configuration -> World -> Picture
drawPathing cfig w = setLayer DebugLayer $
(foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) $ FGL.labEdges gr)
--(color green . pictures . Set.map (thickLine 5 . tflat2) $ _pathGraphP w)
<> concatMap dispInc (graphToIncidence gr)
where
src/Dodge/Room/Pillar.hs
+1 -1
View File
@@ -70,7 +70,7 @@ roomPillarsSquare = do
where
makepill edge = sps (rprBool $ \rp _ -> t edge rp) smallPillar
t edge rp = any (f edge) (_rpType rp) && _rpPlacementUse rp == 0
f edge rpt = maybe False (PathFromEdge edge 0 `S.member`) (rpt ^? offPathEdges)
f edge rpt = maybe False (PathFromEdge edge 0 `S.member`) (rpt ^? offPathFromEdges)
roomPillarsPassage :: RandomGen g => State g Room
roomPillarsPassage = do
src/Dodge/Room/Tanks.hs
+2 -2
View File
@@ -42,7 +42,7 @@ randEdgeTank = do
<> horPipe 80 0 (70 *.* cardVec edge))))
-- 70 is a guess, the true value depends on the distance to the wall
& plSpot .~ rprBool (\rp _ -> _rpPlacementUse rp == 0
&& rpOffPathEdge (PathFromEdge edge 0) rp)
&& rpOffPathFromEdge (PathFromEdge edge 0) rp)
randEdgeTanks :: RandomGen g => Int -> State g [Placement]
randEdgeTanks i = do
@@ -54,7 +54,7 @@ randEdgeTanks i = do
<> horPipe 80 0 (70 *.* cardVec edge))))
-- 70 is a guess, the true value depends on the distance to the wall
& plSpot .~ rprBool (\rp _ -> _rpPlacementUse rp == 0
&& rpOffPathEdge (PathFromEdge edge 0) rp)
&& rpOffPathFromEdge (PathFromEdge edge 0) rp)
tanksPipesRoom :: RandomGen g => State g Room
tanksPipesRoom = do
src/Dodge/Zone/Size.hs
+2 -2
View File
@@ -1,7 +1,7 @@
module Dodge.Zone.Size where
phZoneSize :: Float
phZoneSize = 100
pnZoneSize :: Float
pnZoneSize = 100
wlZoneSize :: Float
wlZoneSize = 50