Add pathing infrastructure

src/Dodge/Data.hs

@@ -150,7 +150,8 @@ data World = World
     , _clickMousePos        :: Point2
     , _pathGraph            :: PathGraph
     , _pathGraphP           :: S.Set (Point2,Point2)
-    , _phZoning             :: Zoning [] (Int,Point2)
+    , _pnZoning             :: Zoning [] (Int,Point2)
+    , _peZoning             :: Zoning [] (Int,Int,PathEdge)
     , _hud                  :: HUD
     , _lightSources         :: IM.IntMap LightSource
     , _tempLightSources     :: [TempLightSource]

src/Dodge/Data/PathGraph.hs

@@ -4,9 +4,24 @@ 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 Float
+    { _pgGraph      :: Gr Point2 PathEdge
-    , _pgNodeMap    :: NodeMap Point2
+    , _pgNodeMap    :: Map Point2 Int
+    , _pgNodeCount  :: Int
+    , _pgEdgeMap    :: Map (V2 Point2) Int2
     }
+data PathEdge = PathEdge
+    {_peStart :: Point2
+    ,_peEnd   :: Point2
+    ,_peObstacles :: Set.Set EdgeObstacle
+    }
+  deriving (Eq,Ord,Show)
+data EdgeObstacle
+    = BlockObstacle
+    | DoorObstacle
+    | AutoDoorObstacle
+  deriving (Eq,Ord,Show,Bounded,Enum)
 
 makeLenses ''PathGraph

src/Dodge/Data/Room.hs

@@ -61,12 +61,12 @@ data RPLinkStatus
     | UnusedLink  { _rplsType :: S.Set RoomLinkType }
     | NotLink
   deriving (Eq,Ord,Show)
-data PathEdge = PathFromEdge CardinalPoint Int
+data PathFromEdge = PathFromEdge CardinalPoint Int
   deriving (Eq,Ord,Show)
 
 data RoomPosType 
-    = RoomPosOnPath {_onPathEdges :: S.Set PathEdge}
+    = RoomPosOnPath {_onPathFromEdges :: S.Set PathFromEdge}
-    | RoomPosOffPath {_offPathEdges :: S.Set PathEdge}
+    | RoomPosOffPath {_offPathFromEdges :: S.Set PathFromEdge}
     | RoomPosExLink
     | RoomPosLab Int
   deriving (Eq,Ord,Show)

src/Dodge/Default/World.hs

@@ -4,6 +4,7 @@ import Dodge.Zone.Size
 import Dodge.Zone.Object
 import Dodge.Base
 import Geometry.Vector3D
+import Geometry.Zone
 --import Dodge.Config.KeyConfig
 --import Dodge.Menu
 --import Picture
@@ -73,9 +74,10 @@ defaultWorld = World
     --, _savedWorlds = M.empty
 --    , _menuLayers = []
     , _clickMousePos = V2 0 0
-    , _pathGraph = PathGraph Data.Graph.Inductive.Graph.empty new
+    , _pathGraph = PathGraph Data.Graph.Inductive.Graph.empty mempty 0 mempty
     , _pathGraphP   = mempty
-    , _phZoning     = Zoning mempty phZoneSize (zonePos snd)
+    , _pnZoning     = Zoning mempty pnZoneSize (zonePos snd)
+    , _peZoning     = Zoning mempty pnZoneSize (\x (_,_,PathEdge p q _) -> zoneOfSeg x p q)
     , _hud = HUD
         { _hudElement = DisplayInventory NoSubInventory
         , _carteCenter = V2 0 0

src/Dodge/Floor.hs

@@ -41,9 +41,9 @@ initialAnoTree :: Annotation
 initialAnoTree = OnwardList 
         $ intersperse (AnTree corDoor)
     [ IntAnno $ AnTree . startRoom
+    , AnRoom $ roomCCrits 10
     , AnRoom $ return airlock0
     , AnRoom slowDoorRoom
---    , AnRoom $ roomCCrits 10
     , AnTree firstBreather
 --    , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
 --    ]

src/Dodge/Layout.hs

@@ -22,7 +22,7 @@ import qualified IntMapHelp as IM
 import Tile
 import RandomHelp
 
-import Data.Graph.Inductive (labNodes)
+import Data.Graph.Inductive (labNodes,labEdges)
 import Data.List (nubBy)
 import Data.Traversable
 import Control.Lens
@@ -46,8 +46,10 @@ generateLevelFromRoomList gr' w = initWallZoning
         , _pathGraph    = path
         , _pathGraphP   = pairPath
         }
-        & phZoning   %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+        & pnZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
-            (labNodes (_pgGraph path))
+            (labNodes (_pgGraph path)))
+        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+            (labEdges (_pgGraph path)))
   where
     path = pairsToGraph'' pairPath
     pairPath = foldMap _rmPath rs

src/Dodge/Path.hs

@@ -9,6 +9,7 @@ module Dodge.Path
     , walkableNodeNear
     , nodesNearL
     , getNodePos
+    , addObstacleCrossing'
     ) where
 import Dodge.Data
 import Dodge.Base.Collide
@@ -21,7 +22,10 @@ import Data.Maybe
 import Data.List
 --import qualified Data.IntMap.Strict as IM
 import Data.Graph.Inductive hiding ((&))
+import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.Map (Map)
+import qualified Data.Map.Strict as M
 import qualified Streaming.Prelude as S
 import StreamingHelp
 --import Data.Graph.Inductive.PatriciaTree
@@ -34,7 +38,10 @@ makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
 makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
     (na,_) <- walkableNodeNear a w
     (nb,_) <- walkableNodeNear b w
-    sp na nb (_pgGraph $ _pathGraph w)
+    sp na nb (second pathDist $ _pgGraph $ _pathGraph w)
+
+pathDist :: PathEdge -> Float
+pathDist pe = dist (_peStart pe) (_peEnd pe)
 
 walkableNodeNear :: Point2 -> World -> Maybe (Int,Point2)
 {-# INLINE walkableNodeNear #-}
@@ -43,7 +50,7 @@ walkableNodeNear p w = minStreamOn (dist p . snd)
 
 nodesNear :: Point2 -> World -> StreamOf (Int,Point2)
 {-# INLINE nodesNear #-}
-nodesNear = aroundPoint _phZoning
+nodesNear = aroundPoint _pnZoning
 
 nodesNearL :: Point2 -> World -> [(Int,Point2)]
 nodesNearL p = runIdentity . S.toList_ . nodesNear p
@@ -99,18 +106,45 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a
 --
 
 pairsToGraph'' :: Set.Set (Point2,Point2) -> PathGraph
-pairsToGraph'' = uncurry PathGraph . pairsToGraph' dist
+pairsToGraph'' pairset = PathGraph gr' nodemap ncount edgemap
-
-pairsToGraph' :: Ord a => (a -> a -> b) -> Set.Set (a,a) -> (Gr a b, NodeMap a)
-pairsToGraph' f pairset = ngr'
   where
-    nodeset = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
+    (gr,nodemap,ncount) = insertNodes pairset
-    getnode nodeset' (x,y) = Set.insert x $ Set.insert y nodeset'
+    (gr',edgemap) = insertEdges toPathEdge pairset gr nodemap
-    ngr = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,new) id nodeset
+    
-    ngr' = runIdentity $ S.fold_ insertedge ngr id $ S.each pairset
+
-    insertedge (gr,nm) (x,y) = (insMapEdge nm (x,y,f x y) gr, nm)
+toPathEdge :: Point2 -> Point2 -> PathEdge
-    insertnode (gr,nm) n = fstsnd $ insMapNode nm n gr
+toPathEdge sp' ep = PathEdge sp' ep mempty
-    fstsnd (a,b,_) = (a,b)
+
+insertEdges :: (Point2 -> Point2 -> b) 
+    -> Set (Point2,Point2) -> Gr Point2 b -> Map Point2 Int -> (Gr Point2 b,Map (V2 Point2) Int2)
+insertEdges efunc pairset gr nm = runIdentity $ S.fold_ insertedge (gr,mempty) id $ (S.each pairset)
+  where
+    insertedge (gr',em) (a,b) = (insEdge (f a,f b,efunc a b) gr'
+        , M.insert (V2 a b) (V2 (f a) (f b)) em)
+    f a = nm M.! a
+
+insertNodes :: Set (Point2,Point2) -> (Gr Point2 b, Map Point2 Int, Int)
+insertNodes pairset = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,mempty,0) id nodestream
+  where
+    nodestream :: StreamOf Point2
+    nodestream = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
+    getnode strm (x,y) = Set.insert x $ Set.insert y strm
+    insertnode :: (Gr Point2 b,Map Point2 Int,Int) -> Point2 -> (Gr Point2 b,Map Point2 Int,Int)
+    insertnode (gr,nm,i) n = case M.lookup n nm of
+        Nothing -> (insNode (j,n) gr, M.insert n j nm, j)
+        Just _  -> (gr,nm,i)
+      where
+        j = i + 1
+--pairsToGraph' :: (Ord a) => (a -> a -> b) -> Set (a,a) -> (Gr a b, Map a Int, Map (V2 a) Int2)
+--pairsToGraph' f pairset = ngr'
+--  where
+--    nodeset = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
+--    getnode nodeset' (x,y) = Set.insert x $ Set.insert y nodeset'
+--    ngr = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,new) id nodeset
+--    ngr' = runIdentity $ S.fold_ insertedge ngr id $ S.each pairset
+--    insertedge (gr,nm) (x,y) = (insMapEdge nm (x,y,f x y) gr, nm)
+--    insertnode (gr,nm) n = fstsnd $ insMapNode nm n gr
+--    fstsnd (a,b,_) = (a,b)
 
 pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
 pairsToGraph f pairs = undir
@@ -120,6 +154,26 @@ pairsToGraph f pairs = undir
     nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
     pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
 
+--findEdgesCrossing :: Point2 -> Point2 -> Gr Point2 PathEdge -> 
+--
+addObstacleCrossing :: World -> EdgeObstacle -> Point2 -> Point2 
+    -> Gr Point2 PathEdge
+    -> Gr Point2 PathEdge
+addObstacleCrossing w eo a b gr = runIdentity $ S.fold_ updateedge gr id paths
+  where
+    updateedge gr' (xi,yi,PathEdge x y obs) = insEdge (xi,yi,PathEdge x y (Set.insert eo obs))
+        $ delEdge (xi,yi) gr'
+    paths = S.filter f $ nearSeg _peZoning a b w
+    f (_,_,PathEdge x y _) = isJust $ intersectSegSeg x y a b
+
+addObstacleCrossing' :: EdgeObstacle -> Point2 -> Point2 
+    -> World
+    -> World
+addObstacleCrossing' eo a b w = w & pathGraph . pgGraph %~ addObstacleCrossing w eo a b
+  where
+    paths = S.filter f $ nearSeg _peZoning a b w
+    f (_,_,PathEdge x y _) = isJust $ intersectSegSeg x y a b
+
 removePathsCrossing :: Point2 -> Point2 -> World -> World
 removePathsCrossing a b w = w
 --    & pathGraph . pgGraph %~ deleteEdges
@@ -130,7 +184,7 @@ removePathsCrossing a b w = w
 --        (labNodes newGraph)
   where
     thegr = _pgGraph (_pathGraph w)
-    ns = nearSeg _phZoning a b w
+    ns = nearSeg _pnZoning a b w
     pairs = S.filter testEdge $ S.for ns (nodePairs thegr)
     testEdge ((_,p),(_,q)) = isJust $ intersectSegSeg a b p q
     deleteEdges gr = runIdentity $ S.fold_ deleteEdge gr id pairs

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -55,7 +55,7 @@ addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon"
         
 placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World)
 placeBlock poly bl wl w 
-    = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
+    = (0, foldr (uncurry (addObstacleCrossing' BlockObstacle)) wWithBlock pairs)
 --    = (0, wWithBlock)
   where 
     pairs = loopPairs poly

src/Dodge/PlacementSpot.hs

@@ -3,8 +3,8 @@ module Dodge.PlacementSpot
     ( atFstLnkOut
     , rpIsOnPath
     , rpIsOffPath
-    , rpOffPathEdge
+    , rpOffPathFromEdge
-    , rpOnPathEdge
+    , rpOnPathFromEdge
     , useUnusedLnk
     , psRandRanges
     , useRoomPosCond
@@ -82,16 +82,16 @@ rpIsOffPath = any f . _rpType
   where
     f RoomPosOffPath {} = True
     f _ = False
-rpOffPathEdge :: PathEdge -> RoomPos -> Bool
+rpOffPathFromEdge :: PathFromEdge -> RoomPos -> Bool
-rpOffPathEdge pe = any f . _rpType
+rpOffPathFromEdge pe = any f . _rpType
   where
-    f rt = maybe False (pe `elem`) (rt ^? offPathEdges) 
+    f rt = maybe False (pe `elem`) (rt ^? offPathFromEdges) 
 
 -- test whether a roomPos is on the path with a given from edge value
-rpOnPathEdge :: PathEdge -> RoomPos -> Bool
+rpOnPathFromEdge :: PathFromEdge -> RoomPos -> Bool
-rpOnPathEdge pe = any f . _rpType
+rpOnPathFromEdge pe = any f . _rpType
   where
-    f rt = maybe False (pe `elem`) (rt ^? onPathEdges) 
+    f rt = maybe False (pe `elem`) (rt ^? onPathFromEdges) 
 
 resetPLUse :: PlacementSpot -> PlacementSpot
 resetPLUse (PSPos f g fallback) = PSPos f' g fallback

src/Dodge/Render/ShapePicture.hs

@@ -34,6 +34,7 @@ import qualified Data.Set as Set
 import Control.Lens
 import Data.Maybe
 import qualified Streaming.Prelude as S
+import qualified Data.Graph.Inductive as FGL
 
 -- TODO only filter out shapes outside the range of the furthest shown light source
 worldSPic :: Configuration -> World -> SPic
@@ -110,7 +111,7 @@ debugDraw' cfig w bl = case bl of
     Cr_status               -> Right $ drawCrInfo cfig w
     Mouse_position          -> Right $ drawMousePosition cfig w
     Walls_info              -> Right $ drawWlIDs cfig w
-    Pathing                 -> Right $ drawPathing w
+    Pathing                 -> Right $ drawPathing cfig w
     Show_nodes_near_select  -> Right $ drawNodesNearSelect w
 
 drawCreatureDisplayTexts :: World -> Picture
@@ -118,7 +119,7 @@ drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
 
 drawNodesNearSelect :: World -> Picture
 drawNodesNearSelect w = setLayer DebugLayer $
-     runIdentity (S.foldMap_ (drawZone phZoneSize) (zoneAroundPoint phZoneSize sp))
+     runIdentity (S.foldMap_ (drawZone pnZoneSize) (zoneAroundPoint pnZoneSize sp))
     <> color red (foldMap (drawCross . snd) $ nodesNearL sp w)
     <> color green (drawCross sp)
     <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w)
@@ -264,9 +265,19 @@ drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
       where
         p = worldPosToScreen w $ 0.5 *.* uncurry (+.+) (_wlLine wl)
 
-drawPathing :: World -> Picture
+edgeToPic :: [Point2] -> PathEdge -> Picture
-drawPathing w = setLayer DebugLayer $ 
+edgeToPic poly pe
-        (color green . pictures . map (thickLine 5 . tflat2) $ graphToEdges gr)
+    | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
+    | null $ _peObstacles pe 
+                = color green $ arrow sp ep
+    | otherwise = color red   $ arrow sp ep
+  where
+    sp = _peStart pe
+    ep = _peEnd pe
+
+drawPathing :: Configuration -> World -> Picture
+drawPathing cfig w = setLayer DebugLayer $ 
+        (foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) $ FGL.labEdges gr)
         --(color green . pictures . Set.map (thickLine 5 . tflat2) $ _pathGraphP w)
         <> concatMap dispInc (graphToIncidence gr)
   where

src/Dodge/Room/Pillar.hs

@@ -70,7 +70,7 @@ roomPillarsSquare = do
   where
     makepill edge = sps (rprBool $ \rp _ -> t edge rp) smallPillar
     t edge rp = any (f edge) (_rpType rp) && _rpPlacementUse rp == 0
-    f edge rpt = maybe False (PathFromEdge edge 0 `S.member`) (rpt ^? offPathEdges)
+    f edge rpt = maybe False (PathFromEdge edge 0 `S.member`) (rpt ^? offPathFromEdges)
 
 roomPillarsPassage :: RandomGen g => State g Room
 roomPillarsPassage = do

src/Dodge/Room/Tanks.hs

@@ -42,7 +42,7 @@ randEdgeTank = do
                 <>  horPipe 80 0 (70 *.* cardVec edge))))
                     -- 70 is a guess, the true value depends on the distance to the wall
         & plSpot .~ rprBool (\rp _ -> _rpPlacementUse rp == 0
-                && rpOffPathEdge (PathFromEdge edge 0) rp)
+                && rpOffPathFromEdge (PathFromEdge edge 0) rp)
 
 randEdgeTanks :: RandomGen g => Int -> State g [Placement]
 randEdgeTanks i = do
@@ -54,7 +54,7 @@ randEdgeTanks i = do
                 <>  horPipe 80 0 (70 *.* cardVec edge))))
                     -- 70 is a guess, the true value depends on the distance to the wall
         & plSpot .~ rprBool (\rp _ -> _rpPlacementUse rp == 0
-                && rpOffPathEdge (PathFromEdge edge 0) rp)
+                && rpOffPathFromEdge (PathFromEdge edge 0) rp)
 
 tanksPipesRoom :: RandomGen g => State g Room
 tanksPipesRoom = do

src/Dodge/Zone/Size.hs

@@ -1,7 +1,7 @@
 module Dodge.Zone.Size where
 
-phZoneSize :: Float
+pnZoneSize :: Float
-phZoneSize = 100
+pnZoneSize = 100
 
 wlZoneSize :: Float
 wlZoneSize = 50