simplify Mesh data add some missing function

1 files changed, 35 insertions, 133 deletions

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