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