From 64e13239772dae2a73e30bd0aa8ca2c70154987c Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Fri, 8 Jan 2016 12:01:39 +0100 Subject: move to LambdaCube.GL, use more descriptive names, update for OpenGLRaw 3.0 --- Backend/GL/Mesh.hs | 238 ----------------------------------------------------- 1 file changed, 238 deletions(-) delete mode 100644 Backend/GL/Mesh.hs (limited to 'Backend/GL/Mesh.hs') diff --git a/Backend/GL/Mesh.hs b/Backend/GL/Mesh.hs deleted file mode 100644 index 4539622..0000000 --- a/Backend/GL/Mesh.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# LANGUAGE TupleSections #-} -module Backend.GL.Mesh ( - loadMesh', - loadMesh, - saveMesh, - addMesh, - compileMesh, - updateMesh, - Mesh(..), - MeshPrimitive(..), - MeshAttribute(..), - GPUData -) where - -import Control.Applicative -import Control.Monad -import Data.Binary -import Data.ByteString.Char8 (ByteString) -import Foreign.Ptr -import Data.Int -import Foreign.Storable -import Foreign.Marshal.Utils -import System.IO.Unsafe -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 - -import Backend.GL -import Backend.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 :: T.Trie MeshAttribute - , mPrimitive :: MeshPrimitive - , mGPUData :: Maybe GPUData - } - -data GPUData - = GPUData - { dPrimitive :: Primitive - , dStreams :: T.Trie (Stream Buffer) - , dIndices :: Maybe (IndexStream Buffer) - } - -loadMesh' :: String -> IO Mesh -loadMesh' n = decode <$> LB.readFile n - -loadMesh :: String -> IO Mesh -loadMesh n = compileMesh =<< loadMesh' n - -saveMesh :: String -> Mesh -> IO () -saveMesh n m = LB.writeFile n (encode m) - -addMesh :: GLPipelineInput -> ByteString -> Mesh -> [ByteString] -> IO Object -addMesh input slotName (Mesh _ _ (Just (GPUData prim streams indices))) objUniNames = 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 -addMesh _ _ _ _ = fail "addMesh: 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 - -meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer -meshAttrToStream b i (A_Float v) = Stream TFloat b i 0 (V.length v) -meshAttrToStream b i (A_V2F v) = Stream TV2F b i 0 (V.length v) -meshAttrToStream b i (A_V3F v) = Stream TV3F b i 0 (V.length v) -meshAttrToStream b i (A_V4F v) = Stream TV4F b i 0 (V.length v) -meshAttrToStream b i (A_M22F v) = Stream TM22F b i 0 (V.length v) -meshAttrToStream b i (A_M33F v) = Stream TM33F b i 0 (V.length v) -meshAttrToStream b i (A_M44F v) = Stream TM44F b i 0 (V.length v) -meshAttrToStream b i (A_Int v) = Stream TInt b i 0 (V.length v) -meshAttrToStream b i (A_Word v) = Stream TWord b i 0 (V.length v) - -{- -updateBuffer :: Buffer -> [(Int,Array)] -> IO () - - | Stream - { streamType :: StreamType - , streamBuffer :: b - , streamArrIdx :: Int - , streamStart :: Int - , streamLength :: Int - } - --- stream of index values (for index buffer) -data IndexStream b - = IndexStream - { indexBuffer :: b - , indexArrIdx :: Int - , indexStart :: Int - , indexLength :: Int - } --} -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] - if not ok then putStrLn "updateMesh: attribute mismatch!" - else do - forM_ al $ \(n,a) -> do - case T.lookup n dS of - Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)] - _ -> return () -{- - case mp of - Nothing -> return () - Just p -> do - let ok2 = case (dMP,p) of - (Just (P_TriangleStripI v1, P_TriangleStripI v2) -> V.length v1 == V.length v2 - (P_TrianglesI v1, P_TrianglesI v2) -> V.length v1 == V.length v2 - (a,b) -> a == b --} - -compileMesh :: Mesh -> IO Mesh -compileMesh (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] - (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) - gpuData = GPUData prim streams indices - return $! Mesh attrs mPrim (Just gpuData) - -compileMesh 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" - -instance Binary Mesh where - put (Mesh a b _) = put (T.toList a) >> put b - get = do - a <- get - b <- get - return $! Mesh (T.fromList a) b Nothing -- cgit v1.2.3