summaryrefslogtreecommitdiff
path: root/Backend/GL/Mesh.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Backend/GL/Mesh.hs')
-rw-r--r--Backend/GL/Mesh.hs232
1 files changed, 232 insertions, 0 deletions
diff --git a/Backend/GL/Mesh.hs b/Backend/GL/Mesh.hs
new file mode 100644
index 0000000..261e6cc
--- /dev/null
+++ b/Backend/GL/Mesh.hs
@@ -0,0 +1,232 @@
1{-# LANGUAGE TupleSections #-}
2module Backend.GL.Mesh (
3 loadMesh,
4 saveMesh,
5 addMesh,
6 compileMesh,
7 updateMesh,
8 Mesh(..),
9 MeshPrimitive(..),
10 MeshAttribute(..)
11) where
12
13import Control.Applicative
14import Control.Monad
15import Data.Binary
16import Data.ByteString.Char8 (ByteString)
17import Foreign.Ptr
18import Data.Int
19import Foreign.Storable
20import Foreign.Marshal.Utils
21import System.IO.Unsafe
22import qualified Data.ByteString.Char8 as SB
23import qualified Data.ByteString.Lazy as LB
24import qualified Data.Trie as T
25import qualified Data.Vector.Storable as V
26import qualified Data.Vector.Storable.Mutable as MV
27
28import Backend.GL
29import Backend.GL.Type as T
30import IR as IR
31
32fileVersion :: Int32
33fileVersion = 1
34
35data MeshAttribute
36 = A_Float (V.Vector Float)
37 | A_V2F (V.Vector V2F)
38 | A_V3F (V.Vector V3F)
39 | A_V4F (V.Vector V4F)
40 | A_M22F (V.Vector M22F)
41 | A_M33F (V.Vector M33F)
42 | A_M44F (V.Vector M44F)
43 | A_Int (V.Vector Int32)
44 | A_Word (V.Vector Word32)
45
46data MeshPrimitive
47 = P_Points
48 | P_TriangleStrip
49 | P_Triangles
50 | P_TriangleStripI (V.Vector Int32)
51 | P_TrianglesI (V.Vector Int32)
52
53data Mesh
54 = Mesh
55 { mAttributes :: T.Trie MeshAttribute
56 , mPrimitive :: MeshPrimitive
57 , mGPUData :: Maybe GPUData
58 }
59
60data GPUData
61 = GPUData
62 { dPrimitive :: Primitive
63 , dStreams :: T.Trie (Stream Buffer)
64 , dIndices :: Maybe (IndexStream Buffer)
65 }
66
67loadMesh :: String -> IO Mesh
68loadMesh n = compileMesh =<< decode <$> LB.readFile n
69
70saveMesh :: String -> Mesh -> IO ()
71saveMesh n m = LB.writeFile n (encode m)
72
73addMesh :: GLPipelineInput -> ByteString -> Mesh -> [ByteString] -> IO Object
74addMesh input slotName (Mesh _ _ (Just (GPUData prim streams indices))) objUniNames = do
75 -- select proper attributes
76 let Just (SlotSchema slotPrim slotStreams) = T.lookup slotName $! T.slots $! T.schema input
77 filterStream n s
78 | T.member n slotStreams = Just s
79 | otherwise = Nothing
80 addObject input slotName prim indices (T.mapBy filterStream streams) objUniNames
81addMesh _ _ _ _ = fail "addMesh: only compiled mesh with GPUData is supported"
82
83withV w a f = w a (\p -> f $ castPtr p)
84
85meshAttrToArray :: MeshAttribute -> Array
86meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV V.unsafeWith v
87meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV V.unsafeWith v
88meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV V.unsafeWith v
89meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v
90meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV V.unsafeWith v
91meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV V.unsafeWith v
92meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV V.unsafeWith v
93meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV V.unsafeWith v
94meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV V.unsafeWith v
95
96meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer
97meshAttrToStream b i (A_Float v) = Stream TFloat b i 0 (V.length v)
98meshAttrToStream b i (A_V2F v) = Stream TV2F b i 0 (V.length v)
99meshAttrToStream b i (A_V3F v) = Stream TV3F b i 0 (V.length v)
100meshAttrToStream b i (A_V4F v) = Stream TV4F b i 0 (V.length v)
101meshAttrToStream b i (A_M22F v) = Stream TM22F b i 0 (V.length v)
102meshAttrToStream b i (A_M33F v) = Stream TM33F b i 0 (V.length v)
103meshAttrToStream b i (A_M44F v) = Stream TM44F b i 0 (V.length v)
104meshAttrToStream b i (A_Int v) = Stream TInt b i 0 (V.length v)
105meshAttrToStream b i (A_Word v) = Stream TWord b i 0 (V.length v)
106
107{-
108updateBuffer :: Buffer -> [(Int,Array)] -> IO ()
109
110 | Stream
111 { streamType :: StreamType
112 , streamBuffer :: b
113 , streamArrIdx :: Int
114 , streamStart :: Int
115 , streamLength :: Int
116 }
117
118-- stream of index values (for index buffer)
119data IndexStream b
120 = IndexStream
121 { indexBuffer :: b
122 , indexArrIdx :: Int
123 , indexStart :: Int
124 , indexLength :: Int
125 }
126-}
127updateMesh :: Mesh -> [(ByteString,MeshAttribute)] -> Maybe MeshPrimitive -> IO ()
128updateMesh (Mesh dMA dMP (Just (GPUData _ dS dI))) al mp = do
129 -- check type match
130 let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2
131 ok = and [T.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) | (n,a1) <- al, let Just a2 = T.lookup n dMA]
132 if not ok then putStrLn "updateMesh: attribute mismatch!"
133 else do
134 forM_ al $ \(n,a) -> do
135 case T.lookup n dS of
136 Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)]
137 _ -> return ()
138{-
139 case mp of
140 Nothing -> return ()
141 Just p -> do
142 let ok2 = case (dMP,p) of
143 (Just (P_TriangleStripI v1, P_TriangleStripI v2) -> V.length v1 == V.length v2
144 (P_TrianglesI v1, P_TrianglesI v2) -> V.length v1 == V.length v2
145 (a,b) -> a == b
146-}
147
148compileMesh :: Mesh -> IO Mesh
149compileMesh (Mesh attrs mPrim Nothing) = do
150 let mkIndexBuf v = do
151 iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV V.unsafeWith v]
152 return $! Just $! IndexStream iBuf 0 0 (V.length v)
153 vBuf <- compileBuffer [meshAttrToArray a | a <- T.elems attrs]
154 (indices,prim) <- case mPrim of
155 P_Points -> return (Nothing,PointList)
156 P_TriangleStrip -> return (Nothing,TriangleStrip)
157 P_Triangles -> return (Nothing,TriangleList)
158 P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v
159 P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v
160 let streams = T.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (T.toList attrs)
161 gpuData = GPUData prim streams indices
162 return $! Mesh attrs mPrim (Just gpuData)
163
164compileMesh mesh = return mesh
165
166sblToV :: Storable a => [SB.ByteString] -> V.Vector a
167sblToV ls = v
168 where
169 offs o (s:xs) = (o,s):offs (o + SB.length s) xs
170 offs _ [] = []
171 cnt = sum (map SB.length ls) `div` (sizeOf $ V.head v)
172 v = unsafePerformIO $ do
173 mv <- MV.new cnt
174 MV.unsafeWith mv $ \dst -> forM_ (offs 0 ls) $ \(o,s) ->
175 SB.useAsCStringLen s $ \(src,len) -> moveBytes (plusPtr dst o) src len
176 V.unsafeFreeze mv
177
178vToSB :: Storable a => V.Vector a -> SB.ByteString
179vToSB v = unsafePerformIO $ do
180 let len = V.length v * sizeOf (V.head v)
181 V.unsafeWith v $ \p -> SB.packCStringLen (castPtr p,len)
182
183instance Storable a => Binary (V.Vector a) where
184 put v = put $ vToSB v
185 get = do s <- get ; return $ sblToV [s]
186
187instance Binary MeshAttribute where
188 put (A_Float a) = putWord8 0 >> put a
189 put (A_V2F a) = putWord8 1 >> put a
190 put (A_V3F a) = putWord8 2 >> put a
191 put (A_V4F a) = putWord8 3 >> put a
192 put (A_M22F a) = putWord8 4 >> put a
193 put (A_M33F a) = putWord8 5 >> put a
194 put (A_M44F a) = putWord8 6 >> put a
195 put (A_Int a) = putWord8 7 >> put a
196 put (A_Word a) = putWord8 8 >> put a
197 get = do
198 tag_ <- getWord8
199 case tag_ of
200 0 -> A_Float <$> get
201 1 -> A_V2F <$> get
202 2 -> A_V3F <$> get
203 3 -> A_V4F <$> get
204 4 -> A_M22F <$> get
205 5 -> A_M33F <$> get
206 6 -> A_M44F <$> get
207 7 -> A_Int <$> get
208 8 -> A_Word <$> get
209 _ -> fail "no parse"
210
211instance Binary MeshPrimitive where
212 put P_Points = putWord8 0
213 put P_TriangleStrip = putWord8 1
214 put P_Triangles = putWord8 2
215 put (P_TriangleStripI a) = putWord8 3 >> put a
216 put (P_TrianglesI a) = putWord8 4 >> put a
217 get = do
218 tag_ <- getWord8
219 case tag_ of
220 0 -> return P_Points
221 1 -> return P_TriangleStrip
222 2 -> return P_Triangles
223 3 -> P_TriangleStripI <$> get
224 4 -> P_TrianglesI <$> get
225 _ -> fail "no parse"
226
227instance Binary Mesh where
228 put (Mesh a b _) = put (T.toList a) >> put b
229 get = do
230 a <- get
231 b <- get
232 return $! Mesh (T.fromList a) b Nothing
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-10 01:05:43 +0000