Use Data.Data to specify ring buffer attributes.

3 files changed, 58 insertions, 31 deletions

diff --git a/AttributeData.hs b/AttributeData.hs
index 8e149af..59b9e6d 100644
--- a/AttributeData.hs
+++ b/AttributeData.hs
@@ -104,8 +104,12 @@ reflectPrim r = case () of
 
 
 reflectVectorType :: Typeable a => proxy a -> Maybe (Some TypeTag)
-reflectVectorType proxy = case R.someTypeRep proxy of
+reflectVectorType proxy = go (R.someTypeRep proxy)
+ where
+   go :: R.SomeTypeRep -> Maybe (Some TypeTag)
+   go rep = case rep of
     R.SomeTypeRep r -> case R.splitApps r of
+
         (v,[c,a])   -> do
             cols <- reflectDim c
             This p <- reflectPrim a
@@ -125,6 +129,7 @@ reflectVectorType proxy = case R.someTypeRep proxy of
                     2 -> This TypeV2F
                     3 -> This TypeV3F
                     4 -> This TypeV4F
+
         (m,[r,c,a]) -> do
             rows <- reflectDim r
             cols <- reflectDim c
@@ -147,6 +152,9 @@ reflectVectorType proxy = case R.someTypeRep proxy of
                         4 -> Just $ This TypeM44F
                         _ -> Nothing
                 _ -> Nothing
+
+        (p,[x])     -> go x
+
         _           -> Nothing
 
 fieldParameters :: forall attrkeys proxy. Data attrkeys => proxy attrkeys -> (String -> String) -> [Parameter]
@@ -156,7 +164,7 @@ fieldParameters proxy toAttrName = do
         AlgRep (c:_) -> do
             let fields = constrFields c
                 mkb :: (MonadPlus m, Data k) => p k -> String -> m InputType
-                mkb pxy n = case reflectVectorType proxy of
+                mkb pxy n = case reflectVectorType pxy of
                     Just (This tt) -> return $ unwitnessType tt
                     _              -> mzero
                 go :: Data c => StateT ([String],[Parameter]) Maybe c
diff --git a/MeshSketch.hs b/MeshSketch.hs
index d06e905..cca9524 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -1,14 +1,17 @@
-{-# LANGUAGE CPP               #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedLabels  #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE OverloadedLabels   #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RecordWildCards    #-}
 module MeshSketch where
 
 import Codec.Picture             as Juicy
 import Control.Concurrent
 import Control.Monad
+import Data.Data
 import Data.Word
 import Data.Function ((&))
 import Data.Functor ((<&>))
@@ -44,6 +47,7 @@ import Text.Printf
 
 import CubeMap
 import GLWidget (nullableContext, withCurrentGL)
+import LambdaCube.GL.Input.Type
 import LambdaCube.GL.HMatrix
 import LambdaCubeWidget (loadPipeline,DynamicPipeline(..))
 import Animator
@@ -52,6 +56,7 @@ import InfinitePlane
 import MtlParser (ObjMaterial(..))
 import Matrix
 import PointPrimitiveRing
+import MaskableStream (AttributeKey,(@<-))
 
 
 prettyDebug :: GL.DebugMessage -> String
@@ -75,6 +80,14 @@ setupGLDebugging = do
 
 type Plane = Vector Float
 
+data RingPoint = RingPoint
+    { rpPosition :: AttributeKey (GLVector 3 Float)
+    }
+    deriving Data
+
+ringPointAttr :: String -> String
+ringPointAttr ('r':'p':c:cs) = toLower c : cs
+
 -- State created by uploadState.
 data State = State
     { stAnimator   :: Animator
@@ -84,7 +97,7 @@ data State = State
     , stSkybox     :: IORef Int
     , stSkyTexture :: IORef TextureCubeData
     , stDragFrom   :: IORef (Maybe (Vector Float,Camera))
-    , stRingBuffer :: Ring
+    , stRingBuffer :: Ring RingPoint
     , stPenDown    :: IORef Bool
     , stPlane      :: IORef (Maybe Plane)
     , stDragPlane  :: IORef (Maybe (Vector Float,Plane))
@@ -183,7 +196,7 @@ uploadState obj glarea storage = do
     -- grid plane
     uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" []
 
-    ring <- newRing storage 100
+    ring <- newRing storage 100 ringPointAttr
 
     -- setup FrameClock
     w <- toWidget glarea
@@ -560,7 +573,9 @@ pushRing w st h k = do
     plane <- readIORef (stPlane st)
     d <- worldCoordinates st h k plane
     Just win <- getWidgetWindow w
-    pushBack (stRingBuffer st) (d!0) (d!1) (d!2)
+    pushBack (stRingBuffer st) $ do
+        RingPoint{..} <- return $ rKeys (stRingBuffer st)
+        rpPosition @<- d
     windowInvalidateRect win Nothing False
     return d
 
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 ()