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

Commit before complicating zoning

Browse Source
This commit is contained in:
justin
2022-06-28 14:35:49 +01:00
parent 9801a40b9e
commit 4965934502
6 changed files with 57 additions and 48 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Path.hs
+16 -11
View File
@@ -9,15 +9,15 @@ import Dodge.Data
import Dodge.Base.Collide
import Dodge.Zone
import Geometry.Data
import Dodge.Base
import Geometry
import Control.Lens
import Data.Maybe
import Data.List
import qualified Data.IntMap.Strict as IM
--import qualified Data.IntMap.Strict as IM
import Data.Graph.Inductive hiding ((&))
import qualified Data.Set as S
import qualified Data.Set as Set
import qualified Streaming.Prelude as S
--import Data.Graph.Inductive.PatriciaTree
--import Data.Graph.Inductive.Graph hiding ((&))
@@ -27,9 +27,13 @@ makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
nb <- walkableNodeNear b
sp na nb (_pathGraph w)
where
nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
--nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
nodesNear p = runIdentity . S.toList_ $ nearPoint wlZoneSize _pathPoints p w
walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
--walkableNodeNear :: Point2 -> World -> Maybe Point2
--walkableNodeNear p w = insideCirc
makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween a b w
@@ -79,18 +83,19 @@ 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) -> S.Set (a,a) -> Gr a b
pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
pairsToGraph f pairs =
let nodes' = S.map fst pairs `S.union` S.map snd pairs
pairs' = S.map (\(x,y)->(x,y,f x y)) pairs
in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (S.toList nodes') >> insMapEdgesM (S.toList 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'
& pathPoints .~ foldr insertPoint IM.empty (labNodes newGraph)
& pathPoints .~ foldl' insertpoint (Zoning mempty) (labNodes newGraph)
where
pg' = S.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
insertPoint pp@(_,p) = uncurryV insertInZoneWith (wlZoneOfPoint p) (++) [pp]
pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
insertpoint zn (i,p) = insertInZoneWith (wlZoneOfPoint p) (++) [(i,p)] zn
-- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
newGraph = pairsToGraph dist pg'