--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.OGL.GL.Evaluators
-- Copyright   :  (c) Sven Panne 2002-2006
-- 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.OGL.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 ( zipWithM_ )
import Data.List ( genericLength )
import Foreign.ForeignPtr ( ForeignPtr, mallocForeignPtrArray, withForeignPtr )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Array ( allocaArray )
import Foreign.Ptr ( Ptr, plusPtr )
import Foreign.Storable ( Storable(peek,sizeOf) )
import Graphics.Rendering.OGL.Monad
import Graphics.Rendering.OGL.GL.Capability (
   EnableCap(CapAutoNormal), makeCapability, makeStateVarMaybe )
import Graphics.Rendering.OGL.GL.ControlPoint
import Graphics.Rendering.OGL.GL.Domain
import Graphics.Rendering.OGL.GL.BasicTypes ( GLenum, GLint, Capability )
import Graphics.Rendering.OGL.GL.PeekPoke ( peek2, peek4 )
import Graphics.Rendering.OGL.GL.PolygonMode ( marshalPolygonMode )
import Graphics.Rendering.OGL.GL.Polygons ( PolygonMode )
import Graphics.Rendering.OGL.GL.QueryUtils (
   GetPName(GetMaxEvalOrder,
            GetMap1GridSegments,GetMap1GridDomain,
            GetMap2GridSegments,GetMap2GridDomain),
   getSizei1, getInteger1, getInteger2 )
import Graphics.Rendering.OGL.GL.StateVar (
   GettableStateVar, makeGettableStateVar, StateVar, makeStateVar )
import Graphics.Rendering.OGL.GL.VertexArrays ( NumComponents, Stride )

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

#include "HsOpenGLTypes.h"

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

type Order = GLint

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

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

data Domain d => 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 = (flip (const sizeOf) :: Storable a => Ptr a -> a -> Int) undefined

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

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

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

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

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

   withNewMap1 descriptor@(MapDescriptor domain _ _ _) act = liftIO $ do
      allocaArray (totalComponents1 descriptor) $ \ptr -> do
         runGL $ act ptr
         controlPoints <- peekControlPoints1 descriptor ptr
         runGL $ 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)
		  
      liftIO . allocaArray (totalComponents1 descriptor) $ \ptr -> do
         pokeControlPoints1 descriptor ptr controlPoints
         runGL $ 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 ->
         liftIO $ pokeControlPoints1 descriptor ptr controlPoints

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

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

data (ControlPoint c, Domain d) => GLmap1 c d =
   GLmap1 (MapDescriptor d) (ForeignPtr d)
#ifdef __HADDOCK__
-- Help Haddock a bit, because it doesn't do any instance inference.
instance Eq d => Eq (GLmap1 c d)
instance Ord d => Ord (GLmap1 c d)
instance Show d => Show (GLmap1 c d)
#else
   deriving ( Eq, Ord, Show )
#endif

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

   withMap1 (GLmap1 descriptor fp) act = liftIO $
      withForeignPtr fp $ (runGL . 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
   runGL $ withNewMap1 (MapDescriptor domain (numComponents dummyControlPoint) order numComp) $
      (liftIO . glGetMapv target (marshalGetMapQuery Coeff))

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

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

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

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

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

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

   withNewMap2 uDescriptor@(MapDescriptor uDomain _ _ _)
               vDescriptor@(MapDescriptor vDomain _ _ _) act = liftIO . 
      allocaArray (totalComponents2 uDescriptor vDescriptor) $ \ptr -> do
         runGL $ act ptr
         controlPoints <- peekControlPoints2 uDescriptor vDescriptor ptr
         runGL $ 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
      liftIO . allocaArray (totalComponents2 uDescriptor vDescriptor) $ \ptr -> do
         pokeControlPoints2 uDescriptor vDescriptor ptr controlPoints
         runGL $ 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 -> liftIO $ 
         pokeControlPoints2 uDescriptor vDescriptor ptr controlPoints

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

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

data (ControlPoint c, Domain d) => GLmap2 c d =
   GLmap2 (MapDescriptor d)  (MapDescriptor d) (ForeignPtr d)
#ifdef __HADDOCK__
-- Help Haddock a bit, because it doesn't do any instance inference.
instance Eq d => Eq (GLmap2 c d)
instance Ord d => Ord (GLmap2 c d)
instance Show d => Show (GLmap2 c d)
#else
   deriving ( Eq, Ord, Show )
#endif

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

   withMap2 (GLmap2 uDescriptor vDescriptor fp) act = liftIO . 
      withForeignPtr fp $ (runGL . 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
   runGL . withNewMap2 (MapDescriptor uDomain uStride uOrder (fromIntegral vStride))
               (MapDescriptor vDomain vStride vOrder (fromIntegral vStride)) $
      (liftIO . glGetMapv target (marshalGetMapQuery Coeff))

setMap2 :: (Map2 m, ControlPoint c, Domain d) => c d -> m c d -> IO ()
setMap2 dummyControlPoint m = runGL . 
   withMap2 m $ \(MapDescriptor (u1, u2) uStride uOrder _)
                 (MapDescriptor (v1, v2) vStride vOrder _) ->
      liftIO . 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 -> 0xa00
   Order -> 0xa01
   Domain -> 0xa02

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

foreign import CALLCONV unsafe "glGetMapiv" glGetMapiv ::
   GLenum -> GLenum -> Ptr GLint -> IO ()

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

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) -> GL ()
evalMesh1 m (p1, p2) = glEvalMesh1 (marshalPolygonMode m) p1 p2

foreign import CALLCONV unsafe "glEvalMesh1" glEvalMesh1 ::
   GLenum -> GLint -> GLint -> GL ()

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

foreign import CALLCONV unsafe "glEvalMesh2" glEvalMesh2 ::
   GLenum -> GLint -> GLint -> GLint -> GLint -> GL ()

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

foreign import CALLCONV unsafe "glEvalPoint1" evalPoint1 ::
   GLint -> PrimitiveGL ()

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

foreign import CALLCONV unsafe "glEvalPoint2" glEvalPoint2 ::
   GLint -> GLint -> PrimitiveGL ()

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

autoNormal :: StateVar Capability
autoNormal = makeCapability CapAutoNormal