summaryrefslogtreecommitdiff
path: root/src/LambdaCube/GL/Mesh.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/LambdaCube/GL/Mesh.hs')
-rw-r--r--src/LambdaCube/GL/Mesh.hs19
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
49addMeshToObjectArray :: GLStorage -> String -> [String] -> GPUMesh -> IO Object 49addMeshToObjectArray :: GLStorage
50 -> String -- ^ Slot name for a PrimitiveStream.
51 -> [String] -- ^ Uniform names. IORefs will be put in 'objUniSetup'.
52 -> GPUMesh
53 -> IO Object
50addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do 54addMeshToObjectArray 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
60withV :: (v a -> (Ptr a -> io) -> io) -> v a -> (Ptr () -> io) -> io
56withV w a f = w a (\p -> f $ castPtr p) 61withV w a f = w a (\p -> f $ castPtr p)
57 62
58meshAttrToArray :: MeshAttribute -> Array 63meshAttrToArray :: MeshAttribute -> Array
@@ -77,11 +82,17 @@ meshAttrToStream b i (A_M44F v) = Stream Attribute_M44F b i 0 (V.length v)
77meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v) 82meshAttrToStream b i (A_Int v) = Stream Attribute_Int b i 0 (V.length v)
78meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v) 83meshAttrToStream b i (A_Word v) = Stream Attribute_Word b i 0 (V.length v)
79 84
80updateMesh :: 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.
87updateMesh :: GPUMesh -- ^ Mesh to be updated.
88 -> [(String,MeshAttribute)] -- ^ A list of updates.
89 -> Maybe MeshPrimitive -- ^ Ignored.
90 -> IO ()
81updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do 91updateMesh (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.
101uploadMeshToGPU :: Mesh -> IO GPUMesh 114uploadMeshToGPU :: Mesh -> IO GPUMesh
102uploadMeshToGPU mesh@(Mesh attrs mPrim) = do 115uploadMeshToGPU mesh@(Mesh attrs mPrim) = do
103 let mkIndexBuf v = do 116 let mkIndexBuf v = do