Allow multiple attributes for dynamic buffer.

2 files changed, 34 insertions, 11 deletions

diff --git a/MaskableStream.hs b/MaskableStream.hs
index e6628e6..831a6e2 100644
--- a/MaskableStream.hs
+++ b/MaskableStream.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE LambdaCase, RecordWildCards #-}
+{-# LANGUAGE LambdaCase, RecordWildCards, KindSignatures, GADTs #-}
 
 -- TODO: Formulate this module as a patch against lambdacube-gl.
 
@@ -18,6 +18,10 @@ import Foreign.C.Types (CPtrdiff)
 import Foreign.Marshal
 import Foreign.Ptr
 import Foreign.Storable
+import Data.Dependent.Sum
+import Data.Some
+import Data.GADT.Show
+import GHC.TypeLits
 
 import LambdaCube.GL      as LC
 import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
@@ -186,23 +190,42 @@ updateCommands input obj mask = do
     return obj
 
 
+componentCount :: GLABI c -> Int
+componentCount x@(IsGLVector _) = fromIntegral $ natVal $ vectorLength x
+componentCount x@(IsGLMatrix _) = let (r,c) = matrixDimensions x
+                                    in fromIntegral (natVal r) * fromIntegral (natVal c)
+
 -- TODO: Add flexibility.
 -- Currently this allocates a buffer consisting of a single named vertex attribute that
 -- must be of type V3F.
-uploadDynamicBuffer :: Int -> String -> IO GPUData
-uploadDynamicBuffer sz attrname = do
+uploadDynamicBuffer :: Int -> [Parameter] -> IO GPUData
+uploadDynamicBuffer sz params = do
     bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo
     glBindBuffer GL_ARRAY_BUFFER bo
-    let bufsize = 3 * fromIntegral sz
-        byteCount = 4 * bufsize
-    glBufferData GL_ARRAY_BUFFER byteCount nullPtr GL_DYNAMIC_DRAW
+    let (mkstreams, mkarrays) = unzip $ mapMaybe attrInfo params
+        attrInfo (Parameter n typ) = do
+            atyp <- toStreamType typ
+            This tt <- witnessType typ
+            let abi = glABI tt
+                cnt = componentCount abi
+                arrtyp = let go :: GLPointerType typ -> ArrayType
+                             go = \case GLPrimUInt  -> ArrWord32
+                                        GLPrimInt   -> ArrInt32
+                                        GLPrimFloat -> ArrFloat
+                         in case abi of { IsGLVector p -> go p ; IsGLMatrix p -> go p }
+            return ( \b i -> (n, Stream atyp b i 0 sz)
+                   , \offset -> ArrayDesc arrtyp (cnt * sz) offset (4 * sz * cnt))
+        streams = zipWith ($ buffer) mkstreams [0..]
+        arrays = foldr mk (const []) mkarrays 0
+            where mk f fin offset = let a = f offset
+                                    in a : fin (offset + arrSize a)
+        buffer = Buffer (V.fromList arrays) bo
+        byteCount = sum $ map arrSize arrays
+    glBufferData GL_ARRAY_BUFFER (fromIntegral byteCount) nullPtr GL_DYNAMIC_DRAW
     glBindBuffer GL_ARRAY_BUFFER 0
-    let buffer = Buffer (V.singleton $ ArrayDesc ArrFloat (fromIntegral bufsize) 0 (fromIntegral byteCount))
-                        bo
-        gd = GPUData PointList (Map.singleton attrname $ Stream Attribute_V3F buffer 0 0 sz) Nothing [buffer]
+    let gd = GPUData PointList (Map.fromList streams) Nothing [buffer]
     return gd
 
-
 incrementalUpdateBuffer :: MonadIO m => Buffer -> GLintptr -> GLsizeiptr -> Ptr a -> m ()
 incrementalUpdateBuffer b byteoffset bytecount ptr = do
     glBindBuffer GL_ARRAY_BUFFER (bufGLObj b)
diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs
index 10040d5..3f2258b 100644
--- a/PointPrimitiveRing.hs
+++ b/PointPrimitiveRing.hs
@@ -41,7 +41,7 @@ newRing :: GLStorage -> Int -> IO Ring
 newRing storage sz = do
     startRef <- newIORef 0
     sizeRef <- newIORef 0
-    gd <- uploadDynamicBuffer sz "position"
+    gd <- uploadDynamicBuffer sz [Parameter "position" V3F]
     obj <- addToObjectArray storage "Points" [] gd
     readIORef (objCommands obj) >>= mapM_ print
         -- [[GLSetUniform 0 GLUniform M44F,GLSetVertexAttribArray 0 5 3 5126 0x0000000000000000,GLDrawArrays 0 0 1],[],[],[]]