diff options
Diffstat (limited to 'PointPrimitiveRing.hs')
-rw-r--r-- | PointPrimitiveRing.hs | 44 |
1 files changed, 24 insertions, 20 deletions
diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs index f55e08e..47819e3 100644 --- a/PointPrimitiveRing.hs +++ b/PointPrimitiveRing.hs | |||
@@ -2,7 +2,9 @@ | |||
2 | module PointPrimitiveRing where | 2 | module PointPrimitiveRing where |
3 | 3 | ||
4 | import Control.Monad | 4 | import Control.Monad |
5 | import Control.Monad.Writer | ||
5 | import Data.Data | 6 | import Data.Data |
7 | import Data.Dependent.Sum | ||
6 | import Data.Foldable | 8 | import Data.Foldable |
7 | import Data.Function | 9 | import Data.Function |
8 | import Data.Int | 10 | import Data.Int |
@@ -27,43 +29,48 @@ import LambdaCube.GL.Util | |||
27 | import LambdaCube.GL.Input.Type | 29 | import LambdaCube.GL.Input.Type |
28 | import LambdaCube.GL.Input hiding (createObjectCommands) | 30 | import LambdaCube.GL.Input hiding (createObjectCommands) |
29 | 31 | ||
32 | import AttributeData | ||
33 | |||
30 | -- import Graphics.GL.Core33 | 34 | -- import Graphics.GL.Core33 |
31 | 35 | ||
32 | import MaskableStream | 36 | import MaskableStream |
33 | 37 | ||
34 | data Ring = Ring | 38 | data Ring keys = Ring |
35 | { rBufferObject :: Buffer | 39 | { rBufferObject :: Buffer |
36 | , rStorage :: GLStorage | 40 | , rStorage :: GLStorage |
37 | , rObject :: Object | 41 | , rObject :: Object |
38 | , rSize :: IORef Int -- Current count of vertices in the ring buffer. | 42 | , rSize :: IORef Int -- Current count of vertices in the ring buffer. |
39 | , rBack :: IORef Int -- Where next vertex will be added. | 43 | , rBack :: IORef Int -- Where next vertex will be added. |
40 | , ringCapacity :: Int -- Maximum number of vertices in buffer. | 44 | , ringCapacity :: Int -- Maximum number of vertices in buffer. |
41 | , rPosition :: AttributeKey (GLVector 3 Float) | 45 | , rKeys :: keys |
42 | } | 46 | } |
43 | 47 | ||
44 | newRing :: GLStorage -> Int -> IO Ring | 48 | newRing :: Data keys => GLStorage -> Int -> (String -> String) -> IO (Ring keys) |
45 | newRing storage sz = do | 49 | newRing storage sz toAttr = fix $ \retProxy -> do |
50 | let paramProxy = paramProxy' retProxy | ||
51 | where paramProxy' :: io (ring keys) -> Proxy keys | ||
52 | paramProxy' _ = Proxy | ||
46 | startRef <- newIORef 0 | 53 | startRef <- newIORef 0 |
47 | sizeRef <- newIORef 0 | 54 | sizeRef <- newIORef 0 |
48 | gd <- uploadDynamicBuffer sz [Parameter "position" V3F] | 55 | let ps = fieldParameters paramProxy toAttr |
49 | let Just k = attributeKey gd "position" | 56 | putStrLn $ "Ring params: " ++ show ps |
57 | gd <- uploadDynamicBuffer sz ps | ||
58 | Just keys <- return $ lookupAttrKeys (lookupAttributeKey gd . toAttr) | ||
50 | obj <- addToObjectArray storage "Points" [] gd | 59 | obj <- addToObjectArray storage "Points" [] gd |
51 | readIORef (objCommands obj) >>= mapM_ print | 60 | readIORef (objCommands obj) >>= mapM_ print |
52 | -- [[GLSetUniform 0 GLUniform M44F,GLSetVertexAttribArray 0 5 3 5126 0x0000000000000000,GLDrawArrays 0 0 1],[],[],[]] | 61 | let r = Ring |
53 | let bo = streamBuffer $ dStreams gd Map.! "position" | 62 | { rBufferObject = streamBuffer $ head $ Map.elems (dStreams gd) |
54 | r = Ring | ||
55 | { rBufferObject = bo | ||
56 | , rStorage = storage | 63 | , rStorage = storage |
57 | , rObject = obj | 64 | , rObject = obj |
58 | , rSize = sizeRef | 65 | , rSize = sizeRef |
59 | , rBack = startRef | 66 | , rBack = startRef |
60 | , ringCapacity = sz | 67 | , ringCapacity = sz |
61 | , rPosition = k | 68 | , rKeys = keys |
62 | } | 69 | } |
63 | updateRingCommands r | 70 | updateRingCommands r |
64 | return r | 71 | return r |
65 | 72 | ||
66 | updateRingCommands :: Ring -> IO () | 73 | updateRingCommands :: Ring keys -> IO () |
67 | updateRingCommands r = do | 74 | updateRingCommands r = do |
68 | back <- fromIntegral <$> readIORef (rBack r) | 75 | back <- fromIntegral <$> readIORef (rBack r) |
69 | size <- fromIntegral <$> readIORef (rSize r) | 76 | size <- fromIntegral <$> readIORef (rSize r) |
@@ -77,17 +84,14 @@ updateRingCommands r = do | |||
77 | readIORef (objCommands $ rObject r) >>= mapM_ print | 84 | readIORef (objCommands $ rObject r) >>= mapM_ print |
78 | return () | 85 | return () |
79 | 86 | ||
80 | pushBack :: Ring -> Float -> Float -> Float -> IO () | 87 | pushBack :: Ring keys -> Writer [DSum AttributeKey GLUniformValue] a -> IO () |
81 | pushBack r x y z = do | 88 | pushBack r attrs = do |
82 | back <- readIORef $ rBack r | 89 | back <- readIORef $ rBack r |
83 | writeIORef (rBack r) (mod (back + 1) (ringCapacity r)) | 90 | writeIORef (rBack r) (mod (back + 1) (ringCapacity r)) |
84 | updateAttributes back $ do | 91 | updateAttributes back attrs |
85 | rPosition r @<- V3 x y z -- (fromList [x,y,z] :: Vector Float) | ||
86 | sz <- readIORef (rSize r) | 92 | sz <- readIORef (rSize r) |
87 | putStrLn $ "pushBack "++show (sz,back,(x,y,z)) | 93 | when (sz < ringCapacity r) $ writeIORef (rSize r) (sz + 1) |
88 | when (sz < ringCapacity r) $ do | ||
89 | writeIORef (rSize r) (sz + 1) | ||
90 | updateRingCommands r | 94 | updateRingCommands r |
91 | 95 | ||
92 | updateRingUniforms :: GLStorage -> Ring -> IO () | 96 | updateRingUniforms :: GLStorage -> Ring keys -> IO () |
93 | updateRingUniforms _ _ = return () | 97 | updateRingUniforms _ _ = return () |