From 56b063544c4142ec700f3047114b4ad01d800bbe Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 30 Jun 2022 23:33:48 +0100 Subject: [PATCH] Add pathing infrastructure --- src/Dodge/Data.hs | 3 +- src/Dodge/Data/PathGraph.hs | 19 +++++- src/Dodge/Data/Room.hs | 6 +- src/Dodge/Default/World.hs | 6 +- src/Dodge/Floor.hs | 2 +- src/Dodge/Layout.hs | 8 ++- src/Dodge/Path.hs | 82 +++++++++++++++++++++----- src/Dodge/Placement/PlaceSpot/Block.hs | 2 +- src/Dodge/PlacementSpot.hs | 16 ++--- src/Dodge/Render/ShapePicture.hs | 21 +++++-- src/Dodge/Room/Pillar.hs | 2 +- src/Dodge/Room/Tanks.hs | 4 +- src/Dodge/Zone/Size.hs | 4 +- 13 files changed, 130 insertions(+), 45 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 4fa281d75..794f7dac5 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -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] diff --git a/src/Dodge/Data/PathGraph.hs b/src/Dodge/Data/PathGraph.hs index 5b318938e..338fdba5c 100644 --- a/src/Dodge/Data/PathGraph.hs +++ b/src/Dodge/Data/PathGraph.hs @@ -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 diff --git a/src/Dodge/Data/Room.hs b/src/Dodge/Data/Room.hs index 3eb0c3da3..fa0296f62 100644 --- a/src/Dodge/Data/Room.hs +++ b/src/Dodge/Data/Room.hs @@ -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) diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index fc237cf73..3a19d2ffa 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -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 diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 393c1a8c1..822e0ac31 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -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 -- ] diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 6170b0c68..5a94f2801 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -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 diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index 4aaaf870e..4e7b2a4af 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -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 diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index 5d6850f50..927dbe0d4 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -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 diff --git a/src/Dodge/PlacementSpot.hs b/src/Dodge/PlacementSpot.hs index f6ecd3d19..3446d9194 100644 --- a/src/Dodge/PlacementSpot.hs +++ b/src/Dodge/PlacementSpot.hs @@ -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 diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 2b8901719..82e23718b 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -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 diff --git a/src/Dodge/Room/Pillar.hs b/src/Dodge/Room/Pillar.hs index dfbaecd44..04c376569 100644 --- a/src/Dodge/Room/Pillar.hs +++ b/src/Dodge/Room/Pillar.hs @@ -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 diff --git a/src/Dodge/Room/Tanks.hs b/src/Dodge/Room/Tanks.hs index f5855ab75..864a85bcc 100644 --- a/src/Dodge/Room/Tanks.hs +++ b/src/Dodge/Room/Tanks.hs @@ -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 diff --git a/src/Dodge/Zone/Size.hs b/src/Dodge/Zone/Size.hs index b7f238797..1b4c1351a 100644 --- a/src/Dodge/Zone/Size.hs +++ b/src/Dodge/Zone/Size.hs @@ -1,7 +1,7 @@ module Dodge.Zone.Size where -phZoneSize :: Float -phZoneSize = 100 +pnZoneSize :: Float +pnZoneSize = 100 wlZoneSize :: Float wlZoneSize = 50