From dc5aecfffbe071e9b8714988b9824c4f445f8dfc Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Sun, 19 May 2019 22:16:55 -0400
Subject: Use Data.Data to specify ring buffer attributes.

---
 PointPrimitiveRing.hs | 44 ++++++++++++++++++++++++--------------------
 1 file changed, 24 insertions(+), 20 deletions(-)

(limited to 'PointPrimitiveRing.hs')

diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs
index f55e08e..47819e3 100644
--- a/PointPrimitiveRing.hs
+++ b/PointPrimitiveRing.hs
@@ -2,7 +2,9 @@
 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
@@ -27,43 +29,48 @@ 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 = Ring
+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.
-    , rPosition     :: AttributeKey (GLVector 3 Float)
+    , rKeys         :: keys
     }
 
-newRing :: GLStorage -> Int -> IO Ring
-newRing storage sz = do
+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
-    gd <- uploadDynamicBuffer sz [Parameter "position" V3F]
-    let Just k = attributeKey gd "position"
+    let ps = fieldParameters paramProxy toAttr
+    putStrLn $ "Ring params: " ++ show ps
+    gd <- uploadDynamicBuffer sz ps
+    Just keys <- return $ lookupAttrKeys (lookupAttributeKey gd . toAttr)
     obj <- addToObjectArray storage "Points" [] gd
     readIORef (objCommands obj) >>= mapM_ print
-        -- [[GLSetUniform 0 GLUniform M44F,GLSetVertexAttribArray 0 5 3 5126 0x0000000000000000,GLDrawArrays 0 0 1],[],[],[]]
-    let bo = streamBuffer $ dStreams gd Map.! "position"
-        r = Ring
-            { rBufferObject = bo
+    let r = Ring
+            { rBufferObject = streamBuffer $ head $ Map.elems (dStreams gd)
             , rStorage      = storage
             , rObject       = obj
             , rSize         = sizeRef
             , rBack         = startRef
             , ringCapacity  = sz
-            , rPosition     = k
+            , rKeys         = keys
             }
     updateRingCommands r
     return r
 
-updateRingCommands :: Ring -> IO ()
+updateRingCommands :: Ring keys -> IO ()
 updateRingCommands r = do
     back <- fromIntegral <$> readIORef (rBack r)
     size  <- fromIntegral <$> readIORef (rSize r)
@@ -77,17 +84,14 @@ updateRingCommands r = do
     readIORef (objCommands $ rObject r) >>= mapM_ print
     return ()
 
-pushBack :: Ring -> Float -> Float -> Float -> IO ()
-pushBack r x y z = do
+pushBack :: Ring 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 $ do
-        rPosition r @<- V3 x y z -- (fromList [x,y,z] :: Vector Float)
+    updateAttributes back attrs
     sz <- readIORef (rSize r)
-    putStrLn $ "pushBack "++show (sz,back,(x,y,z))
-    when (sz < ringCapacity r) $ do
-        writeIORef (rSize r) (sz + 1)
+    when (sz < ringCapacity r) $ writeIORef (rSize r) (sz + 1)
     updateRingCommands r
 
-updateRingUniforms :: GLStorage -> Ring -> IO ()
+updateRingUniforms :: GLStorage -> Ring keys -> IO ()
 updateRingUniforms _ _ = return ()
-- 
cgit v1.2.3