From 32646973035dcb3f35c7501d0654607dfaeec091 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Fri, 29 Jan 2016 15:25:49 +0100 Subject: simplify Mesh data add some missing function --- src/LambdaCube/GL.hs | 13 ++-- src/LambdaCube/GL/Backend.hs | 7 +- src/LambdaCube/GL/Data.hs | 5 ++ src/LambdaCube/GL/Input.hs | 56 +++++++++------ src/LambdaCube/GL/Mesh.hs | 168 +++++++++---------------------------------- src/LambdaCube/GL/Type.hs | 47 +----------- src/LambdaCube/GL/Util.hs | 5 +- 7 files changed, 91 insertions(+), 210 deletions(-) (limited to 'src/LambdaCube') diff --git a/src/LambdaCube/GL.hs b/src/LambdaCube/GL.hs index 258d2ba..2b5c814 100644 --- a/src/LambdaCube/GL.hs +++ b/src/LambdaCube/GL.hs @@ -1,4 +1,6 @@ module LambdaCube.GL ( + -- Schema + module LambdaCube.PipelineSchema, -- IR V2(..),V3(..),V4(..), -- Array, Buffer, Texture @@ -9,7 +11,6 @@ module LambdaCube.GL ( IndexStream(..), Stream(..), StreamSetter, - StreamType(..), FetchPrimitive(..), InputType(..), Primitive(..), @@ -20,20 +21,20 @@ module LambdaCube.GL ( sizeOfArrayType, toStreamType, compileBuffer, + disposeBuffer, updateBuffer, bufferSize, arraySize, arrayType, uploadTexture2DToGPU, uploadTexture2DToGPU', + disposeTexture, -- GL: Renderer, Storage, Object GLUniformName, GLRenderer, GLStorage, Object, - PipelineSchema(..), - ObjectArraySchema(..), schema, schemaFromPipeline, allocRenderer, @@ -96,5 +97,7 @@ import LambdaCube.GL.Type import LambdaCube.GL.Backend import LambdaCube.GL.Data import LambdaCube.GL.Input -import IR -import Linear +import LambdaCube.IR +import LambdaCube.Linear +import LambdaCube.PipelineSchema +import LambdaCube.PipelineSchemaUtil diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs index 677e925..bb45fbd 100644 --- a/src/LambdaCube/GL/Backend.hs +++ b/src/LambdaCube/GL/Backend.hs @@ -24,9 +24,10 @@ import Foreign import Foreign.C.String -- LC IR imports -import Linear -import IR hiding (streamType) -import qualified IR as IR +import LambdaCube.PipelineSchema +import LambdaCube.Linear +import LambdaCube.IR hiding (streamType) +import qualified LambdaCube.IR as IR import LambdaCube.GL.Type import LambdaCube.GL.Util diff --git a/src/LambdaCube/GL/Data.hs b/src/LambdaCube/GL/Data.hs index 4ebe33c..3e0f963 100644 --- a/src/LambdaCube/GL/Data.hs +++ b/src/LambdaCube/GL/Data.hs @@ -23,6 +23,9 @@ import LambdaCube.GL.Type import LambdaCube.GL.Util -- Buffer +disposeBuffer :: Buffer -> IO () +disposeBuffer (Buffer _ bo) = withArray [bo] $ glDeleteBuffers 1 + compileBuffer :: [Array] -> IO Buffer compileBuffer arrs = do let calcDesc (offset,setters,descs) (Array arrType cnt setter) = @@ -55,6 +58,8 @@ arrayType :: Buffer -> Int -> ArrayType arrayType buf arrIdx = arrType $! bufArrays buf V.! arrIdx -- Texture +disposeTexture :: TextureData -> IO () +disposeTexture (TextureData to) = withArray [to] $ glDeleteTextures 1 -- FIXME: Temporary implemenation uploadTexture2DToGPU :: DynamicImage -> IO TextureData diff --git a/src/LambdaCube/GL/Input.hs b/src/LambdaCube/GL/Input.hs index 7e4ba74..9ceb35f 100644 --- a/src/LambdaCube/GL/Input.hs +++ b/src/LambdaCube/GL/Input.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-} module LambdaCube.GL.Input where import Control.Applicative @@ -22,12 +22,13 @@ import qualified Data.ByteString.Char8 as SB import Graphics.GL.Core33 -import IR as IR -import Linear as IR +import LambdaCube.IR as IR +import LambdaCube.Linear as IR +import LambdaCube.PipelineSchema import LambdaCube.GL.Type as T import LambdaCube.GL.Util -import qualified IR as IR +import qualified LambdaCube.IR as IR schemaFromPipeline :: IR.Pipeline -> PipelineSchema schemaFromPipeline a = PipelineSchema (Map.fromList sl) (foldl Map.union Map.empty ul) @@ -392,29 +393,38 @@ uniformFTexture2D n is = case Map.lookup n is of Just (SFTexture2D fun) -> fun _ -> nullSetter n "FTexture2D" -a @: b = tell [(a,b)] -defObjectArray n p m = mapM_ tell [PipelineSchema (Map.singleton n $ ObjectArraySchema p $ Map.singleton a t) mempty | (a,t) <- execWriter m] -defUniforms m = tell $ PipelineSchema mempty $ Map.fromList $ execWriter m -makeSchema a = execWriter a :: PipelineSchema - -unionObjectArraySchema (ObjectArraySchema a1 b1) (ObjectArraySchema a2 b2) = - ObjectArraySchema (if a1 == a2 then a1 else error $ "object array schema primitive mismatch " ++ show (a1,a2)) - (Map.unionWith (\a b -> if a == b then a else error $ "object array schema attribute type mismatch " ++ show (a,b)) b1 b2) - -instance Monoid PipelineSchema where - mempty = PipelineSchema mempty mempty - mappend (PipelineSchema a1 b1) (PipelineSchema a2 b2) = - PipelineSchema (Map.unionWith unionObjectArraySchema a1 a2) (Map.unionWith (\a b -> if a == b then a else error $ "schema type mismatch " ++ show (a,b)) b1 b2) - type UniM = Writer [GLStorage -> IO ()] class UniformSetter a where (@=) :: GLUniformName -> IO a -> UniM () -instance UniformSetter Float where - n @= act = tell [\s -> let f = uniformFloat n (uniformSetter s) in f =<< act] - -instance UniformSetter TextureData where - n @= act = tell [\s -> let f = uniformFTexture2D n (uniformSetter s) in f =<< act] +setUniM setUni n act = tell [\s -> let f = setUni n (uniformSetter s) in f =<< act] + +instance UniformSetter Bool where (@=) = setUniM uniformBool +instance UniformSetter V2B where (@=) = setUniM uniformV2B +instance UniformSetter V3B where (@=) = setUniM uniformV3B +instance UniformSetter V4B where (@=) = setUniM uniformV4B +instance UniformSetter Word32 where (@=) = setUniM uniformWord +instance UniformSetter V2U where (@=) = setUniM uniformV2U +instance UniformSetter V3U where (@=) = setUniM uniformV3U +instance UniformSetter V4U where (@=) = setUniM uniformV4U +instance UniformSetter Int32 where (@=) = setUniM uniformInt +instance UniformSetter V2I where (@=) = setUniM uniformV2I +instance UniformSetter V3I where (@=) = setUniM uniformV3I +instance UniformSetter V4I where (@=) = setUniM uniformV4I +instance UniformSetter Float where (@=) = setUniM uniformFloat +instance UniformSetter V2F where (@=) = setUniM uniformV2F +instance UniformSetter V3F where (@=) = setUniM uniformV3F +instance UniformSetter V4F where (@=) = setUniM uniformV4F +instance UniformSetter M22F where (@=) = setUniM uniformM22F +instance UniformSetter M23F where (@=) = setUniM uniformM23F +instance UniformSetter M24F where (@=) = setUniM uniformM24F +instance UniformSetter M32F where (@=) = setUniM uniformM32F +instance UniformSetter M33F where (@=) = setUniM uniformM33F +instance UniformSetter M34F where (@=) = setUniM uniformM34F +instance UniformSetter M42F where (@=) = setUniM uniformM42F +instance UniformSetter M43F where (@=) = setUniM uniformM43F +instance UniformSetter M44F where (@=) = setUniM uniformM44F +instance UniformSetter TextureData where (@=) = setUniM uniformFTexture2D updateUniforms storage m = sequence_ $ let l = map ($ storage) $ execWriter m in l diff --git a/src/LambdaCube/GL/Mesh.hs b/src/LambdaCube/GL/Mesh.hs index f8521dd..0c56f26 100644 --- a/src/LambdaCube/GL/Mesh.hs +++ b/src/LambdaCube/GL/Mesh.hs @@ -1,20 +1,19 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections, RecordWildCards #-} module LambdaCube.GL.Mesh ( - loadMesh', - loadMesh, - saveMesh, addMeshToObjectArray, uploadMeshToGPU, + disposeMesh, updateMesh, Mesh(..), MeshPrimitive(..), MeshAttribute(..), - GPUData + GPUMesh, + meshData ) where +import Data.Maybe import Control.Applicative import Control.Monad -import Data.Binary import Foreign.Ptr import Data.Int import Foreign.Storable @@ -22,80 +21,51 @@ import Foreign.Marshal.Utils import System.IO.Unsafe import Data.Map (Map) import qualified Data.Map as Map -import qualified Data.Vector.Storable as V +import qualified Data.Vector as V +import qualified Data.Vector.Storable as SV import qualified Data.Vector.Storable.Mutable as MV import qualified Data.ByteString.Char8 as SB import qualified Data.ByteString.Lazy as LB import LambdaCube.GL import LambdaCube.GL.Type as T -import IR as IR -import Linear as IR - -fileVersion :: Int32 -fileVersion = 1 - -data MeshAttribute - = A_Float (V.Vector Float) - | A_V2F (V.Vector V2F) - | A_V3F (V.Vector V3F) - | A_V4F (V.Vector V4F) - | A_M22F (V.Vector M22F) - | A_M33F (V.Vector M33F) - | A_M44F (V.Vector M44F) - | A_Int (V.Vector Int32) - | A_Word (V.Vector Word32) - -data MeshPrimitive - = P_Points - | P_TriangleStrip - | P_Triangles - | P_TriangleStripI (V.Vector Int32) - | P_TrianglesI (V.Vector Int32) - -data Mesh - = Mesh - { mAttributes :: Map String MeshAttribute - , mPrimitive :: MeshPrimitive - , mGPUData :: Maybe GPUData - } +import LambdaCube.IR as IR +import LambdaCube.Linear as IR +import LambdaCube.Mesh data GPUData = GPUData { dPrimitive :: Primitive , dStreams :: Map String (Stream Buffer) , dIndices :: Maybe (IndexStream Buffer) + , dBuffers :: [Buffer] } -loadMesh' :: String -> IO Mesh -loadMesh' n = decode <$> LB.readFile n - -loadMesh :: String -> IO Mesh -loadMesh n = uploadMeshToGPU =<< loadMesh' n - -saveMesh :: String -> Mesh -> IO () -saveMesh n m = LB.writeFile n (encode m) +data GPUMesh + = GPUMesh + { meshData :: Mesh + , gpuData :: GPUData + } -addMeshToObjectArray :: GLStorage -> String -> [String] -> Mesh -> IO Object -addMeshToObjectArray input slotName objUniNames (Mesh _ _ (Just (GPUData prim streams indices))) = do +addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object +addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do -- select proper attributes 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) meshAttrToArray :: MeshAttribute -> Array -meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV V.unsafeWith v -meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV V.unsafeWith v -meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV V.unsafeWith v -meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v -meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v -meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV V.unsafeWith v -meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV V.unsafeWith v -meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV V.unsafeWith v -meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV V.unsafeWith v +meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV SV.unsafeWith $ V.convert v +meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV SV.unsafeWith $ V.convert v +meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV SV.unsafeWith $ V.convert v +meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV SV.unsafeWith $ V.convert v +meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV SV.unsafeWith $ V.convert v +meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV SV.unsafeWith $ V.convert v +meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV SV.unsafeWith $ V.convert v +meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV SV.unsafeWith $ V.convert v +meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV SV.unsafeWith $ V.convert v meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer meshAttrToStream b i (A_Float v) = Stream Attribute_Float b i 0 (V.length v) @@ -108,8 +78,8 @@ meshAttrToStream b i (A_M44F v) = Stream Attribute_M44F b i 0 (V.length v) meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v) meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v) -updateMesh :: Mesh -> [(String,MeshAttribute)] -> Maybe MeshPrimitive -> IO () -updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do +updateMesh :: GPUMesh -> [(String,MeshAttribute)] -> Maybe MeshPrimitive -> IO () +updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do -- check type match let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 ok = and [Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = Map.lookup n dMA] @@ -129,10 +99,10 @@ updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do (a,b) -> a == b -} -uploadMeshToGPU :: Mesh -> IO Mesh -uploadMeshToGPU (Mesh attrs mPrim Nothing) = do +uploadMeshToGPU :: Mesh -> IO GPUMesh +uploadMeshToGPU mesh@(Mesh attrs mPrim) = do let mkIndexBuf v = do - iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v] + iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV SV.unsafeWith $ V.convert v] return $! Just $! IndexStream iBuf 0 0 (V.length v) vBuf <- compileBuffer [meshAttrToArray a | a <- Map.elems attrs] (indices,prim) <- case mPrim of @@ -142,75 +112,7 @@ uploadMeshToGPU (Mesh attrs mPrim Nothing) = do P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v 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) - -uploadMeshToGPU mesh = return mesh - -sblToV :: Storable a => [SB.ByteString] -> V.Vector a -sblToV ls = v - where - offs o (s:xs) = (o,s):offs (o + SB.length s) xs - offs _ [] = [] - cnt = sum (map SB.length ls) `div` (sizeOf $ V.head v) - v = unsafePerformIO $ do - mv <- MV.new cnt - MV.unsafeWith mv $ \dst -> forM_ (offs 0 ls) $ \(o,s) -> - SB.useAsCStringLen s $ \(src,len) -> moveBytes (plusPtr dst o) src len - V.unsafeFreeze mv - -vToSB :: Storable a => V.Vector a -> SB.ByteString -vToSB v = unsafePerformIO $ do - let len = V.length v * sizeOf (V.head v) - V.unsafeWith v $ \p -> SB.packCStringLen (castPtr p,len) - -instance Storable a => Binary (V.Vector a) where - put v = put $ vToSB v - get = do s <- get ; return $ sblToV [s] - -instance Binary MeshAttribute where - put (A_Float a) = putWord8 0 >> put a - put (A_V2F a) = putWord8 1 >> put a - put (A_V3F a) = putWord8 2 >> put a - put (A_V4F a) = putWord8 3 >> put a - put (A_M22F a) = putWord8 4 >> put a - put (A_M33F a) = putWord8 5 >> put a - put (A_M44F a) = putWord8 6 >> put a - put (A_Int a) = putWord8 7 >> put a - put (A_Word a) = putWord8 8 >> put a - get = do - tag_ <- getWord8 - case tag_ of - 0 -> A_Float <$> get - 1 -> A_V2F <$> get - 2 -> A_V3F <$> get - 3 -> A_V4F <$> get - 4 -> A_M22F <$> get - 5 -> A_M33F <$> get - 6 -> A_M44F <$> get - 7 -> A_Int <$> get - 8 -> A_Word <$> get - _ -> fail "no parse" - -instance Binary MeshPrimitive where - put P_Points = putWord8 0 - put P_TriangleStrip = putWord8 1 - put P_Triangles = putWord8 2 - put (P_TriangleStripI a) = putWord8 3 >> put a - put (P_TrianglesI a) = putWord8 4 >> put a - get = do - tag_ <- getWord8 - case tag_ of - 0 -> return P_Points - 1 -> return P_TriangleStrip - 2 -> return P_Triangles - 3 -> P_TriangleStripI <$> get - 4 -> P_TrianglesI <$> get - _ -> fail "no parse" + return $! GPUMesh mesh (GPUData prim streams indices (vBuf:[iBuf | IndexStream iBuf _ _ _ <- maybeToList indices])) -instance Binary Mesh where - put (Mesh a b _) = put (Map.toList a) >> put b - get = do - a <- get - b <- get - return $! Mesh (Map.fromList a) b Nothing +disposeMesh :: GPUMesh -> IO () +disposeMesh (GPUMesh _ GPUData{..}) = mapM_ disposeBuffer dBuffers diff --git a/src/LambdaCube/GL/Type.hs b/src/LambdaCube/GL/Type.hs index 8f4bdd7..376fdf1 100644 --- a/src/LambdaCube/GL/Type.hs +++ b/src/LambdaCube/GL/Type.hs @@ -14,8 +14,9 @@ import Data.ByteString import Graphics.GL.Core33 -import Linear -import IR +import LambdaCube.Linear +import LambdaCube.IR +import LambdaCube.PipelineSchema type GLUniformName = ByteString @@ -66,21 +67,6 @@ data ArrayDesc - independent from pipeline - per object features: enable/disable visibility, set render ordering -} - -data ObjectArraySchema - = ObjectArraySchema - { primitive :: FetchPrimitive - , attributes :: Map String StreamType - } - deriving Show - -data PipelineSchema - = PipelineSchema - { objectArrays :: Map String ObjectArraySchema - , uniforms :: Map String InputType - } - deriving Show - data GLUniform = forall a. Storable a => GLUniform !InputType !(IORef a) instance Show GLUniform where @@ -322,33 +308,6 @@ sizeOfArrayType ArrHalf = 2 data Array -- array type, element count (NOT byte size!), setter = Array ArrayType Int BufferSetter --- dev hint: this should be InputType --- we restrict StreamType using type class --- subset of InputType, describes a stream type (in GPU side) -data StreamType - = Attribute_Word - | Attribute_V2U - | Attribute_V3U - | Attribute_V4U - | Attribute_Int - | Attribute_V2I - | Attribute_V3I - | Attribute_V4I - | Attribute_Float - | Attribute_V2F - | Attribute_V3F - | Attribute_V4F - | Attribute_M22F - | Attribute_M23F - | Attribute_M24F - | Attribute_M32F - | Attribute_M33F - | Attribute_M34F - | Attribute_M42F - | Attribute_M43F - | Attribute_M44F - deriving (Show,Eq,Ord) - toStreamType :: InputType -> Maybe StreamType toStreamType Word = Just Attribute_Word toStreamType V2U = Just Attribute_V2U diff --git a/src/LambdaCube/GL/Util.hs b/src/LambdaCube/GL/Util.hs index c8449eb..28ab935 100644 --- a/src/LambdaCube/GL/Util.hs +++ b/src/LambdaCube/GL/Util.hs @@ -43,8 +43,9 @@ import Data.Map (Map) import qualified Data.Map as Map import Graphics.GL.Core33 -import Linear -import IR +import LambdaCube.Linear +import LambdaCube.IR +import LambdaCube.PipelineSchema import LambdaCube.GL.Type setSampler :: GLint -> Int32 -> IO () -- cgit v1.2.3