Allow creatures to path around chasms

src/Dodge/Base/Collide.hs

@@ -37,6 +37,7 @@ module Dodge.Base.Collide (
     collide3,
 ) where
 
+import Data.Monoid
 import Control.Lens
 import Control.Monad
 import qualified Data.IntSet as IS
@@ -326,10 +327,13 @@ hasLOSIndirect p1 p2 =
 
 isWalkable :: Point2 -> Point2 -> World -> Bool
 {-# INLINE isWalkable #-}
-isWalkable p1 p2 =
+isWalkable p1 p2 w =
-    not
+    (not
         . collidePointTestFilter (not . (^?! wlPathable)) p1 p2
-        . wlsNearSeg p1 p2
+        . wlsNearSeg p1 p2 $ w)
+    && not (getAny $ foldMap f (w ^. cWorld . chasms))
+  where
+    f = foldMap (Any . isJust . uncurry (intersectSegSeg p1 p2)) . loopPairs
 
 canSee :: Int -> Int -> World -> Bool
 {-# INLINE canSee #-}

src/Dodge/Data/PathGraph.hs.orig

@@ -1,36 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE StrictData #-}
-module Dodge.Data.PathGraph where
-import Geometry.Data
-import Control.Lens
-import Data.Graph.Inductive
-import qualified Data.Set as Set
-import Data.Map.Strict (Map)
-data PathGraph = PathGraph
-    { _pgGraph      :: Gr Point2 PathEdge
-    , _pgNodeMap    :: Map Point2 Int
-    , _pgNodeCount  :: Int
-    , _pgEdgeMap    :: Map (V2 Point2) (Int,Int,PathEdge)
-    }
-data PathEdge = PathEdge
-    {_peStart :: Point2
-    ,_peEnd   :: Point2
-<<<<<<< HEAD
-=======
-    ,_peDist  :: Float
->>>>>>> efficientRuntime
-    ,_peObstacles :: Set.Set EdgeObstacle
-    }
-  deriving (Eq,Ord,Show)
-data EdgeObstacle
-    = BlockObstacle
-    | DoorObstacle
-    | AutoDoorObstacle
-    | WallObstacle
-  deriving (Eq,Ord,Show,Bounded,Enum)
-
-makeLenses ''PathGraph
-<<<<<<< HEAD
-=======
-makeLenses ''PathEdge
->>>>>>> efficientRuntime

src/Dodge/Path.hs

@@ -5,6 +5,7 @@ module Dodge.Path (
     makePathBetweenPs,
     --    , removePathsCrossing
     obstructPathsCrossing,
+    obstructPathsCrossing',
     pairsToGraph,
     getNodePos,
     walkableNodeNear,
@@ -44,6 +45,7 @@ makePathBetween = makePathUsing $ not . pathEdgeObstructed
 
 pathEdgeObstructed :: PathEdge -> Bool
 pathEdgeObstructed pe = DoorObstacle `Set.member` obs || BlockObstacle `Set.member` obs
+    || ChasmObstacle `Set.member` obs
   where
     obs = _peObstacles pe
 
@@ -158,6 +160,17 @@ obstructPathsCrossing obstacletype sp' ep w =
     updateedge gr (PathEdgeNodes x y pe) =
         insEdge (x, y, pe & peObstacles . at obstacletype ?~ ()) $ delEdge (x, y) gr
 
+obstructPathsCrossing' :: EdgeObstacle -> Point2 -> Point2 -> World 
+    -> World
+obstructPathsCrossing' obstacletype sp' ep w =
+     w & cWorld . pathGraph %~ updateedges
+  where
+    es = Set.filter edgecrosses $ pesNearSeg sp' ep w
+    edgecrosses (PathEdgeNodes _ _ pe) = isJust $ intersectSegSeg sp' ep (_peStart pe) (_peEnd pe)
+    updateedges gr = foldl' updateedge gr es
+    updateedge gr (PathEdgeNodes x y pe) =
+        insEdge (x, y, pe & peObstacles . at obstacletype ?~ ()) $ delEdge (x, y) gr
+
 snapToGrid :: Set (Point2,Point2) -> Set (Point2, Point2)
 snapToGrid = Set.map (over each (fmap (fromIntegral . f)))
   where

src/Dodge/Placement/PlaceSpot.hs

@@ -148,11 +148,7 @@ placeSpotID rid ps pt w = case pt of
     PutNothing -> (0, w)
     PutID i -> (i, w)
     PutWorldUpdate f -> (0, w & f rid ps)
-    PutChasm ps' ->
+    PutChasm ps' -> (0, placeChasm w rid ps' $ map doShift ps')
-        ( 0
-        , w & gwWorld . cWorld . chasms .:~ map doShift ps'
-            & genRooms . ix rid . rmPos %~ filter (\rp -> not $ pointInPoly (_rpPos rp) ps')
-        )
     PutLabel{} -> (0, w)
   where
     p@(V2 px py) = _psPos ps
@@ -160,6 +156,15 @@ placeSpotID rid ps pt w = case pt of
     rot = _psRot ps
     doShift = shiftPointBy (p, rot)
 
+placeChasm :: GenWorld -> Int -> [Point2] -> [Point2] -> GenWorld
+placeChasm gw rid ps shiftps =
+    gw & gwWorld . cWorld . chasms .:~ shiftps
+        & genRooms . ix rid . rmPos %~ filter (\rp -> not $ pointInPoly (_rpPos rp) ps)
+        & gwWorld %~ f
+  where
+    f w = foldl' g w (loopPairs shiftps)
+    g w (x,y) = fst $ obstructPathsCrossing ChasmObstacle x y w
+
 --evaluateRandPS
 --    :: Int -> State StdGen PSType -> PlacementSpot -> GenWorld -> (Int, GenWorld)
 --evaluateRandPS rid rgen ps w = placeSpotID rid ps evaluatedType