    --------------------------------------------------------------------------------
    -- |
    -- Module      :  Graphics.Rendering.OpenGL.GLU.Tessellation
    -- Copyright   :  (c) Sven Panne 2002-2009
    -- License     :  BSD-style (see the file libraries/OpenGL/LICENSE)
    --
    -- Maintainer  :  sven.panne@aedion.de
    -- Stability   :  stable
    -- Portability :  portable
    --
    -- This module corresponds to chapter 5 (Polygon Tessellation) of the GLU specs.
    --
    --------------------------------------------------------------------------------

    module Graphics.Rendering.OpenGL.GLU.Tessellation (
       -- * Polygon description
       AnnotatedVertex(..), ComplexContour(..), ComplexPolygon(..),

       -- * Combining vertices
       WeightedProperties(..), Combiner,

       -- * Tessellation parameters
       TessWinding(..), Tolerance,

       -- * Tessellator type
       Tessellator,

       -- * Contour extraction
       SimpleContour(..), PolygonContours(..), extractContours,

       -- * Triangulation
       TriangleVertex, Triangle(..), Triangulation(..), triangulate,

       -- * Tessellation into primitives
       Primitive(..), SimplePolygon(..), tessellate
    ) where

    import Control.Monad ( foldM_, unless )
    import Data.IORef ( newIORef, readIORef, writeIORef, modifyIORef )
    import Data.Maybe ( fromJust, fromMaybe )
    import Foreign.Marshal.Alloc ( allocaBytes )
    import Foreign.Marshal.Array ( peekArray, pokeArray )
    import Foreign.Marshal.Pool ( Pool, withPool, pooledNew )
    import Foreign.Ptr ( Ptr, nullPtr, plusPtr, castPtr, freeHaskellFunPtr )
    import Foreign.Storable ( Storable(..) )
    import Graphics.Rendering.GLU.Raw
    import Graphics.Rendering.OpenGL.Raw.Core31
    import Graphics.Rendering.OpenGL.GL.Tensor
    import Graphics.Rendering.OpenGL.GL.EdgeFlag ( unmarshalEdgeFlag )
    import Graphics.Rendering.OpenGL.GL.Exception ( bracket )
    import Graphics.Rendering.OpenGL.GL.GLboolean ( marshalGLboolean )
    import Graphics.Rendering.OpenGL.GL.PrimitiveMode ( unmarshalPrimitiveMode )
    import Graphics.Rendering.OpenGL.GL.BeginEnd (
       PrimitiveMode, EdgeFlag(BeginsInteriorEdge) )
    import Graphics.Rendering.OpenGL.GL.VertexSpec
    import Graphics.Rendering.OpenGL.GL.QueryUtils
    import Graphics.Rendering.OpenGL.GLU.ErrorsInternal

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

    data TessWinding =
         TessWindingOdd
       | TessWindingNonzero
       | TessWindingPositive
       | TessWindingNegative
       | TessWindingAbsGeqTwo
       deriving ( Eq, Ord, Show )

    marshalTessWinding :: TessWinding -> GLenum
    marshalTessWinding x = case x of
       TessWindingOdd -> glu_TESS_WINDING_ODD
       TessWindingNonzero -> glu_TESS_WINDING_NONZERO
       TessWindingPositive -> glu_TESS_WINDING_POSITIVE
       TessWindingNegative -> glu_TESS_WINDING_NEGATIVE
       TessWindingAbsGeqTwo -> glu_TESS_WINDING_ABS_GEQ_TWO

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

    -- | The basic building block in tessellation is a 3D vertex with an associated
    -- property, e.g. color, texture coordinates, etc.

    data AnnotatedVertex v = AnnotatedVertex (Vertex3 GLdouble) v
       deriving ( Eq, Ord )

    offsetOfProperty :: Storable v => v -> Int
    offsetOfProperty v = alignOffset v (3 * sizeOf x)
       where AnnotatedVertex (Vertex3 x _ _) _ = undefined

    alignOffset :: Storable a => a -> Int -> Int
    alignOffset x offset = n - (n `mod` a)
       where a = alignment x
             n = a + offset - 1

    instance Storable v => Storable (AnnotatedVertex v) where

       sizeOf ~(AnnotatedVertex (Vertex3 x _ _) v) =
          alignOffset x (sizeOf v + offsetOfProperty v)

       alignment ~(AnnotatedVertex (Vertex3 x _ _) _) =
          alignment x

       peek ptr = do
          x <- peekElemOff (castPtr ptr) 0
          y <- peekElemOff (castPtr ptr) 1
          z <- peekElemOff (castPtr ptr) 2
          let dummyElement :: Ptr (AnnotatedVertex v) -> v
              dummyElement = undefined
          v <- peekByteOff (castPtr ptr) (offsetOfProperty (dummyElement ptr))
          return $ AnnotatedVertex (Vertex3 x y z) v

       poke ptr (AnnotatedVertex (Vertex3 x y z) v) = do
          pokeElemOff (castPtr ptr) 0 x
          pokeElemOff (castPtr ptr) 1 y
          pokeElemOff (castPtr ptr) 2 z
          pokeByteOff (castPtr ptr) (offsetOfProperty v) v

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

    -- | A complex contour, which can be self-intersecting and\/or concave.

    newtype ComplexContour v = ComplexContour [AnnotatedVertex v]
       deriving ( Eq, Ord )

    sizeOfComplexContour :: Storable v => ComplexContour v -> Int
    sizeOfComplexContour (ComplexContour vs) =
       length vs * sizeOf (head vs)

    pokeComplexContour ::
       Storable v => Ptr (ComplexContour v) -> ComplexContour v -> IO ()
    pokeComplexContour ptr (ComplexContour vs) =
       pokeArray (castPtr ptr) vs

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

    -- | A complex (possibly concave) polygon, represented by one or more complex
    -- and possibly intersecting contours.

    newtype ComplexPolygon v = ComplexPolygon [ComplexContour v]
       deriving ( Eq, Ord )

    sizeOfComplexPolygon :: Storable v => ComplexPolygon v -> Int
    sizeOfComplexPolygon (ComplexPolygon complexContours) =
       sum (map sizeOfComplexContour complexContours)

    pokeComplexPolygon ::
       Storable v => Ptr (ComplexPolygon v) -> ComplexPolygon v -> IO ()
    pokeComplexPolygon ptr (ComplexPolygon complexContours) =
       foldM_ pokeAndAdvance (castPtr ptr) complexContours >> return ()
       where pokeAndAdvance p complexContour = do
                pokeComplexContour p complexContour
                return $ p `plusPtr` sizeOfComplexContour complexContour

    withComplexPolygon ::
       Storable v => ComplexPolygon v -> (Ptr (ComplexPolygon v) -> IO a) -> IO a
    withComplexPolygon complexPolygon f =
       allocaBytes (sizeOfComplexPolygon complexPolygon) $ \ptr -> do
          pokeComplexPolygon ptr complexPolygon
          f ptr

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

    -- | Four vertex properties (cf. 'AnnotatedVertex') with associated weigths
    -- summing up to 1.0.

    data WeightedProperties v
       = WeightedProperties (GLfloat, v)
                            (GLfloat, v)
                            (GLfloat, v)
                            (GLfloat, v)
       deriving ( Eq, Ord )

    -- | A function combining given vertex properties into a property for a newly
    -- generated vertex

    type Combiner v
        = Vertex3 GLdouble
       -> WeightedProperties v
       -> v

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

    -- | The relative tolerance under which two vertices can be combined (see
    -- 'Combiner'). Multiplication with the largest coordinate magnitude of all
    -- polygon vertices yields the maximum distance between two mergeable vertices.
    --
    -- Note that merging is optional and the tolerance is only a hint.

    type Tolerance = GLdouble

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

    -- | A general tessellator type.
    --
    -- Before tessellation of a complex polygon, all its vertices are projected into
    -- a plane perpendicular to the given normal. If the given normal is
    -- @Normal3 0 0 0@, a fitting plane of all vertices is used.

    type Tessellator p v
       = TessWinding
      -> Tolerance
      -> Normal3 GLdouble
      -> Combiner v
      -> ComplexPolygon v
      -> IO (p v)

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

    -- | A simple, non-self-intersecting contour

    newtype SimpleContour v = SimpleContour [AnnotatedVertex v]
       deriving ( Eq, Ord )

    -- | The contours of a complex polygon, represented by one or more
    -- non-intersecting simple contours

    newtype PolygonContours v = PolygonContours [SimpleContour v]
       deriving ( Eq, Ord )

    extractContours :: Storable v => Tessellator PolygonContours v
    extractContours windingRule tolerance theNormal combiner complexPoly = do

       vertices <- newIORef []
       let addVertex v = modifyIORef vertices (v:)

       contours <- newIORef []
       let finishContour = do
              vs <- readIORef vertices
              writeIORef vertices []
              modifyIORef contours (SimpleContour (reverse vs) :)

           getContours = fmap (PolygonContours . reverse) (readIORef contours)

       withTessellatorObj (PolygonContours [])$ \tessObj -> do
          setTessellatorProperties tessObj windingRule tolerance theNormal True
          withVertexCallback tessObj addVertex $
             withEndCallback tessObj finishContour $
                checkForError tessObj $
                   withCombineCallback tessObj combiner $ do
                      defineComplexPolygon tessObj complexPoly
                      getContours

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

    -- | A triangle vertex with additional information about the edge it begins

    type TriangleVertex v = AnnotatedVertex (v,EdgeFlag)

    -- | A triangle, represented by three triangle vertices

    data Triangle v
       = Triangle (TriangleVertex v) (TriangleVertex v) (TriangleVertex v)
       deriving ( Eq, Ord )

    -- | A triangulation of a complex polygon

    newtype Triangulation v = Triangulation [Triangle v]
       deriving ( Eq, Ord )

    triangulate :: Storable v => Tessellator Triangulation v
    triangulate windingRule tolerance theNormal combiner complexPoly = do

       edgeFlagState <- newIORef BeginsInteriorEdge
       let registerEdgeFlag = writeIORef edgeFlagState

       vertices <- newIORef []
       let addVertex (AnnotatedVertex xyz v) = do
              ef <- readIORef edgeFlagState
              modifyIORef vertices (AnnotatedVertex xyz (v,ef) :)

           getTriangulation = do
              vs <- readIORef vertices
              return $ Triangulation (collectTriangles (reverse vs))

       withTessellatorObj (Triangulation []) $ \tessObj -> do
          setTessellatorProperties tessObj windingRule tolerance theNormal False
          withEdgeFlagCallback tessObj registerEdgeFlag $
             withVertexCallback tessObj addVertex $
                checkForError tessObj $
                   withCombineCallback tessObj combiner $ do
                      defineComplexPolygon tessObj complexPoly
                      getTriangulation

    collectTriangles :: [TriangleVertex v] -> [Triangle v]
    collectTriangles []           = []
    collectTriangles (a:b:c:rest) = Triangle a b c : collectTriangles rest
    collectTriangles _            = error "triangles left"

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

    data Primitive v = Primitive PrimitiveMode [AnnotatedVertex v]
       deriving ( Eq, Ord )

    newtype SimplePolygon v = SimplePolygon [Primitive v]
       deriving ( Eq, Ord )

    tessellate :: Storable v => Tessellator SimplePolygon v
    tessellate windingRule tolerance theNormal combiner complexPoly = do

       beginModeState <- newIORef undefined
       let setPrimitiveMode = writeIORef beginModeState

       vertices <- newIORef []
       let addVertex v = modifyIORef vertices (v:)

       primitives <- newIORef []
       let finishPrimitive = do
              beginMode <- readIORef beginModeState
              vs <- readIORef vertices
              writeIORef vertices []
              modifyIORef primitives (Primitive beginMode (reverse vs) :)

           getSimplePolygon = fmap (SimplePolygon . reverse) (readIORef primitives)

       withTessellatorObj (SimplePolygon []) $ \tessObj -> do
          setTessellatorProperties tessObj windingRule tolerance theNormal False
          withBeginCallback tessObj setPrimitiveMode $
             withVertexCallback tessObj addVertex $
                withEndCallback tessObj finishPrimitive $
                   checkForError tessObj $
                      withCombineCallback tessObj combiner $ do
                         defineComplexPolygon tessObj complexPoly
                         getSimplePolygon

    --------------------------------------------------------------------------------
    -- chapter 5.1: The Tessellation Object

    -- an opaque pointer to a tessellator object
    type TessellatorObj = Ptr GLUtesselator

    isNullTesselatorObj :: TessellatorObj -> Bool
    isNullTesselatorObj = (nullPtr ==)

    withTessellatorObj :: a -> (TessellatorObj -> IO a) -> IO a
    withTessellatorObj failureValue action =
       bracket gluNewTess safeDeleteTess
               (\tessObj -> if isNullTesselatorObj tessObj
                               then do recordOutOfMemory
                                       return failureValue
                               else action tessObj)

    safeDeleteTess :: TessellatorObj -> IO ()
    safeDeleteTess tessObj =
       unless (isNullTesselatorObj tessObj) $ gluDeleteTess tessObj

    --------------------------------------------------------------------------------
    -- chapter 5.2: Polygon Definition (polygons)

    defineComplexPolygon ::
       Storable v => TessellatorObj -> ComplexPolygon v -> IO ()
    defineComplexPolygon tessObj cp@(ComplexPolygon complexContours) =
       withComplexPolygon cp $ \ptr ->
          tessBeginEndPolygon tessObj nullPtr $
             let loop _ []     = return ()
                 loop p (c:cs) = do defineComplexContour tessObj (castPtr p) c
                                    loop (p `plusPtr` sizeOfComplexContour c) cs
             in loop ptr complexContours

    tessBeginEndPolygon :: TessellatorObj -> Ptr p -> IO a -> IO a
    tessBeginEndPolygon tessObj ptr f = do
       gluTessBeginPolygon tessObj ptr
       res <- f
       gluTessEndPolygon tessObj
       return res

    --------------------------------------------------------------------------------
    -- chapter 5.2: Polygon Definition (contours)

    defineComplexContour ::
       Storable v =>
       TessellatorObj -> Ptr (ComplexContour v) -> ComplexContour v -> IO ()
    defineComplexContour tessObj ptr (ComplexContour annotatedVertices) =
       tessBeginEndContour tessObj $
             let loop _ []     = return ()
                 loop p (v:vs) = do defineVertex tessObj (castPtr p)
                                    loop (p `plusPtr` sizeOf v) vs
             in loop ptr annotatedVertices

    tessBeginEndContour :: TessellatorObj -> IO a -> IO a
    tessBeginEndContour tessObj f = do
       gluTessBeginContour tessObj
       res <- f
       gluTessEndContour tessObj
       return res

    --------------------------------------------------------------------------------
    -- chapter 5.2: Polygon Definition (vertices)

    defineVertex :: TessellatorObj -> Ptr (AnnotatedVertex v) -> IO ()
    defineVertex tessObj ptr = gluTessVertex tessObj (castPtr ptr) ptr

    --------------------------------------------------------------------------------
    -- chapter 5.3: Callbacks (begin)

    type BeginCallback  = PrimitiveMode -> IO ()

    withBeginCallback :: TessellatorObj -> BeginCallback -> IO a -> IO a
    withBeginCallback tessObj beginCallback action =
       bracket (makeTessBeginCallback (beginCallback . unmarshalPrimitiveMode))
               freeHaskellFunPtr $ \callbackPtr -> do
          gluTessCallback tessObj glu_TESS_BEGIN callbackPtr
          action

    --------------------------------------------------------------------------------
    -- chapter 5.3: Callbacks (edgeFlag)

    type EdgeFlagCallback  = EdgeFlag -> IO ()

    withEdgeFlagCallback :: TessellatorObj -> EdgeFlagCallback -> IO a -> IO a
    withEdgeFlagCallback tessObj edgeFlagCallback action =
       bracket (makeTessEdgeFlagCallback (edgeFlagCallback . unmarshalEdgeFlag))
               freeHaskellFunPtr $ \callbackPtr -> do
          gluTessCallback tessObj glu_TESS_EDGE_FLAG callbackPtr
          action

    --------------------------------------------------------------------------------
    -- chapter 5.3: Callbacks (vertex)

    type VertexCallback v = AnnotatedVertex v -> IO ()

    withVertexCallback ::
       Storable v => TessellatorObj -> VertexCallback v -> IO a -> IO a
    withVertexCallback tessObj vertexCallback action =
       bracket (makeTessVertexCallback (\p -> peek p >>= vertexCallback))
               freeHaskellFunPtr $ \callbackPtr -> do
          gluTessCallback tessObj glu_TESS_VERTEX callbackPtr
          action

    --------------------------------------------------------------------------------
    -- chapter 5.3: Callbacks (end)

    type EndCallback  = IO ()

    withEndCallback :: TessellatorObj -> EndCallback -> IO a -> IO a
    withEndCallback tessObj endCallback action =
       bracket (makeTessEndCallback endCallback) freeHaskellFunPtr $ \callbackPtr -> do
          gluTessCallback tessObj glu_TESS_END callbackPtr
          action

    --------------------------------------------------------------------------------
    -- chapter 5.3: Callbacks (error)

    type ErrorCallback = GLenum -> IO ()

    withErrorCallback :: TessellatorObj -> ErrorCallback -> IO a -> IO a
    withErrorCallback tessObj errorCallback action =
       bracket (makeTessErrorCallback errorCallback)
               freeHaskellFunPtr $ \callbackPtr -> do
          gluTessCallback tessObj glu_TESS_ERROR callbackPtr
          action

    checkForError :: TessellatorObj -> IO a -> IO a
    checkForError tessObj = withErrorCallback tessObj recordErrorCode

    --------------------------------------------------------------------------------
    -- chapter 5.3: Callbacks (combine)

    type CombineCallback v =
          Ptr GLdouble
       -> Ptr (Ptr (AnnotatedVertex v))
       -> Ptr GLfloat
       -> Ptr (Ptr (AnnotatedVertex v))
       -> IO ()

    withCombineCallback ::
       Storable v => TessellatorObj -> Combiner v -> IO a -> IO a
    withCombineCallback tessObj combiner action =
       withPool $ \vertexPool ->
          bracket (makeTessCombineCallback (combineProperties vertexPool combiner))
                  freeHaskellFunPtr $ \callbackPtr -> do
             gluTessCallback tessObj glu_TESS_COMBINE callbackPtr
             action

    -- NOTE: SGI's tesselator has a bug, sometimes passing NULL for the last two
    -- vertices instead of valid vertex data, so we have to work around this. We
    -- just pass the first vertex in these cases, which is OK, because the
    -- corresponding weight is 0.
    combineProperties :: Storable v => Pool -> Combiner v -> CombineCallback v
    combineProperties pool combiner newVertexPtr propertyPtrs weights result = do
       newVertex <- peek (castPtr newVertexPtr :: Ptr (Vertex3 GLdouble))
       [v0, v1, v2, v3] <- mapM (getProperty propertyPtrs) [0..3]
       [w0, w1, w2, w3] <- peekArray 4 weights
       let defaultProperty = fromJust v0
           f = fromMaybe defaultProperty
           wp = WeightedProperties (w0, f v0) (w1, f v1) (w2, f v2) (w3, f v3)
           av = AnnotatedVertex newVertex (combiner newVertex wp)
       poke result =<< pooledNew pool av

    getProperty :: Storable v => Ptr (Ptr (AnnotatedVertex v)) -> Int -> IO (Maybe v)
    getProperty propertyPtrs n = peekElemOff propertyPtrs n >>=
                                 maybeNullPtr (return Nothing) peekProperty

    peekProperty :: Storable v => Ptr (AnnotatedVertex v) -> IO (Maybe v)
    peekProperty ptr = do
       AnnotatedVertex _ v <- peek ptr
       return (Just v)

    --------------------------------------------------------------------------------
    -- chapter 5.4: Control over Tessellation

    setTessellatorProperties ::
        TessellatorObj -> TessWinding -> Tolerance -> Normal3 GLdouble -> Bool
     -> IO ()
    setTessellatorProperties tessObj windingRule tolerance theNormal boundaryOnly = do
       setWindingRule tessObj windingRule
       setTolerance tessObj tolerance
       setNormal tessObj theNormal
       setBoundaryOnly tessObj boundaryOnly

    setWindingRule :: TessellatorObj -> TessWinding -> IO ()
    setWindingRule tessObj =
       gluTessProperty tessObj glu_TESS_WINDING_RULE . fromIntegral . marshalTessWinding

    setBoundaryOnly :: TessellatorObj -> Bool -> IO ()
    setBoundaryOnly tessObj =
       gluTessProperty tessObj glu_TESS_BOUNDARY_ONLY . marshalGLboolean

    setTolerance :: TessellatorObj -> Tolerance -> IO ()
    setTolerance tessObj = gluTessProperty tessObj glu_TESS_TOLERANCE

    setNormal :: TessellatorObj -> Normal3 GLdouble -> IO ()
    setNormal tessObj (Normal3 x y z) = gluTessNormal tessObj x y z