--------------------------------------------------------------------------------
-- |
-- Module      :  Algorithms.Geometry.PolygonTriangulation.TriangulateMonotone
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--------------------------------------------------------------------------------
module Algorithms.Geometry.PolygonTriangulation.TriangulateMonotone
  ( MonotonePolygon
  , triangulate
  , triangulate'
  , computeDiagonals
  -- , LR(..)
  -- , P
  -- , Stack
  -- , chainOf
  -- , toVtx
  -- , seg
  -- , process
  -- , isInside
  -- , mergeBy
  -- , splitPolygon
  ) where

import           Algorithms.Geometry.PolygonTriangulation.Types
import           Control.Lens
import           Data.Ext
import qualified Data.Foldable                                  as F
import           Data.Geometry.LineSegment
import           Data.Geometry.PlanarSubdivision.Basic          (PlanarSubdivision, PolygonFaceData)
import           Data.Geometry.Point
import           Data.Geometry.Polygon
import qualified Data.List                                      as L
import           Data.Ord                                       (Down (..), comparing)
import           Data.PlaneGraph                                (PlaneGraph)
import           Data.Util
import qualified Data.Vector.Circular.Util                      as CV

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

-- | Y-monotone polygon. All straight horizontal lines intersects the polygon
--   no more than twice.
type MonotonePolygon p r = SimplePolygon p r

data LR = L | R deriving (Int -> LR -> ShowS
[LR] -> ShowS
LR -> String
(Int -> LR -> ShowS)
-> (LR -> String) -> ([LR] -> ShowS) -> Show LR
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LR] -> ShowS
$cshowList :: [LR] -> ShowS
show :: LR -> String
$cshow :: LR -> String
showsPrec :: Int -> LR -> ShowS
$cshowsPrec :: Int -> LR -> ShowS
Show,LR -> LR -> Bool
(LR -> LR -> Bool) -> (LR -> LR -> Bool) -> Eq LR
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LR -> LR -> Bool
$c/= :: LR -> LR -> Bool
== :: LR -> LR -> Bool
$c== :: LR -> LR -> Bool
Eq)

-- | Triangulates a polygon of \(n\) vertices
--
-- running time: \(O(n \log n)\)
triangulate        :: (Ord r, Fractional r)
                   => proxy s -> MonotonePolygon p r
                   -> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r
triangulate :: proxy s
-> MonotonePolygon p r
-> PlanarSubdivision s p PolygonEdgeType PolygonFaceData r
triangulate proxy s
px MonotonePolygon p r
pg' = 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 (MonotonePolygon p r -> [LineSegment 2 p r]
forall r p.
(Ord r, Num r) =>
MonotonePolygon p r -> [LineSegment 2 p r]
computeDiagonals MonotonePolygon p r
pg)
  where
    pg :: MonotonePolygon p r
pg     = MonotonePolygon p r -> MonotonePolygon p r
forall r (t :: PolygonType) p.
(Eq r, Num r) =>
Polygon t p r -> Polygon t p r
toCounterClockWiseOrder MonotonePolygon p r
pg'
    (LineSegment 2 p r
e:[LineSegment 2 p r]
es) = MonotonePolygon p r -> [LineSegment 2 p r]
forall (t :: PolygonType) p r. Polygon t p r -> [LineSegment 2 p r]
listEdges MonotonePolygon p r
pg
  -- TODO: Find a way to construct the graph in O(n) time.

-- | Triangulates a polygon of \(n\) vertices
--
-- running time: \(O(n \log n)\)
triangulate'        :: (Ord r, Fractional r)
                    => proxy s -> MonotonePolygon p r
                    -> PlaneGraph s p PolygonEdgeType PolygonFaceData r
triangulate' :: proxy s
-> MonotonePolygon p r
-> PlaneGraph s p PolygonEdgeType PolygonFaceData r
triangulate' proxy s
px MonotonePolygon p r
pg' = proxy s
-> LineSegment 2 p r
-> [LineSegment 2 p r]
-> [LineSegment 2 p r]
-> PlaneGraph 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]
-> PlaneGraph s p PolygonEdgeType PolygonFaceData r
constructGraph proxy s
px LineSegment 2 p r
e [LineSegment 2 p r]
es (MonotonePolygon p r -> [LineSegment 2 p r]
forall r p.
(Ord r, Num r) =>
MonotonePolygon p r -> [LineSegment 2 p r]
computeDiagonals MonotonePolygon p r
pg)
  where
    pg :: MonotonePolygon p r
pg     = MonotonePolygon p r -> MonotonePolygon p r
forall r (t :: PolygonType) p.
(Eq r, Num r) =>
Polygon t p r -> Polygon t p r
toCounterClockWiseOrder MonotonePolygon p r
pg'
    (LineSegment 2 p r
e:[LineSegment 2 p r]
es) = MonotonePolygon p r -> [LineSegment 2 p r]
forall (t :: PolygonType) p r. Polygon t p r -> [LineSegment 2 p r]
listEdges MonotonePolygon p r
pg
  -- TODO: Find a way to construct the graph in O(n) time.


-- | Given a y-monotone polygon in counter clockwise order computes the diagonals
-- to add to triangulate the polygon
--
-- pre: the input polygon is y-monotone and has \(n \geq 3\) vertices
--
-- running time: \(O(n)\)
computeDiagonals    :: (Ord r, Num r)
                    => MonotonePolygon p r -> [LineSegment 2 p r]
computeDiagonals :: MonotonePolygon p r -> [LineSegment 2 p r]
computeDiagonals MonotonePolygon p r
pg = [LineSegment 2 p r]
diags'' [LineSegment 2 p r] -> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a. Semigroup a => a -> a -> a
<> [LineSegment 2 p r]
diags'
  where
    -- | run the stack computation
    SP (P p r
_:[P p r]
stack') [LineSegment 2 p r]
diags' = (SP [P p r] [LineSegment 2 p r]
 -> P p r -> SP [P p r] [LineSegment 2 p r])
-> SP [P p r] [LineSegment 2 p r]
-> [P p r]
-> SP [P p r] [LineSegment 2 p r]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\(SP [P p r]
stack [LineSegment 2 p r]
acc) P p r
v' -> ([LineSegment 2 p r] -> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a. Semigroup a => a -> a -> a
<> [LineSegment 2 p r]
acc) ([LineSegment 2 p r] -> [LineSegment 2 p r])
-> SP [P p r] [LineSegment 2 p r] -> SP [P p r] [LineSegment 2 p r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> P p r -> [P p r] -> SP [P p r] [LineSegment 2 p r]
forall r p.
(Ord r, Num r) =>
P p r -> Stack (P p r) -> SP (Stack (P p r)) [LineSegment 2 p r]
process P p r
v' [P p r]
stack)
                                    ([P p r] -> [LineSegment 2 p r] -> SP [P p r] [LineSegment 2 p r]
forall a b. a -> b -> SP a b
SP [P p r
v,P p r
u] []) [P p r]
vs'
    -- add vertices from the last guy w to all 'middle' guys of the final stack
    diags'' :: [LineSegment 2 p r]
diags'' = (P p r -> LineSegment 2 p r) -> [P p r] -> [LineSegment 2 p r]
forall a b. (a -> b) -> [a] -> [b]
map (P p r -> P p r -> LineSegment 2 p r
forall p r. P p r -> P p r -> LineSegment 2 p r
seg P p r
w) ([P p r] -> [LineSegment 2 p r]) -> [P p r] -> [LineSegment 2 p r]
forall a b. (a -> b) -> a -> b
$ [P p r] -> [P p r]
forall a. [a] -> [a]
init [P p r]
stack'
    -- extract the last vertex
    Just ([P p r]
vs',P p r
w) = [P p r] -> Maybe ([P p r], P p r)
forall s a. Snoc s s a a => s -> Maybe (s, a)
unsnoc [P p r]
vs
    -- merge the two lists into one list for procerssing
    (P p r
u:P p r
v:[P p r]
vs) = ([P p r] -> [P p r] -> [P p r]) -> ([P p r], [P p r]) -> [P p r]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((P p r -> P p r -> Ordering) -> [P p r] -> [P p r] -> [P p r]
forall a. (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy ((P p r -> P p r -> Ordering) -> [P p r] -> [P p r] -> [P p r])
-> (P p r -> P p r -> Ordering) -> [P p r] -> [P p r] -> [P p r]
forall a b. (a -> b) -> a -> b
$ (P p r -> (Down r, r)) -> P p r -> P p r -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (\(Point2 r
x r
y :+ LR :+ p
_) -> (r -> Down r
forall a. a -> Down a
Down r
y, r
x)))
             (([P p r], [P p r]) -> [P p r]) -> ([P p r], [P p r]) -> [P p r]
forall a b. (a -> b) -> a -> b
$ MonotonePolygon p r -> ([P p r], [P p r])
forall r p.
Ord r =>
MonotonePolygon p r
-> ([Point 2 r :+ (LR :+ p)], [Point 2 r :+ (LR :+ p)])
splitPolygon MonotonePolygon p r
pg


type P p r = Point 2 r :+ (LR :+ p)

type Stack a = [a]




-- type Scan p r = State (Stack (P p r))

chainOf :: P p r -> LR
chainOf :: P p r -> LR
chainOf = (P p r -> Getting LR (P p r) LR -> LR
forall s a. s -> Getting a s a -> a
^.((LR :+ p) -> Const LR (LR :+ p)) -> P p r -> Const LR (P p r)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra(((LR :+ p) -> Const LR (LR :+ p)) -> P p r -> Const LR (P p r))
-> ((LR -> Const LR LR) -> (LR :+ p) -> Const LR (LR :+ p))
-> Getting LR (P p r) LR
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(LR -> Const LR LR) -> (LR :+ p) -> Const LR (LR :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core)

toVtx :: P p r -> Point 2 r :+ p
toVtx :: P p r -> Point 2 r :+ p
toVtx = (P p r -> (P p r -> Point 2 r :+ p) -> Point 2 r :+ p
forall a b. a -> (a -> b) -> b
&((LR :+ p) -> Identity p) -> P p r -> Identity (Point 2 r :+ p)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra (((LR :+ p) -> Identity p) -> P p r -> Identity (Point 2 r :+ p))
-> ((LR :+ p) -> p) -> P p r -> Point 2 r :+ p
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((LR :+ p) -> Getting p (LR :+ p) p -> p
forall s a. s -> Getting a s a -> a
^.Getting p (LR :+ p) p
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra))

seg     :: P p r -> P p r -> LineSegment 2 p r
seg :: P p r -> P p r -> LineSegment 2 p r
seg P p r
u P p r
v = (Point 2 r :+ p) -> (Point 2 r :+ p) -> LineSegment 2 p r
forall (d :: Nat) r p.
(Point d r :+ p) -> (Point d r :+ p) -> LineSegment d p r
ClosedLineSegment (P p r -> Point 2 r :+ p
forall p r. P p r -> Point 2 r :+ p
toVtx P p r
u) (P p r -> Point 2 r :+ p
forall p r. P p r -> Point 2 r :+ p
toVtx P p r
v)

process                    :: (Ord r, Num r)
                           => P p r -> Stack (P p r)
                           -> SP (Stack (P p r)) [LineSegment 2 p r]
process :: P p r -> Stack (P p r) -> SP (Stack (P p r)) [LineSegment 2 p r]
process P p r
_ []               = String -> SP (Stack (P p r)) [LineSegment 2 p r]
forall a. HasCallStack => String -> a
error String
"TriangulateMonotone.process: absurd. empty stack"
process P p r
v stack :: Stack (P p r)
stack@(P p r
u:Stack (P p r)
ws)
  | P p r -> LR
forall p r. P p r -> LR
chainOf P p r
v LR -> LR -> Bool
forall a. Eq a => a -> a -> Bool
/= P p r -> LR
forall p r. P p r -> LR
chainOf P p r
u = Stack (P p r)
-> [LineSegment 2 p r] -> SP (Stack (P p r)) [LineSegment 2 p r]
forall a b. a -> b -> SP a b
SP [P p r
v,P p r
u]      ((P p r -> LineSegment 2 p r)
-> Stack (P p r) -> [LineSegment 2 p r]
forall a b. (a -> b) -> [a] -> [b]
map (P p r -> P p r -> LineSegment 2 p r
forall p r. P p r -> P p r -> LineSegment 2 p r
seg P p r
v) (Stack (P p r) -> [LineSegment 2 p r])
-> (Stack (P p r) -> Stack (P p r))
-> Stack (P p r)
-> [LineSegment 2 p r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack (P p r) -> Stack (P p r)
forall a. [a] -> [a]
init (Stack (P p r) -> [LineSegment 2 p r])
-> Stack (P p r) -> [LineSegment 2 p r]
forall a b. (a -> b) -> a -> b
$ Stack (P p r)
stack)
  | Bool
otherwise              = Stack (P p r)
-> [LineSegment 2 p r] -> SP (Stack (P p r)) [LineSegment 2 p r]
forall a b. a -> b -> SP a b
SP (P p r
vP p r -> Stack (P p r) -> Stack (P p r)
forall a. a -> [a] -> [a]
:P p r
wP p r -> Stack (P p r) -> Stack (P p r)
forall a. a -> [a] -> [a]
:Stack (P p r)
rest) ((P p r -> LineSegment 2 p r)
-> Stack (P p r) -> [LineSegment 2 p r]
forall a b. (a -> b) -> [a] -> [b]
map (P p r -> P p r -> LineSegment 2 p r
forall p r. P p r -> P p r -> LineSegment 2 p r
seg P p r
v) Stack (P p r)
popped)
      where
        (Stack (P p r)
popped,Stack (P p r)
rest) = ([(P p r, P p r)] -> Stack (P p r))
-> ([(P p r, P p r)] -> Stack (P p r))
-> ([(P p r, P p r)], [(P p r, P p r)])
-> (Stack (P p r), Stack (P p r))
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (((P p r, P p r) -> P p r) -> [(P p r, P p r)] -> Stack (P p r)
forall a b. (a -> b) -> [a] -> [b]
map (P p r, P p r) -> P p r
forall a b. (a, b) -> a
fst) (((P p r, P p r) -> P p r) -> [(P p r, P p r)] -> Stack (P p r)
forall a b. (a -> b) -> [a] -> [b]
map (P p r, P p r) -> P p r
forall a b. (a, b) -> a
fst) (([(P p r, P p r)], [(P p r, P p r)])
 -> (Stack (P p r), Stack (P p r)))
-> ([(P p r, P p r)] -> ([(P p r, P p r)], [(P p r, P p r)]))
-> [(P p r, P p r)]
-> (Stack (P p r), Stack (P p r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((P p r, P p r) -> Bool)
-> [(P p r, P p r)] -> ([(P p r, P p r)], [(P p r, P p r)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.span (P p r -> (P p r, P p r) -> Bool
forall r p. (Ord r, Num r) => P p r -> (P p r, P p r) -> Bool
isInside P p r
v) ([(P p r, P p r)] -> (Stack (P p r), Stack (P p r)))
-> [(P p r, P p r)] -> (Stack (P p r), Stack (P p r))
forall a b. (a -> b) -> a -> b
$ Stack (P p r) -> Stack (P p r) -> [(P p r, P p r)]
forall a b. [a] -> [b] -> [(a, b)]
zip Stack (P p r)
ws Stack (P p r)
stack
        w :: P p r
w             = Stack (P p r) -> P p r
forall a. [a] -> a
last (Stack (P p r) -> P p r) -> Stack (P p r) -> P p r
forall a b. (a -> b) -> a -> b
$ P p r
uP p r -> Stack (P p r) -> Stack (P p r)
forall a. a -> [a] -> [a]
:Stack (P p r)
popped


-- | test if m does not block the line segment from v to u
isInside          :: (Ord r, Num r) => P p r -> (P p r, P p r) -> Bool
isInside :: P p r -> (P p r, P p r) -> Bool
isInside P p r
v (P p r
u, P p r
m) = case P p r -> P p r -> P p r -> CCW
forall r a b c.
(Ord r, Num r) =>
(Point 2 r :+ a) -> (Point 2 r :+ b) -> (Point 2 r :+ c) -> CCW
ccw' P p r
v P p r
m P p r
u of
                     CCW
CoLinear -> Bool
False
                     CCW
CCW      -> P p r -> LR
forall p r. P p r -> LR
chainOf P p r
v LR -> LR -> Bool
forall a. Eq a => a -> a -> Bool
== LR
R
                     CCW
CW       -> P p r -> LR
forall p r. P p r -> LR
chainOf P p r
v LR -> LR -> Bool
forall a. Eq a => a -> a -> Bool
== LR
L

-- | given a comparison function, merge the two ordered lists
mergeBy     :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy a -> a -> Ordering
cmp = [a] -> [a] -> [a]
go
  where
    go :: [a] -> [a] -> [a]
go []     [a]
ys     = [a]
ys
    go [a]
xs     []     = [a]
xs
    go (a
x:[a]
xs) (a
y:[a]
ys) = case a
x a -> a -> Ordering
`cmp` a
y of
                         Ordering
GT -> a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
go (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) [a]
ys
                         Ordering
_  -> a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
go [a]
xs     (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)


-- | When the polygon is in counter clockwise order we return (leftChain,rightChain)
-- ordered from the top-down.
--
-- if there are multiple points with the maximum yCoord we pick the rightmost one,
-- if there are multiple point with the minimum yCoord we pick the leftmost one.
--
-- running time: \(O(n)\)
splitPolygon    :: Ord r => MonotonePolygon p r
                -> ([Point 2 r :+ (LR :+ p)], [Point 2 r :+ (LR :+ p)])
splitPolygon :: MonotonePolygon p r
-> ([Point 2 r :+ (LR :+ p)], [Point 2 r :+ (LR :+ p)])
splitPolygon MonotonePolygon p r
pg = ([Point 2 r :+ p] -> [Point 2 r :+ (LR :+ p)])
-> ([Point 2 r :+ p] -> [Point 2 r :+ (LR :+ p)])
-> ([Point 2 r :+ p], [Point 2 r :+ p])
-> ([Point 2 r :+ (LR :+ p)], [Point 2 r :+ (LR :+ p)])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (LR -> [Point 2 r :+ p] -> [Point 2 r :+ (LR :+ p)]
forall core core extra.
core -> [core :+ extra] -> [core :+ (core :+ extra)]
f LR
L) (LR -> [Point 2 r :+ p] -> [Point 2 r :+ (LR :+ p)]
forall core core extra.
core -> [core :+ extra] -> [core :+ (core :+ extra)]
f LR
R ([Point 2 r :+ p] -> [Point 2 r :+ (LR :+ p)])
-> ([Point 2 r :+ p] -> [Point 2 r :+ p])
-> [Point 2 r :+ p]
-> [Point 2 r :+ (LR :+ p)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point 2 r :+ p] -> [Point 2 r :+ p]
forall a. [a] -> [a]
reverse)
                (([Point 2 r :+ p], [Point 2 r :+ p])
 -> ([Point 2 r :+ (LR :+ p)], [Point 2 r :+ (LR :+ p)]))
-> (CircularVector (Point 2 r :+ p)
    -> ([Point 2 r :+ p], [Point 2 r :+ p]))
-> CircularVector (Point 2 r :+ p)
-> ([Point 2 r :+ (LR :+ p)], [Point 2 r :+ (LR :+ p)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point 2 r :+ p) -> Bool)
-> [Point 2 r :+ p] -> ([Point 2 r :+ p], [Point 2 r :+ p])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break (\Point 2 r :+ p
v -> Point 2 r :+ p
v(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 -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r
vMinY)
                ([Point 2 r :+ p] -> ([Point 2 r :+ p], [Point 2 r :+ p]))
-> (CircularVector (Point 2 r :+ p) -> [Point 2 r :+ p])
-> CircularVector (Point 2 r :+ p)
-> ([Point 2 r :+ p], [Point 2 r :+ p])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmptyVector (Point 2 r :+ p) -> [Point 2 r :+ p]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (NonEmptyVector (Point 2 r :+ p) -> [Point 2 r :+ p])
-> (CircularVector (Point 2 r :+ p)
    -> NonEmptyVector (Point 2 r :+ p))
-> CircularVector (Point 2 r :+ p)
-> [Point 2 r :+ p]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CircularVector (Point 2 r :+ p) -> NonEmptyVector (Point 2 r :+ p)
forall a. CircularVector a -> NonEmptyVector a
CV.rightElements (CircularVector (Point 2 r :+ p)
 -> ([Point 2 r :+ (LR :+ p)], [Point 2 r :+ (LR :+ p)]))
-> CircularVector (Point 2 r :+ p)
-> ([Point 2 r :+ (LR :+ p)], [Point 2 r :+ (LR :+ p)])
forall a b. (a -> b) -> a -> b
$ CircularVector (Point 2 r :+ p)
vs'
  where
    f :: core -> [core :+ extra] -> [core :+ (core :+ extra)]
f core
x = ((core :+ extra) -> core :+ (core :+ extra))
-> [core :+ extra] -> [core :+ (core :+ extra)]
forall a b. (a -> b) -> [a] -> [b]
map ((core :+ extra)
-> ((core :+ extra) -> core :+ (core :+ extra))
-> core :+ (core :+ extra)
forall a b. a -> (a -> b) -> b
&(extra -> Identity (core :+ extra))
-> (core :+ extra) -> Identity (core :+ (core :+ extra))
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra ((extra -> Identity (core :+ extra))
 -> (core :+ extra) -> Identity (core :+ (core :+ extra)))
-> (extra -> core :+ extra)
-> (core :+ extra)
-> core :+ (core :+ extra)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (core
x core -> extra -> core :+ extra
forall core extra. core -> extra -> core :+ extra
:+))
    -- rotates the list to the vtx with max ycoord
    Just CircularVector (Point 2 r :+ p)
vs' = ((Point 2 r :+ p) -> Bool)
-> CircularVector (Point 2 r :+ p)
-> Maybe (CircularVector (Point 2 r :+ p))
forall a.
(a -> Bool) -> CircularVector a -> Maybe (CircularVector a)
CV.findRotateTo (\Point 2 r :+ p
v -> Point 2 r :+ p
v(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 -> Point 2 r -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r
vMaxY)
             (CircularVector (Point 2 r :+ p)
 -> Maybe (CircularVector (Point 2 r :+ p)))
-> CircularVector (Point 2 r :+ p)
-> Maybe (CircularVector (Point 2 r :+ p))
forall a b. (a -> b) -> a -> b
$ MonotonePolygon p r
pgMonotonePolygon p r
-> Getting
     (CircularVector (Point 2 r :+ p))
     (MonotonePolygon 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))
  (MonotonePolygon p r)
  (CircularVector (Point 2 r :+ p))
forall (t :: PolygonType) p r.
Getter (Polygon t p r) (CircularVector (Point 2 r :+ p))
outerBoundaryVector
    vMaxY :: Point 2 r
vMaxY = (((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
 -> CircularVector (Point 2 r :+ p) -> Point 2 r :+ p)
-> Point 2 r
getY ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> CircularVector (Point 2 r :+ p) -> Point 2 r :+ p
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
F.maximumBy
    vMinY :: Point 2 r
vMinY = (((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
 -> CircularVector (Point 2 r :+ p) -> Point 2 r :+ p)
-> Point 2 r
getY ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> CircularVector (Point 2 r :+ p) -> Point 2 r :+ p
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
F.minimumBy
    swap' :: Point 2 r -> Point 2 r
swap' (Point2 r
x r
y) = r -> r -> Point 2 r
forall r. r -> r -> Point 2 r
Point2 r
y r
x
    getY :: (((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
 -> CircularVector (Point 2 r :+ p) -> Point 2 r :+ p)
-> Point 2 r
getY ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> CircularVector (Point 2 r :+ p) -> Point 2 r :+ p
ff = let p :: Point 2 r :+ p
p = ((Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering)
-> CircularVector (Point 2 r :+ p) -> Point 2 r :+ p
ff (((Point 2 r :+ p) -> Point 2 r)
-> (Point 2 r :+ p) -> (Point 2 r :+ p) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((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'
coreGetting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> Point 2 r -> Const (Point 2 r) (Point 2 r))
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Point 2 r)
-> (Point 2 r -> Const (Point 2 r) (Point 2 r))
-> Point 2 r
-> Const (Point 2 r) (Point 2 r)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Point 2 r -> Point 2 r
forall r. Point 2 r -> Point 2 r
swap')) (CircularVector (Point 2 r :+ p) -> Point 2 r :+ p)
-> CircularVector (Point 2 r :+ p) -> Point 2 r :+ p
forall a b. (a -> b) -> a -> b
$ MonotonePolygon p r
pgMonotonePolygon p r
-> Getting
     (CircularVector (Point 2 r :+ p))
     (MonotonePolygon 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))
  (MonotonePolygon p r)
  (CircularVector (Point 2 r :+ p))
forall (t :: PolygonType) p r.
Getter (Polygon t p r) (CircularVector (Point 2 r :+ p))
outerBoundaryVector
              in 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



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

-- testPolygon = fromPoints . map ext $ [ Point2 10 10
--                                      , Point2 5 20
--                                      , Point2 3 14
--                                      , Point2 1 1
--                                      , Point2 8 8 ]






-- testPoly5 :: SimplePolygon () Rational
-- testPoly5 = toCounterClockWiseOrder . fromPoints $ map ext [ Point2 176 736
--                                                            , Point2 240 688
--                                                            , Point2 240 608
--                                                            , Point2 128 576
--                                                            , Point2 64 640
--                                                            , Point2 80 720
--                                                            , Point2 128 752
--                                                            ]


-- testPoly5 :: SimplePolygon () Rational
-- testPoly5 = toCounterClockWiseOrder . fromPoints $ map ext $ [ Point2 320 320
--                                                              , Point2 256 320
--                                                              , Point2 224 320
--                                                              , Point2 128 240
--                                                              , Point2 64 224
--                                                              , Point2 256 192
--                                                              ]