{-# OPTIONS_HADDOCK hide #-}

module Graphics.Gloss.Internals.Rendering.Polygon(renderComplexPolygon) where
import Graphics.Gloss.Internals.Rendering.Common
import Graphics.Rendering.OpenGL.GLU.Tessellation
import qualified Graphics.Rendering.OpenGL.GL           as GL

combiner :: a -> b -> ()
combiner :: forall a b. a -> b -> ()
combiner a
_ b
_ = ()


-- written this way to measurably improve performance
zipLoop :: [a] -> [(a,a)]
zipLoop :: forall a. [a] -> [(a, a)]
zipLoop [] = []
zipLoop (a
x:[a]
xs) = a -> [a] -> [(a, a)]
go a
x [a]
xs where
  go :: a -> [a] -> [(a, a)]
go a
y [] = [(a
y,a
x)]
  go a
y (a
z:[a]
rs) = (a
y,a
z) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: a -> [a] -> [(a, a)]
go a
z [a]
rs

zipWithLoop :: (a->a->b) -> [a] -> [b]
zipWithLoop :: forall a b. (a -> a -> b) -> [a] -> [b]
zipWithLoop a -> a -> b
f = ((a, a) -> b) -> [(a, a)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> a -> b) -> (a, a) -> b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> b
f) ([(a, a)] -> [b]) -> ([a] -> [(a, a)]) -> [a] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [(a, a)]
forall a. [a] -> [(a, a)]
zipLoop

-- signed angle between 2 vectors
-- https://stackoverflow.com/a/16544330/1779797
-- Note: `isConvex` would remain correct if this returned a value between theta*7/2pi and theta*7/4pi which probably provides an opportunity for optimisation
angle :: (Float,Float) -> (Float,Float) -> Float
angle :: (GLfloat, GLfloat) -> (GLfloat, GLfloat) -> GLfloat
angle (GLfloat
x1,GLfloat
y1) (GLfloat
x2,GLfloat
y2) = let dot :: GLfloat
dot = GLfloat
x1GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
*GLfloat
x2 GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
+ GLfloat
y1GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
*GLfloat
y2 -- cos theta * |v1||v2|
                            det :: GLfloat
det = GLfloat
y2GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
*GLfloat
x1 GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
- GLfloat
x2GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
*GLfloat
y1 -- sin theta * |v1||v2|
                        in GLfloat -> GLfloat -> GLfloat
forall a. RealFloat a => a -> a -> a
atan2 GLfloat
det GLfloat
dot


-- Approximating 2pi by 7 is reasonable here.
-- The total rotation theoretically must be a multiple of 2pi,
-- so a little generosity doesn't break anything, but might save some cases that would fail due to floating point errors
isConvex :: [(Float,Float)] -> Bool
isConvex :: [(GLfloat, GLfloat)] -> Bool
isConvex [(GLfloat, GLfloat)]
ps =
    -- check that it doesn't turn more than one full circle in total
    (GLfloat -> Bool) -> [GLfloat] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\GLfloat
theta -> (GLfloat
theta GLfloat -> GLfloat -> Bool
forall a. Ord a => a -> a -> Bool
<= GLfloat
7) Bool -> Bool -> Bool
&& (GLfloat
theta GLfloat -> GLfloat -> Bool
forall a. Ord a => a -> a -> Bool
> -GLfloat
7)) ([GLfloat] -> Bool) -> [GLfloat] -> Bool
forall a b. (a -> b) -> a -> b
$
    (GLfloat -> GLfloat -> GLfloat)
-> GLfloat -> [GLfloat] -> [GLfloat]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl GLfloat -> GLfloat -> GLfloat
angleAdd GLfloat
0 ([GLfloat] -> [GLfloat]) -> [GLfloat] -> [GLfloat]
forall a b. (a -> b) -> a -> b
$ -- check that the path's direction is consistent
    ((GLfloat, GLfloat) -> (GLfloat, GLfloat) -> GLfloat)
-> [(GLfloat, GLfloat)] -> [GLfloat]
forall a b. (a -> a -> b) -> [a] -> [b]
zipWithLoop (GLfloat, GLfloat) -> (GLfloat, GLfloat) -> GLfloat
angle ([(GLfloat, GLfloat)] -> [GLfloat])
-> [(GLfloat, GLfloat)] -> [GLfloat]
forall a b. (a -> b) -> a -> b
$ -- compute angles of turns at each vertex
    ((GLfloat, GLfloat) -> Bool)
-> [(GLfloat, GLfloat)] -> [(GLfloat, GLfloat)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((GLfloat, GLfloat) -> (GLfloat, GLfloat) -> Bool
forall a. Eq a => a -> a -> Bool
/= (GLfloat
0,GLfloat
0)) ([(GLfloat, GLfloat)] -> [(GLfloat, GLfloat)])
-> [(GLfloat, GLfloat)] -> [(GLfloat, GLfloat)]
forall a b. (a -> b) -> a -> b
$ -- discard edges arising from duplicated vertices
    ((GLfloat, GLfloat) -> (GLfloat, GLfloat) -> (GLfloat, GLfloat))
-> [(GLfloat, GLfloat)] -> [(GLfloat, GLfloat)]
forall a b. (a -> a -> b) -> [a] -> [b]
zipWithLoop (\(GLfloat
x1,GLfloat
y1) (GLfloat
x2,GLfloat
y2) -> (GLfloat
x2GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
-GLfloat
x1,GLfloat
y2GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
-GLfloat
y1) ) -- produce vectors for each edge
        [(GLfloat, GLfloat)]
ps
  where
    -- Combine angles, but return a value greater than 7 if they have opposite signs
    angleAdd :: Float -> Float -> Float
    angleAdd :: GLfloat -> GLfloat -> GLfloat
angleAdd GLfloat
a GLfloat
b = if GLfloat -> GLfloat
forall a. Num a => a -> a
signum GLfloat
aGLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
*GLfloat -> GLfloat
forall a. Num a => a -> a
signum GLfloat
b GLfloat -> GLfloat -> Bool
forall a. Ord a => a -> a -> Bool
< -GLfloat
0.5 then GLfloat
10 else GLfloat
a GLfloat -> GLfloat -> GLfloat
forall a. Num a => a -> a -> a
+ GLfloat
b

renderComplexPolygon :: [(Float,Float)] -> IO ()
renderComplexPolygon :: [(GLfloat, GLfloat)] -> IO ()
renderComplexPolygon [(GLfloat, GLfloat)]
path = if [(GLfloat, GLfloat)] -> Bool
isConvex [(GLfloat, GLfloat)]
path
  then PrimitiveMode -> IO () -> IO ()
forall a. PrimitiveMode -> IO a -> IO a
GL.renderPrimitive PrimitiveMode
GL.Polygon (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [(GLfloat, GLfloat)] -> IO ()
vertexPFs [(GLfloat, GLfloat)]
path
  else do
    Triangulation [Triangle ()]
ts <- Tessellator Triangulation ()
forall v. Storable v => Tessellator Triangulation v
triangulate TessWinding
TessWindingOdd GLdouble
0 ( GLdouble -> GLdouble -> GLdouble -> Normal3 GLdouble
forall a. a -> a -> a -> Normal3 a
GL.Normal3 GLdouble
0 GLdouble
0 GLdouble
1) Vertex3 GLdouble -> WeightedProperties () -> ()
forall a b. a -> b -> ()
combiner
      ([ComplexContour ()] -> ComplexPolygon ()
forall v. [ComplexContour v] -> ComplexPolygon v
ComplexPolygon [[AnnotatedVertex ()] -> ComplexContour ()
forall v. [AnnotatedVertex v] -> ComplexContour v
ComplexContour [Vertex3 GLdouble -> () -> AnnotatedVertex ()
forall v. Vertex3 GLdouble -> v -> AnnotatedVertex v
AnnotatedVertex (GLdouble -> GLdouble -> GLdouble -> Vertex3 GLdouble
forall a. a -> a -> a -> Vertex3 a
GL.Vertex3 (GLfloat -> GLdouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac GLfloat
a) (GLfloat -> GLdouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac GLfloat
b) GLdouble
0) () | (GLfloat
a,GLfloat
b) <- [(GLfloat, GLfloat)]
path]])
    PrimitiveMode -> IO () -> IO ()
forall a. PrimitiveMode -> IO a -> IO a
GL.renderPrimitive PrimitiveMode
GL.Triangles ([Triangle ()] -> IO ()
forall a. [Triangle a] -> IO ()
trisToGLVertices [Triangle ()]
ts)
    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

trisToGLVertices ::    [Triangle a] -> IO ()
trisToGLVertices :: forall a. [Triangle a] -> IO ()
trisToGLVertices []    = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
trisToGLVertices ((Triangle (AnnotatedVertex Vertex3 GLdouble
v1 (a, EdgeFlag)
_) (AnnotatedVertex Vertex3 GLdouble
v2 (a, EdgeFlag)
_) (AnnotatedVertex Vertex3 GLdouble
v3 (a, EdgeFlag)
_)) : [Triangle a]
rest)
 = do   Vertex3 GLdouble -> IO ()
forall a. Vertex a => a -> IO ()
GL.vertex (Vertex3 GLdouble -> IO ()) -> Vertex3 GLdouble -> IO ()
forall a b. (a -> b) -> a -> b
$ Vertex3 GLdouble
v1
        Vertex3 GLdouble -> IO ()
forall a. Vertex a => a -> IO ()
GL.vertex (Vertex3 GLdouble -> IO ()) -> Vertex3 GLdouble -> IO ()
forall a b. (a -> b) -> a -> b
$ Vertex3 GLdouble
v2
        Vertex3 GLdouble -> IO ()
forall a. Vertex a => a -> IO ()
GL.vertex (Vertex3 GLdouble -> IO ()) -> Vertex3 GLdouble -> IO ()
forall a b. (a -> b) -> a -> b
$ Vertex3 GLdouble
v3
        [Triangle a] -> IO ()
forall a. [Triangle a] -> IO ()
trisToGLVertices [Triangle a]
rest
{-# INLINE trisToGLVertices #-}


vertexPFs ::    [(Float, Float)] -> IO ()
vertexPFs :: [(GLfloat, GLfloat)] -> IO ()
vertexPFs []    = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
vertexPFs ((GLfloat
x, GLfloat
y) : [(GLfloat, GLfloat)]
rest)
 = do   Vertex2 GLfloat -> IO ()
forall a. Vertex a => a -> IO ()
GL.vertex (Vertex2 GLfloat -> IO ()) -> Vertex2 GLfloat -> IO ()
forall a b. (a -> b) -> a -> b
$ GLfloat -> GLfloat -> Vertex2 GLfloat
forall a. a -> a -> Vertex2 a
GL.Vertex2 (GLfloat -> GLfloat
gf GLfloat
x) (GLfloat -> GLfloat
gf GLfloat
y)
        [(GLfloat, GLfloat)] -> IO ()
vertexPFs [(GLfloat, GLfloat)]
rest
{-# INLINE vertexPFs #-}