summaryrefslogtreecommitdiff
path: root/Backend/GL/Input.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Backend/GL/Input.hs')
-rw-r--r--Backend/GL/Input.hs387
1 files changed, 0 insertions, 387 deletions
diff --git a/Backend/GL/Input.hs b/Backend/GL/Input.hs
deleted file mode 100644
index f92a9c9..0000000
--- a/Backend/GL/Input.hs
+++ /dev/null
@@ -1,387 +0,0 @@
1module Backend.GL.Input where
2
3import Control.Applicative
4import Control.Exception
5import Control.Monad
6import Data.ByteString.Char8 (ByteString,pack)
7import Data.IORef
8import Data.IntMap (IntMap)
9import Data.Trie (Trie)
10import Data.Trie.Convenience as T
11import Data.Vector (Vector,(//),(!))
12import Data.Word
13import Foreign
14import qualified Data.ByteString.Char8 as SB
15import qualified Data.IntMap as IM
16import qualified Data.Set as S
17import qualified Data.Map as Map
18import qualified Data.Trie as T
19import qualified Data.Vector as V
20import qualified Data.Vector.Algorithms.Intro as I
21
22import Graphics.Rendering.OpenGL.Raw.Core33
23
24import IR as IR
25import Linear as IR
26import Backend.GL.Type as T
27import Backend.GL.Util
28
29import qualified IR as IR
30
31schemaFromPipeline :: IR.Pipeline -> PipelineSchema
32schemaFromPipeline a = PipelineSchema (T.fromList sl) (foldl T.unionL T.empty ul)
33 where
34 (sl,ul) = unzip [( (pack sName,SlotSchema sPrimitive (fmap cvt (toTrie sStreams)))
35 , toTrie sUniforms
36 )
37 | IR.Slot sName sStreams sUniforms sPrimitive _ <- V.toList $ IR.slots a
38 ]
39 cvt a = case toStreamType a of
40 Just v -> v
41 Nothing -> error "internal error (schemaFromPipeline)"
42
43mkUniform :: [(ByteString,InputType)] -> IO (Trie InputSetter, Trie GLUniform)
44mkUniform l = do
45 unisAndSetters <- forM l $ \(n,t) -> do
46 (uni, setter) <- mkUniformSetter t
47 return ((n,uni),(n,setter))
48 let (unis,setters) = unzip unisAndSetters
49 return (T.fromList setters, T.fromList unis)
50
51mkGLPipelineInput :: PipelineSchema -> IO GLPipelineInput
52mkGLPipelineInput sch = do
53 let sm = T.fromList $ zip (T.keys $ T.slots sch) [0..]
54 len = T.size sm
55 (setters,unis) <- mkUniform $ T.toList $ uniforms sch
56 seed <- newIORef 0
57 slotV <- V.replicateM len $ newIORef (GLSlot IM.empty V.empty Ordered)
58 size <- newIORef (0,0)
59 ppls <- newIORef $ V.singleton Nothing
60 return $ GLPipelineInput
61 { schema = sch
62 , slotMap = sm
63 , slotVector = slotV
64 , objSeed = seed
65 , uniformSetter = setters
66 , uniformSetup = unis
67 , screenSize = size
68 , pipelines = ppls
69 }
70
71-- object
72addObject :: GLPipelineInput -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object
73addObject input slotName prim indices attribs uniformNames = do
74 let sch = schema input
75 forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of
76 Nothing -> throw $ userError $ "Unknown uniform: " ++ show n
77 _ -> return ()
78 case T.lookup slotName (T.slots sch) of
79 Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName
80 Just (SlotSchema sPrim sAttrs) -> do
81 when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $
82 "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim
83 let sType = fmap streamToStreamType attribs
84 when (sType /= sAttrs) $ throw $ userError $ unlines $
85 [ "Attribute stream mismatch for slot (" ++ show slotName ++ ") expected "
86 , show sAttrs
87 , " but got "
88 , show sType
89 ]
90
91 let slotIdx = case slotName `T.lookup` slotMap input of
92 Nothing -> error $ "internal error (slot index): " ++ show slotName
93 Just i -> i
94 seed = objSeed input
95 order <- newIORef 0
96 enabled <- newIORef True
97 index <- readIORef seed
98 modifyIORef seed (1+)
99 (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let Just t = T.lookup n (uniforms sch)]
100 cmdsRef <- newIORef (V.singleton V.empty)
101 let obj = Object
102 { objSlot = slotIdx
103 , objPrimitive = prim
104 , objIndices = indices
105 , objAttributes = attribs
106 , objUniSetter = setters
107 , objUniSetup = unis
108 , objOrder = order
109 , objEnabled = enabled
110 , objId = index
111 , objCommands = cmdsRef
112 }
113
114 modifyIORef (slotVector input ! slotIdx) $ \(GLSlot objs _ _) -> GLSlot (IM.insert index obj objs) V.empty Generate
115
116 -- generate GLObjectCommands for the new object
117 {-
118 foreach pipeline:
119 foreach realted program:
120 generate commands
121 -}
122 ppls <- readIORef $ pipelines input
123 let topUnis = uniformSetup input
124 cmds <- V.forM ppls $ \mp -> case mp of
125 Nothing -> return V.empty
126 Just p -> do
127 Just ic <- readIORef $ glInput p
128 case icSlotMapInputToPipeline ic ! slotIdx of
129 Nothing -> do
130 putStrLn $ " ** slot is not used!"
131 return V.empty -- this slot is not used in that pipeline
132 Just pSlotIdx -> do
133 putStrLn "slot is used!"
134 --where
135 let emptyV = V.replicate (V.length $ glPrograms p) []
136 return $ emptyV // [(prgIdx,createObjectCommands (glTexUnitMapping p) topUnis obj (glPrograms p ! prgIdx))| prgIdx <- glSlotPrograms p ! pSlotIdx]
137 writeIORef cmdsRef cmds
138 return obj
139
140removeObject :: GLPipelineInput -> Object -> IO ()
141removeObject p obj = modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs _ _) -> GLSlot (IM.delete (objId obj) objs) V.empty Generate
142
143enableObject :: Object -> Bool -> IO ()
144enableObject obj b = writeIORef (objEnabled obj) b
145
146setObjectOrder :: GLPipelineInput -> Object -> Int -> IO ()
147setObjectOrder p obj i = do
148 writeIORef (objOrder obj) i
149 modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder
150
151objectUniformSetter :: Object -> Trie InputSetter
152objectUniformSetter = objUniSetter
153
154setScreenSize :: GLPipelineInput -> Word -> Word -> IO ()
155setScreenSize p w h = writeIORef (screenSize p) (w,h)
156
157sortSlotObjects :: GLPipelineInput -> IO ()
158sortSlotObjects p = V.forM_ (slotVector p) $ \slotRef -> do
159 GLSlot objMap sortedV ord <- readIORef slotRef
160 let cmpFun (a,_) (b,_) = a `compare` b
161 doSort objs = do
162 ordObjsM <- V.thaw objs
163 I.sortBy cmpFun ordObjsM
164 ordObjs <- V.freeze ordObjsM
165 writeIORef slotRef (GLSlot objMap ordObjs Ordered)
166 case ord of
167 Ordered -> return ()
168 Generate -> do
169 objs <- V.forM (V.fromList $ IM.elems objMap) $ \obj -> do
170 ord <- readIORef $ objOrder obj
171 return (ord,obj)
172 doSort objs
173 Reorder -> do
174 objs <- V.forM sortedV $ \(_,obj) -> do
175 ord <- readIORef $ objOrder obj
176 return (ord,obj)
177 doSort objs
178
179createObjectCommands :: Trie (IORef GLint) -> Trie GLUniform -> Object -> GLProgram -> [GLObjectCommand]
180createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++ [objDrawCmd]
181 where
182 -- object draw command
183 objDrawCmd = case objIndices obj of
184 Nothing -> GLDrawArrays prim 0 (fromIntegral count)
185 Just (IndexStream (Buffer arrs bo) arrIdx start idxCount) -> GLDrawElements prim (fromIntegral idxCount) idxType bo ptr
186 where
187 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
188 idxType = arrayTypeToGLType arrType
189 ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType)
190 where
191 objAttrs = objAttributes obj
192 prim = primitiveToGLType $ objPrimitive obj
193 count = head [c | Stream _ _ _ _ c <- T.elems objAttrs]
194
195 -- object uniform commands
196 -- texture slot setup commands
197 objUniCmds = uniCmds ++ texCmds
198 where
199 uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = T.lookupWithDefault (topUni n) n objUnis]
200 uniMap = T.toList $ inputUniforms prg
201 topUni n = T.lookupWithDefault (error $ "internal error (createObjectCommands): " ++ show n) n topUnis
202 objUnis = objUniSetup obj
203 texUnis = S.toList $ inputTextureUniforms prg
204 texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u
205 | n <- texUnis
206 , let u = T.lookupWithDefault (topUni n) n objUnis
207 , let texUnit = T.lookupWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap
208 ]
209 uniInputType (GLUniform ty _) = ty
210
211 -- object attribute stream commands
212 objStreamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name objAttrs]
213 where
214 attrMap = inputStreams prg
215 objAttrs = objAttributes obj
216 attrCmd i s = case s of
217 Stream ty (Buffer arrs bo) arrIdx start len -> case ty of
218 TWord -> setIntAttrib 1
219 TV2U -> setIntAttrib 2
220 TV3U -> setIntAttrib 3
221 TV4U -> setIntAttrib 4
222 TInt -> setIntAttrib 1
223 TV2I -> setIntAttrib 2
224 TV3I -> setIntAttrib 3
225 TV4I -> setIntAttrib 4
226 TFloat -> setFloatAttrib 1
227 TV2F -> setFloatAttrib 2
228 TV3F -> setFloatAttrib 3
229 TV4F -> setFloatAttrib 4
230 TM22F -> setFloatAttrib 4
231 TM23F -> setFloatAttrib 6
232 TM24F -> setFloatAttrib 8
233 TM32F -> setFloatAttrib 6
234 TM33F -> setFloatAttrib 9
235 TM34F -> setFloatAttrib 12
236 TM42F -> setFloatAttrib 8
237 TM43F -> setFloatAttrib 12
238 TM44F -> setFloatAttrib 16
239 where
240 setFloatAttrib n = GLSetVertexAttribArray i bo n glType (ptr n)
241 setIntAttrib n = GLSetVertexAttribIArray i bo n glType (ptr n)
242 ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
243 glType = arrayTypeToGLType arrType
244 ptr compCnt = intPtrToPtr $! fromIntegral (arrOffs + start * fromIntegral compCnt * sizeOfArrayType arrType)
245
246 -- constant generic attribute
247 constAttr -> GLSetVertexAttrib i constAttr
248
249nullSetter :: ByteString -> String -> a -> IO ()
250--nullSetter n t _ = return () -- Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t
251nullSetter n t _ = Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t
252
253uniformBool :: ByteString -> Trie InputSetter -> SetterFun Bool
254uniformV2B :: ByteString -> Trie InputSetter -> SetterFun V2B
255uniformV3B :: ByteString -> Trie InputSetter -> SetterFun V3B
256uniformV4B :: ByteString -> Trie InputSetter -> SetterFun V4B
257
258uniformWord :: ByteString -> Trie InputSetter -> SetterFun Word32
259uniformV2U :: ByteString -> Trie InputSetter -> SetterFun V2U
260uniformV3U :: ByteString -> Trie InputSetter -> SetterFun V3U
261uniformV4U :: ByteString -> Trie InputSetter -> SetterFun V4U
262
263uniformInt :: ByteString -> Trie InputSetter -> SetterFun Int32
264uniformV2I :: ByteString -> Trie InputSetter -> SetterFun V2I
265uniformV3I :: ByteString -> Trie InputSetter -> SetterFun V3I
266uniformV4I :: ByteString -> Trie InputSetter -> SetterFun V4I
267
268uniformFloat :: ByteString -> Trie InputSetter -> SetterFun Float
269uniformV2F :: ByteString -> Trie InputSetter -> SetterFun V2F
270uniformV3F :: ByteString -> Trie InputSetter -> SetterFun V3F
271uniformV4F :: ByteString -> Trie InputSetter -> SetterFun V4F
272
273uniformM22F :: ByteString -> Trie InputSetter -> SetterFun M22F
274uniformM23F :: ByteString -> Trie InputSetter -> SetterFun M23F
275uniformM24F :: ByteString -> Trie InputSetter -> SetterFun M24F
276uniformM32F :: ByteString -> Trie InputSetter -> SetterFun M32F
277uniformM33F :: ByteString -> Trie InputSetter -> SetterFun M33F
278uniformM34F :: ByteString -> Trie InputSetter -> SetterFun M34F
279uniformM42F :: ByteString -> Trie InputSetter -> SetterFun M42F
280uniformM43F :: ByteString -> Trie InputSetter -> SetterFun M43F
281uniformM44F :: ByteString -> Trie InputSetter -> SetterFun M44F
282
283uniformFTexture2D :: ByteString -> Trie InputSetter -> SetterFun TextureData
284
285uniformBool n is = case T.lookup n is of
286 Just (SBool fun) -> fun
287 _ -> nullSetter n "Bool"
288
289uniformV2B n is = case T.lookup n is of
290 Just (SV2B fun) -> fun
291 _ -> nullSetter n "V2B"
292
293uniformV3B n is = case T.lookup n is of
294 Just (SV3B fun) -> fun
295 _ -> nullSetter n "V3B"
296
297uniformV4B n is = case T.lookup n is of
298 Just (SV4B fun) -> fun
299 _ -> nullSetter n "V4B"
300
301uniformWord n is = case T.lookup n is of
302 Just (SWord fun) -> fun
303 _ -> nullSetter n "Word"
304
305uniformV2U n is = case T.lookup n is of
306 Just (SV2U fun) -> fun
307 _ -> nullSetter n "V2U"
308
309uniformV3U n is = case T.lookup n is of
310 Just (SV3U fun) -> fun
311 _ -> nullSetter n "V3U"
312
313uniformV4U n is = case T.lookup n is of
314 Just (SV4U fun) -> fun
315 _ -> nullSetter n "V4U"
316
317uniformInt n is = case T.lookup n is of
318 Just (SInt fun) -> fun
319 _ -> nullSetter n "Int"
320
321uniformV2I n is = case T.lookup n is of
322 Just (SV2I fun) -> fun
323 _ -> nullSetter n "V2I"
324
325uniformV3I n is = case T.lookup n is of
326 Just (SV3I fun) -> fun
327 _ -> nullSetter n "V3I"
328
329uniformV4I n is = case T.lookup n is of
330 Just (SV4I fun) -> fun
331 _ -> nullSetter n "V4I"
332
333uniformFloat n is = case T.lookup n is of
334 Just (SFloat fun) -> fun
335 _ -> nullSetter n "Float"
336
337uniformV2F n is = case T.lookup n is of
338 Just (SV2F fun) -> fun
339 _ -> nullSetter n "V2F"
340
341uniformV3F n is = case T.lookup n is of
342 Just (SV3F fun) -> fun
343 _ -> nullSetter n "V3F"
344
345uniformV4F n is = case T.lookup n is of
346 Just (SV4F fun) -> fun
347 _ -> nullSetter n "V4F"
348
349uniformM22F n is = case T.lookup n is of
350 Just (SM22F fun) -> fun
351 _ -> nullSetter n "M22F"
352
353uniformM23F n is = case T.lookup n is of
354 Just (SM23F fun) -> fun
355 _ -> nullSetter n "M23F"
356
357uniformM24F n is = case T.lookup n is of
358 Just (SM24F fun) -> fun
359 _ -> nullSetter n "M24F"
360
361uniformM32F n is = case T.lookup n is of
362 Just (SM32F fun) -> fun
363 _ -> nullSetter n "M32F"
364
365uniformM33F n is = case T.lookup n is of
366 Just (SM33F fun) -> fun
367 _ -> nullSetter n "M33F"
368
369uniformM34F n is = case T.lookup n is of
370 Just (SM34F fun) -> fun
371 _ -> nullSetter n "M34F"
372
373uniformM42F n is = case T.lookup n is of
374 Just (SM42F fun) -> fun
375 _ -> nullSetter n "M42F"
376
377uniformM43F n is = case T.lookup n is of
378 Just (SM43F fun) -> fun
379 _ -> nullSetter n "M43F"
380
381uniformM44F n is = case T.lookup n is of
382 Just (SM44F fun) -> fun
383 _ -> nullSetter n "M44F"
384
385uniformFTexture2D n is = case T.lookup n is of
386 Just (SFTexture2D fun) -> fun
387 _ -> nullSetter n "FTexture2D"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-09 09:01:42 +0000