simplify Mesh data add some missing function

7 files changed, 91 insertions, 210 deletions

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 ()