Factored gpu-backend out of RingBuffer, wrote vector-backend.

5 files changed, 138 insertions, 113 deletions

diff --git a/GPURing.hs b/GPURing.hs
new file mode 100644
index 0000000..d5f46af
--- /dev/null
+++ b/GPURing.hs
@@ -0,0 +1,46 @@
+module GPURing where
+
+import Control.Monad.Writer
+import Data.Data
+import Data.Dependent.Sum
+import Data.Function
+import Data.Typeable
+
+import AttributeData
+import RingBuffer
+import MaskableStream
+
+import LambdaCube.GL      as LC hiding (updateBuffer)
+import LambdaCube.GL.Data hiding (updateBuffer) -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
+import LambdaCube.GL.Mesh as LC
+import LambdaCube.GL.Type
+import LambdaCube.IR      as LC
+import LambdaCube.GL.Util
+import LambdaCube.GL.Input.Type
+import LambdaCube.GL.Input hiding (createObjectCommands)
+
+
+-- | Typical usage:
+--
+-- > ringBuffer <- newRing capacity (VectorRing.new capacity)
+type Update keys = (keys -> Writer [DSum AttributeKey GLUniformValue] ())
+
+new :: Data keys => GLStorage -> (String -> String) -> Int -> IO (TargetBuffer (Update keys))
+new storage toAttr sz = fix $ \retProxy -> do
+    let paramProxy = paramProxy' retProxy
+            where paramProxy' :: io (targetbuffer (keys -> writer)) -> Proxy keys
+                  paramProxy' _ = Proxy
+    let ps = fieldParameters paramProxy toAttr
+    putStrLn $ "Ring params: " ++ show ps
+    gd0 <- uploadDynamicBuffer sz ps
+    let gd = gd0 { dPrimitive = LineStrip }
+    Just keys <- return $ lookupAttrKeys (lookupAttributeKey gd . toAttr)
+    obj <- addToObjectArray storage "Points" [] gd
+    -- readIORef (objCommands obj) >>= mapM_ print
+    return TargetBuffer
+        { syncBuffer   = \mask -> do updateCommands storage obj mask
+                                     return ()
+        , updateBuffer = \i u -> do updateAttributes i $ u keys
+                                    return ()
+        }
+
diff --git a/MeshSketch.hs b/MeshSketch.hs
index d598bbd..8660119 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -59,7 +59,8 @@ import LoadMesh
 import InfinitePlane
 import MtlParser (ObjMaterial(..))
 import Matrix
-import PointPrimitiveRing
+import GPURing as GPU
+import RingBuffer
 import MaskableStream (AttributeKey,(@<-))
 import SmallRing
 
@@ -103,7 +104,7 @@ data State = State
     , stSkybox     :: IORef Int
     , stSkyTexture :: IORef TextureCubeData
     , stDragFrom   :: IORef (Maybe (Vector Float,Camera))
-    , stRingBuffer :: Ring RingPoint
+    , stRingBuffer :: RingBuffer (GPU.Update RingPoint)
     , stPenDown    :: IORef Bool
     , stPlane      :: IORef (Maybe Plane)
     , stDragPlane  :: IORef (Maybe (Vector Float,Plane))
@@ -204,7 +205,7 @@ uploadState obj glarea storage = do
     -- grid plane
     uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" []
 
-    ring <- newRing storage 100 ringPointAttr
+    ring <- newRing 100 (GPU.new storage ringPointAttr 100)
 
     -- setup FrameClock
     w <- toWidget glarea
@@ -298,7 +299,7 @@ setUniforms gl storage st = do
       "CameraPosition" @= return (pos :: Vector Float)
       "ViewProjection" @= return (mvp :: Matrix Float)
       "PlaneModel" @= return planeModel
-    updateRingUniforms storage (stRingBuffer st)
+    -- updateRingUniforms storage (stRingBuffer st)
 
 data MeshSketch = MeshSketch
     { mmWidget   :: GLArea
diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs
deleted file mode 100644
index d4fafae..0000000
--- a/PointPrimitiveRing.hs
+++ /dev/null
@@ -1,109 +0,0 @@
-{-# LANGUAGE LambdaCase, RecordWildCards, DataKinds #-}
-module PointPrimitiveRing where
-
-import Control.Monad
-import Control.Monad.Writer
-import Data.Data
-import Data.Dependent.Sum
-import Data.Foldable
-import Data.Function
-import Data.Int
-import Data.IORef
-import Data.Maybe
-import Data.Some
-import Data.Word
-import qualified Data.Map.Strict as Map
-import qualified Data.Vector as V
-         ;import Data.Vector as V ((!),(//))
-import Foreign.C.Types (CPtrdiff)
-import Foreign.Marshal
-import Foreign.Ptr
-import Foreign.Storable
-
-import LambdaCube.GL      as LC
-import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
-import LambdaCube.GL.Mesh as LC
-import LambdaCube.GL.Type
-import LambdaCube.IR      as LC
-import LambdaCube.GL.Util
-import LambdaCube.GL.Input.Type
-import LambdaCube.GL.Input hiding (createObjectCommands)
-
-import AttributeData
-
--- import Graphics.GL.Core33
-
-import MaskableStream
-
-data Ring keys = Ring
-    { rBufferObject :: Buffer
-    , rStorage      :: GLStorage
-    , rObject       :: Object
-    , rSize         :: IORef Int -- Current count of vertices in the ring buffer.
-    , rBack         :: IORef Int -- Where next vertex will be added.
-    , ringCapacity  :: Int       -- Maximum number of vertices in buffer.
-    , rKeys         :: keys
-    }
-
-newRing :: Data keys => GLStorage -> Int -> (String -> String) -> IO (Ring keys)
-newRing storage sz toAttr = fix $ \retProxy -> do
-    let paramProxy = paramProxy' retProxy
-            where paramProxy' :: io (ring keys) -> Proxy keys
-                  paramProxy' _ = Proxy
-    startRef <- newIORef 0
-    sizeRef <- newIORef 0
-    let ps = fieldParameters paramProxy toAttr
-    putStrLn $ "Ring params: " ++ show ps
-    gd0 <- uploadDynamicBuffer sz ps
-    let gd = gd0 { dPrimitive = LineStrip }
-    Just keys <- return $ lookupAttrKeys (lookupAttributeKey gd . toAttr)
-    obj <- addToObjectArray storage "Points" [] gd
-    readIORef (objCommands obj) >>= mapM_ print
-    let r = Ring
-            { rBufferObject = streamBuffer $ head $ Map.elems (dStreams gd)
-            , rStorage      = storage
-            , rObject       = obj
-            , rSize         = sizeRef
-            , rBack         = startRef
-            , ringCapacity  = sz
-            , rKeys         = keys
-            }
-    updateRingCommands r
-    return r
-
-clearRing :: Ring keys -> IO ()
-clearRing r = do
-    writeIORef (rBack r) 0
-    writeIORef (rSize r) 0
-    updateRingCommands r
-
-updateRingCommands :: Ring keys -> IO ()
-updateRingCommands r = do
-    back <- fromIntegral <$> readIORef (rBack r)
-    size  <- fromIntegral <$> readIORef (rSize r)
-    let mask 0   = []
-        mask cnt
-            | cnt==size = [(0,cnt)]
-            | otherwise = case cnt + back - size of
-                front | front > cnt -> [(front - cnt,size)]
-                      | otherwise   -> [(0,back), (front,cnt - front)]
-    updateCommands (rStorage r) (rObject r) mask
-    -- readIORef (objCommands $ rObject r) >>= mapM_ print
-    return ()
-
-pushBack :: Ring keys -> (keys -> Writer [DSum AttributeKey GLUniformValue] a) -> IO ()
-pushBack r attrs = do
-    back <- readIORef $ rBack r
-    writeIORef (rBack r) (mod (back + 1) (ringCapacity r))
-    updateAttributes back $ attrs (rKeys r)
-    sz <- readIORef (rSize r)
-    when (sz < ringCapacity r) $ writeIORef (rSize r) (sz + 1)
-    updateRingCommands r
-
-updateBack :: Ring keys -> (keys -> Writer [DSum AttributeKey GLUniformValue] a) -> IO ()
-updateBack r attrs = do
-    back <- readIORef $ rBack r
-    updateAttributes (mod (back - 1) (ringCapacity r)) $ attrs (rKeys r)
-
-updateRingUniforms :: GLStorage -> Ring keys -> IO ()
-updateRingUniforms _ _ = return ()
diff --git a/RingBuffer.hs b/RingBuffer.hs
new file mode 100644
index 0000000..b2779d7
--- /dev/null
+++ b/RingBuffer.hs
@@ -0,0 +1,70 @@
+module RingBuffer where
+
+import Control.Monad
+import Data.Int
+import Data.IORef
+
+data TargetBuffer u = TargetBuffer
+    { -- | Called whenever the rBack or rSize changes.  The purpose is so that
+      -- some other state, such as an OpenGL vertex buffer object, can remain in
+      -- sync.
+      syncBuffer :: (Int32 -> [(Int32,Int32)]) -> IO ()
+      -- | This updates the data associated with a particular index (usually
+      -- rBack).  The update specification /u/ may be a value or a set of
+      -- key-value pairs or whatever is most convenient way to instruct the
+      -- target representation to update itself.
+    , updateBuffer :: Int -> u -> IO ()
+    }
+
+data RingBuffer u = RingBuffer
+    { rBack        :: IORef Int
+    , rSize        :: IORef Int
+    , ringCapacity :: Int
+    , rBuffer      :: TargetBuffer u
+    }
+
+newRing :: Int -> IO (TargetBuffer u) -> IO (RingBuffer u)
+newRing sz newBuffer = do
+    backRef <- newIORef 0
+    sizeRef <- newIORef 0
+    b <- newBuffer
+    let r = RingBuffer
+            { rBack        = backRef
+            , rSize        = sizeRef
+            , ringCapacity = sz
+            , rBuffer      = b
+            }
+    syncRing r
+    return r
+
+syncRing :: RingBuffer u -> IO ()
+syncRing r = do
+    size <- fromIntegral <$> readIORef (rSize r)
+    back <- fromIntegral <$> readIORef (rBack r)
+    let mask 0   = []
+        mask cnt
+            | cnt==size = [(0,cnt)]
+            | otherwise = case cnt + back - size of
+                front | front > cnt -> [(front - cnt,size)]
+                      | otherwise   -> [(0,back), (front,cnt - front)]
+    syncBuffer (rBuffer r) mask
+
+clearRing :: RingBuffer u -> IO ()
+clearRing r = do
+    writeIORef (rBack r) 0
+    writeIORef (rSize r) 0
+    syncRing r
+
+pushBack :: RingBuffer u -> u -> IO ()
+pushBack r upd = do
+    back <- readIORef $ rBack r
+    writeIORef (rBack r) (mod (back + 1) (ringCapacity r))
+    updateBuffer (rBuffer r) back upd
+    sz <- readIORef (rSize r)
+    when (sz < ringCapacity r) $ writeIORef (rSize r) (sz + 1)
+    syncRing r
+
+updateBack :: RingBuffer u -> u -> IO ()
+updateBack r upd = do
+    back <- readIORef $ rBack r
+    updateBuffer (rBuffer r) back upd
diff --git a/VectorRing.hs b/VectorRing.hs
new file mode 100644
index 0000000..2ddac72
--- /dev/null
+++ b/VectorRing.hs
@@ -0,0 +1,17 @@
+module VectorRing where
+
+import Data.Vector.Unboxed.Mutable
+import RingBuffer
+
+-- | Typical usage:
+--
+-- > ringBuffer <- newRing capacity (VectorRing.new capacity)
+new :: Unbox a => Int -> IO (TargetBuffer a)
+new sz = do
+    v <- unsafeNew sz
+    return () :: IO ()
+    return TargetBuffer
+        { syncBuffer   = \_ -> return ()
+        , updateBuffer = \i u -> write v i u
+        }
+