VertexBufferVector.hs

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

-- TODO: fix diffuse and specular types

-- | The types of 'VectorVertexData' without the data.
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)

-- | Primitive buffer data
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 Vec3)
    | 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

-- | Multimaterial geometry, including a default geometry for
-- submeshes that don't provide their own.
data VMesh
    = VMesh
    { vmSubMeshList         :: [VSubMesh]  -- ^ The collection of single-material submeshes making up the mesh.
    , vmSharedVertexData    :: Maybe VVB   -- ^ Default geometry for submeshes.
    }

-- | Geometry with associated material.
data VSubMesh
    = VSubMesh
    { vsmMaterialName   :: String         -- ^ The material associated with the submesh.
    , vsmOperationType  :: OperationType  -- ^ The type of primitives making up the geometry.
    , vsmVertexData     :: Maybe VVB      -- ^ Optional vertex buffer (supplied by the containing mesh if absent).
    , vsmIndexData      :: Maybe VIB      -- ^ Optional index buffer.
    }

-- | Extract the type of the vertex data.
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

{-
    TODO:
        - implement interleaved to non-interleaved vertex buffer conversion function
        - implement much faster VectorVertexData conversion via storable vector interface
-}
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..n-1] $ \i -> do
                a <- peek $ plusPtr buf $ i*isize :: IO Word16
                MV.write v i $ fromIntegral a
        IT_32BIT -> forM [0..n-1] $ \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 -- TODO
    -- create IndexData
    ib <- createIndexBuffer rs IT_32BIT indexCount usage True
    -- 1. lock buffer
    ptr <- lock ib 0 (getSizeInBytes ib) HBL_NORMAL
    -- 2. fill buffer
    pokeArray (castPtr ptr) $ map (fromIntegral :: Int -> Word32) $ V.toList vib
    -- 3. unlock buffer
    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..n-1] $ \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_FLOAT4)                -> VVD_DIFFUSE <$> gv ve
            (VES_SPECULAR,VET_FLOAT3)               -> 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 -- aggregated type: offset, veIndex Map, [VertexElement], vertex count
        (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_FLOAT4,g a,V.length a)
                VVD_SPECULAR a              -> (VES_SPECULAR,VET_FLOAT3,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)
        -- create VertexDeclaration
        decl = VertexDeclaration $ map snd elems
        -- create VertexBufferBinding
        usage = HBU_STATIC -- TODO

    --debugM "fromVectorVertexData" $ "gemetry declaration: " ++ show decl

    bufs <- mapM (\s -> createVertexBuffer rs s vcount usage True) [size]
    let binding = VertexBufferBinding $ IntMap.fromList $ zip [0..] bufs
        fillBuffer (d,b) = do
            -- 1. lock buffer
            ptr <- lock b 0 (getSizeInBytes b) HBL_NORMAL
            let vsize = getVertexSize b
                fillAttribute (vf,_) = vf ptr vsize
            -- 2. fill vertex attributes according declaration
            mapM_ fillAttribute d
            -- 3. unlock buffer
            unlock b
            -- end fillBuffer

    -- fill buffers with data
    mapM_ fillBuffer $ zip [elems] bufs

    -- create VertexData
    return $ VertexData decl binding 0 vcount

-- utility functions
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