From 2cc82723838be8f9fc084c7582bbc87f26e1a794 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Fri, 8 Jan 2016 14:53:25 +0100 Subject: use Map instead of Trie --- src/LambdaCube/GL/Backend.hs | 82 +++++++++++----------- src/LambdaCube/GL/Data.hs | 1 - src/LambdaCube/GL/Input.hs | 164 +++++++++++++++++++++---------------------- src/LambdaCube/GL/Mesh.hs | 27 ++++--- src/LambdaCube/GL/Type.hs | 34 ++++----- src/LambdaCube/GL/Util.hs | 13 ++-- 6 files changed, 157 insertions(+), 164 deletions(-) (limited to 'src/LambdaCube/GL') 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) import Data.Maybe (isNothing,fromJust) import Data.Map (Map) import Data.Set (Set) -import Data.Trie as T -import Data.Trie.Convenience as T import Data.Vector (Vector,(!),(//)) import qualified Data.ByteString.Char8 as SB import qualified Data.Foldable as F @@ -198,7 +196,7 @@ clearRenderTarget values = do printGLStatus = checkGL >>= print printFBOStatus = checkFBO >>= print -compileProgram :: Trie InputType -> Program -> IO GLProgram +compileProgram :: Map ByteString InputType -> Program -> IO GLProgram compileProgram uniTrie p = do po <- glCreateProgram putStrLn $ "compile program: " ++ show po @@ -230,10 +228,10 @@ compileProgram uniTrie p = do (attributes,attributesType) <- queryStreams po print uniforms print attributes - let lcUniforms = (toTrie $ programUniforms p) `unionL` (toTrie $ programInTextures p) + let lcUniforms = (toTrie $ programUniforms p) `Map.union` (toTrie $ programInTextures p) lcStreams = fmap ty (toTrie $ programStreams p) - check a m = and $ map go $ T.toList m - where go (k,b) = case T.lookup k a of + check a m = and $ map go $ Map.toList m + where go (k,b) = case Map.lookup k a of Nothing -> False Just x -> x == b unless (check lcUniforms uniformsType) $ do @@ -241,31 +239,31 @@ compileProgram uniTrie p = do putStrLn $ "actual: " ++ show uniformsType fail "shader program uniform input mismatch!" unless (check lcStreams attributesType) $ fail $ "shader program stream input mismatch! " ++ show (attributesType,lcStreams) - -- the public (user) pipeline and program input is encoded by the slots, therefore the programs does not distinct the render and slot textures input + -- the public (user) pipeline and program input is encoded by the objectArrays, therefore the programs does not distinct the render and slot textures input let inUniNames = toTrie $ programUniforms p - inUniforms = L.filter (\(n,v) -> T.member n inUniNames) $ T.toList $ uniforms + inUniforms = L.filter (\(n,v) -> Map.member n inUniNames) $ Map.toList $ uniforms inTextureNames = toTrie $ programInTextures p - inTextures = L.filter (\(n,v) -> T.member n inTextureNames) $ T.toList $ uniforms - texUnis = [n | (n,_) <- inTextures, T.member n uniTrie] - putStrLn $ "uniTrie: " ++ show (T.keys uniTrie) + inTextures = L.filter (\(n,v) -> Map.member n inTextureNames) $ Map.toList $ uniforms + texUnis = [n | (n,_) <- inTextures, Map.member n uniTrie] + putStrLn $ "uniTrie: " ++ show (Map.keys uniTrie) putStrLn $ "inUniNames: " ++ show inUniNames putStrLn $ "inUniforms: " ++ show inUniforms putStrLn $ "inTextureNames: " ++ show inTextureNames putStrLn $ "inTextures: " ++ show inTextures putStrLn $ "texUnis: " ++ show texUnis - let valA = T.toList $ attributes - valB = T.toList $ toTrie $ programStreams p + let valA = Map.toList $ attributes + valB = Map.toList $ toTrie $ programStreams p putStrLn "------------" - print $ T.toList $ attributes - print $ T.toList $ toTrie $ programStreams p + print $ Map.toList $ attributes + print $ Map.toList $ toTrie $ programStreams p let lcStreamName = fmap name (toTrie $ programStreams p) return $ GLProgram { shaderObjects = objs , programObject = po - , inputUniforms = T.fromList inUniforms - , inputTextures = T.fromList inTextures + , inputUniforms = Map.fromList inUniforms + , inputTextures = Map.fromList inTextures , inputTextureUniforms = S.fromList $ texUnis - , inputStreams = T.fromList [(n,(idx, pack attrName)) | (n,idx) <- T.toList $ attributes, let Just attrName = T.lookup n lcStreamName] + , inputStreams = Map.fromList [(n,(idx, pack attrName)) | (n,idx) <- Map.toList $ attributes, let Just attrName = Map.lookup n lcStreamName] } compileSampler :: SamplerDescriptor -> IO GLSampler @@ -415,32 +413,32 @@ compileStreamData s = do , glStreamProgram = V.head $ streamPrograms s } -createStreamCommands :: Trie (IORef GLint) -> Trie GLUniform -> Trie (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand] +createStreamCommands :: Map ByteString (IORef GLint) -> Map ByteString GLUniform -> Map ByteString (Stream Buffer) -> Primitive -> GLProgram -> [GLObjectCommand] createStreamCommands texUnitMap topUnis attrs primitive prg = streamUniCmds ++ streamCmds ++ [drawCmd] where -- object draw command drawCmd = GLDrawArrays prim 0 (fromIntegral count) where prim = primitiveToGLType primitive - count = head [c | Stream _ _ _ _ c <- T.elems attrs] + count = head [c | Stream _ _ _ _ c <- Map.elems attrs] -- object uniform commands -- texture slot setup commands streamUniCmds = uniCmds ++ texCmds where uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = topUni n] - uniMap = T.toList $ inputUniforms prg - topUni n = T.lookupWithDefault (error "internal error (createStreamCommands)!") n topUnis + uniMap = Map.toList $ inputUniforms prg + topUni n = Map.findWithDefault (error "internal error (createStreamCommands)!") n topUnis texUnis = S.toList $ inputTextureUniforms prg texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u | n <- texUnis , let u = topUni n - , let texUnit = T.lookupWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap + , let texUnit = Map.findWithDefault (error "internal error (createStreamCommands - Texture Unit)") n texUnitMap ] uniInputType (GLUniform ty _) = ty -- object attribute stream commands - streamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name attrs] + streamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let Just s = Map.lookup name attrs] where attrMap = inputStreams prg attrCmd i s = case s of @@ -485,7 +483,7 @@ allocRenderer p = do prgs <- V.mapM (compileProgram uniTrie) $ programs p -- texture unit mapping ioref trie -- texUnitMapRefs :: Map UniformName (IORef TextureUnit) - texUnitMapRefs <- T.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (T.keys . toTrie . programInTextures) $ programs p) + texUnitMapRefs <- Map.fromList <$> mapM (\k -> (k,) <$> newIORef 0) (S.toList $ S.fromList $ concat $ V.toList $ V.map (Map.keys . toTrie . programInTextures) $ programs p) let (cmds,st) = runState (mapM (compileCommand texUnitMapRefs smps texs trgs prgs) $ V.toList $ commands p) initCGState input <- newIORef Nothing -- default Vertex Array Object @@ -518,8 +516,8 @@ disposeRenderer p = do with (glVAO p) $ (glDeleteVertexArrays 1) {- -data SlotSchema - = SlotSchema +data ObjectArraySchema + = ObjectArraySchema { primitive :: FetchPrimitive , attributes :: Trie StreamType } @@ -527,13 +525,13 @@ data SlotSchema data PipelineSchema = PipelineSchema - { slots :: Trie SlotSchema - , uniforms :: Trie InputType + { objectArrays :: Trie ObjectArraySchema + , uniforms :: Trie InputType } deriving Show -} -isSubTrie :: (a -> a -> Bool) -> Trie a -> Trie a -> Bool -isSubTrie eqFun universe subset = and [isMember a (T.lookup n universe) | (n,a) <- T.toList subset] +isSubTrie :: (a -> a -> Bool) -> Map ByteString a -> Map ByteString a -> Bool +isSubTrie eqFun universe subset = and [isMember a (Map.lookup n universe) | (n,a) <- Map.toList subset] where isMember a Nothing = False isMember a (Just b) = eqFun a b @@ -541,12 +539,12 @@ isSubTrie eqFun universe subset = and [isMember a (T.lookup n universe) | (n,a) -- TODO: if there is a mismatch thow detailed error message in the excoeption, containing the missing attributes and uniforms {- let sch = schema input - forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of + forM_ uniformNames $ \n -> case Map.lookup n (uniforms sch) of Nothing -> throw $ userError $ "Unknown uniform: " ++ show n _ -> return () - case T.lookup slotName (slots sch) of + case Map.lookup slotName (objectArrays sch) of Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName - Just (SlotSchema sPrim sAttrs) -> do + Just (ObjectArraySchema sPrim sAttrs) -> do when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $ "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim let sType = fmap streamToStreamType attribs @@ -571,7 +569,7 @@ setStorage' p input' = do -} {- deletion: - - remove pipeline's object commands from used slots + - remove pipeline's object commands from used objectArrays - remove pipeline from attached pipelines vector -} ic' <- readIORef $ glInput p @@ -592,7 +590,7 @@ setStorage' p input' = do - get an id from pipeline input - add to attached pipelines - generate slot mappings - - update used slots, and generate object commands for objects in the related slots + - update used objectArrays, and generate object commands for objects in the related objectArrays -} case input' of Nothing -> writeIORef (glInput p) Nothing >> return Nothing @@ -610,11 +608,11 @@ setStorage' p input' = do return (i,Nothing) -- create input connection let sm = slotMap input - pToI = [i | n <- glSlotNames p, let Just i = T.lookup n sm] - iToP = V.update (V.replicate (T.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI) + pToI = [i | n <- glSlotNames p, let Just i = Map.lookup n sm] + iToP = V.update (V.replicate (Map.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI) writeIORef (glInput p) $ Just $ InputConnection idx input pToI iToP - -- generate object commands for related slots + -- generate object commands for related objectArrays {- for each slot in pipeline: map slot name to input slot name @@ -771,7 +769,7 @@ initCGState = CGState type CG a = State CGState a -compileCommand :: Trie (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG GLCommand +compileCommand :: Map ByteString (IORef GLint) -> Vector GLSampler -> Vector GLTexture -> Vector GLRenderTarget -> Vector GLProgram -> Command -> CG GLCommand compileCommand texUnitMap samplers textures targets programs cmd = case cmd of SetRasterContext rCtx -> return $ GLSetRasterContext rCtx SetAccumulationContext aCtx -> return $ GLSetAccumulationContext aCtx @@ -782,9 +780,9 @@ compileCommand texUnitMap samplers textures targets programs cmd = case cmd of SetSamplerUniform n tu -> do modify (\s@CGState{..} -> s {samplerUniforms = Map.insert n tu samplerUniforms}) p <- currentProgram <$> get - case T.lookup (pack n) (inputTextures $ programs ! p) of + case Map.lookup (pack n) (inputTextures $ programs ! p) of Nothing -> fail $ "internal error (SetSamplerUniform)! - " ++ show cmd - Just i -> case T.lookup (pack n) texUnitMap of + Just i -> case Map.lookup (pack n) texUnitMap of Nothing -> fail $ "internal error (SetSamplerUniform - IORef)! - " ++ show cmd Just r -> return $ GLSetSamplerUniform i (fromIntegral tu) r 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) import Data.IORef import Data.List as L import Data.Maybe -import Data.Trie as T import Foreign --import qualified Data.IntMap as IM 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 import Control.Monad import Data.ByteString.Char8 (ByteString,pack) import Data.IORef +import Data.Map (Map) import Data.IntMap (IntMap) -import Data.Trie (Trie) -import Data.Trie.Convenience as T import Data.Vector (Vector,(//),(!)) import Data.Word import Foreign @@ -15,7 +14,6 @@ import qualified Data.ByteString.Char8 as SB import qualified Data.IntMap as IM import qualified Data.Set as S import qualified Data.Map as Map -import qualified Data.Trie as T import qualified Data.Vector as V import qualified Data.Vector.Algorithms.Intro as I @@ -29,9 +27,9 @@ import LambdaCube.GL.Util import qualified IR as IR schemaFromPipeline :: IR.Pipeline -> PipelineSchema -schemaFromPipeline a = PipelineSchema (T.fromList sl) (foldl T.unionL T.empty ul) +schemaFromPipeline a = PipelineSchema (Map.fromList sl) (foldl Map.union Map.empty ul) where - (sl,ul) = unzip [( (pack sName,SlotSchema sPrimitive (fmap cvt (toTrie sStreams))) + (sl,ul) = unzip [( (pack sName,ObjectArraySchema sPrimitive (fmap cvt (toTrie sStreams))) , toTrie sUniforms ) | 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 Just v -> v Nothing -> error "internal error (schemaFromPipeline)" -mkUniform :: [(ByteString,InputType)] -> IO (Trie InputSetter, Trie GLUniform) +mkUniform :: [(ByteString,InputType)] -> IO (Map ByteString InputSetter, Map ByteString GLUniform) mkUniform l = do unisAndSetters <- forM l $ \(n,t) -> do (uni, setter) <- mkUniformSetter t return ((n,uni),(n,setter)) let (unis,setters) = unzip unisAndSetters - return (T.fromList setters, T.fromList unis) + return (Map.fromList setters, Map.fromList unis) allocStorage :: PipelineSchema -> IO GLStorage allocStorage sch = do - let sm = T.fromList $ zip (T.keys $ T.slots sch) [0..] - len = T.size sm - (setters,unis) <- mkUniform $ T.toList $ uniforms sch + let sm = Map.fromList $ zip (Map.keys $ objectArrays sch) [0..] + len = Map.size sm + (setters,unis) <- mkUniform $ Map.toList $ uniforms sch seed <- newIORef 0 slotV <- V.replicateM len $ newIORef (GLSlot IM.empty V.empty Ordered) size <- newIORef (0,0) @@ -72,15 +70,15 @@ disposeStorage :: GLStorage -> IO () disposeStorage = error "not implemented: disposeStorage" -- object -addObject :: GLStorage -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Trie (Stream Buffer) -> [ByteString] -> IO Object +addObject :: GLStorage -> ByteString -> Primitive -> Maybe (IndexStream Buffer) -> Map ByteString (Stream Buffer) -> [ByteString] -> IO Object addObject input slotName prim indices attribs uniformNames = do let sch = schema input - forM_ uniformNames $ \n -> case T.lookup n (uniforms sch) of + forM_ uniformNames $ \n -> case Map.lookup n (uniforms sch) of Nothing -> throw $ userError $ "Unknown uniform: " ++ show n _ -> return () - case T.lookup slotName (T.slots sch) of + case Map.lookup slotName (objectArrays sch) of Nothing -> throw $ userError $ "Unknown slot: " ++ show slotName - Just (SlotSchema sPrim sAttrs) -> do + Just (ObjectArraySchema sPrim sAttrs) -> do when (sPrim /= (primitiveToFetchPrimitive prim)) $ throw $ userError $ "Primitive mismatch for slot (" ++ show slotName ++ ") expected " ++ show sPrim ++ " but got " ++ show prim let sType = fmap streamToStreamType attribs @@ -91,7 +89,7 @@ addObject input slotName prim indices attribs uniformNames = do , show sType ] - let slotIdx = case slotName `T.lookup` slotMap input of + let slotIdx = case slotName `Map.lookup` slotMap input of Nothing -> error $ "internal error (slot index): " ++ show slotName Just i -> i seed = objSeed input @@ -99,7 +97,7 @@ addObject input slotName prim indices attribs uniformNames = do enabled <- newIORef True index <- readIORef seed modifyIORef seed (1+) - (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let Just t = T.lookup n (uniforms sch)] + (setters,unis) <- mkUniform [(n,t) | n <- uniformNames, let Just t = Map.lookup n (uniforms sch)] cmdsRef <- newIORef (V.singleton V.empty) let obj = Object { objSlot = slotIdx @@ -151,7 +149,7 @@ setObjectOrder p obj i = do writeIORef (objOrder obj) i modifyIORef (slotVector p ! objSlot obj) $ \(GLSlot objs sorted _) -> GLSlot objs sorted Reorder -objectUniformSetter :: Object -> Trie InputSetter +objectUniformSetter :: Object -> Map ByteString InputSetter objectUniformSetter = objUniSetter setScreenSize :: GLStorage -> Word -> Word -> IO () @@ -179,7 +177,7 @@ sortSlotObjects p = V.forM_ (slotVector p) $ \slotRef -> do return (ord,obj) doSort objs -createObjectCommands :: Trie (IORef GLint) -> Trie GLUniform -> Object -> GLProgram -> [GLObjectCommand] +createObjectCommands :: Map ByteString (IORef GLint) -> Map ByteString GLUniform -> Object -> GLProgram -> [GLObjectCommand] createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++ [objDrawCmd] where -- object draw command @@ -193,26 +191,26 @@ createObjectCommands texUnitMap topUnis obj prg = objUniCmds ++ objStreamCmds ++ where objAttrs = objAttributes obj prim = primitiveToGLType $ objPrimitive obj - count = head [c | Stream _ _ _ _ c <- T.elems objAttrs] + count = head [c | Stream _ _ _ _ c <- Map.elems objAttrs] -- object uniform commands -- texture slot setup commands objUniCmds = uniCmds ++ texCmds where - uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = T.lookupWithDefault (topUni n) n objUnis] - uniMap = T.toList $ inputUniforms prg - topUni n = T.lookupWithDefault (error $ "internal error (createObjectCommands): " ++ show n) n topUnis + uniCmds = [GLSetUniform i u | (n,i) <- uniMap, let u = Map.findWithDefault (topUni n) n objUnis] + uniMap = Map.toList $ inputUniforms prg + topUni n = Map.findWithDefault (error $ "internal error (createObjectCommands): " ++ show n) n topUnis objUnis = objUniSetup obj texUnis = S.toList $ inputTextureUniforms prg texCmds = [ GLBindTexture (inputTypeToTextureTarget $ uniInputType u) texUnit u | n <- texUnis - , let u = T.lookupWithDefault (topUni n) n objUnis - , let texUnit = T.lookupWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap + , let u = Map.findWithDefault (topUni n) n objUnis + , let texUnit = Map.findWithDefault (error $ "internal error (createObjectCommands - Texture Unit): " ++ show n) n texUnitMap ] uniInputType (GLUniform ty _) = ty -- object attribute stream commands - objStreamCmds = [attrCmd i s | (i,name) <- T.elems attrMap, let Just s = T.lookup name objAttrs] + objStreamCmds = [attrCmd i s | (i,name) <- Map.elems attrMap, let Just s = Map.lookup name objAttrs] where attrMap = inputStreams prg objAttrs = objAttributes obj @@ -253,138 +251,138 @@ nullSetter :: ByteString -> String -> a -> IO () --nullSetter n t _ = return () -- Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t nullSetter n t _ = Prelude.putStrLn $ "WARNING: unknown uniform: " ++ SB.unpack n ++ " :: " ++ t -uniformBool :: ByteString -> Trie InputSetter -> SetterFun Bool -uniformV2B :: ByteString -> Trie InputSetter -> SetterFun V2B -uniformV3B :: ByteString -> Trie InputSetter -> SetterFun V3B -uniformV4B :: ByteString -> Trie InputSetter -> SetterFun V4B - -uniformWord :: ByteString -> Trie InputSetter -> SetterFun Word32 -uniformV2U :: ByteString -> Trie InputSetter -> SetterFun V2U -uniformV3U :: ByteString -> Trie InputSetter -> SetterFun V3U -uniformV4U :: ByteString -> Trie InputSetter -> SetterFun V4U - -uniformInt :: ByteString -> Trie InputSetter -> SetterFun Int32 -uniformV2I :: ByteString -> Trie InputSetter -> SetterFun V2I -uniformV3I :: ByteString -> Trie InputSetter -> SetterFun V3I -uniformV4I :: ByteString -> Trie InputSetter -> SetterFun V4I - -uniformFloat :: ByteString -> Trie InputSetter -> SetterFun Float -uniformV2F :: ByteString -> Trie InputSetter -> SetterFun V2F -uniformV3F :: ByteString -> Trie InputSetter -> SetterFun V3F -uniformV4F :: ByteString -> Trie InputSetter -> SetterFun V4F - -uniformM22F :: ByteString -> Trie InputSetter -> SetterFun M22F -uniformM23F :: ByteString -> Trie InputSetter -> SetterFun M23F -uniformM24F :: ByteString -> Trie InputSetter -> SetterFun M24F -uniformM32F :: ByteString -> Trie InputSetter -> SetterFun M32F -uniformM33F :: ByteString -> Trie InputSetter -> SetterFun M33F -uniformM34F :: ByteString -> Trie InputSetter -> SetterFun M34F -uniformM42F :: ByteString -> Trie InputSetter -> SetterFun M42F -uniformM43F :: ByteString -> Trie InputSetter -> SetterFun M43F -uniformM44F :: ByteString -> Trie InputSetter -> SetterFun M44F - -uniformFTexture2D :: ByteString -> Trie InputSetter -> SetterFun TextureData - -uniformBool n is = case T.lookup n is of +uniformBool :: ByteString -> Map ByteString InputSetter -> SetterFun Bool +uniformV2B :: ByteString -> Map ByteString InputSetter -> SetterFun V2B +uniformV3B :: ByteString -> Map ByteString InputSetter -> SetterFun V3B +uniformV4B :: ByteString -> Map ByteString InputSetter -> SetterFun V4B + +uniformWord :: ByteString -> Map ByteString InputSetter -> SetterFun Word32 +uniformV2U :: ByteString -> Map ByteString InputSetter -> SetterFun V2U +uniformV3U :: ByteString -> Map ByteString InputSetter -> SetterFun V3U +uniformV4U :: ByteString -> Map ByteString InputSetter -> SetterFun V4U + +uniformInt :: ByteString -> Map ByteString InputSetter -> SetterFun Int32 +uniformV2I :: ByteString -> Map ByteString InputSetter -> SetterFun V2I +uniformV3I :: ByteString -> Map ByteString InputSetter -> SetterFun V3I +uniformV4I :: ByteString -> Map ByteString InputSetter -> SetterFun V4I + +uniformFloat :: ByteString -> Map ByteString InputSetter -> SetterFun Float +uniformV2F :: ByteString -> Map ByteString InputSetter -> SetterFun V2F +uniformV3F :: ByteString -> Map ByteString InputSetter -> SetterFun V3F +uniformV4F :: ByteString -> Map ByteString InputSetter -> SetterFun V4F + +uniformM22F :: ByteString -> Map ByteString InputSetter -> SetterFun M22F +uniformM23F :: ByteString -> Map ByteString InputSetter -> SetterFun M23F +uniformM24F :: ByteString -> Map ByteString InputSetter -> SetterFun M24F +uniformM32F :: ByteString -> Map ByteString InputSetter -> SetterFun M32F +uniformM33F :: ByteString -> Map ByteString InputSetter -> SetterFun M33F +uniformM34F :: ByteString -> Map ByteString InputSetter -> SetterFun M34F +uniformM42F :: ByteString -> Map ByteString InputSetter -> SetterFun M42F +uniformM43F :: ByteString -> Map ByteString InputSetter -> SetterFun M43F +uniformM44F :: ByteString -> Map ByteString InputSetter -> SetterFun M44F + +uniformFTexture2D :: ByteString -> Map ByteString InputSetter -> SetterFun TextureData + +uniformBool n is = case Map.lookup n is of Just (SBool fun) -> fun _ -> nullSetter n "Bool" -uniformV2B n is = case T.lookup n is of +uniformV2B n is = case Map.lookup n is of Just (SV2B fun) -> fun _ -> nullSetter n "V2B" -uniformV3B n is = case T.lookup n is of +uniformV3B n is = case Map.lookup n is of Just (SV3B fun) -> fun _ -> nullSetter n "V3B" -uniformV4B n is = case T.lookup n is of +uniformV4B n is = case Map.lookup n is of Just (SV4B fun) -> fun _ -> nullSetter n "V4B" -uniformWord n is = case T.lookup n is of +uniformWord n is = case Map.lookup n is of Just (SWord fun) -> fun _ -> nullSetter n "Word" -uniformV2U n is = case T.lookup n is of +uniformV2U n is = case Map.lookup n is of Just (SV2U fun) -> fun _ -> nullSetter n "V2U" -uniformV3U n is = case T.lookup n is of +uniformV3U n is = case Map.lookup n is of Just (SV3U fun) -> fun _ -> nullSetter n "V3U" -uniformV4U n is = case T.lookup n is of +uniformV4U n is = case Map.lookup n is of Just (SV4U fun) -> fun _ -> nullSetter n "V4U" -uniformInt n is = case T.lookup n is of +uniformInt n is = case Map.lookup n is of Just (SInt fun) -> fun _ -> nullSetter n "Int" -uniformV2I n is = case T.lookup n is of +uniformV2I n is = case Map.lookup n is of Just (SV2I fun) -> fun _ -> nullSetter n "V2I" -uniformV3I n is = case T.lookup n is of +uniformV3I n is = case Map.lookup n is of Just (SV3I fun) -> fun _ -> nullSetter n "V3I" -uniformV4I n is = case T.lookup n is of +uniformV4I n is = case Map.lookup n is of Just (SV4I fun) -> fun _ -> nullSetter n "V4I" -uniformFloat n is = case T.lookup n is of +uniformFloat n is = case Map.lookup n is of Just (SFloat fun) -> fun _ -> nullSetter n "Float" -uniformV2F n is = case T.lookup n is of +uniformV2F n is = case Map.lookup n is of Just (SV2F fun) -> fun _ -> nullSetter n "V2F" -uniformV3F n is = case T.lookup n is of +uniformV3F n is = case Map.lookup n is of Just (SV3F fun) -> fun _ -> nullSetter n "V3F" -uniformV4F n is = case T.lookup n is of +uniformV4F n is = case Map.lookup n is of Just (SV4F fun) -> fun _ -> nullSetter n "V4F" -uniformM22F n is = case T.lookup n is of +uniformM22F n is = case Map.lookup n is of Just (SM22F fun) -> fun _ -> nullSetter n "M22F" -uniformM23F n is = case T.lookup n is of +uniformM23F n is = case Map.lookup n is of Just (SM23F fun) -> fun _ -> nullSetter n "M23F" -uniformM24F n is = case T.lookup n is of +uniformM24F n is = case Map.lookup n is of Just (SM24F fun) -> fun _ -> nullSetter n "M24F" -uniformM32F n is = case T.lookup n is of +uniformM32F n is = case Map.lookup n is of Just (SM32F fun) -> fun _ -> nullSetter n "M32F" -uniformM33F n is = case T.lookup n is of +uniformM33F n is = case Map.lookup n is of Just (SM33F fun) -> fun _ -> nullSetter n "M33F" -uniformM34F n is = case T.lookup n is of +uniformM34F n is = case Map.lookup n is of Just (SM34F fun) -> fun _ -> nullSetter n "M34F" -uniformM42F n is = case T.lookup n is of +uniformM42F n is = case Map.lookup n is of Just (SM42F fun) -> fun _ -> nullSetter n "M42F" -uniformM43F n is = case T.lookup n is of +uniformM43F n is = case Map.lookup n is of Just (SM43F fun) -> fun _ -> nullSetter n "M43F" -uniformM44F n is = case T.lookup n is of +uniformM44F n is = case Map.lookup n is of Just (SM44F fun) -> fun _ -> nullSetter n "M44F" -uniformFTexture2D n is = case T.lookup n is of +uniformFTexture2D n is = case Map.lookup n is of Just (SFTexture2D fun) -> fun _ -> 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 import Foreign.Storable import Foreign.Marshal.Utils import System.IO.Unsafe +import Data.Map (Map) +import qualified Data.Map as Map import qualified Data.ByteString.Char8 as SB import qualified Data.ByteString.Lazy as LB -import qualified Data.Trie as T import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as MV @@ -55,7 +56,7 @@ data MeshPrimitive data Mesh = Mesh - { mAttributes :: T.Trie MeshAttribute + { mAttributes :: Map ByteString MeshAttribute , mPrimitive :: MeshPrimitive , mGPUData :: Maybe GPUData } @@ -63,7 +64,7 @@ data Mesh data GPUData = GPUData { dPrimitive :: Primitive - , dStreams :: T.Trie (Stream Buffer) + , dStreams :: Map ByteString (Stream Buffer) , dIndices :: Maybe (IndexStream Buffer) } @@ -79,11 +80,9 @@ saveMesh n m = LB.writeFile n (encode m) addMeshToObjectArray :: GLStorage -> ByteString -> [ByteString] -> Mesh -> IO Object addMeshToObjectArray input slotName objUniNames (Mesh _ _ (Just (GPUData prim streams indices))) = do -- select proper attributes - let Just (SlotSchema slotPrim slotStreams) = T.lookup slotName $! T.slots $! T.schema input - filterStream n s - | T.member n slotStreams = Just s - | otherwise = Nothing - addObject input slotName prim indices (T.mapBy filterStream streams) objUniNames + let Just (ObjectArraySchema slotPrim slotStreams) = Map.lookup slotName $! objectArrays $! schema input + filterStream n _ = Map.member n slotStreams + addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames addMeshToObjectArray _ _ _ _ = fail "addMeshToObjectArray: only compiled mesh with GPUData is supported" withV w a f = w a (\p -> f $ castPtr p) @@ -114,11 +113,11 @@ updateMesh :: Mesh -> [(ByteString,MeshAttribute)] -> Maybe MeshPrimitive -> IO updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do -- check type match let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 - ok = and [T.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = T.lookup n dMA] + ok = and [Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = Map.lookup n dMA] if not ok then putStrLn "updateMesh: attribute mismatch!" else do forM_ al $ \(n,a) -> do - case T.lookup n dS of + case Map.lookup n dS of Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)] _ -> return () {- @@ -136,14 +135,14 @@ uploadMeshToGPU (Mesh attrs mPrim Nothing) = do let mkIndexBuf v = do iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v] return $! Just $! IndexStream iBuf 0 0 (V.length v) - vBuf <- compileBuffer [meshAttrToArray a | a <- T.elems attrs] + vBuf <- compileBuffer [meshAttrToArray a | a <- Map.elems attrs] (indices,prim) <- case mPrim of P_Points -> return (Nothing,PointList) P_TriangleStrip -> return (Nothing,TriangleStrip) P_Triangles -> return (Nothing,TriangleList) P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v - let streams = T.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (T.toList attrs) + let streams = Map.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (Map.toList attrs) gpuData = GPUData prim streams indices return $! Mesh attrs mPrim (Just gpuData) @@ -211,8 +210,8 @@ instance Binary MeshPrimitive where _ -> fail "no parse" instance Binary Mesh where - put (Mesh a b _) = put (T.toList a) >> put b + put (Mesh a b _) = put (Map.toList a) >> put b get = do a <- get b <- get - return $! Mesh (T.fromList a) b Nothing + 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 import Data.Int import Data.IntMap (IntMap) import Data.Set (Set) -import Data.Trie (Trie) +import Data.Map (Map) import Data.Vector (Vector) import Data.Word import Foreign.Ptr @@ -65,17 +65,17 @@ data ArrayDesc - per object features: enable/disable visibility, set render ordering -} -data SlotSchema - = SlotSchema +data ObjectArraySchema + = ObjectArraySchema { primitive :: FetchPrimitive - , attributes :: Trie StreamType + , attributes :: Map ByteString StreamType } deriving Show data PipelineSchema = PipelineSchema - { slots :: Trie SlotSchema - , uniforms :: Trie InputType + { objectArrays :: Map ByteString ObjectArraySchema + , uniforms :: Map ByteString InputType } deriving Show @@ -99,11 +99,11 @@ data GLSlot data GLStorage = GLStorage { schema :: PipelineSchema - , slotMap :: Trie SlotName + , slotMap :: Map ByteString SlotName , slotVector :: Vector (IORef GLSlot) , objSeed :: IORef Int - , uniformSetter :: Trie InputSetter - , uniformSetup :: Trie GLUniform + , uniformSetter :: Map ByteString InputSetter + , uniformSetup :: Map ByteString GLUniform , screenSize :: IORef (Word,Word) , pipelines :: IORef (Vector (Maybe GLRenderer)) -- attached pipelines } @@ -113,9 +113,9 @@ data Object -- internal type { objSlot :: SlotName , objPrimitive :: Primitive , objIndices :: Maybe (IndexStream Buffer) - , objAttributes :: Trie (Stream Buffer) - , objUniSetter :: Trie InputSetter - , objUniSetup :: Trie GLUniform + , objAttributes :: Map ByteString (Stream Buffer) + , objUniSetter :: Map ByteString InputSetter + , objUniSetup :: Map ByteString GLUniform , objOrder :: IORef Int , objEnabled :: IORef Bool , objId :: Int @@ -130,10 +130,10 @@ data GLProgram = GLProgram { shaderObjects :: [GLuint] , programObject :: GLuint - , inputUniforms :: Trie GLint - , inputTextures :: Trie GLint -- all input textures (render texture + uniform texture) + , inputUniforms :: Map ByteString GLint + , inputTextures :: Map ByteString GLint -- all input textures (render texture + uniform texture) , inputTextureUniforms :: Set ByteString - , inputStreams :: Trie (GLuint,ByteString) + , inputStreams :: Map ByteString (GLuint,ByteString) } data GLTexture @@ -154,7 +154,7 @@ data GLStream = GLStream { glStreamCommands :: IORef [GLObjectCommand] , glStreamPrimitive :: Primitive - , glStreamAttributes :: Trie (Stream Buffer) + , glStreamAttributes :: Map ByteString (Stream Buffer) , glStreamProgram :: ProgramName } @@ -169,7 +169,7 @@ data GLRenderer , glInput :: IORef (Maybe InputConnection) , glSlotNames :: Vector ByteString , glVAO :: GLuint - , glTexUnitMapping :: Trie (IORef GLint) -- maps texture uniforms to texture units + , glTexUnitMapping :: Map ByteString (IORef GLint) -- maps texture uniforms to texture units , glStreams :: Vector GLStream } 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 import Data.ByteString.Char8 (ByteString,pack,unpack) import Data.IORef import Data.List as L -import Data.Trie as T import Foreign import qualified Data.ByteString.Char8 as SB import qualified Data.Vector as V @@ -51,8 +50,8 @@ import Linear import IR import LambdaCube.GL.Type -toTrie :: Map String a -> Trie a -toTrie m = T.fromList [(pack k,v) | (k,v) <- Map.toList m] +toTrie :: Map String a -> Map ByteString a +toTrie m = Map.fromList [(pack k,v) | (k,v) <- Map.toList m] setSampler :: GLint -> Int32 -> IO () setSampler i v = glUniform1i i $ fromIntegral v @@ -62,13 +61,13 @@ z3 = V3 0 0 0 :: V3F z4 = V4 0 0 0 0 :: V4F -- uniform functions -queryUniforms :: GLuint -> IO (Trie GLint, Trie InputType) +queryUniforms :: GLuint -> IO (Map ByteString GLint, Map ByteString InputType) queryUniforms po = do ul <- getNameTypeSize po glGetActiveUniform glGetUniformLocation GL_ACTIVE_UNIFORMS GL_ACTIVE_UNIFORM_MAX_LENGTH let uNames = [n | (n,_,_,_) <- ul] uTypes = [fromGLType (e,s) | (_,_,e,s) <- ul] uLocation = [i | (_,i,_,_) <- ul] - return $! (T.fromList $! zip uNames uLocation, T.fromList $! zip uNames uTypes) + return $! (Map.fromList $! zip uNames uLocation, Map.fromList $! zip uNames uTypes) b2w :: Bool -> GLuint b2w True = 1 @@ -137,13 +136,13 @@ setUniform i ty ref = do _ -> fail $ "internal error (setUniform)! - " ++ show ty -- attribute functions -queryStreams :: GLuint -> IO (Trie GLuint, Trie InputType) +queryStreams :: GLuint -> IO (Map ByteString GLuint, Map ByteString InputType) queryStreams po = do al <- getNameTypeSize po glGetActiveAttrib glGetAttribLocation GL_ACTIVE_ATTRIBUTES GL_ACTIVE_ATTRIBUTE_MAX_LENGTH let aNames = [n | (n,_,_,_) <- al] aTypes = [fromGLType (e,s) | (_,_,e,s) <- al] aLocation = [fromIntegral i | (_,i,_,_) <- al] - return $! (T.fromList $! zip aNames aLocation, T.fromList $! zip aNames aTypes) + return $! (Map.fromList $! zip aNames aLocation, Map.fromList $! zip aNames aTypes) arrayTypeToGLType :: ArrayType -> GLenum arrayTypeToGLType a = case a of -- cgit v1.2.3