Store paths crossing block walls in block

2022-07-02 15:31:27 +01:00
parent 75a98a572f
commit 3952ec6315
8 changed files with 52 additions and 17 deletions
@@ -151,6 +151,7 @@ data World = World
    , _pathGraph            :: Gr Point2 PathEdge
    , _pathGraphP           :: S.Set (Point2,Point2)
    , _pnZoning             :: Zoning [] (Int,Point2)
+    , _peZoning             :: Zoning [] (Int,Int,PathEdge)
    , _hud                  :: HUD
    , _lightSources         :: IM.IntMap LightSource
    , _tempLightSources     :: [TempLightSource]
@@ -951,6 +952,7 @@ data Block = Block
    , _blDir        :: Float
    , _blDraw       :: Block -> SPic
    , _blDeath      :: Block -> World -> World
+    , _blPaths      :: [(Int,Int,PathEdge)]
    }
 data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady
  deriving (Eq,Ord,Show)
@@ -27,3 +27,4 @@ data EdgeObstacle
  deriving (Eq,Ord,Show,Bounded,Enum)

 makeLenses ''PathGraph
+makeLenses ''PathEdge
@@ -15,6 +15,7 @@ defaultBlock = Block
    , _blDraw      = const mempty
    , _blDeath     = makeBlockDebris
    , _blObstructs = []
+    , _blPaths      = []
    }
 defaultDirtBlock :: Block
 defaultDirtBlock = defaultBlock & blHP .~ 50
@@ -77,6 +77,7 @@ defaultWorld = World
    , _pathGraph = Data.Graph.Inductive.Graph.empty
    , _pathGraphP   = mempty
    , _pnZoning     = Zoning mempty wlZoneSize (zonePos snd)
+    , _peZoning     = Zoning mempty wlZoneSize (\x (_,_,e) -> zoneOfSeg x (_peStart e) (_peEnd e))
    , _hud = HUD
        { _hudElement = DisplayInventory NoSubInventory
        , _carteCenter = V2 0 0
@@ -48,10 +48,10 @@ generateLevelFromRoomList gr' w = initWallZoning
        }
        & pnZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
            (labNodes path))
--        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
--            (labEdges (_pgGraph path)))
+        & peZoning   %~ (\zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
+            (labEdges path))
  where
-    path = pairsToGraph pairPath
+    (_,path) = pairsToGraph pairPath
    pairPath = foldMap _rmPath rs
    rs = map doRoomShift $ IM.elems rs'
    rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w
@@ -3,7 +3,8 @@ module Dodge.Path
    ( pointTowardsImpulse
    , makePathBetween
    , makePathBetweenPs
-    , removePathsCrossing
+--    , removePathsCrossing
+    , obstructPathsCrossing
    , pairsToGraph
    , getNodePos
    , walkableNodeNear
@@ -96,7 +97,7 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a
 --        [] -> return Nothing
 --        _  -> return $ Just $ ns !! i
 --
-pairsToGraph :: Set.Set (Point2,Point2) -> Gr Point2 PathEdge
+pairsToGraph :: Set.Set (Point2,Point2) -> (Map (V2 Point2) (Int,Int,PathEdge),Gr Point2 PathEdge)
 pairsToGraph pairs = addEdges nodemap gr $ S.each pairs
  where
    (nodemap,_,gr) = addNodes $ S.map fst (S.each pairs) <> S.map snd (S.each pairs)
@@ -110,12 +111,29 @@ addNodes = runIdentity . S.fold_ f (mempty,0,Data.Graph.Inductive.empty) id
    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 -> StreamOf (Point2,Point2) -> Gr Point2 PathEdge
-addEdges nodemap gr = runIdentity . S.fold_ f gr id
+addEdges :: Map Point2 Int -> Gr Point2 PathEdge -> StreamOf (Point2,Point2) 
+    -> (Map (V2 Point2) (Int,Int,PathEdge) , Gr Point2 PathEdge)
+addEdges nodemap gr = runIdentity . S.fold_ f (mempty,gr) id
  where
-    f gr' (a,b) = insEdge (g a,g b,PathEdge a b (dist a b) mempty) gr'
+    f (edgemap,gr') (a,b) = (M.insert (V2 a b) theedge edgemap
+        , insEdge theedge gr'
+        )
+      where
+        theedge = (g a,g b,PathEdge a b (dist a b) mempty)
    g a = nodemap M.! a

+obstructPathsCrossing :: Point2 -> Point2 -> World -> ( World, [(Int,Int,PathEdge)])
+obstructPathsCrossing sp ep w = 
+    ( w & pathGraph %~ updateedges
+    , runIdentity $ S.toList_ edges
+    )
+  where
+    edges = S.filter edgecrosses $ nearSeg _peZoning sp ep w
+    edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp ep (_peStart pe) (_peEnd pe)
+    updateedges gr = runIdentity $ S.fold_ updateedge gr id edges
+    updateedge gr (x,y,pe) 
+        = insEdge (x,y,pe & peObstacles . at BlockObstacle .~ Just ()) $ delEdge (x,y) gr
+
 removePathsCrossing :: Point2 -> Point2 -> World -> World
 removePathsCrossing a b w = w
 --    & pathGraph  .~ newGraph 
@@ -120,9 +120,10 @@ evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
    (evaluatedType, g) = runState rgen (_randGen w)

 placeWallPoly :: [Point2] -> Wall -> World -> World
-placeWallPoly ps wl = rmCrossPaths . over walls (placeWalls ps wl)
-  where
-    rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
+placeWallPoly ps wl = -- rmCrossPaths . 
+    over walls (placeWalls ps wl)
+--  where
+--    rmCrossPaths w = foldr (uncurry obstructPathsCrossing) w $ loopPairs ps

 placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
 placeWalls qs wl wls = foldl' (addPane wl) wls pairs
@@ -25,13 +25,13 @@ plBlock
    -> (Int,World)
 plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon"
 plBlock (p:ps) bl wl w = (,) blid $ w
-    & flip (foldr insertWall) wls
    & blocks . at blid ?~ bl 
        { _blID = blid
        , _blWallIDs = IS.fromList is
        , _blShadows = []
        , _blFootprint = p:ps
        }
+    & insertWalls blid wls
  where 
    blid = IM.newKey $ _blocks w
    lns = zip (p:ps) (ps ++ [p])
@@ -51,7 +51,8 @@ plLineBlock
    -> World 
    -> (Int, World)
 plLineBlock basePane blwidth a b gw = ( 0 
-    , foldr insertWall (insertBlocks gw) listWalls
+--    , foldr insertWall (insertBlocks gw) listWalls
+    , insertBlocks gw
    )
  where 
    depth = blwidth
@@ -65,13 +66,17 @@ plLineBlock basePane blwidth a b gw = ( 0
    linesAt p = loopPairs $ cornersAt p
    wlid = IM.newKey $ _walls gw
    blid = IM.newKey $ _blocks gw
-    insertBlock (i,p) = over blocks $ IM.insert (i+blid) Block 
+    insertBlock (i,p) = 
+        insertWalls (i + blid) (makeWallAt p i)
+        . (over blocks $ IM.insert (i+blid) Block 
        { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
        , _blHP = 1000, _blShadows = shadowsAt i
        , _blDir = 0    -- THIS IS NOT SENSIBLE. TODO rethink block positioning
        , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
        , _blObstructs = []
+        , _blPaths = []
        , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris}
+        )
    insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs
    ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3]
    visibilityAt i 
@@ -91,6 +96,12 @@ plLineBlock basePane blwidth a b gw = ( 0
        }
    listWalls = concat $ zipWith makeWallAt blockCenPs is

-insertWall :: Wall -> World -> World
-insertWall wl = (walls . at (_wlID wl) ?~ wl)
--    . uncurry (addObstacleCrossing' BlockObstacle) (_wlLine wl)
+-- | Must be done after inserting the block
+insertWalls :: Int -> [Wall] -> World -> World
+insertWalls blid wls w = w' & blocks . ix blid . blPaths .~ concat paths
+  where
+    (w',paths) = mapAccumR (flip insertWall) w wls
+
+insertWall :: Wall -> World -> (World,[(Int,Int,PathEdge)])
+insertWall wl = uncurry obstructPathsCrossing (_wlLine wl)
+    . (walls . at (_wlID wl) ?~ wl)