--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.OpenGL.GL.VertexArrays
-- Copyright   :  (c) Sven Panne 2002-2013
-- License     :  BSD3
--
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- This module corresponds to section 2.8 (Vertex Arrays) of the OpenGL 2.1
-- specs.
--
--------------------------------------------------------------------------------

module Graphics.Rendering.OpenGL.GL.VertexArrays (
   -- * Describing Data for the Arrays
   NumComponents, DataType(..), Stride, VertexArrayDescriptor(..),

   -- * Specifying Data for the Arrays
   Capability(..),
   ClientArrayType(..), arrayPointer,
   InterleavedArrays(..), interleavedArrays,

   -- * Enabling Arrays
   clientState, clientActiveTexture,

   -- * Dereferencing and Rendering
   ArrayIndex, NumArrayIndices, NumIndexBlocks,
   arrayElement, drawArrays, multiDrawArrays, drawElements, multiDrawElements,
   drawRangeElements, maxElementsVertices, maxElementsIndices, lockArrays,
   primitiveRestartIndex, primitiveRestartIndexNV,

   -- * Generic Vertex Attribute Arrays
   vertexAttribPointer, vertexAttribArray, vertexAttribDivisor,

   -- * Instanced draws
   drawArraysInstanced
) where

import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import Graphics.Rendering.OpenGL.GL.Capability
import Graphics.Rendering.OpenGL.GL.DataType
import Graphics.Rendering.OpenGL.GL.GLboolean
import Graphics.Rendering.OpenGL.GL.PrimitiveMode
import Graphics.Rendering.OpenGL.GL.QueryUtils
import Graphics.Rendering.OpenGL.GL.StateVar
import Graphics.Rendering.OpenGL.GL.Texturing.TextureUnit
import Graphics.Rendering.OpenGL.GL.VertexSpec
import Graphics.Rendering.OpenGL.GLU.ErrorsInternal
import Graphics.Rendering.OpenGL.Raw

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

type NumComponents = GLint

type Stride = GLsizei

data VertexArrayDescriptor a =
   VertexArrayDescriptor !NumComponents !DataType !Stride !(Ptr a)
   deriving ( Eq, Ord, Show )

noVertexArrayDescriptor :: VertexArrayDescriptor a
noVertexArrayDescriptor = VertexArrayDescriptor 0 Byte 0 nullPtr

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

data ClientArrayType =
     VertexArray
   | NormalArray
   | ColorArray
   | IndexArray
   | TextureCoordArray
   | EdgeFlagArray
   | FogCoordArray
   | SecondaryColorArray
   | MatrixIndexArray
   deriving ( Eq, Ord, Show )

marshalClientArrayType :: ClientArrayType -> GLenum
marshalClientArrayType x = case x of
   VertexArray -> gl_VERTEX_ARRAY
   NormalArray -> gl_NORMAL_ARRAY
   ColorArray -> gl_COLOR_ARRAY
   IndexArray -> gl_INDEX_ARRAY
   TextureCoordArray -> gl_TEXTURE_COORD_ARRAY
   EdgeFlagArray -> gl_EDGE_FLAG_ARRAY
   FogCoordArray -> gl_FOG_COORD_ARRAY
   SecondaryColorArray -> gl_SECONDARY_COLOR_ARRAY
   MatrixIndexArray -> gl_MATRIX_INDEX_ARRAY

-- Hmmm...
clientArrayTypeToEnableCap :: ClientArrayType -> EnableCap
clientArrayTypeToEnableCap x = case x of
   VertexArray -> CapVertexArray
   NormalArray -> CapNormalArray
   ColorArray -> CapColorArray
   IndexArray -> CapIndexArray
   TextureCoordArray -> CapTextureCoordArray
   EdgeFlagArray -> CapEdgeFlagArray
   FogCoordArray -> CapFogCoordArray
   SecondaryColorArray -> CapSecondaryColorArray
   MatrixIndexArray -> CapMatrixIndexArray

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

arrayPointer :: ClientArrayType -> StateVar (VertexArrayDescriptor a)
arrayPointer t = case t of
   VertexArray -> vertexPointer
   NormalArray -> normalPointer
   ColorArray -> colorPointer
   IndexArray -> indexPointer
   TextureCoordArray -> texCoordPointer
   EdgeFlagArray -> edgeFlagPointer
   FogCoordArray -> fogCoordPointer
   SecondaryColorArray -> secondaryColorPointer
   MatrixIndexArray ->
      makeStateVar
        (do recordInvalidEnum ; return noVertexArrayDescriptor)
        (const recordInvalidEnum)

check :: Bool -> IO () -> IO ()
check flag val = if flag then val else recordInvalidValue

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

vertexPointer :: StateVar (VertexArrayDescriptor a)
vertexPointer = makeStateVar getVertexPointer setVertexPointer

getVertexPointer :: IO (VertexArrayDescriptor a)
getVertexPointer = do
   n <- getInteger1 id GetVertexArraySize
   d <- getEnum1 unmarshalDataType GetVertexArrayType
   s <- getInteger1 fromIntegral GetVertexArrayStride
   p <- getPointer VertexArrayPointer
   return $ VertexArrayDescriptor n d s p

setVertexPointer :: VertexArrayDescriptor a -> IO ()
setVertexPointer (VertexArrayDescriptor n d s p) =
   glVertexPointer n (marshalDataType d) s p

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

normalPointer :: StateVar (VertexArrayDescriptor a)
normalPointer = makeStateVar getNormalPointer setNormalPointer

getNormalPointer :: IO (VertexArrayDescriptor a)
getNormalPointer = do
   d <- getEnum1 unmarshalDataType GetNormalArrayType
   s <- getInteger1 fromIntegral GetNormalArrayStride
   p <- getPointer NormalArrayPointer
   return $ VertexArrayDescriptor 3 d s p

setNormalPointer :: VertexArrayDescriptor a -> IO ()
setNormalPointer (VertexArrayDescriptor n d s p) =
   check (n == 3) $ glNormalPointer (marshalDataType d) s p

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

colorPointer :: StateVar (VertexArrayDescriptor a)
colorPointer = makeStateVar getColorPointer setColorPointer

getColorPointer :: IO (VertexArrayDescriptor a)
getColorPointer = do
   n <- getInteger1 id GetColorArraySize
   d <- getEnum1 unmarshalDataType GetColorArrayType
   s <- getInteger1 fromIntegral GetColorArrayStride
   p <- getPointer ColorArrayPointer
   return $ VertexArrayDescriptor n d s p

setColorPointer :: VertexArrayDescriptor a -> IO ()
setColorPointer (VertexArrayDescriptor n d s p) =
   check (n == 3 || n == 4) $ glColorPointer n (marshalDataType d) s p

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

indexPointer :: StateVar (VertexArrayDescriptor a)
indexPointer = makeStateVar getIndexPointer setIndexPointer

getIndexPointer :: IO (VertexArrayDescriptor a)
getIndexPointer = do
   d <- getEnum1 unmarshalDataType GetIndexArrayType
   s <- getInteger1 fromIntegral GetIndexArrayStride
   p <- getPointer IndexArrayPointer
   return $ VertexArrayDescriptor 1 d s p

setIndexPointer :: VertexArrayDescriptor a -> IO ()
setIndexPointer (VertexArrayDescriptor n d s p) =
   check (n == 1) $ glIndexPointer (marshalDataType d) s p

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

texCoordPointer :: StateVar (VertexArrayDescriptor a)
texCoordPointer = makeStateVar getTexCoordPointer setTexCoordPointer

getTexCoordPointer :: IO (VertexArrayDescriptor a)
getTexCoordPointer = do
   n <- getInteger1 id GetTextureCoordArraySize
   d <- getEnum1 unmarshalDataType GetTextureCoordArrayType
   s <- getInteger1 fromIntegral GetTextureCoordArrayStride
   p <- getPointer TextureCoordArrayPointer
   return $ VertexArrayDescriptor n d s p

setTexCoordPointer :: VertexArrayDescriptor a -> IO ()
setTexCoordPointer (VertexArrayDescriptor n d s p) =
   glTexCoordPointer n (marshalDataType d) s p

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

edgeFlagPointer :: StateVar (VertexArrayDescriptor a)
edgeFlagPointer = makeStateVar getEdgeFlagPointer setEdgeFlagPointer

getEdgeFlagPointer :: IO (VertexArrayDescriptor a)
getEdgeFlagPointer = do
   s <- getInteger1 fromIntegral GetEdgeFlagArrayStride
   p <- getPointer EdgeFlagArrayPointer
   return $ VertexArrayDescriptor 1 UnsignedByte s p

setEdgeFlagPointer :: VertexArrayDescriptor a -> IO ()
setEdgeFlagPointer (VertexArrayDescriptor n d s p) =
   check (n == 1 && d == UnsignedByte) $ glEdgeFlagPointer s p

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

fogCoordPointer :: StateVar (VertexArrayDescriptor a)
fogCoordPointer = makeStateVar getFogCoordPointer setFogCoordPointer

getFogCoordPointer :: IO (VertexArrayDescriptor a)
getFogCoordPointer = do
   d <- getEnum1 unmarshalDataType GetFogCoordArrayType
   s <- getInteger1 fromIntegral GetFogCoordArrayStride
   p <- getPointer FogCoordArrayPointer
   return $ VertexArrayDescriptor 1 d s p

setFogCoordPointer :: VertexArrayDescriptor a -> IO ()
setFogCoordPointer (VertexArrayDescriptor n d s p) =
   check (n == 1) $ glFogCoordPointer (marshalDataType d) s p

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

secondaryColorPointer :: StateVar (VertexArrayDescriptor a)
secondaryColorPointer =
   makeStateVar getSecondaryColorPointer setSecondaryColorPointer

getSecondaryColorPointer :: IO (VertexArrayDescriptor a)
getSecondaryColorPointer = do
   n <- getInteger1 id GetSecondaryColorArraySize
   d <- getEnum1 unmarshalDataType GetSecondaryColorArrayType
   s <- getInteger1 fromIntegral GetSecondaryColorArrayStride
   p <- getPointer SecondaryColorArrayPointer
   return $ VertexArrayDescriptor n d s p

setSecondaryColorPointer :: (VertexArrayDescriptor a) -> IO ()
setSecondaryColorPointer (VertexArrayDescriptor n d s p) =
   glSecondaryColorPointer n (marshalDataType d) s p

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

data InterleavedArrays =
     V2f
   | V3f
   | C4ubV2f
   | C4ubV3f
   | C3fV3f
   | N3fV3f
   | C4fN3fV3f
   | T2fV3f
   | T4fV4f
   | T2fC4ubV3f
   | T2fC3fV3f
   | T2fN3fV3f
   | T2fC4fN3fV3f
   | T4fC4fN3fV4f
   deriving ( Eq, Ord, Show )

marshalInterleavedArrays :: InterleavedArrays -> GLenum
marshalInterleavedArrays x = case x of
   V2f -> gl_V2F
   V3f -> gl_V3F
   C4ubV2f -> gl_C4UB_V2F
   C4ubV3f -> gl_C4UB_V3F
   C3fV3f -> gl_C3F_V3F
   N3fV3f -> gl_N3F_V3F
   C4fN3fV3f -> gl_C4F_N3F_V3F
   T2fV3f -> gl_T2F_V3F
   T4fV4f -> gl_T4F_V4F
   T2fC4ubV3f -> gl_T2F_C4UB_V3F
   T2fC3fV3f -> gl_T2F_C3F_V3F
   T2fN3fV3f -> gl_T2F_N3F_V3F
   T2fC4fN3fV3f -> gl_T2F_C4F_N3F_V3F
   T4fC4fN3fV4f -> gl_T4F_C4F_N3F_V4F

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

interleavedArrays :: InterleavedArrays -> Stride -> Ptr a -> IO ()
interleavedArrays = glInterleavedArrays . marshalInterleavedArrays

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

clientState :: ClientArrayType -> StateVar Capability
clientState arrayType =
   makeStateVar (getClientState arrayType) (setClientState arrayType)

getClientState :: ClientArrayType -> IO Capability
getClientState arrayType = get . makeCapability . clientArrayTypeToEnableCap $ arrayType

setClientState :: ClientArrayType -> Capability -> IO ()
setClientState arrayType val =
   (if val == Enabled then glEnableClientState else glDisableClientState)
      (marshalClientArrayType arrayType)

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

clientActiveTexture :: StateVar TextureUnit
clientActiveTexture =
   makeStateVar (getEnum1 unmarshalTextureUnit GetClientActiveTexture)
                (glClientActiveTexture . marshalTextureUnit)

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

type ArrayIndex = GLint

type NumArrayIndices = GLsizei

type NumIndexBlocks = GLsizei

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

arrayElement :: ArrayIndex -> IO ()
arrayElement = glArrayElement

drawArraysInstanced :: PrimitiveMode -> ArrayIndex -> NumArrayIndices -> GLsizei -> IO ()
drawArraysInstanced = glDrawArraysInstanced . marshalPrimitiveMode

drawArrays :: PrimitiveMode -> ArrayIndex -> NumArrayIndices -> IO ()
drawArrays = glDrawArrays . marshalPrimitiveMode

multiDrawArrays ::
      PrimitiveMode -> Ptr ArrayIndex -> Ptr NumArrayIndices -> NumIndexBlocks
   -> IO ()
multiDrawArrays = glMultiDrawArrays . marshalPrimitiveMode

drawElements :: PrimitiveMode -> NumArrayIndices -> DataType -> Ptr a -> IO ()
drawElements m c = glDrawElements (marshalPrimitiveMode m) c . marshalDataType

multiDrawElements ::
      PrimitiveMode -> Ptr NumArrayIndices -> DataType -> Ptr (Ptr a)
   -> NumIndexBlocks -> IO ()
multiDrawElements m c =
   glMultiDrawElements (marshalPrimitiveMode m) c . marshalDataType

drawRangeElements ::
      PrimitiveMode -> (ArrayIndex, ArrayIndex) -> NumArrayIndices -> DataType
   -> Ptr a -> IO ()
drawRangeElements m (s, e) c =
   glDrawRangeElements (marshalPrimitiveMode m) (fromIntegral s)
                       (fromIntegral e) c . marshalDataType

maxElementsVertices :: GettableStateVar NumArrayIndices
maxElementsVertices = makeGettableStateVar (getSizei1 id GetMaxElementsVertices)

maxElementsIndices :: GettableStateVar NumArrayIndices
maxElementsIndices = makeGettableStateVar (getSizei1 id GetMaxElementsIndices)

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

lockArrays :: StateVar (Maybe (ArrayIndex, NumArrayIndices))
lockArrays = makeStateVar getLockArrays setLockArrays

getLockArrays :: IO (Maybe (ArrayIndex, NumArrayIndices))
getLockArrays = do
   count <- getInteger1 fromIntegral GetArrayElementLockCount
   if count > 0
      then do first <- getInteger1 id GetArrayElementLockFirst
              return $ Just (first, count)
      else return Nothing

setLockArrays :: Maybe (ArrayIndex, NumArrayIndices) -> IO ()
setLockArrays = maybe glUnlockArrays (uncurry glLockArrays)

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

primitiveRestartIndex :: StateVar (Maybe ArrayIndex)
primitiveRestartIndex =
   makeStateVarMaybe
      (return CapPrimitiveRestart)
      (getInteger1 id GetPrimitiveRestartIndex)
      (glPrimitiveRestartIndex . fromIntegral)

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

-- We almost could use makeStateVarMaybe below, but, alas, this is client state.

primitiveRestartIndexNV :: StateVar (Maybe ArrayIndex)
primitiveRestartIndexNV =
   makeStateVar getPrimitiveRestartIndexNV setPrimitiveRestartIndexNV

getPrimitiveRestartIndexNV :: IO (Maybe ArrayIndex)
getPrimitiveRestartIndexNV = do
   on <- getBoolean1 unmarshalGLboolean GetPrimitiveRestartNV
   if on
      then fmap Just $ getInteger1 fromIntegral GetPrimitiveRestartIndexNV
      else return Nothing

setPrimitiveRestartIndexNV :: Maybe ArrayIndex -> IO ()
setPrimitiveRestartIndexNV maybeIdx = case maybeIdx of
   Nothing  -> glDisableClientState gl_PRIMITIVE_RESTART_NV
   Just idx -> do glEnableClientState gl_PRIMITIVE_RESTART_NV
                  glPrimitiveRestartIndexNV (fromIntegral idx)

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

data GetPointervPName =
     VertexArrayPointer
   | NormalArrayPointer
   | ColorArrayPointer
   | IndexArrayPointer
   | TextureCoordArrayPointer
   | EdgeFlagArrayPointer
   | FogCoordArrayPointer
   | SecondaryColorArrayPointer
   | FeedbackBufferPointer
   | SelectionBufferPointer
   | WeightArrayPointer
   | MatrixIndexArrayPointer

marshalGetPointervPName :: GetPointervPName -> GLenum
marshalGetPointervPName x = case x of
   VertexArrayPointer -> gl_VERTEX_ARRAY_POINTER
   NormalArrayPointer -> gl_NORMAL_ARRAY_POINTER
   ColorArrayPointer -> gl_COLOR_ARRAY_POINTER
   IndexArrayPointer -> gl_INDEX_ARRAY_POINTER
   TextureCoordArrayPointer -> gl_TEXTURE_COORD_ARRAY_POINTER
   EdgeFlagArrayPointer -> gl_EDGE_FLAG_ARRAY_POINTER
   FogCoordArrayPointer -> gl_FOG_COORD_ARRAY_POINTER
   SecondaryColorArrayPointer -> gl_SECONDARY_COLOR_ARRAY_POINTER
   FeedbackBufferPointer -> gl_FEEDBACK_BUFFER_POINTER
   SelectionBufferPointer -> gl_SELECTION_BUFFER_POINTER
   WeightArrayPointer -> gl_WEIGHT_ARRAY_POINTER
   MatrixIndexArrayPointer -> gl_MATRIX_INDEX_ARRAY_POINTER

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

getPointer :: GetPointervPName -> IO (Ptr a)
getPointer n = alloca $ \buf -> do
   glGetPointerv (marshalGetPointervPName n) buf
   peek buf

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

vertexAttribPointer :: AttribLocation -> StateVar (IntegerHandling, VertexArrayDescriptor a)
vertexAttribPointer location =
   makeStateVar (getVertexAttribPointer_ location) (setVertexAttribPointer location)

vertexAttribDivisor :: AttribLocation -> Integer -> IO ()
vertexAttribDivisor (AttribLocation loc) divisor = glVertexAttribDivisor loc (fromIntegral divisor)

getVertexAttribPointer_ :: AttribLocation -> IO (IntegerHandling, VertexArrayDescriptor a)
getVertexAttribPointer_ location = do
   i <- getVertexAttribBoolean1 unmarshalGLboolean location GetVertexAttribArrayInteger
   h <- if i
           then return KeepIntegral
           else do f <- getVertexAttribBoolean1 unmarshalGLboolean location GetVertexAttribArrayNormalized
                   return $ if f then ToNormalizedFloat else ToFloat
   n <- getVertexAttribInteger1 id location GetVertexAttribArraySize
   d <- getVertexAttribEnum1 unmarshalDataType location GetVertexAttribArrayType
   s <- getVertexAttribInteger1 fromIntegral location GetVertexAttribArrayStride
   p <- getVertexAttribPointer location VertexAttribArrayPointer
   return (h, VertexArrayDescriptor n d s p)

setVertexAttribPointer :: AttribLocation -> (IntegerHandling, VertexArrayDescriptor a) -> IO ()
setVertexAttribPointer (AttribLocation location) (h, VertexArrayDescriptor n d s p) = case h of
   ToFloat -> glVertexAttribPointer location n md (marshalGLboolean False) s p
   ToNormalizedFloat -> glVertexAttribPointer location n md (marshalGLboolean True) s p
   KeepIntegral -> glVertexAttribIPointer location n md s p
  where md = marshalDataType d

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

vertexAttribArray :: AttribLocation -> StateVar Capability
vertexAttribArray location =
   makeStateVar (getVertexAttribArray location) (flip setVertexAttribArray location)

getVertexAttribArray :: AttribLocation -> IO Capability
getVertexAttribArray location =
   getVertexAttribBoolean1 unmarshalCapability location GetVertexAttribArrayEnabled

setVertexAttribArray :: Capability -> AttribLocation -> IO ()
setVertexAttribArray Disabled (AttribLocation location) = glDisableVertexAttribArray location
setVertexAttribArray Enabled (AttribLocation location) = glEnableVertexAttribArray location
