Type-safe incremental attribute update.

1 files changed, 46 insertions, 3 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