Contents.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wall -funbox-strict-fields #-}
----------------------------------------------------------------------
-- |
-- Module      :  Graphics.Formats.Obj.Contents
-- Copyright   :  (c) Anygma BVBA & Thomas Davie 2008
-- License     :  BSD3
-- 
-- Maintainer  :  tom.davie@gmail.com
-- Stability   :  experimental
-- 
-- Describes the concrete syntax of an Obj file
----------------------------------------------------------------------
module Graphics.Formats.Obj.Contents
       (ObjFile(..),Statement(..),VTriple(..),VDouble(..)
       ,isVertex,isNormal,isTexCoord
       ,isPoints,isLines,isFace,isObject
       ,isUseMtl,isSmoothG
       ,contentsTests) where

import Test.QuickCheck
import Test.QuickCheck.Instances

import Control.Monad
import Control.Applicative
import Control.Applicative.Infix

import qualified Data.ByteString.Char8 as CBS

newtype ObjFile = OF [Statement]
                  deriving (Show,Eq)

instance Arbitrary ObjFile where
  arbitrary = liftM OF arbitrary
  coarbitrary (OF x) = coarbitrary x

data Statement = V  !Float !Float !Float !Float
               | VN !Float !Float !Float
               | VT !Float !Float !Float
               | P ![Int]
               | L ![VDouble]
               | F ![VTriple]
               | G ![Group]
               | SG !Int
               | MtlLib ![CBS.ByteString]
               | UseMtl !CBS.ByteString
                 deriving (Show,Read,Eq)

data VTriple = VTr !Int !(Maybe Int) !(Maybe Int)
               deriving (Eq,Ord,Show,Read)
data VDouble = VD  !Int !(Maybe Int)
               deriving (Eq,Ord,Show,Read)
type Group   = CBS.ByteString

instance Arbitrary Statement where
  arbitrary =
    oneof [V  <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
          ,VN <$> arbitrary <*> arbitrary <*> arbitrary
          ,VT <$> arbitrary <*> arbitrary <*> arbitrary
          ,P  <$> (nonEmpty nonZero_)
          ,L  <$> (nonEmpty arbitrary)
          ,F  <$> (nonEmpty arbitrary)
          ,(G . map CBS.pack) <$> (nonEmpty (nonEmpty (notOneof " \t\n\r#")))
          ,SG <$> positive]
  coarbitrary (V x y z w) =
    coarbitrary x . coarbitrary y . coarbitrary z . coarbitrary w
  coarbitrary (VN x y z)  =
    coarbitrary x . coarbitrary y . coarbitrary z
  coarbitrary (VT x y z)  =
    coarbitrary x . coarbitrary y . coarbitrary z
  coarbitrary (P n)       = coarbitrary n
  coarbitrary (L n)       = coarbitrary n
  coarbitrary (F n)       = coarbitrary n
  coarbitrary (G n)       = coarbitrary (map CBS.unpack n)
  coarbitrary (SG g)      = coarbitrary g
  coarbitrary (UseMtl xs) = coarbitrary (CBS.unpack xs)
  coarbitrary (MtlLib x)  = coarbitrary (map CBS.unpack x)
  
instance Arbitrary VTriple where
  arbitrary = VTr <$> positive <*> maybeGen positive <*> maybeGen positive
  coarbitrary (VTr v t n) = coarbitrary v . coarbitrary t . coarbitrary n

instance Arbitrary VDouble where
  arbitrary = VD <$> positive <*> maybeGen positive
  coarbitrary (VD v t) = coarbitrary v . coarbitrary t

isNormal :: Statement -> Bool
isNormal (VN _ _ _) = True
isNormal _ = False

isTexCoord :: Statement -> Bool
isTexCoord (VT _ _ _) = True
isTexCoord _ = False

isVertex :: Statement -> Bool
isVertex (V _ _ _ _) = True
isVertex _ = False

isPoints :: Statement -> Bool
isPoints (P _) = True
isPoints _ = False

isLines :: Statement -> Bool
isLines (L _) = True
isLines _ = False

isFace :: Statement -> Bool
isFace (F _) = True
isFace _ = False

isObject :: Statement -> Bool
isObject = isFace <^(||)^> isLines <^(||)^> isPoints

isUseMtl :: Statement -> Bool
isUseMtl (UseMtl _) = True
isUseMtl _ = False

isSmoothG :: Statement -> Bool
isSmoothG (SG _) = True
isSmoothG _ = False

contentsTests :: IO ()
contentsTests = return ()