summaryrefslogtreecommitdiff
path: root/src/LambdaCube/GL/Mesh.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/LambdaCube/GL/Mesh.hs')
-rw-r--r--src/LambdaCube/GL/Mesh.hs27
1 files changed, 13 insertions, 14 deletions
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
21import Foreign.Storable 21import Foreign.Storable
22import Foreign.Marshal.Utils 22import Foreign.Marshal.Utils
23import System.IO.Unsafe 23import System.IO.Unsafe
24import Data.Map (Map)
25import qualified Data.Map as Map
24import qualified Data.ByteString.Char8 as SB 26import qualified Data.ByteString.Char8 as SB
25import qualified Data.ByteString.Lazy as LB 27import qualified Data.ByteString.Lazy as LB
26import qualified Data.Trie as T
27import qualified Data.Vector.Storable as V 28import qualified Data.Vector.Storable as V
28import qualified Data.Vector.Storable.Mutable as MV 29import qualified Data.Vector.Storable.Mutable as MV
29 30
@@ -55,7 +56,7 @@ data MeshPrimitive
55 56
56data Mesh 57data Mesh
57 = Mesh 58 = Mesh
58 { mAttributes :: T.Trie MeshAttribute 59 { mAttributes :: Map ByteString MeshAttribute
59 , mPrimitive :: MeshPrimitive 60 , mPrimitive :: MeshPrimitive
60 , mGPUData :: Maybe GPUData 61 , mGPUData :: Maybe GPUData
61 } 62 }
@@ -63,7 +64,7 @@ data Mesh
63data GPUData 64data GPUData
64 = GPUData 65 = GPUData
65 { dPrimitive :: Primitive 66 { dPrimitive :: Primitive
66 , dStreams :: T.Trie (Stream Buffer) 67 , dStreams :: Map ByteString (Stream Buffer)
67 , dIndices :: Maybe (IndexStream Buffer) 68 , dIndices :: Maybe (IndexStream Buffer)
68 } 69 }
69 70
@@ -79,11 +80,9 @@ saveMesh n m = LB.writeFile n (encode m)
79addMeshToObjectArray :: GLStorage -> ByteString -> [ByteString] -> Mesh -> IO Object 80addMeshToObjectArray :: GLStorage -> ByteString -> [ByteString] -> Mesh -> IO Object
80addMeshToObjectArray input slotName objUniNames (Mesh _ _ (Just (GPUData prim streams indices))) = do 81addMeshToObjectArray input slotName objUniNames (Mesh _ _ (Just (GPUData prim streams indices))) = do
81 -- select proper attributes 82 -- select proper attributes
82 let Just (SlotSchema slotPrim slotStreams) = T.lookup slotName $! T.slots $! T.schema input 83 let Just (ObjectArraySchema slotPrim slotStreams) = Map.lookup slotName $! objectArrays $! schema input
83 filterStream n s 84 filterStream n _ = Map.member n slotStreams
84 | T.member n slotStreams = Just s 85 addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames
85 | otherwise = Nothing
86 addObject input slotName prim indices (T.mapBy filterStream streams) objUniNames
87addMeshToObjectArray _ _ _ _ = fail "addMeshToObjectArray: only compiled mesh with GPUData is supported" 86addMeshToObjectArray _ _ _ _ = fail "addMeshToObjectArray: only compiled mesh with GPUData is supported"
88 87
89withV w a f = w a (\p -> f $ castPtr p) 88withV w a f = w a (\p -> f $ castPtr p)
@@ -114,11 +113,11 @@ updateMesh :: Mesh -> [(ByteString,MeshAttribute)] -> Maybe MeshPrimitive -> IO
114updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do 113updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do
115 -- check type match 114 -- check type match
116 let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 115 let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2
117 ok = and [T.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = T.lookup n dMA] 116 ok = and [Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = Map.lookup n dMA]
118 if not ok then putStrLn "updateMesh: attribute mismatch!" 117 if not ok then putStrLn "updateMesh: attribute mismatch!"
119 else do 118 else do
120 forM_ al $ \(n,a) -> do 119 forM_ al $ \(n,a) -> do
121 case T.lookup n dS of 120 case Map.lookup n dS of
122 Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)] 121 Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)]
123 _ -> return () 122 _ -> return ()
124{- 123{-
@@ -136,14 +135,14 @@ uploadMeshToGPU (Mesh attrs mPrim Nothing) = do
136 let mkIndexBuf v = do 135 let mkIndexBuf v = do
137 iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v] 136 iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v]
138 return $! Just $! IndexStream iBuf 0 0 (V.length v) 137 return $! Just $! IndexStream iBuf 0 0 (V.length v)
139 vBuf <- compileBuffer [meshAttrToArray a | a <- T.elems attrs] 138 vBuf <- compileBuffer [meshAttrToArray a | a <- Map.elems attrs]
140 (indices,prim) <- case mPrim of 139 (indices,prim) <- case mPrim of
141 P_Points -> return (Nothing,PointList) 140 P_Points -> return (Nothing,PointList)
142 P_TriangleStrip -> return (Nothing,TriangleStrip) 141 P_TriangleStrip -> return (Nothing,TriangleStrip)
143 P_Triangles -> return (Nothing,TriangleList) 142 P_Triangles -> return (Nothing,TriangleList)
144 P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v 143 P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v
145 P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v 144 P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v
146 let streams = T.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (T.toList attrs) 145 let streams = Map.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (Map.toList attrs)
147 gpuData = GPUData prim streams indices 146 gpuData = GPUData prim streams indices
148 return $! Mesh attrs mPrim (Just gpuData) 147 return $! Mesh attrs mPrim (Just gpuData)
149 148
@@ -211,8 +210,8 @@ instance Binary MeshPrimitive where
211 _ -> fail "no parse" 210 _ -> fail "no parse"
212 211
213instance Binary Mesh where 212instance Binary Mesh where
214 put (Mesh a b _) = put (T.toList a) >> put b 213 put (Mesh a b _) = put (Map.toList a) >> put b
215 get = do 214 get = do
216 a <- get 215 a <- get
217 b <- get 216 b <- get
218 return $! Mesh (T.fromList a) b Nothing 217 return $! Mesh (Map.fromList a) b Nothing