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