diff options
Diffstat (limited to 'PointPrimitiveRing.hs')
-rw-r--r-- | PointPrimitiveRing.hs | 109 |
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 #-} | ||
2 | module PointPrimitiveRing where | ||
3 | |||
4 | import Control.Monad | ||
5 | import Control.Monad.Writer | ||
6 | import Data.Data | ||
7 | import Data.Dependent.Sum | ||
8 | import Data.Foldable | ||
9 | import Data.Function | ||
10 | import Data.Int | ||
11 | import Data.IORef | ||
12 | import Data.Maybe | ||
13 | import Data.Some | ||
14 | import Data.Word | ||
15 | import qualified Data.Map.Strict as Map | ||
16 | import qualified Data.Vector as V | ||
17 | ;import Data.Vector as V ((!),(//)) | ||
18 | import Foreign.C.Types (CPtrdiff) | ||
19 | import Foreign.Marshal | ||
20 | import Foreign.Ptr | ||
21 | import Foreign.Storable | ||
22 | |||
23 | import LambdaCube.GL as LC | ||
24 | import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer) | ||
25 | import LambdaCube.GL.Mesh as LC | ||
26 | import LambdaCube.GL.Type | ||
27 | import LambdaCube.IR as LC | ||
28 | import LambdaCube.GL.Util | ||
29 | import LambdaCube.GL.Input.Type | ||
30 | import LambdaCube.GL.Input hiding (createObjectCommands) | ||
31 | |||
32 | import AttributeData | ||
33 | |||
34 | -- import Graphics.GL.Core33 | ||
35 | |||
36 | import MaskableStream | ||
37 | |||
38 | data 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 | |||
48 | newRing :: Data keys => GLStorage -> Int -> (String -> String) -> IO (Ring keys) | ||
49 | newRing 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 | |||
74 | clearRing :: Ring keys -> IO () | ||
75 | clearRing r = do | ||
76 | writeIORef (rBack r) 0 | ||
77 | writeIORef (rSize r) 0 | ||
78 | updateRingCommands r | ||
79 | |||
80 | updateRingCommands :: Ring keys -> IO () | ||
81 | updateRingCommands 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 | |||
94 | pushBack :: Ring keys -> (keys -> Writer [DSum AttributeKey GLUniformValue] a) -> IO () | ||
95 | pushBack 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 | |||
103 | updateBack :: Ring keys -> (keys -> Writer [DSum AttributeKey GLUniformValue] a) -> IO () | ||
104 | updateBack r attrs = do | ||
105 | back <- readIORef $ rBack r | ||
106 | updateAttributes (mod (back - 1) (ringCapacity r)) $ attrs (rKeys r) | ||
107 | |||
108 | updateRingUniforms :: GLStorage -> Ring keys -> IO () | ||
109 | updateRingUniforms _ _ = return () | ||