Factor TEXTURE_BUFFER-based ring buffer into module.

1 files changed, 61 insertions, 0 deletions

diff --git a/TextureBufferRing.hs b/TextureBufferRing.hs
new file mode 100644
index 0000000..2edf86f
--- /dev/null
+++ b/TextureBufferRing.hs
@@ -0,0 +1,61 @@
+module TextureBufferRing where
+
+import Control.Monad
+import Data.Int
+import Data.IORef
+import qualified Data.Map.Strict as Map
+import qualified Data.Vector     as V
+import Foreign.Marshal.Array
+import Foreign.Storable
+
+import LambdaCube.GL      as LC
+import LambdaCube.GL.Data (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
+import LambdaCube.GL.Mesh as LC
+import LambdaCube.IR      as LC
+
+data Ring = Ring
+    { ringMax     :: Int
+    , ringTexture :: TextureBufferData
+    , ringStart   :: IO Int
+    , ringSize    :: IO Int
+    , pushBack    :: Float -> Float -> Float -> IO ()
+    , popFront    :: IO ()
+    }
+
+newRing :: GLStorage -> Int -> IO Ring
+newRing storage cnt = do
+    let ringCapacity = cnt * 3
+    tbo <- uploadTextureBufferToGPU ringCapacity
+    p <- uploadMeshToGPU Mesh
+        { mAttributes = Map.singleton "position" $ A_Float $ V.fromList
+            $ replicate ringCapacity 0.0
+        , mPrimitive = P_Points
+        }
+    obj <- addMeshToObjectArray storage "Points" [] p
+    LC.updateUniforms storage $ do
+        "PointBuffer" @= return tbo
+    rstart <- newIORef 0
+    rsize <- newIORef 0
+    return Ring
+        { ringMax     = cnt * 3
+        , ringTexture = tbo
+        , ringStart   = readIORef rstart
+        , ringSize    = readIORef rsize
+        , pushBack    = \x y z -> do
+                            start <- readIORef rstart
+                            allocaArray 3 $ \ptr -> do
+                                pokeElemOff ptr 0 x
+                                pokeElemOff ptr 1 y
+                                pokeElemOff ptr 2 z
+                                updateTextureBuffer tbo start 3 ptr
+                            writeIORef rstart (mod (start + 3) ringCapacity)
+                            sz <- readIORef rsize
+                            putStrLn $ "pushBack "++show (sz,start,(x,y,z))
+                            when (sz < ringCapacity) $ do
+                                writeIORef rsize (sz + 3)
+        , popFront    = modifyIORef' rsize $ \s -> if s > 3 then s - 3 else 0
+        }
+
+updateRingUniforms storage ring = LC.updateUniforms storage $ do
+      "PointsStart" @= fmap (fromIntegral :: Int -> Int32) (ringStart ring)
+      "PointsMax" @= return (fromIntegral (ringMax ring) :: Int32)