{-# 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