1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
{-# LANGUAGE TupleSections, RecordWildCards #-}
module LambdaCube.GL.Mesh (
addMeshToObjectArray,
uploadMeshToGPU,
disposeMesh,
updateMesh,
Mesh(..),
MeshPrimitive(..),
MeshAttribute(..),
GPUMesh(..), GPUData(..),
) where
import Data.Maybe
import Control.Applicative
import Control.Monad
import Foreign.Ptr
import Data.Int
import Foreign.Storable
import Foreign.Marshal.Utils
import System.IO.Unsafe
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Vector as V
import qualified Data.Vector.Storable as SV
import qualified Data.Vector.Storable.Mutable as MV
import qualified Data.ByteString.Char8 as SB
import qualified Data.ByteString.Lazy as LB
import LambdaCube.GL
import LambdaCube.GL.Type as T
import LambdaCube.IR as IR
import LambdaCube.Linear as IR
import LambdaCube.Mesh
data GPUData
= GPUData
{ dPrimitive :: Primitive
, dStreams :: Map String (Stream Buffer)
, dIndices :: Maybe (IndexStream Buffer)
, dBuffers :: [Buffer]
}
data GPUMesh
= GPUMesh
{ meshData :: Mesh
, gpuData :: GPUData
}
addMeshToObjectArray :: GLStorage
-> String -- ^ Slot name for a PrimitiveStream.
-> [String] -- ^ Uniform names. IORefs will be put in 'objUniSetup'.
-> GPUMesh
-> IO Object
addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do
-- select proper attributes
let (ObjectArraySchema slotPrim slotStreams) = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName) $ Map.lookup slotName $! objectArrays $! schema input
filterStream n _ = Map.member n slotStreams
addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames
withV :: (v a -> (Ptr a -> io) -> io) -> v a -> (Ptr () -> io) -> io
withV w a f = w a (\p -> f $ castPtr p)
meshAttrToArray :: MeshAttribute -> Array
meshAttrToArray (A_Float v) = Array ArrFloat (1 * V.length v) $ withV SV.unsafeWith $ V.convert v
meshAttrToArray (A_V2F v) = Array ArrFloat (2 * V.length v) $ withV SV.unsafeWith $ V.convert v
meshAttrToArray (A_V3F v) = Array ArrFloat (3 * V.length v) $ withV SV.unsafeWith $ V.convert v
meshAttrToArray (A_V4F v) = Array ArrFloat (4 * V.length v) $ withV SV.unsafeWith $ V.convert v
meshAttrToArray (A_M22F v) = Array ArrFloat (4 * V.length v) $ withV SV.unsafeWith $ V.convert v
meshAttrToArray (A_M33F v) = Array ArrFloat (9 * V.length v) $ withV SV.unsafeWith $ V.convert v
meshAttrToArray (A_M44F v) = Array ArrFloat (16 * V.length v) $ withV SV.unsafeWith $ V.convert v
meshAttrToArray (A_Int v) = Array ArrInt32 (1 * V.length v) $ withV SV.unsafeWith $ V.convert v
meshAttrToArray (A_Word v) = Array ArrWord32 (1 * V.length v) $ withV SV.unsafeWith $ V.convert v
meshAttrToStream :: Buffer -> Int -> MeshAttribute -> Stream Buffer
meshAttrToStream b i (A_Float v) = Stream Attribute_Float b i 0 (V.length v)
meshAttrToStream b i (A_V2F v) = Stream Attribute_V2F b i 0 (V.length v)
meshAttrToStream b i (A_V3F v) = Stream Attribute_V3F b i 0 (V.length v)
meshAttrToStream b i (A_V4F v) = Stream Attribute_V4F b i 0 (V.length v)
meshAttrToStream b i (A_M22F v) = Stream Attribute_M22F b i 0 (V.length v)
meshAttrToStream b i (A_M33F v) = Stream Attribute_M33F b i 0 (V.length v)
meshAttrToStream b i (A_M44F v) = Stream Attribute_M44F b i 0 (V.length v)
meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v)
meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v)
-- | Update a mesh without allocating new buffer objects. Each update must
-- provide new values for all existing array elements.
updateMesh :: GPUMesh -- ^ Mesh to be updated.
-> [(String,MeshAttribute)] -- ^ A list of updates.
-> Maybe MeshPrimitive -- ^ Ignored.
-> IO ()
updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do
-- check type match
let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2
ok = and [ Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2)
| (n,a1) <- al, let a2 = fromMaybe (error $ "missing mesh attribute: " ++ n) $ Map.lookup n dMA]
if not ok then putStrLn "updateMesh: attribute mismatch!"
else do
forM_ al $ \(n,a) -> do
case Map.lookup n dS of
Just (Stream _ b i _ _) -> updateBuffer b [(i,meshAttrToArray a)]
_ -> return ()
{-
case mp of
Nothing -> return ()
Just p -> do
let ok2 = case (dMP,p) of
(Just (P_TriangleStripI v1, P_TriangleStripI v2) -> V.length v1 == V.length v2
(P_TrianglesI v1, P_TrianglesI v2) -> V.length v1 == V.length v2
(a,b) -> a == b
-}
-- | This allocates buffer objects. Use 'disposeMesh' to free them. Use
-- 'updateMesh' to modify the allocated buffer object data.
uploadMeshToGPU :: Mesh -> IO GPUMesh
uploadMeshToGPU mesh@(Mesh attrs mPrim) = do
let mkIndexBuf v = do
iBuf <- compileBuffer [Array ArrWord32 (V.length v) $ withV SV.unsafeWith $ V.convert v]
return $! Just $! IndexStream iBuf 0 0 (V.length v)
vBuf <- compileBuffer [meshAttrToArray a | a <- Map.elems attrs]
(indices,prim) <- case mPrim of
P_Points -> return (Nothing,PointList)
P_TriangleStrip -> return (Nothing,TriangleStrip)
P_Triangles -> return (Nothing,TriangleList)
P_TriangleStripI v -> (,TriangleStrip) <$> mkIndexBuf v
P_TrianglesI v -> (,TriangleList) <$> mkIndexBuf v
let streams = Map.fromList $! zipWith (\i (n,a) -> (n,meshAttrToStream vBuf i a)) [0..] (Map.toList attrs)
return $! GPUMesh mesh (GPUData prim streams indices (vBuf:[iBuf | IndexStream iBuf _ _ _ <- maybeToList indices]))
disposeMesh :: GPUMesh -> IO ()
disposeMesh (GPUMesh _ GPUData{..}) = mapM_ disposeBuffer dBuffers
|
