--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Geometry.Polygon.Inflate
-- Copyright   :  (C) David Himmelstrup
-- License     :  see the LICENSE file
-- Maintainer  :  David Himmelstrup
--------------------------------------------------------------------------------
module Data.Geometry.Polygon.Inflate
  ( Arc(..)
  , inflate
  ) where

import           Algorithms.Geometry.SSSP   (SSSP, sssp, triangulate)
import           Control.Lens
import           Data.Ext
import           Data.Geometry.Line         (lineThrough)
import           Data.Geometry.LineSegment  (LineSegment (LineSegment, OpenLineSegment),
                                             interpolate, sqSegmentLength)
import           Data.Geometry.Point
import           Data.Geometry.Polygon.Core
import           Data.Intersection          (IsIntersectableWith (intersect),
                                             NoIntersection (NoIntersection))
import           Data.Maybe                 (catMaybes)
import qualified Data.Vector                as V
import qualified Data.Vector.Circular       as CV
import qualified Data.Vector.Unboxed        as VU
import           Data.Vinyl                 (Rec (RNil, (:&)))
import           Data.Vinyl.CoRec           (Handler (H), match)

----------------------------------------------------
-- Implementation

-- | Points annotated with an 'Arc' indicate that the edge from this point to
--   the next should not be a straight line but instead an arc with a given center
--   and a given border edge.
data Arc r = Arc
  { Arc r -> Point 2 r
arcCenter :: Point 2 r
  , Arc r -> (Point 2 r, Point 2 r)
arcEdge   :: (Point 2 r, Point 2 r)
  } deriving (Int -> Arc r -> ShowS
[Arc r] -> ShowS
Arc r -> String
(Int -> Arc r -> ShowS)
-> (Arc r -> String) -> ([Arc r] -> ShowS) -> Show (Arc r)
forall r. Show r => Int -> Arc r -> ShowS
forall r. Show r => [Arc r] -> ShowS
forall r. Show r => Arc r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Arc r] -> ShowS
$cshowList :: forall r. Show r => [Arc r] -> ShowS
show :: Arc r -> String
$cshow :: forall r. Show r => Arc r -> String
showsPrec :: Int -> Arc r -> ShowS
$cshowsPrec :: forall r. Show r => Int -> Arc r -> ShowS
Show)

type Parent = Int

markParents :: SSSP -> SimplePolygon p r -> SimplePolygon Parent r
markParents :: SSSP -> SimplePolygon p r -> SimplePolygon Int r
markParents SSSP
t SimplePolygon p r
p = CircularVector (Point 2 r :+ Int) -> SimplePolygon Int r
forall r p. CircularVector (Point 2 r :+ p) -> SimplePolygon p r
unsafeFromCircularVector (CircularVector (Point 2 r :+ Int) -> SimplePolygon Int r)
-> CircularVector (Point 2 r :+ Int) -> SimplePolygon Int r
forall a b. (a -> b) -> a -> b
$
  (Int -> (Point 2 r :+ p) -> Point 2 r :+ Int)
-> CircularVector (Point 2 r :+ p)
-> CircularVector (Point 2 r :+ Int)
forall a b. (Int -> a -> b) -> CircularVector a -> CircularVector b
CV.imap (\Int
i (Point 2 r
pt :+ p
_) -> Point 2 r
pt Point 2 r -> Int -> Point 2 r :+ Int
forall core extra. core -> extra -> core :+ extra
:+ SSSP
t SSSP -> Int -> Int
forall a. Unbox a => Vector a -> Int -> a
VU.! Int
i) (SimplePolygon p r
pSimplePolygon p r
-> Getting
     (CircularVector (Point 2 r :+ p))
     (SimplePolygon p r)
     (CircularVector (Point 2 r :+ p))
-> CircularVector (Point 2 r :+ p)
forall s a. s -> Getting a s a -> a
^.Getting
  (CircularVector (Point 2 r :+ p))
  (SimplePolygon p r)
  (CircularVector (Point 2 r :+ p))
forall (t :: PolygonType) p r.
Getter (Polygon t p r) (CircularVector (Point 2 r :+ p))
outerBoundaryVector)

addSteinerPoints :: (Ord r, Fractional r) => SimplePolygon Parent r -> SimplePolygon Parent r
addSteinerPoints :: SimplePolygon Int r -> SimplePolygon Int r
addSteinerPoints SimplePolygon Int r
p = [Point 2 r :+ Int] -> SimplePolygon Int r
forall p r. (Eq r, Num r) => [Point 2 r :+ p] -> SimplePolygon p r
fromPoints ([Point 2 r :+ Int] -> SimplePolygon Int r)
-> [Point 2 r :+ Int] -> SimplePolygon Int r
forall a b. (a -> b) -> a -> b
$ (Int -> [Point 2 r :+ Int]) -> [Int] -> [Point 2 r :+ Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int -> [Point 2 r :+ Int]
worker [Int
0 .. SimplePolygon Int r -> Int
forall (t :: PolygonType) p r. Polygon t p r -> Int
size SimplePolygon Int r
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  where
    worker :: Int -> [Point 2 r :+ Int]
worker Int
nth = do
        Point 2 r :+ Int
pointA (Point 2 r :+ Int) -> [Point 2 r :+ Int] -> [Point 2 r :+ Int]
forall a. a -> [a] -> [a]
: [Maybe (Point 2 r :+ Int)] -> [Point 2 r :+ Int]
forall a. [Maybe a] -> [a]
catMaybes [ (Point 2 r -> Int -> Point 2 r :+ Int
forall core extra. core -> extra -> core :+ extra
:+ Int -> Int
parent Int
nth)     (Point 2 r -> Point 2 r :+ Int)
-> Maybe (Point 2 r) -> Maybe (Point 2 r :+ Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LineSegment 2 Int r -> Line 2 r -> Maybe (Point 2 r)
forall g h a (d :: Nat) p r.
(IsIntersectableWith g h,
 IntersectionOf g h ~ '[NoIntersection, a, LineSegment d p r]) =>
g -> h -> Maybe a
getIntersection LineSegment 2 Int r
edge Line 2 r
lineA
                           , (Point 2 r -> Int -> Point 2 r :+ Int
forall core extra. core -> extra -> core :+ extra
:+ Int -> Int
parent (Int
nthInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) (Point 2 r -> Point 2 r :+ Int)
-> Maybe (Point 2 r) -> Maybe (Point 2 r :+ Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LineSegment 2 Int r -> Line 2 r -> Maybe (Point 2 r)
forall g h a (d :: Nat) p r.
(IsIntersectableWith g h,
 IntersectionOf g h ~ '[NoIntersection, a, LineSegment d p r]) =>
g -> h -> Maybe a
getIntersection LineSegment 2 Int r
edge Line 2 r
lineB ]
      where
        fetch :: Int -> Point 2 r :+ Int
fetch Int
idx = SimplePolygon Int r
p SimplePolygon Int r
-> Getting
     (Point 2 r :+ Int) (SimplePolygon Int r) (Point 2 r :+ Int)
-> Point 2 r :+ Int
forall s a. s -> Getting a s a -> a
^. Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex Int
idx
        pointA :: Point 2 r :+ Int
pointA = Int -> Point 2 r :+ Int
fetch Int
nth
        pointB :: Point 2 r :+ Int
pointB = Int -> Point 2 r :+ Int
fetch (Int
nthInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        parent :: Int -> Int
parent Int
idx = SimplePolygon Int r
pSimplePolygon Int r -> Getting Int (SimplePolygon Int r) Int -> Int
forall s a. s -> Getting a s a -> a
^.Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex Int
idx(((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
 -> SimplePolygon Int r -> Const Int (SimplePolygon Int r))
-> ((Int -> Const Int Int)
    -> (Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> Getting Int (SimplePolygon Int r) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int)
-> (Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra
        lineA :: Line 2 r
lineA = Point 2 r -> Point 2 r -> Line 2 r
forall r (d :: Nat).
(Num r, Arity d) =>
Point d r -> Point d r -> Line d r
lineThrough
          (Int -> Point 2 r :+ Int
fetch (Int -> Int
parent Int
nth) (Point 2 r :+ Int)
-> Getting (Point 2 r) (Point 2 r :+ Int) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ Int) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
          (Int -> Point 2 r :+ Int
fetch (Int -> Int
parent (Int -> Int
parent Int
nth)) (Point 2 r :+ Int)
-> Getting (Point 2 r) (Point 2 r :+ Int) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ Int) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
        lineB :: Line 2 r
lineB = Point 2 r -> Point 2 r -> Line 2 r
forall r (d :: Nat).
(Num r, Arity d) =>
Point d r -> Point d r -> Line d r
lineThrough
          (Int -> Point 2 r :+ Int
fetch (Int -> Int
parent (Int
nthInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) (Point 2 r :+ Int)
-> Getting (Point 2 r) (Point 2 r :+ Int) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ Int) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
          (Int -> Point 2 r :+ Int
fetch (Int -> Int
parent (Int -> Int
parent (Int
nthInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))) (Point 2 r :+ Int)
-> Getting (Point 2 r) (Point 2 r :+ Int) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^. Getting (Point 2 r) (Point 2 r :+ Int) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
        edge :: LineSegment 2 Int r
edge = (Point 2 r :+ Int) -> (Point 2 r :+ Int) -> LineSegment 2 Int r
forall (d :: Nat) r p.
(Point d r :+ p) -> (Point d r :+ p) -> LineSegment d p r
OpenLineSegment Point 2 r :+ Int
pointA Point 2 r :+ Int
pointB
        getIntersection :: g -> h -> Maybe a
getIntersection g
segment h
line =
          CoRec Identity '[NoIntersection, a, LineSegment d p r]
-> Handlers '[NoIntersection, a, LineSegment d p r] (Maybe a)
-> Maybe a
forall (ts :: [*]) b. CoRec Identity ts -> Handlers ts b -> b
match (g
segment g -> h -> Intersection g h
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
`intersect` h
line) (
               (NoIntersection -> Maybe a) -> Handler (Maybe a) NoIntersection
forall b a. (a -> b) -> Handler b a
H (\NoIntersection
NoIntersection -> Maybe a
forall a. Maybe a
Nothing)
            Handler (Maybe a) NoIntersection
-> Rec (Handler (Maybe a)) '[a, LineSegment d p r]
-> Handlers '[NoIntersection, a, LineSegment d p r] (Maybe a)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& (a -> Maybe a) -> Handler (Maybe a) a
forall b a. (a -> b) -> Handler b a
H (\a
pt -> a -> Maybe a
forall a. a -> Maybe a
Just a
pt)
            Handler (Maybe a) a
-> Rec (Handler (Maybe a)) '[LineSegment d p r]
-> Rec (Handler (Maybe a)) '[a, LineSegment d p r]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& (LineSegment d p r -> Maybe a)
-> Handler (Maybe a) (LineSegment d p r)
forall b a. (a -> b) -> Handler b a
H (\LineSegment{} -> Maybe a
forall a. Maybe a
Nothing)
            Handler (Maybe a) (LineSegment d p r)
-> Rec (Handler (Maybe a)) '[]
-> Rec (Handler (Maybe a)) '[LineSegment d p r]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec (Handler (Maybe a)) '[]
forall u (a :: u -> *). Rec a '[]
RNil
          )

annotate :: (Real r, Fractional r) =>
  Double -> SimplePolygon Parent r -> SimplePolygon Parent r -> SimplePolygon (Arc r) r
annotate :: Double
-> SimplePolygon Int r
-> SimplePolygon Int r
-> SimplePolygon (Arc r) r
annotate Double
t SimplePolygon Int r
original SimplePolygon Int r
p = CircularVector (Point 2 r :+ Arc r) -> SimplePolygon (Arc r) r
forall r p. CircularVector (Point 2 r :+ p) -> SimplePolygon p r
unsafeFromCircularVector (CircularVector (Point 2 r :+ Arc r) -> SimplePolygon (Arc r) r)
-> CircularVector (Point 2 r :+ Arc r) -> SimplePolygon (Arc r) r
forall a b. (a -> b) -> a -> b
$
    (Int -> (Point 2 r :+ Int) -> Point 2 r :+ Arc r)
-> CircularVector (Point 2 r :+ Int)
-> CircularVector (Point 2 r :+ Arc r)
forall a b. (Int -> a -> b) -> CircularVector a -> CircularVector b
CV.imap Int -> (Point 2 r :+ Int) -> Point 2 r :+ Arc r
ann (SimplePolygon Int r
pSimplePolygon Int r
-> Getting
     (CircularVector (Point 2 r :+ Int))
     (SimplePolygon Int r)
     (CircularVector (Point 2 r :+ Int))
-> CircularVector (Point 2 r :+ Int)
forall s a. s -> Getting a s a -> a
^.Getting
  (CircularVector (Point 2 r :+ Int))
  (SimplePolygon Int r)
  (CircularVector (Point 2 r :+ Int))
forall (t :: PolygonType) p r.
Getter (Polygon t p r) (CircularVector (Point 2 r :+ p))
outerBoundaryVector)
    -- CV.generate (size p) ann -- Use this when circular-vector-0.1.2 is out.
  where
    nO :: Int
nO = SimplePolygon Int r -> Int
forall (t :: PolygonType) p r. Polygon t p r -> Int
size SimplePolygon Int r
original
    visibleDist :: Double
visibleDist = Vector Double -> Double
forall a. Ord a => Vector a -> a
V.maximum Vector Double
distanceTreeSum Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
t
    parent :: Int -> Int
parent Int
idx = SimplePolygon Int r
pSimplePolygon Int r -> Getting Int (SimplePolygon Int r) Int -> Int
forall s a. s -> Getting a s a -> a
^.Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex Int
idx(((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
 -> SimplePolygon Int r -> Const Int (SimplePolygon Int r))
-> ((Int -> Const Int Int)
    -> (Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> Getting Int (SimplePolygon Int r) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int)
-> (Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra
    parentO :: Int -> Int
parentO Int
idx = SimplePolygon Int r
originalSimplePolygon Int r -> Getting Int (SimplePolygon Int r) Int -> Int
forall s a. s -> Getting a s a -> a
^.Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex Int
idx(((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
 -> SimplePolygon Int r -> Const Int (SimplePolygon Int r))
-> ((Int -> Const Int Int)
    -> (Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> Getting Int (SimplePolygon Int r) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Int -> Const Int Int)
-> (Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra
    getLineO :: Int -> LineSegment 2 Int r
getLineO Int
idx = (Point 2 r :+ Int) -> (Point 2 r :+ Int) -> LineSegment 2 Int r
forall (d :: Nat) r p.
(Point d r :+ p) -> (Point d r :+ p) -> LineSegment d p r
OpenLineSegment (SimplePolygon Int r
original SimplePolygon Int r
-> Getting
     (Point 2 r :+ Int) (SimplePolygon Int r) (Point 2 r :+ Int)
-> Point 2 r :+ Int
forall s a. s -> Getting a s a -> a
^. Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex (Int -> Int
parentO Int
idx)) (SimplePolygon Int r
original SimplePolygon Int r
-> Getting
     (Point 2 r :+ Int) (SimplePolygon Int r) (Point 2 r :+ Int)
-> Point 2 r :+ Int
forall s a. s -> Getting a s a -> a
^. Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex Int
idx)
    getLineP :: Int -> LineSegment 2 Int r
getLineP Int
idx = (Point 2 r :+ Int) -> (Point 2 r :+ Int) -> LineSegment 2 Int r
forall (d :: Nat) r p.
(Point d r :+ p) -> (Point d r :+ p) -> LineSegment d p r
OpenLineSegment (SimplePolygon Int r
original SimplePolygon Int r
-> Getting
     (Point 2 r :+ Int) (SimplePolygon Int r) (Point 2 r :+ Int)
-> Point 2 r :+ Int
forall s a. s -> Getting a s a -> a
^. Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex (Int -> Int
parent Int
idx)) (SimplePolygon Int r
p SimplePolygon Int r
-> Getting
     (Point 2 r :+ Int) (SimplePolygon Int r) (Point 2 r :+ Int)
-> Point 2 r :+ Int
forall s a. s -> Getting a s a -> a
^. Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex Int
idx)

    ann :: Int -> (Point 2 r :+ Int) -> Point 2 r :+ Arc r
ann Int
i Point 2 r :+ Int
_ =
        Int -> Point 2 r
ptLocation Int
i Point 2 r -> Arc r -> Point 2 r :+ Arc r
forall core extra. core -> extra -> core :+ extra
:+ Arc r
arc
      where
        start :: Point 2 r
start = SimplePolygon Int r
p SimplePolygon Int r
-> Getting (Point 2 r) (SimplePolygon Int r) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^. Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex Int
i (((Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int))
 -> SimplePolygon Int r -> Const (Point 2 r) (SimplePolygon Int r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int))
-> Getting (Point 2 r) (SimplePolygon Int r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
        end :: Point 2 r
end = SimplePolygon Int r
p SimplePolygon Int r
-> Getting (Point 2 r) (SimplePolygon Int r) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^. Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (((Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int))
 -> SimplePolygon Int r -> Const (Point 2 r) (SimplePolygon Int r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int))
-> Getting (Point 2 r) (SimplePolygon Int r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
        arc :: Arc r
arc = Arc :: forall r. Point 2 r -> (Point 2 r, Point 2 r) -> Arc r
Arc
          { arcCenter :: Point 2 r
arcCenter =
              SimplePolygon Int r
original SimplePolygon Int r
-> Getting (Point 2 r) (SimplePolygon Int r) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^. Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex (SimplePolygon Int r -> Int -> Int -> Int
forall r. SimplePolygon Int r -> Int -> Int -> Int
commonParent SimplePolygon Int r
original (Int -> Int
parent Int
i) (Int -> Int
parent (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))) (((Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int))
 -> SimplePolygon Int r -> Const (Point 2 r) (SimplePolygon Int r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int))
-> Getting (Point 2 r) (SimplePolygon Int r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
          , arcEdge :: (Point 2 r, Point 2 r)
arcEdge   = (Point 2 r
start, Point 2 r
end) }

    -- Array of locations for points in the original polygon.
    ptLocationsO :: Vector (Point 2 r)
ptLocationsO = Int -> (Int -> Point 2 r) -> Vector (Point 2 r)
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
nO Int -> Point 2 r
ptLocationO
    ptLocationO :: Int -> Point 2 r
ptLocationO Int
0 = (SimplePolygon Int r
original SimplePolygon Int r
-> Getting (Point 2 r) (SimplePolygon Int r) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^. Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex Int
0 (((Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int))
 -> SimplePolygon Int r -> Const (Point 2 r) (SimplePolygon Int r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int))
-> Getting (Point 2 r) (SimplePolygon Int r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
    ptLocationO Int
i
      | r
frac r -> r -> Bool
forall a. Ord a => a -> a -> Bool
<= r
0 = Vector (Point 2 r)
ptLocationsO Vector (Point 2 r) -> Int -> Point 2 r
forall a. Vector a -> Int -> a
V.! (Int -> Int
parentO Int
i)
      | r
frac r -> r -> Bool
forall a. Ord a => a -> a -> Bool
>= r
1 = (SimplePolygon Int r
original SimplePolygon Int r
-> Getting (Point 2 r) (SimplePolygon Int r) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^. Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex Int
i (((Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int))
 -> SimplePolygon Int r -> Const (Point 2 r) (SimplePolygon Int r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int))
-> Getting (Point 2 r) (SimplePolygon Int r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
      | Bool
otherwise = (r -> LineSegment 2 Int r -> Point 2 r
forall r (d :: Nat) p.
(Fractional r, Arity d) =>
r -> LineSegment d p r -> Point d r
interpolate r
frac (Int -> LineSegment 2 Int r
getLineO Int
i))
      where
        dParent :: Double
dParent = Vector Double
distanceTreeSum Vector Double -> Int -> Double
forall a. Vector a -> Int -> a
V.! Int -> Int
parentO Int
i
        dSelf :: Double
dSelf   = Vector Double
oDistance Vector Double -> Int -> Double
forall a. Unbox a => Vector a -> Int -> a
VU.! Int
i
        frac :: r
frac    = Double -> r
forall a b. (Real a, Fractional b) => a -> b
realToFrac ((Double
visibleDist Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
dParent) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
dSelf)

    -- Locations for original points and steiner points.
    ptLocation :: Int -> Point 2 r
ptLocation Int
0 = (SimplePolygon Int r
p SimplePolygon Int r
-> Getting (Point 2 r) (SimplePolygon Int r) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^. Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex Int
0 (((Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int))
 -> SimplePolygon Int r -> Const (Point 2 r) (SimplePolygon Int r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int))
-> Getting (Point 2 r) (SimplePolygon Int r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
    ptLocation Int
i
      | r
frac r -> r -> Bool
forall a. Ord a => a -> a -> Bool
<= r
0 = Vector (Point 2 r)
ptLocationsO Vector (Point 2 r) -> Int -> Point 2 r
forall a. Vector a -> Int -> a
V.! (Int -> Int
parent Int
i)
      | r
frac r -> r -> Bool
forall a. Ord a => a -> a -> Bool
>= r
1 = (SimplePolygon Int r
p SimplePolygon Int r
-> Getting (Point 2 r) (SimplePolygon Int r) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^. Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex Int
i (((Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int))
 -> SimplePolygon Int r -> Const (Point 2 r) (SimplePolygon Int r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int))
-> Getting (Point 2 r) (SimplePolygon Int r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ Int) -> Const (Point 2 r) (Point 2 r :+ Int)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
      | Bool
otherwise = (r -> LineSegment 2 Int r -> Point 2 r
forall r (d :: Nat) p.
(Fractional r, Arity d) =>
r -> LineSegment d p r -> Point d r
interpolate r
frac (Int -> LineSegment 2 Int r
getLineP Int
i))
      where
        dParent :: Double
dParent = Vector Double
distanceTreeSum Vector Double -> Int -> Double
forall a. Vector a -> Int -> a
V.! Int -> Int
parent Int
i
        dSelf :: Double
dSelf   = Double -> Double
forall a. Floating a => a -> a
sqrt (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ r -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (r -> Double) -> r -> Double
forall a b. (a -> b) -> a -> b
$ LineSegment 2 Int r -> r
forall (d :: Nat) r p. (Arity d, Num r) => LineSegment d p r -> r
sqSegmentLength (LineSegment 2 Int r -> r) -> LineSegment 2 Int r -> r
forall a b. (a -> b) -> a -> b
$ Int -> LineSegment 2 Int r
getLineP Int
i
        frac :: r
frac    = Double -> r
forall a b. (Real a, Fractional b) => a -> b
realToFrac ((Double
visibleDist Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
dParent) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
dSelf)

    oDistance :: Vector Double
oDistance = Int -> (Int -> Double) -> Vector Double
forall a. Unbox a => Int -> (Int -> a) -> Vector a
VU.generate Int
nO ((Int -> Double) -> Vector Double)
-> (Int -> Double) -> Vector Double
forall a b. (a -> b) -> a -> b
$ \Int
i ->
      case Int
i of
        Int
0 -> Double
0
        Int
_ -> Double -> Double
forall a. Floating a => a -> a
sqrt (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ r -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (r -> Double) -> r -> Double
forall a b. (a -> b) -> a -> b
$ LineSegment 2 Int r -> r
forall (d :: Nat) r p. (Arity d, Num r) => LineSegment d p r -> r
sqSegmentLength (LineSegment 2 Int r -> r) -> LineSegment 2 Int r -> r
forall a b. (a -> b) -> a -> b
$ Int -> LineSegment 2 Int r
getLineO Int
i
    distanceTreeSum :: Vector Double
distanceTreeSum = Int -> (Int -> Double) -> Vector Double
forall a. Int -> (Int -> a) -> Vector a
V.generate Int
nO ((Int -> Double) -> Vector Double)
-> (Int -> Double) -> Vector Double
forall a b. (a -> b) -> a -> b
$ \Int
i ->
      case Int
i of
        Int
0 -> Double
0
        Int
_ -> Vector Double
distanceTreeSum Vector Double -> Int -> Double
forall a. Vector a -> Int -> a
V.! Int -> Int
parentO Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Vector Double
oDistance Vector Double -> Int -> Double
forall a. Unbox a => Vector a -> Int -> a
VU.! Int
i

commonParent :: SimplePolygon Parent r -> Int -> Int -> Int
commonParent :: SimplePolygon Int r -> Int -> Int -> Int
commonParent SimplePolygon Int r
p Int
a Int
b = Int -> [Int] -> [Int] -> Int
forall t. Eq t => t -> [t] -> [t] -> t
worker Int
0 (Int -> [Int]
parents Int
a) (Int -> [Int]
parents Int
b)
  where
    worker :: t -> [t] -> [t] -> t
worker t
_shared (t
x:[t]
xs) (t
y:[t]
ys)
      | t
x t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
y = t -> [t] -> [t] -> t
worker t
x [t]
xs [t]
ys
    worker t
shared [t]
_ [t]
_ = t
shared
    parents :: Int -> [Int]
parents Int
0 = [Int
0]
    parents Int
i = Int -> [Int]
parents (SimplePolygon Int r
p SimplePolygon Int r -> Getting Int (SimplePolygon Int r) Int -> Int
forall s a. s -> Getting a s a -> a
^. Int -> Getter (SimplePolygon Int r) (Point 2 r :+ Int)
forall (t :: PolygonType) p r.
Int -> Getter (Polygon t p r) (Point 2 r :+ p)
outerVertex Int
i (((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
 -> SimplePolygon Int r -> Const Int (SimplePolygon Int r))
-> ((Int -> Const Int Int)
    -> (Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> Getting Int (SimplePolygon Int r) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int)
-> (Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
i]

-- | \( O(n \log n) \)
inflate :: (Real r, Fractional r) => Double -> SimplePolygon () r -> SimplePolygon (Arc r) r
inflate :: Double -> SimplePolygon () r -> SimplePolygon (Arc r) r
inflate Double
t SimplePolygon () r
p = Double
-> SimplePolygon Int r
-> SimplePolygon Int r
-> SimplePolygon (Arc r) r
forall r.
(Real r, Fractional r) =>
Double
-> SimplePolygon Int r
-> SimplePolygon Int r
-> SimplePolygon (Arc r) r
annotate Double
t SimplePolygon Int r
marked SimplePolygon Int r
steiner
  where
    marked :: SimplePolygon Int r
marked = SSSP -> SimplePolygon () r -> SimplePolygon Int r
forall p r. SSSP -> SimplePolygon p r -> SimplePolygon Int r
markParents (PlaneGraph Any Int PolygonEdgeType PolygonFaceData r -> SSSP
forall k r (s :: k).
(Ord r, Fractional r) =>
PlaneGraph s Int PolygonEdgeType PolygonFaceData r -> SSSP
sssp (SimplePolygon () r
-> PlaneGraph Any Int PolygonEdgeType PolygonFaceData r
forall k r p (s :: k).
(Ord r, Fractional r) =>
SimplePolygon p r
-> PlaneGraph s Int PolygonEdgeType PolygonFaceData r
triangulate SimplePolygon () r
p)) SimplePolygon () r
p
    steiner :: SimplePolygon Int r
steiner = SimplePolygon Int r -> SimplePolygon Int r
forall r.
(Ord r, Fractional r) =>
SimplePolygon Int r -> SimplePolygon Int r
addSteinerPoints SimplePolygon Int r
marked