32 lines
1.1 KiB
Haskell
32 lines
1.1 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Room.Path (linksDAGToPath,addNodesCrossing) where
|
|
|
|
import Linear
|
|
import Data.Maybe
|
|
import Control.Lens
|
|
import Data.Function (on)
|
|
import Data.List
|
|
import qualified Data.Set as S
|
|
import Dodge.Data.GenWorld
|
|
import Geometry
|
|
|
|
linksDAGToPath :: Foldable f => [RoomLink] -> f (Point2, Point2) -> S.Set (Point2, Point2)
|
|
linksDAGToPath lnks xs
|
|
| null xs = foldMap doublePairSet $ ys & each %~ (, centroid ys)
|
|
| otherwise = subpth <> foldMap (linkClosest . (^. rlPos)) lnks
|
|
where
|
|
ys = lnks <&> _rlPos
|
|
subpth = foldMap doublePairSet xs
|
|
linkClosest p = doublePairSet (p, minimumBy (compare `on` dist p) $ S.map fst subpth)
|
|
|
|
addNodesCrossing :: (Point2,Point2) -> S.Set (Point2,Point2) -> S.Set (Point2,Point2)
|
|
addNodesCrossing (x,y) = g . foldMap f
|
|
where
|
|
g (xs,m) = h xs <> m
|
|
f (a,b) = fromMaybe (mempty,S.singleton (a,b)) $ do
|
|
i <- intersectSegSeg x y a b
|
|
return (S.singleton i, S.fromList [(a,i),(i,b)])
|
|
h is | null is = mempty
|
|
| otherwise = let js = sortOn (distance x) $ S.toList is
|
|
in S.fromList . zip js $ tail js
|