53 lines
1.7 KiB
Haskell
53 lines
1.7 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Dodge.Room.Path (
|
|
linksDAGToPath,
|
|
addNodesCrossing,
|
|
addNodesCrossingCirc,
|
|
) where
|
|
|
|
import Control.Applicative
|
|
import Control.Lens
|
|
import Data.Function (on)
|
|
import Data.List
|
|
import Data.Maybe
|
|
import qualified Data.Set as S
|
|
import Dodge.Data.GenWorld
|
|
import Geometry
|
|
import Linear
|
|
|
|
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
|
|
|
|
addNodesCrossingCirc :: Point2 -> Float -> S.Set (Point2, Point2) -> S.Set (Point2, Point2)
|
|
addNodesCrossingCirc c r = g . foldMap f
|
|
where
|
|
g (xs, m) = h xs <> m
|
|
f (a, b) = fromMaybe (mempty, S.singleton (a, b)) $ do
|
|
let (ma,mb) = intersectCircSeg c r a b
|
|
i <- ma <|> mb
|
|
return (S.singleton i, S.fromList [(a, i), (i, b)])
|
|
h is
|
|
| (j:js) <- sortOn (\x -> argV (x - c)) $ S.toList is
|
|
= S.fromList . zip js $ (tail js <> [j])
|
|
| otherwise = mempty
|