From 3dfa6926cc183d7a3f19c8dfb1e34bfad927d74a Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 30 Jun 2022 16:41:12 +0100 Subject: [PATCH] Tweak pathfinding --- src/Dodge/Data.hs | 2 +- src/Dodge/Layout.hs | 4 +++ src/Dodge/Path.hs | 41 +++++++++++++++++++------- src/Dodge/Placement/PlaceSpot.hs | 8 ++--- src/Dodge/Placement/PlaceSpot/Block.hs | 4 +-- src/Dodge/Render/ShapePicture.hs | 2 ++ src/Dodge/Zone.hs | 1 + 7 files changed, 44 insertions(+), 18 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index a109594e2..4fa281d75 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -76,7 +76,7 @@ import GHC.Generics import Control.Lens import Control.Monad.State import System.Random -import Data.Graph.Inductive +--import Data.Graph.Inductive import qualified Data.Set as S import qualified Data.IntSet as IS import qualified Data.IntMap.Strict as IM diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 056f8df8a..6170b0c68 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -5,6 +5,7 @@ module Dodge.Layout import Data.Tile import Dodge.Data import Dodge.Path +import Dodge.Zone.Update import Dodge.ShiftPoint import Dodge.Placement.PlaceSpot --import Dodge.LevelGen.Data @@ -21,6 +22,7 @@ import qualified IntMapHelp as IM import Tile import RandomHelp +import Data.Graph.Inductive (labNodes) import Data.List (nubBy) import Data.Traversable import Control.Lens @@ -44,6 +46,8 @@ generateLevelFromRoomList gr' w = initWallZoning , _pathGraph = path , _pathGraphP = pairPath } + & phZoning %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) + (labNodes (_pgGraph path)) where path = pairsToGraph'' pairPath pairPath = foldMap _rmPath rs diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index f1ee3529c..4aaaf870e 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE TupleSections #-} module Dodge.Path ( pointTowardsImpulse , makePathBetween , makePathBetweenPs --- , removePathsCrossing + , removePathsCrossing , pairsToGraph , pairsToGraph'' , walkableNodeNear @@ -101,14 +102,15 @@ 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 = runIdentity . S.fold_ g (Data.Graph.Inductive.empty,new) id . S.each +pairsToGraph' f pairset = ngr' where - g grnm (x,y) = h' $ h x $ h y grnm - where - h' (gr,nm) = (insMapEdge nm (x,y,f x y) gr , nm) - h n (gr,nm) = (gr',nm') - where - (gr',nm',_) = insMapNode nm n gr + 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 @@ -118,13 +120,30 @@ 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 ---removePathsCrossing :: Point2 -> Point2 -> World -> World ---removePathsCrossing a b w = w +removePathsCrossing :: Point2 -> Point2 -> World -> World +removePathsCrossing a b w = w +-- & pathGraph . pgGraph %~ deleteEdges +-- & pathGraphP %~ deletePairs -- & pathGraph .~ newGraph -- & pathGraphP .~ pg' -- & phZoning %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty) -- (labNodes newGraph) --- where + where + thegr = _pgGraph (_pathGraph w) + ns = nearSeg _phZoning 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 + deleteEdge gr ((x,_),(y,_)) = delEdge (x,y) $ delEdge (y,x) gr +-- deletePairs s = runIdentity $ S.fold_ deletePair s id pairs +-- deletePair s (x,y) = Set.delete (x,y) $ Set.delete (y,x) s + +nodePairs :: Gr a b -> (Int,a) -> StreamOf ((Int,a),(Int,a)) +nodePairs gr (n,p) = S.mapMaybe (fmap ((n,p),) . nodeLabel gr) . S.each $ neighbors gr n + +nodeLabel :: Gr a b -> Int -> Maybe (Int, a) +nodeLabel gr n = (n,) <$> lab gr n + -- pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w -- -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp] -- newGraph = pairsToGraph'' dist pg' diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index c793ceb37..e53035621 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -120,10 +120,10 @@ evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w) (evaluatedType, g) = runState rgen (_randGen w) placeWallPoly :: [Point2] -> Wall -> World -> World -placeWallPoly ps wl = over walls (placeWalls ps wl) ---placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl) --- where --- rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps +--placeWallPoly ps wl = over walls (placeWalls ps wl) +placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl) + where + rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall placeWalls qs wl wls = foldl' (addPane wl) wls pairs diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index abb72b7de..5d6850f50 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -55,8 +55,8 @@ 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, wWithBlock) + = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs) +-- = (0, wWithBlock) where pairs = loopPairs poly wWithBlock = addBlock poly wl bl w diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 8e2c7e2a0..2b8901719 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -30,6 +30,7 @@ import Geometry.ConvexPoly --import Data.Foldable import qualified Data.IntMap.Strict as IM -- Lazy? import qualified Data.Map.Strict as M +import qualified Data.Set as Set import Control.Lens import Data.Maybe import qualified Streaming.Prelude as S @@ -266,6 +267,7 @@ drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w) drawPathing :: World -> Picture drawPathing w = setLayer DebugLayer $ (color green . pictures . map (thickLine 5 . tflat2) $ graphToEdges gr) + --(color green . pictures . Set.map (thickLine 5 . tflat2) $ _pathGraphP w) <> concatMap dispInc (graphToIncidence gr) where dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index 2d181352f..ab6f325bc 100644 --- a/src/Dodge/Zone.hs +++ b/src/Dodge/Zone.hs @@ -3,6 +3,7 @@ module Dodge.Zone , zoneAroundPoint , aroundPoint , nearPoint + , nearSeg , wlsNearPoint , crsNearPoint , clsNearPoint