TextureBuffer support.

5 files changed, 65 insertions, 6 deletions

diff --git a/src/LambdaCube/GL.hs b/src/LambdaCube/GL.hs
index 47c97d8..8d795a6 100644
--- a/src/LambdaCube/GL.hs
+++ b/src/LambdaCube/GL.hs
@@ -17,6 +17,7 @@ module LambdaCube.GL (
     SetterFun,
     TextureData,
     TextureCubeData,
+    TextureBufferData,
     InputSetter(..),
     fromStreamType,
     sizeOfArrayType,
@@ -31,6 +32,7 @@ module LambdaCube.GL (
     uploadTexture2DToGPU',
     disposeTexture,
     disposeTextureCube,
+    disposeTextureBuffer,
 
     -- GL: Renderer, Storage, Object
     GLUniformName,
diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
index 50d0d3f..8c533f2 100644
--- a/src/LambdaCube/GL/Backend.hs
+++ b/src/LambdaCube/GL/Backend.hs
@@ -775,7 +775,7 @@ renderSlot glDrawCallCounterRef glVertexBufferRef glIndexBufferRef cmds = forM_
         GLSetUniform idx (GLTypedUniform ty ref)        -> setUniform idx ty (readIORef ref)
         GLSetUniform idx (GLUniform ref)                -> return () -- putStrLn $ "TODO: setUniform FTexture2D"
         GLBindTexture txTarget tuRef (GLUniform ref)  -> do
-                                                            txObj <- coerce <$> readIORef ref
+                                                            txObj <- objectName <$> readIORef ref
                                                             do
                                                                 texUnit <- readIORef tuRef
                                                                 glActiveTexture $ GL_TEXTURE0 + fromIntegral texUnit
diff --git a/src/LambdaCube/GL/Data.hs b/src/LambdaCube/GL/Data.hs
index 952e14a..4e6dcae 100644
--- a/src/LambdaCube/GL/Data.hs
+++ b/src/LambdaCube/GL/Data.hs
@@ -66,6 +66,12 @@ disposeTexture (Texture2DName to) = withArray [to] $ glDeleteTextures 1
 disposeTextureCube :: TextureCubeData -> IO ()
 disposeTextureCube (TextureCubeName to) = withArray [to] $ glDeleteTextures 1
 
+disposeTextureBuffer :: TextureBufferData -> IO ()
+disposeTextureBuffer TextureBufferData{ textureBufferName = to, textureBufferObject = bo } = do
+    withArray [to] $ glDeleteTextures 1
+    withArray [bo] $ glDeleteBuffers 1
+
+
 -- FIXME: Temporary implemenation
 uploadTexture2DToGPU :: DynamicImage -> IO TextureData
 uploadTexture2DToGPU = uploadTexture2DToGPU' True False True False
@@ -182,3 +188,41 @@ uploadCubeMapToGPU' isFiltered isSRGB isMip isClamped (bitmap':bitmaps') = do
     -- A GL_INVALID_OPERATION error will be generated if target is GL_TEXTURE_CUBE_MAP,
     -- and not all cube-map faces are initialized and consistent.
     return $ TextureCubeName to
+
+uploadTextureBufferToGPU :: Int -- ^ count of floats in buffer to allocate
+                            -> IO TextureBufferData
+uploadTextureBufferToGPU size = do
+    bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo
+    glBindBuffer GL_TEXTURE_BUFFER bo
+    glBufferData GL_TEXTURE_BUFFER (4 * fromIntegral size) nullPtr GL_DYNAMIC_DRAW
+    to <- alloca $! \pto -> glGenTextures 1 pto >> peek pto
+    glBindTexture GL_TEXTURE_BUFFER to
+    glTexBuffer GL_TEXTURE_BUFFER GL_R32F bo -- GL_R32F Means 32-bit floats.
+    glBindBuffer GL_TEXTURE_BUFFER 0
+    return TextureBufferData { textureBufferName   = to
+                             , textureBufferObject = bo
+                             }
+
+updateTextureBuffer :: TextureBufferData
+                                   -> Int       -- ^ index
+                                   -> Int       -- ^ count
+                                   -> Ptr Float -- ^ source floats to copy
+                                   -> IO ()
+updateTextureBuffer t off sz ptr = do
+    glBindBuffer GL_TEXTURE_BUFFER $ textureBufferObject t
+    glBufferSubData GL_TEXTURE_BUFFER (4*fromIntegral off) (4*fromIntegral sz) ptr
+    glBindBuffer GL_TEXTURE_BUFFER 0
+
+
+readTextureBuffer :: TextureBufferData
+                                -> Int -- ^ index
+                                -> Int -- ^ count
+                                -> (Ptr Float -> IO b)
+                                -> IO b
+readTextureBuffer t off sz f = do
+    glBindBuffer GL_TEXTURE_BUFFER $ textureBufferObject t
+    ptr <- glMapBufferRange GL_TEXTURE_BUFFER (4*fromIntegral off) (4*fromIntegral sz) GL_MAP_READ_BIT
+    b <- f ptr
+    glUnmapBuffer GL_TEXTURE_BUFFER
+    glBindBuffer GL_TEXTURE_BUFFER 0
+    return b
diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs
index ce3a365..57f7df0 100644
--- a/src/LambdaCube/GL/Type.hs
+++ b/src/LambdaCube/GL/Type.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE ExistentialQuantification, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts  #-}
 module LambdaCube.GL.Type where
 
 import Data.Coerce
@@ -76,9 +77,14 @@ data GLUniform = forall c. Typeable c => GLTypedUniform (TypeTag c) (IORef (GLUn
 
 data GLUniformValue c = forall a. GLData a c => GLUniformValue a
 
-class (Coercible t Word32, Typeable t) => IsGLObject t where
+class Typeable t => IsGLObject t where
     objectType :: p t -> InputType
 
+    objectName :: t -> Word32
+
+    default objectName :: Coercible t Word32 => t -> Word32
+    objectName = coerce
+
 instance Show GLUniform where
     showsPrec d (GLTypedUniform t _) = paren '('
                                      . mappend "GLUniform "
@@ -407,6 +413,11 @@ instance IsGLObject TextureData where objectType _ = FTexture2D
 newtype TextureCubeData = TextureCubeName GLuint
 instance IsGLObject TextureCubeData where objectType _ = FTextureCube
 
+data TextureBufferData = TextureBufferData { textureBufferName   :: GLuint
+                                           , textureBufferObject :: GLuint }
+instance IsGLObject TextureBufferData where
+    objectType _ = FTextureBuffer
+    objectName = textureBufferName
 
 data Primitive
     = TriangleStrip
diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs
index 1320f7d..fe027a9 100644
--- a/src/LambdaCube/GL/Util.hs
+++ b/src/LambdaCube/GL/Util.hs
@@ -143,6 +143,7 @@ instance Uniformable (V4 V4F) where uniformContexts _ = contexts $ supports Type
 
 instance Uniformable TextureData where uniformContexts _ = DMap.empty
 instance Uniformable TextureCubeData where uniformContexts _ = DMap.empty
+instance Uniformable TextureBufferData where uniformContexts _ = DMap.empty
 
 mkU :: GLData a c => TypeTag c -> a -> IO GLUniform
 mkU ty a = GLTypedUniform ty <$> newIORef (GLUniformValue a)
@@ -178,9 +179,10 @@ initializeUniform t = case witnessType t of
         TypeM44F -> mkU ty (V4 z4 z4 z4 z4)
 
     Nothing -> case t of
-        FTexture2D   -> GLUniform <$> newIORef (Texture2DName 0)
-        FTextureCube -> GLUniform <$> newIORef (TextureCubeName 0)
-        _            -> fail $ "initializeUniform: " ++ show t
+        FTexture2D     -> GLUniform <$> newIORef (Texture2DName 0)
+        FTextureCube   -> GLUniform <$> newIORef (TextureCubeName 0)
+        FTextureBuffer -> GLUniform <$> newIORef (TextureBufferData 0 0)
+        _              -> fail $ "initializeUniform: " ++ show t
 
 
 data TypeMismatch c a = TypeMismatch