diff options
Diffstat (limited to 'src/LambdaCube/GL/Mesh.hs')
-rw-r--r-- | src/LambdaCube/GL/Mesh.hs | 19 |
1 files changed, 16 insertions, 3 deletions
diff --git a/src/LambdaCube/GL/Mesh.hs b/src/LambdaCube/GL/Mesh.hs index 95ca582..384cdd1 100644 --- a/src/LambdaCube/GL/Mesh.hs +++ b/src/LambdaCube/GL/Mesh.hs | |||
@@ -46,13 +46,18 @@ data GPUMesh | |||
46 | , gpuData :: GPUData | 46 | , gpuData :: GPUData |
47 | } | 47 | } |
48 | 48 | ||
49 | addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object | 49 | addMeshToObjectArray :: GLStorage |
50 | -> String -- ^ Slot name for a PrimitiveStream. | ||
51 | -> [String] -- ^ Uniform names. IORefs will be put in 'objUniSetup'. | ||
52 | -> GPUMesh | ||
53 | -> IO Object | ||
50 | addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do | 54 | addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do |
51 | -- select proper attributes | 55 | -- select proper attributes |
52 | let (ObjectArraySchema slotPrim slotStreams) = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName) $ Map.lookup slotName $! objectArrays $! schema input | 56 | let (ObjectArraySchema slotPrim slotStreams) = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName) $ Map.lookup slotName $! objectArrays $! schema input |
53 | filterStream n _ = Map.member n slotStreams | 57 | filterStream n _ = Map.member n slotStreams |
54 | addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames | 58 | addObject input slotName prim indices (Map.filterWithKey filterStream streams) objUniNames |
55 | 59 | ||
60 | withV :: (v a -> (Ptr a -> io) -> io) -> v a -> (Ptr () -> io) -> io | ||
56 | withV w a f = w a (\p -> f $ castPtr p) | 61 | withV w a f = w a (\p -> f $ castPtr p) |
57 | 62 | ||
58 | meshAttrToArray :: MeshAttribute -> Array | 63 | meshAttrToArray :: MeshAttribute -> Array |
@@ -77,11 +82,17 @@ meshAttrToStream b i (A_M44F v) = Stream Attribute_M44F b i 0 (V.length v) | |||
77 | meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v) | 82 | meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v) |
78 | meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v) | 83 | meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v) |
79 | 84 | ||
80 | updateMesh :: GPUMesh -> [(String,MeshAttribute)] -> Maybe MeshPrimitive -> IO () | 85 | -- | Update a mesh without allocating new buffer objects. Each update must |
86 | -- provide new values for all existing array elements. | ||
87 | updateMesh :: GPUMesh -- ^ Mesh to be updated. | ||
88 | -> [(String,MeshAttribute)] -- ^ A list of updates. | ||
89 | -> Maybe MeshPrimitive -- ^ Ignored. | ||
90 | -> IO () | ||
81 | updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do | 91 | updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do |
82 | -- check type match | 92 | -- check type match |
83 | let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 | 93 | let arrayChk (Array t1 s1 _) (Array t2 s2 _) = t1 == t2 && s1 == s2 |
84 | 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] | 94 | ok = and [ Map.member n dMA && arrayChk (meshAttrToArray a1) (meshAttrToArray a2) |
95 | | (n,a1) <- al, let a2 = fromMaybe (error $ "missing mesh attribute: " ++ n) $ Map.lookup n dMA] | ||
85 | if not ok then putStrLn "updateMesh: attribute mismatch!" | 96 | if not ok then putStrLn "updateMesh: attribute mismatch!" |
86 | else do | 97 | else do |
87 | forM_ al $ \(n,a) -> do | 98 | forM_ al $ \(n,a) -> do |
@@ -98,6 +109,8 @@ updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do | |||
98 | (a,b) -> a == b | 109 | (a,b) -> a == b |
99 | -} | 110 | -} |
100 | 111 | ||
112 | -- | This allocates buffer objects. Use 'disposeMesh' to free them. Use | ||
113 | -- 'updateMesh' to modify the allocated buffer object data. | ||
101 | uploadMeshToGPU :: Mesh -> IO GPUMesh | 114 | uploadMeshToGPU :: Mesh -> IO GPUMesh |
102 | uploadMeshToGPU mesh@(Mesh attrs mPrim) = do | 115 | uploadMeshToGPU mesh@(Mesh attrs mPrim) = do |
103 | let mkIndexBuf v = do | 116 | let mkIndexBuf v = do |