143 lines
4.7 KiB
Haskell
143 lines
4.7 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Path (
|
|
pointTowardsImpulse,
|
|
makePathBetween,
|
|
makePathBetweenPs,
|
|
obstructPathsCrossing,
|
|
getNodePos,
|
|
walkableNodeNear,
|
|
snapToGrid,
|
|
pairsToIncGraph,
|
|
updateEdge,
|
|
getEdgesCrossing,
|
|
) where
|
|
|
|
import Dodge.WorldEvent.ThingsHit
|
|
import qualified Data.Set as S
|
|
import qualified Algorithm.Search as AS
|
|
import Control.Lens
|
|
--import Data.Bifunctor
|
|
import Data.Foldable
|
|
--import Data.Graph.Inductive hiding ((&))
|
|
import Data.List (sortOn)
|
|
--import Data.Map.Strict (Map)
|
|
--import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Vector as V
|
|
import qualified Data.Vector.Unboxed as UV
|
|
import Dodge.Data.World
|
|
import Dodge.Zoning.Base
|
|
import Dodge.Zoning.Common
|
|
import Dodge.Zoning.Pathing
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import Linear
|
|
|
|
getNodePos :: Int -> World -> Maybe Point2
|
|
getNodePos i w = w ^? cWorld . incNode . ix i
|
|
|
|
--getEdgesCrossingPoly :: [Point2] -> World -> [(Int,Int)]
|
|
--getEdgesCrossingPoly ps w = filter tcross $ zonesExtract (w ^. incEdgeZoning)
|
|
-- $ Set.toList $ foldMap (uncurry $ zoneOfSegSet peZoneSize) $ pairs
|
|
-- where
|
|
-- pairs = loopPairs ps
|
|
-- tcross (i,j) = any (isJust . uncurry (intersectSegSeg (f i) (f j))) pairs
|
|
-- f i = w ^?! cWorld . incNode . ix i
|
|
|
|
getEdgesCrossing :: Point2 -> Point2 -> World -> [(Int,Int)]
|
|
getEdgesCrossing s e w = filter inedgecrosses $ nearSeg peZoneSize _incEdgeZoning s e w
|
|
where
|
|
inedgecrosses (i, j) = isJust $ intersectSegSeg s e (f i) (f j)
|
|
f i = w ^?! cWorld . incNode . ix i
|
|
|
|
updateEdge ::
|
|
(Set.Set EdgeObstacle -> Set.Set EdgeObstacle) ->
|
|
(Int, Int) ->
|
|
V.Vector [(Int, SimpleEdge)] ->
|
|
V.Vector [(Int, SimpleEdge)]
|
|
updateEdge f (i, j) = ix i . each %~ g
|
|
where
|
|
g (k, o)
|
|
| j == k = (k, o & seObstacles %~ f)
|
|
| otherwise = (k, o)
|
|
|
|
makePathUsing :: (Set.Set EdgeObstacle -> Bool) -> Point2 -> Point2 -> World -> Maybe [Int]
|
|
makePathUsing t s e w = do
|
|
na <- walkableNodeNear w s
|
|
nb <- walkableNodeNear w e
|
|
let h i = distance (getn nb) (getn i)
|
|
(na :) . snd <$> AS.aStarAssoc getes h (== nb) na
|
|
where
|
|
g (i, SimpleEdge c o)
|
|
| t o = Just (i, c)
|
|
| otherwise = Nothing
|
|
getes i = mapMaybe g $ w ^?! cWorld . incGraph . ix i
|
|
getn i = w ^?! cWorld . incNode . ix i
|
|
|
|
makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
|
|
makePathBetween = makePathUsing $ not . pathEdgeObstructed
|
|
|
|
pathEdgeObstructed :: Set.Set EdgeObstacle -> Bool
|
|
pathEdgeObstructed pe = any (`Set.member` pe) [WallObstacle WallNotAutoOpen, ChasmObstacle]
|
|
|
|
walkableNodeNear :: World -> Point2 -> Maybe Int
|
|
{-# INLINE walkableNodeNear #-}
|
|
walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
|
|
where
|
|
nodesNear = zonesExtract (w ^. incNodeZoning) . snailAround $ zoneOfPoint pnZoneSize p
|
|
|
|
snailAround :: Int2 -> [Int2]
|
|
snailAround x = (x +) <$> smallSnailInt2
|
|
|
|
smallSnailInt2 :: [Int2]
|
|
smallSnailInt2 =
|
|
sortOn
|
|
(distance (V2 0 (0 :: Float)) . fmap fromIntegral)
|
|
[V2 x y | x <- [-2 .. 2], y <- [-2 .. 2]]
|
|
|
|
makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
|
|
makePathBetweenPs a b w = traverse (`getNodePos` w) =<< makePathBetween a b w
|
|
|
|
-- assumes that pathfinding is symmetric
|
|
pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2
|
|
pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs b a w
|
|
|
|
pairsToIncGraph ::
|
|
Set.Set (Point2, Point2) ->
|
|
( UV.Vector Point2
|
|
, V.Vector [(Int, SimpleEdge)]
|
|
, [(Int, Int)]
|
|
)
|
|
pairsToIncGraph pairs =
|
|
( inodes
|
|
, incgraph
|
|
, Set.toList pairs & each . each %~ (\i -> pToNode ^?! ix i)
|
|
)
|
|
where
|
|
incgraph = V.generate (length im) (im IM.!)
|
|
im = IM.fromListWith (++) . fmap toedge $ Set.toList pairs
|
|
toedge (x, y) =
|
|
( pToNode ^?! ix x
|
|
, [(pToNode ^?! ix y, SimpleEdge (distance x y) mempty)]
|
|
)
|
|
pToNode = IM.invertIntMapUnique . IM.fromDistinctAscList $ zip [0 ..] ps
|
|
inodes = UV.generate (length ps) (ps !!)
|
|
ps = Set.toList $ Set.map fst pairs <> Set.map snd pairs
|
|
|
|
obstructPathsCrossing :: S.Set EdgeObstacle -> Point2 -> Point2 -> World -> World
|
|
obstructPathsCrossing obs s e w = w & cWorld . incGraph %~ updateincedges
|
|
where
|
|
updateincedge = flip $ updateEdge (S.union obs)
|
|
updateincedges gr = foldl' updateincedge gr inces
|
|
inces = filter inedgecrosses $ nearSeg peZoneSize _incEdgeZoning s e w
|
|
inedgecrosses (i, j) = isJust $ intersectSegSeg s e (f i) (f j)
|
|
f i = w ^?! cWorld . incNode . ix i
|
|
|
|
snapToGrid :: Set (Point2, Point2) -> Set (Point2, Point2)
|
|
snapToGrid = Set.map (over each (fmap (fromIntegral . f)))
|
|
where
|
|
f :: Float -> Int
|
|
f = round
|