diff options
Diffstat (limited to 'src/LambdaCube/GL/Mesh.hs')
-rw-r--r-- | src/LambdaCube/GL/Mesh.hs | 168 |
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 @@ | |||
1 | {-# LANGUAGE TupleSections #-} | 1 | {-# LANGUAGE TupleSections, RecordWildCards #-} |
2 | module LambdaCube.GL.Mesh ( | 2 | module LambdaCube.GL.Mesh ( |
3 | loadMesh', | ||
4 | loadMesh, | ||
5 | saveMesh, | ||
6 | addMeshToObjectArray, | 3 | addMeshToObjectArray, |
7 | uploadMeshToGPU, | 4 | uploadMeshToGPU, |
5 | disposeMesh, | ||
8 | updateMesh, | 6 | updateMesh, |
9 | Mesh(..), | 7 | Mesh(..), |
10 | MeshPrimitive(..), | 8 | MeshPrimitive(..), |
11 | MeshAttribute(..), | 9 | MeshAttribute(..), |
12 | GPUData | 10 | GPUMesh, |
11 | meshData | ||
13 | ) where | 12 | ) where |
14 | 13 | ||
14 | import Data.Maybe | ||
15 | import Control.Applicative | 15 | import Control.Applicative |
16 | import Control.Monad | 16 | import Control.Monad |
17 | import Data.Binary | ||
18 | import Foreign.Ptr | 17 | import Foreign.Ptr |
19 | import Data.Int | 18 | import Data.Int |
20 | import Foreign.Storable | 19 | import Foreign.Storable |
@@ -22,80 +21,51 @@ import Foreign.Marshal.Utils | |||
22 | import System.IO.Unsafe | 21 | import System.IO.Unsafe |
23 | import Data.Map (Map) | 22 | import Data.Map (Map) |
24 | import qualified Data.Map as Map | 23 | import qualified Data.Map as Map |
25 | import qualified Data.Vector.Storable as V | 24 | import qualified Data.Vector as V |
25 | import qualified Data.Vector.Storable as SV | ||
26 | import qualified Data.Vector.Storable.Mutable as MV | 26 | import qualified Data.Vector.Storable.Mutable as MV |
27 | import qualified Data.ByteString.Char8 as SB | 27 | import qualified Data.ByteString.Char8 as SB |
28 | import qualified Data.ByteString.Lazy as LB | 28 | import qualified Data.ByteString.Lazy as LB |
29 | 29 | ||
30 | import LambdaCube.GL | 30 | import LambdaCube.GL |
31 | import LambdaCube.GL.Type as T | 31 | import LambdaCube.GL.Type as T |
32 | import IR as IR | 32 | import LambdaCube.IR as IR |
33 | import Linear as IR | 33 | import LambdaCube.Linear as IR |
34 | 34 | import LambdaCube.Mesh | |
35 | fileVersion :: Int32 | ||
36 | fileVersion = 1 | ||
37 | |||
38 | data MeshAttribute | ||
39 | = A_Float (V.Vector Float) | ||
40 | | A_V2F (V.Vector V2F) | ||
41 | | A_V3F (V.Vector V3F) | ||
42 | | A_V4F (V.Vector V4F) | ||
43 | | A_M22F (V.Vector M22F) | ||
44 | | A_M33F (V.Vector M33F) | ||
45 | | A_M44F (V.Vector M44F) | ||
46 | | A_Int (V.Vector Int32) | ||
47 | | A_Word (V.Vector Word32) | ||
48 | |||
49 | data MeshPrimitive | ||
50 | = P_Points | ||
51 | | P_TriangleStrip | ||
52 | | P_Triangles | ||
53 | | P_TriangleStripI (V.Vector Int32) | ||
54 | | P_TrianglesI (V.Vector Int32) | ||
55 | |||
56 | data Mesh | ||
57 | = Mesh | ||
58 | { mAttributes :: Map String MeshAttribute | ||
59 | , mPrimitive :: MeshPrimitive | ||
60 | , mGPUData :: Maybe GPUData | ||
61 | } | ||
62 | 35 | ||
63 | data GPUData | 36 | data GPUData |
64 | = GPUData | 37 | = GPUData |
65 | { dPrimitive :: Primitive | 38 | { dPrimitive :: Primitive |
66 | , dStreams :: Map String (Stream Buffer) | 39 | , dStreams :: Map String (Stream Buffer) |
67 | , dIndices :: Maybe (IndexStream Buffer) | 40 | , dIndices :: Maybe (IndexStream Buffer) |
41 | , dBuffers :: [Buffer] | ||
68 | } | 42 | } |
69 | 43 | ||
70 | loadMesh' :: String -> IO Mesh | 44 | data GPUMesh |
71 | loadMesh' n = decode <$> LB.readFile n | 45 | = GPUMesh |
72 | 46 | { meshData :: Mesh | |
73 | loadMesh :: String -> IO Mesh | 47 | , gpuData :: GPUData |
74 | loadMesh n = uploadMeshToGPU =<< loadMesh' n | 48 | } |
75 | |||
76 | saveMesh :: String -> Mesh -> IO () | ||
77 | saveMesh n m = LB.writeFile n (encode m) | ||
78 | 49 | ||
79 | addMeshToObjectArray :: GLStorage -> String -> [String] -> Mesh -> IO Object | 50 | addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object |
80 | addMeshToObjectArray input slotName objUniNames (Mesh _ _ (Just (GPUData prim streams indices))) = do | 51 | addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do |
81 | -- select proper attributes | 52 | -- select proper attributes |
82 | let Just (ObjectArraySchema slotPrim slotStreams) = Map.lookup slotName $! objectArrays $! schema input | 53 | let Just (ObjectArraySchema slotPrim slotStreams) = Map.lookup slotName $! objectArrays $! schema input |
83 | filterStream n _ = Map.member n slotStreams | 54 | filterStream n _ = Map.member n slotStreams |
84 | addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames | 55 | addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames |
85 | addMeshToObjectArray _ _ _ _ = fail "addMeshToObjectArray: only compiled mesh with GPUData is supported" | ||
86 | 56 | ||
87 | withV w a f = w a (\p -> f $ castPtr p) | 57 | withV w a f = w a (\p -> f $ castPtr p) |
88 | 58 | ||
89 | meshAttrToArray :: MeshAttribute -> Array | 59 | meshAttrToArray :: MeshAttribute -> Array |
90 | meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV V.unsafeWith v | 60 | meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV SV.unsafeWith $ V.convert v |
91 | meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV V.unsafeWith v | 61 | meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV SV.unsafeWith $ V.convert v |
92 | meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV V.unsafeWith v | 62 | meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV SV.unsafeWith $ V.convert v |
93 | meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v | 63 | meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV SV.unsafeWith $ V.convert v |
94 | meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v | 64 | meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV SV.unsafeWith $ V.convert v |
95 | meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV V.unsafeWith v | 65 | meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV SV.unsafeWith $ V.convert v |
96 | meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV V.unsafeWith v | 66 | meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV SV.unsafeWith $ V.convert v |
97 | meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV V.unsafeWith v | 67 | meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV SV.unsafeWith $ V.convert v |
98 | meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV V.unsafeWith v | 68 | meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV SV.unsafeWith $ V.convert v |
99 | 69 | ||
100 | meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer | 70 | meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer |
101 | meshAttrToStream b i (A_Float v) = Stream Attribute_Float b i 0 (V.length v) | 71 | 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) | |||
108 | meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v) | 78 | meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v) |
109 | meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v) | 79 | meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v) |
110 | 80 | ||
111 | updateMesh :: Mesh -> [(String,MeshAttribute)] -> Maybe MeshPrimitive -> IO () | 81 | updateMesh :: GPUMesh -> [(String,MeshAttribute)] -> Maybe MeshPrimitive -> IO () |
112 | updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do | 82 | updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do |
113 | -- check type match | 83 | -- check type match |
114 | let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 | 84 | let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 |
115 | ok = and [Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = Map.lookup n dMA] | 85 | 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 | |||
129 | (a,b) -> a == b | 99 | (a,b) -> a == b |
130 | -} | 100 | -} |
131 | 101 | ||
132 | uploadMeshToGPU :: Mesh -> IO Mesh | 102 | uploadMeshToGPU :: Mesh -> IO GPUMesh |
133 | uploadMeshToGPU (Mesh attrs mPrim Nothing) = do | 103 | uploadMeshToGPU mesh@(Mesh attrs mPrim) = do |
134 | let mkIndexBuf v = do | 104 | let mkIndexBuf v = do |
135 | iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v] | 105 | iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV SV.unsafeWith $ V.convert v] |
136 | return $! Just $! IndexStream iBuf 0 0 (V.length v) | 106 | return $! Just $! IndexStream iBuf 0 0 (V.length v) |
137 | vBuf <- compileBuffer [meshAttrToArray a | a <- Map.elems attrs] | 107 | vBuf <- compileBuffer [meshAttrToArray a | a <- Map.elems attrs] |
138 | (indices,prim) <- case mPrim of | 108 | (indices,prim) <- case mPrim of |
@@ -142,75 +112,7 @@ uploadMeshToGPU (Mesh attrs mPrim Nothing) = do | |||
142 | P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v | 112 | P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v |
143 | P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v | 113 | P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v |
144 | let streams = Map.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (Map.toList attrs) | 114 | let streams = Map.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (Map.toList attrs) |
145 | gpuData = GPUData prim streams indices | 115 | return $! GPUMesh mesh (GPUData prim streams indices (vBuf:[iBuf | IndexStream iBuf _ _ _ <- maybeToList indices])) |
146 | return $! Mesh attrs mPrim (Just gpuData) | ||
147 | |||
148 | uploadMeshToGPU mesh = return mesh | ||
149 | |||
150 | sblToV :: Storable a => [SB.ByteString] -> V.Vector a | ||
151 | sblToV ls = v | ||
152 | where | ||
153 | offs o (s:xs) = (o,s):offs (o + SB.length s) xs | ||
154 | offs _ [] = [] | ||
155 | cnt = sum (map SB.length ls) `div` (sizeOf $ V.head v) | ||
156 | v = unsafePerformIO $ do | ||
157 | mv <- MV.new cnt | ||
158 | MV.unsafeWith mv $ \dst -> forM_ (offs 0 ls) $ \(o,s) -> | ||
159 | SB.useAsCStringLen s $ \(src,len) -> moveBytes (plusPtr dst o) src len | ||
160 | V.unsafeFreeze mv | ||
161 | |||
162 | vToSB :: Storable a => V.Vector a -> SB.ByteString | ||
163 | vToSB v = unsafePerformIO $ do | ||
164 | let len = V.length v * sizeOf (V.head v) | ||
165 | V.unsafeWith v $ \p -> SB.packCStringLen (castPtr p,len) | ||
166 | |||
167 | instance Storable a => Binary (V.Vector a) where | ||
168 | put v = put $ vToSB v | ||
169 | get = do s <- get ; return $ sblToV [s] | ||
170 | |||
171 | instance Binary MeshAttribute where | ||
172 | put (A_Float a) = putWord8 0 >> put a | ||
173 | put (A_V2F a) = putWord8 1 >> put a | ||
174 | put (A_V3F a) = putWord8 2 >> put a | ||
175 | put (A_V4F a) = putWord8 3 >> put a | ||
176 | put (A_M22F a) = putWord8 4 >> put a | ||
177 | put (A_M33F a) = putWord8 5 >> put a | ||
178 | put (A_M44F a) = putWord8 6 >> put a | ||
179 | put (A_Int a) = putWord8 7 >> put a | ||
180 | put (A_Word a) = putWord8 8 >> put a | ||
181 | get = do | ||
182 | tag_ <- getWord8 | ||
183 | case tag_ of | ||
184 | 0 -> A_Float <$> get | ||
185 | 1 -> A_V2F <$> get | ||
186 | 2 -> A_V3F <$> get | ||
187 | 3 -> A_V4F <$> get | ||
188 | 4 -> A_M22F <$> get | ||
189 | 5 -> A_M33F <$> get | ||
190 | 6 -> A_M44F <$> get | ||
191 | 7 -> A_Int <$> get | ||
192 | 8 -> A_Word <$> get | ||
193 | _ -> fail "no parse" | ||
194 | |||
195 | instance Binary MeshPrimitive where | ||
196 | put P_Points = putWord8 0 | ||
197 | put P_TriangleStrip = putWord8 1 | ||
198 | put P_Triangles = putWord8 2 | ||
199 | put (P_TriangleStripI a) = putWord8 3 >> put a | ||
200 | put (P_TrianglesI a) = putWord8 4 >> put a | ||
201 | get = do | ||
202 | tag_ <- getWord8 | ||
203 | case tag_ of | ||
204 | 0 -> return P_Points | ||
205 | 1 -> return P_TriangleStrip | ||
206 | 2 -> return P_Triangles | ||
207 | 3 -> P_TriangleStripI <$> get | ||
208 | 4 -> P_TrianglesI <$> get | ||
209 | _ -> fail "no parse" | ||
210 | 116 | ||
211 | instance Binary Mesh where | 117 | disposeMesh :: GPUMesh -> IO () |
212 | put (Mesh a b _) = put (Map.toList a) >> put b | 118 | disposeMesh (GPUMesh _ GPUData{..}) = mapM_ disposeBuffer dBuffers |
213 | get = do | ||
214 | a <- get | ||
215 | b <- get | ||
216 | return $! Mesh (Map.fromList a) b Nothing | ||