diff options
-rw-r--r-- | MaskableStream.hs | 49 | ||||
-rw-r--r-- | PointPrimitiveRing.hs | 9 |
2 files changed, 53 insertions, 5 deletions
diff --git a/MaskableStream.hs b/MaskableStream.hs index 831a6e2..5ef5b28 100644 --- a/MaskableStream.hs +++ b/MaskableStream.hs | |||
@@ -6,7 +6,9 @@ module MaskableStream where | |||
6 | 6 | ||
7 | import Control.Monad | 7 | import Control.Monad |
8 | import Control.Monad.IO.Class | 8 | import Control.Monad.IO.Class |
9 | import Control.Monad.Writer | ||
9 | import Data.Foldable | 10 | import Data.Foldable |
11 | import Data.Function | ||
10 | import Data.Int | 12 | import Data.Int |
11 | import Data.IORef | 13 | import Data.IORef |
12 | import Data.Maybe | 14 | import Data.Maybe |
@@ -22,6 +24,7 @@ import Data.Dependent.Sum | |||
22 | import Data.Some | 24 | import Data.Some |
23 | import Data.GADT.Show | 25 | import Data.GADT.Show |
24 | import GHC.TypeLits | 26 | import GHC.TypeLits |
27 | import System.IO | ||
25 | 28 | ||
26 | import LambdaCube.GL as LC | 29 | import LambdaCube.GL as LC |
27 | import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer) | 30 | import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer) |
@@ -195,9 +198,6 @@ componentCount x@(IsGLVector _) = fromIntegral $ natVal $ vectorLength x | |||
195 | componentCount x@(IsGLMatrix _) = let (r,c) = matrixDimensions x | 198 | componentCount x@(IsGLMatrix _) = let (r,c) = matrixDimensions x |
196 | in fromIntegral (natVal r) * fromIntegral (natVal c) | 199 | in fromIntegral (natVal r) * fromIntegral (natVal c) |
197 | 200 | ||
198 | -- TODO: Add flexibility. | ||
199 | -- Currently this allocates a buffer consisting of a single named vertex attribute that | ||
200 | -- must be of type V3F. | ||
201 | uploadDynamicBuffer :: Int -> [Parameter] -> IO GPUData | 201 | uploadDynamicBuffer :: Int -> [Parameter] -> IO GPUData |
202 | uploadDynamicBuffer sz params = do | 202 | uploadDynamicBuffer sz params = do |
203 | bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo | 203 | bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo |
@@ -231,3 +231,46 @@ incrementalUpdateBuffer b byteoffset bytecount ptr = do | |||
231 | glBindBuffer GL_ARRAY_BUFFER (bufGLObj b) | 231 | glBindBuffer GL_ARRAY_BUFFER (bufGLObj b) |
232 | glBufferSubData GL_ARRAY_BUFFER byteoffset bytecount ptr | 232 | glBufferSubData GL_ARRAY_BUFFER byteoffset bytecount ptr |
233 | glBindBuffer GL_ARRAY_BUFFER 0 | 233 | glBindBuffer GL_ARRAY_BUFFER 0 |
234 | |||
235 | data AttributeKey c = AttributeKey (TypeTag c) Buffer CPtrdiff | ||
236 | |||
237 | attributeKey :: TypeTagable c => GPUData -> String -> Maybe (AttributeKey c) | ||
238 | attributeKey dta name = do | ||
239 | stream <- Map.lookup name (dStreams dta) | ||
240 | fix $ \mp -> let typ = typeTag (fromJust mp) in case stream of | ||
241 | Stream t b i _ _ -> do | ||
242 | let a = bufArrays b ! i | ||
243 | -- arrType :: ArrayType | ||
244 | -- arrLength :: Int -- number of 32 bit values | ||
245 | -- arrOffset :: Int -- byte offset into buffer | ||
246 | -- arrSize :: Int -- byte count | ||
247 | off = arrOffset a | ||
248 | guard (fromStreamType t == unwitnessType typ) | ||
249 | Just $ AttributeKey typ b (fromIntegral off) | ||
250 | _ -> Nothing | ||
251 | |||
252 | (@<-) :: GLData a c => AttributeKey c -> a -> Writer [DSum AttributeKey GLUniformValue] () | ||
253 | k @<- v = tell [k :=> GLUniformValue v] | ||
254 | |||
255 | updateAttributes :: Int -> Writer [DSum AttributeKey GLUniformValue] a -> IO () | ||
256 | updateAttributes i writer = forM_ (execWriter writer) $ \case | ||
257 | AttributeKey typ b base :=> GLUniformValue a -> do | ||
258 | glBindBuffer GL_ARRAY_BUFFER (bufGLObj b) | ||
259 | let abi = glABI typ | ||
260 | attribSize = 4 * componentCount abi | ||
261 | case marshalUniform abi a of | ||
262 | |||
263 | Just (MarshalGLVector with) -> with $ \sz ptr -> do | ||
264 | let sz' = fromIntegral $ attribSize * (fromIntegral sz) | ||
265 | putStrLn $ "vector sz = " ++ show sz | ||
266 | glBufferSubData GL_ARRAY_BUFFER (base + fromIntegral i * sz') sz' ptr | ||
267 | |||
268 | Just (MarshalGLMatrix with) -> with $ \sz isrowcol ptr -> do | ||
269 | if isrowcol then | ||
270 | hPutStrLn stderr $ "WARNING: (TODO) row-major matrix attribute update unimplemented." | ||
271 | else do | ||
272 | let sz' = fromIntegral $ attribSize * (fromIntegral sz) | ||
273 | glBufferSubData GL_ARRAY_BUFFER (base + fromIntegral i * sz') sz' ptr | ||
274 | |||
275 | Nothing -> hPutStrLn stderr $ "Warning: dimension mismatch updating " ++ show (unwitnessType typ) ++ " attribute." | ||
276 | glBindBuffer GL_ARRAY_BUFFER 0 | ||
diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs index 3f2258b..ee5a126 100644 --- a/PointPrimitiveRing.hs +++ b/PointPrimitiveRing.hs | |||
@@ -1,4 +1,4 @@ | |||
1 | {-# LANGUAGE LambdaCase, RecordWildCards #-} | 1 | {-# LANGUAGE LambdaCase, RecordWildCards, DataKinds #-} |
2 | module PointPrimitiveRing where | 2 | module PointPrimitiveRing where |
3 | 3 | ||
4 | import Control.Monad | 4 | import Control.Monad |
@@ -35,6 +35,7 @@ data Ring = Ring | |||
35 | , rSize :: IORef CPtrdiff -- Current count of Floats in the ring buffer. | 35 | , rSize :: IORef CPtrdiff -- Current count of Floats in the ring buffer. |
36 | , rStart :: IORef CPtrdiff -- Float-index where next vector will be added. TODO: rename this. | 36 | , rStart :: IORef CPtrdiff -- Float-index where next vector will be added. TODO: rename this. |
37 | , ringCapacity :: CPtrdiff -- Maximum number of floats in buffer. | 37 | , ringCapacity :: CPtrdiff -- Maximum number of floats in buffer. |
38 | , rPosition :: AttributeKey (GLVector 3 Float) | ||
38 | } | 39 | } |
39 | 40 | ||
40 | newRing :: GLStorage -> Int -> IO Ring | 41 | newRing :: GLStorage -> Int -> IO Ring |
@@ -42,6 +43,7 @@ newRing storage sz = do | |||
42 | startRef <- newIORef 0 | 43 | startRef <- newIORef 0 |
43 | sizeRef <- newIORef 0 | 44 | sizeRef <- newIORef 0 |
44 | gd <- uploadDynamicBuffer sz [Parameter "position" V3F] | 45 | gd <- uploadDynamicBuffer sz [Parameter "position" V3F] |
46 | let Just k = attributeKey gd "position" | ||
45 | obj <- addToObjectArray storage "Points" [] gd | 47 | obj <- addToObjectArray storage "Points" [] gd |
46 | readIORef (objCommands obj) >>= mapM_ print | 48 | readIORef (objCommands obj) >>= mapM_ print |
47 | -- [[GLSetUniform 0 GLUniform M44F,GLSetVertexAttribArray 0 5 3 5126 0x0000000000000000,GLDrawArrays 0 0 1],[],[],[]] | 49 | -- [[GLSetUniform 0 GLUniform M44F,GLSetVertexAttribArray 0 5 3 5126 0x0000000000000000,GLDrawArrays 0 0 1],[],[],[]] |
@@ -53,6 +55,7 @@ newRing storage sz = do | |||
53 | , rSize = sizeRef | 55 | , rSize = sizeRef |
54 | , rStart = startRef | 56 | , rStart = startRef |
55 | , ringCapacity = 3 * fromIntegral sz | 57 | , ringCapacity = 3 * fromIntegral sz |
58 | , rPosition = k | ||
56 | } | 59 | } |
57 | updateRingCommands r | 60 | updateRingCommands r |
58 | return r | 61 | return r |
@@ -76,7 +79,9 @@ pushBack r x y z = allocaArray 3 $ \ptr -> do | |||
76 | pokeElemOff ptr 2 z | 79 | pokeElemOff ptr 2 z |
77 | start <- readIORef $ rStart r | 80 | start <- readIORef $ rStart r |
78 | writeIORef (rStart r) (mod (start + 3) (ringCapacity r)) | 81 | writeIORef (rStart r) (mod (start + 3) (ringCapacity r)) |
79 | incrementalUpdateBuffer (rBufferObject r) (4*start) (4*3) ptr | 82 | -- incrementalUpdateBuffer (rBufferObject r) (4*start) (4*3) ptr |
83 | updateAttributes (fromIntegral (start `div` 3)) $ do | ||
84 | rPosition r @<- V3 x y z -- (fromList [x,y,z] :: Vector Float) | ||
80 | -- glFlush | 85 | -- glFlush |
81 | -- glFinish | 86 | -- glFinish |
82 | sz <- readIORef (rSize r) | 87 | sz <- readIORef (rSize r) |