FVF.hs

module DirectX9.D3D.Utility.FVF
where
import Foreign.Marshal.Array ( pokeArray )
import Foreign.Ptr  ( Ptr, plusPtr )
import Foreign.Storable ( pokeByteOff )

import DirectX9.Types
import DirectX9.D3D.Raw
import DirectX9.D3D.Format
import DirectX9.D3D.Constant
import DirectX9.D3D.Device
import DirectX9.D3D.Resource


class FVF a where
    sizeOfOne :: a -> Int
    sizeOfAll :: a -> Int
    fvfFlags :: a -> D3DFVF
    writeFVF :: a -> Ptr b -> IO (Ptr b)

-- todo: optimise indexes that can fit into 16-bits
fvfCreateIndexBuffer :: (Num a, Storable a) => Device -> DWORD -> D3DPOOL -> [a] -> IO IndexBuffer
fvfCreateIndexBuffer dev usage pool arr = do
    ib <- devCreateIndexBuffer dev bytes usage format pool
    withLockedIndexBuffer ib 0 bytes 0 $ flip pokeArray arr
    return ib
    where
        (format,bytes) = case (sizeOf (arr!!0)) of
            4 -> (d3DFMT_INDEX32, 4*(length arr))
            2 -> (d3DFMT_INDEX16, 2*(length arr))
            _ -> (0,0)


fvfToVertexElems :: D3DFVF -> [D3DVERTEXELEMENT9]
fvfToVertexElems fvf = reverse $ foldl offset [] $ concat $ snd $ foldl fun (fvf,[]) fields
    where
        fun :: (D3DFVF, [[a]]) -> (D3DFVF,[a]) -> (D3DFVF,[[a]])
        fun (fvf, old) (f, d)
            | f<=fvf            = ((fvf-f),d:old)
            | otherwise         = (fvf,old)
        nextOffset [] = 0
        nextOffset (x:_) =
            d3DVERTEXELEMENT9_Offset x
            + case lookup (d3DVERTEXELEMENT9_Type x) sizes of
                Just x -> x
                Nothing -> 999
        sizes = 
            [(d3DDECLTYPE_FLOAT2    ,8)
            ,(d3DDECLTYPE_FLOAT3    ,12)
            ,(d3DDECLTYPE_FLOAT4    ,16)
            ,(d3DDECLTYPE_D3DCOLOR   ,4)
            ]
        offset old (t,u) = (D3DVERTEXELEMENT9 0 (nextOffset old) t d3DDECLMETHOD_DEFAULT u 0 ):old
        fields =
            [(d3DFVF_TEX8,      replicate 8 (d3DDECLTYPE_FLOAT2,d3DDECLUSAGE_TEXCOORD))
            ,(d3DFVF_TEX7,      replicate 7 (d3DDECLTYPE_FLOAT2,d3DDECLUSAGE_TEXCOORD))
            ,(d3DFVF_TEX6,      replicate 6 (d3DDECLTYPE_FLOAT2,d3DDECLUSAGE_TEXCOORD))
            ,(d3DFVF_TEX5,      replicate 5 (d3DDECLTYPE_FLOAT2,d3DDECLUSAGE_TEXCOORD))
            ,(d3DFVF_TEX4,      replicate 4 (d3DDECLTYPE_FLOAT2,d3DDECLUSAGE_TEXCOORD))
            ,(d3DFVF_TEX3,      replicate 3 (d3DDECLTYPE_FLOAT2,d3DDECLUSAGE_TEXCOORD))
            ,(d3DFVF_TEX2,      replicate 2 (d3DDECLTYPE_FLOAT2,d3DDECLUSAGE_TEXCOORD))
            ,(d3DFVF_TEX1,      replicate 1 (d3DDECLTYPE_FLOAT2,d3DDECLUSAGE_TEXCOORD))
            ,(d3DFVF_SPECULAR,  [(d3DDECLTYPE_D3DCOLOR,d3DDECLUSAGE_COLOR)])
            ,(d3DFVF_DIFFUSE,   [(d3DDECLTYPE_D3DCOLOR,d3DDECLUSAGE_COLOR)])
            ,(d3DFVF_NORMAL,    [(d3DDECLTYPE_FLOAT3,d3DDECLUSAGE_NORMAL)])
            ,(d3DFVF_XYZRHW,    [(d3DDECLTYPE_FLOAT4,d3DDECLUSAGE_POSITION)])
            ,(d3DFVF_XYZ,       [(d3DDECLTYPE_FLOAT3,d3DDECLUSAGE_POSITION)])
            ]


fvfCreateVertexBuffer :: (FVF a) => Device -> DWORD -> D3DPOOL -> a -> IO VertexBuffer
fvfCreateVertexBuffer dev usage pool o = do
    vb <- devCreateVertexBuffer dev bytes usage (fvfFlags o) pool
    withLockedVertexBuffer vb 0 bytes 0 (writeFVF o)
    return vb
    where bytes = sizeOfAll o

fvfCreateVertexDeclaration :: (FVF a) => Device -> Int -> a -> IO VertexDeclaration
fvfCreateVertexDeclaration dev stream fvf = devCreateVertexDeclaration dev decl
    where
        setStream x = x { d3DVERTEXELEMENT9_Stream = fromIntegral stream}
        decl = map setStream $ fvfToVertexElems $ fvfFlags fvf

    
type FVFVector4 = (Float,Float,Float,Float)
type FVFVector3 = (Float,Float,Float)
type FVFVector2 = (Float,Float)

writeFVFV4 :: FVFVector4 -> Ptr a -> IO (Ptr a)
writeFVFV4 (v1,v2,v3,v4) b = do
    pokeByteOff b 0 v1
    pokeByteOff b 4 v2
    pokeByteOff b 8 v3
    pokeByteOff b 12 v4
    return $ plusPtr b 16

writeFVFV3 :: FVFVector3 -> Ptr a -> IO (Ptr a)
writeFVFV3 (v1,v2,v3) b = do
    pokeByteOff b 0 v1
    pokeByteOff b 4 v2
    pokeByteOff b 8 v3
    return $ plusPtr b 12

writeFVFV2 :: FVFVector2 -> Ptr a -> IO (Ptr a)
writeFVFV2 (v1,v2) b = do
    pokeByteOff b 0 v1
    pokeByteOff b 4 v2
    return $ plusPtr b 8

writeFVFD :: D3DCOLOR -> Ptr a -> IO (Ptr a)
writeFVFD v b = do
    pokeByteOff b 0 v
    return $ plusPtr b 4

writeFVF' :: (a -> Ptr b -> IO (Ptr b)) -> [a] -> Ptr b -> IO (Ptr b)
writeFVF' f a s = foldl (\x y -> x >>= f y) (return s) a

newtype PosF = PosF [FVFVector3]
newtype PosNormF = PosNormF [(FVFVector3,FVFVector3)]
newtype PosDiffF = PosDiffF [(FVFVector3, D3DCOLOR)]
newtype PosNormDiffF = PosNormDiffF [(FVFVector3, FVFVector3, D3DCOLOR)]
newtype PosTexF = PosTexF [(FVFVector3, FVFVector2)]
newtype PosNormTexF = PosNormTexF [(FVFVector3, FVFVector3, FVFVector2)]

instance FVF PosF where
    sizeOfOne _ = 4*3
    sizeOfAll (PosF a) = (4*3) * length a
    fvfFlags _ = d3DFVF_XYZ
    writeFVF (PosF v) = writeFVF' w v
        where w v b = writeFVFV3 v b

instance FVF PosNormF where
    sizeOfOne _ = 4*3+4*3
    sizeOfAll (PosNormF v) = (4*3+4*3) * length v
    fvfFlags _ = d3DFVF_XYZ + d3DFVF_NORMAL
    writeFVF (PosNormF v) = writeFVF' w v
        where w (v,n) b = return b >>= writeFVFV3 v >>= writeFVFV3 n

instance FVF PosDiffF where
    sizeOfOne _ = 4*3+4
    sizeOfAll (PosDiffF v) = (4*3+3) * length v
    fvfFlags _ = d3DFVF_XYZ + d3DFVF_DIFFUSE
    writeFVF (PosDiffF v) = writeFVF' w v
        where w (v,d) b = return b >>= writeFVFV3 v >>= writeFVFD d

instance FVF PosNormDiffF where
    sizeOfOne _ = 4*3+4*3+4
    sizeOfAll (PosNormDiffF v) = (4*3+4*3+4) * length v
    fvfFlags _ = d3DFVF_XYZ+d3DFVF_NORMAL+d3DFVF_DIFFUSE
    writeFVF (PosNormDiffF v) = writeFVF' w v
        where w (v,n,d) b = return b >>= writeFVFV3 v >>= writeFVFV3 n >>= writeFVFD d

instance FVF PosTexF where
    sizeOfOne _ = 4*3+4*2
    sizeOfAll (PosTexF v) = (4*3+4*2) * length v
    fvfFlags _ = d3DFVF_XYZ+d3DFVF_TEX1
    writeFVF (PosTexF v) = writeFVF' w v
        where w (v,t) b = return b >>= writeFVFV3 v >>= writeFVFV2 t

instance FVF PosNormTexF where
    sizeOfOne _ = 4*3+4*3+4*2
    sizeOfAll (PosNormTexF v) = (4*3+4*3+4*2) * length v
    fvfFlags _ = d3DFVF_XYZ+d3DFVF_NORMAL+d3DFVF_TEX1
    writeFVF (PosNormTexF v) = writeFVF' w v
        where w (v,n,t) b = return b >>= writeFVFV3 v >>= writeFVFV3 n >>= writeFVFV2 t