diff options
Diffstat (limited to 'src/LambdaCube/GL/Mesh.hs')
-rw-r--r-- | src/LambdaCube/GL/Mesh.hs | 27 |
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 | |||
21 | import Foreign.Storable | 21 | import Foreign.Storable |
22 | import Foreign.Marshal.Utils | 22 | import Foreign.Marshal.Utils |
23 | import System.IO.Unsafe | 23 | import System.IO.Unsafe |
24 | import Data.Map (Map) | ||
25 | import qualified Data.Map as Map | ||
24 | import qualified Data.ByteString.Char8 as SB | 26 | import qualified Data.ByteString.Char8 as SB |
25 | import qualified Data.ByteString.Lazy as LB | 27 | import qualified Data.ByteString.Lazy as LB |
26 | import qualified Data.Trie as T | ||
27 | import qualified Data.Vector.Storable as V | 28 | import qualified Data.Vector.Storable as V |
28 | import qualified Data.Vector.Storable.Mutable as MV | 29 | import qualified Data.Vector.Storable.Mutable as MV |
29 | 30 | ||
@@ -55,7 +56,7 @@ data MeshPrimitive | |||
55 | 56 | ||
56 | data Mesh | 57 | data 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 | |||
63 | data GPUData | 64 | data 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) | |||
79 | addMeshToObjectArray :: GLStorage -> ByteString -> [ByteString] -> Mesh -> IO Object | 80 | addMeshToObjectArray :: GLStorage -> ByteString -> [ByteString] -> Mesh -> IO Object |
80 | addMeshToObjectArray input slotName objUniNames (Mesh _ _ (Just (GPUData prim streams indices))) = do | 81 | addMeshToObjectArray 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 | ||
87 | addMeshToObjectArray _ _ _ _ = fail "addMeshToObjectArray: only compiled mesh with GPUData is supported" | 86 | addMeshToObjectArray _ _ _ _ = fail "addMeshToObjectArray: only compiled mesh with GPUData is supported" |
88 | 87 | ||
89 | withV w a f = w a (\p -> f $ castPtr p) | 88 | withV w a f = w a (\p -> f $ castPtr p) |
@@ -114,11 +113,11 @@ updateMesh :: Mesh -> [(ByteString,MeshAttribute)] -> Maybe MeshPrimitive -> IO | |||
114 | updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do | 113 | updateMesh (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 | ||
213 | instance Binary Mesh where | 212 | instance 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 |