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

Correct walkableNodeNear

Browse Source
This commit is contained in:
justin
2022-07-02 12:14:31 +01:00
parent 8dc7682327
commit 75a98a572f
2 changed files with 13 additions and 8 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Path.hs
+11 -6
View File
@@ -6,6 +6,7 @@ module Dodge.Path
, removePathsCrossing , removePathsCrossing
, pairsToGraph , pairsToGraph
, getNodePos , getNodePos
, walkableNodeNear
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Base.Collide import Dodge.Base.Collide
@@ -31,16 +32,20 @@ getNodePos i w = _pathGraph w `lab` i
makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int] makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w) makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
na <- walkableNodeNear a na <- walkableNodeNear w a
nb <- walkableNodeNear b nb <- walkableNodeNear w b
sp na nb (second _peDist (_pathGraph w)) sp na nb (second _peDist (_pathGraph w))
where where
--nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w) --nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
nodesNear p = runIdentity . S.toList_ $ nearPoint _pnZoning p w -- nodesNear p = runIdentity . S.toList_ $ nearPoint _pnZoning p w
walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p -- walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
--walkableNodeNear :: Point2 -> World -> Maybe Point2 walkableNodeNear :: World -> Point2 -> Maybe Int
--walkableNodeNear p w = insideCirc {-# INLINE walkableNodeNear #-}
walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
where
--nodesNear = runIdentity . S.toList_ $ nearPoint _pnZoning p w
nodesNear = runIdentity . S.toList_ $ aroundPoint _pnZoning p w
makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2] makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween a b w makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween a b w
src/Dodge/Render/ShapePicture.hs
+2 -2
View File
@@ -122,8 +122,8 @@ drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
drawPathBetween :: World -> Picture drawPathBetween :: World -> Picture
drawPathBetween w = setLayer DebugLayer drawPathBetween w = setLayer DebugLayer
$ color yellow (foldMap (arrowPath . mapMaybe nodepos) nodelist) $ color yellow (foldMap (arrowPath . mapMaybe nodepos) nodelist)
<> foldMap (color green . arrow sp) (nodepos =<< nodelist ^? _Just . ix 0) <> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp)
<> foldMap (color cyan . flip arrow ep) (nodepos =<< lastOf traverse =<< nodelist ^? _Just) <> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep)
where where
nodepos = (`getNodePos` w) nodepos = (`getNodePos` w)
nodelist = makePathBetween sp ep w nodelist = makePathBetween sp ep w