diff options
Diffstat (limited to 'PointPrimitiveRing.hs')
-rw-r--r-- | PointPrimitiveRing.hs | 239 |
1 files changed, 239 insertions, 0 deletions
diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs new file mode 100644 index 0000000..bd9a15b --- /dev/null +++ b/PointPrimitiveRing.hs | |||
@@ -0,0 +1,239 @@ | |||
1 | {-# LANGUAGE LambdaCase, RecordWildCards #-} | ||
2 | module PointPrimitiveRing where | ||
3 | |||
4 | import Control.Monad | ||
5 | import Data.Foldable | ||
6 | import Data.Int | ||
7 | import Data.IORef | ||
8 | import Data.Maybe | ||
9 | import Data.Word | ||
10 | import qualified Data.Map.Strict as Map | ||
11 | import qualified Data.Vector as V | ||
12 | ;import Data.Vector as V ((!),(//)) | ||
13 | import Foreign.C.Types (CPtrdiff) | ||
14 | import Foreign.Marshal | ||
15 | import Foreign.Ptr | ||
16 | import Foreign.Storable | ||
17 | |||
18 | import LambdaCube.GL as LC | ||
19 | import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer) | ||
20 | import LambdaCube.GL.Mesh as LC | ||
21 | import LambdaCube.GL.Type | ||
22 | import LambdaCube.IR as LC | ||
23 | import LambdaCube.GL.Util | ||
24 | import LambdaCube.GL.Input.Type | ||
25 | import LambdaCube.GL.Input hiding (createObjectCommands) | ||
26 | |||
27 | import Graphics.GL.Core33 | ||
28 | |||
29 | data Ring = Ring | ||
30 | { rBufferObject :: Word32 | ||
31 | , rStorage :: GLStorage | ||
32 | , rObject :: Object | ||
33 | , rSize :: IORef CPtrdiff | ||
34 | , rStart :: IORef CPtrdiff | ||
35 | , ringCapacity :: CPtrdiff | ||
36 | } | ||
37 | |||
38 | addToObjectArray :: GLStorage | ||
39 | -> String -- ^ Slot name for a PrimitiveStream. | ||
40 | -> [String] -- ^ Uniform names. IORefs will be put in 'objUniSetup'. | ||
41 | -> GPUData | ||
42 | -> IO Object | ||
43 | addToObjectArray input slotName objUniNames (GPUData prim streams indices _) = do | ||
44 | let ObjectArraySchema _ slotStreams = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName) | ||
45 | $ Map.lookup slotName $! objectArrays $! schema input | ||
46 | addObject input slotName prim indices (Map.intersection streams slotStreams) objUniNames | ||
47 | |||
48 | setUniformCommand :: (String -> GLUniform) | ||
49 | -> (String,GLint) | ||
50 | -> GLObjectCommand | ||
51 | setUniformCommand ulookup (n,i) = GLSetUniform i (ulookup n) | ||
52 | |||
53 | bindTextureCommand :: (String -> IORef GLint) | ||
54 | -> (String -> GLUniform) | ||
55 | -> String | ||
56 | -> GLObjectCommand | ||
57 | bindTextureCommand tlookup ulookup n = GLBindTexture (inputTypeToTextureTarget $ uniInputType u) (tlookup n) u | ||
58 | where | ||
59 | u = ulookup n | ||
60 | uniInputType (GLTypedUniform ty _) = unwitnessType ty | ||
61 | uniInputType (GLUniform r) = objectType r | ||
62 | |||
63 | |||
64 | lookupOrLookup :: (Ord k, Show k) => String -> Map.Map k a -> Map.Map k a -> k -> a | ||
65 | lookupOrLookup callsite objUnis topUnis n = Map.findWithDefault (topUni n) n objUnis | ||
66 | where | ||
67 | topUni n = Map.findWithDefault (error $ "internal error ("++callsite++"): " ++ show n) n topUnis | ||
68 | |||
69 | |||
70 | classifyStreamType :: StreamType -> ( GLint | ||
71 | , GLuint -> GLuint -> GLint -> GLenum -> Ptr () -> GLObjectCommand) | ||
72 | classifyStreamType = \case | ||
73 | Attribute_Word -> ( 1 , GLSetVertexAttribIArray ) | ||
74 | Attribute_V2U -> ( 2 , GLSetVertexAttribIArray ) | ||
75 | Attribute_V3U -> ( 3 , GLSetVertexAttribIArray ) | ||
76 | Attribute_V4U -> ( 4 , GLSetVertexAttribIArray ) | ||
77 | Attribute_Int -> ( 1 , GLSetVertexAttribIArray ) | ||
78 | Attribute_V2I -> ( 2 , GLSetVertexAttribIArray ) | ||
79 | Attribute_V3I -> ( 3 , GLSetVertexAttribIArray ) | ||
80 | Attribute_V4I -> ( 4 , GLSetVertexAttribIArray ) | ||
81 | Attribute_Float -> ( 1 , GLSetVertexAttribArray ) | ||
82 | Attribute_V2F -> ( 2 , GLSetVertexAttribArray ) | ||
83 | Attribute_V3F -> ( 3 , GLSetVertexAttribArray ) | ||
84 | Attribute_V4F -> ( 4 , GLSetVertexAttribArray ) | ||
85 | Attribute_M22F -> ( 4 , GLSetVertexAttribArray ) | ||
86 | Attribute_M23F -> ( 6 , GLSetVertexAttribArray ) | ||
87 | Attribute_M24F -> ( 8 , GLSetVertexAttribArray ) | ||
88 | Attribute_M32F -> ( 6 , GLSetVertexAttribArray ) | ||
89 | Attribute_M33F -> ( 9 , GLSetVertexAttribArray ) | ||
90 | Attribute_M34F -> ( 12 , GLSetVertexAttribArray ) | ||
91 | Attribute_M42F -> ( 8 , GLSetVertexAttribArray ) | ||
92 | Attribute_M43F -> ( 12 , GLSetVertexAttribArray ) | ||
93 | Attribute_M44F -> ( 16 , GLSetVertexAttribArray ) | ||
94 | |||
95 | drawElementsCommand :: GLenum -> IndexStream Buffer -> GLObjectCommand | ||
96 | drawElementsCommand prim (IndexStream (Buffer arrs bo) arrIdx start idxCount) | ||
97 | = GLDrawElements prim (fromIntegral idxCount) idxType bo ptr | ||
98 | where | ||
99 | ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx | ||
100 | idxType = arrayTypeToGLType arrType | ||
101 | ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType) | ||
102 | |||
103 | objectDrawStyle :: (GLsizei -> [(GLint,GLsizei)]) -- ^ mask, normally \x -> [(0,x)] | ||
104 | -> Object | ||
105 | -> Either [(GLint,GLsizei)] (IndexStream Buffer) | ||
106 | objectDrawStyle streamMask obj = case objIndices obj of | ||
107 | Nothing -> Left $ let cnt = head [c | Stream _ _ _ _ c <- Map.elems (objAttributes obj)] | ||
108 | in streamMask $ fromIntegral cnt | ||
109 | Just idxStream -> Right idxStream | ||
110 | |||
111 | |||
112 | createObjectCommands :: Map.Map String (IORef GLint) -> Map.Map String GLUniform -> Object -> GLProgram -> [GLObjectCommand] | ||
113 | createObjectCommands texUnitMap topUnis obj prg = | ||
114 | createObjectCommands_ (objectEnvironment texUnitMap topUnis obj (pure . ((,) 0))) prg | ||
115 | |||
116 | createObjectCommands_ :: ObjectEnvironment -> GLProgram -> [GLObjectCommand] | ||
117 | createObjectCommands_ ObjectEnvironment{..} prg = concat | ||
118 | [ map (setUniformCommand ulookup) $ Map.toList (inputUniforms prg) | ||
119 | , map (bindTextureCommand tlookup ulookup) $ toList (inputTextureUniforms prg) | ||
120 | , map (setVertexAttribCommmand alookup) $ Map.elems (inputStreams prg) | ||
121 | , case envDrawStyle of | ||
122 | Left ranges -> map (uncurry $ GLDrawArrays envPrim) ranges | ||
123 | Right indexed -> pure $ drawElementsCommand envPrim indexed | ||
124 | ] | ||
125 | |||
126 | data ObjectEnvironment = ObjectEnvironment | ||
127 | { envPrim :: GLenum | ||
128 | , envDrawStyle :: Either [(GLint,GLsizei)] (IndexStream Buffer) | ||
129 | , tlookup :: String -> IORef GLint | ||
130 | , ulookup :: String -> GLUniform | ||
131 | , alookup :: String -> Stream Buffer | ||
132 | } | ||
133 | |||
134 | objectEnvironment :: Map.Map String (IORef GLint) | ||
135 | -> Map.Map String GLUniform | ||
136 | -> Object | ||
137 | -> (GLsizei -> [(GLint, GLsizei)]) | ||
138 | -> ObjectEnvironment | ||
139 | objectEnvironment texUnitMap topUnis obj streamMask = ObjectEnvironment | ||
140 | { envPrim = primitiveToGLType $ objPrimitive obj | ||
141 | , envDrawStyle = objectDrawStyle streamMask obj | ||
142 | , tlookup = \n -> Map.findWithDefault (error $ "missing texture unit: " ++ show n) n texUnitMap | ||
143 | , ulookup = lookupOrLookup "missing uniform: " (objUniSetup obj) topUnis | ||
144 | , alookup = \n -> Map.findWithDefault (error $ "missing attribute: " ++ n) n $ objAttributes obj | ||
145 | } | ||
146 | |||
147 | |||
148 | setVertexAttribCommmand :: (t -> Stream Buffer) -> (GLuint, t) -> GLObjectCommand | ||
149 | setVertexAttribCommmand alookup (i,name) = case alookup name of | ||
150 | Stream ty (Buffer arrs bo) arrIdx start len -> mkAttrCmd i bo n (arrayTypeToGLType arrType) (intPtrToPtr $! offset) | ||
151 | where | ||
152 | (n, mkAttrCmd) = classifyStreamType ty | ||
153 | ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx | ||
154 | offset = fromIntegral (arrOffs + start * fromIntegral n * sizeOfArrayType arrType) | ||
155 | |||
156 | -- constant generic attribute | ||
157 | constAttr -> GLSetVertexAttrib i constAttr | ||
158 | |||
159 | updateCommands :: GLStorage | ||
160 | -> Object | ||
161 | -> (GLsizei -> [(GLint,GLsizei)]) | ||
162 | -> IO Object | ||
163 | updateCommands input obj mask = do | ||
164 | let cmdsRef = objCommands obj :: IORef (V.Vector (V.Vector [GLObjectCommand])) | ||
165 | slotIdx = objSlot obj :: Int | ||
166 | ppls <- readIORef $ pipelines input | ||
167 | cmds <- V.forM (ppls :: V.Vector (Maybe GLRenderer)) $ \mp -> case mp of | ||
168 | Nothing -> return V.empty | ||
169 | Just p -> do | ||
170 | let env = objectEnvironment (glTexUnitMapping p) (uniformSetup input) obj mask | ||
171 | Just ic <- readIORef $ glInput p | ||
172 | case icSlotMapInputToPipeline ic ! slotIdx of | ||
173 | Nothing -> return V.empty -- this slot is not used in that pipeline | ||
174 | Just pSlotIdx -> do | ||
175 | let emptyV = V.replicate (V.length $ glPrograms p) [] | ||
176 | return $ emptyV // [(prgIdx,createObjectCommands_ env (glPrograms p ! prgIdx)) | ||
177 | | prgIdx <- glSlotPrograms p ! pSlotIdx] | ||
178 | writeIORef cmdsRef cmds | ||
179 | return obj | ||
180 | |||
181 | newRing :: GLStorage -> Int -> IO Ring | ||
182 | newRing storage sz = do | ||
183 | bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo | ||
184 | glBindBuffer GL_ARRAY_BUFFER bo | ||
185 | let bufsize = 3 * fromIntegral sz | ||
186 | byteCount = 4 * bufsize | ||
187 | glBufferData GL_ARRAY_BUFFER byteCount nullPtr GL_DYNAMIC_DRAW | ||
188 | glBindBuffer GL_ARRAY_BUFFER 0 | ||
189 | startRef <- newIORef 0 | ||
190 | sizeRef <- newIORef 0 | ||
191 | let buffer = Buffer (V.singleton $ ArrayDesc ArrFloat (fromIntegral bufsize) 0 (fromIntegral byteCount)) | ||
192 | bo | ||
193 | gd = GPUData PointList (Map.singleton "position" $ Stream Attribute_V3F buffer 0 0 sz) Nothing [buffer] | ||
194 | obj <- addToObjectArray storage "Points" [] gd | ||
195 | readIORef (objCommands obj) >>= mapM_ print | ||
196 | -- [[GLSetUniform 0 GLUniform M44F,GLSetVertexAttribArray 0 5 3 5126 0x0000000000000000,GLDrawArrays 0 0 1],[],[],[]] | ||
197 | let r = Ring | ||
198 | { rBufferObject = bo | ||
199 | , rStorage = storage | ||
200 | , rObject = obj | ||
201 | , rSize = sizeRef | ||
202 | , rStart = startRef | ||
203 | , ringCapacity = bufsize | ||
204 | } | ||
205 | updateRingCommands r | ||
206 | return r | ||
207 | |||
208 | updateRingCommands :: Ring -> IO () | ||
209 | updateRingCommands r = do | ||
210 | start <- fmap (fromIntegral . (`div` 3)) $ readIORef $ rStart r | ||
211 | size <- fmap (fromIntegral . (`div` 3)) $ readIORef $ rSize r | ||
212 | let mask 0 = [] | ||
213 | mask cnt = if start + size < cnt | ||
214 | then [(start,size)] | ||
215 | else [(0,start + size - cnt), (start,cnt-start)] | ||
216 | updateCommands (rStorage r) (rObject r) mask | ||
217 | readIORef (objCommands $ rObject r) >>= mapM_ print | ||
218 | return () | ||
219 | |||
220 | pushBack :: Ring -> Float -> Float -> Float -> IO () | ||
221 | pushBack r x y z = allocaArray 3 $ \ptr -> do | ||
222 | pokeElemOff ptr 0 x | ||
223 | pokeElemOff ptr 1 y | ||
224 | pokeElemOff ptr 2 z | ||
225 | start <- readIORef $ rStart r | ||
226 | writeIORef (rStart r) (mod (start + 3) (ringCapacity r)) | ||
227 | glBindBuffer GL_ARRAY_BUFFER (rBufferObject r) | ||
228 | glBufferSubData GL_ARRAY_BUFFER (4*start) (4*3) ptr | ||
229 | glBindBuffer GL_ARRAY_BUFFER 0 | ||
230 | glFlush | ||
231 | glFinish | ||
232 | sz <- readIORef (rSize r) | ||
233 | putStrLn $ "pushBack "++show (sz,start,(x,y,z)) | ||
234 | when (sz < ringCapacity r) $ do | ||
235 | writeIORef (rSize r) (sz + 3) | ||
236 | updateRingCommands r | ||
237 | |||
238 | updateRingUniforms :: GLStorage -> Ring -> IO () | ||
239 | updateRingUniforms _ _ = return () | ||