--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.OGL.GL.BufferObjects
-- 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 2.9 (Buffer Objects) of the OpenGL 2.1
-- specs.
--
--------------------------------------------------------------------------------

module Graphics.Rendering.OGL.GL.BufferObjects (
   -- * Object Names
   ObjectName(..),

   -- * Buffer Objects
   BufferObject(BufferObject),

   -- * Binding Buffer Objects
   BufferTarget(..), bindBuffer, arrayBufferBinding,

   -- * Handling Buffer Data
   BufferUsage(..), bufferData, TransferDirection(..), bufferSubData,

   -- * Mapping Buffer Objects
   BufferAccess(..), MappingFailure(..), withMappedBuffer,
   bufferAccess, bufferMapped, mapBuffer, unmapBuffer
) where

import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Array ( withArrayLen, peekArray, allocaArray )
import Foreign.Ptr ( Ptr, nullPtr )
import Foreign.Storable ( Storable(peek) )
import Graphics.Rendering.OGL.Monad
import Graphics.Rendering.OGL.GL.BasicTypes (
   GLboolean, GLenum, GLint, GLintptr, GLuint, GLsizei, GLsizeiptr )
import Graphics.Rendering.OGL.GL.Exception ( finallyRet )
import Graphics.Rendering.OGL.GL.Extensions (
   FunPtr, unsafePerformIO, Invoker, getProcAddress )
import Graphics.Rendering.OGL.GL.GLboolean ( unmarshalGLboolean )
import Graphics.Rendering.OGL.GL.PeekPoke ( peek1 )
import Graphics.Rendering.OGL.GL.QueryUtils (
   GetPName(GetArrayBufferBinding,GetElementArrayBufferBinding,
            GetVertexArrayBufferBinding,GetNormalArrayBufferBinding,
            GetColorArrayBufferBinding,GetIndexArrayBufferBinding,
            GetTextureCoordArrayBufferBinding,GetEdgeFlagArrayBufferBinding,
            GetFogCoordArrayBufferBinding,GetSecondaryColorArrayBufferBinding,
            GetPixelPackBufferBinding,GetPixelUnpackBufferBinding ),
   getInteger1 )
import Graphics.Rendering.OGL.GL.StateVar (
   GettableStateVar, makeGettableStateVar, StateVar, makeStateVar )
import Graphics.Rendering.OGL.GL.VertexArrays ( ClientArrayType(..) )
import Graphics.Rendering.OGL.GLU.ErrorsInternal ( recordInvalidEnum )

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

#include "HsOpenGLExt.h"

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

-- | An 'ObjectName' corresponds to the general OpenGL notion of an explicitly
-- handled object name, e.g. a display list name, a texture object name, a
-- buffer object name, etc.

class ObjectName a where
   genObjectNames :: Int -> GL [a]
   deleteObjectNames:: [a] -> GL ()
   isObjectName :: a -> GL Bool

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

newtype BufferObject = BufferObject { bufferID :: GLuint }
   deriving ( Eq, Ord, Show )

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

instance ObjectName BufferObject where
   genObjectNames n = liftIO . 
      allocaArray n $ \buf -> do
        glGenBuffersARB (fromIntegral n) buf
        fmap (map BufferObject) $ peekArray n buf

   deleteObjectNames bufferObjects = liftIO .
      withArrayLen (map bufferID bufferObjects) $
         glDeleteBuffersARB . fromIntegral

   isObjectName = liftIO . fmap unmarshalGLboolean . glIsBufferARB . bufferID

EXTENSION_ENTRY("GL_ARB_vertex_buffer_object or OpenGL 1.5",glGenBuffersARB,GLsizei -> Ptr GLuint -> IO ())

EXTENSION_ENTRY("GL_ARB_vertex_buffer_object or OpenGL 1.5",glDeleteBuffersARB,GLsizei -> Ptr GLuint -> IO ())

EXTENSION_ENTRY("GL_ARB_vertex_buffer_object or OpenGL 1.5",glIsBufferARB,GLuint -> IO GLboolean)

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

data BufferTarget =
     ArrayBuffer
   | ElementArrayBuffer
   | PixelPackBuffer
   | PixelUnpackBuffer
   deriving ( Eq, Ord, Show )

marshalBufferTarget :: BufferTarget -> GLenum
marshalBufferTarget x = case x of
   ArrayBuffer -> 0x8892
   ElementArrayBuffer -> 0x8893
   PixelPackBuffer -> 0x88eb
   PixelUnpackBuffer -> 0x88ec

bufferTargetToGetPName :: BufferTarget -> GetPName
bufferTargetToGetPName x = case x of
   ArrayBuffer -> GetArrayBufferBinding
   ElementArrayBuffer -> GetElementArrayBufferBinding
   PixelPackBuffer -> GetPixelPackBufferBinding
   PixelUnpackBuffer -> GetPixelUnpackBufferBinding

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

data BufferUsage =
     StreamDraw
   | StreamRead
   | StreamCopy
   | StaticDraw
   | StaticRead
   | StaticCopy
   | DynamicDraw
   | DynamicRead
   | DynamicCopy
   deriving ( Eq, Ord, Show )

marshalBufferUsage :: BufferUsage -> GLenum
marshalBufferUsage x = case x of
   StreamDraw -> 0x88e0
   StreamRead -> 0x88e1
   StreamCopy -> 0x88e2
   StaticDraw -> 0x88e4
   StaticRead -> 0x88e5
   StaticCopy -> 0x88e6
   DynamicDraw -> 0x88e8
   DynamicRead -> 0x88e9
   DynamicCopy -> 0x88ea

unmarshalBufferUsage :: GLenum -> BufferUsage
unmarshalBufferUsage x
   | x == 0x88e0 = StreamDraw
   | x == 0x88e1 = StreamRead
   | x == 0x88e2 = StreamCopy
   | x == 0x88e4 = StaticDraw
   | x == 0x88e5 = StaticRead
   | x == 0x88e6 = StaticCopy
   | x == 0x88e8 = DynamicDraw
   | x == 0x88e9 = DynamicRead
   | x == 0x88ea = DynamicCopy
   | otherwise = error ("unmarshalBufferUsage: illegal value " ++ show x)

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

data BufferAccess =
     ReadOnly
   | WriteOnly
   | ReadWrite
   deriving ( Eq, Ord, Show )

marshalBufferAccess :: BufferAccess -> GLenum
marshalBufferAccess x = case x of
   ReadOnly -> 0x88b8
   WriteOnly -> 0x88b9
   ReadWrite -> 0x88ba

unmarshalBufferAccess :: GLenum -> BufferAccess
unmarshalBufferAccess x
   | x == 0x88b8 = ReadOnly
   | x == 0x88b9 = WriteOnly
   | x == 0x88ba = ReadWrite
   | otherwise = error ("unmarshalBufferAccess: illegal value " ++ show x)

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

bindBuffer :: BufferTarget -> StateVar (Maybe BufferObject)
bindBuffer t = makeStateVar (getBindBuffer t) (setBindBuffer t)

getBindBuffer :: BufferTarget -> IO (Maybe BufferObject)
getBindBuffer = bufferQuery bufferTargetToGetPName

bufferQuery :: (a -> GetPName) -> a -> IO (Maybe BufferObject)
bufferQuery func t = do
   buf <- getInteger1 (BufferObject . fromIntegral) (func t)
   return $ if buf == noBufferObject then Nothing else Just buf

noBufferObject :: BufferObject
noBufferObject = BufferObject 0

setBindBuffer :: BufferTarget -> Maybe BufferObject -> IO ()
setBindBuffer t =
   glBindBufferARB (marshalBufferTarget t) . bufferID . maybe noBufferObject id

EXTENSION_ENTRY("GL_ARB_vertex_buffer_object or OpenGL 1.5",glBindBufferARB,GLenum -> GLuint -> IO ())

clientArrayTypeToGetPName :: ClientArrayType -> GetPName
clientArrayTypeToGetPName x = case x of
   VertexArray -> GetVertexArrayBufferBinding
   NormalArray -> GetNormalArrayBufferBinding
   ColorArray -> GetColorArrayBufferBinding
   IndexArray -> GetIndexArrayBufferBinding
   TextureCoordArray -> GetTextureCoordArrayBufferBinding
   EdgeFlagArray -> GetEdgeFlagArrayBufferBinding
   FogCoordArray -> GetFogCoordArrayBufferBinding
   SecondaryColorArray -> GetSecondaryColorArrayBufferBinding
   MatrixIndexArray -> error "clientArrayTypeToGetPName: impossible"

arrayBufferBinding :: ClientArrayType -> GettableStateVar (Maybe BufferObject)
arrayBufferBinding t =
   makeGettableStateVar $ case t of
      MatrixIndexArray -> do recordInvalidEnum ; return Nothing
      _ -> bufferQuery clientArrayTypeToGetPName t

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

bufferData :: BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage)
bufferData t = makeStateVar (getBufferData t) (setBufferData t)

getBufferData :: BufferTarget -> IO (GLsizeiptr, Ptr a, BufferUsage)
getBufferData t = do
   s <- getBufferParameter t fromIntegral GetBufferSize
   p <- getBufferPointer t
   u <- getBufferParameter t unmarshalBufferUsage GetBufferUsage
   return (s, p, u)

setBufferData :: BufferTarget -> (GLsizeiptr, Ptr a, BufferUsage) -> IO ()
setBufferData t (s, p, u) =
   glBufferDataARB (marshalBufferTarget t) s p (marshalBufferUsage u)

EXTENSION_ENTRY("GL_ARB_vertex_buffer_object or OpenGL 1.5",glBufferDataARB,GLenum -> GLsizeiptr -> Ptr a -> GLenum -> IO ())

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

data TransferDirection =
     ReadFromBuffer
   | WriteToBuffer
   deriving ( Eq, Ord, Show )

bufferSubData ::
   BufferTarget -> TransferDirection -> GLintptr -> GLsizeiptr -> Ptr a -> GL ()
bufferSubData t WriteToBuffer = glBufferSubDataARB (marshalBufferTarget t)
bufferSubData t ReadFromBuffer = glGetBufferSubDataARB (marshalBufferTarget t)

EXTENSION_ENTRY("GL_ARB_vertex_buffer_object or OpenGL 1.5",glBufferSubDataARB,GLenum -> GLintptr -> GLsizeiptr -> Ptr a -> GL ())

EXTENSION_ENTRY("GL_ARB_vertex_buffer_object or OpenGL 1.5",glGetBufferSubDataARB,GLenum -> GLintptr -> GLsizeiptr -> Ptr a -> GL ())

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

data GetBufferPName =
     GetBufferSize
   | GetBufferUsage
   | GetBufferAccess
   | GetBufferMapped

marshalGetBufferPName :: GetBufferPName -> GLenum
marshalGetBufferPName x = case x of
   GetBufferSize -> 0x8764
   GetBufferUsage -> 0x8765
   GetBufferAccess -> 0x88bb
   GetBufferMapped -> 0x88bc

getBufferParameter :: BufferTarget -> (GLenum -> a) -> GetBufferPName -> IO a
getBufferParameter t f p = alloca $ \buf -> do
   glGetBufferParameterivARB (marshalBufferTarget t)
                             (marshalGetBufferPName p) buf
   peek1 (f . fromIntegral) buf

EXTENSION_ENTRY("GL_ARB_vertex_buffer_object or OpenGL 1.5",glGetBufferParameterivARB,GLenum -> GLenum -> Ptr GLint -> IO ())

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

getBufferPointer :: BufferTarget -> IO (Ptr a)
getBufferPointer t = alloca $ \buf -> do
   -- only one pname: GL_BUFFER_MAP_POINTER
   glGetBufferPointervARB (marshalBufferTarget t) 0x88bd buf
   peek buf

EXTENSION_ENTRY("GL_ARB_vertex_buffer_object or OpenGL 1.5",glGetBufferPointervARB,GLenum -> GLenum -> Ptr (Ptr a) -> IO ())

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

data MappingFailure =
     MappingFailed
   | UnmappingFailed
   deriving ( Eq, Ord, Show )

withMappedBuffer :: BufferTarget -> BufferAccess -> (Ptr a -> GL b) -> (MappingFailure -> GL b) -> GL b
withMappedBuffer t a action err = do
   buf <- mapBuffer t a
   if buf == nullPtr
      then err MappingFailed
      else do (ret, ok) <- liftIO $ finallyRet 
									(runGL $ action buf) 
									(runGL $ unmapBuffer t)
              if ok
                 then return ret
                 else err UnmappingFailed

mapBuffer :: BufferTarget -> BufferAccess -> GL (Ptr a)
mapBuffer t = glMapBufferARB (marshalBufferTarget t) . marshalBufferAccess

EXTENSION_ENTRY("GL_ARB_vertex_buffer_object or OpenGL 1.5",glMapBufferARB,GLenum -> GLenum -> GL (Ptr a))

unmapBuffer :: BufferTarget -> GL Bool
unmapBuffer = fmap unmarshalGLboolean . glUnmapBufferARB . marshalBufferTarget

EXTENSION_ENTRY("GL_ARB_vertex_buffer_object or OpenGL 1.5",glUnmapBufferARB,GLenum -> GL GLboolean)

bufferAccess :: BufferTarget -> GettableStateVar BufferAccess
bufferAccess t = makeGettableStateVar $
   getBufferParameter t unmarshalBufferAccess GetBufferAccess

bufferMapped :: BufferTarget -> GettableStateVar Bool
bufferMapped t = makeGettableStateVar $
   getBufferParameter t unmarshalGLboolean GetBufferMapped