From dc5aecfffbe071e9b8714988b9824c4f445f8dfc Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sun, 19 May 2019 22:16:55 -0400 Subject: Use Data.Data to specify ring buffer attributes. --- AttributeData.hs | 12 ++++++++++-- MeshSketch.hs | 33 ++++++++++++++++++++++++--------- PointPrimitiveRing.hs | 44 ++++++++++++++++++++++++-------------------- 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 () -- cgit v1.2.3