Commit before potential Door refactor
This commit is contained in:
+12
-113
@@ -61,9 +61,8 @@ makePathUsing :: (Set.Set EdgeObstacle -> Bool) -> Point2 -> Point2 -> World ->
|
||||
makePathUsing t s e w = do
|
||||
na <- walkableNodeNear w s
|
||||
nb <- walkableNodeNear w e
|
||||
let f i = getes i
|
||||
h i = distance (getn nb) (getn i)
|
||||
(na :) . snd <$> AS.aStarAssoc f h (== nb) na
|
||||
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)
|
||||
@@ -71,22 +70,11 @@ makePathUsing t s e w = do
|
||||
getes i = mapMaybe g $ w ^?! cWorld . incGraph . ix i
|
||||
getn i = w ^?! cWorld . incNode . ix i
|
||||
|
||||
-- sp na nb . second _peDist . efilter (^. _3 . to t) $ w ^. cWorld . pathGraph
|
||||
|
||||
makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
|
||||
makePathBetween = makePathUsing $ not . pathEdgeObstructed
|
||||
|
||||
--pathEdgeObstructed' :: PathEdge -> Bool
|
||||
--pathEdgeObstructed' pe =
|
||||
-- any
|
||||
-- (`Set.member` _peObstacles pe)
|
||||
-- [DoorObstacle, BlockObstacle, ChasmObstacle]
|
||||
|
||||
pathEdgeObstructed :: Set.Set EdgeObstacle -> Bool
|
||||
pathEdgeObstructed pe =
|
||||
any
|
||||
(`Set.member` pe)
|
||||
[DoorObstacle, BlockObstacle, ChasmObstacle]
|
||||
pathEdgeObstructed pe = any (`Set.member` pe) [DoorObstacle, BlockObstacle, ChasmObstacle]
|
||||
|
||||
walkableNodeNear :: World -> Point2 -> Maybe Int
|
||||
{-# INLINE walkableNodeNear #-}
|
||||
@@ -94,12 +82,6 @@ walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
|
||||
where
|
||||
nodesNear = zonesExtract (w ^. incNodeZoning) . snailAround $ zoneOfPoint pnZoneSize p
|
||||
|
||||
--walkableNodeNear' :: World -> Point2 -> Maybe Int
|
||||
--{-# INLINE walkableNodeNear' #-}
|
||||
--walkableNodeNear' w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
|
||||
-- where
|
||||
-- nodesNear = zonesExtract (w ^. pnZoning) . snailAround $ zoneOfPoint pnZoneSize p
|
||||
|
||||
snailAround :: Int2 -> [Int2]
|
||||
snailAround x = (x +) <$> smallSnailInt2
|
||||
|
||||
@@ -110,64 +92,11 @@ smallSnailInt2 =
|
||||
[V2 x y | x <- [-2 .. 2], y <- [-2 .. 2]]
|
||||
|
||||
makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
|
||||
--makePathBetweenPs a b w = mapMaybe (lab $ w ^. cWorld . pathGraph) <$> makePathBetween a b w
|
||||
makePathBetweenPs a b w = mapMaybe (flip getNodePos w) <$> makePathBetween a b w
|
||||
|
||||
--bfsNodePoints :: Int -> World -> [Point2]
|
||||
--bfsNodePoints n w = mapMaybe (lab g) $ bfs n g
|
||||
-- where
|
||||
-- g = w ^. cWorld . pathGraph
|
||||
makePathBetweenPs a b w = traverse (flip 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) . reverse)
|
||||
-- =<< (makePathBetweenPs a b w <&> (<> [b]))
|
||||
(find (flip (isWalkable a) w) . reverse)
|
||||
=<< makePathBetweenPs a b w -- <&> (<> [b]))
|
||||
|
||||
------ continues a walk from a list of points, without repetitions
|
||||
------ supposes that the list is non-empty
|
||||
--randomGraphWalk :: RandomGen g => [Int] -> Gr a b -> State g [Int]
|
||||
--randomGraphWalk (n:ns) g = do
|
||||
-- next' <- randomGraphStepRestricted n ns g
|
||||
-- case next' of
|
||||
-- Nothing -> return (n:ns)
|
||||
-- Just n' -> randomGraphWalk (n':n:ns) g
|
||||
--randomGraphWalk _ _ = error "Trying to walk in an empty list"
|
||||
--
|
||||
--randomPointXStepsFrom :: Int -> Point2 -> World -> Point2
|
||||
--randomPointXStepsFrom i p w =
|
||||
-- let g = _pathGraph w
|
||||
-- ns = labNodes g
|
||||
-- mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns
|
||||
-- in case mp of
|
||||
-- Nothing -> p
|
||||
-- Just (n,_) -> fromJust
|
||||
-- $ lab g (last $ take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w)
|
||||
--
|
||||
--randomPointsXStepsFrom :: Int -> Point2 -> World -> [Point2]
|
||||
--randomPointsXStepsFrom i p w =
|
||||
-- let g = _pathGraph w
|
||||
-- ns = labNodes g
|
||||
-- mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns
|
||||
-- in case mp of
|
||||
-- Nothing -> [p]
|
||||
-- Just (n,_) -> mapMaybe (lab g) (take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w)
|
||||
--
|
||||
--randomGraphStep :: RandomGen g => Int -> Gr a b -> State g (Maybe Int)
|
||||
--randomGraphStep n g =
|
||||
-- do let ns = neighbors g n
|
||||
-- i <- state $ randomR (0,length ns - 1)
|
||||
-- case ns of [] -> return Nothing
|
||||
-- _ -> return $ Just $ ns !! i
|
||||
--randomGraphStepRestricted :: RandomGen g => Int -> [Int] -> Gr a b -> State g (Maybe Int)
|
||||
--randomGraphStepRestricted n notns g = do
|
||||
-- let ns = neighbors g n \\ notns
|
||||
-- i <- state $ randomR (0,length ns - 1)
|
||||
-- case ns of
|
||||
-- [] -> return Nothing
|
||||
-- _ -> return $ Just $ ns !! i
|
||||
--
|
||||
pointTowardsImpulse a b w = (find $ flip (isWalkable a) w) =<< makePathBetweenPs b a w
|
||||
|
||||
pairsToIncGraph ::
|
||||
Set.Set (Point2, Point2) ->
|
||||
@@ -178,49 +107,19 @@ pairsToIncGraph ::
|
||||
pairsToIncGraph pairs =
|
||||
( inodes
|
||||
, incgraph
|
||||
, Set.toList pairs & each . each %~ (\i -> pstons ^?! ix i . _head)
|
||||
, Set.toList pairs & each . each %~ (\i -> pToNode ^?! ix i)
|
||||
)
|
||||
where
|
||||
incgraph = V.generate (length im) (\i -> im ^?! ix i)
|
||||
im = IM.fromListWith (<>) . fmap toedge $ Set.toList pairs
|
||||
incgraph = V.generate (length im) (im IM.!)
|
||||
im = IM.fromListWith (++) . fmap toedge $ Set.toList pairs
|
||||
toedge (x, y) =
|
||||
( pstons ^?! ix x . _head
|
||||
, [(pstons ^?! ix y . _head, SimpleEdge (distance x y) mempty)]
|
||||
( pToNode ^?! ix x
|
||||
, [(pToNode ^?! ix y, SimpleEdge (distance x y) mempty)]
|
||||
)
|
||||
pstons = IM.invertIntMap . IM.fromList $ zip [0 ..] ps
|
||||
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
|
||||
|
||||
--pairsToGraph ::
|
||||
-- Set.Set (Point2, Point2) ->
|
||||
-- (Map (V2 Point2) PathEdgeNodes, Gr Point2 PathEdge)
|
||||
--pairsToGraph pairs = addEdges nodemap gr pairs
|
||||
-- where
|
||||
-- (nodemap, _, gr) = addNodes $ Set.toList $ Set.map fst pairs <> Set.map snd pairs
|
||||
|
||||
--addNodes :: [Point2] -> (Map Point2 Int, Int, Gr Point2 PathEdge)
|
||||
--addNodes = foldl' f (mempty, 0, Data.Graph.Inductive.empty)
|
||||
-- where
|
||||
-- f (nodemap, i, gr) p = case nodemap M.!? p of
|
||||
-- Just _ -> (nodemap, i, gr)
|
||||
-- Nothing -> (nodemap & at p ?~ i, i + 1, insNode (i, p) gr)
|
||||
|
||||
--addEdges ::
|
||||
-- Map Point2 Int ->
|
||||
-- Gr Point2 PathEdge ->
|
||||
-- Set.Set (Point2, Point2) ->
|
||||
-- (Map (V2 Point2) PathEdgeNodes, Gr Point2 PathEdge)
|
||||
--addEdges nodemap gr = foldl' f (mempty, gr)
|
||||
-- where
|
||||
-- f (edgemap, gr') (a, b) =
|
||||
-- ( M.insert (V2 a b) theedgedata edgemap
|
||||
-- , insEdge theedgetup gr'
|
||||
-- )
|
||||
-- where
|
||||
-- theedgetup = (g a, g b, PathEdge a b (dist a b) mempty)
|
||||
-- theedgedata = PathEdgeNodes (g a) (g b) (PathEdge a b (dist a b) mempty)
|
||||
-- g a = nodemap M.! a
|
||||
|
||||
obstructPathsCrossing ::
|
||||
EdgeObstacle ->
|
||||
Point2 ->
|
||||
|
||||
Reference in New Issue
Block a user