summaryrefslogtreecommitdiff
path: root/PointPrimitiveRing.hs
diff options
context:
space:
mode:
Diffstat (limited to 'PointPrimitiveRing.hs')
-rw-r--r--PointPrimitiveRing.hs109
1 files changed, 0 insertions, 109 deletions
diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs
deleted file mode 100644
index d4fafae..0000000
--- a/PointPrimitiveRing.hs
+++ /dev/null
@@ -1,109 +0,0 @@
1{-# LANGUAGE LambdaCase, RecordWildCards, DataKinds #-}
2module PointPrimitiveRing where
3
4import Control.Monad
5import Control.Monad.Writer
6import Data.Data
7import Data.Dependent.Sum
8import Data.Foldable
9import Data.Function
10import Data.Int
11import Data.IORef
12import Data.Maybe
13import Data.Some
14import Data.Word
15import qualified Data.Map.Strict as Map
16import qualified Data.Vector as V
17 ;import Data.Vector as V ((!),(//))
18import Foreign.C.Types (CPtrdiff)
19import Foreign.Marshal
20import Foreign.Ptr
21import Foreign.Storable
22
23import LambdaCube.GL as LC
24import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
25import LambdaCube.GL.Mesh as LC
26import LambdaCube.GL.Type
27import LambdaCube.IR as LC
28import LambdaCube.GL.Util
29import LambdaCube.GL.Input.Type
30import LambdaCube.GL.Input hiding (createObjectCommands)
31
32import AttributeData
33
34-- import Graphics.GL.Core33
35
36import MaskableStream
37
38data Ring keys = Ring
39 { rBufferObject :: Buffer
40 , rStorage :: GLStorage
41 , rObject :: Object
42 , rSize :: IORef Int -- Current count of vertices in the ring buffer.
43 , rBack :: IORef Int -- Where next vertex will be added.
44 , ringCapacity :: Int -- Maximum number of vertices in buffer.
45 , rKeys :: keys
46 }
47
48newRing :: Data keys => GLStorage -> Int -> (String -> String) -> IO (Ring keys)
49newRing storage sz toAttr = fix $ \retProxy -> do
50 let paramProxy = paramProxy' retProxy
51 where paramProxy' :: io (ring keys) -> Proxy keys
52 paramProxy' _ = Proxy
53 startRef <- newIORef 0
54 sizeRef <- newIORef 0
55 let ps = fieldParameters paramProxy toAttr
56 putStrLn $ "Ring params: " ++ show ps
57 gd0 <- uploadDynamicBuffer sz ps
58 let gd = gd0 { dPrimitive = LineStrip }
59 Just keys <- return $ lookupAttrKeys (lookupAttributeKey gd . toAttr)
60 obj <- addToObjectArray storage "Points" [] gd
61 readIORef (objCommands obj) >>= mapM_ print
62 let r = Ring
63 { rBufferObject = streamBuffer $ head $ Map.elems (dStreams gd)
64 , rStorage = storage
65 , rObject = obj
66 , rSize = sizeRef
67 , rBack = startRef
68 , ringCapacity = sz
69 , rKeys = keys
70 }
71 updateRingCommands r
72 return r
73
74clearRing :: Ring keys -> IO ()
75clearRing r = do
76 writeIORef (rBack r) 0
77 writeIORef (rSize r) 0
78 updateRingCommands r
79
80updateRingCommands :: Ring keys -> IO ()
81updateRingCommands r = do
82 back <- fromIntegral <$> readIORef (rBack r)
83 size <- fromIntegral <$> readIORef (rSize r)
84 let mask 0 = []
85 mask cnt
86 | cnt==size = [(0,cnt)]
87 | otherwise = case cnt + back - size of
88 front | front > cnt -> [(front - cnt,size)]
89 | otherwise -> [(0,back), (front,cnt - front)]
90 updateCommands (rStorage r) (rObject r) mask
91 -- readIORef (objCommands $ rObject r) >>= mapM_ print
92 return ()
93
94pushBack :: Ring keys -> (keys -> Writer [DSum AttributeKey GLUniformValue] a) -> IO ()
95pushBack r attrs = do
96 back <- readIORef $ rBack r
97 writeIORef (rBack r) (mod (back + 1) (ringCapacity r))
98 updateAttributes back $ attrs (rKeys r)
99 sz <- readIORef (rSize r)
100 when (sz < ringCapacity r) $ writeIORef (rSize r) (sz + 1)
101 updateRingCommands r
102
103updateBack :: Ring keys -> (keys -> Writer [DSum AttributeKey GLUniformValue] a) -> IO ()
104updateBack r attrs = do
105 back <- readIORef $ rBack r
106 updateAttributes (mod (back - 1) (ringCapacity r)) $ attrs (rKeys r)
107
108updateRingUniforms :: GLStorage -> Ring keys -> IO ()
109updateRingUniforms _ _ = return ()