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

Fix leaky path graph creation

Browse Source
This commit is contained in:
justin
2022-06-29 23:17:45 +01:00
parent 84cb830804
commit 1abcf099e2
8 changed files with 65 additions and 28 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Path.hs
+38 -19
View File
@@ -2,8 +2,9 @@ module Dodge.Path
( pointTowardsImpulse
, makePathBetween
, makePathBetweenPs
, removePathsCrossing
-- , removePathsCrossing
, pairsToGraph
, pairsToGraph''
, walkableNodeNear
, nodesNearL
, getNodePos
@@ -26,26 +27,28 @@ import StreamingHelp
--import Data.Graph.Inductive.Graph hiding ((&))
getNodePos :: Int -> World -> Maybe Point2
getNodePos i w = _pathGraph w `lab` i
getNodePos i w = _pgGraph (_pathGraph w) `lab` i
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 (_pathGraph w)
sp na nb (_pgGraph $ _pathGraph w)
walkableNodeNear :: Point2 -> World -> Maybe (Int,Point2)
{-# INLINE walkableNodeNear #-}
walkableNodeNear p w = minStreamOn (dist p . snd)
. S.filter (flip (isWalkable p) w . snd) $ nodesNear p w
nodesNear :: Point2 -> World -> StreamOf (Int,Point2)
{-# INLINE nodesNear #-}
nodesNear = aroundPoint _phZoning
nodesNearL :: Point2 -> World -> [(Int,Point2)]
nodesNearL p = runIdentity . S.toList_ . nodesNear p
makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween a b w
makePathBetweenPs a b w = mapMaybe (lab $ _pgGraph $ _pathGraph w) <$> makePathBetween a b w
pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2
pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a b w
@@ -93,19 +96,35 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a
-- [] -> return Nothing
-- _ -> return $ Just $ ns !! i
--
pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
pairsToGraph f pairs =
let nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
removePathsCrossing :: Point2 -> Point2 -> World -> World
removePathsCrossing a b w = w
& pathGraph .~ newGraph
& pathGraphP .~ pg'
& phZoning %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
(labNodes newGraph)
where
pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
-- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
newGraph = pairsToGraph dist pg'
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
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
pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
pairsToGraph f pairs = undir
$ run_ Data.Graph.Inductive.empty
$ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
where
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
-- & pathGraph .~ newGraph
-- & pathGraphP .~ pg'
-- & phZoning %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
-- (labNodes newGraph)
-- where
-- pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
-- -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
-- newGraph = pairsToGraph'' dist pg'