{-# 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