module Graphics.LambdaCube.VertexBufferVector where
import Control.Applicative
import Control.Monad
import Data.List (foldl')
import Data.Vector (Vector)
import Data.Word
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import Graphics.LambdaCube.HardwareBuffer
import Graphics.LambdaCube.HardwareIndexBuffer
import Graphics.LambdaCube.HardwareVertexBuffer
import Graphics.LambdaCube.Mesh
import Graphics.LambdaCube.RenderOperation
import Graphics.LambdaCube.RenderSystem
import Graphics.LambdaCube.Types hiding (Vector)
import Graphics.LambdaCube.VertexIndexData
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
data VectorVertexType
= VVT_POSITION
| VVT_BLEND_WEIGHTS
| VVT_BLEND_INDICES
| VVT_NORMAL
| VVT_DIFFUSE
| VVT_SPECULAR
| VVT_TEXTURE_COORDINATES1
| VVT_TEXTURE_COORDINATES2
| VVT_TEXTURE_COORDINATES3
| VVT_BINORMAL
| VVT_TANGENT
deriving (Eq,Ord,Show)
data VectorVertexData
= VVD_POSITION (Vector Vec3)
| VVD_BLEND_WEIGHTS (Vector FloatType)
| VVD_BLEND_INDICES (Vector Int)
| VVD_NORMAL (Vector Vec3)
| VVD_DIFFUSE (Vector Vec4)
| VVD_SPECULAR (Vector Vec4)
| VVD_TEXTURE_COORDINATES1 (Vector FloatType)
| VVD_TEXTURE_COORDINATES2 (Vector Vec2)
| VVD_TEXTURE_COORDINATES3 (Vector Vec3)
| VVD_BINORMAL (Vector Vec3)
| VVD_TANGENT (Vector Vec3)
deriving (Show)
type VVB = Vector VectorVertexData
type VIB = Vector Int
data VMesh
= VMesh
{ vmSubMeshList :: [VSubMesh]
, vmSharedVertexData :: Maybe VVB
}
data VSubMesh
= VSubMesh
{ vsmMaterialName :: String
, vsmOperationType :: OperationType
, vsmVertexData :: Maybe VVB
, vsmIndexData :: Maybe VIB
}
vectorVertexType :: VectorVertexData -> VectorVertexType
vectorVertexType v = case v of
VVD_POSITION _ -> VVT_POSITION
VVD_BLEND_WEIGHTS _ -> VVT_BLEND_WEIGHTS
VVD_BLEND_INDICES _ -> VVT_BLEND_INDICES
VVD_NORMAL _ -> VVT_NORMAL
VVD_DIFFUSE _ -> VVT_DIFFUSE
VVD_SPECULAR _ -> VVT_SPECULAR
VVD_TEXTURE_COORDINATES1 _ -> VVT_TEXTURE_COORDINATES1
VVD_TEXTURE_COORDINATES2 _ -> VVT_TEXTURE_COORDINATES2
VVD_TEXTURE_COORDINATES3 _ -> VVT_TEXTURE_COORDINATES3
VVD_BINORMAL _ -> VVT_BINORMAL
VVD_TANGENT _ -> VVT_TANGENT
toVectorIndexData :: HardwareIndexBuffer ib => IndexData ib -> IO VIB
toVectorIndexData idata = do
let ib = idIndexBuffer idata
n = idIndexCount idata
isize = getIndexSize ib
buf <- lock ib (idIndexStart idata * isize) (n * isize) HBL_READ_ONLY
v <- MV.new n
case getIndexType ib of
IT_16BIT -> forM [0..n1] $ \i -> do
a <- peek $ plusPtr buf $ i*isize :: IO Word16
MV.write v i $ fromIntegral a
IT_32BIT -> forM [0..n1] $ \i -> do
a <- peek $ plusPtr buf $ i*isize :: IO Word32
MV.write v i $ fromIntegral a
unlock ib
V.freeze v
fromVectorIndexData :: (RenderSystem rs vb ib q t p lp) => rs -> VIB -> IO (IndexData ib)
fromVectorIndexData rs vib = do
let indexCount = V.length vib
usage = HBU_STATIC
ib <- createIndexBuffer rs IT_32BIT indexCount usage True
ptr <- lock ib 0 (getSizeInBytes ib) HBL_NORMAL
pokeArray (castPtr ptr) $ map (fromIntegral :: Int -> Word32) $ V.toList vib
unlock ib
return $ IndexData
{ idIndexBuffer = ib
, idIndexStart = 0
, idIndexCount = indexCount
}
toVectorVertexData :: HardwareVertexBuffer vb => VertexData vb -> IO (Vector VectorVertexData)
toVectorVertexData vd = do
let n = vdVertexCount vd
vl = vdElementList $ vdVertexDeclaration vd
vbmap = vbbBindingMap $ vdVertexBufferBinding vd
g ve f = do
let vb = vbmap IntMap.! (veSource ve)
vsize = getVertexSize vb
buf <- lock vb 0 (getSizeInBytes vb) HBL_READ_ONLY
let p0 = plusPtr buf $ veOffset ve
v <- MV.new n
forM [0..n1] $ \i -> do
a <- peek $ plusPtr p0 $ i*vsize
MV.write v i $ f a
unlock vb
V.freeze v
gv ve = g ve id
gs ve = g ve id
createVDVector ve = case (veSemantic ve, veType ve) of
(VES_POSITION,VET_FLOAT3) -> VVD_POSITION <$> gv ve
(VES_BLEND_WEIGHTS,VET_FLOAT1) -> VVD_BLEND_WEIGHTS <$> gs ve
(VES_BLEND_INDICES,VET_SHORT1) -> VVD_BLEND_INDICES <$> gs ve
(VES_NORMAL,VET_FLOAT3) -> VVD_NORMAL <$> gv ve
(VES_DIFFUSE,VET_COLOUR_ABGR) -> VVD_DIFFUSE <$> gv ve
(VES_SPECULAR,VET_COLOUR_ABGR) -> VVD_SPECULAR <$> gv ve
(VES_TEXTURE_COORDINATES,VET_FLOAT1) -> VVD_TEXTURE_COORDINATES1 <$> gs ve
(VES_TEXTURE_COORDINATES,VET_FLOAT2) -> VVD_TEXTURE_COORDINATES2 <$> gv ve
(VES_TEXTURE_COORDINATES,VET_FLOAT3) -> VVD_TEXTURE_COORDINATES3 <$> gv ve
(VES_BINORMAL,VET_FLOAT3) -> VVD_BINORMAL <$> gv ve
(VES_TANGENT,VET_FLOAT3) -> VVD_TANGENT <$> gv ve
_ -> error "Not supported vertex buffer format"
l <- mapM createVDVector vl
return $ V.fromList l
fromVectorVertexData :: (RenderSystem rs vb ib q t p lp) => rs -> Vector VectorVertexData -> IO (VertexData vb)
fromVectorVertexData rs vd = do
let
(size,_,elems,vcount) = foldl' f (0,Map.empty,[],0) $ V.toList vd
f (o,m,ex,_) ve = (o + getTypeSize vt, Map.insert vs (i+1) m,(vf,VertexElement 0 o vt vs i):ex,vc)
where
i = (Map.findWithDefault 0 vs m)
(vs,vt,vf,vc) = cf ve
g a ptr vsize = V.foldM' (\p ed -> do poke (castPtr p) ed; return $ plusPtr p vsize) (plusPtr ptr o) a
g' a ptr vsize = V.foldM' (\p ed -> do poke (castPtr p) ed; return $ plusPtr p vsize) (plusPtr ptr o) a
cf t = case t of
VVD_POSITION a -> (VES_POSITION,VET_FLOAT3,g a,V.length a)
VVD_BLEND_WEIGHTS a -> (VES_BLEND_WEIGHTS,VET_FLOAT1,g' a,V.length a)
VVD_BLEND_INDICES a -> (VES_BLEND_INDICES,VET_SHORT1,g' a,V.length a)
VVD_NORMAL a -> (VES_NORMAL,VET_FLOAT3,g a,V.length a)
VVD_DIFFUSE a -> (VES_DIFFUSE,VET_COLOUR_ABGR,g a,V.length a)
VVD_SPECULAR a -> (VES_SPECULAR,VET_COLOUR_ABGR,g a,V.length a)
VVD_TEXTURE_COORDINATES1 a -> (VES_TEXTURE_COORDINATES,VET_FLOAT1,g' a,V.length a)
VVD_TEXTURE_COORDINATES2 a -> (VES_TEXTURE_COORDINATES,VET_FLOAT2,g a,V.length a)
VVD_TEXTURE_COORDINATES3 a -> (VES_TEXTURE_COORDINATES,VET_FLOAT3,g a,V.length a)
VVD_BINORMAL a -> (VES_BINORMAL,VET_FLOAT3,g a,V.length a)
VVD_TANGENT a -> (VES_TANGENT,VET_FLOAT3,g a,V.length a)
decl = VertexDeclaration $ map snd elems
usage = HBU_STATIC
bufs <- mapM (\s -> createVertexBuffer rs s vcount usage True) [size]
let binding = VertexBufferBinding $ IntMap.fromList $ zip [0..] bufs
fillBuffer (d,b) = do
ptr <- lock b 0 (getSizeInBytes b) HBL_NORMAL
let vsize = getVertexSize b
fillAttribute (vf,_) = vf ptr vsize
mapM_ fillAttribute d
unlock b
mapM_ fillBuffer $ zip [elems] bufs
return $ VertexData decl binding 0 vcount
meshFromV :: (RenderSystem rs vb ib q t p lp) => rs -> VMesh -> IO (Mesh vb ib)
meshFromV rs vmesh = do
let convMVVD mvvd = case mvvd of
Nothing -> return Nothing
Just vvd -> Just <$> fromVectorVertexData rs vvd
convMVID mvid = case mvid of
Nothing -> return Nothing
Just vid -> Just <$> fromVectorIndexData rs vid
sm <- forM (vmSubMeshList vmesh) $ \vsm -> do
vdata <- convMVVD $ vsmVertexData vsm
idata <- convMVID $ vsmIndexData vsm
return $ SubMesh
{ smOperationType = vsmOperationType vsm
, smVertexData = vdata
, smIndexData = idata
, smMaterialName = vsmMaterialName vsm
}
svd <- convMVVD $ vmSharedVertexData vmesh
let mesh = Mesh
{ msSubMeshList = sm
, msSharedVertexData = svd
, msBoundRadius = undefined
}
r <- calculateBoundingRadius mesh
return mesh { msBoundRadius = r }
vFromMesh :: (HardwareVertexBuffer vb, HardwareIndexBuffer ib) => Mesh vb ib -> IO VMesh
vFromMesh mesh = do
let convMVD mvd = case mvd of
Nothing -> return Nothing
Just vd -> Just <$> toVectorVertexData vd
convMID mid = case mid of
Nothing -> return Nothing
Just ixd -> Just <$> toVectorIndexData ixd
vsm <- forM (msSubMeshList mesh) $ \sm -> do
vdata <- convMVD $ smVertexData sm
idata <- convMID $ smIndexData sm
return $ VSubMesh (smMaterialName sm) (smOperationType sm) vdata idata
vsvd <- convMVD $ msSharedVertexData mesh
return $ VMesh vsm vsvd