diff options
author | Joe Crayne <joe@jerkface.net> | 2019-05-30 00:09:21 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-05-30 00:09:21 -0400 |
commit | 315d96fb6f76985ec9269a434039f3afca983d5a (patch) | |
tree | 8c681a071207f3d7cc8c08a9464eccf9c95a04f1 /GPURing.hs | |
parent | 8e735080a3f45a90f9952f1ff883260b1230fdf1 (diff) |
Factored gpu-backend out of RingBuffer, wrote vector-backend.
Diffstat (limited to 'GPURing.hs')
-rw-r--r-- | GPURing.hs | 46 |
1 files changed, 46 insertions, 0 deletions
diff --git a/GPURing.hs b/GPURing.hs new file mode 100644 index 0000000..d5f46af --- /dev/null +++ b/GPURing.hs | |||
@@ -0,0 +1,46 @@ | |||
1 | module GPURing where | ||
2 | |||
3 | import Control.Monad.Writer | ||
4 | import Data.Data | ||
5 | import Data.Dependent.Sum | ||
6 | import Data.Function | ||
7 | import Data.Typeable | ||
8 | |||
9 | import AttributeData | ||
10 | import RingBuffer | ||
11 | import MaskableStream | ||
12 | |||
13 | import LambdaCube.GL as LC hiding (updateBuffer) | ||
14 | import LambdaCube.GL.Data hiding (updateBuffer) -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer) | ||
15 | import LambdaCube.GL.Mesh as LC | ||
16 | import LambdaCube.GL.Type | ||
17 | import LambdaCube.IR as LC | ||
18 | import LambdaCube.GL.Util | ||
19 | import LambdaCube.GL.Input.Type | ||
20 | import LambdaCube.GL.Input hiding (createObjectCommands) | ||
21 | |||
22 | |||
23 | -- | Typical usage: | ||
24 | -- | ||
25 | -- > ringBuffer <- newRing capacity (VectorRing.new capacity) | ||
26 | type Update keys = (keys -> Writer [DSum AttributeKey GLUniformValue] ()) | ||
27 | |||
28 | new :: Data keys => GLStorage -> (String -> String) -> Int -> IO (TargetBuffer (Update keys)) | ||
29 | new storage toAttr sz = fix $ \retProxy -> do | ||
30 | let paramProxy = paramProxy' retProxy | ||
31 | where paramProxy' :: io (targetbuffer (keys -> writer)) -> Proxy keys | ||
32 | paramProxy' _ = Proxy | ||
33 | let ps = fieldParameters paramProxy toAttr | ||
34 | putStrLn $ "Ring params: " ++ show ps | ||
35 | gd0 <- uploadDynamicBuffer sz ps | ||
36 | let gd = gd0 { dPrimitive = LineStrip } | ||
37 | Just keys <- return $ lookupAttrKeys (lookupAttributeKey gd . toAttr) | ||
38 | obj <- addToObjectArray storage "Points" [] gd | ||
39 | -- readIORef (objCommands obj) >>= mapM_ print | ||
40 | return TargetBuffer | ||
41 | { syncBuffer = \mask -> do updateCommands storage obj mask | ||
42 | return () | ||
43 | , updateBuffer = \i u -> do updateAttributes i $ u keys | ||
44 | return () | ||
45 | } | ||
46 | |||