{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--------------------------------------------------------------------------------
module Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer
  (
    -- * Divide & Conqueror Delaunay Triangulation
    delaunayTriangulation
  ) where

import           Algorithms.Geometry.ConvexHull.GrahamScan       as GS
import           Algorithms.Geometry.DelaunayTriangulation.Types
import           Control.Lens
import           Control.Monad.Reader
import           Control.Monad.State
import           Data.BinaryTree
import qualified Data.CircularList                               as CL
import qualified Data.CircularList.Util                          as CU
import           Data.Ext
import qualified Data.Foldable                                   as F
import           Data.Function                                   (on)
import           Data.Geometry                                   hiding (rotateTo)
import           Data.Geometry.Ball                              (disk, insideBall)
import           Data.Geometry.Polygon.Convex                    (ConvexPolygon (..), simplePolygon)
import qualified Data.Geometry.Polygon.Convex                    as Convex
import qualified Data.IntMap.Strict                              as IM
import qualified Data.List                                       as L
import qualified Data.List.NonEmpty                              as NonEmpty
import qualified Data.Map                                        as M
import           Data.Maybe                                      (fromJust, fromMaybe)
import           Data.Measured.Size
import qualified Data.Vector                                     as V
import qualified Data.Vector.Circular.Util                       as CV

-------------------------------------------------------------------------------
-- * Divide & Conqueror Delaunay Triangulation
--
-- Implementation of the Divide & Conqueror algorithm as described in:
--
-- Two Algorithms for Constructing a Delaunay Triangulation
-- Lee and Schachter
-- International Journal of Computer and Information Sciences, Vol 9, No. 3, 1980
--
-- We store all adjacency lists in clockwise order
--
-- : If v on the convex hull, then its first entry in the adj. lists is its CCW
-- successor (i.e. its predecessor) on the convex hull
--
-- Rotating Right <-> rotate clockwise

-- | Computes the delaunay triangulation of a set of points.
--
-- Running time: \(O(n \log n)\)
-- (note: We use an IntMap in the implementation. So maybe actually \(O(n \log^2 n)\))
--
-- pre: the input is a *SET*, i.e. contains no duplicate points. (If the
-- input does contain duplicate points, the implementation throws them away)
delaunayTriangulation      :: (Ord r, Fractional r)
                           => NonEmpty.NonEmpty (Point 2 r :+ p) -> Triangulation p r
delaunayTriangulation :: NonEmpty (Point 2 r :+ p) -> Triangulation p r
delaunayTriangulation NonEmpty (Point 2 r :+ p)
pts' = Map (Point 2 r) VertexID
-> Vector (Point 2 r :+ p)
-> Vector (CList VertexID)
-> Triangulation p r
forall p r.
Map (Point 2 r) VertexID
-> Vector (Point 2 r :+ p)
-> Vector (CList VertexID)
-> Triangulation p r
Triangulation Map (Point 2 r) VertexID
vtxMap Vector (Point 2 r :+ p)
ptsV Vector (CList VertexID)
adjV
  where
    pts :: NonEmpty (Point 2 r :+ p)
pts    = NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall a b. Eq a => NonEmpty (a :+ b) -> NonEmpty (a :+ b)
nub' (NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p))
-> (NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p))
-> NonEmpty (Point 2 r :+ p)
-> NonEmpty (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NonEmpty.sortBy (Point 2 r -> Point 2 r -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Point 2 r -> Point 2 r -> Ordering)
-> ((Point 2 r :+ p) -> Point 2 r)
-> (Point 2 r :+ p)
-> (Point 2 r :+ p)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((Point 2 r :+ p)
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)) (NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p))
-> NonEmpty (Point 2 r :+ p) -> NonEmpty (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$ NonEmpty (Point 2 r :+ p)
pts'
    ptsV :: Vector (Point 2 r :+ p)
ptsV   = [Point 2 r :+ p] -> Vector (Point 2 r :+ p)
forall a. [a] -> Vector a
V.fromList ([Point 2 r :+ p] -> Vector (Point 2 r :+ p))
-> (NonEmpty (Point 2 r :+ p) -> [Point 2 r :+ p])
-> NonEmpty (Point 2 r :+ p)
-> Vector (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Point 2 r :+ p) -> [Point 2 r :+ p]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (NonEmpty (Point 2 r :+ p) -> Vector (Point 2 r :+ p))
-> NonEmpty (Point 2 r :+ p) -> Vector (Point 2 r :+ p)
forall a b. (a -> b) -> a -> b
$ NonEmpty (Point 2 r :+ p)
pts
    vtxMap :: Map (Point 2 r) VertexID
vtxMap = [(Point 2 r, VertexID)] -> Map (Point 2 r) VertexID
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Point 2 r, VertexID)] -> Map (Point 2 r) VertexID)
-> [(Point 2 r, VertexID)] -> Map (Point 2 r) VertexID
forall a b. (a -> b) -> a -> b
$ [Point 2 r] -> [VertexID] -> [(Point 2 r, VertexID)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Point 2 r :+ p) -> Point 2 r) -> [Point 2 r :+ p] -> [Point 2 r]
forall a b. (a -> b) -> [a] -> [b]
map ((Point 2 r :+ p)
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) ([Point 2 r :+ p] -> [Point 2 r])
-> (Vector (Point 2 r :+ p) -> [Point 2 r :+ p])
-> Vector (Point 2 r :+ p)
-> [Point 2 r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Point 2 r :+ p) -> [Point 2 r :+ p]
forall a. Vector a -> [a]
V.toList (Vector (Point 2 r :+ p) -> [Point 2 r])
-> Vector (Point 2 r :+ p) -> [Point 2 r]
forall a b. (a -> b) -> a -> b
$ Vector (Point 2 r :+ p)
ptsV) [VertexID
0..]

    tr :: BinLeafTree Size (Point 2 r :+ p)
tr     = Elem (Point 2 r :+ p) -> Point 2 r :+ p
forall a. Elem a -> a
_unElem (Elem (Point 2 r :+ p) -> Point 2 r :+ p)
-> BinLeafTree Size (Elem (Point 2 r :+ p))
-> BinLeafTree Size (Point 2 r :+ p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Point 2 r :+ p)
-> BinLeafTree Size (Elem (Point 2 r :+ p))
forall a. NonEmpty a -> BinLeafTree Size (Elem a)
asBalancedBinLeafTree NonEmpty (Point 2 r :+ p)
pts

    (Adj
adj,ConvexPolygon (p :+ VertexID) r
_) = BinLeafTree Size (Point 2 r :+ p)
-> Mapping p r -> (Adj, ConvexPolygon (p :+ VertexID) r)
forall r p.
(Ord r, Fractional r) =>
BinLeafTree Size (Point 2 r :+ p)
-> Mapping p r -> (Adj, ConvexPolygon (p :+ VertexID) r)
delaunayTriangulation' BinLeafTree Size (Point 2 r :+ p)
tr (Map (Point 2 r) VertexID
vtxMap,Vector (Point 2 r :+ p)
ptsV)
    adjV :: Vector (CList VertexID)
adjV    = [CList VertexID] -> Vector (CList VertexID)
forall a. [a] -> Vector a
V.fromList ([CList VertexID] -> Vector (CList VertexID))
-> (Adj -> [CList VertexID]) -> Adj -> Vector (CList VertexID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Adj -> [CList VertexID]
forall a. IntMap a -> [a]
IM.elems (Adj -> Vector (CList VertexID)) -> Adj -> Vector (CList VertexID)
forall a b. (a -> b) -> a -> b
$ Adj
adj



-- : pre: - Input points are sorted lexicographically
delaunayTriangulation' :: (Ord r, Fractional r)
                       => BinLeafTree Size (Point 2 r :+ p)
                       -> Mapping p r
                       -> (Adj, ConvexPolygon (p :+ VertexID) r)
delaunayTriangulation' :: BinLeafTree Size (Point 2 r :+ p)
-> Mapping p r -> (Adj, ConvexPolygon (p :+ VertexID) r)
delaunayTriangulation' BinLeafTree Size (Point 2 r :+ p)
pts mapping' :: Mapping p r
mapping'@(Map (Point 2 r) VertexID
vtxMap,Vector (Point 2 r :+ p)
_)
  | BinLeafTree Size (Point 2 r :+ p) -> Size
forall a. BinLeafTree Size a -> Size
size' BinLeafTree Size (Point 2 r :+ p)
pts Size -> Size -> Bool
forall a. Eq a => a -> a -> Bool
== Size
1 = let (Leaf Point 2 r :+ p
p) = BinLeafTree Size (Point 2 r :+ p)
pts
                         i :: VertexID
i        = Map (Point 2 r) VertexID -> Point 2 r -> VertexID
forall k a. Ord k => Map k a -> k -> a
lookup' Map (Point 2 r) VertexID
vtxMap (Point 2 r :+ p
p(Point 2 r :+ p)
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
                     in (VertexID -> CList VertexID -> Adj
forall a. VertexID -> a -> IntMap a
IM.singleton VertexID
i CList VertexID
forall a. CList a
CL.empty, SimplePolygon (p :+ VertexID) r -> ConvexPolygon (p :+ VertexID) r
forall p r. SimplePolygon p r -> ConvexPolygon p r
ConvexPolygon (SimplePolygon (p :+ VertexID) r
 -> ConvexPolygon (p :+ VertexID) r)
-> SimplePolygon (p :+ VertexID) r
-> ConvexPolygon (p :+ VertexID) r
forall a b. (a -> b) -> a -> b
$ [Point 2 r :+ (p :+ VertexID)] -> SimplePolygon (p :+ VertexID) r
forall r p. [Point 2 r :+ p] -> SimplePolygon p r
unsafeFromPoints [(Point 2 r :+ p) -> VertexID -> Point 2 r :+ (p :+ VertexID)
forall c e e'. (c :+ e) -> e' -> c :+ (e :+ e')
withID Point 2 r :+ p
p VertexID
i])
  | BinLeafTree Size (Point 2 r :+ p) -> Size
forall a. BinLeafTree Size a -> Size
size' BinLeafTree Size (Point 2 r :+ p)
pts Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Size
3 = let pts' :: NonEmpty (Point 2 r :+ (p :+ VertexID))
pts'  = [Point 2 r :+ (p :+ VertexID)]
-> NonEmpty (Point 2 r :+ (p :+ VertexID))
forall a. [a] -> NonEmpty a
NonEmpty.fromList
                               ([Point 2 r :+ (p :+ VertexID)]
 -> NonEmpty (Point 2 r :+ (p :+ VertexID)))
-> (BinLeafTree Size (Point 2 r :+ p)
    -> [Point 2 r :+ (p :+ VertexID)])
-> BinLeafTree Size (Point 2 r :+ p)
-> NonEmpty (Point 2 r :+ (p :+ VertexID))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point 2 r :+ p) -> Point 2 r :+ (p :+ VertexID))
-> [Point 2 r :+ p] -> [Point 2 r :+ (p :+ VertexID)]
forall a b. (a -> b) -> [a] -> [b]
map (\Point 2 r :+ p
p -> (Point 2 r :+ p) -> VertexID -> Point 2 r :+ (p :+ VertexID)
forall c e e'. (c :+ e) -> e' -> c :+ (e :+ e')
withID Point 2 r :+ p
p (Map (Point 2 r) VertexID -> Point 2 r -> VertexID
forall k a. Ord k => Map k a -> k -> a
lookup' Map (Point 2 r) VertexID
vtxMap (Point 2 r :+ p
p(Point 2 r :+ p)
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)))
                               ([Point 2 r :+ p] -> [Point 2 r :+ (p :+ VertexID)])
-> (BinLeafTree Size (Point 2 r :+ p) -> [Point 2 r :+ p])
-> BinLeafTree Size (Point 2 r :+ p)
-> [Point 2 r :+ (p :+ VertexID)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinLeafTree Size (Point 2 r :+ p) -> [Point 2 r :+ p]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (BinLeafTree Size (Point 2 r :+ p)
 -> NonEmpty (Point 2 r :+ (p :+ VertexID)))
-> BinLeafTree Size (Point 2 r :+ p)
-> NonEmpty (Point 2 r :+ (p :+ VertexID))
forall a b. (a -> b) -> a -> b
$ BinLeafTree Size (Point 2 r :+ p)
pts
                         ch :: ConvexPolygon (p :+ VertexID) r
ch    = NonEmpty (Point 2 r :+ (p :+ VertexID))
-> ConvexPolygon (p :+ VertexID) r
forall r p.
(Ord r, Num r) =>
NonEmpty (Point 2 r :+ p) -> ConvexPolygon p r
GS.convexHull NonEmpty (Point 2 r :+ (p :+ VertexID))
pts'
                     in (Mapping p r -> ConvexPolygon (p :+ VertexID) r -> Adj
forall r p q.
Ord r =>
Mapping p r -> ConvexPolygon (p :+ q) r -> Adj
fromHull Mapping p r
mapping' ConvexPolygon (p :+ VertexID) r
ch, ConvexPolygon (p :+ VertexID) r
ch)
  | Bool
otherwise      = let (Node BinLeafTree Size (Point 2 r :+ p)
lt Size
_ BinLeafTree Size (Point 2 r :+ p)
rt) = BinLeafTree Size (Point 2 r :+ p)
pts
                         (Adj
ld,ConvexPolygon (p :+ VertexID) r
lch)       = BinLeafTree Size (Point 2 r :+ p)
-> Mapping p r -> (Adj, ConvexPolygon (p :+ VertexID) r)
forall r p.
(Ord r, Fractional r) =>
BinLeafTree Size (Point 2 r :+ p)
-> Mapping p r -> (Adj, ConvexPolygon (p :+ VertexID) r)
delaunayTriangulation' BinLeafTree Size (Point 2 r :+ p)
lt Mapping p r
mapping'
                         (Adj
rd,ConvexPolygon (p :+ VertexID) r
rch)       = BinLeafTree Size (Point 2 r :+ p)
-> Mapping p r -> (Adj, ConvexPolygon (p :+ VertexID) r)
forall r p.
(Ord r, Fractional r) =>
BinLeafTree Size (Point 2 r :+ p)
-> Mapping p r -> (Adj, ConvexPolygon (p :+ VertexID) r)
delaunayTriangulation' BinLeafTree Size (Point 2 r :+ p)
rt Mapping p r
mapping'
                         (ConvexPolygon (p :+ VertexID) r
ch, LineSegment 2 (p :+ VertexID) r
bt, LineSegment 2 (p :+ VertexID) r
ut)   = ConvexPolygon (p :+ VertexID) r
-> ConvexPolygon (p :+ VertexID) r
-> (ConvexPolygon (p :+ VertexID) r,
    LineSegment 2 (p :+ VertexID) r, LineSegment 2 (p :+ VertexID) r)
forall r p.
(Num r, Ord r) =>
ConvexPolygon p r
-> ConvexPolygon p r
-> (ConvexPolygon p r, LineSegment 2 p r, LineSegment 2 p r)
Convex.merge ConvexPolygon (p :+ VertexID) r
lch ConvexPolygon (p :+ VertexID) r
rch
                     in (Adj
-> Adj
-> LineSegment 2 (p :+ VertexID) r
-> LineSegment 2 (p :+ VertexID) r
-> Mapping p r
-> Firsts
-> Adj
forall r p.
(Ord r, Fractional r) =>
Adj
-> Adj
-> LineSegment 2 (p :+ VertexID) r
-> LineSegment 2 (p :+ VertexID) r
-> Mapping p r
-> Firsts
-> Adj
merge Adj
ld Adj
rd LineSegment 2 (p :+ VertexID) r
bt LineSegment 2 (p :+ VertexID) r
ut Mapping p r
mapping' (ConvexPolygon (p :+ VertexID) r -> Firsts
forall p r. ConvexPolygon (p :+ VertexID) r -> Firsts
firsts ConvexPolygon (p :+ VertexID) r
ch), ConvexPolygon (p :+ VertexID) r
ch)

--------------------------------------------------------------------------------
-- * Implementation

-- | Mapping that says for each vtx in the convex hull what the first entry in
-- the adj. list should be. The input polygon is given in Clockwise order
firsts :: ConvexPolygon (p :+ VertexID) r -> IM.IntMap VertexID
firsts :: ConvexPolygon (p :+ VertexID) r -> Firsts
firsts = [(VertexID, VertexID)] -> Firsts
forall a. [(VertexID, a)] -> IntMap a
IM.fromList ([(VertexID, VertexID)] -> Firsts)
-> (ConvexPolygon (p :+ VertexID) r -> [(VertexID, VertexID)])
-> ConvexPolygon (p :+ VertexID) r
-> Firsts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LineSegment 2 (p :+ VertexID) r -> (VertexID, VertexID))
-> [LineSegment 2 (p :+ VertexID) r] -> [(VertexID, VertexID)]
forall a b. (a -> b) -> [a] -> [b]
map (\LineSegment 2 (p :+ VertexID) r
s -> (LineSegment 2 (p :+ VertexID) r
sLineSegment 2 (p :+ VertexID) r
-> Getting VertexID (LineSegment 2 (p :+ VertexID) r) VertexID
-> VertexID
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ (p :+ VertexID))
 -> Const VertexID (Point 2 r :+ (p :+ VertexID)))
-> LineSegment 2 (p :+ VertexID) r
-> Const VertexID (LineSegment 2 (p :+ VertexID) r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ (p :+ VertexID))
  -> Const VertexID (Point 2 r :+ (p :+ VertexID)))
 -> LineSegment 2 (p :+ VertexID) r
 -> Const VertexID (LineSegment 2 (p :+ VertexID) r))
-> ((VertexID -> Const VertexID VertexID)
    -> (Point 2 r :+ (p :+ VertexID))
    -> Const VertexID (Point 2 r :+ (p :+ VertexID)))
-> Getting VertexID (LineSegment 2 (p :+ VertexID) r) VertexID
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((p :+ VertexID) -> Const VertexID (p :+ VertexID))
-> (Point 2 r :+ (p :+ VertexID))
-> Const VertexID (Point 2 r :+ (p :+ VertexID))
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra(((p :+ VertexID) -> Const VertexID (p :+ VertexID))
 -> (Point 2 r :+ (p :+ VertexID))
 -> Const VertexID (Point 2 r :+ (p :+ VertexID)))
-> ((VertexID -> Const VertexID VertexID)
    -> (p :+ VertexID) -> Const VertexID (p :+ VertexID))
-> (VertexID -> Const VertexID VertexID)
-> (Point 2 r :+ (p :+ VertexID))
-> Const VertexID (Point 2 r :+ (p :+ VertexID))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(VertexID -> Const VertexID VertexID)
-> (p :+ VertexID) -> Const VertexID (p :+ VertexID)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra, LineSegment 2 (p :+ VertexID) r
sLineSegment 2 (p :+ VertexID) r
-> Getting VertexID (LineSegment 2 (p :+ VertexID) r) VertexID
-> VertexID
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ (p :+ VertexID))
 -> Const VertexID (Point 2 r :+ (p :+ VertexID)))
-> LineSegment 2 (p :+ VertexID) r
-> Const VertexID (LineSegment 2 (p :+ VertexID) r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ (p :+ VertexID))
  -> Const VertexID (Point 2 r :+ (p :+ VertexID)))
 -> LineSegment 2 (p :+ VertexID) r
 -> Const VertexID (LineSegment 2 (p :+ VertexID) r))
-> ((VertexID -> Const VertexID VertexID)
    -> (Point 2 r :+ (p :+ VertexID))
    -> Const VertexID (Point 2 r :+ (p :+ VertexID)))
-> Getting VertexID (LineSegment 2 (p :+ VertexID) r) VertexID
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((p :+ VertexID) -> Const VertexID (p :+ VertexID))
-> (Point 2 r :+ (p :+ VertexID))
-> Const VertexID (Point 2 r :+ (p :+ VertexID))
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra(((p :+ VertexID) -> Const VertexID (p :+ VertexID))
 -> (Point 2 r :+ (p :+ VertexID))
 -> Const VertexID (Point 2 r :+ (p :+ VertexID)))
-> ((VertexID -> Const VertexID VertexID)
    -> (p :+ VertexID) -> Const VertexID (p :+ VertexID))
-> (VertexID -> Const VertexID VertexID)
-> (Point 2 r :+ (p :+ VertexID))
-> Const VertexID (Point 2 r :+ (p :+ VertexID))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(VertexID -> Const VertexID VertexID)
-> (p :+ VertexID) -> Const VertexID (p :+ VertexID)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra))
       ([LineSegment 2 (p :+ VertexID) r] -> [(VertexID, VertexID)])
-> (ConvexPolygon (p :+ VertexID) r
    -> [LineSegment 2 (p :+ VertexID) r])
-> ConvexPolygon (p :+ VertexID) r
-> [(VertexID, VertexID)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CircularVector (LineSegment 2 (p :+ VertexID) r)
-> [LineSegment 2 (p :+ VertexID) r]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (CircularVector (LineSegment 2 (p :+ VertexID) r)
 -> [LineSegment 2 (p :+ VertexID) r])
-> (ConvexPolygon (p :+ VertexID) r
    -> CircularVector (LineSegment 2 (p :+ VertexID) r))
-> ConvexPolygon (p :+ VertexID) r
-> [LineSegment 2 (p :+ VertexID) r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon 'Simple (p :+ VertexID) r
-> CircularVector (LineSegment 2 (p :+ VertexID) r)
forall (t :: PolygonType) p r.
Polygon t p r -> CircularVector (LineSegment 2 p r)
outerBoundaryEdges (Polygon 'Simple (p :+ VertexID) r
 -> CircularVector (LineSegment 2 (p :+ VertexID) r))
-> (ConvexPolygon (p :+ VertexID) r
    -> Polygon 'Simple (p :+ VertexID) r)
-> ConvexPolygon (p :+ VertexID) r
-> CircularVector (LineSegment 2 (p :+ VertexID) r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConvexPolygon (p :+ VertexID) r
-> Polygon 'Simple (p :+ VertexID) r
forall p r. ConvexPolygon p r -> SimplePolygon p r
_simplePolygon


-- | Given a polygon; construct the adjacency list representation
-- pre: at least two elements
fromHull              :: Ord r => Mapping p r -> ConvexPolygon (p :+ q) r -> Adj
fromHull :: Mapping p r -> ConvexPolygon (p :+ q) r -> Adj
fromHull (Map (Point 2 r) VertexID
vtxMap,Vector (Point 2 r :+ p)
_) ConvexPolygon (p :+ q) r
p = let vs :: [VertexID]
vs@(VertexID
u:VertexID
v:[VertexID]
vs') = ((Point 2 r :+ (p :+ q)) -> VertexID)
-> [Point 2 r :+ (p :+ q)] -> [VertexID]
forall a b. (a -> b) -> [a] -> [b]
map (Map (Point 2 r) VertexID -> Point 2 r -> VertexID
forall k a. Ord k => Map k a -> k -> a
lookup' Map (Point 2 r) VertexID
vtxMap (Point 2 r -> VertexID)
-> ((Point 2 r :+ (p :+ q)) -> Point 2 r)
-> (Point 2 r :+ (p :+ q))
-> VertexID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point 2 r :+ (p :+ q))
-> Getting (Point 2 r) (Point 2 r :+ (p :+ q)) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ (p :+ q)) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core))
                                         ([Point 2 r :+ (p :+ q)] -> [VertexID])
-> (CircularVector (Point 2 r :+ (p :+ q))
    -> [Point 2 r :+ (p :+ q)])
-> CircularVector (Point 2 r :+ (p :+ q))
-> [VertexID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmptyVector (Point 2 r :+ (p :+ q)) -> [Point 2 r :+ (p :+ q)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (NonEmptyVector (Point 2 r :+ (p :+ q)) -> [Point 2 r :+ (p :+ q)])
-> (CircularVector (Point 2 r :+ (p :+ q))
    -> NonEmptyVector (Point 2 r :+ (p :+ q)))
-> CircularVector (Point 2 r :+ (p :+ q))
-> [Point 2 r :+ (p :+ q)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CircularVector (Point 2 r :+ (p :+ q))
-> NonEmptyVector (Point 2 r :+ (p :+ q))
forall a. CircularVector a -> NonEmptyVector a
CV.rightElements
                                         (CircularVector (Point 2 r :+ (p :+ q)) -> [VertexID])
-> CircularVector (Point 2 r :+ (p :+ q)) -> [VertexID]
forall a b. (a -> b) -> a -> b
$ ConvexPolygon (p :+ q) r
pConvexPolygon (p :+ q) r
-> Getting
     (CircularVector (Point 2 r :+ (p :+ q)))
     (ConvexPolygon (p :+ q) r)
     (CircularVector (Point 2 r :+ (p :+ q)))
-> CircularVector (Point 2 r :+ (p :+ q))
forall s a. s -> Getting a s a -> a
^.(SimplePolygon (p :+ q) r
 -> Const
      (CircularVector (Point 2 r :+ (p :+ q)))
      (SimplePolygon (p :+ q) r))
-> ConvexPolygon (p :+ q) r
-> Const
     (CircularVector (Point 2 r :+ (p :+ q))) (ConvexPolygon (p :+ q) r)
forall p1 r1 p2 r2.
Iso
  (ConvexPolygon p1 r1)
  (ConvexPolygon p2 r2)
  (SimplePolygon p1 r1)
  (SimplePolygon p2 r2)
simplePolygon((SimplePolygon (p :+ q) r
  -> Const
       (CircularVector (Point 2 r :+ (p :+ q)))
       (SimplePolygon (p :+ q) r))
 -> ConvexPolygon (p :+ q) r
 -> Const
      (CircularVector (Point 2 r :+ (p :+ q)))
      (ConvexPolygon (p :+ q) r))
-> ((CircularVector (Point 2 r :+ (p :+ q))
     -> Const
          (CircularVector (Point 2 r :+ (p :+ q)))
          (CircularVector (Point 2 r :+ (p :+ q))))
    -> SimplePolygon (p :+ q) r
    -> Const
         (CircularVector (Point 2 r :+ (p :+ q)))
         (SimplePolygon (p :+ q) r))
-> Getting
     (CircularVector (Point 2 r :+ (p :+ q)))
     (ConvexPolygon (p :+ q) r)
     (CircularVector (Point 2 r :+ (p :+ q)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(CircularVector (Point 2 r :+ (p :+ q))
 -> Const
      (CircularVector (Point 2 r :+ (p :+ q)))
      (CircularVector (Point 2 r :+ (p :+ q))))
-> SimplePolygon (p :+ q) r
-> Const
     (CircularVector (Point 2 r :+ (p :+ q))) (SimplePolygon (p :+ q) r)
forall (t :: PolygonType) p r.
Getter (Polygon t p r) (CircularVector (Point 2 r :+ p))
outerBoundaryVector
                            es :: [(VertexID, CList VertexID)]
es           = (VertexID -> VertexID -> VertexID -> (VertexID, CList VertexID))
-> [VertexID]
-> [VertexID]
-> [VertexID]
-> [(VertexID, CList VertexID)]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 VertexID -> VertexID -> VertexID -> (VertexID, CList VertexID)
forall a a. Eq a => a -> a -> a -> (a, CList a)
f [VertexID]
vs ([VertexID] -> [VertexID]
forall a. [a] -> [a]
tail [VertexID]
vs [VertexID] -> [VertexID] -> [VertexID]
forall a. [a] -> [a] -> [a]
++ [VertexID
u]) ([VertexID]
vs' [VertexID] -> [VertexID] -> [VertexID]
forall a. [a] -> [a] -> [a]
++ [VertexID
u,VertexID
v])
                            f :: a -> a -> a -> (a, CList a)
f a
prv a
c a
nxt  = (a
c,[a] -> CList a
forall a. [a] -> CList a
CL.fromList ([a] -> CList a) -> ([a] -> [a]) -> [a] -> CList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. Eq a => [a] -> [a]
L.nub ([a] -> CList a) -> [a] -> CList a
forall a b. (a -> b) -> a -> b
$ [a
prv, a
nxt])
                        in [(VertexID, CList VertexID)] -> Adj
forall a. [(VertexID, a)] -> IntMap a
IM.fromList [(VertexID, CList VertexID)]
es


-- | Merge the two delaunay triangulations.
--
-- running time: \(O(n)\) (although we cheat a bit by using a IntMap)
merge                            :: (Ord r, Fractional r)
                                 => Adj
                                 -> Adj
                                 -> LineSegment 2 (p :+ VertexID) r -- ^ lower tangent
                                 -> LineSegment 2 (p :+ VertexID) r -- ^ upper tangent
                                 -> Mapping p r
                                 -> Firsts
                                 -> Adj
merge :: Adj
-> Adj
-> LineSegment 2 (p :+ VertexID) r
-> LineSegment 2 (p :+ VertexID) r
-> Mapping p r
-> Firsts
-> Adj
merge Adj
ld Adj
rd LineSegment 2 (p :+ VertexID) r
bt LineSegment 2 (p :+ VertexID) r
ut mapping' :: Mapping p r
mapping'@(Map (Point 2 r) VertexID
vtxMap,Vector (Point 2 r :+ p)
_) Firsts
fsts =
    (Reader (Mapping p r, Firsts) Adj -> (Mapping p r, Firsts) -> Adj)
-> (Mapping p r, Firsts) -> Reader (Mapping p r, Firsts) Adj -> Adj
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader (Mapping p r, Firsts) Adj -> (Mapping p r, Firsts) -> Adj
forall r a. Reader r a -> r -> a
runReader (Mapping p r
mapping', Firsts
fsts) (Reader (Mapping p r, Firsts) Adj -> Adj)
-> (StateT Adj (ReaderT (Mapping p r, Firsts) Identity) ()
    -> Reader (Mapping p r, Firsts) Adj)
-> StateT Adj (ReaderT (Mapping p r, Firsts) Identity) ()
-> Adj
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT Adj (ReaderT (Mapping p r, Firsts) Identity) ()
 -> Adj -> Reader (Mapping p r, Firsts) Adj)
-> Adj
-> StateT Adj (ReaderT (Mapping p r, Firsts) Identity) ()
-> Reader (Mapping p r, Firsts) Adj
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Adj (ReaderT (Mapping p r, Firsts) Identity) ()
-> Adj -> Reader (Mapping p r, Firsts) Adj
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT Adj
adj (StateT Adj (ReaderT (Mapping p r, Firsts) Identity) () -> Adj)
-> StateT Adj (ReaderT (Mapping p r, Firsts) Identity) () -> Adj
forall a b. (a -> b) -> a -> b
$ (VertexID, VertexID)
-> VertexID
-> VertexID
-> StateT Adj (ReaderT (Mapping p r, Firsts) Identity) ()
forall r p.
(Ord r, Fractional r) =>
(VertexID, VertexID) -> VertexID -> VertexID -> Merge p r ()
moveUp (VertexID
tl,VertexID
tr) VertexID
l VertexID
r
  where
    l :: VertexID
l   = Map (Point 2 r) VertexID -> Point 2 r -> VertexID
forall k a. Ord k => Map k a -> k -> a
lookup' Map (Point 2 r) VertexID
vtxMap (LineSegment 2 (p :+ VertexID) r
btLineSegment 2 (p :+ VertexID) r
-> Getting
     (Point 2 r) (LineSegment 2 (p :+ VertexID) r) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ (p :+ VertexID))
 -> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID)))
-> LineSegment 2 (p :+ VertexID) r
-> Const (Point 2 r) (LineSegment 2 (p :+ VertexID) r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ (p :+ VertexID))
  -> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID)))
 -> LineSegment 2 (p :+ VertexID) r
 -> Const (Point 2 r) (LineSegment 2 (p :+ VertexID) r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ (p :+ VertexID))
    -> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID)))
-> Getting
     (Point 2 r) (LineSegment 2 (p :+ VertexID) 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 :+ (p :+ VertexID))
-> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID))
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
    r :: VertexID
r   = Map (Point 2 r) VertexID -> Point 2 r -> VertexID
forall k a. Ord k => Map k a -> k -> a
lookup' Map (Point 2 r) VertexID
vtxMap (LineSegment 2 (p :+ VertexID) r
btLineSegment 2 (p :+ VertexID) r
-> Getting
     (Point 2 r) (LineSegment 2 (p :+ VertexID) r) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ (p :+ VertexID))
 -> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID)))
-> LineSegment 2 (p :+ VertexID) r
-> Const (Point 2 r) (LineSegment 2 (p :+ VertexID) r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ (p :+ VertexID))
  -> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID)))
 -> LineSegment 2 (p :+ VertexID) r
 -> Const (Point 2 r) (LineSegment 2 (p :+ VertexID) r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ (p :+ VertexID))
    -> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID)))
-> Getting
     (Point 2 r) (LineSegment 2 (p :+ VertexID) 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 :+ (p :+ VertexID))
-> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID))
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
    tl :: VertexID
tl  = Map (Point 2 r) VertexID -> Point 2 r -> VertexID
forall k a. Ord k => Map k a -> k -> a
lookup' Map (Point 2 r) VertexID
vtxMap (LineSegment 2 (p :+ VertexID) r
utLineSegment 2 (p :+ VertexID) r
-> Getting
     (Point 2 r) (LineSegment 2 (p :+ VertexID) r) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ (p :+ VertexID))
 -> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID)))
-> LineSegment 2 (p :+ VertexID) r
-> Const (Point 2 r) (LineSegment 2 (p :+ VertexID) r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ (p :+ VertexID))
  -> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID)))
 -> LineSegment 2 (p :+ VertexID) r
 -> Const (Point 2 r) (LineSegment 2 (p :+ VertexID) r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ (p :+ VertexID))
    -> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID)))
-> Getting
     (Point 2 r) (LineSegment 2 (p :+ VertexID) 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 :+ (p :+ VertexID))
-> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID))
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
    tr :: VertexID
tr  = Map (Point 2 r) VertexID -> Point 2 r -> VertexID
forall k a. Ord k => Map k a -> k -> a
lookup' Map (Point 2 r) VertexID
vtxMap (LineSegment 2 (p :+ VertexID) r
utLineSegment 2 (p :+ VertexID) r
-> Getting
     (Point 2 r) (LineSegment 2 (p :+ VertexID) r) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ (p :+ VertexID))
 -> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID)))
-> LineSegment 2 (p :+ VertexID) r
-> Const (Point 2 r) (LineSegment 2 (p :+ VertexID) r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ (p :+ VertexID))
  -> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID)))
 -> LineSegment 2 (p :+ VertexID) r
 -> Const (Point 2 r) (LineSegment 2 (p :+ VertexID) r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ (p :+ VertexID))
    -> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID)))
-> Getting
     (Point 2 r) (LineSegment 2 (p :+ VertexID) 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 :+ (p :+ VertexID))
-> Const (Point 2 r) (Point 2 r :+ (p :+ VertexID))
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)
    adj :: Adj
adj = Adj
ld Adj -> Adj -> Adj
forall a. IntMap a -> IntMap a -> IntMap a
`IM.union` Adj
rd

type Merge p r = StateT Adj (Reader (Mapping p r, Firsts))

type Firsts = IM.IntMap VertexID

-- | Merges the two delaunay traingulations.
moveUp          :: (Ord r, Fractional r)
                => (VertexID,VertexID) -> VertexID -> VertexID -> Merge p r ()
moveUp :: (VertexID, VertexID) -> VertexID -> VertexID -> Merge p r ()
moveUp (VertexID, VertexID)
ut VertexID
l VertexID
r
  | (VertexID
l,VertexID
r) (VertexID, VertexID) -> (VertexID, VertexID) -> Bool
forall a. Eq a => a -> a -> Bool
== (VertexID, VertexID)
ut = VertexID -> VertexID -> Merge p r ()
forall r p. (Num r, Ord r) => VertexID -> VertexID -> Merge p r ()
insert VertexID
l VertexID
r
  | Bool
otherwise   = do
                     VertexID -> VertexID -> Merge p r ()
forall r p. (Num r, Ord r) => VertexID -> VertexID -> Merge p r ()
insert VertexID
l VertexID
r
                     -- Get the neighbours of r and l along the convex hull
                     CList VertexID
r1 <- (Adj -> CList VertexID)
-> StateT Adj (Reader (Mapping p r, Firsts)) (CList VertexID)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (CList VertexID -> CList VertexID
forall a. CList a -> CList a
pred' (CList VertexID -> CList VertexID)
-> (Adj -> CList VertexID) -> Adj -> CList VertexID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VertexID -> CList VertexID -> CList VertexID
forall a. Eq a => a -> CList a -> CList a
rotateTo VertexID
l (CList VertexID -> CList VertexID)
-> (Adj -> CList VertexID) -> Adj -> CList VertexID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VertexID -> Adj -> CList VertexID
forall a. VertexID -> IntMap a -> a
lookup'' VertexID
r)
                     CList VertexID
l1 <- (Adj -> CList VertexID)
-> StateT Adj (Reader (Mapping p r, Firsts)) (CList VertexID)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (CList VertexID -> CList VertexID
forall a. CList a -> CList a
succ' (CList VertexID -> CList VertexID)
-> (Adj -> CList VertexID) -> Adj -> CList VertexID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VertexID -> CList VertexID -> CList VertexID
forall a. Eq a => a -> CList a -> CList a
rotateTo VertexID
r (CList VertexID -> CList VertexID)
-> (Adj -> CList VertexID) -> Adj -> CList VertexID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VertexID -> Adj -> CList VertexID
forall a. VertexID -> IntMap a -> a
lookup'' VertexID
l)

                     (CList VertexID
r1',Bool
a) <- VertexID
-> VertexID -> CList VertexID -> Merge p r (CList VertexID, Bool)
forall r p.
(Ord r, Fractional r) =>
VertexID
-> VertexID -> CList VertexID -> Merge p r (CList VertexID, Bool)
rotateR VertexID
l VertexID
r CList VertexID
r1
                     (CList VertexID
l1',Bool
b) <- VertexID
-> VertexID -> CList VertexID -> Merge p r (CList VertexID, Bool)
forall r p.
(Ord r, Fractional r) =>
VertexID
-> VertexID -> CList VertexID -> Merge p r (CList VertexID, Bool)
rotateL VertexID
l VertexID
r CList VertexID
l1
                     Bool
c       <- VertexID
-> VertexID -> CList VertexID -> CList VertexID -> Merge p r Bool
forall r p.
(Ord r, Fractional r) =>
VertexID
-> VertexID -> CList VertexID -> CList VertexID -> Merge p r Bool
qTest VertexID
l VertexID
r CList VertexID
r1' CList VertexID
l1'
                     let (VertexID
l',VertexID
r') = case (Bool
a,Bool
b,Bool
c) of
                                     (Bool
True,Bool
_,Bool
_)          -> (CList VertexID -> VertexID
forall a. CList a -> a
focus' CList VertexID
l1', VertexID
r)
                                     (Bool
False,Bool
True,Bool
_)      -> (VertexID
l,          CList VertexID -> VertexID
forall a. CList a -> a
focus' CList VertexID
r1')
                                     (Bool
False,Bool
False,Bool
True)  -> (VertexID
l,          CList VertexID -> VertexID
forall a. CList a -> a
focus' CList VertexID
r1')
                                     (Bool
False,Bool
False,Bool
False) -> (CList VertexID -> VertexID
forall a. CList a -> a
focus' CList VertexID
l1', VertexID
r)
                     (VertexID, VertexID) -> VertexID -> VertexID -> Merge p r ()
forall r p.
(Ord r, Fractional r) =>
(VertexID, VertexID) -> VertexID -> VertexID -> Merge p r ()
moveUp (VertexID, VertexID)
ut VertexID
l' VertexID
r'


-- | \'rotates\' around r and removes all neighbours of r that violate the
-- delaunay condition. Returns the first vertex (as a Neighbour of r) that
-- should remain in the Delaunay Triangulation, as well as a boolean A that
-- helps deciding if we merge up by rotating left or rotating right (See
-- description in the paper for more info)
rotateR        :: (Ord r, Fractional r)
               => VertexID -> VertexID -> Vertex -> Merge p r (Vertex, Bool)
rotateR :: VertexID
-> VertexID -> CList VertexID -> Merge p r (CList VertexID, Bool)
rotateR VertexID
l VertexID
r CList VertexID
r1 = CList VertexID -> VertexID
forall a. CList a -> a
focus' CList VertexID
r1 VertexID -> (VertexID, VertexID) -> Merge p r Bool
forall r p.
(Ord r, Num r) =>
VertexID -> (VertexID, VertexID) -> Merge p r Bool
`isLeftOf` (VertexID
l, VertexID
r) Merge p r Bool
-> (Bool -> Merge p r (CList VertexID, Bool))
-> Merge p r (CList VertexID, Bool)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                   Bool
True  -> (,Bool
False) (CList VertexID -> (CList VertexID, Bool))
-> StateT Adj (Reader (Mapping p r, Firsts)) (CList VertexID)
-> Merge p r (CList VertexID, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VertexID
-> VertexID
-> CList VertexID
-> CList VertexID
-> StateT Adj (Reader (Mapping p r, Firsts)) (CList VertexID)
forall r p.
(Ord r, Fractional r) =>
VertexID
-> VertexID
-> CList VertexID
-> CList VertexID
-> Merge p r (CList VertexID)
rotateR' VertexID
l VertexID
r CList VertexID
r1 (CList VertexID -> CList VertexID
forall a. CList a -> CList a
pred' CList VertexID
r1)
                   Bool
False -> (CList VertexID, Bool) -> Merge p r (CList VertexID, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CList VertexID
r1,Bool
True)


-- | The code that does the actual rotating
rotateR'     :: (Ord r, Fractional r)
             => VertexID -> VertexID -> Vertex -> Vertex -> Merge p r Vertex
rotateR' :: VertexID
-> VertexID
-> CList VertexID
-> CList VertexID
-> Merge p r (CList VertexID)
rotateR' VertexID
l VertexID
r = CList VertexID -> CList VertexID -> Merge p r (CList VertexID)
go
  where
    go :: CList VertexID -> CList VertexID -> Merge p r (CList VertexID)
go CList VertexID
r1 CList VertexID
r2 = VertexID
-> VertexID -> CList VertexID -> CList VertexID -> Merge p r Bool
forall r p.
(Ord r, Fractional r) =>
VertexID
-> VertexID -> CList VertexID -> CList VertexID -> Merge p r Bool
qTest VertexID
l VertexID
r CList VertexID
r1 CList VertexID
r2 Merge p r Bool
-> (Bool -> Merge p r (CList VertexID))
-> Merge p r (CList VertexID)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                 Bool
True  -> CList VertexID -> Merge p r (CList VertexID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CList VertexID
r1
                 Bool
False -> do (Adj -> Adj) -> StateT Adj (Reader (Mapping p r, Firsts)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Adj -> Adj) -> StateT Adj (Reader (Mapping p r, Firsts)) ())
-> (Adj -> Adj) -> StateT Adj (Reader (Mapping p r, Firsts)) ()
forall a b. (a -> b) -> a -> b
$ VertexID -> VertexID -> Adj -> Adj
delete VertexID
r (CList VertexID -> VertexID
forall a. CList a -> a
focus' CList VertexID
r1)
                             CList VertexID -> CList VertexID -> Merge p r (CList VertexID)
go CList VertexID
r2 (CList VertexID -> CList VertexID
forall a. CList a -> CList a
pred' CList VertexID
r2)


-- | Symmetric to rotateR
rotateL     :: (Ord r, Fractional r)
                     => VertexID -> VertexID -> Vertex -> Merge p r (Vertex, Bool)
rotateL :: VertexID
-> VertexID -> CList VertexID -> Merge p r (CList VertexID, Bool)
rotateL VertexID
l VertexID
r CList VertexID
l1 = CList VertexID -> VertexID
forall a. CList a -> a
focus' CList VertexID
l1 VertexID -> (VertexID, VertexID) -> Merge p r Bool
forall r p.
(Ord r, Num r) =>
VertexID -> (VertexID, VertexID) -> Merge p r Bool
`isRightOf` (VertexID
r, VertexID
l) Merge p r Bool
-> (Bool -> Merge p r (CList VertexID, Bool))
-> Merge p r (CList VertexID, Bool)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                   Bool
True  -> (,Bool
False) (CList VertexID -> (CList VertexID, Bool))
-> StateT Adj (Reader (Mapping p r, Firsts)) (CList VertexID)
-> Merge p r (CList VertexID, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VertexID
-> VertexID
-> CList VertexID
-> CList VertexID
-> StateT Adj (Reader (Mapping p r, Firsts)) (CList VertexID)
forall r p.
(Ord r, Fractional r) =>
VertexID
-> VertexID
-> CList VertexID
-> CList VertexID
-> Merge p r (CList VertexID)
rotateL' VertexID
l VertexID
r CList VertexID
l1 (CList VertexID -> CList VertexID
forall a. CList a -> CList a
succ' CList VertexID
l1)
                   Bool
False -> (CList VertexID, Bool) -> Merge p r (CList VertexID, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CList VertexID
l1,Bool
True)

-- | The code that does the actual rotating. Symmetric to rotateR'
rotateL'     :: (Ord r, Fractional r)
             => VertexID -> VertexID -> Vertex -> Vertex -> Merge p r Vertex
rotateL' :: VertexID
-> VertexID
-> CList VertexID
-> CList VertexID
-> Merge p r (CList VertexID)
rotateL' VertexID
l VertexID
r = CList VertexID -> CList VertexID -> Merge p r (CList VertexID)
go
  where
    go :: CList VertexID -> CList VertexID -> Merge p r (CList VertexID)
go CList VertexID
l1 CList VertexID
l2 = VertexID
-> VertexID -> CList VertexID -> CList VertexID -> Merge p r Bool
forall r p.
(Ord r, Fractional r) =>
VertexID
-> VertexID -> CList VertexID -> CList VertexID -> Merge p r Bool
qTest VertexID
l VertexID
r CList VertexID
l1 CList VertexID
l2 Merge p r Bool
-> (Bool -> Merge p r (CList VertexID))
-> Merge p r (CList VertexID)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                 Bool
True  -> CList VertexID -> Merge p r (CList VertexID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CList VertexID
l1
                 Bool
False -> do (Adj -> Adj) -> StateT Adj (Reader (Mapping p r, Firsts)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Adj -> Adj) -> StateT Adj (Reader (Mapping p r, Firsts)) ())
-> (Adj -> Adj) -> StateT Adj (Reader (Mapping p r, Firsts)) ()
forall a b. (a -> b) -> a -> b
$ VertexID -> VertexID -> Adj -> Adj
delete VertexID
l (CList VertexID -> VertexID
forall a. CList a -> a
focus' CList VertexID
l1)
                             CList VertexID -> CList VertexID -> Merge p r (CList VertexID)
go CList VertexID
l2 (CList VertexID -> CList VertexID
forall a. CList a -> CList a
succ' CList VertexID
l2)

--------------------------------------------------------------------------------
-- * Primitives used by the Algorithm

-- | returns True if the forth point (vertex) does not lie in the disk defined
-- by the first three points.
qTest         :: (Ord r, Fractional r)
              => VertexID -> VertexID -> Vertex -> Vertex -> Merge p r Bool
qTest :: VertexID
-> VertexID -> CList VertexID -> CList VertexID -> Merge p r Bool
qTest VertexID
h VertexID
i CList VertexID
j CList VertexID
k = (((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
 -> Bool)
-> Merge p r Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Vector (Point 2 r :+ p) -> Bool
withPtMap (Vector (Point 2 r :+ p) -> Bool)
-> (((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
    -> Vector (Point 2 r :+ p))
-> ((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Point 2 r) VertexID, Vector (Point 2 r :+ p))
-> Vector (Point 2 r :+ p)
forall a b. (a, b) -> b
snd ((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p))
 -> Vector (Point 2 r :+ p))
-> (((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
    -> (Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)))
-> ((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
-> Vector (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
-> (Map (Point 2 r) VertexID, Vector (Point 2 r :+ p))
forall a b. (a, b) -> a
fst)
  where
    withPtMap :: Vector (Point 2 r :+ p) -> Bool
withPtMap Vector (Point 2 r :+ p)
ptMap = let h' :: Point 2 r :+ p
h' = Vector (Point 2 r :+ p)
ptMap Vector (Point 2 r :+ p) -> VertexID -> Point 2 r :+ p
forall a. Vector a -> VertexID -> a
V.! VertexID
h
                          i' :: Point 2 r :+ p
i' = Vector (Point 2 r :+ p)
ptMap Vector (Point 2 r :+ p) -> VertexID -> Point 2 r :+ p
forall a. Vector a -> VertexID -> a
V.! VertexID
i
                          j' :: Point 2 r :+ p
j' = Vector (Point 2 r :+ p)
ptMap Vector (Point 2 r :+ p) -> VertexID -> Point 2 r :+ p
forall a. Vector a -> VertexID -> a
V.! CList VertexID -> VertexID
forall a. CList a -> a
focus' CList VertexID
j
                          k' :: Point 2 r :+ p
k' = Vector (Point 2 r :+ p)
ptMap Vector (Point 2 r :+ p) -> VertexID -> Point 2 r :+ p
forall a. Vector a -> VertexID -> a
V.! CList VertexID -> VertexID
forall a. CList a -> a
focus' CList VertexID
k
                      in Bool -> Bool
not (Bool -> Bool)
-> (Maybe (Ball 2 () r) -> Bool) -> Maybe (Ball 2 () r) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> (Ball 2 () r -> Bool) -> Maybe (Ball 2 () r) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((Point 2 r :+ p
k'(Point 2 r :+ p)
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) Point 2 r -> Ball 2 () r -> Bool
forall (d :: Nat) r p.
(Arity d, Ord r, Num r) =>
Point d r -> Ball d p r -> Bool
`insideBall`) (Maybe (Ball 2 () r) -> Bool) -> Maybe (Ball 2 () r) -> Bool
forall a b. (a -> b) -> a -> b
$ (Point 2 r :+ p)
-> (Point 2 r :+ p) -> (Point 2 r :+ p) -> Maybe (Ball 2 () r)
forall r extra extra extra.
(Eq r, Fractional r) =>
(Point 2 r :+ extra)
-> (Point 2 r :+ extra)
-> (Point 2 r :+ extra)
-> Maybe (Disk () r)
disk' Point 2 r :+ p
h' Point 2 r :+ p
i' Point 2 r :+ p
j'
    disk' :: (Point 2 r :+ extra)
-> (Point 2 r :+ extra)
-> (Point 2 r :+ extra)
-> Maybe (Disk () r)
disk' Point 2 r :+ extra
p Point 2 r :+ extra
q Point 2 r :+ extra
r = Point 2 r -> Point 2 r -> Point 2 r -> Maybe (Disk () r)
forall r.
(Eq r, Fractional r) =>
Point 2 r -> Point 2 r -> Point 2 r -> Maybe (Disk () r)
disk (Point 2 r :+ extra
p(Point 2 r :+ extra)
-> Getting (Point 2 r) (Point 2 r :+ extra) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ extra) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) (Point 2 r :+ extra
q(Point 2 r :+ extra)
-> Getting (Point 2 r) (Point 2 r :+ extra) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ extra) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) (Point 2 r :+ extra
r(Point 2 r :+ extra)
-> Getting (Point 2 r) (Point 2 r :+ extra) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ extra) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)

-- | Inserts an edge into the right position.
insert     :: (Num r, Ord r) => VertexID -> VertexID -> Merge p r ()
insert :: VertexID -> VertexID -> Merge p r ()
insert VertexID
u VertexID
v = do
               (Mapping p r
mapping',Firsts
fsts) <- StateT Adj (Reader (Mapping p r, Firsts)) (Mapping p r, Firsts)
forall r (m :: * -> *). MonadReader r m => m r
ask
               (Adj -> Adj) -> Merge p r ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Adj -> Adj) -> Merge p r ()) -> (Adj -> Adj) -> Merge p r ()
forall a b. (a -> b) -> a -> b
$ VertexID -> VertexID -> Mapping p r -> Adj -> Adj
forall r p.
(Num r, Ord r) =>
VertexID -> VertexID -> Mapping p r -> Adj -> Adj
insert' VertexID
u VertexID
v Mapping p r
mapping'
               VertexID -> Firsts -> Merge p r ()
forall p r. VertexID -> Firsts -> Merge p r ()
rotateToFirst VertexID
u Firsts
fsts
               VertexID -> Firsts -> Merge p r ()
forall p r. VertexID -> Firsts -> Merge p r ()
rotateToFirst VertexID
v Firsts
fsts


-- | make sure that the first vtx in the adj list of v is its predecessor on the CH
rotateToFirst        :: VertexID -> Firsts -> Merge p r ()
rotateToFirst :: VertexID -> Firsts -> Merge p r ()
rotateToFirst VertexID
v Firsts
fsts = (Adj -> Adj) -> Merge p r ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Adj -> Adj) -> Merge p r ()) -> (Adj -> Adj) -> Merge p r ()
forall a b. (a -> b) -> a -> b
$ (CList VertexID -> CList VertexID) -> VertexID -> Adj -> Adj
forall a. (a -> a) -> VertexID -> IntMap a -> IntMap a
IM.adjust CList VertexID -> CList VertexID
f VertexID
v
  where
    mfst :: Maybe VertexID
mfst   = VertexID -> Firsts -> Maybe VertexID
forall a. VertexID -> IntMap a -> Maybe a
IM.lookup VertexID
v Firsts
fsts
    f :: CList VertexID -> CList VertexID
f  CList VertexID
cl  = CList VertexID -> Maybe (CList VertexID) -> CList VertexID
forall a. a -> Maybe a -> a
fromMaybe CList VertexID
cl (Maybe (CList VertexID) -> CList VertexID)
-> Maybe (CList VertexID) -> CList VertexID
forall a b. (a -> b) -> a -> b
$ Maybe VertexID
mfst Maybe VertexID
-> (VertexID -> Maybe (CList VertexID)) -> Maybe (CList VertexID)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (VertexID -> CList VertexID -> Maybe (CList VertexID))
-> CList VertexID -> VertexID -> Maybe (CList VertexID)
forall a b c. (a -> b -> c) -> b -> a -> c
flip VertexID -> CList VertexID -> Maybe (CList VertexID)
forall a. Eq a => a -> CList a -> Maybe (CList a)
CL.rotateTo CList VertexID
cl


-- | Inserts an edge (and makes sure that the vertex is inserted in the
-- correct. pos in the adjacency lists)
insert'               :: (Num r, Ord r)
                      => VertexID -> VertexID -> Mapping p r -> Adj -> Adj
insert' :: VertexID -> VertexID -> Mapping p r -> Adj -> Adj
insert' VertexID
u VertexID
v (Map (Point 2 r) VertexID
_,Vector (Point 2 r :+ p)
ptMap) = (VertexID -> CList VertexID -> CList VertexID)
-> VertexID -> Adj -> Adj
forall a. (VertexID -> a -> a) -> VertexID -> IntMap a -> IntMap a
IM.adjustWithKey (VertexID -> VertexID -> CList VertexID -> CList VertexID
insert'' VertexID
v) VertexID
u
                      (Adj -> Adj) -> (Adj -> Adj) -> Adj -> Adj
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VertexID -> CList VertexID -> CList VertexID)
-> VertexID -> Adj -> Adj
forall a. (VertexID -> a -> a) -> VertexID -> IntMap a -> IntMap a
IM.adjustWithKey (VertexID -> VertexID -> CList VertexID -> CList VertexID
insert'' VertexID
u) VertexID
v
  where
    -- inserts b into the adjacency list of a
    insert'' :: VertexID -> VertexID -> CList VertexID -> CList VertexID
insert'' VertexID
bi VertexID
ai = (VertexID -> VertexID -> Ordering)
-> VertexID -> CList VertexID -> CList VertexID
forall a. (a -> a -> Ordering) -> a -> CList a -> CList a
CU.insertOrdBy ((Point 2 r :+ p)
-> (Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering
forall r c p q.
(Num r, Ord r) =>
(Point 2 r :+ c)
-> (Point 2 r :+ p) -> (Point 2 r :+ q) -> Ordering
cmp (Vector (Point 2 r :+ p)
ptMap Vector (Point 2 r :+ p) -> VertexID -> Point 2 r :+ p
forall a. Vector a -> VertexID -> a
V.! VertexID
ai) ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> (VertexID -> Point 2 r :+ p) -> VertexID -> VertexID -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Vector (Point 2 r :+ p)
ptMap Vector (Point 2 r :+ p) -> VertexID -> Point 2 r :+ p
forall a. Vector a -> VertexID -> a
V.!)) VertexID
bi
    cmp :: (Point 2 r :+ c)
-> (Point 2 r :+ p) -> (Point 2 r :+ q) -> Ordering
cmp Point 2 r :+ c
c Point 2 r :+ p
p Point 2 r :+ q
q = (Point 2 r :+ c)
-> (Point 2 r :+ p) -> (Point 2 r :+ q) -> Ordering
forall r c p q.
(Num r, Ord r) =>
(Point 2 r :+ c)
-> (Point 2 r :+ p) -> (Point 2 r :+ q) -> Ordering
cwCmpAround' Point 2 r :+ c
c Point 2 r :+ p
p Point 2 r :+ q
q Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> (Point 2 r :+ c)
-> (Point 2 r :+ p) -> (Point 2 r :+ q) -> Ordering
forall r (d :: Nat) c p q.
(Ord r, Num r, Arity d) =>
(Point d r :+ c)
-> (Point d r :+ p) -> (Point d r :+ q) -> Ordering
cmpByDistanceTo' Point 2 r :+ c
c Point 2 r :+ p
p Point 2 r :+ q
q


-- | Deletes an edge
delete     :: VertexID -> VertexID -> Adj -> Adj
delete :: VertexID -> VertexID -> Adj -> Adj
delete VertexID
u VertexID
v = (CList VertexID -> CList VertexID) -> VertexID -> Adj -> Adj
forall a. (a -> a) -> VertexID -> IntMap a -> IntMap a
IM.adjust (VertexID -> CList VertexID -> CList VertexID
forall a. Eq a => a -> CList a -> CList a
delete' VertexID
v) VertexID
u (Adj -> Adj) -> (Adj -> Adj) -> Adj -> Adj
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CList VertexID -> CList VertexID) -> VertexID -> Adj -> Adj
forall a. (a -> a) -> VertexID -> IntMap a -> IntMap a
IM.adjust (VertexID -> CList VertexID -> CList VertexID
forall a. Eq a => a -> CList a -> CList a
delete' VertexID
u) VertexID
v
  where
    delete' :: a -> CList a -> CList a
delete' a
x = (a -> Bool) -> CList a -> CList a
forall a. (a -> Bool) -> CList a -> CList a
CL.filterL (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
x) -- should we rotate left or right if it is the focus?


-- | Lifted version of Convex.IsLeftOf
isLeftOf           :: (Ord r, Num r)
                   => VertexID -> (VertexID, VertexID) -> Merge p r Bool
VertexID
p isLeftOf :: VertexID -> (VertexID, VertexID) -> Merge p r Bool
`isLeftOf` (VertexID
l,VertexID
r) = (((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
 -> Bool)
-> Merge p r Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Vector (Point 2 r :+ p) -> Bool
withPtMap (Vector (Point 2 r :+ p) -> Bool)
-> (((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
    -> Vector (Point 2 r :+ p))
-> ((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Point 2 r) VertexID, Vector (Point 2 r :+ p))
-> Vector (Point 2 r :+ p)
forall a b. (a, b) -> b
snd ((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p))
 -> Vector (Point 2 r :+ p))
-> (((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
    -> (Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)))
-> ((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
-> Vector (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
-> (Map (Point 2 r) VertexID, Vector (Point 2 r :+ p))
forall a b. (a, b) -> a
fst)
  where
    withPtMap :: Vector (Point 2 r :+ p) -> Bool
withPtMap Vector (Point 2 r :+ p)
ptMap = (Vector (Point 2 r :+ p)
ptMap Vector (Point 2 r :+ p) -> VertexID -> Point 2 r :+ p
forall a. Vector a -> VertexID -> a
V.! VertexID
p) (Point 2 r :+ p) -> (Point 2 r :+ p, Point 2 r :+ p) -> Bool
forall r c a b.
(Ord r, Num r) =>
(Point 2 r :+ c) -> (Point 2 r :+ a, Point 2 r :+ b) -> Bool
`isLeftOf'` (Vector (Point 2 r :+ p)
ptMap Vector (Point 2 r :+ p) -> VertexID -> Point 2 r :+ p
forall a. Vector a -> VertexID -> a
V.! VertexID
l, Vector (Point 2 r :+ p)
ptMap Vector (Point 2 r :+ p) -> VertexID -> Point 2 r :+ p
forall a. Vector a -> VertexID -> a
V.! VertexID
r)
    Point 2 r :+ c
a isLeftOf' :: (Point 2 r :+ c) -> (Point 2 r :+ a, Point 2 r :+ b) -> Bool
`isLeftOf'` (Point 2 r :+ a
b,Point 2 r :+ b
c) = (Point 2 r :+ a) -> (Point 2 r :+ b) -> (Point 2 r :+ c) -> CCW
forall r a b c.
(Ord r, Num r) =>
(Point 2 r :+ a) -> (Point 2 r :+ b) -> (Point 2 r :+ c) -> CCW
ccw' Point 2 r :+ a
b Point 2 r :+ b
c Point 2 r :+ c
a CCW -> CCW -> Bool
forall a. Eq a => a -> a -> Bool
== CCW
CCW

-- | Lifted version of Convex.IsRightOf
isRightOf           :: (Ord r, Num r)
                    => VertexID -> (VertexID, VertexID) -> Merge p r Bool
VertexID
p isRightOf :: VertexID -> (VertexID, VertexID) -> Merge p r Bool
`isRightOf` (VertexID
l,VertexID
r) = (((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
 -> Bool)
-> Merge p r Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Vector (Point 2 r :+ p) -> Bool
withPtMap (Vector (Point 2 r :+ p) -> Bool)
-> (((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
    -> Vector (Point 2 r :+ p))
-> ((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Point 2 r) VertexID, Vector (Point 2 r :+ p))
-> Vector (Point 2 r :+ p)
forall a b. (a, b) -> b
snd ((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p))
 -> Vector (Point 2 r :+ p))
-> (((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
    -> (Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)))
-> ((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
-> Vector (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Map (Point 2 r) VertexID, Vector (Point 2 r :+ p)), Firsts)
-> (Map (Point 2 r) VertexID, Vector (Point 2 r :+ p))
forall a b. (a, b) -> a
fst)
  where
    withPtMap :: Vector (Point 2 r :+ p) -> Bool
withPtMap Vector (Point 2 r :+ p)
ptMap = (Vector (Point 2 r :+ p)
ptMap Vector (Point 2 r :+ p) -> VertexID -> Point 2 r :+ p
forall a. Vector a -> VertexID -> a
V.! VertexID
p) (Point 2 r :+ p) -> (Point 2 r :+ p, Point 2 r :+ p) -> Bool
forall r c a b.
(Ord r, Num r) =>
(Point 2 r :+ c) -> (Point 2 r :+ a, Point 2 r :+ b) -> Bool
`isRightOf'` (Vector (Point 2 r :+ p)
ptMap Vector (Point 2 r :+ p) -> VertexID -> Point 2 r :+ p
forall a. Vector a -> VertexID -> a
V.! VertexID
l, Vector (Point 2 r :+ p)
ptMap Vector (Point 2 r :+ p) -> VertexID -> Point 2 r :+ p
forall a. Vector a -> VertexID -> a
V.! VertexID
r)
    Point 2 r :+ c
a isRightOf' :: (Point 2 r :+ c) -> (Point 2 r :+ a, Point 2 r :+ b) -> Bool
`isRightOf'` (Point 2 r :+ a
b,Point 2 r :+ b
c) = (Point 2 r :+ a) -> (Point 2 r :+ b) -> (Point 2 r :+ c) -> CCW
forall r a b c.
(Ord r, Num r) =>
(Point 2 r :+ a) -> (Point 2 r :+ b) -> (Point 2 r :+ c) -> CCW
ccw' Point 2 r :+ a
b Point 2 r :+ b
c Point 2 r :+ c
a CCW -> CCW -> Bool
forall a. Eq a => a -> a -> Bool
== CCW
CW

--------------------------------------------------------------------------------
-- * Some Helper functions


lookup'     :: Ord k => M.Map k a -> k -> a
lookup' :: Map k a -> k -> a
lookup' Map k a
m k
x = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
x Map k a
m

size'              :: BinLeafTree Size a -> Size
size' :: BinLeafTree Size a -> Size
size' (Leaf a
_)     = Size
1
size' (Node BinLeafTree Size a
_ Size
s BinLeafTree Size a
_) = Size
s

-- | an \'unsafe\' version of rotateTo that assumes the element to rotate to
-- occurs in the list.
rotateTo   :: Eq a => a -> CL.CList a -> CL.CList a
rotateTo :: a -> CList a -> CList a
rotateTo a
x = Maybe (CList a) -> CList a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (CList a) -> CList a)
-> (CList a -> Maybe (CList a)) -> CList a -> CList a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> CList a -> Maybe (CList a)
forall a. Eq a => a -> CList a -> Maybe (CList a)
CL.rotateTo a
x

-- | Adjacency lists are stored in clockwise order, so pred means rotate right
pred' :: CL.CList a -> CL.CList a
pred' :: CList a -> CList a
pred' = CList a -> CList a
forall a. CList a -> CList a
CL.rotR

-- | Adjacency lists are stored in clockwise order, so pred and succ rotate left
succ' :: CL.CList a -> CL.CList a
succ' :: CList a -> CList a
succ' = CList a -> CList a
forall a. CList a -> CList a
CL.rotL

-- | Return the focus of the CList, throwing an exception if the list is empty.
focus' :: CL.CList a -> a
focus' :: CList a -> a
focus' = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> (CList a -> Maybe a) -> CList a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CList a -> Maybe a
forall a. CList a -> Maybe a
CL.focus

-- | Removes duplicates from a sorted list
nub' :: Eq a => NonEmpty.NonEmpty (a :+ b) -> NonEmpty.NonEmpty (a :+ b)
nub' :: NonEmpty (a :+ b) -> NonEmpty (a :+ b)
nub' = (NonEmpty (a :+ b) -> a :+ b)
-> NonEmpty (NonEmpty (a :+ b)) -> NonEmpty (a :+ b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (a :+ b) -> a :+ b
forall a. NonEmpty a -> a
NonEmpty.head (NonEmpty (NonEmpty (a :+ b)) -> NonEmpty (a :+ b))
-> (NonEmpty (a :+ b) -> NonEmpty (NonEmpty (a :+ b)))
-> NonEmpty (a :+ b)
-> NonEmpty (a :+ b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a :+ b) -> (a :+ b) -> Bool)
-> NonEmpty (a :+ b) -> NonEmpty (NonEmpty (a :+ b))
forall a. (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a)
NonEmpty.groupBy1 (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool) -> ((a :+ b) -> a) -> (a :+ b) -> (a :+ b) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ((a :+ b) -> Getting a (a :+ b) a -> a
forall s a. s -> Getting a s a -> a
^.Getting a (a :+ b) a
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core))


withID     :: c :+ e -> e' -> c :+ (e :+ e')
withID :: (c :+ e) -> e' -> c :+ (e :+ e')
withID c :+ e
p e'
i = c :+ e
p(c :+ e) -> ((c :+ e) -> c :+ (e :+ e')) -> c :+ (e :+ e')
forall a b. a -> (a -> b) -> b
&(e -> Identity (e :+ e')) -> (c :+ e) -> Identity (c :+ (e :+ e'))
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra ((e -> Identity (e :+ e'))
 -> (c :+ e) -> Identity (c :+ (e :+ e')))
-> (e -> e :+ e') -> (c :+ e) -> c :+ (e :+ e')
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (e -> e' -> e :+ e'
forall core extra. core -> extra -> core :+ extra
:+e'
i)

lookup'' :: Int -> IM.IntMap a -> a
lookup'' :: VertexID -> IntMap a -> a
lookup'' VertexID
k IntMap a
m = IntMap a
m IntMap a -> VertexID -> a
forall a. IntMap a -> VertexID -> a
IM.! VertexID
k