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