Contents.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wall #-}
----------------------------------------------------------------------
-- |
-- 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 Data.Char

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 (Maybe Int)
               | MtlLib [String]
               | UseMtl String
                 deriving (Show,Read,Eq)

type VTriple = (Int, Maybe Int, Maybe Int)
type VDouble = (Int, Maybe Int)
type Group   = String

instance Arbitrary Statement where
  arbitrary =
    oneof [V  <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
          ,VN <$> arbitrary <*> arbitrary <*> arbitrary
          ,VT <$> arbitrary <*> arbitrary <*> arbitrary
          ,P  <$> (nonEmpty nonZero_)
          ,L  <$> (nonEmpty (nonZero_ >*< (maybeGen nonZero_)))
          ,F  <$> (nonEmpty ((>**<) nonZero_
                                    (maybeGen nonZero_)
                                    (maybeGen nonZero_)))
          ,G  <$> (nonEmpty (nonEmpty (notOneof " \t\n\r#")))
          ,SG <$> (maybeGen 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 n
  coarbitrary (SG g)      = coarbitrary g
  coarbitrary (UseMtl xs) = coarbitrary xs
  coarbitrary (MtlLib x)  = coarbitrary x
  
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 = liftA2 (||) isFace (liftA2 (||) isLines isPoints)

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

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

contentsTests :: IO ()
contentsTests = return ()