module LambdaCube.GL.Mesh (
addMeshToObjectArray,
uploadMeshToGPU,
disposeMesh,
updateMesh,
Mesh(..),
MeshPrimitive(..),
MeshAttribute(..),
GPUMesh,
meshData
) 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 -> [String] -> GPUMesh -> IO Object
addMeshToObjectArray input slotName objUniNames (GPUMesh _ (GPUData prim streams indices _)) = do
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 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)
updateMesh :: GPUMesh -> [(String,MeshAttribute)] -> Maybe MeshPrimitive -> IO ()
updateMesh (GPUMesh (Mesh dMA dMP) (GPUData _ dS dI _)) al mp = do
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 ()
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