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
|
{-# 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
gd <- uploadDynamicBuffer sz ps
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
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 ()
|