    {-# LANGUAGE KindSignatures #-}
    --------------------------------------------------------------------------------
    -- |
    -- Module      :  Graphics.Rendering.OpenGL.GL.Evaluators
    -- 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 section 5.1 (Evaluators) of the OpenGL 2.1 specs.
    --
    --------------------------------------------------------------------------------

    module Graphics.Rendering.OpenGL.GL.Evaluators (
       -- * Evaluator-related Types
       Order, maxOrder, Domain, MapDescriptor(..), ControlPoint,

       -- * Defining Evaluator Maps
       -- ** One-dimensional Evaluator Maps
       Map1(..), GLmap1, map1,

       -- ** Two-dimensional Evaluator Maps
       Map2(..), GLmap2, map2,

       -- * Using Evaluator Maps

       -- ** Evaluating an Arbitrary Coordinate Value
       evalCoord1, evalCoord1v, evalCoord2, evalCoord2v,

       -- ** Using Evenly Spaced Coordinate Values

       -- *** Defining a Grid
       mapGrid1, mapGrid2,

       -- *** Evaluating a Whole Mesh
       evalMesh1, evalMesh2,

       -- *** Evaluating a Single Point on a Mesh
       evalPoint1, evalPoint2,

       -- * Normal Generation
       autoNormal
    ) where

    import Control.Monad
    import Data.List
    import Foreign.ForeignPtr
    import Foreign.Marshal.Alloc
    import Foreign.Marshal.Array
    import Foreign.Ptr
    import Foreign.Storable
    import Graphics.Rendering.OpenGL.GL.StateVar
    import Graphics.Rendering.OpenGL.GL.Capability
    import Graphics.Rendering.OpenGL.GL.ControlPoint
    import Graphics.Rendering.OpenGL.GL.Domain
    import Graphics.Rendering.OpenGL.GL.PeekPoke
    import Graphics.Rendering.OpenGL.GL.PolygonMode
    import Graphics.Rendering.OpenGL.GL.QueryUtils
    import Graphics.Rendering.OpenGL.GL.VertexArrays
    import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility (
       glEvalMesh1, glEvalMesh2, glEvalPoint1, glEvalPoint2, glGetMapiv, gl_COEFF,
       gl_DOMAIN, gl_ORDER )
    import Graphics.Rendering.OpenGL.Raw.Core31

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

    type Order = GLint

    maxOrder :: GettableStateVar Order
    maxOrder = makeGettableStateVar (getInteger1 id GetMaxEvalOrder)

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

    data MapDescriptor d =
       MapDescriptor (d, d) Stride Order NumComponents
       deriving ( Eq, Ord, Show )

    totalComponents1 :: Domain d => MapDescriptor d -> Int
    totalComponents1 (MapDescriptor _ stride order numComp) =
       fromIntegral stride * (fromIntegral order - 1) + fromIntegral numComp

    totalComponents2 :: Domain d => MapDescriptor d -> MapDescriptor d -> Int
    totalComponents2 uDescriptor vDescriptor@(MapDescriptor _ _ _ numComp) =
       totalComponents1 uDescriptor + totalComponents1 vDescriptor - fromIntegral numComp

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

    peekControlPoints1 ::
       (ControlPoint c, Domain d) => MapDescriptor d -> Ptr d -> IO [c d]
    peekControlPoints1 descriptor ptr =
       mapM peekControlPoint (controlPointPtrs1 descriptor ptr)

    peekControlPoints2 ::
          (ControlPoint c, Domain d)
       => MapDescriptor d -> MapDescriptor d -> Ptr d -> IO [[c d]]
    peekControlPoints2 uDescriptor vDescriptor ptr =
       mapM (mapM peekControlPoint) (controlPointPtrs2 uDescriptor vDescriptor ptr)

    pokeControlPoints1 ::
       (ControlPoint c, Domain d) => MapDescriptor d -> Ptr d -> [c d] -> IO ()
    pokeControlPoints1 descriptor ptr =
       zipWithM_ pokeControlPoint (controlPointPtrs1 descriptor ptr)

    pokeControlPoints2 ::
          (ControlPoint c, Domain d)
       => MapDescriptor d -> MapDescriptor d -> Ptr d -> [[c d]] -> IO ()
    pokeControlPoints2 uDescriptor vDescriptor ptr =
       zipWithM_ (zipWithM_ pokeControlPoint)
                 (controlPointPtrs2 uDescriptor vDescriptor ptr)

    controlPointPtrs1 :: Domain d => MapDescriptor d -> Ptr d -> [Ptr a]
    controlPointPtrs1 (MapDescriptor _ stride order _) ptr =
       [ ptr `plusPtr` (o * s) | o <- [ 0 .. fromIntegral order - 1 ] ]
       where s = sizeOfPtr ptr * fromIntegral stride

    controlPointPtrs2 ::
       Domain d => MapDescriptor d -> MapDescriptor d -> Ptr d -> [[Ptr a]]
    controlPointPtrs2 uDescriptor vDescriptor ptr =
       [ controlPointPtrs1 vDescriptor p | p <- controlPointPtrs1 uDescriptor ptr ]

    sizeOfPtr :: Storable a => Ptr a -> Int
    sizeOfPtr = sizeOf . (const undefined :: Ptr a -> a)

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

    class Map1 m where
       withNewMap1 :: (ControlPoint c, Domain d)
          => MapDescriptor d -> (Ptr d -> IO ()) -> IO (m c d)

       withMap1 :: (ControlPoint c, Domain d)
          => m c d -> (MapDescriptor d -> Ptr d -> IO a) -> IO a

       newMap1 :: (ControlPoint c, Domain d)
          => (d, d) -> [c d] -> IO (m c d)

       getMap1Components :: (ControlPoint c, Domain d)
          => m c d -> IO ((d, d), [c d])

       withNewMap1 descriptor@(MapDescriptor domain _ _ _) act = do
          allocaArray (totalComponents1 descriptor) $ \ptr -> do
             act ptr
             controlPoints <- peekControlPoints1 descriptor ptr
             newMap1 domain controlPoints

       withMap1 m act = do
          (domain, controlPoints) <- getMap1Components m
          let stride = numComponents (head controlPoints)
              order = genericLength controlPoints
              descriptor = MapDescriptor domain stride order (fromIntegral stride)
          allocaArray (totalComponents1 descriptor) $ \ptr -> do
             pokeControlPoints1 descriptor ptr controlPoints
             act descriptor ptr

       newMap1 domain controlPoints = do
          let stride = numComponents (head controlPoints)
              order = genericLength controlPoints
              descriptor = MapDescriptor domain stride order (fromIntegral stride)
          withNewMap1 descriptor $ \ptr ->
             pokeControlPoints1 descriptor ptr controlPoints

       getMap1Components m =
          withMap1 m $ \descriptor@(MapDescriptor domain _ _ _) ptr -> do
             controlPoints <- peekControlPoints1 descriptor ptr
             return (domain, controlPoints)

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

    data GLmap1 (c :: * -> *) d =
       GLmap1 (MapDescriptor d) (ForeignPtr d)
       deriving ( Eq, Ord, Show )

    instance Map1 GLmap1 where
       withNewMap1 descriptor act = do
          fp <- mallocForeignPtrArray (totalComponents1 descriptor)
          withForeignPtr fp act
          return $ GLmap1 descriptor fp

       withMap1 (GLmap1 descriptor fp) act =
          withForeignPtr fp $ act descriptor

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

    map1 :: (Map1 m, ControlPoint c, Domain d) => StateVar (Maybe (m c d))
    map1 = makeMap1StateVar enableCap1 getMap1 setMap1

    makeMap1StateVar ::
          (c d -> EnableCap) -> (c d -> IO (m c d)) -> (c d -> m c d -> IO ())
       -> StateVar (Maybe (m c d))
    makeMap1StateVar getCap getAct setAct =
       makeStateVarMaybe
          (return (getCap undefined))
          (getAct undefined)
          (setAct undefined)

    getMap1 :: (Map1 m, ControlPoint c, Domain d) => c d -> IO (m c d)
    getMap1 dummyControlPoint = do
       let target = map1Target dummyControlPoint
           numComp = fromIntegral (numComponents dummyControlPoint)
       domain <- allocaArray 2 $ \ptr -> do
          glGetMapv target (marshalGetMapQuery Domain) ptr
          peek2 (,) ptr
       order <- alloca $ \ptr -> do
          glGetMapiv target (marshalGetMapQuery Order) ptr
          fmap fromIntegral $ peek ptr
       withNewMap1 (MapDescriptor domain (numComponents dummyControlPoint) order numComp) $
          glGetMapv target (marshalGetMapQuery Coeff)

    setMap1 :: (Map1 m, ControlPoint c, Domain d) => c d -> m c d -> IO ()
    setMap1 dummyControlPoint m =
       withMap1 m $ \(MapDescriptor (u1, u2) stride order _) ->
          glMap1 (map1Target dummyControlPoint) u1 u2
                 (fromIntegral stride) (fromIntegral order)

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

    class Map2 m where
       withNewMap2 :: (ControlPoint c, Domain d)
          => MapDescriptor d -> MapDescriptor d -> (Ptr d -> IO ()) -> IO (m c d)

       withMap2 :: (ControlPoint c, Domain d)
          => m c d -> (MapDescriptor d -> MapDescriptor d -> Ptr d -> IO a) -> IO a

       newMap2 :: (ControlPoint c, Domain d)
          => (d, d) -> (d, d) -> [[c d]] -> IO (m c d)

       getMap2Components :: (ControlPoint c, Domain d)
          => m c d -> IO ((d, d), (d, d), [[c d]])

       withNewMap2 uDescriptor@(MapDescriptor uDomain _ _ _)
                   vDescriptor@(MapDescriptor vDomain _ _ _) act =
          allocaArray (totalComponents2 uDescriptor vDescriptor) $ \ptr -> do
             act ptr
             controlPoints <- peekControlPoints2 uDescriptor vDescriptor ptr
             newMap2 uDomain vDomain controlPoints

       withMap2 m act = do
          (uDomain, vDomain, controlPoints) <- getMap2Components m
          let vStride = numComponents (head (head controlPoints))
              vOrder = genericLength (head controlPoints)
              uStride = vStride * fromIntegral vOrder
              uOrder = genericLength controlPoints
              numComp = fromIntegral vStride
              uDescriptor = MapDescriptor uDomain uStride uOrder numComp
              vDescriptor = MapDescriptor vDomain vStride vOrder numComp
          allocaArray (totalComponents2 uDescriptor vDescriptor) $ \ptr -> do
             pokeControlPoints2 uDescriptor vDescriptor ptr controlPoints
             act uDescriptor vDescriptor ptr

       newMap2 uDomain vDomain controlPoints = do
          let vStride = numComponents (head (head controlPoints))
              vOrder = genericLength (head controlPoints)
              uStride = vStride * fromIntegral vOrder
              uOrder = genericLength controlPoints
              numComp = fromIntegral vStride
              uDescriptor = MapDescriptor uDomain uStride uOrder numComp
              vDescriptor = MapDescriptor vDomain vStride vOrder numComp
          withNewMap2 uDescriptor vDescriptor $ \ptr ->
             pokeControlPoints2 uDescriptor vDescriptor ptr controlPoints

       getMap2Components m =
          withMap2 m $ \uDescriptor@(MapDescriptor uDomain _ _ _)
                        vDescriptor@(MapDescriptor vDomain _ _ _) ptr -> do
             controlPoints <- peekControlPoints2 uDescriptor vDescriptor ptr
             return (uDomain, vDomain, controlPoints)

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

    data GLmap2 (c :: * -> *) d =
       GLmap2 (MapDescriptor d)  (MapDescriptor d) (ForeignPtr d)
       deriving ( Eq, Ord, Show )

    instance Map2 GLmap2 where
       withNewMap2 uDescriptor vDescriptor act = do
          fp <- mallocForeignPtrArray (totalComponents2 uDescriptor vDescriptor)
          withForeignPtr fp act
          return $ GLmap2 uDescriptor vDescriptor fp

       withMap2 (GLmap2 uDescriptor vDescriptor fp) act =
          withForeignPtr fp $ act uDescriptor vDescriptor

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

    map2 :: (Map2 m, ControlPoint c, Domain d) => StateVar (Maybe (m c d))
    map2 = makeMap2StateVar enableCap2 getMap2 setMap2

    makeMap2StateVar ::
          (c d -> EnableCap) -> (c d -> IO (m c d)) -> (c d -> m c d -> IO ())
       -> StateVar (Maybe (m c d))
    makeMap2StateVar getCap getAct setAct =
       makeStateVarMaybe
          (return (getCap undefined))
          (getAct undefined)
          (setAct undefined)

    getMap2 :: (Map2 m, ControlPoint c, Domain d) => c d -> IO (m c d)
    getMap2 dummyControlPoint = do
       let target = map2Target dummyControlPoint
       (uDomain, vDomain) <- allocaArray 4 $ \ptr -> do
          glGetMapv target (marshalGetMapQuery Domain) ptr
          peek4 (\u1 u2 v1 v2 -> ((u1, u2), (v1, v2))) ptr
       (uOrder, vOrder) <- allocaArray 2 $ \ptr -> do
          glGetMapiv target (marshalGetMapQuery Order) ptr
          peek2 (,) ptr
       let vStride = numComponents dummyControlPoint
           uStride = vStride * fromIntegral vOrder
       withNewMap2 (MapDescriptor uDomain uStride uOrder (fromIntegral vStride))
                   (MapDescriptor vDomain vStride vOrder (fromIntegral vStride)) $
          glGetMapv target (marshalGetMapQuery Coeff)

    setMap2 :: (Map2 m, ControlPoint c, Domain d) => c d -> m c d -> IO ()
    setMap2 dummyControlPoint m =
       withMap2 m $ \(MapDescriptor (u1, u2) uStride uOrder _)
                     (MapDescriptor (v1, v2) vStride vOrder _) ->
          glMap2 (map2Target dummyControlPoint)
                 u1 u2 (fromIntegral uStride) (fromIntegral uOrder)
                 v1 v2 (fromIntegral vStride) (fromIntegral vOrder)

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

    data GetMapQuery =
         Coeff
       | Order
       | Domain

    marshalGetMapQuery :: GetMapQuery -> GLenum
    marshalGetMapQuery x = case x of
       Coeff -> gl_COEFF
       Order -> gl_ORDER
       Domain -> gl_DOMAIN

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

    mapGrid1 :: Domain d => StateVar (GLint, (d, d))
    mapGrid1 =
       makeStateVar
          (do n <- getInteger1 id GetMap1GridSegments
              domain <- get2 (,) GetMap1GridDomain
              return (n, domain))
          (\(n, (u1, u2)) -> glMapGrid1 n u1 u2)

    mapGrid2 :: Domain d => StateVar ((GLint, (d, d)), (GLint, (d, d)))
    mapGrid2 =
       makeStateVar
          (do (un, vn) <- getInteger2 (,) GetMap2GridSegments
              (u1, u2, v1, v2) <- get4 (,,,) GetMap2GridDomain
              return ((un, (u1, u2)), (vn, (v1, v2))))
          (\((un, (u1, u2)), (vn, (v1, v2))) -> glMapGrid2 un u1 u2 vn v1 v2)

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

    evalMesh1 :: PolygonMode -> (GLint, GLint) -> IO ()
    evalMesh1 m (p1, p2) = glEvalMesh1 (marshalPolygonMode m) p1 p2

    evalMesh2 :: PolygonMode -> (GLint, GLint) -> (GLint, GLint) -> IO ()
    evalMesh2 m (p1, p2) (q1, q2) = glEvalMesh2 (marshalPolygonMode m) p1 p2 q1 q2

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

    evalPoint1 :: GLint -> IO ()
    evalPoint1 = glEvalPoint1

    evalPoint2 :: (GLint, GLint) -> IO ()
    evalPoint2 = uncurry glEvalPoint2

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

    autoNormal :: StateVar Capability
    autoNormal = makeCapability CapAutoNormal