Type-safe incremental attribute update.

2 files changed, 53 insertions, 5 deletions

diff --git a/MaskableStream.hs b/MaskableStream.hs
index 831a6e2..5ef5b28 100644
--- a/MaskableStream.hs
+++ b/MaskableStream.hs
@@ -6,7 +6,9 @@ module MaskableStream where
 
 import Control.Monad
 import Control.Monad.IO.Class
+import Control.Monad.Writer
 import Data.Foldable
+import Data.Function
 import Data.Int
 import Data.IORef
 import Data.Maybe
@@ -22,6 +24,7 @@ import Data.Dependent.Sum
 import Data.Some
 import Data.GADT.Show
 import GHC.TypeLits
+import System.IO
 
 import LambdaCube.GL      as LC
 import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
@@ -195,9 +198,6 @@ 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 -> [Parameter] -> IO GPUData
 uploadDynamicBuffer sz params = do
     bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo
@@ -231,3 +231,46 @@ incrementalUpdateBuffer b byteoffset bytecount ptr = do
     glBindBuffer GL_ARRAY_BUFFER (bufGLObj b)
     glBufferSubData GL_ARRAY_BUFFER byteoffset bytecount ptr
     glBindBuffer GL_ARRAY_BUFFER 0
+
+data AttributeKey c = AttributeKey (TypeTag c) Buffer CPtrdiff
+
+attributeKey :: TypeTagable c => GPUData -> String -> Maybe (AttributeKey c)
+attributeKey dta name = do
+    stream <- Map.lookup name (dStreams dta)
+    fix $ \mp -> let typ = typeTag (fromJust mp) in case stream of
+        Stream t b i _ _ -> do
+            let a = bufArrays b ! i
+                -- arrType :: ArrayType
+                -- arrLength :: Int -- number of 32 bit values
+                -- arrOffset :: Int -- byte offset into buffer
+                -- arrSize   :: Int -- byte count
+                off = arrOffset a
+            guard (fromStreamType t == unwitnessType typ)
+            Just $ AttributeKey typ b (fromIntegral off)
+        _ -> Nothing
+
+(@<-) :: GLData a c => AttributeKey c -> a -> Writer [DSum AttributeKey GLUniformValue] ()
+k @<- v = tell [k :=> GLUniformValue v]
+
+updateAttributes :: Int -> Writer [DSum AttributeKey GLUniformValue] a -> IO ()
+updateAttributes i writer = forM_ (execWriter writer) $ \case
+    AttributeKey typ b base :=> GLUniformValue a -> do
+        glBindBuffer GL_ARRAY_BUFFER (bufGLObj b)
+        let abi = glABI typ
+            attribSize = 4 * componentCount abi
+        case marshalUniform abi a of
+
+            Just (MarshalGLVector with) -> with $ \sz ptr -> do
+                let sz' = fromIntegral $ attribSize * (fromIntegral sz)
+                putStrLn $ "vector sz = " ++ show sz
+                glBufferSubData GL_ARRAY_BUFFER (base + fromIntegral i * sz') sz' ptr
+
+            Just (MarshalGLMatrix with) -> with $ \sz isrowcol ptr -> do
+                if isrowcol then
+                    hPutStrLn stderr $ "WARNING: (TODO) row-major matrix attribute update unimplemented."
+                else do
+                    let sz' = fromIntegral $ attribSize * (fromIntegral sz)
+                    glBufferSubData GL_ARRAY_BUFFER (base + fromIntegral i * sz') sz' ptr
+
+            Nothing -> hPutStrLn stderr $ "Warning: dimension mismatch updating " ++ show (unwitnessType typ) ++ " attribute."
+        glBindBuffer GL_ARRAY_BUFFER 0
diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs
index 3f2258b..ee5a126 100644
--- a/PointPrimitiveRing.hs
+++ b/PointPrimitiveRing.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE LambdaCase, RecordWildCards #-}
+{-# LANGUAGE LambdaCase, RecordWildCards, DataKinds #-}
 module PointPrimitiveRing where
 
 import Control.Monad
@@ -35,6 +35,7 @@ data Ring = Ring
     , rSize         :: IORef CPtrdiff -- Current count of Floats in the ring buffer.
     , rStart        :: IORef CPtrdiff -- Float-index where next vector will be added. TODO: rename this.
     , ringCapacity  :: CPtrdiff       -- Maximum number of floats in buffer.
+    , rPosition     :: AttributeKey (GLVector 3 Float)
     }
 
 newRing :: GLStorage -> Int -> IO Ring
@@ -42,6 +43,7 @@ newRing storage sz = do
     startRef <- newIORef 0
     sizeRef <- newIORef 0
     gd <- uploadDynamicBuffer sz [Parameter "position" V3F]
+    let Just k = attributeKey gd "position"
     obj <- addToObjectArray storage "Points" [] gd
     readIORef (objCommands obj) >>= mapM_ print
         -- [[GLSetUniform 0 GLUniform M44F,GLSetVertexAttribArray 0 5 3 5126 0x0000000000000000,GLDrawArrays 0 0 1],[],[],[]]
@@ -53,6 +55,7 @@ newRing storage sz = do
             , rSize         = sizeRef
             , rStart        = startRef
             , ringCapacity  = 3 * fromIntegral sz
+            , rPosition     = k
             }
     updateRingCommands r
     return r
@@ -76,7 +79,9 @@ pushBack r x y z = allocaArray 3 $ \ptr -> do
     pokeElemOff ptr 2 z
     start <- readIORef $ rStart r
     writeIORef (rStart r) (mod (start + 3) (ringCapacity r))
-    incrementalUpdateBuffer (rBufferObject r) (4*start) (4*3) ptr
+    -- incrementalUpdateBuffer (rBufferObject r) (4*start) (4*3) ptr
+    updateAttributes (fromIntegral (start `div` 3)) $ do
+        rPosition r @<- V3 x y z -- (fromList [x,y,z] :: Vector Float)
     -- glFlush
     -- glFinish
     sz <- readIORef (rSize r)