Factor TEXTURE_BUFFER-based ring buffer into module.

2 files changed, 63 insertions, 44 deletions

diff --git a/MeshSketch.hs b/MeshSketch.hs
index 9425890..16c8284 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -48,6 +48,7 @@ import LoadMesh
 import InfinitePlane
 import MtlParser (ObjMaterial(..))
 import Matrix
+import TextureBufferRing
 
 
 prettyDebug :: GL.DebugMessage -> String
@@ -139,48 +140,6 @@ mkFullscreenToggle w = do
         if b then windowFullscreen w
              else windowUnfullscreen w
 
-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
-        }
 
 uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State
 uploadState obj glarea storage = do
@@ -263,8 +222,7 @@ setUniforms gl storage st = do
     LC.updateUniforms storage $ do
       "CameraPosition" @= return (pos :: Vector Float)
       "ViewProjection" @= return (mvp :: Matrix Float)
-      "PointsStart" @= fmap (fromIntegral :: Int -> Int32) (ringStart $ stRingBuffer st)
-      "PointsMax" @= return (fromIntegral (ringMax $ stRingBuffer st) :: Int32)
+    updateRingUniforms storage (stRingBuffer st)
 
 data MeshSketch = MeshSketch
     { mmWidget   :: GLArea
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)