module Graphics.LambdaCube.Loader.VMesh where

import Control.Applicative
import Data.Binary
import Data.Vect
import Foreign
import qualified Data.ByteString.Lazy as LB
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as M

import Graphics.LambdaCube.RenderOperation
import Graphics.LambdaCube.VertexBufferVector

instance Binary Vec2 where
    put (Vec2 a b) = put a >> put b
    get = Vec2 <$> get <*> get

instance Binary Vec3 where
    put (Vec3 a b c) = put a >> put b >> put c
    get = Vec3 <$> get <*> get <*> get

instance Binary Vec4 where
    put (Vec4 a b c d) = put a >> put b >> put c >> put d
    get = Vec4 <$> get <*> get <*> get <*> get

instance Binary Mat2 where
    put (Mat2 a b) = put a >> put b
    get = Mat2 <$> get <*> get

instance Binary Mat3 where
    put (Mat3 a b c) = put a >> put b >> put c
    get = Mat3 <$> get <*> get <*> get

instance Binary Mat4 where
    put (Mat4 a b c d) = put a >> put b >> put c >> put d
    get = Mat4 <$> get <*> get <*> get <*> get

instance (Binary a) => Binary (V.Vector a) where
    put v = do
        put (V.length v)
        mapM_ put (V.toList v)

    -- this is morally sound, if very awkward.
    -- all effects are contained, and can't escape the unsafeFreeze
    {-# INLINE get #-}
    get = do
        n  <- get

        -- new unitinialized array
        mv <- lift $ M.new n

        let fill i
                | i < n = do
                    x <- get
                    (unsafePerformIO $ M.unsafeWrite mv i x) `seq` return ()
                    fill (i+1)

                | otherwise = return ()

        fill 0

        lift $ V.unsafeFreeze mv

lift = return .unsafePerformIO

instance Binary VectorVertexData where
    put (VVD_POSITION a)             = putWord8 0 >> put a
    put (VVD_BLEND_WEIGHTS a)        = putWord8 1 >> put a
    put (VVD_BLEND_INDICES a)        = putWord8 2 >> put a
    put (VVD_NORMAL a)               = putWord8 3 >> put a
    put (VVD_DIFFUSE a)              = putWord8 4 >> put a
    put (VVD_SPECULAR a)             = putWord8 5 >> put a
    put (VVD_TEXTURE_COORDINATES1 a) = putWord8 6 >> put a
    put (VVD_TEXTURE_COORDINATES2 a) = putWord8 7 >> put a
    put (VVD_TEXTURE_COORDINATES3 a) = putWord8 8 >> put a
    put (VVD_BINORMAL a)             = putWord8 9 >> put a
    put (VVD_TANGENT a)              = putWord8 10 >> put a
    get = do
        tag_ <- getWord8
        case tag_ of
            0 -> VVD_POSITION <$> get
            1 -> VVD_BLEND_WEIGHTS <$> get
            2 -> VVD_BLEND_INDICES <$> get
            3 -> VVD_NORMAL <$> get
            4 -> VVD_DIFFUSE <$> get
            5 -> VVD_SPECULAR <$> get
            6 -> VVD_TEXTURE_COORDINATES1 <$> get
            7 -> VVD_TEXTURE_COORDINATES2 <$> get
            8 -> VVD_TEXTURE_COORDINATES3 <$> get
            9 -> VVD_BINORMAL <$> get
            10 -> VVD_TANGENT <$> get
            _ -> fail "no parse"

instance Binary OperationType where
    put a = put (fromEnum a)
    get = toEnum <$> get

putIndices :: Maybe (V.Vector Int) -> Put
putIndices (Just i) = putWord8 1 >> put (V.map (fromIntegral :: Int -> Int32) i)
putIndices Nothing  = putWord8 0

getIndices :: Get (Maybe (V.Vector Int))
getIndices = do
    m <- getWord8
    case m of
        1 -> Just <$> V.map (fromIntegral :: Int32 -> Int) <$> get
        _ -> return Nothing

instance Binary VSubMesh where
    put (VSubMesh a b c d) = put a >> put b >> put c >> putIndices d
    get = VSubMesh <$> get <*> get <*> get <*> getIndices

instance Binary VMesh where
    put (VMesh a b) = put a >> put b
    get = VMesh <$> get <*> get

decodeVMesh :: LB.ByteString -> VMesh
decodeVMesh d = decode d

encodeVMesh :: VMesh -> LB.ByteString
encodeVMesh vm = encode vm

loadVMesh :: FilePath -> IO VMesh
loadVMesh name = decodeFile name

saveVMesh :: FilePath -> VMesh -> IO ()
saveVMesh name vm = encodeFile name vm