30 lines
1.0 KiB
Haskell
30 lines
1.0 KiB
Haskell
module Dodge.LevelGen.Pathing
|
|
where
|
|
import Geometry
|
|
|
|
import Control.Lens
|
|
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
|
|
import Data.Maybe
|
|
import Data.List
|
|
|
|
import qualified Data.IntMap as IM
|
|
import Data.Graph.Inductive hiding ((&))
|
|
import Data.Graph.Inductive.NodeMap
|
|
|
|
pairsToGraph :: (Ord a, Eq a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b
|
|
pairsToGraph f pairs = let nodes = nub (map fst pairs ++ map snd pairs)
|
|
pairs' = map (\(x,y)->(x,y,f x y)) pairs
|
|
in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes >> insMapEdgesM pairs'
|
|
|
|
removePathsCrossing :: Point2 -> Point2 -> World -> World
|
|
removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg'
|
|
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
|
|
w
|
|
where pg' = filter (not . isJust . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
|
|
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
|
|
newGraph = pairsToGraph dist pg'
|
|
|