{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Algorithms.Geometry.PolygonTriangulation.MakeMonotone
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--------------------------------------------------------------------------------
module Algorithms.Geometry.PolygonTriangulation.MakeMonotone( makeMonotone
                                                            , computeDiagonals


                                                            , VertexType(..)
                                                            , classifyVertices
                                                            ) where

import Algorithms.Geometry.LineSegmentIntersection.BentleyOttmann (ordAt, xCoordAt)
import Algorithms.Geometry.PolygonTriangulation.Types

import           Control.Lens
import           Control.Monad.Reader
import           Control.Monad.State.Strict
import           Control.Monad.Writer                  (WriterT, execWriterT, tell)
import           Data.Bifunctor
import qualified Data.DList                            as DList
import           Data.Ext
import qualified Data.Foldable                         as F
import           Data.Geometry.LineSegment
import           Data.Geometry.PlanarSubdivision.Basic
import           Data.Geometry.Point
import           Data.Geometry.Polygon
import qualified Data.IntMap                           as IntMap
import qualified Data.List.NonEmpty                    as NonEmpty
import           Data.Ord                              (Down (..), comparing)
import qualified Data.Set                              as SS
import qualified Data.Set.Util                         as SS
import           Data.Util
import qualified Data.Vector                           as V
import qualified Data.Vector.Circular                  as CV
import qualified Data.Vector.Mutable                   as MV


-- import Debug.Trace
----------------------------------------------------------------------------------

data VertexType = Start | Merge | Split | End | Regular deriving (Int -> VertexType -> ShowS
[VertexType] -> ShowS
VertexType -> String
(Int -> VertexType -> ShowS)
-> (VertexType -> String)
-> ([VertexType] -> ShowS)
-> Show VertexType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VertexType] -> ShowS
$cshowList :: [VertexType] -> ShowS
show :: VertexType -> String
$cshow :: VertexType -> String
showsPrec :: Int -> VertexType -> ShowS
$cshowsPrec :: Int -> VertexType -> ShowS
Show,ReadPrec [VertexType]
ReadPrec VertexType
Int -> ReadS VertexType
ReadS [VertexType]
(Int -> ReadS VertexType)
-> ReadS [VertexType]
-> ReadPrec VertexType
-> ReadPrec [VertexType]
-> Read VertexType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [VertexType]
$creadListPrec :: ReadPrec [VertexType]
readPrec :: ReadPrec VertexType
$creadPrec :: ReadPrec VertexType
readList :: ReadS [VertexType]
$creadList :: ReadS [VertexType]
readsPrec :: Int -> ReadS VertexType
$creadsPrec :: Int -> ReadS VertexType
Read,VertexType -> VertexType -> Bool
(VertexType -> VertexType -> Bool)
-> (VertexType -> VertexType -> Bool) -> Eq VertexType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VertexType -> VertexType -> Bool
$c/= :: VertexType -> VertexType -> Bool
== :: VertexType -> VertexType -> Bool
$c== :: VertexType -> VertexType -> Bool
Eq)

-- | assigns a vertex type to each vertex
--
-- pre: Both the outer boundary and the inner boundary of the polygon are given in CCW order.
--
-- running time: \(O(n)\).
classifyVertices                     :: (Num r, Ord r)
                                     => Polygon t p r
                                     -> Polygon t (p :+ VertexType) r
classifyVertices :: Polygon t p r -> Polygon t (p :+ VertexType) r
classifyVertices p :: Polygon t p r
p@SimplePolygon{}   = SimplePolygon p r -> SimplePolygon (p :+ VertexType) r
forall r p.
(Num r, Ord r) =>
SimplePolygon p r -> SimplePolygon (p :+ VertexType) r
classifyVertices' Polygon t p r
SimplePolygon p r
p
classifyVertices (MultiPolygon SimplePolygon p r
vs [SimplePolygon p r]
h) = SimplePolygon (p :+ VertexType) r
-> [SimplePolygon (p :+ VertexType) r]
-> MultiPolygon (p :+ VertexType) r
forall p r.
SimplePolygon p r -> [SimplePolygon p r] -> MultiPolygon p r
MultiPolygon SimplePolygon (p :+ VertexType) r
vs' [SimplePolygon (p :+ VertexType) r]
h'
  where
    vs' :: SimplePolygon (p :+ VertexType) r
vs' = SimplePolygon p r -> SimplePolygon (p :+ VertexType) r
forall r p.
(Num r, Ord r) =>
SimplePolygon p r -> SimplePolygon (p :+ VertexType) r
classifyVertices' SimplePolygon p r
vs
    h' :: [SimplePolygon (p :+ VertexType) r]
h' = (SimplePolygon p r -> SimplePolygon (p :+ VertexType) r)
-> [SimplePolygon p r] -> [SimplePolygon (p :+ VertexType) r]
forall a b. (a -> b) -> [a] -> [b]
map (((p :+ VertexType) -> p :+ VertexType)
-> SimplePolygon (p :+ VertexType) r
-> SimplePolygon (p :+ VertexType) r
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((p :+ VertexType)
-> ((p :+ VertexType) -> p :+ VertexType) -> p :+ VertexType
forall a b. a -> (a -> b) -> b
&(VertexType -> Identity VertexType)
-> (p :+ VertexType) -> Identity (p :+ VertexType)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra ((VertexType -> Identity VertexType)
 -> (p :+ VertexType) -> Identity (p :+ VertexType))
-> (VertexType -> VertexType)
-> (p :+ VertexType)
-> p :+ VertexType
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ VertexType -> VertexType
onHole) (SimplePolygon (p :+ VertexType) r
 -> SimplePolygon (p :+ VertexType) r)
-> (SimplePolygon p r -> SimplePolygon (p :+ VertexType) r)
-> SimplePolygon p r
-> SimplePolygon (p :+ VertexType) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimplePolygon p r -> SimplePolygon (p :+ VertexType) r
forall r p.
(Num r, Ord r) =>
SimplePolygon p r -> SimplePolygon (p :+ VertexType) r
classifyVertices') [SimplePolygon p r]
h

    -- the roles on hole vertices are slightly different
    onHole :: VertexType -> VertexType
onHole VertexType
Start   = VertexType
Split
    onHole VertexType
Merge   = VertexType
End
    onHole VertexType
Split   = VertexType
Start
    onHole VertexType
End     = VertexType
Merge
    onHole VertexType
Regular = VertexType
Regular

-- | assigns a vertex type to each vertex
--
-- pre: the polygon is given in CCW order
--
-- running time: \(O(n)\).
classifyVertices'                    :: (Num r, Ord r)
                                     => SimplePolygon p r
                                     -> SimplePolygon (p :+ VertexType) r
classifyVertices' :: SimplePolygon p r -> SimplePolygon (p :+ VertexType) r
classifyVertices' SimplePolygon p r
poly =
    CircularVector (Point 2 r :+ (p :+ VertexType))
-> SimplePolygon (p :+ VertexType) r
forall r p. CircularVector (Point 2 r :+ p) -> SimplePolygon p r
unsafeFromCircularVector (CircularVector (Point 2 r :+ (p :+ VertexType))
 -> SimplePolygon (p :+ VertexType) r)
-> CircularVector (Point 2 r :+ (p :+ VertexType))
-> SimplePolygon (p :+ VertexType) r
forall a b. (a -> b) -> a -> b
$ ((Point 2 r :+ p)
 -> (Point 2 r :+ p)
 -> (Point 2 r :+ p)
 -> Point 2 r :+ (p :+ VertexType))
-> CircularVector (Point 2 r :+ p)
-> CircularVector (Point 2 r :+ p)
-> CircularVector (Point 2 r :+ p)
-> CircularVector (Point 2 r :+ (p :+ VertexType))
forall a b c d.
(a -> b -> c -> d)
-> CircularVector a
-> CircularVector b
-> CircularVector c
-> CircularVector d
CV.zipWith3 (Point 2 r :+ p)
-> (Point 2 r :+ p)
-> (Point 2 r :+ p)
-> Point 2 r :+ (p :+ VertexType)
forall r core.
(Ord r, Num r) =>
(Point 2 r :+ core)
-> (Point 2 r :+ core)
-> (Point 2 r :+ core)
-> Point 2 r :+ (core :+ VertexType)
f (Int
-> CircularVector (Point 2 r :+ p)
-> CircularVector (Point 2 r :+ p)
forall a. Int -> CircularVector a -> CircularVector a
CV.rotateLeft Int
1 CircularVector (Point 2 r :+ p)
vs) CircularVector (Point 2 r :+ p)
vs (Int
-> CircularVector (Point 2 r :+ p)
-> CircularVector (Point 2 r :+ p)
forall a. Int -> CircularVector a -> CircularVector a
CV.rotateRight Int
1 CircularVector (Point 2 r :+ p)
vs)
  where
    vs :: CircularVector (Point 2 r :+ p)
vs = SimplePolygon p r
poly SimplePolygon 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
    -- is the angle larger than > 180 degrees
    largeInteriorAngle :: (Point 2 r :+ extra)
-> (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Bool
largeInteriorAngle Point 2 r :+ extra
p Point 2 r :+ extra
c Point 2 r :+ extra
n = case Point 2 r -> Point 2 r -> Point 2 r -> CCW
forall r.
(Ord r, Num r) =>
Point 2 r -> Point 2 r -> Point 2 r -> CCW
ccw (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
c(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
n(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) of
           CCW
CCW -> Bool
False
           CCW
CW  -> Bool
True
           CCW
_   -> String -> Bool
forall a. HasCallStack => String -> a
error String
"classifyVertices -> largeInteriorAngle: colinear points"

    f :: (Point 2 r :+ core)
-> (Point 2 r :+ core)
-> (Point 2 r :+ core)
-> Point 2 r :+ (core :+ VertexType)
f Point 2 r :+ core
p Point 2 r :+ core
c Point 2 r :+ core
n = Point 2 r :+ core
c(Point 2 r :+ core)
-> ((Point 2 r :+ core) -> Point 2 r :+ (core :+ VertexType))
-> Point 2 r :+ (core :+ VertexType)
forall a b. a -> (a -> b) -> b
&(core -> Identity (core :+ VertexType))
-> (Point 2 r :+ core)
-> Identity (Point 2 r :+ (core :+ VertexType))
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra ((core -> Identity (core :+ VertexType))
 -> (Point 2 r :+ core)
 -> Identity (Point 2 r :+ (core :+ VertexType)))
-> (core -> core :+ VertexType)
-> (Point 2 r :+ core)
-> Point 2 r :+ (core :+ VertexType)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (core -> VertexType -> core :+ VertexType
forall core extra. core -> extra -> core :+ extra
:+ VertexType
vt)
      where
        vt :: VertexType
vt = case (Point 2 r :+ core
p (Point 2 r :+ core) -> (Point 2 r :+ core) -> Ordering
forall r e.
Ord r =>
(Point 2 r :+ e) -> (Point 2 r :+ e) -> Ordering
`cmpSweep` Point 2 r :+ core
c, Point 2 r :+ core
n (Point 2 r :+ core) -> (Point 2 r :+ core) -> Ordering
forall r e.
Ord r =>
(Point 2 r :+ e) -> (Point 2 r :+ e) -> Ordering
`cmpSweep` Point 2 r :+ core
c, (Point 2 r :+ core)
-> (Point 2 r :+ core) -> (Point 2 r :+ core) -> Bool
forall r extra extra extra.
(Ord r, Num r) =>
(Point 2 r :+ extra)
-> (Point 2 r :+ extra) -> (Point 2 r :+ extra) -> Bool
largeInteriorAngle Point 2 r :+ core
p Point 2 r :+ core
c Point 2 r :+ core
n) of
               (Ordering
LT, Ordering
LT, Bool
False) -> VertexType
Start
               (Ordering
LT, Ordering
LT, Bool
True)  -> VertexType
Split
               (Ordering
GT, Ordering
GT, Bool
False) -> VertexType
End
               (Ordering
GT, Ordering
GT, Bool
True)  -> VertexType
Merge
               (Ordering, Ordering, Bool)
_               -> VertexType
Regular



-- | p < q = p.y < q.y || p.y == q.y && p.x > q.y
cmpSweep :: Ord r => Point 2 r :+ e -> Point 2 r :+ e -> Ordering
Point 2 r :+ e
p cmpSweep :: (Point 2 r :+ e) -> (Point 2 r :+ e) -> Ordering
`cmpSweep` Point 2 r :+ e
q =
  ((Point 2 r :+ e) -> r)
-> (Point 2 r :+ e) -> (Point 2 r :+ e) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Point 2 r :+ e) -> Getting r (Point 2 r :+ e) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ e) -> Const r (Point 2 r :+ e)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ e) -> Const r (Point 2 r :+ e))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ e) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord) Point 2 r :+ e
p Point 2 r :+ e
q Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> ((Point 2 r :+ e) -> Down r)
-> (Point 2 r :+ e) -> (Point 2 r :+ e) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (r -> Down r
forall a. a -> Down a
Down (r -> Down r)
-> ((Point 2 r :+ e) -> r) -> (Point 2 r :+ e) -> Down r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point 2 r :+ e) -> Getting r (Point 2 r :+ e) r -> r
forall s a. s -> Getting a s a -> a
^.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ e) -> Const r (Point 2 r :+ e)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
 -> (Point 2 r :+ e) -> Const r (Point 2 r :+ e))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> Getting r (Point 2 r :+ e) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord)) Point 2 r :+ e
p Point 2 r :+ e
q


--------------------------------------------------------------------------------

type Event r = Point 2 r :+ Two (LineSegment 2 Int r)

data StatusStruct r = SS { StatusStruct r -> Set (LineSegment 2 Int r)
_statusStruct :: !(SS.Set (LineSegment 2 Int r))
                         , StatusStruct r -> IntMap Int
_helper       :: !(IntMap.IntMap Int)
                         -- ^ for every e_i, the id of the helper vertex
                         } deriving (Int -> StatusStruct r -> ShowS
[StatusStruct r] -> ShowS
StatusStruct r -> String
(Int -> StatusStruct r -> ShowS)
-> (StatusStruct r -> String)
-> ([StatusStruct r] -> ShowS)
-> Show (StatusStruct r)
forall r. Show r => Int -> StatusStruct r -> ShowS
forall r. Show r => [StatusStruct r] -> ShowS
forall r. Show r => StatusStruct r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StatusStruct r] -> ShowS
$cshowList :: forall r. Show r => [StatusStruct r] -> ShowS
show :: StatusStruct r -> String
$cshow :: forall r. Show r => StatusStruct r -> String
showsPrec :: Int -> StatusStruct r -> ShowS
$cshowsPrec :: forall r. Show r => Int -> StatusStruct r -> ShowS
Show)
makeLenses ''StatusStruct

ix'   :: Int -> Lens' (V.Vector a) a
ix' :: Int -> Lens' (Vector a) a
ix' Int
i = Traversing (->) f (Vector a) (Vector a) a a
-> Over (->) f (Vector a) (Vector a) a a
forall (p :: * -> * -> *) (f :: * -> *) s t a.
(HasCallStack, Conjoined p, Functor f) =>
Traversing p f s t a a -> Over p f s t a a
singular (Index (Vector a) -> Traversal' (Vector a) (IxValue (Vector a))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
Index (Vector a)
i)

{- HLINT ignore computeDiagonals -}
-- | Given a polygon, find a set of non-intersecting diagonals that partition
-- the polygon into y-monotone pieces.
--
-- running time: \(O(n\log n)\)
computeDiagonals    :: forall t r p. (Fractional r, Ord r)
                    => Polygon t p r -> [LineSegment 2 p r]
computeDiagonals :: Polygon t p r -> [LineSegment 2 p r]
computeDiagonals Polygon t p r
p' = (LineSegment 2 Int r -> LineSegment 2 p r)
-> [LineSegment 2 Int r] -> [LineSegment 2 p r]
forall a b. (a -> b) -> [a] -> [b]
map LineSegment 2 Int r -> LineSegment 2 p r
f ([LineSegment 2 Int r] -> [LineSegment 2 p r])
-> (Polygon t (SP Int (p :+ VertexType)) r
    -> [LineSegment 2 Int r])
-> Polygon t (SP Int (p :+ VertexType)) r
-> [LineSegment 2 p r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Event r) -> [LineSegment 2 Int r]
sweep
                    (NonEmpty (Event r) -> [LineSegment 2 Int r])
-> (Polygon t (SP Int (p :+ VertexType)) r -> NonEmpty (Event r))
-> Polygon t (SP Int (p :+ VertexType)) r
-> [LineSegment 2 Int r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event r -> Event r -> Ordering)
-> NonEmpty (Event r) -> NonEmpty (Event r)
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NonEmpty.sortBy ((Event r -> Event r -> Ordering) -> Event r -> Event r -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Event r -> Event r -> Ordering
forall r e.
Ord r =>
(Point 2 r :+ e) -> (Point 2 r :+ e) -> Ordering
cmpSweep)
                    (NonEmpty (Event r) -> NonEmpty (Event r))
-> (Polygon t (SP Int (p :+ VertexType)) r -> NonEmpty (Event r))
-> Polygon t (SP Int (p :+ VertexType)) r
-> NonEmpty (Event r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon t (Two (LineSegment 2 Int r)) r -> NonEmpty (Event r)
forall (t :: PolygonType) p r.
Polygon t p r -> NonEmpty (Point 2 r :+ p)
polygonVertices (Polygon t (Two (LineSegment 2 Int r)) r -> NonEmpty (Event r))
-> (Polygon t (SP Int (p :+ VertexType)) r
    -> Polygon t (Two (LineSegment 2 Int r)) r)
-> Polygon t (SP Int (p :+ VertexType)) r
-> NonEmpty (Event r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon t Int r -> Polygon t (Two (LineSegment 2 Int r)) r
forall (t :: PolygonType) p r.
Polygon t p r -> Polygon t (Two (LineSegment 2 p r)) r
withIncidentEdges
                    (Polygon t Int r -> Polygon t (Two (LineSegment 2 Int r)) r)
-> (Polygon t (SP Int (p :+ VertexType)) r -> Polygon t Int r)
-> Polygon t (SP Int (p :+ VertexType)) r
-> Polygon t (Two (LineSegment 2 Int r)) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SP Int (p :+ VertexType) -> Int)
-> Polygon t (SP Int (p :+ VertexType)) r -> Polygon t Int r
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (SP Int (p :+ VertexType)
-> Getting Int (SP Int (p :+ VertexType)) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (SP Int (p :+ VertexType)) Int
forall s t a b. Field1 s t a b => Lens s t a b
_1) (Polygon t (SP Int (p :+ VertexType)) r -> [LineSegment 2 p r])
-> Polygon t (SP Int (p :+ VertexType)) r -> [LineSegment 2 p r]
forall a b. (a -> b) -> a -> b
$ Polygon t (SP Int (p :+ VertexType)) r
pg
  where
    -- remaps to get the p value rather than the vertexId
    f :: LineSegment 2 Int r -> LineSegment 2 p r
f = (Int -> p) -> LineSegment 2 Int r -> LineSegment 2 p r
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\Int
i -> Vector (STR (Point 2 r) p VertexType)
vertexInfoVector (STR (Point 2 r) p VertexType)
-> Getting p (Vector (STR (Point 2 r) p VertexType)) p -> p
forall s a. s -> Getting a s a -> a
^.Int
-> Lens'
     (Vector (STR (Point 2 r) p VertexType))
     (STR (Point 2 r) p VertexType)
forall a. Int -> Lens' (Vector a) a
ix' Int
i((STR (Point 2 r) p VertexType
  -> Const p (STR (Point 2 r) p VertexType))
 -> Vector (STR (Point 2 r) p VertexType)
 -> Const p (Vector (STR (Point 2 r) p VertexType)))
-> ((p -> Const p p)
    -> STR (Point 2 r) p VertexType
    -> Const p (STR (Point 2 r) p VertexType))
-> Getting p (Vector (STR (Point 2 r) p VertexType)) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(p -> Const p p)
-> STR (Point 2 r) p VertexType
-> Const p (STR (Point 2 r) p VertexType)
forall s t a b. Field2 s t a b => Lens s t a b
_2)

    pg :: Polygon t (SP Int (p :+ VertexType)) r
    pg :: Polygon t (SP Int (p :+ VertexType)) r
pg = Polygon t (p :+ VertexType) r
-> Polygon t (SP Int (p :+ VertexType)) r
forall (t :: PolygonType) p r.
Polygon t p r -> Polygon t (SP Int p) r
numberVertices (Polygon t (p :+ VertexType) r
 -> Polygon t (SP Int (p :+ VertexType)) r)
-> (Polygon t p r -> Polygon t (p :+ VertexType) r)
-> Polygon t p r
-> Polygon t (SP Int (p :+ VertexType)) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon t (p :+ VertexType) r -> Polygon t (p :+ VertexType) r
forall r (t :: PolygonType) p.
(Eq r, Num r) =>
Polygon t p r -> Polygon t p r
holesToCW (Polygon t (p :+ VertexType) r -> Polygon t (p :+ VertexType) r)
-> (Polygon t p r -> Polygon t (p :+ VertexType) r)
-> Polygon t p r
-> Polygon t (p :+ VertexType) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon t p r -> Polygon t (p :+ VertexType) r
forall r (t :: PolygonType) p.
(Num r, Ord r) =>
Polygon t p r -> Polygon t (p :+ VertexType) r
classifyVertices (Polygon t p r -> Polygon t (p :+ VertexType) r)
-> (Polygon t p r -> Polygon t p r)
-> Polygon t p r
-> Polygon t (p :+ VertexType) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon t p r -> Polygon t p r
forall r (t :: PolygonType) p.
(Eq r, Num r) =>
Polygon t p r -> Polygon t p r
toCCW (Polygon t p r -> Polygon t (SP Int (p :+ VertexType)) r)
-> Polygon t p r -> Polygon t (SP Int (p :+ VertexType)) r
forall a b. (a -> b) -> a -> b
$ Polygon t p r
p'
    vertexInfo :: V.Vector (STR (Point 2 r) p VertexType)
    vertexInfo :: Vector (STR (Point 2 r) p VertexType)
vertexInfo = let vs :: NonEmpty (Point 2 r :+ SP Int (p :+ VertexType))
vs = Polygon t (SP Int (p :+ VertexType)) r
-> NonEmpty (Point 2 r :+ SP Int (p :+ VertexType))
forall (t :: PolygonType) p r.
Polygon t p r -> NonEmpty (Point 2 r :+ p)
polygonVertices Polygon t (SP Int (p :+ VertexType)) r
pg
                     n :: Int
n  = NonEmpty (Point 2 r :+ SP Int (p :+ VertexType)) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
F.length NonEmpty (Point 2 r :+ SP Int (p :+ VertexType))
vs
                 in (forall s. ST s (MVector s (STR (Point 2 r) p VertexType)))
-> Vector (STR (Point 2 r) p VertexType)
forall a. (forall s. ST s (MVector s a)) -> Vector a
V.create ((forall s. ST s (MVector s (STR (Point 2 r) p VertexType)))
 -> Vector (STR (Point 2 r) p VertexType))
-> (forall s. ST s (MVector s (STR (Point 2 r) p VertexType)))
-> Vector (STR (Point 2 r) p VertexType)
forall a b. (a -> b) -> a -> b
$ do
                   MVector s (STR (Point 2 r) p VertexType)
v <- Int
-> ST s (MVector (PrimState (ST s)) (STR (Point 2 r) p VertexType))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
MV.new Int
n
                   NonEmpty (Point 2 r :+ SP Int (p :+ VertexType))
-> ((Point 2 r :+ SP Int (p :+ VertexType)) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (Point 2 r :+ SP Int (p :+ VertexType))
vs (((Point 2 r :+ SP Int (p :+ VertexType)) -> ST s ()) -> ST s ())
-> ((Point 2 r :+ SP Int (p :+ VertexType)) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(Point 2 r
pt :+ SP Int
i (p
p :+ VertexType
vt)) ->
                     MVector (PrimState (ST s)) (STR (Point 2 r) p VertexType)
-> Int -> STR (Point 2 r) p VertexType -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s (STR (Point 2 r) p VertexType)
MVector (PrimState (ST s)) (STR (Point 2 r) p VertexType)
v Int
i (Point 2 r -> p -> VertexType -> STR (Point 2 r) p VertexType
forall a b c. a -> b -> c -> STR a b c
STR Point 2 r
pt p
p VertexType
vt)
                   MVector s (STR (Point 2 r) p VertexType)
-> ST s (MVector s (STR (Point 2 r) p VertexType))
forall (m :: * -> *) a. Monad m => a -> m a
return MVector s (STR (Point 2 r) p VertexType)
v

    initialSS :: StatusStruct r
initialSS = Set (LineSegment 2 Int r) -> IntMap Int -> StatusStruct r
forall r. Set (LineSegment 2 Int r) -> IntMap Int -> StatusStruct r
SS Set (LineSegment 2 Int r)
forall a. Set a
SS.empty IntMap Int
forall a. Monoid a => a
mempty

    sweep :: NonEmpty (Event r) -> [LineSegment 2 Int r]
sweep  NonEmpty (Event r)
es = (Reader
   (Vector (STR (Point 2 r) p VertexType)) [LineSegment 2 Int r]
 -> Vector (STR (Point 2 r) p VertexType) -> [LineSegment 2 Int r])
-> Vector (STR (Point 2 r) p VertexType)
-> Reader
     (Vector (STR (Point 2 r) p VertexType)) [LineSegment 2 Int r]
-> [LineSegment 2 Int r]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  (Vector (STR (Point 2 r) p VertexType)) [LineSegment 2 Int r]
-> Vector (STR (Point 2 r) p VertexType) -> [LineSegment 2 Int r]
forall r a. Reader r a -> r -> a
runReader Vector (STR (Point 2 r) p VertexType)
vertexInfo (Reader
   (Vector (STR (Point 2 r) p VertexType)) [LineSegment 2 Int r]
 -> [LineSegment 2 Int r])
-> Reader
     (Vector (STR (Point 2 r) p VertexType)) [LineSegment 2 Int r]
-> [LineSegment 2 Int r]
forall a b. (a -> b) -> a -> b
$ StateT
  (StatusStruct r)
  (Reader (Vector (STR (Point 2 r) p VertexType)))
  [LineSegment 2 Int r]
-> StatusStruct r
-> Reader
     (Vector (STR (Point 2 r) p VertexType)) [LineSegment 2 Int r]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (NonEmpty (Event r)
-> StateT
     (StatusStruct r)
     (Reader (Vector (STR (Point 2 r) p VertexType)))
     [LineSegment 2 Int r]
sweep' NonEmpty (Event r)
es) StatusStruct r
forall r. StatusStruct r
initialSS
    sweep' :: NonEmpty (Event r)
-> StateT
     (StatusStruct r)
     (Reader (Vector (STR (Point 2 r) p VertexType)))
     [LineSegment 2 Int r]
sweep' NonEmpty (Event r)
es = DList (LineSegment 2 Int r) -> [LineSegment 2 Int r]
forall a. DList a -> [a]
DList.toList (DList (LineSegment 2 Int r) -> [LineSegment 2 Int r])
-> StateT
     (StatusStruct r)
     (Reader (Vector (STR (Point 2 r) p VertexType)))
     (DList (LineSegment 2 Int r))
-> StateT
     (StatusStruct r)
     (Reader (Vector (STR (Point 2 r) p VertexType)))
     [LineSegment 2 Int r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT
  (DList (LineSegment 2 Int r))
  (StateT
     (StatusStruct r) (Reader (Vector (STR (Point 2 r) p VertexType))))
  ()
-> StateT
     (StatusStruct r)
     (Reader (Vector (STR (Point 2 r) p VertexType)))
     (DList (LineSegment 2 Int r))
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (NonEmpty (Event r)
-> WriterT
     (DList (LineSegment 2 Int r))
     (StateT
        (StatusStruct r) (Reader (Vector (STR (Point 2 r) p VertexType))))
     ()
sweep'' NonEmpty (Event r)
es)

    sweep'' :: NonEmpty.NonEmpty (Event r) -> Sweep p r ()
    sweep'' :: NonEmpty (Event r)
-> WriterT
     (DList (LineSegment 2 Int r))
     (StateT
        (StatusStruct r) (Reader (Vector (STR (Point 2 r) p VertexType))))
     ()
sweep'' = (Event r
 -> WriterT
      (DList (LineSegment 2 Int r))
      (StateT
         (StatusStruct r) (Reader (Vector (STR (Point 2 r) p VertexType))))
      ())
-> NonEmpty (Event r)
-> WriterT
     (DList (LineSegment 2 Int r))
     (StateT
        (StatusStruct r) (Reader (Vector (STR (Point 2 r) p VertexType))))
     ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Event r
-> WriterT
     (DList (LineSegment 2 Int r))
     (StateT
        (StatusStruct r) (Reader (Vector (STR (Point 2 r) p VertexType))))
     ()
forall r p. (Fractional r, Ord r) => Event r -> Sweep p r ()
handle

    -- make everything counterclockwise
    toCCW :: Polygon t p r -> Polygon t p r
toCCW Polygon t p r
p = (Polygon t p r -> Polygon t p r
forall r (t :: PolygonType) p.
(Eq r, Num r) =>
Polygon t p r -> Polygon t p r
toCounterClockWiseOrder' Polygon t p r
p)Polygon t p r -> (Polygon t p r -> Polygon t p r) -> Polygon t p r
forall a b. a -> (a -> b) -> b
&([Polygon 'Simple p r] -> Identity [Polygon 'Simple p r])
-> Polygon t p r -> Identity (Polygon t p r)
forall (t :: PolygonType) p r.
Traversal' (Polygon t p r) [Polygon 'Simple p r]
polygonHoles'(([Polygon 'Simple p r] -> Identity [Polygon 'Simple p r])
 -> Polygon t p r -> Identity (Polygon t p r))
-> ((Polygon 'Simple p r -> Identity (Polygon 'Simple p r))
    -> [Polygon 'Simple p r] -> Identity [Polygon 'Simple p r])
-> (Polygon 'Simple p r -> Identity (Polygon 'Simple p r))
-> Polygon t p r
-> Identity (Polygon t p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Polygon 'Simple p r -> Identity (Polygon 'Simple p r))
-> [Polygon 'Simple p r] -> Identity [Polygon 'Simple p r]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Polygon 'Simple p r -> Identity (Polygon 'Simple p r))
 -> Polygon t p r -> Identity (Polygon t p r))
-> (Polygon 'Simple p r -> Polygon 'Simple p r)
-> Polygon t p r
-> Polygon t p r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Polygon 'Simple p r -> Polygon 'Simple p r
forall r (t :: PolygonType) p.
(Eq r, Num r) =>
Polygon t p r -> Polygon t p r
toCounterClockWiseOrder'
    -- make the holes clockwise:
    holesToCW :: Polygon t p r -> Polygon t p r
holesToCW Polygon t p r
p = Polygon t p r
pPolygon t p r -> (Polygon t p r -> Polygon t p r) -> Polygon t p r
forall a b. a -> (a -> b) -> b
&([Polygon 'Simple p r] -> Identity [Polygon 'Simple p r])
-> Polygon t p r -> Identity (Polygon t p r)
forall (t :: PolygonType) p r.
Traversal' (Polygon t p r) [Polygon 'Simple p r]
polygonHoles'(([Polygon 'Simple p r] -> Identity [Polygon 'Simple p r])
 -> Polygon t p r -> Identity (Polygon t p r))
-> ((Polygon 'Simple p r -> Identity (Polygon 'Simple p r))
    -> [Polygon 'Simple p r] -> Identity [Polygon 'Simple p r])
-> (Polygon 'Simple p r -> Identity (Polygon 'Simple p r))
-> Polygon t p r
-> Identity (Polygon t p r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Polygon 'Simple p r -> Identity (Polygon 'Simple p r))
-> [Polygon 'Simple p r] -> Identity [Polygon 'Simple p r]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Polygon 'Simple p r -> Identity (Polygon 'Simple p r))
 -> Polygon t p r -> Identity (Polygon t p r))
-> (Polygon 'Simple p r -> Polygon 'Simple p r)
-> Polygon t p r
-> Polygon t p r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Polygon 'Simple p r -> Polygon 'Simple p r
forall r (t :: PolygonType) p.
(Eq r, Num r) =>
Polygon t p r -> Polygon t p r
toClockwiseOrder'



-- | Computes a set of diagionals that decompose the polygon into y-monotone
-- pieces.
--
-- pre: the polygon boundary is given in counterClockwise order.
--
-- running time: \(O(n\log n)\)
makeMonotone      :: (Fractional r, Ord r)
                  => proxy s -> Polygon t p r
                  -> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r
makeMonotone :: proxy s
-> Polygon t p r
-> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r
makeMonotone proxy s
px Polygon t p r
pg = let (LineSegment 2 p r
e:[LineSegment 2 p r]
es) = Polygon t p r -> [LineSegment 2 p r]
forall (t :: PolygonType) p r. Polygon t p r -> [LineSegment 2 p r]
listEdges Polygon t p r
pg
                     in proxy s
-> LineSegment 2 p r
-> [LineSegment 2 p r]
-> [LineSegment 2 p r]
-> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r
forall k (proxy :: k -> *) r (s :: k) p.
(Fractional r, Ord r) =>
proxy s
-> LineSegment 2 p r
-> [LineSegment 2 p r]
-> [LineSegment 2 p r]
-> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r
constructSubdivision proxy s
px LineSegment 2 p r
e [LineSegment 2 p r]
es (Polygon t p r -> [LineSegment 2 p r]
forall (t :: PolygonType) r p.
(Fractional r, Ord r) =>
Polygon t p r -> [LineSegment 2 p r]
computeDiagonals Polygon t p r
pg)

type Sweep p r = WriterT (DList.DList (LineSegment 2 Int r))
                   (StateT (StatusStruct r)
                     (Reader (V.Vector (VertexInfo p r))))

type VertexInfo p r = STR (Point 2 r) p VertexType


tell' :: LineSegment 2 Int r -> Sweep p r ()
tell' :: LineSegment 2 Int r -> Sweep p r ()
tell' = DList (LineSegment 2 Int r) -> Sweep p r ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (DList (LineSegment 2 Int r) -> Sweep p r ())
-> (LineSegment 2 Int r -> DList (LineSegment 2 Int r))
-> LineSegment 2 Int r
-> Sweep p r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineSegment 2 Int r -> DList (LineSegment 2 Int r)
forall a. a -> DList a
DList.singleton

getIdx :: Event r -> Int
getIdx :: Event r -> Int
getIdx = Getting Int (Event r) Int -> Event r -> Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Two (LineSegment 2 Int r)
 -> Const Int (Two (LineSegment 2 Int r)))
-> Event r -> Const Int (Event r)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra((Two (LineSegment 2 Int r)
  -> Const Int (Two (LineSegment 2 Int r)))
 -> Event r -> Const Int (Event r))
-> ((Int -> Const Int Int)
    -> Two (LineSegment 2 Int r)
    -> Const Int (Two (LineSegment 2 Int r)))
-> Getting Int (Event r) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
-> Two (LineSegment 2 Int r)
-> Const Int (Two (LineSegment 2 Int r))
forall s t a b. Field1 s t a b => Lens s t a b
_1((LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
 -> Two (LineSegment 2 Int r)
 -> Const Int (Two (LineSegment 2 Int r)))
-> ((Int -> Const Int Int)
    -> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
-> (Int -> Const Int Int)
-> Two (LineSegment 2 Int r)
-> Const Int (Two (LineSegment 2 Int r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
 -> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
-> ((Int -> Const Int Int)
    -> (Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> (Int -> Const Int Int)
-> LineSegment 2 Int r
-> Const Int (LineSegment 2 Int r)
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)

getVertexType   :: Int -> Sweep p r VertexType
getVertexType :: Int -> Sweep p r VertexType
getVertexType Int
v = (Vector (VertexInfo p r) -> VertexType) -> Sweep p r VertexType
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Vector (VertexInfo p r)
-> Getting VertexType (Vector (VertexInfo p r)) VertexType
-> VertexType
forall s a. s -> Getting a s a -> a
^.Int -> Lens' (Vector (VertexInfo p r)) (VertexInfo p r)
forall a. Int -> Lens' (Vector a) a
ix' Int
v((VertexInfo p r -> Const VertexType (VertexInfo p r))
 -> Vector (VertexInfo p r)
 -> Const VertexType (Vector (VertexInfo p r)))
-> ((VertexType -> Const VertexType VertexType)
    -> VertexInfo p r -> Const VertexType (VertexInfo p r))
-> Getting VertexType (Vector (VertexInfo p r)) VertexType
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(VertexType -> Const VertexType VertexType)
-> VertexInfo p r -> Const VertexType (VertexInfo p r)
forall s t a b. Field3 s t a b => Lens s t a b
_3)

getEventType :: Event r -> Sweep p r VertexType
getEventType :: Event r -> Sweep p r VertexType
getEventType = Int -> Sweep p r VertexType
forall p r. Int -> Sweep p r VertexType
getVertexType (Int -> Sweep p r VertexType)
-> (Event r -> Int) -> Event r -> Sweep p r VertexType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event r -> Int
forall r. Event r -> Int
getIdx

handle   :: (Fractional r, Ord r) => Event r -> Sweep p r ()
handle :: Event r -> Sweep p r ()
handle Event r
e = let i :: Int
i = Event r -> Int
forall r. Event r -> Int
getIdx Event r
e in Event r -> Sweep p r VertexType
forall r p. Event r -> Sweep p r VertexType
getEventType Event r
e Sweep p r VertexType
-> (VertexType -> Sweep p r ()) -> Sweep p r ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    VertexType
Start   -> Int -> Event r -> Sweep p r ()
forall r p. (Fractional r, Ord r) => Int -> Event r -> Sweep p r ()
handleStart   Int
i Event r
e
    VertexType
End     -> Int -> Event r -> Sweep p r ()
forall r p. (Fractional r, Ord r) => Int -> Event r -> Sweep p r ()
handleEnd     Int
i Event r
e
    VertexType
Split   -> Int -> Event r -> Sweep p r ()
forall r p. (Fractional r, Ord r) => Int -> Event r -> Sweep p r ()
handleSplit   Int
i Event r
e
    VertexType
Merge   -> Int -> Event r -> Sweep p r ()
forall r p. (Fractional r, Ord r) => Int -> Event r -> Sweep p r ()
handleMerge   Int
i Event r
e
    VertexType
Regular | Int -> Event r -> Bool
forall r. Ord r => Int -> Event r -> Bool
isLeftVertex Int
i Event r
e -> Int -> Event r -> Sweep p r ()
forall r p. (Fractional r, Ord r) => Int -> Event r -> Sweep p r ()
handleRegularL Int
i Event r
e
            | Bool
otherwise        -> Int -> Event r -> Sweep p r ()
forall r p. (Fractional r, Ord r) => Int -> Event r -> Sweep p r ()
handleRegularR Int
i Event r
e


insertAt   :: (Ord r, Fractional r) => Point 2 r -> LineSegment 2 q r
           -> SS.Set (LineSegment 2 q r) -> SS.Set (LineSegment 2 q r)
insertAt :: Point 2 r
-> LineSegment 2 q r
-> Set (LineSegment 2 q r)
-> Set (LineSegment 2 q r)
insertAt Point 2 r
v = (LineSegment 2 q r -> LineSegment 2 q r -> Ordering)
-> LineSegment 2 q r
-> Set (LineSegment 2 q r)
-> Set (LineSegment 2 q r)
forall a. (a -> a -> Ordering) -> a -> Set a -> Set a
SS.insertBy (r -> LineSegment 2 q r -> LineSegment 2 q r -> Ordering
forall r p.
(Fractional r, Ord r) =>
r -> Compare (LineSegment 2 p r)
ordAt (r -> LineSegment 2 q r -> LineSegment 2 q r -> Ordering)
-> r -> LineSegment 2 q r -> LineSegment 2 q r -> Ordering
forall a b. (a -> b) -> a -> b
$ Point 2 r
vPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord)

deleteAt   :: (Fractional r, Ord r) => Point 2 r -> LineSegment 2 p r
           -> SS.Set (LineSegment 2 p r) -> SS.Set (LineSegment 2 p r)
deleteAt :: Point 2 r
-> LineSegment 2 p r
-> Set (LineSegment 2 p r)
-> Set (LineSegment 2 p r)
deleteAt Point 2 r
v = (LineSegment 2 p r -> LineSegment 2 p r -> Ordering)
-> LineSegment 2 p r
-> Set (LineSegment 2 p r)
-> Set (LineSegment 2 p r)
forall a. (a -> a -> Ordering) -> a -> Set a -> Set a
SS.deleteAllBy (r -> LineSegment 2 p r -> LineSegment 2 p r -> Ordering
forall r p.
(Fractional r, Ord r) =>
r -> Compare (LineSegment 2 p r)
ordAt (r -> LineSegment 2 p r -> LineSegment 2 p r -> Ordering)
-> r -> LineSegment 2 p r -> LineSegment 2 p r -> Ordering
forall a b. (a -> b) -> a -> b
$ Point 2 r
vPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord)


handleStart              :: (Fractional r, Ord r)
                         => Int -> Event r -> Sweep p r ()
handleStart :: Int -> Event r -> Sweep p r ()
handleStart Int
i (Point 2 r
v :+ Two (LineSegment 2 Int r)
adj) = (StatusStruct r -> StatusStruct r) -> Sweep p r ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((StatusStruct r -> StatusStruct r) -> Sweep p r ())
-> (StatusStruct r -> StatusStruct r) -> Sweep p r ()
forall a b. (a -> b) -> a -> b
$ \(SS Set (LineSegment 2 Int r)
t IntMap Int
h) ->
                                Set (LineSegment 2 Int r) -> IntMap Int -> StatusStruct r
forall r. Set (LineSegment 2 Int r) -> IntMap Int -> StatusStruct r
SS (Point 2 r
-> LineSegment 2 Int r
-> Set (LineSegment 2 Int r)
-> Set (LineSegment 2 Int r)
forall r q.
(Ord r, Fractional r) =>
Point 2 r
-> LineSegment 2 q r
-> Set (LineSegment 2 q r)
-> Set (LineSegment 2 q r)
insertAt Point 2 r
v (Two (LineSegment 2 Int r)
adjTwo (LineSegment 2 Int r)
-> Getting
     (LineSegment 2 Int r)
     (Two (LineSegment 2 Int r))
     (LineSegment 2 Int r)
-> LineSegment 2 Int r
forall s a. s -> Getting a s a -> a
^.Getting
  (LineSegment 2 Int r)
  (Two (LineSegment 2 Int r))
  (LineSegment 2 Int r)
forall s t a b. Field2 s t a b => Lens s t a b
_2) Set (LineSegment 2 Int r)
t)
                                   (Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
i Int
i IntMap Int
h)

handleEnd              :: (Fractional r, Ord r)
                       => Int -> Event r -> Sweep p r ()
handleEnd :: Int -> Event r -> Sweep p r ()
handleEnd Int
i (Point 2 r
v :+ Two (LineSegment 2 Int r)
adj) = do let iPred :: Int
iPred = Two (LineSegment 2 Int r)
adjTwo (LineSegment 2 Int r)
-> Getting Int (Two (LineSegment 2 Int r)) Int -> Int
forall s a. s -> Getting a s a -> a
^.(LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
-> Two (LineSegment 2 Int r)
-> Const Int (Two (LineSegment 2 Int r))
forall s t a b. Field1 s t a b => Lens s t a b
_1((LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
 -> Two (LineSegment 2 Int r)
 -> Const Int (Two (LineSegment 2 Int r)))
-> ((Int -> Const Int Int)
    -> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
-> Getting Int (Two (LineSegment 2 Int r)) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
 -> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
-> ((Int -> Const Int Int)
    -> (Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> (Int -> Const Int Int)
-> LineSegment 2 Int r
-> Const Int (LineSegment 2 Int r)
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  -- i-1
                            -- lookup p's helper; if it is a merge vertex
                            -- we insert a new segment
                            Int -> Point 2 r -> Int -> Sweep p r ()
forall r p. Int -> Point 2 r -> Int -> Sweep p r ()
tellIfMerge Int
i Point 2 r
v Int
iPred
                            -- delete e_{i-1} from the status struct
                            (StatusStruct r -> StatusStruct r) -> Sweep p r ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((StatusStruct r -> StatusStruct r) -> Sweep p r ())
-> (StatusStruct r -> StatusStruct r) -> Sweep p r ()
forall a b. (a -> b) -> a -> b
$ \StatusStruct r
ss ->
                              StatusStruct r
ssStatusStruct r
-> (StatusStruct r -> StatusStruct r) -> StatusStruct r
forall a b. a -> (a -> b) -> b
&(Set (LineSegment 2 Int r) -> Identity (Set (LineSegment 2 Int r)))
-> StatusStruct r -> Identity (StatusStruct r)
forall r r.
Lens
  (StatusStruct r)
  (StatusStruct r)
  (Set (LineSegment 2 Int r))
  (Set (LineSegment 2 Int r))
statusStruct ((Set (LineSegment 2 Int r)
  -> Identity (Set (LineSegment 2 Int r)))
 -> StatusStruct r -> Identity (StatusStruct r))
-> (Set (LineSegment 2 Int r) -> Set (LineSegment 2 Int r))
-> StatusStruct r
-> StatusStruct r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Point 2 r
-> LineSegment 2 Int r
-> Set (LineSegment 2 Int r)
-> Set (LineSegment 2 Int r)
forall r p.
(Fractional r, Ord r) =>
Point 2 r
-> LineSegment 2 p r
-> Set (LineSegment 2 p r)
-> Set (LineSegment 2 p r)
deleteAt Point 2 r
v (Two (LineSegment 2 Int r)
adjTwo (LineSegment 2 Int r)
-> Getting
     (LineSegment 2 Int r)
     (Two (LineSegment 2 Int r))
     (LineSegment 2 Int r)
-> LineSegment 2 Int r
forall s a. s -> Getting a s a -> a
^.Getting
  (LineSegment 2 Int r)
  (Two (LineSegment 2 Int r))
  (LineSegment 2 Int r)
forall s t a b. Field1 s t a b => Lens s t a b
_1)

-- | Adds edge (i,j) if e_j's helper is a merge vertex
tellIfMerge       :: Int -> Point 2 r -> Int -> Sweep p r ()
tellIfMerge :: Int -> Point 2 r -> Int -> Sweep p r ()
tellIfMerge Int
i Point 2 r
v Int
j = do SP Point 2 r :+ Int
u VertexType
ut <- Int -> Sweep p r (SP (Point 2 r :+ Int) VertexType)
forall p r. Int -> Sweep p r (SP (Point 2 r :+ Int) VertexType)
getHelper Int
j
                       Bool -> Sweep p r () -> Sweep p r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VertexType
ut VertexType -> VertexType -> Bool
forall a. Eq a => a -> a -> Bool
== VertexType
Merge) (LineSegment 2 Int r -> Sweep p r ()
forall r p. LineSegment 2 Int r -> Sweep p r ()
tell' (LineSegment 2 Int r -> Sweep p r ())
-> LineSegment 2 Int r -> Sweep p r ()
forall a b. (a -> b) -> a -> b
$ (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
ClosedLineSegment (Point 2 r
v Point 2 r -> Int -> Point 2 r :+ Int
forall core extra. core -> extra -> core :+ extra
:+ Int
i) Point 2 r :+ Int
u)

-- | Get the helper of edge i, and its vertex type
getHelper   :: Int -> Sweep p r (SP (Point 2 r :+ Int) VertexType)
getHelper :: Int -> Sweep p r (SP (Point 2 r :+ Int) VertexType)
getHelper Int
i = do Int
ui         <- (StatusStruct r -> Int)
-> WriterT
     (DList (LineSegment 2 Int r))
     (StateT (StatusStruct r) (Reader (Vector (VertexInfo p r))))
     Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StatusStruct r -> Getting (Endo Int) (StatusStruct r) Int -> Int
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?!(IntMap Int -> Const (Endo Int) (IntMap Int))
-> StatusStruct r -> Const (Endo Int) (StatusStruct r)
forall r. Lens' (StatusStruct r) (IntMap Int)
helper((IntMap Int -> Const (Endo Int) (IntMap Int))
 -> StatusStruct r -> Const (Endo Int) (StatusStruct r))
-> ((Int -> Const (Endo Int) Int)
    -> IntMap Int -> Const (Endo Int) (IntMap Int))
-> Getting (Endo Int) (StatusStruct r) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Index (IntMap Int)
-> Traversal' (IntMap Int) (IxValue (IntMap Int))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
Index (IntMap Int)
i)
                 STR Point 2 r
u p
_ VertexType
ut <- (Vector (VertexInfo p r) -> VertexInfo p r)
-> WriterT
     (DList (LineSegment 2 Int r))
     (StateT (StatusStruct r) (Reader (Vector (VertexInfo p r))))
     (VertexInfo p r)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Vector (VertexInfo p r)
-> Getting
     (VertexInfo p r) (Vector (VertexInfo p r)) (VertexInfo p r)
-> VertexInfo p r
forall s a. s -> Getting a s a -> a
^.Int -> Lens' (Vector (VertexInfo p r)) (VertexInfo p r)
forall a. Int -> Lens' (Vector a) a
ix' Int
ui)
                 SP (Point 2 r :+ Int) VertexType
-> Sweep p r (SP (Point 2 r :+ Int) VertexType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SP (Point 2 r :+ Int) VertexType
 -> Sweep p r (SP (Point 2 r :+ Int) VertexType))
-> SP (Point 2 r :+ Int) VertexType
-> Sweep p r (SP (Point 2 r :+ Int) VertexType)
forall a b. (a -> b) -> a -> b
$ (Point 2 r :+ Int)
-> VertexType -> SP (Point 2 r :+ Int) VertexType
forall a b. a -> b -> SP a b
SP (Point 2 r
u Point 2 r -> Int -> Point 2 r :+ Int
forall core extra. core -> extra -> core :+ extra
:+ Int
ui) VertexType
ut


lookupLE     :: (Ord r, Fractional r)
             => Point 2 r -> SS.Set (LineSegment 2 Int r)
             -> Maybe (LineSegment 2 Int r)
lookupLE :: Point 2 r
-> Set (LineSegment 2 Int r) -> Maybe (LineSegment 2 Int r)
lookupLE Point 2 r
v Set (LineSegment 2 Int r)
s = let (Set (LineSegment 2 Int r)
l,Set (LineSegment 2 Int r)
m,Set (LineSegment 2 Int r)
_) = (LineSegment 2 Int r -> r)
-> r
-> Set (LineSegment 2 Int r)
-> (Set (LineSegment 2 Int r), Set (LineSegment 2 Int r),
    Set (LineSegment 2 Int r))
forall b a.
Ord b =>
(a -> b) -> b -> Set a -> (Set a, Set a, Set a)
SS.splitOn (r -> LineSegment 2 Int r -> r
forall r p. (Fractional r, Ord r) => r -> LineSegment 2 p r -> r
xCoordAt (r -> LineSegment 2 Int r -> r) -> r -> LineSegment 2 Int r -> r
forall a b. (a -> b) -> a -> b
$ Point 2 r
vPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord) (Point 2 r
vPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord) Set (LineSegment 2 Int r)
s
               in Set (LineSegment 2 Int r) -> Maybe (LineSegment 2 Int r)
forall a. Set a -> Maybe a
SS.lookupMax (Set (LineSegment 2 Int r)
l Set (LineSegment 2 Int r)
-> Set (LineSegment 2 Int r) -> Set (LineSegment 2 Int r)
forall a. Set a -> Set a -> Set a
`SS.join` Set (LineSegment 2 Int r)
m)


handleSplit              :: (Fractional r, Ord r) => Int -> Event r -> Sweep p r ()
handleSplit :: Int -> Event r -> Sweep p r ()
handleSplit Int
i (Point 2 r
v :+ Two (LineSegment 2 Int r)
adj) = do LineSegment 2 Int r
ej <- (StatusStruct r -> LineSegment 2 Int r)
-> WriterT
     (DList (LineSegment 2 Int r))
     (StateT (StatusStruct r) (Reader (Vector (VertexInfo p r))))
     (LineSegment 2 Int r)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((StatusStruct r -> LineSegment 2 Int r)
 -> WriterT
      (DList (LineSegment 2 Int r))
      (StateT (StatusStruct r) (Reader (Vector (VertexInfo p r))))
      (LineSegment 2 Int r))
-> (StatusStruct r -> LineSegment 2 Int r)
-> WriterT
     (DList (LineSegment 2 Int r))
     (StateT (StatusStruct r) (Reader (Vector (VertexInfo p r))))
     (LineSegment 2 Int r)
forall a b. (a -> b) -> a -> b
$ \StatusStruct r
ss -> StatusStruct r
ssStatusStruct r
-> Getting
     (Endo (LineSegment 2 Int r)) (StatusStruct r) (LineSegment 2 Int r)
-> LineSegment 2 Int r
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?!(Set (LineSegment 2 Int r)
 -> Const (Endo (LineSegment 2 Int r)) (Set (LineSegment 2 Int r)))
-> StatusStruct r
-> Const (Endo (LineSegment 2 Int r)) (StatusStruct r)
forall r r.
Lens
  (StatusStruct r)
  (StatusStruct r)
  (Set (LineSegment 2 Int r))
  (Set (LineSegment 2 Int r))
statusStruct((Set (LineSegment 2 Int r)
  -> Const (Endo (LineSegment 2 Int r)) (Set (LineSegment 2 Int r)))
 -> StatusStruct r
 -> Const (Endo (LineSegment 2 Int r)) (StatusStruct r))
-> ((LineSegment 2 Int r
     -> Const (Endo (LineSegment 2 Int r)) (LineSegment 2 Int r))
    -> Set (LineSegment 2 Int r)
    -> Const (Endo (LineSegment 2 Int r)) (Set (LineSegment 2 Int r)))
-> Getting
     (Endo (LineSegment 2 Int r)) (StatusStruct r) (LineSegment 2 Int r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Set (LineSegment 2 Int r) -> Maybe (LineSegment 2 Int r))
-> Optic'
     (->)
     (Const (Endo (LineSegment 2 Int r)))
     (Set (LineSegment 2 Int r))
     (Maybe (LineSegment 2 Int r))
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Point 2 r
-> Set (LineSegment 2 Int r) -> Maybe (LineSegment 2 Int r)
forall r.
(Ord r, Fractional r) =>
Point 2 r
-> Set (LineSegment 2 Int r) -> Maybe (LineSegment 2 Int r)
lookupLE Point 2 r
v)Optic'
  (->)
  (Const (Endo (LineSegment 2 Int r)))
  (Set (LineSegment 2 Int r))
  (Maybe (LineSegment 2 Int r))
-> ((LineSegment 2 Int r
     -> Const (Endo (LineSegment 2 Int r)) (LineSegment 2 Int r))
    -> Maybe (LineSegment 2 Int r)
    -> Const
         (Endo (LineSegment 2 Int r)) (Maybe (LineSegment 2 Int r)))
-> (LineSegment 2 Int r
    -> Const (Endo (LineSegment 2 Int r)) (LineSegment 2 Int r))
-> Set (LineSegment 2 Int r)
-> Const (Endo (LineSegment 2 Int r)) (Set (LineSegment 2 Int r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LineSegment 2 Int r
 -> Const (Endo (LineSegment 2 Int r)) (LineSegment 2 Int r))
-> Maybe (LineSegment 2 Int r)
-> Const (Endo (LineSegment 2 Int r)) (Maybe (LineSegment 2 Int r))
forall a b. Prism (Maybe a) (Maybe b) a b
_Just
                              let j :: Int
j = LineSegment 2 Int r
ejLineSegment 2 Int r -> Getting Int (LineSegment 2 Int r) Int -> Int
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
 -> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
-> ((Int -> Const Int Int)
    -> (Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> Getting Int (LineSegment 2 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
                              SP Point 2 r :+ Int
u VertexType
_ <- Int -> Sweep p r (SP (Point 2 r :+ Int) VertexType)
forall p r. Int -> Sweep p r (SP (Point 2 r :+ Int) VertexType)
getHelper Int
j
                              -- update the status struct:
                              -- insert the new edge into the status Struct and
                              -- set the helper of e_j to be v_i
                              (StatusStruct r -> StatusStruct r) -> Sweep p r ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((StatusStruct r -> StatusStruct r) -> Sweep p r ())
-> (StatusStruct r -> StatusStruct r) -> Sweep p r ()
forall a b. (a -> b) -> a -> b
$ \(SS Set (LineSegment 2 Int r)
t IntMap Int
h) ->
                                Set (LineSegment 2 Int r) -> IntMap Int -> StatusStruct r
forall r. Set (LineSegment 2 Int r) -> IntMap Int -> StatusStruct r
SS (Point 2 r
-> LineSegment 2 Int r
-> Set (LineSegment 2 Int r)
-> Set (LineSegment 2 Int r)
forall r q.
(Ord r, Fractional r) =>
Point 2 r
-> LineSegment 2 q r
-> Set (LineSegment 2 q r)
-> Set (LineSegment 2 q r)
insertAt Point 2 r
v (Two (LineSegment 2 Int r)
adjTwo (LineSegment 2 Int r)
-> Getting
     (LineSegment 2 Int r)
     (Two (LineSegment 2 Int r))
     (LineSegment 2 Int r)
-> LineSegment 2 Int r
forall s a. s -> Getting a s a -> a
^.Getting
  (LineSegment 2 Int r)
  (Two (LineSegment 2 Int r))
  (LineSegment 2 Int r)
forall s t a b. Field2 s t a b => Lens s t a b
_2) Set (LineSegment 2 Int r)
t)
                                   (Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
i Int
i (IntMap Int -> IntMap Int)
-> (IntMap Int -> IntMap Int) -> IntMap Int -> IntMap Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
j Int
i (IntMap Int -> IntMap Int) -> IntMap Int -> IntMap Int
forall a b. (a -> b) -> a -> b
$ IntMap Int
h)
                              -- return the diagonal
                              LineSegment 2 Int r -> Sweep p r ()
forall r p. LineSegment 2 Int r -> Sweep p r ()
tell' (LineSegment 2 Int r -> Sweep p r ())
-> LineSegment 2 Int r -> Sweep p r ()
forall a b. (a -> b) -> a -> b
$ (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
ClosedLineSegment (Point 2 r
v Point 2 r -> Int -> Point 2 r :+ Int
forall core extra. core -> extra -> core :+ extra
:+ Int
i) Point 2 r :+ Int
u

handleMerge              :: (Fractional r, Ord r) => Int -> Event r -> Sweep p r ()
handleMerge :: Int -> Event r -> Sweep p r ()
handleMerge Int
i (Point 2 r
v :+ Two (LineSegment 2 Int r)
adj) = do let ePred :: Int
ePred = Two (LineSegment 2 Int r)
adjTwo (LineSegment 2 Int r)
-> Getting Int (Two (LineSegment 2 Int r)) Int -> Int
forall s a. s -> Getting a s a -> a
^.(LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
-> Two (LineSegment 2 Int r)
-> Const Int (Two (LineSegment 2 Int r))
forall s t a b. Field1 s t a b => Lens s t a b
_1((LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
 -> Two (LineSegment 2 Int r)
 -> Const Int (Two (LineSegment 2 Int r)))
-> ((Int -> Const Int Int)
    -> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
-> Getting Int (Two (LineSegment 2 Int r)) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
 -> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
-> ((Int -> Const Int Int)
    -> (Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> (Int -> Const Int Int)
-> LineSegment 2 Int r
-> Const Int (LineSegment 2 Int r)
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 -- i-1
                              Int -> Point 2 r -> Int -> Sweep p r ()
forall r p. Int -> Point 2 r -> Int -> Sweep p r ()
tellIfMerge Int
i Point 2 r
v Int
ePred
                              -- delete e_{i-1} from the status struct
                              (StatusStruct r -> StatusStruct r) -> Sweep p r ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((StatusStruct r -> StatusStruct r) -> Sweep p r ())
-> (StatusStruct r -> StatusStruct r) -> Sweep p r ()
forall a b. (a -> b) -> a -> b
$ \StatusStruct r
ss -> StatusStruct r
ssStatusStruct r
-> (StatusStruct r -> StatusStruct r) -> StatusStruct r
forall a b. a -> (a -> b) -> b
&(Set (LineSegment 2 Int r) -> Identity (Set (LineSegment 2 Int r)))
-> StatusStruct r -> Identity (StatusStruct r)
forall r r.
Lens
  (StatusStruct r)
  (StatusStruct r)
  (Set (LineSegment 2 Int r))
  (Set (LineSegment 2 Int r))
statusStruct ((Set (LineSegment 2 Int r)
  -> Identity (Set (LineSegment 2 Int r)))
 -> StatusStruct r -> Identity (StatusStruct r))
-> (Set (LineSegment 2 Int r) -> Set (LineSegment 2 Int r))
-> StatusStruct r
-> StatusStruct r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Point 2 r
-> LineSegment 2 Int r
-> Set (LineSegment 2 Int r)
-> Set (LineSegment 2 Int r)
forall r p.
(Fractional r, Ord r) =>
Point 2 r
-> LineSegment 2 p r
-> Set (LineSegment 2 p r)
-> Set (LineSegment 2 p r)
deleteAt Point 2 r
v (Two (LineSegment 2 Int r)
adjTwo (LineSegment 2 Int r)
-> Getting
     (LineSegment 2 Int r)
     (Two (LineSegment 2 Int r))
     (LineSegment 2 Int r)
-> LineSegment 2 Int r
forall s a. s -> Getting a s a -> a
^.Getting
  (LineSegment 2 Int r)
  (Two (LineSegment 2 Int r))
  (LineSegment 2 Int r)
forall s t a b. Field1 s t a b => Lens s t a b
_1)
                              Int -> Point 2 r -> Sweep p r ()
forall r p.
(Fractional r, Ord r) =>
Int -> Point 2 r -> Sweep p r ()
connectToLeft Int
i Point 2 r
v

-- | finds the edge j to the left of v_i, and connect v_i to it if the helper
-- of j is a merge vertex
connectToLeft     :: (Fractional r, Ord r) => Int -> Point 2 r -> Sweep p r ()
connectToLeft :: Int -> Point 2 r -> Sweep p r ()
connectToLeft Int
i Point 2 r
v = do LineSegment 2 Int r
ej <- (StatusStruct r -> LineSegment 2 Int r)
-> WriterT
     (DList (LineSegment 2 Int r))
     (StateT (StatusStruct r) (Reader (Vector (VertexInfo p r))))
     (LineSegment 2 Int r)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((StatusStruct r -> LineSegment 2 Int r)
 -> WriterT
      (DList (LineSegment 2 Int r))
      (StateT (StatusStruct r) (Reader (Vector (VertexInfo p r))))
      (LineSegment 2 Int r))
-> (StatusStruct r -> LineSegment 2 Int r)
-> WriterT
     (DList (LineSegment 2 Int r))
     (StateT (StatusStruct r) (Reader (Vector (VertexInfo p r))))
     (LineSegment 2 Int r)
forall a b. (a -> b) -> a -> b
$ \StatusStruct r
ss -> StatusStruct r
ssStatusStruct r
-> Getting
     (Endo (LineSegment 2 Int r)) (StatusStruct r) (LineSegment 2 Int r)
-> LineSegment 2 Int r
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?!(Set (LineSegment 2 Int r)
 -> Const (Endo (LineSegment 2 Int r)) (Set (LineSegment 2 Int r)))
-> StatusStruct r
-> Const (Endo (LineSegment 2 Int r)) (StatusStruct r)
forall r r.
Lens
  (StatusStruct r)
  (StatusStruct r)
  (Set (LineSegment 2 Int r))
  (Set (LineSegment 2 Int r))
statusStruct((Set (LineSegment 2 Int r)
  -> Const (Endo (LineSegment 2 Int r)) (Set (LineSegment 2 Int r)))
 -> StatusStruct r
 -> Const (Endo (LineSegment 2 Int r)) (StatusStruct r))
-> ((LineSegment 2 Int r
     -> Const (Endo (LineSegment 2 Int r)) (LineSegment 2 Int r))
    -> Set (LineSegment 2 Int r)
    -> Const (Endo (LineSegment 2 Int r)) (Set (LineSegment 2 Int r)))
-> Getting
     (Endo (LineSegment 2 Int r)) (StatusStruct r) (LineSegment 2 Int r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Set (LineSegment 2 Int r) -> Maybe (LineSegment 2 Int r))
-> Optic'
     (->)
     (Const (Endo (LineSegment 2 Int r)))
     (Set (LineSegment 2 Int r))
     (Maybe (LineSegment 2 Int r))
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Point 2 r
-> Set (LineSegment 2 Int r) -> Maybe (LineSegment 2 Int r)
forall r.
(Ord r, Fractional r) =>
Point 2 r
-> Set (LineSegment 2 Int r) -> Maybe (LineSegment 2 Int r)
lookupLE Point 2 r
v)Optic'
  (->)
  (Const (Endo (LineSegment 2 Int r)))
  (Set (LineSegment 2 Int r))
  (Maybe (LineSegment 2 Int r))
-> ((LineSegment 2 Int r
     -> Const (Endo (LineSegment 2 Int r)) (LineSegment 2 Int r))
    -> Maybe (LineSegment 2 Int r)
    -> Const
         (Endo (LineSegment 2 Int r)) (Maybe (LineSegment 2 Int r)))
-> (LineSegment 2 Int r
    -> Const (Endo (LineSegment 2 Int r)) (LineSegment 2 Int r))
-> Set (LineSegment 2 Int r)
-> Const (Endo (LineSegment 2 Int r)) (Set (LineSegment 2 Int r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LineSegment 2 Int r
 -> Const (Endo (LineSegment 2 Int r)) (LineSegment 2 Int r))
-> Maybe (LineSegment 2 Int r)
-> Const (Endo (LineSegment 2 Int r)) (Maybe (LineSegment 2 Int r))
forall a b. Prism (Maybe a) (Maybe b) a b
_Just
                       let j :: Int
j = LineSegment 2 Int r
ejLineSegment 2 Int r -> Getting Int (LineSegment 2 Int r) Int -> Int
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
 -> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
-> ((Int -> Const Int Int)
    -> (Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> Getting Int (LineSegment 2 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 -> Point 2 r -> Int -> Sweep p r ()
forall r p. Int -> Point 2 r -> Int -> Sweep p r ()
tellIfMerge Int
i Point 2 r
v Int
j
                       (StatusStruct r -> StatusStruct r) -> Sweep p r ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((StatusStruct r -> StatusStruct r) -> Sweep p r ())
-> (StatusStruct r -> StatusStruct r) -> Sweep p r ()
forall a b. (a -> b) -> a -> b
$ \StatusStruct r
ss -> StatusStruct r
ssStatusStruct r
-> (StatusStruct r -> StatusStruct r) -> StatusStruct r
forall a b. a -> (a -> b) -> b
&(IntMap Int -> Identity (IntMap Int))
-> StatusStruct r -> Identity (StatusStruct r)
forall r. Lens' (StatusStruct r) (IntMap Int)
helper ((IntMap Int -> Identity (IntMap Int))
 -> StatusStruct r -> Identity (StatusStruct r))
-> (IntMap Int -> IntMap Int) -> StatusStruct r -> StatusStruct r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
j Int
i

-- | returns True if v the interior of the polygon is to the right of v
isLeftVertex              :: Ord r => Int -> Event r -> Bool
isLeftVertex :: Int -> Event r -> Bool
isLeftVertex Int
i (Point 2 r
v :+ Two (LineSegment 2 Int r)
adj) = case (Two (LineSegment 2 Int r)
adjTwo (LineSegment 2 Int r)
-> Getting
     (Point 2 r :+ Int) (Two (LineSegment 2 Int r)) (Point 2 r :+ Int)
-> Point 2 r :+ Int
forall s a. s -> Getting a s a -> a
^.(LineSegment 2 Int r
 -> Const (Point 2 r :+ Int) (LineSegment 2 Int r))
-> Two (LineSegment 2 Int r)
-> Const (Point 2 r :+ Int) (Two (LineSegment 2 Int r))
forall s t a b. Field1 s t a b => Lens s t a b
_1((LineSegment 2 Int r
  -> Const (Point 2 r :+ Int) (LineSegment 2 Int r))
 -> Two (LineSegment 2 Int r)
 -> Const (Point 2 r :+ Int) (Two (LineSegment 2 Int r)))
-> (((Point 2 r :+ Int)
     -> Const (Point 2 r :+ Int) (Point 2 r :+ Int))
    -> LineSegment 2 Int r
    -> Const (Point 2 r :+ Int) (LineSegment 2 Int r))
-> Getting
     (Point 2 r :+ Int) (Two (LineSegment 2 Int r)) (Point 2 r :+ Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Point 2 r :+ Int) -> Const (Point 2 r :+ Int) (Point 2 r :+ Int))
-> LineSegment 2 Int r
-> Const (Point 2 r :+ Int) (LineSegment 2 Int r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start) (Point 2 r :+ Int) -> (Point 2 r :+ Int) -> Ordering
forall r e.
Ord r =>
(Point 2 r :+ e) -> (Point 2 r :+ e) -> Ordering
`cmpSweep` (Point 2 r
v Point 2 r -> Int -> Point 2 r :+ Int
forall core extra. core -> extra -> core :+ extra
:+ Int
i) of
                              Ordering
GT -> Bool
True
                              Ordering
_  -> Bool
False
  -- if the predecessor occurs before the sweep, this must be a left vertex

handleRegularL              :: (Fractional r, Ord r) => Int -> Event r -> Sweep p r ()
handleRegularL :: Int -> Event r -> Sweep p r ()
handleRegularL Int
i (Point 2 r
v :+ Two (LineSegment 2 Int r)
adj) = do let ePred :: Int
ePred = Two (LineSegment 2 Int r)
adjTwo (LineSegment 2 Int r)
-> Getting Int (Two (LineSegment 2 Int r)) Int -> Int
forall s a. s -> Getting a s a -> a
^.(LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
-> Two (LineSegment 2 Int r)
-> Const Int (Two (LineSegment 2 Int r))
forall s t a b. Field1 s t a b => Lens s t a b
_1((LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
 -> Two (LineSegment 2 Int r)
 -> Const Int (Two (LineSegment 2 Int r)))
-> ((Int -> Const Int Int)
    -> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
-> Getting Int (Two (LineSegment 2 Int r)) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
 -> LineSegment 2 Int r -> Const Int (LineSegment 2 Int r))
-> ((Int -> Const Int Int)
    -> (Point 2 r :+ Int) -> Const Int (Point 2 r :+ Int))
-> (Int -> Const Int Int)
-> LineSegment 2 Int r
-> Const Int (LineSegment 2 Int r)
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 -- i-1
                                 Int -> Point 2 r -> Int -> Sweep p r ()
forall r p. Int -> Point 2 r -> Int -> Sweep p r ()
tellIfMerge Int
i Point 2 r
v Int
ePred
                                 -- delete e_{i-1} from the status struct
                                 (StatusStruct r -> StatusStruct r) -> Sweep p r ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((StatusStruct r -> StatusStruct r) -> Sweep p r ())
-> (StatusStruct r -> StatusStruct r) -> Sweep p r ()
forall a b. (a -> b) -> a -> b
$ \StatusStruct r
ss ->
                                   StatusStruct r
ssStatusStruct r
-> (StatusStruct r -> StatusStruct r) -> StatusStruct r
forall a b. a -> (a -> b) -> b
&(Set (LineSegment 2 Int r) -> Identity (Set (LineSegment 2 Int r)))
-> StatusStruct r -> Identity (StatusStruct r)
forall r r.
Lens
  (StatusStruct r)
  (StatusStruct r)
  (Set (LineSegment 2 Int r))
  (Set (LineSegment 2 Int r))
statusStruct ((Set (LineSegment 2 Int r)
  -> Identity (Set (LineSegment 2 Int r)))
 -> StatusStruct r -> Identity (StatusStruct r))
-> (Set (LineSegment 2 Int r) -> Set (LineSegment 2 Int r))
-> StatusStruct r
-> StatusStruct r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Point 2 r
-> LineSegment 2 Int r
-> Set (LineSegment 2 Int r)
-> Set (LineSegment 2 Int r)
forall r p.
(Fractional r, Ord r) =>
Point 2 r
-> LineSegment 2 p r
-> Set (LineSegment 2 p r)
-> Set (LineSegment 2 p r)
deleteAt Point 2 r
v (Two (LineSegment 2 Int r)
adjTwo (LineSegment 2 Int r)
-> Getting
     (LineSegment 2 Int r)
     (Two (LineSegment 2 Int r))
     (LineSegment 2 Int r)
-> LineSegment 2 Int r
forall s a. s -> Getting a s a -> a
^.Getting
  (LineSegment 2 Int r)
  (Two (LineSegment 2 Int r))
  (LineSegment 2 Int r)
forall s t a b. Field1 s t a b => Lens s t a b
_1)
                                 -- insert a e_i in the status struct, and set its helper
                                 -- to be v_i
                                 (StatusStruct r -> StatusStruct r) -> Sweep p r ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((StatusStruct r -> StatusStruct r) -> Sweep p r ())
-> (StatusStruct r -> StatusStruct r) -> Sweep p r ()
forall a b. (a -> b) -> a -> b
$ \(SS Set (LineSegment 2 Int r)
t IntMap Int
h) ->
                                     Set (LineSegment 2 Int r) -> IntMap Int -> StatusStruct r
forall r. Set (LineSegment 2 Int r) -> IntMap Int -> StatusStruct r
SS (Point 2 r
-> LineSegment 2 Int r
-> Set (LineSegment 2 Int r)
-> Set (LineSegment 2 Int r)
forall r q.
(Ord r, Fractional r) =>
Point 2 r
-> LineSegment 2 q r
-> Set (LineSegment 2 q r)
-> Set (LineSegment 2 q r)
insertAt Point 2 r
v (Two (LineSegment 2 Int r)
adjTwo (LineSegment 2 Int r)
-> Getting
     (LineSegment 2 Int r)
     (Two (LineSegment 2 Int r))
     (LineSegment 2 Int r)
-> LineSegment 2 Int r
forall s a. s -> Getting a s a -> a
^.Getting
  (LineSegment 2 Int r)
  (Two (LineSegment 2 Int r))
  (LineSegment 2 Int r)
forall s t a b. Field2 s t a b => Lens s t a b
_2) Set (LineSegment 2 Int r)
t)
                                        (Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
i Int
i IntMap Int
h)

handleRegularR            :: (Fractional r, Ord r) => Int -> Event r -> Sweep p r ()
handleRegularR :: Int -> Event r -> Sweep p r ()
handleRegularR Int
i (Point 2 r
v :+ Two (LineSegment 2 Int r)
_) = Int -> Point 2 r -> Sweep p r ()
forall r p.
(Fractional r, Ord r) =>
Int -> Point 2 r -> Sweep p r ()
connectToLeft Int
i Point 2 r
v




--------------------------------------------------------------------------------


-- testPolygon :: SimplePolygon Int Rational
-- testPolygon = fromPoints [ Point2 20 20 :+ 1
--                          , Point2 18 19 :+ 2
--                          , Point2 16 25 :+ 3
--                          , Point2 13 23 :+ 4
--                          , Point2 10 24 :+ 5
--                          , Point2 6  22 :+ 6
--                          , Point2 8  21 :+ 7
--                          , Point2 7  18 :+ 8
--                          , Point2 2  19 :+ 9
--                          , Point2 1  10 :+ 10
--                          , Point2 3  5  :+ 11
--                          , Point2 11 7  :+ 12
--                          , Point2 15 1  :+ 13
--                          , Point2 12 15 :+ 14
--                          , Point2 15 12 :+ 15
--                          ]

-- vertexTypes = [Start,Merge,Start,Merge,Start,Regular,Regular,Merge,Start,Regular,End,Split,End,Split,End]


-- loadT = do pgs <- readAllFrom "/Users/frank/tmp/testPoly.ipe"
--                         :: IO [SimplePolygon () Rational :+ IpeAttributes Path Rational]
--            mapM_ print pgs
--            let diags = map (computeDiagonals . (^.core)) pgs
--                f = asIpeGroup . map (asIpeObject' mempty)
--                out = [ asIpeGroup $ map (\(pg :+ a) -> asIpeObject pg a) pgs
--                      , asIpeGroup $ map f diags
--                      ]
--                outFile = "/Users/frank/tmp/out.ipe"
--            writeIpeFile outFile . singlePageFromContent $ out


-- myPoly :: Polygon Multi () Rational
-- myPoly = MultiPolygon (CC.fromList $ read "[Point2 [16 % 1,80 % 1] :+ (),Point2 [16 % 1,16 % 1] :+ (),Point2 [144 % 1,16 % 1] :+ (),Point2 [144 % 1,80 % 1] :+ ()]"
--                       )
--   [ fromPoints $ read "[Point2 [88 % 1,48 % 1] :+ (),Point2 [112 % 1,40 % 1] :+ (),Point2 [112 % 1,48 % 1] :+ (),Point2 [80 % 1,56 % 1] :+ ()]"
--   , fromPoints $ read "[Point2 [32 % 1,64 % 1] :+ (),Point2 [32 % 1,32 % 1] :+ (),Point2 [64 % 1,32 % 1] :+ (),Point2 [64 % 1,64 % 1] :+ ()]"
--   ]