diff options
author | Csaba Hruska <csaba.hruska@gmail.com> | 2016-01-08 14:53:25 +0100 |
---|---|---|
committer | Csaba Hruska <csaba.hruska@gmail.com> | 2016-01-08 14:53:25 +0100 |
commit | 2cc82723838be8f9fc084c7582bbc87f26e1a794 (patch) | |
tree | 154ecec9f0a82f0d6aeb3c5a9f2cd7b489cfa8cb /src | |
parent | 64e13239772dae2a73e30bd0aa8ca2c70154987c (diff) |
use Map instead of Trie
Diffstat (limited to 'src')
-rw-r--r-- | src/LambdaCube/GL.hs | 2 | ||||
-rw-r--r-- | src/LambdaCube/GL/Backend.hs | 82 | ||||
-rw-r--r-- | src/LambdaCube/GL/Data.hs | 1 | ||||
-rw-r--r-- | src/LambdaCube/GL/Input.hs | 164 | ||||
-rw-r--r-- | src/LambdaCube/GL/Mesh.hs | 27 | ||||
-rw-r--r-- | src/LambdaCube/GL/Type.hs | 34 | ||||
-rw-r--r-- | src/LambdaCube/GL/Util.hs | 13 |
7 files changed, 158 insertions, 165 deletions
diff --git a/src/LambdaCube/GL.hs b/src/LambdaCube/GL.hs index 37ba205..1c87f94 100644 --- a/src/LambdaCube/GL.hs +++ b/src/LambdaCube/GL.hs | |||
@@ -30,7 +30,7 @@ module LambdaCube.GL ( | |||
30 | GLStorage, | 30 | GLStorage, |
31 | Object, | 31 | Object, |
32 | PipelineSchema(..), | 32 | PipelineSchema(..), |
33 | SlotSchema(..), | 33 | ObjectArraySchema(..), |
34 | schema, | 34 | schema, |
35 | schemaFromPipeline, | 35 | schemaFromPipeline, |
36 | allocRenderer, | 36 | allocRenderer, |
diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs index 7251a78..196280d 100644 --- a/src/LambdaCube/GL/Backend.hs +++ b/src/LambdaCube/GL/Backend.hs | |||
@@ -11,8 +11,6 @@ import Data.IntMap (IntMap) | |||
11 | import Data.Maybe (isNothing,fromJust) | 11 | import Data.Maybe (isNothing,fromJust) |
12 | import Data.Map (Map) | 12 | import Data.Map (Map) |
13 | import Data.Set (Set) | 13 | import Data.Set (Set) |
14 | import Data.Trie as T | ||
15 | import Data.Trie.Convenience as T | ||
16 | import Data.Vector (Vector,(!),(//)) | 14 | import Data.Vector (Vector,(!),(//)) |
17 | import qualified Data.ByteString.Char8 as SB | 15 | import qualified Data.ByteString.Char8 as SB |
18 | import qualified Data.Foldable as F | 16 | import qualified Data.Foldable as F |
@@ -198,7 +196,7 @@ clearRenderTarget values = do | |||
198 | printGLStatus = checkGL >>= print | 196 | printGLStatus = checkGL >>= print |
199 | printFBOStatus = checkFBO >>= print | 197 | printFBOStatus = checkFBO >>= print |
200 | 198 | ||
201 | compileProgram :: Trie InputType -> Program -> IO GLProgram | 199 | compileProgram :: Map ByteString InputType -> Program -> IO GLProgram |
202 | compileProgram uniTrie p = do | 200 | compileProgram uniTrie p = do |
203 | po <- glCreateProgram | 201 | po <- glCreateProgram |
204 | putStrLn $ "compile program: " ++ show po | 202 | putStrLn $ "compile program: " ++ show po |
@@ -230,10 +228,10 @@ compileProgram uniTrie p = do | |||
230 | (attributes,attributesType) <- queryStreams po | 228 | (attributes,attributesType) <- queryStreams po |
231 | print uniforms | 229 | print uniforms |
232 | print attributes | 230 | print attributes |
233 | let lcUniforms = (toTrie $ programUniforms p) `unionL` (toTrie $ programInTextures p) | 231 | let lcUniforms = (toTrie $ programUniforms p) `Map.union` (toTrie $ programInTextures p) |
234 | lcStreams = fmap ty (toTrie $ programStreams p) | 232 | lcStreams = fmap ty (toTrie $ programStreams p) |
235 | check a m = and $ map go $ T.toList m | 233 | check a m = and $ map go $ Map.toList m |
236 | where go (k,b) = case T.lookup k a of | 234 | where go (k,b) = case Map.lookup k a of |
237 | Nothing -> False | 235 | Nothing -> False |
238 | Just x -> x == b | 236 | Just x -> x == b |
239 | unless (check lcUniforms uniformsType) $ do | 237 | unless (check lcUniforms uniformsType) $ do |
@@ -241,31 +239,31 @@ compileProgram uniTrie p = do | |||
241 | putStrLn $ "actual: " ++ show uniformsType | 239 | putStrLn $ "actual: " ++ show uniformsType |
242 | fail "shader program uniform input mismatch!" | 240 | fail "shader program uniform input mismatch!" |
243 | unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams) | 241 | unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams) |
244 | -- the public (user) pipeline and program input is encoded by the slots, therefore the programs does not distinct the render and slot textures input | 242 | -- the public (user) pipeline and program input is encoded by the objectArrays, therefore the programs does not distinct the render and slot textures input |
245 | let inUniNames = toTrie $ programUniforms p | 243 | let inUniNames = toTrie $ programUniforms p |
246 | inUniforms = L.filter (\(n,v) -> T.member n inUniNames) $ T.toList $ uniforms | 244 | inUniforms = L.filter (\(n,v) -> Map.member n inUniNames) $ Map.toList $ uniforms |
247 | inTextureNames = toTrie $ programInTextures p | 245 | inTextureNames = toTrie $ programInTextures p |
248 | inTextures = L.filter (\(n,v) -> T.member n inTextureNames) $ T.toList $ uniforms | 246 | inTextures = L.filter (\(n,v) -> Map.member n inTextureNames) $ Map.toList $ uniforms |
249 | texUnis = [n | (n,_) <- inTextures, T.member n uniTrie] | 247 | texUnis = [n | (n,_) <- inTextures, Map.member n uniTrie] |
250 | putStrLn $ "uniTrie: " ++ show (T.keys uniTrie) | 248 | putStrLn $ "uniTrie: " ++ show (Map.keys uniTrie) |
251 | putStrLn $ "inUniNames: " ++ show inUniNames | 249 | putStrLn $ "inUniNames: " ++ show inUniNames |
252 | putStrLn $ "inUniforms: " ++ show inUniforms | 250 | putStrLn $ "inUniforms: " ++ show inUniforms |
253 | putStrLn $ "inTextureNames: " ++ show inTextureNames | 251 | putStrLn $ "inTextureNames: " ++ show inTextureNames |
254 | putStrLn $ "inTextures: " ++ show inTextures | 252 | putStrLn $ "inTextures: " ++ show inTextures |
255 | putStrLn $ "texUnis: " ++ show texUnis | 253 | putStrLn $ "texUnis: " ++ show texUnis |
256 | let valA = T.toList $ attributes | 254 | let valA = Map.toList $ attributes |
257 | valB = T.toList $ toTrie $ programStreams p | 255 | valB = Map.toList $ toTrie $ programStreams p |
258 | putStrLn "------------" | 256 | putStrLn "------------" |
259 | print $ T.toList $ attributes | 257 | print $ Map.toList $ attributes |
260 | print $ T.toList $ toTrie $ programStreams p | 258 | print $ Map.toList $ toTrie $ programStreams p |
261 | let lcStreamName = fmap name (toTrie $ programStreams p) | 259 | let lcStreamName = fmap name (toTrie $ programStreams p) |
262 | return $ GLProgram | 260 | return $ GLProgram |
263 | { shaderObjects = objs | 261 | { shaderObjects = objs |
264 | , programObject = po | 262 | , programObject = po |
265 | , inputUniforms = T.fromList inUniforms | 263 | , inputUniforms = Map.fromList inUniforms |
266 | , inputTextures = T.fromList inTextures | 264 | , inputTextures = Map.fromList inTextures |
267 | , inputTextureUniforms = S.fromList $ texUnis | 265 | , inputTextureUniforms = S.fromList $ texUnis |
268 | , inputStreams = T.fromList [(n,(idx, pack attrName)) | (n,idx) <- T.toList $ attributes, let Just attrName = T.lookup n lcStreamName] | 266 | , inputStreams = Map.fromList [(n,(idx, pack attrName)) | (n,idx) <- Map.toList $ attributes, let Just attrName = Map.lookup n lcStreamName] |
269 | } | 267 | } |
270 | 268 | ||
271 | compileSampler :: SamplerDescriptor -> IO GLSampler | 269 | compileSampler :: SamplerDescriptor -> IO GLSampler |
@@ -415,32 +413,32 @@ compileStreamData s = do | |||
415 | , glStreamProgram = V.head $ streamPrograms s | 413 | , glStreamProgram = V.head $ streamPrograms s |
416 | } | 414 | } |
417 | 415 | ||
418 | createStreamCommands :: Trie (IORef GLint) -> Trie GLUniform -> Trie (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand] | 416 | createStreamCommands :: Map ByteString (IORef GLint) -> Map ByteString GLUniform -> Map ByteString (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand] |
419 | createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ streamCmds ++ [drawCmd] | 417 | createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ streamCmds ++ [drawCmd] |
420 | where | 418 | where |
421 | -- object draw command | 419 | -- object draw command |
422 | drawCmd = GLDrawArrays prim 0 (fromIntegral count) | 420 | drawCmd = GLDrawArrays prim 0 (fromIntegral count) |
423 | where | 421 | where |
424 | prim = primitiveToGLType primitive | 422 | prim = primitiveToGLType primitive |
425 | count = head [c | Stream _ _ _ _ c <- T.elems attrs] | 423 | count = head [c | Stream _ _ _ _ c <- Map.elems attrs] |
426 | 424 | ||
427 | -- object uniform commands | 425 | -- object uniform commands |
428 | -- texture slot setup commands | 426 | -- texture slot setup commands |
429 | streamUniCmds = uniCmds ++ texCmds | 427 | streamUniCmds = uniCmds ++ texCmds |
430 | where | 428 | where |
431 | uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = topUni n] | 429 | uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = topUni n] |
432 | uniMap = T.toList $ inputUniforms prg | 430 | uniMap = Map.toList $ inputUniforms prg |
433 | topUni n = T.lookupWithDefault (error "internal error (createStreamCommands)!") n topUnis | 431 | topUni n = Map.findWithDefault (error "internal error (createStreamCommands)!") n topUnis |
434 | texUnis = S.toList $ inputTextureUniforms prg | 432 | texUnis = S.toList $ inputTextureUniforms prg |
435 | texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u | 433 | texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u |
436 | | n <- texUnis | 434 | | n <- texUnis |
437 | , let u = topUni n | 435 | , let u = topUni n |
438 | , let texUnit = T.lookupWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap | 436 | , let texUnit = Map.findWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap |
439 | ] | 437 | ] |
440 | uniInputType (GLUniform ty _) = ty | 438 | uniInputType (GLUniform ty _) = ty |
441 | 439 | ||
442 | -- object attribute stream commands | 440 | -- object attribute stream commands |
443 | streamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name attrs] | 441 | streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let Just s = Map.lookup name attrs] |
444 | where | 442 | where |
445 | attrMap = inputStreams prg | 443 | attrMap = inputStreams prg |
446 | attrCmd i s = case s of | 444 | attrCmd i s = case s of |
@@ -485,7 +483,7 @@ allocRenderer p = do | |||
485 | prgs <- V.mapM (compileProgram uniTrie) $ programs p | 483 | prgs <- V.mapM (compileProgram uniTrie) $ programs p |
486 | -- texture unit mapping ioref trie | 484 | -- texture unit mapping ioref trie |
487 | -- texUnitMapRefs :: Map UniformName (IORef TextureUnit) | 485 | -- texUnitMapRefs :: Map UniformName (IORef TextureUnit) |
488 | texUnitMapRefs <- T.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (T.keys . toTrie . programInTextures) $ programs p) | 486 | texUnitMapRefs <- Map.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (Map.keys . toTrie . programInTextures) $ programs p) |
489 | let (cmds,st) = runState (mapM (compileCommand texUnitMapRefs smps texs trgs prgs) $ V.toList $ commands p) initCGState | 487 | let (cmds,st) = runState (mapM (compileCommand texUnitMapRefs smps texs trgs prgs) $ V.toList $ commands p) initCGState |
490 | input <- newIORef Nothing | 488 | input <- newIORef Nothing |
491 | -- default Vertex Array Object | 489 | -- default Vertex Array Object |
@@ -518,8 +516,8 @@ disposeRenderer p = do | |||
518 | with (glVAO p) $ (glDeleteVertexArrays 1) | 516 | with (glVAO p) $ (glDeleteVertexArrays 1) |
519 | 517 | ||
520 | {- | 518 | {- |
521 | data SlotSchema | 519 | data ObjectArraySchema |
522 | = SlotSchema | 520 | = ObjectArraySchema |
523 | { primitive :: FetchPrimitive | 521 | { primitive :: FetchPrimitive |
524 | , attributes :: Trie StreamType | 522 | , attributes :: Trie StreamType |
525 | } | 523 | } |
@@ -527,13 +525,13 @@ data SlotSchema | |||
527 | 525 | ||
528 | data PipelineSchema | 526 | data PipelineSchema |
529 | = PipelineSchema | 527 | = PipelineSchema |
530 | { slots :: Trie SlotSchema | 528 | { objectArrays :: Trie ObjectArraySchema |
531 | , uniforms :: Trie InputType | 529 | , uniforms :: Trie InputType |
532 | } | 530 | } |
533 | deriving Show | 531 | deriving Show |
534 | -} | 532 | -} |
535 | isSubTrie :: (a -> a -> Bool) -> Trie a -> Trie a -> Bool | 533 | isSubTrie :: (a -> a -> Bool) -> Map ByteString a -> Map ByteString a -> Bool |
536 | isSubTrie eqFun universe subset = and [isMember a (T.lookup n universe) | (n,a) <- T.toList subset] | 534 | isSubTrie eqFun universe subset = and [isMember a (Map.lookup n universe) | (n,a) <- Map.toList subset] |
537 | where | 535 | where |
538 | isMember a Nothing = False | 536 | isMember a Nothing = False |
539 | isMember a (Just b) = eqFun a b | 537 | isMember a (Just b) = eqFun a b |
@@ -541,12 +539,12 @@ isSubTrie eqFun universe subset = and [isMember a (T.lookup n universe) | (n,a) | |||
541 | -- TODO: if there is a mismatch thow detailed error message in the excoeption, containing the missing attributes and uniforms | 539 | -- TODO: if there is a mismatch thow detailed error message in the excoeption, containing the missing attributes and uniforms |
542 | {- | 540 | {- |
543 | let sch = schema input | 541 | let sch = schema input |
544 | forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of | 542 | forM_ uniformNames $ \n -> case Map.lookup n (uniforms sch) of |
545 | Nothing -> throw $ userError $ "Unknown uniform: " ++ show n | 543 | Nothing -> throw $ userError $ "Unknown uniform: " ++ show n |
546 | _ -> return () | 544 | _ -> return () |
547 | case T.lookup slotName (slots sch) of | 545 | case Map.lookup slotName (objectArrays sch) of |
548 | Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName | 546 | Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName |
549 | Just (SlotSchema sPrim sAttrs) -> do | 547 | Just (ObjectArraySchema sPrim sAttrs) -> do |
550 | when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $ | 548 | when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $ |
551 | "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim | 549 | "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim |
552 | let sType = fmap streamToStreamType attribs | 550 | let sType = fmap streamToStreamType attribs |
@@ -571,7 +569,7 @@ setStorage' p input' = do | |||
571 | -} | 569 | -} |
572 | {- | 570 | {- |
573 | deletion: | 571 | deletion: |
574 | - remove pipeline's object commands from used slots | 572 | - remove pipeline's object commands from used objectArrays |
575 | - remove pipeline from attached pipelines vector | 573 | - remove pipeline from attached pipelines vector |
576 | -} | 574 | -} |
577 | ic' <- readIORef $ glInput p | 575 | ic' <- readIORef $ glInput p |
@@ -592,7 +590,7 @@ setStorage' p input' = do | |||
592 | - get an id from pipeline input | 590 | - get an id from pipeline input |
593 | - add to attached pipelines | 591 | - add to attached pipelines |
594 | - generate slot mappings | 592 | - generate slot mappings |
595 | - update used slots, and generate object commands for objects in the related slots | 593 | - update used objectArrays, and generate object commands for objects in the related objectArrays |
596 | -} | 594 | -} |
597 | case input' of | 595 | case input' of |
598 | Nothing -> writeIORef (glInput p) Nothing >> return Nothing | 596 | Nothing -> writeIORef (glInput p) Nothing >> return Nothing |
@@ -610,11 +608,11 @@ setStorage' p input' = do | |||
610 | return (i,Nothing) | 608 | return (i,Nothing) |
611 | -- create input connection | 609 | -- create input connection |
612 | let sm = slotMap input | 610 | let sm = slotMap input |
613 | pToI = [i | n <- glSlotNames p, let Just i = T.lookup n sm] | 611 | pToI = [i | n <- glSlotNames p, let Just i = Map.lookup n sm] |
614 | iToP = V.update (V.replicate (T.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI) | 612 | iToP = V.update (V.replicate (Map.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI) |
615 | writeIORef (glInput p) $ Just $ InputConnection idx input pToI iToP | 613 | writeIORef (glInput p) $ Just $ InputConnection idx input pToI iToP |
616 | 614 | ||
617 | -- generate object commands for related slots | 615 | -- generate object commands for related objectArrays |
618 | {- | 616 | {- |
619 | for each slot in pipeline: | 617 | for each slot in pipeline: |
620 | map slot name to input slot name | 618 | map slot name to input slot name |
@@ -771,7 +769,7 @@ initCGState = CGState | |||
771 | 769 | ||
772 | type CG a = State CGState a | 770 | type CG a = State CGState a |
773 | 771 | ||
774 | compileCommand :: Trie (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG GLCommand | 772 | compileCommand :: Map ByteString (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG GLCommand |
775 | compileCommand texUnitMap samplers textures targets programs cmd = case cmd of | 773 | compileCommand texUnitMap samplers textures targets programs cmd = case cmd of |
776 | SetRasterContext rCtx -> return $ GLSetRasterContext rCtx | 774 | SetRasterContext rCtx -> return $ GLSetRasterContext rCtx |
777 | SetAccumulationContext aCtx -> return $ GLSetAccumulationContext aCtx | 775 | SetAccumulationContext aCtx -> return $ GLSetAccumulationContext aCtx |
@@ -782,9 +780,9 @@ compileCommand texUnitMap samplers textures targets programs cmd = case cmd of | |||
782 | SetSamplerUniform n tu -> do | 780 | SetSamplerUniform n tu -> do |
783 | modify (\s@CGState{..} -> s {samplerUniforms = Map.insert n tu samplerUniforms}) | 781 | modify (\s@CGState{..} -> s {samplerUniforms = Map.insert n tu samplerUniforms}) |
784 | p <- currentProgram <$> get | 782 | p <- currentProgram <$> get |
785 | case T.lookup (pack n) (inputTextures $ programs ! p) of | 783 | case Map.lookup (pack n) (inputTextures $ programs ! p) of |
786 | Nothing -> fail $ "internal error (SetSamplerUniform)! - " ++ show cmd | 784 | Nothing -> fail $ "internal error (SetSamplerUniform)! - " ++ show cmd |
787 | Just i -> case T.lookup (pack n) texUnitMap of | 785 | Just i -> case Map.lookup (pack n) texUnitMap of |
788 | Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd | 786 | Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd |
789 | Just r -> return $ GLSetSamplerUniform i (fromIntegral tu) r | 787 | Just r -> return $ GLSetSamplerUniform i (fromIntegral tu) r |
790 | SetTexture tu t -> do | 788 | SetTexture tu t -> do |
diff --git a/src/LambdaCube/GL/Data.hs b/src/LambdaCube/GL/Data.hs index 231da8b..21142f5 100644 --- a/src/LambdaCube/GL/Data.hs +++ b/src/LambdaCube/GL/Data.hs | |||
@@ -6,7 +6,6 @@ import Data.ByteString.Char8 (ByteString) | |||
6 | import Data.IORef | 6 | import Data.IORef |
7 | import Data.List as L | 7 | import Data.List as L |
8 | import Data.Maybe | 8 | import Data.Maybe |
9 | import Data.Trie as T | ||
10 | import Foreign | 9 | import Foreign |
11 | --import qualified Data.IntMap as IM | 10 | --import qualified Data.IntMap as IM |
12 | import qualified Data.Map as Map | 11 | import qualified Data.Map as Map |
diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs index aabf0e6..88b2654 100644 --- a/src/LambdaCube/GL/Input.hs +++ b/src/LambdaCube/GL/Input.hs | |||
@@ -5,9 +5,8 @@ import Control.Exception | |||
5 | import Control.Monad | 5 | import Control.Monad |
6 | import Data.ByteString.Char8 (ByteString,pack) | 6 | import Data.ByteString.Char8 (ByteString,pack) |
7 | import Data.IORef | 7 | import Data.IORef |
8 | import Data.Map (Map) | ||
8 | import Data.IntMap (IntMap) | 9 | import Data.IntMap (IntMap) |
9 | import Data.Trie (Trie) | ||
10 | import Data.Trie.Convenience as T | ||
11 | import Data.Vector (Vector,(//),(!)) | 10 | import Data.Vector (Vector,(//),(!)) |
12 | import Data.Word | 11 | import Data.Word |
13 | import Foreign | 12 | import Foreign |
@@ -15,7 +14,6 @@ import qualified Data.ByteString.Char8 as SB | |||
15 | import qualified Data.IntMap as IM | 14 | import qualified Data.IntMap as IM |
16 | import qualified Data.Set as S | 15 | import qualified Data.Set as S |
17 | import qualified Data.Map as Map | 16 | import qualified Data.Map as Map |
18 | import qualified Data.Trie as T | ||
19 | import qualified Data.Vector as V | 17 | import qualified Data.Vector as V |
20 | import qualified Data.Vector.Algorithms.Intro as I | 18 | import qualified Data.Vector.Algorithms.Intro as I |
21 | 19 | ||
@@ -29,9 +27,9 @@ import LambdaCube.GL.Util | |||
29 | import qualified IR as IR | 27 | import qualified IR as IR |
30 | 28 | ||
31 | schemaFromPipeline :: IR.Pipeline -> PipelineSchema | 29 | schemaFromPipeline :: IR.Pipeline -> PipelineSchema |
32 | schemaFromPipeline a = PipelineSchema (T.fromList sl) (foldl T.unionL T.empty ul) | 30 | schemaFromPipeline a = PipelineSchema (Map.fromList sl) (foldl Map.union Map.empty ul) |
33 | where | 31 | where |
34 | (sl,ul) = unzip [( (pack sName,SlotSchema sPrimitive (fmap cvt (toTrie sStreams))) | 32 | (sl,ul) = unzip [( (pack sName,ObjectArraySchema sPrimitive (fmap cvt (toTrie sStreams))) |
35 | , toTrie sUniforms | 33 | , toTrie sUniforms |
36 | ) | 34 | ) |
37 | | IR.Slot sName sStreams sUniforms sPrimitive _ <- V.toList $ IR.slots a | 35 | | IR.Slot sName sStreams sUniforms sPrimitive _ <- V.toList $ IR.slots a |
@@ -40,19 +38,19 @@ schemaFromPipeline a = PipelineSchema (T.fromList sl) (foldl T.unionL T.empty ul | |||
40 | Just v -> v | 38 | Just v -> v |
41 | Nothing -> error "internal error (schemaFromPipeline)" | 39 | Nothing -> error "internal error (schemaFromPipeline)" |
42 | 40 | ||
43 | mkUniform :: [(ByteString,InputType)] -> IO (Trie InputSetter, Trie GLUniform) | 41 | mkUniform :: [(ByteString,InputType)] -> IO (Map ByteString InputSetter, Map ByteString GLUniform) |
44 | mkUniform l = do | 42 | mkUniform l = do |
45 | unisAndSetters <- forM l $ \(n,t) -> do | 43 | unisAndSetters <- forM l $ \(n,t) -> do |
46 | (uni, setter) <- mkUniformSetter t | 44 | (uni, setter) <- mkUniformSetter t |
47 | return ((n,uni),(n,setter)) | 45 | return ((n,uni),(n,setter)) |
48 | let (unis,setters) = unzip unisAndSetters | 46 | let (unis,setters) = unzip unisAndSetters |
49 | return (T.fromList setters, T.fromList unis) | 47 | return (Map.fromList setters, Map.fromList unis) |
50 | 48 | ||
51 | allocStorage :: PipelineSchema -> IO GLStorage | 49 | allocStorage :: PipelineSchema -> IO GLStorage |
52 | allocStorage sch = do | 50 | allocStorage sch = do |
53 | let sm = T.fromList $ zip (T.keys $ T.slots sch) [0..] | 51 | let sm = Map.fromList $ zip (Map.keys $ objectArrays sch) [0..] |
54 | len = T.size sm | 52 | len = Map.size sm |
55 | (setters,unis) <- mkUniform $ T.toList $ uniforms sch | 53 | (setters,unis) <- mkUniform $ Map.toList $ uniforms sch |
56 | seed <- newIORef 0 | 54 | seed <- newIORef 0 |
57 | slotV <- V.replicateM len $ newIORef (GLSlot IM.empty V.empty Ordered) | 55 | slotV <- V.replicateM len $ newIORef (GLSlot IM.empty V.empty Ordered) |
58 | size <- newIORef (0,0) | 56 | size <- newIORef (0,0) |
@@ -72,15 +70,15 @@ disposeStorage :: GLStorage -> IO () | |||
72 | disposeStorage = error "not implemented: disposeStorage" | 70 | disposeStorage = error "not implemented: disposeStorage" |
73 | 71 | ||
74 | -- object | 72 | -- object |
75 | addObject :: GLStorage -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object | 73 | addObject :: GLStorage -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Map ByteString (Stream Buffer) -> [ByteString] -> IO Object |
76 | addObject input slotName prim indices attribs uniformNames = do | 74 | addObject input slotName prim indices attribs uniformNames = do |
77 | let sch = schema input | 75 | let sch = schema input |
78 | forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of | 76 | forM_ uniformNames $ \n -> case Map.lookup n (uniforms sch) of |
79 | Nothing -> throw $ userError $ "Unknown uniform: " ++ show n | 77 | Nothing -> throw $ userError $ "Unknown uniform: " ++ show n |
80 | _ -> return () | 78 | _ -> return () |
81 | case T.lookup slotName (T.slots sch) of | 79 | case Map.lookup slotName (objectArrays sch) of |
82 | Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName | 80 | Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName |
83 | Just (SlotSchema sPrim sAttrs) -> do | 81 | Just (ObjectArraySchema sPrim sAttrs) -> do |
84 | when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $ | 82 | when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $ |
85 | "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim | 83 | "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim |
86 | let sType = fmap streamToStreamType attribs | 84 | let sType = fmap streamToStreamType attribs |
@@ -91,7 +89,7 @@ addObject input slotName prim indices attribs uniformNames = do | |||
91 | , show sType | 89 | , show sType |
92 | ] | 90 | ] |
93 | 91 | ||
94 | let slotIdx = case slotName `T.lookup` slotMap input of | 92 | let slotIdx = case slotName `Map.lookup` slotMap input of |
95 | Nothing -> error $ "internal error (slot index): " ++ show slotName | 93 | Nothing -> error $ "internal error (slot index): " ++ show slotName |
96 | Just i -> i | 94 | Just i -> i |
97 | seed = objSeed input | 95 | seed = objSeed input |
@@ -99,7 +97,7 @@ addObject input slotName prim indices attribs uniformNames = do | |||
99 | enabled <- newIORef True | 97 | enabled <- newIORef True |
100 | index <- readIORef seed | 98 | index <- readIORef seed |
101 | modifyIORef seed (1+) | 99 | modifyIORef seed (1+) |
102 | (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let Just t = T.lookup n (uniforms sch)] | 100 | (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let Just t = Map.lookup n (uniforms sch)] |
103 | cmdsRef <- newIORef (V.singleton V.empty) | 101 | cmdsRef <- newIORef (V.singleton V.empty) |
104 | let obj = Object | 102 | let obj = Object |
105 | { objSlot = slotIdx | 103 | { objSlot = slotIdx |
@@ -151,7 +149,7 @@ setObjectOrder p obj i = do | |||
151 | writeIORef (objOrder obj) i | 149 | writeIORef (objOrder obj) i |
152 | modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder | 150 | modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder |
153 | 151 | ||
154 | objectUniformSetter :: Object -> Trie InputSetter | 152 | objectUniformSetter :: Object -> Map ByteString InputSetter |
155 | objectUniformSetter = objUniSetter | 153 | objectUniformSetter = objUniSetter |
156 | 154 | ||
157 | setScreenSize :: GLStorage -> Word -> Word -> IO () | 155 | setScreenSize :: GLStorage -> Word -> Word -> IO () |
@@ -179,7 +177,7 @@ sortSlotObjects p = V.forM_ (slotVector p) $ \slotRef -> do | |||
179 | return (ord,obj) | 177 | return (ord,obj) |
180 | doSort objs | 178 | doSort objs |
181 | 179 | ||
182 | createObjectCommands :: Trie (IORef GLint) -> Trie GLUniform -> Object -> GLProgram -> [GLObjectCommand] | 180 | createObjectCommands :: Map ByteString (IORef GLint) -> Map ByteString GLUniform -> Object -> GLProgram -> [GLObjectCommand] |
183 | createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++ [objDrawCmd] | 181 | createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++ [objDrawCmd] |
184 | where | 182 | where |
185 | -- object draw command | 183 | -- object draw command |
@@ -193,26 +191,26 @@ createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++ | |||
193 | where | 191 | where |
194 | objAttrs = objAttributes obj | 192 | objAttrs = objAttributes obj |
195 | prim = primitiveToGLType $ objPrimitive obj | 193 | prim = primitiveToGLType $ objPrimitive obj |
196 | count = head [c | Stream _ _ _ _ c <- T.elems objAttrs] | 194 | count = head [c | Stream _ _ _ _ c <- Map.elems objAttrs] |
197 | 195 | ||
198 | -- object uniform commands | 196 | -- object uniform commands |
199 | -- texture slot setup commands | 197 | -- texture slot setup commands |
200 | objUniCmds = uniCmds ++ texCmds | 198 | objUniCmds = uniCmds ++ texCmds |
201 | where | 199 | where |
202 | uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = T.lookupWithDefault (topUni n) n objUnis] | 200 | uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = Map.findWithDefault (topUni n) n objUnis] |
203 | uniMap = T.toList $ inputUniforms prg | 201 | uniMap = Map.toList $ inputUniforms prg |
204 | topUni n = T.lookupWithDefault (error $ "internal error (createObjectCommands): " ++ show n) n topUnis | 202 | topUni n = Map.findWithDefault (error $ "internal error (createObjectCommands): " ++ show n) n topUnis |
205 | objUnis = objUniSetup obj | 203 | objUnis = objUniSetup obj |
206 | texUnis = S.toList $ inputTextureUniforms prg | 204 | texUnis = S.toList $ inputTextureUniforms prg |
207 | texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u | 205 | texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u |
208 | | n <- texUnis | 206 | | n <- texUnis |
209 | , let u = T.lookupWithDefault (topUni n) n objUnis | 207 | , let u = Map.findWithDefault (topUni n) n objUnis |
210 | , let texUnit = T.lookupWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap | 208 | , let texUnit = Map.findWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap |
211 | ] | 209 | ] |
212 | uniInputType (GLUniform ty _) = ty | 210 | uniInputType (GLUniform ty _) = ty |
213 | 211 | ||
214 | -- object attribute stream commands | 212 | -- object attribute stream commands |
215 | objStreamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name objAttrs] | 213 | objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let Just s = Map.lookup name objAttrs] |
216 | where | 214 | where |
217 | attrMap = inputStreams prg | 215 | attrMap = inputStreams prg |
218 | objAttrs = objAttributes obj | 216 | objAttrs = objAttributes obj |
@@ -253,138 +251,138 @@ nullSetter :: ByteString -> String -> a -> IO () | |||
253 | --nullSetter n t _ = return () -- Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t | 251 | --nullSetter n t _ = return () -- Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t |
254 | nullSetter n t _ = Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t | 252 | nullSetter n t _ = Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t |
255 | 253 | ||
256 | uniformBool :: ByteString -> Trie InputSetter -> SetterFun Bool | 254 | uniformBool :: ByteString -> Map ByteString InputSetter -> SetterFun Bool |
257 | uniformV2B :: ByteString -> Trie InputSetter -> SetterFun V2B | 255 | uniformV2B :: ByteString -> Map ByteString InputSetter -> SetterFun V2B |
258 | uniformV3B :: ByteString -> Trie InputSetter -> SetterFun V3B | 256 | uniformV3B :: ByteString -> Map ByteString InputSetter -> SetterFun V3B |
259 | uniformV4B :: ByteString -> Trie InputSetter -> SetterFun V4B | 257 | uniformV4B :: ByteString -> Map ByteString InputSetter -> SetterFun V4B |
260 | 258 | ||
261 | uniformWord :: ByteString -> Trie InputSetter -> SetterFun Word32 | 259 | uniformWord :: ByteString -> Map ByteString InputSetter -> SetterFun Word32 |
262 | uniformV2U :: ByteString -> Trie InputSetter -> SetterFun V2U | 260 | uniformV2U :: ByteString -> Map ByteString InputSetter -> SetterFun V2U |
263 | uniformV3U :: ByteString -> Trie InputSetter -> SetterFun V3U | 261 | uniformV3U :: ByteString -> Map ByteString InputSetter -> SetterFun V3U |
264 | uniformV4U :: ByteString -> Trie InputSetter -> SetterFun V4U | 262 | uniformV4U :: ByteString -> Map ByteString InputSetter -> SetterFun V4U |
265 | 263 | ||
266 | uniformInt :: ByteString -> Trie InputSetter -> SetterFun Int32 | 264 | uniformInt :: ByteString -> Map ByteString InputSetter -> SetterFun Int32 |
267 | uniformV2I :: ByteString -> Trie InputSetter -> SetterFun V2I | 265 | uniformV2I :: ByteString -> Map ByteString InputSetter -> SetterFun V2I |
268 | uniformV3I :: ByteString -> Trie InputSetter -> SetterFun V3I | 266 | uniformV3I :: ByteString -> Map ByteString InputSetter -> SetterFun V3I |
269 | uniformV4I :: ByteString -> Trie InputSetter -> SetterFun V4I | 267 | uniformV4I :: ByteString -> Map ByteString InputSetter -> SetterFun V4I |
270 | 268 | ||
271 | uniformFloat :: ByteString -> Trie InputSetter -> SetterFun Float | 269 | uniformFloat :: ByteString -> Map ByteString InputSetter -> SetterFun Float |
272 | uniformV2F :: ByteString -> Trie InputSetter -> SetterFun V2F | 270 | uniformV2F :: ByteString -> Map ByteString InputSetter -> SetterFun V2F |
273 | uniformV3F :: ByteString -> Trie InputSetter -> SetterFun V3F | 271 | uniformV3F :: ByteString -> Map ByteString InputSetter -> SetterFun V3F |
274 | uniformV4F :: ByteString -> Trie InputSetter -> SetterFun V4F | 272 | uniformV4F :: ByteString -> Map ByteString InputSetter -> SetterFun V4F |
275 | 273 | ||
276 | uniformM22F :: ByteString -> Trie InputSetter -> SetterFun M22F | 274 | uniformM22F :: ByteString -> Map ByteString InputSetter -> SetterFun M22F |
277 | uniformM23F :: ByteString -> Trie InputSetter -> SetterFun M23F | 275 | uniformM23F :: ByteString -> Map ByteString InputSetter -> SetterFun M23F |
278 | uniformM24F :: ByteString -> Trie InputSetter -> SetterFun M24F | 276 | uniformM24F :: ByteString -> Map ByteString InputSetter -> SetterFun M24F |
279 | uniformM32F :: ByteString -> Trie InputSetter -> SetterFun M32F | 277 | uniformM32F :: ByteString -> Map ByteString InputSetter -> SetterFun M32F |
280 | uniformM33F :: ByteString -> Trie InputSetter -> SetterFun M33F | 278 | uniformM33F :: ByteString -> Map ByteString InputSetter -> SetterFun M33F |
281 | uniformM34F :: ByteString -> Trie InputSetter -> SetterFun M34F | 279 | uniformM34F :: ByteString -> Map ByteString InputSetter -> SetterFun M34F |
282 | uniformM42F :: ByteString -> Trie InputSetter -> SetterFun M42F | 280 | uniformM42F :: ByteString -> Map ByteString InputSetter -> SetterFun M42F |
283 | uniformM43F :: ByteString -> Trie InputSetter -> SetterFun M43F | 281 | uniformM43F :: ByteString -> Map ByteString InputSetter -> SetterFun M43F |
284 | uniformM44F :: ByteString -> Trie InputSetter -> SetterFun M44F | 282 | uniformM44F :: ByteString -> Map ByteString InputSetter -> SetterFun M44F |
285 | 283 | ||
286 | uniformFTexture2D :: ByteString -> Trie InputSetter -> SetterFun TextureData | 284 | uniformFTexture2D :: ByteString -> Map ByteString InputSetter -> SetterFun TextureData |
287 | 285 | ||
288 | uniformBool n is = case T.lookup n is of | 286 | uniformBool n is = case Map.lookup n is of |
289 | Just (SBool fun) -> fun | 287 | Just (SBool fun) -> fun |
290 | _ -> nullSetter n "Bool" | 288 | _ -> nullSetter n "Bool" |
291 | 289 | ||
292 | uniformV2B n is = case T.lookup n is of | 290 | uniformV2B n is = case Map.lookup n is of |
293 | Just (SV2B fun) -> fun | 291 | Just (SV2B fun) -> fun |
294 | _ -> nullSetter n "V2B" | 292 | _ -> nullSetter n "V2B" |
295 | 293 | ||
296 | uniformV3B n is = case T.lookup n is of | 294 | uniformV3B n is = case Map.lookup n is of |
297 | Just (SV3B fun) -> fun | 295 | Just (SV3B fun) -> fun |
298 | _ -> nullSetter n "V3B" | 296 | _ -> nullSetter n "V3B" |
299 | 297 | ||
300 | uniformV4B n is = case T.lookup n is of | 298 | uniformV4B n is = case Map.lookup n is of |
301 | Just (SV4B fun) -> fun | 299 | Just (SV4B fun) -> fun |
302 | _ -> nullSetter n "V4B" | 300 | _ -> nullSetter n "V4B" |
303 | 301 | ||
304 | uniformWord n is = case T.lookup n is of | 302 | uniformWord n is = case Map.lookup n is of |
305 | Just (SWord fun) -> fun | 303 | Just (SWord fun) -> fun |
306 | _ -> nullSetter n "Word" | 304 | _ -> nullSetter n "Word" |
307 | 305 | ||
308 | uniformV2U n is = case T.lookup n is of | 306 | uniformV2U n is = case Map.lookup n is of |
309 | Just (SV2U fun) -> fun | 307 | Just (SV2U fun) -> fun |
310 | _ -> nullSetter n "V2U" | 308 | _ -> nullSetter n "V2U" |
311 | 309 | ||
312 | uniformV3U n is = case T.lookup n is of | 310 | uniformV3U n is = case Map.lookup n is of |
313 | Just (SV3U fun) -> fun | 311 | Just (SV3U fun) -> fun |
314 | _ -> nullSetter n "V3U" | 312 | _ -> nullSetter n "V3U" |
315 | 313 | ||
316 | uniformV4U n is = case T.lookup n is of | 314 | uniformV4U n is = case Map.lookup n is of |
317 | Just (SV4U fun) -> fun | 315 | Just (SV4U fun) -> fun |
318 | _ -> nullSetter n "V4U" | 316 | _ -> nullSetter n "V4U" |
319 | 317 | ||
320 | uniformInt n is = case T.lookup n is of | 318 | uniformInt n is = case Map.lookup n is of |
321 | Just (SInt fun) -> fun | 319 | Just (SInt fun) -> fun |
322 | _ -> nullSetter n "Int" | 320 | _ -> nullSetter n "Int" |
323 | 321 | ||
324 | uniformV2I n is = case T.lookup n is of | 322 | uniformV2I n is = case Map.lookup n is of |
325 | Just (SV2I fun) -> fun | 323 | Just (SV2I fun) -> fun |
326 | _ -> nullSetter n "V2I" | 324 | _ -> nullSetter n "V2I" |
327 | 325 | ||
328 | uniformV3I n is = case T.lookup n is of | 326 | uniformV3I n is = case Map.lookup n is of |
329 | Just (SV3I fun) -> fun | 327 | Just (SV3I fun) -> fun |
330 | _ -> nullSetter n "V3I" | 328 | _ -> nullSetter n "V3I" |
331 | 329 | ||
332 | uniformV4I n is = case T.lookup n is of | 330 | uniformV4I n is = case Map.lookup n is of |
333 | Just (SV4I fun) -> fun | 331 | Just (SV4I fun) -> fun |
334 | _ -> nullSetter n "V4I" | 332 | _ -> nullSetter n "V4I" |
335 | 333 | ||
336 | uniformFloat n is = case T.lookup n is of | 334 | uniformFloat n is = case Map.lookup n is of |
337 | Just (SFloat fun) -> fun | 335 | Just (SFloat fun) -> fun |
338 | _ -> nullSetter n "Float" | 336 | _ -> nullSetter n "Float" |
339 | 337 | ||
340 | uniformV2F n is = case T.lookup n is of | 338 | uniformV2F n is = case Map.lookup n is of |
341 | Just (SV2F fun) -> fun | 339 | Just (SV2F fun) -> fun |
342 | _ -> nullSetter n "V2F" | 340 | _ -> nullSetter n "V2F" |
343 | 341 | ||
344 | uniformV3F n is = case T.lookup n is of | 342 | uniformV3F n is = case Map.lookup n is of |
345 | Just (SV3F fun) -> fun | 343 | Just (SV3F fun) -> fun |
346 | _ -> nullSetter n "V3F" | 344 | _ -> nullSetter n "V3F" |
347 | 345 | ||
348 | uniformV4F n is = case T.lookup n is of | 346 | uniformV4F n is = case Map.lookup n is of |
349 | Just (SV4F fun) -> fun | 347 | Just (SV4F fun) -> fun |
350 | _ -> nullSetter n "V4F" | 348 | _ -> nullSetter n "V4F" |
351 | 349 | ||
352 | uniformM22F n is = case T.lookup n is of | 350 | uniformM22F n is = case Map.lookup n is of |
353 | Just (SM22F fun) -> fun | 351 | Just (SM22F fun) -> fun |
354 | _ -> nullSetter n "M22F" | 352 | _ -> nullSetter n "M22F" |
355 | 353 | ||
356 | uniformM23F n is = case T.lookup n is of | 354 | uniformM23F n is = case Map.lookup n is of |
357 | Just (SM23F fun) -> fun | 355 | Just (SM23F fun) -> fun |
358 | _ -> nullSetter n "M23F" | 356 | _ -> nullSetter n "M23F" |
359 | 357 | ||
360 | uniformM24F n is = case T.lookup n is of | 358 | uniformM24F n is = case Map.lookup n is of |
361 | Just (SM24F fun) -> fun | 359 | Just (SM24F fun) -> fun |
362 | _ -> nullSetter n "M24F" | 360 | _ -> nullSetter n "M24F" |
363 | 361 | ||
364 | uniformM32F n is = case T.lookup n is of | 362 | uniformM32F n is = case Map.lookup n is of |
365 | Just (SM32F fun) -> fun | 363 | Just (SM32F fun) -> fun |
366 | _ -> nullSetter n "M32F" | 364 | _ -> nullSetter n "M32F" |
367 | 365 | ||
368 | uniformM33F n is = case T.lookup n is of | 366 | uniformM33F n is = case Map.lookup n is of |
369 | Just (SM33F fun) -> fun | 367 | Just (SM33F fun) -> fun |
370 | _ -> nullSetter n "M33F" | 368 | _ -> nullSetter n "M33F" |
371 | 369 | ||
372 | uniformM34F n is = case T.lookup n is of | 370 | uniformM34F n is = case Map.lookup n is of |
373 | Just (SM34F fun) -> fun | 371 | Just (SM34F fun) -> fun |
374 | _ -> nullSetter n "M34F" | 372 | _ -> nullSetter n "M34F" |
375 | 373 | ||
376 | uniformM42F n is = case T.lookup n is of | 374 | uniformM42F n is = case Map.lookup n is of |
377 | Just (SM42F fun) -> fun | 375 | Just (SM42F fun) -> fun |
378 | _ -> nullSetter n "M42F" | 376 | _ -> nullSetter n "M42F" |
379 | 377 | ||
380 | uniformM43F n is = case T.lookup n is of | 378 | uniformM43F n is = case Map.lookup n is of |
381 | Just (SM43F fun) -> fun | 379 | Just (SM43F fun) -> fun |
382 | _ -> nullSetter n "M43F" | 380 | _ -> nullSetter n "M43F" |
383 | 381 | ||
384 | uniformM44F n is = case T.lookup n is of | 382 | uniformM44F n is = case Map.lookup n is of |
385 | Just (SM44F fun) -> fun | 383 | Just (SM44F fun) -> fun |
386 | _ -> nullSetter n "M44F" | 384 | _ -> nullSetter n "M44F" |
387 | 385 | ||
388 | uniformFTexture2D n is = case T.lookup n is of | 386 | uniformFTexture2D n is = case Map.lookup n is of |
389 | Just (SFTexture2D fun) -> fun | 387 | Just (SFTexture2D fun) -> fun |
390 | _ -> nullSetter n "FTexture2D" | 388 | _ -> nullSetter n "FTexture2D" |
diff --git a/src/LambdaCube/GL/Mesh.hs b/src/LambdaCube/GL/Mesh.hs index f8a0bb9..553e2e8 100644 --- a/src/LambdaCube/GL/Mesh.hs +++ b/src/LambdaCube/GL/Mesh.hs | |||
@@ -21,9 +21,10 @@ import Data.Int | |||
21 | import Foreign.Storable | 21 | import Foreign.Storable |
22 | import Foreign.Marshal.Utils | 22 | import Foreign.Marshal.Utils |
23 | import System.IO.Unsafe | 23 | import System.IO.Unsafe |
24 | import Data.Map (Map) | ||
25 | import qualified Data.Map as Map | ||
24 | import qualified Data.ByteString.Char8 as SB | 26 | import qualified Data.ByteString.Char8 as SB |
25 | import qualified Data.ByteString.Lazy as LB | 27 | import qualified Data.ByteString.Lazy as LB |
26 | import qualified Data.Trie as T | ||
27 | import qualified Data.Vector.Storable as V | 28 | import qualified Data.Vector.Storable as V |
28 | import qualified Data.Vector.Storable.Mutable as MV | 29 | import qualified Data.Vector.Storable.Mutable as MV |
29 | 30 | ||
@@ -55,7 +56,7 @@ data MeshPrimitive | |||
55 | 56 | ||
56 | data Mesh | 57 | data Mesh |
57 | = Mesh | 58 | = Mesh |
58 | { mAttributes :: T.Trie MeshAttribute | 59 | { mAttributes :: Map ByteString MeshAttribute |
59 | , mPrimitive :: MeshPrimitive | 60 | , mPrimitive :: MeshPrimitive |
60 | , mGPUData :: Maybe GPUData | 61 | , mGPUData :: Maybe GPUData |
61 | } | 62 | } |
@@ -63,7 +64,7 @@ data Mesh | |||
63 | data GPUData | 64 | data GPUData |
64 | = GPUData | 65 | = GPUData |
65 | { dPrimitive :: Primitive | 66 | { dPrimitive :: Primitive |
66 | , dStreams :: T.Trie (Stream Buffer) | 67 | , dStreams :: Map ByteString (Stream Buffer) |
67 | , dIndices :: Maybe (IndexStream Buffer) | 68 | , dIndices :: Maybe (IndexStream Buffer) |
68 | } | 69 | } |
69 | 70 | ||
@@ -79,11 +80,9 @@ saveMesh n m = LB.writeFile n (encode m) | |||
79 | addMeshToObjectArray :: GLStorage -> ByteString -> [ByteString] -> Mesh -> IO Object | 80 | addMeshToObjectArray :: GLStorage -> ByteString -> [ByteString] -> Mesh -> IO Object |
80 | addMeshToObjectArray input slotName objUniNames (Mesh _ _ (Just (GPUData prim streams indices))) = do | 81 | addMeshToObjectArray input slotName objUniNames (Mesh _ _ (Just (GPUData prim streams indices))) = do |
81 | -- select proper attributes | 82 | -- select proper attributes |
82 | let Just (SlotSchema slotPrim slotStreams) = T.lookup slotName $! T.slots $! T.schema input | 83 | let Just (ObjectArraySchema slotPrim slotStreams) = Map.lookup slotName $! objectArrays $! schema input |
83 | filterStream n s | 84 | filterStream n _ = Map.member n slotStreams |
84 | | T.member n slotStreams = Just s | 85 | addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames |
85 | | otherwise = Nothing | ||
86 | addObject input slotName prim indices (T.mapBy filterStream streams) objUniNames | ||
87 | addMeshToObjectArray _ _ _ _ = fail "addMeshToObjectArray: only compiled mesh with GPUData is supported" | 86 | addMeshToObjectArray _ _ _ _ = fail "addMeshToObjectArray: only compiled mesh with GPUData is supported" |
88 | 87 | ||
89 | withV w a f = w a (\p -> f $ castPtr p) | 88 | withV w a f = w a (\p -> f $ castPtr p) |
@@ -114,11 +113,11 @@ updateMesh :: Mesh -> [(ByteString,MeshAttribute)] -> Maybe MeshPrimitive -> IO | |||
114 | updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do | 113 | updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do |
115 | -- check type match | 114 | -- check type match |
116 | let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 | 115 | let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 |
117 | ok = and [T.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = T.lookup n dMA] | 116 | ok = and [Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = Map.lookup n dMA] |
118 | if not ok then putStrLn "updateMesh: attribute mismatch!" | 117 | if not ok then putStrLn "updateMesh: attribute mismatch!" |
119 | else do | 118 | else do |
120 | forM_ al $ \(n,a) -> do | 119 | forM_ al $ \(n,a) -> do |
121 | case T.lookup n dS of | 120 | case Map.lookup n dS of |
122 | Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)] | 121 | Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)] |
123 | _ -> return () | 122 | _ -> return () |
124 | {- | 123 | {- |
@@ -136,14 +135,14 @@ uploadMeshToGPU (Mesh attrs mPrim Nothing) = do | |||
136 | let mkIndexBuf v = do | 135 | let mkIndexBuf v = do |
137 | iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v] | 136 | iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v] |
138 | return $! Just $! IndexStream iBuf 0 0 (V.length v) | 137 | return $! Just $! IndexStream iBuf 0 0 (V.length v) |
139 | vBuf <- compileBuffer [meshAttrToArray a | a <- T.elems attrs] | 138 | vBuf <- compileBuffer [meshAttrToArray a | a <- Map.elems attrs] |
140 | (indices,prim) <- case mPrim of | 139 | (indices,prim) <- case mPrim of |
141 | P_Points -> return (Nothing,PointList) | 140 | P_Points -> return (Nothing,PointList) |
142 | P_TriangleStrip -> return (Nothing,TriangleStrip) | 141 | P_TriangleStrip -> return (Nothing,TriangleStrip) |
143 | P_Triangles -> return (Nothing,TriangleList) | 142 | P_Triangles -> return (Nothing,TriangleList) |
144 | P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v | 143 | P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v |
145 | P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v | 144 | P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v |
146 | let streams = T.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (T.toList attrs) | 145 | let streams = Map.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (Map.toList attrs) |
147 | gpuData = GPUData prim streams indices | 146 | gpuData = GPUData prim streams indices |
148 | return $! Mesh attrs mPrim (Just gpuData) | 147 | return $! Mesh attrs mPrim (Just gpuData) |
149 | 148 | ||
@@ -211,8 +210,8 @@ instance Binary MeshPrimitive where | |||
211 | _ -> fail "no parse" | 210 | _ -> fail "no parse" |
212 | 211 | ||
213 | instance Binary Mesh where | 212 | instance Binary Mesh where |
214 | put (Mesh a b _) = put (T.toList a) >> put b | 213 | put (Mesh a b _) = put (Map.toList a) >> put b |
215 | get = do | 214 | get = do |
216 | a <- get | 215 | a <- get |
217 | b <- get | 216 | b <- get |
218 | return $! Mesh (T.fromList a) b Nothing | 217 | return $! Mesh (Map.fromList a) b Nothing |
diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs index c82a8f0..c06032f 100644 --- a/src/LambdaCube/GL/Type.hs +++ b/src/LambdaCube/GL/Type.hs | |||
@@ -6,7 +6,7 @@ import Data.IORef | |||
6 | import Data.Int | 6 | import Data.Int |
7 | import Data.IntMap (IntMap) | 7 | import Data.IntMap (IntMap) |
8 | import Data.Set (Set) | 8 | import Data.Set (Set) |
9 | import Data.Trie (Trie) | 9 | import Data.Map (Map) |
10 | import Data.Vector (Vector) | 10 | import Data.Vector (Vector) |
11 | import Data.Word | 11 | import Data.Word |
12 | import Foreign.Ptr | 12 | import Foreign.Ptr |
@@ -65,17 +65,17 @@ data ArrayDesc | |||
65 | - per object features: enable/disable visibility, set render ordering | 65 | - per object features: enable/disable visibility, set render ordering |
66 | -} | 66 | -} |
67 | 67 | ||
68 | data SlotSchema | 68 | data ObjectArraySchema |
69 | = SlotSchema | 69 | = ObjectArraySchema |
70 | { primitive :: FetchPrimitive | 70 | { primitive :: FetchPrimitive |
71 | , attributes :: Trie StreamType | 71 | , attributes :: Map ByteString StreamType |
72 | } | 72 | } |
73 | deriving Show | 73 | deriving Show |
74 | 74 | ||
75 | data PipelineSchema | 75 | data PipelineSchema |
76 | = PipelineSchema | 76 | = PipelineSchema |
77 | { slots :: Trie SlotSchema | 77 | { objectArrays :: Map ByteString ObjectArraySchema |
78 | , uniforms :: Trie InputType | 78 | , uniforms :: Map ByteString InputType |
79 | } | 79 | } |
80 | deriving Show | 80 | deriving Show |
81 | 81 | ||
@@ -99,11 +99,11 @@ data GLSlot | |||
99 | data GLStorage | 99 | data GLStorage |
100 | = GLStorage | 100 | = GLStorage |
101 | { schema :: PipelineSchema | 101 | { schema :: PipelineSchema |
102 | , slotMap :: Trie SlotName | 102 | , slotMap :: Map ByteString SlotName |
103 | , slotVector :: Vector (IORef GLSlot) | 103 | , slotVector :: Vector (IORef GLSlot) |
104 | , objSeed :: IORef Int | 104 | , objSeed :: IORef Int |
105 | , uniformSetter :: Trie InputSetter | 105 | , uniformSetter :: Map ByteString InputSetter |
106 | , uniformSetup :: Trie GLUniform | 106 | , uniformSetup :: Map ByteString GLUniform |
107 | , screenSize :: IORef (Word,Word) | 107 | , screenSize :: IORef (Word,Word) |
108 | , pipelines :: IORef (Vector (Maybe GLRenderer)) -- attached pipelines | 108 | , pipelines :: IORef (Vector (Maybe GLRenderer)) -- attached pipelines |
109 | } | 109 | } |
@@ -113,9 +113,9 @@ data Object -- internal type | |||
113 | { objSlot :: SlotName | 113 | { objSlot :: SlotName |
114 | , objPrimitive :: Primitive | 114 | , objPrimitive :: Primitive |
115 | , objIndices :: Maybe (IndexStream Buffer) | 115 | , objIndices :: Maybe (IndexStream Buffer) |
116 | , objAttributes :: Trie (Stream Buffer) | 116 | , objAttributes :: Map ByteString (Stream Buffer) |
117 | , objUniSetter :: Trie InputSetter | 117 | , objUniSetter :: Map ByteString InputSetter |
118 | , objUniSetup :: Trie GLUniform | 118 | , objUniSetup :: Map ByteString GLUniform |
119 | , objOrder :: IORef Int | 119 | , objOrder :: IORef Int |
120 | , objEnabled :: IORef Bool | 120 | , objEnabled :: IORef Bool |
121 | , objId :: Int | 121 | , objId :: Int |
@@ -130,10 +130,10 @@ data GLProgram | |||
130 | = GLProgram | 130 | = GLProgram |
131 | { shaderObjects :: [GLuint] | 131 | { shaderObjects :: [GLuint] |
132 | , programObject :: GLuint | 132 | , programObject :: GLuint |
133 | , inputUniforms :: Trie GLint | 133 | , inputUniforms :: Map ByteString GLint |
134 | , inputTextures :: Trie GLint -- all input textures (render texture + uniform texture) | 134 | , inputTextures :: Map ByteString GLint -- all input textures (render texture + uniform texture) |
135 | , inputTextureUniforms :: Set ByteString | 135 | , inputTextureUniforms :: Set ByteString |
136 | , inputStreams :: Trie (GLuint,ByteString) | 136 | , inputStreams :: Map ByteString (GLuint,ByteString) |
137 | } | 137 | } |
138 | 138 | ||
139 | data GLTexture | 139 | data GLTexture |
@@ -154,7 +154,7 @@ data GLStream | |||
154 | = GLStream | 154 | = GLStream |
155 | { glStreamCommands :: IORef [GLObjectCommand] | 155 | { glStreamCommands :: IORef [GLObjectCommand] |
156 | , glStreamPrimitive :: Primitive | 156 | , glStreamPrimitive :: Primitive |
157 | , glStreamAttributes :: Trie (Stream Buffer) | 157 | , glStreamAttributes :: Map ByteString (Stream Buffer) |
158 | , glStreamProgram :: ProgramName | 158 | , glStreamProgram :: ProgramName |
159 | } | 159 | } |
160 | 160 | ||
@@ -169,7 +169,7 @@ data GLRenderer | |||
169 | , glInput :: IORef (Maybe InputConnection) | 169 | , glInput :: IORef (Maybe InputConnection) |
170 | , glSlotNames :: Vector ByteString | 170 | , glSlotNames :: Vector ByteString |
171 | , glVAO :: GLuint | 171 | , glVAO :: GLuint |
172 | , glTexUnitMapping :: Trie (IORef GLint) -- maps texture uniforms to texture units | 172 | , glTexUnitMapping :: Map ByteString (IORef GLint) -- maps texture uniforms to texture units |
173 | , glStreams :: Vector GLStream | 173 | , glStreams :: Vector GLStream |
174 | } | 174 | } |
175 | 175 | ||
diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs index 2059415..6c65628 100644 --- a/src/LambdaCube/GL/Util.hs +++ b/src/LambdaCube/GL/Util.hs | |||
@@ -37,7 +37,6 @@ import Control.Monad | |||
37 | import Data.ByteString.Char8 (ByteString,pack,unpack) | 37 | import Data.ByteString.Char8 (ByteString,pack,unpack) |
38 | import Data.IORef | 38 | import Data.IORef |
39 | import Data.List as L | 39 | import Data.List as L |
40 | import Data.Trie as T | ||
41 | import Foreign | 40 | import Foreign |
42 | import qualified Data.ByteString.Char8 as SB | 41 | import qualified Data.ByteString.Char8 as SB |
43 | import qualified Data.Vector as V | 42 | import qualified Data.Vector as V |
@@ -51,8 +50,8 @@ import Linear | |||
51 | import IR | 50 | import IR |
52 | import LambdaCube.GL.Type | 51 | import LambdaCube.GL.Type |
53 | 52 | ||
54 | toTrie :: Map String a -> Trie a | 53 | toTrie :: Map String a -> Map ByteString a |
55 | toTrie m = T.fromList [(pack k,v) | (k,v) <- Map.toList m] | 54 | toTrie m = Map.fromList [(pack k,v) | (k,v) <- Map.toList m] |
56 | 55 | ||
57 | setSampler :: GLint -> Int32 -> IO () | 56 | setSampler :: GLint -> Int32 -> IO () |
58 | setSampler i v = glUniform1i i $ fromIntegral v | 57 | setSampler i v = glUniform1i i $ fromIntegral v |
@@ -62,13 +61,13 @@ z3 = V3 0 0 0 :: V3F | |||
62 | z4 = V4 0 0 0 0 :: V4F | 61 | z4 = V4 0 0 0 0 :: V4F |
63 | 62 | ||
64 | -- uniform functions | 63 | -- uniform functions |
65 | queryUniforms :: GLuint -> IO (Trie GLint, Trie InputType) | 64 | queryUniforms :: GLuint -> IO (Map ByteString GLint, Map ByteString InputType) |
66 | queryUniforms po = do | 65 | queryUniforms po = do |
67 | ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation GL_ACTIVE_UNIFORMS GL_ACTIVE_UNIFORM_MAX_LENGTH | 66 | ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation GL_ACTIVE_UNIFORMS GL_ACTIVE_UNIFORM_MAX_LENGTH |
68 | let uNames = [n | (n,_,_,_) <- ul] | 67 | let uNames = [n | (n,_,_,_) <- ul] |
69 | uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul] | 68 | uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul] |
70 | uLocation = [i | (_,i,_,_) <- ul] | 69 | uLocation = [i | (_,i,_,_) <- ul] |
71 | return $! (T.fromList $! zip uNames uLocation, T.fromList $! zip uNames uTypes) | 70 | return $! (Map.fromList $! zip uNames uLocation, Map.fromList $! zip uNames uTypes) |
72 | 71 | ||
73 | b2w :: Bool -> GLuint | 72 | b2w :: Bool -> GLuint |
74 | b2w True = 1 | 73 | b2w True = 1 |
@@ -137,13 +136,13 @@ setUniform i ty ref = do | |||
137 | _ -> fail $ "internal error (setUniform)! - " ++ show ty | 136 | _ -> fail $ "internal error (setUniform)! - " ++ show ty |
138 | 137 | ||
139 | -- attribute functions | 138 | -- attribute functions |
140 | queryStreams :: GLuint -> IO (Trie GLuint, Trie InputType) | 139 | queryStreams :: GLuint -> IO (Map ByteString GLuint, Map ByteString InputType) |
141 | queryStreams po = do | 140 | queryStreams po = do |
142 | al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation GL_ACTIVE_ATTRIBUTES GL_ACTIVE_ATTRIBUTE_MAX_LENGTH | 141 | al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation GL_ACTIVE_ATTRIBUTES GL_ACTIVE_ATTRIBUTE_MAX_LENGTH |
143 | let aNames = [n | (n,_,_,_) <- al] | 142 | let aNames = [n | (n,_,_,_) <- al] |
144 | aTypes = [fromGLType (e,s) | (_,_,e,s) <- al] | 143 | aTypes = [fromGLType (e,s) | (_,_,e,s) <- al] |
145 | aLocation = [fromIntegral i | (_,i,_,_) <- al] | 144 | aLocation = [fromIntegral i | (_,i,_,_) <- al] |
146 | return $! (T.fromList $! zip aNames aLocation, T.fromList $! zip aNames aTypes) | 145 | return $! (Map.fromList $! zip aNames aLocation, Map.fromList $! zip aNames aTypes) |
147 | 146 | ||
148 | arrayTypeToGLType :: ArrayType -> GLenum | 147 | arrayTypeToGLType :: ArrayType -> GLenum |
149 | arrayTypeToGLType a = case a of | 148 | arrayTypeToGLType a = case a of |