module Geometry.Algorithms.Triangulate (
    triangulate
) where



import Data.List
import Data.Ord

import Geometry.Core
import Util



-- $setup
-- >>> import Draw
-- >>> import qualified Graphics.Rendering.Cairo as C


-- | Split a polygon into a number of triangles.
--
-- Triangulations often make things easier to handle. For example, you may not know
-- the formula to calculate the area of a polygon. But if you know the area of a
-- triangle, then you can calculate the area by summing up the area of the
-- triangulated pieces.
--
-- <<docs/haddock/Geometry/Algorithms/Triangulate/triangulate.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Algorithms/Triangulate/triangulate.svg" 240 210 $ \_ -> do
--     let polygon = Polygon [Vec2 10 74, Vec2 130 10, Vec2 140 143, Vec2 199 94, Vec2 232 175, Vec2 188 203, Vec2 35 133, Vec2 103 68]
--         triangles = triangulate polygon
--     C.setLineJoin C.LineJoinRound
--     for_ (zip [0..] triangles) $ \(i, triangle) -> cairoScope $ do
--         sketch triangle
--         setColor (mma i)
--         C.fillPreserve
--         C.stroke
--     cairoScope $ do
--         C.setLineWidth 2
--         setColor black
--         sketch polygon
--         C.stroke
-- :}
-- Generated file: size 4KB, crc32: 0xf8dda52c
triangulate :: Polygon -> [Polygon]
triangulate :: Polygon -> [Polygon]
triangulate Polygon
polygon = case Polygon -> (Polygon, Maybe Polygon)
clipEar Polygon
polygon of
    (Polygon
ear, Maybe Polygon
Nothing) -> [Polygon
ear]
    (Polygon
ear, Just Polygon
rest) -> Polygon
ear Polygon -> [Polygon] -> [Polygon]
forall a. a -> [a] -> [a]
: Polygon -> [Polygon]
triangulate Polygon
rest

isEar :: Polygon -> PolygonOrientation -> [Vec2] -> Bool
isEar :: Polygon -> PolygonOrientation -> [Vec2] -> Bool
isEar Polygon
candidate PolygonOrientation
parentOrientation [Vec2]
forbiddenPoints
  = Bool -> Bool
not ((Vec2 -> Bool) -> [Vec2] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Vec2
r -> Vec2 -> Polygon -> Bool
pointInPolygon Vec2
r Polygon
candidate) [Vec2]
forbiddenPoints)
    Bool -> Bool -> Bool
&& PolygonOrientation
parentOrientation PolygonOrientation -> PolygonOrientation -> Bool
forall a. Eq a => a -> a -> Bool
== Polygon -> PolygonOrientation
polygonOrientation Polygon
candidate

-- | Ear-clipping algorithm – find an isolated triangle we can cut off. Meant to
-- be iterated until the input is fully triangulated. Probably terrible
-- performance for large polygons.
clipEar :: Polygon -> (Polygon, Maybe Polygon)
clipEar :: Polygon -> (Polygon, Maybe Polygon)
clipEar Polygon
parentPolygon = Polygon -> (Polygon, Maybe Polygon)
go Polygon
parentPolygon
  where
    parentOrientation :: PolygonOrientation
parentOrientation = Polygon -> PolygonOrientation
polygonOrientation Polygon
parentPolygon
    bestEar :: [(Polygon, b, c)] -> (Polygon, b, c)
bestEar [] = String -> String -> (Polygon, b, c)
forall a. String -> String -> a
bugError String
"Triangulate.clipEar" String
"No ears to cut off"
    bestEar [(Polygon, b, c)]
xs = ((Polygon, b, c) -> (Polygon, b, c) -> Ordering)
-> [(Polygon, b, c)] -> (Polygon, b, c)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (\(Polygon
e1,b
_,c
_) (Polygon
e2,b
_,c
_) -> (Polygon -> Double) -> Polygon -> Polygon -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Polygon -> Double
polygonArea Polygon
e1 Polygon
e2) [(Polygon, b, c)]
xs
    onlyEars :: (Polygon, [Vec2], c) -> Bool
onlyEars (Polygon
candidate, [Vec2]
forbiddenPoints, c
_) = Polygon -> PolygonOrientation -> [Vec2] -> Bool
isEar Polygon
candidate PolygonOrientation
parentOrientation [Vec2]
forbiddenPoints

    go :: Polygon -> (Polygon, Maybe Polygon)
go lastEar :: Polygon
lastEar@(Polygon [Vec2
_,Vec2
_,Vec2
_]) = (Polygon
lastEar, Maybe Polygon
forall a. Maybe a
Nothing)
    go polygon :: Polygon
polygon@(Polygon (Vec2
_:Vec2
_:Vec2
_:[Vec2]
_)) = case ([(Polygon, [Vec2], Polygon)] -> (Polygon, [Vec2], Polygon)
forall {b} {c}. [(Polygon, b, c)] -> (Polygon, b, c)
bestEar ([(Polygon, [Vec2], Polygon)] -> (Polygon, [Vec2], Polygon))
-> (Polygon -> [(Polygon, [Vec2], Polygon)])
-> Polygon
-> (Polygon, [Vec2], Polygon)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Polygon, [Vec2], Polygon) -> Bool)
-> [(Polygon, [Vec2], Polygon)] -> [(Polygon, [Vec2], Polygon)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Polygon, [Vec2], Polygon) -> Bool
forall {c}. (Polygon, [Vec2], c) -> Bool
onlyEars ([(Polygon, [Vec2], Polygon)] -> [(Polygon, [Vec2], Polygon)])
-> (Polygon -> [(Polygon, [Vec2], Polygon)])
-> Polygon
-> [(Polygon, [Vec2], Polygon)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon -> [(Polygon, [Vec2], Polygon)]
triples) Polygon
polygon of
        (Polygon
ear, [Vec2]
_, Polygon
remainder) -> (Polygon
ear, Polygon -> Maybe Polygon
forall a. a -> Maybe a
Just Polygon
remainder)
    go Polygon
_other = String -> (Polygon, Maybe Polygon)
forall a. HasCallStack => String -> a
error String
"oh no"

triples :: Polygon -> [(Polygon, [Vec2], Polygon)]
triples :: Polygon -> [(Polygon, [Vec2], Polygon)]
triples (Polygon [Vec2]
ps)
  = ([Vec2] -> (Polygon, [Vec2], Polygon))
-> [[Vec2]] -> [(Polygon, [Vec2], Polygon)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Vec2
p:Vec2
x:Vec2
q:[Vec2]
rest) -> ([Vec2] -> Polygon
Polygon [Vec2
p,Vec2
x,Vec2
q], [Vec2]
rest, [Vec2] -> Polygon
Polygon (Vec2
pVec2 -> [Vec2] -> [Vec2]
forall a. a -> [a] -> [a]
:Vec2
qVec2 -> [Vec2] -> [Vec2]
forall a. a -> [a] -> [a]
:[Vec2]
rest))) ([Vec2] -> [[Vec2]]
forall a. [a] -> [[a]]
rotations [Vec2]
ps)

-- | All rotations of a list.
rotations :: [a] -> [[a]]
rotations :: forall a. [a] -> [[a]]
rotations = [a] -> [a] -> [[a]]
forall {a}. [a] -> [a] -> [[a]]
go []
  where
    go :: [a] -> [a] -> [[a]]
go [a]
_ [] = []
    go [a]
xs (a
y:[a]
ys) = let xs' :: [a]
xs' = [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
y]
                       rotation :: [a]
rotation = a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs
                   in [a]
rotation [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [[a]]
go [a]
xs' [a]
ys