obj-0.1: src/Graphics/Formats/Obj/Parse.hs
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
----------------------------------------------------------------------
-- |
-- Module : Graphics.Formats.Obj.Parse
-- Copyright : (c) Anygma BVBA & Thomas Davie 2008
-- License : BSD3
--
-- Maintainer : tom.davie@gmail.com
-- Stability : experimental
--
-- Obj file parsing
----------------------------------------------------------------------
module Graphics.Formats.Obj.Parse (parseTests,mtllibs) where
import Graphics.Formats.Obj.Contents
import Graphics.Formats.Obj.ParserBits
import Test.QuickCheck
import Data.Maybe hiding (fromJust)
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Control.Monad
import Control.Applicative
instance Binary ObjFile where
put (OF sts) =
forM_ sts put
get =
return . OF
. catMaybes
. map decodeStmt
. CBS.lines
. CBS.concat
. LBS.toChunks =<< getRemainingLazyByteString
instance Binary Statement where
put (V x y z w) =
do putString "v "
putShow x >> put ' '
putShow y >> put ' '
putShow z >> put ' '
putShow w >> put ' '
put '\n'
put (VN x y z) =
do putString "vn "
putShow x >> put ' '
putShow y >> put ' '
putShow z >> put ' '
put '\n'
put (VT x y z) =
do putString "vt "
putShow x >> put ' '
putShow y >> put ' '
putShow z >> put ' '
put '\n'
put (P is) = put 'p' >> putList putShow is >> put '\n'
put (L is) = put 'l' >> putList putDouble is >> put '\n'
put (F is) = put 'f' >> putList putTriple is >> put '\n'
put (G gs) = put 'g' >> putList putString gs >> put '\n'
put (SG g) = putString "s " >> case g of
Nothing -> putString "0\n"
Just x -> putShow x >> put '\n'
put (MtlLib m) = put "mtllib" >> putList putString m >> put '\n'
put (UseMtl m) = put "usemtl " >> putString m >> put '\n'
get = undefined
putString :: String -> Put
putString = putByteString . CBS.pack
putShow :: Show a => a -> Put
putShow = putString . show
putList :: Binary a => (a -> Put) -> [a] -> Put
putList f x = forM_ x (\i -> put ' ' >> f i)
putDouble :: VDouble -> Put
putDouble (x,Just y ) = putShow x >> put '/' >> putShow y
putDouble (x,Nothing) = putShow x
putTriple :: VTriple -> Put
putTriple (v,t,n) =
putShow v >>
case (t,n) of
(Nothing,Just n') -> putString "//" >> putShow n'
_ -> put' t >> put' n
where
put' x = case x of
Nothing -> return ()
Just x' -> put '/' >> putShow x'
decodeStmt :: CBS.ByteString -> Maybe Statement
decodeStmt = decodeStmt' . consumeWS . removeComments
decodeStmt' :: CBS.ByteString -> Maybe Statement
decodeStmt' s =
if CBS.length s > 0 then
case CBS.head s of
'p' -> Just . P $ runParse parsePoints s
'l' -> Just . L $ runParse parseLines s
'f' -> Just . F $ runParse parseFace s
'g' -> Just . G $ runParse parseGroups s
's' -> Just . SG $ runParse parseSmoothGroup s
_ -> if (CBS.pack "mtllib") `CBS.isPrefixOf` s
then Just . MtlLib $ runParse parseMtlLib (CBS.drop 5 s)
else if (CBS.pack "usemtl") `CBS.isPrefixOf` s
then Just . UseMtl $ runParse parseUseMtl (CBS.drop 5 s)
else if (CBS.pack "vn") `CBS.isPrefixOf` s
then Just . (uncurry3 VN) $ runParse parseNormal (CBS.tail s)
else if (CBS.pack "vt") `CBS.isPrefixOf` s
then Just . (uncurry3 VT) $ runParse parseTexCoord (CBS.tail s)
else if 'v' == CBS.head s
then Just . (uncurry4 V) $ runParse parseVertex s
else Nothing
else Nothing
runParse :: (CBS.ByteString -> a) -> CBS.ByteString -> a
runParse x = x . consumeWS . CBS.tail
if' :: Bool -> a -> a -> a
if' c t e = if c then t else e
parsePoints :: CBS.ByteString -> [Int]
parseLines :: CBS.ByteString -> [VDouble]
parseFace :: CBS.ByteString -> [VTriple]
parsePoints = bSwords unsafeReadInt
parseLines = bSwords readDouble
parseFace = bSwords readTriple
parseGroups :: CBS.ByteString -> [String]
parseSmoothGroup :: CBS.ByteString -> Maybe Int
parseGroups = bSwords (CBS.unpack)
parseSmoothGroup g =
if g == (CBS.pack "off")
then Nothing
else (if' <$> (== 0) <*> (const Nothing) <*> Just) . unsafeReadInt $ g
parseMtlLib :: CBS.ByteString -> [String]
parseUseMtl :: CBS.ByteString -> String
parseMtlLib = bSwords parseName
parseUseMtl = head . bSwords parseName
parseNormal :: CBS.ByteString -> (Float,Float,Float)
parseTexCoord :: CBS.ByteString -> (Float,Float,Float)
parseVertex :: CBS.ByteString -> (Float,Float,Float,Float)
parseNormal = normalTuple
parseTexCoord = texCoordTuple
parseVertex = vertexTuple
unsafeReadInt :: CBS.ByteString -> Int
unsafeReadInt x = case CBS.readInt x of
Just (i,_) -> i
Nothing -> error "unsafeReadInt: No integer to read."
readDouble :: CBS.ByteString -> VDouble
readDouble x =
if CBS.length b > 1
then (unsafeReadInt a, Just . unsafeReadInt $ CBS.tail b)
else (unsafeReadInt a, Nothing)
where
(a,b) = CBS.break (=='/') x
-- | Read a vertex/texcoord/normal triple.
-- Triples can take these forms:
-- v, v/t, v//n, v/t/n
readTriple :: CBS.ByteString -> VTriple
readTriple vtns =
(v,t,n)
where
(vs,tnr) = CBS.break (=='/') vtns
(ts,nr ) = if CBS.length tnr > 0
then CBS.break (=='/') . CBS.tail $ tnr
else (CBS.empty, CBS.empty)
ns = if CBS.length nr > 0
then CBS.tail nr
else CBS.empty
v = unsafeReadInt vs
t = getMaybeInt ts
n = getMaybeInt ns
getMaybeInt x = if CBS.length x > 0
then Just $ unsafeReadInt x
else Nothing
normalTuple :: CBS.ByteString -> (Float,Float,Float)
normalTuple s =
let Just (x,s' ) = unsafeRFloat s
Just (y,s'') = unsafeRFloat s'
Just (z,_ ) = unsafeRFloat s''
in (x,y,z)
vertexTuple :: CBS.ByteString -> (Float,Float,Float,Float)
vertexTuple s =
let Just (x,s' ) = unsafeRFloat s
Just (y,s'' ) = unsafeRFloat s'
Just (z,s''') = unsafeRFloat s''
w = unsafeRFloat s'''
in case w of
Just (w',_) -> (x,y,z,w')
Nothing -> (x,y,z,1 )
texCoordTuple :: CBS.ByteString -> (Float,Float,Float)
texCoordTuple s =
let Just (x,s') = unsafeRFloat s
y = unsafeRFloat s'
in case y of
Just (y',r) -> case unsafeRFloat r of
Just (z,_) -> (x,y',z)
Nothing -> (x,y',0)
Nothing -> (x,0,0)
uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d
uncurry3 f (x,y,z) = f x y z
uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e
uncurry4 f (x,y,z,w) = f x y z w
mtllibs :: ObjFile -> [String]
mtllibs (OF f) = concatMap stmtMtlLibs f
stmtMtlLibs :: Statement -> [String]
stmtMtlLibs (MtlLib xs) = xs
stmtMtlLibs _ = []
prop_parseUnParse :: ObjFile -> Bool
prop_parseUnParse x =
(decode . encode $ x) == x
parseTests :: IO ()
parseTests = do putStr "prop_parseUnParse: "
quickCheck prop_parseUnParse