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