obj-0.1: src/Graphics/Formats/Obj/ObjModel.hs
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wall #-}
----------------------------------------------------------------------
-- |
-- Module : Graphics.Formats.Obj.ObjModel
-- Copyright : (c) Anygma BVBA and Thomas Davie 2008
-- License : BSD3
--
-- Maintainer : tom.davie@gmail.com
-- Stability : experimental
--
-- Describes an Obj Model
----------------------------------------------------------------------
module Graphics.Formats.Obj.ObjModel
(geometryTests
,ObjModel()
,geometry,objFile
) where
import Graphics.Formats
import Graphics.Formats.Obj.Contents
import Graphics.Formats.Obj.ParserBits (anyOf)
import Graphics.Formats.Mtl.Contents
import Graphics.Rendering.OpenGL
import Test.QuickCheck
import Test.QuickCheck.Checkers
import Test.QuickCheck.Instances
import Data.List
import Data.Array
import Data.Function
import Data.Map (Map)
import qualified Data.Map as M
import Control.Monad
import Control.Applicative
data ObjModel = OM BufferSet [Object]
deriving (Show)
type BufferSet = (VertexBuffer, TexCoordBuffer, NormalBuffer)
type VertexBuffer = Array Int (Vertex4 GLfloat)
type TexCoordBuffer = Array Int (TexCoord2 GLfloat)
type NormalBuffer = Array Int (Normal3 GLfloat)
data Object = OFace Material [VTriple]
| OQuad Material [VTriple]
| OTriangle Material [VTriple]
| OLine [VDouble]
| OPoint [Int]
deriving (Show,Eq,Ord)
instance EqProp ObjModel where
m =-= m' = property (normalForm m == normalForm m')
normalForm :: ObjModel -> (BufferSet,[Object])
normalForm (OM (vb,tb,nb) os) =
let lb = fst . bounds
ub = snd . bounds
indicies = (uncurry enumFromTo) . bounds
mkArray a =
let b = lb a
in array (0,ub a - lb a) [(i - b,a ! i) | i <- indicies a]
stripMat (OFace _ bs) = OFace emptyMat bs
stripMat (OTriangle _ bs) = OFace emptyMat bs
stripMat (OQuad _ bs) = OFace emptyMat bs
stripMat x = x
in ((mkArray vb,mkArray tb,mkArray nb)
,sort $ offsetObjects (lb vb) (lb nb) (lb tb) (map stripMat os))
instance Eq ObjModel where
(OM bs os) == (OM bs' os') = bs == bs' && os == os'
instance Arbitrary ObjModel where
arbitrary = OM <$> ((>**<) arbitrary arbitrary arbitrary) <*> arbitrary
coarbitrary (OM (v,t,n) os) =
coarbitrary v . coarbitrary t . coarbitrary n . coarbitrary os
instance Arbitrary Object where
arbitrary = oneof [OFace <$> (return whiteMat)
<*> (nonEmpty
((>**<) positive (maybeGen positive)
(maybeGen positive)))
,OTriangle <$> (return whiteMat)
<*> (setLength 3
((>**<) positive
(maybeGen positive)
(maybeGen positive)))
,OQuad <$> (return whiteMat)
<*> (setLength 4
((>**<) positive
(maybeGen positive)
(maybeGen positive)))
,OLine <$> (nonEmpty
(positive >*< (maybeGen positive)))
,OPoint <$> (nonEmpty positive)]
coarbitrary (OFace _ n) = coarbitrary n
coarbitrary (OTriangle _ n) = coarbitrary n
coarbitrary (OQuad _ n) = coarbitrary n
coarbitrary (OLine n) = coarbitrary n
coarbitrary (OPoint n) = coarbitrary n
instance Renderable ObjModel where
render (OM bs os) =
let (textured,unTextured) = partition isTextured os
texturedGroups = groupBy ((==) `on` texID)
. sortBy (compare `on` texID)
$ textured
in do colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse)
mapM_ (renderOs bs) (unTextured:texturedGroups)
renderOs :: BufferSet -> [Object] -> IO ()
renderOs bs os =
case os of
[] -> return ()
(o:_) -> do setTexturing o
renderList bs (filter isTriangle os) Triangles
renderList bs (filter isQuad os) Quads
mapM_ (renderObject bs) (filter isPolygon os)
material :: Object -> Maybe Material
material (OFace m _) = Just m
material (OTriangle m _) = Just m
material (OQuad m _) = Just m
material _ = Nothing
points :: Object -> Maybe [VTriple]
points (OFace _ ps) = Just ps
points (OTriangle _ ps) = Just ps
points (OQuad _ ps) = Just ps
points _ = Nothing
faceTexture :: Object -> Either String TextureObject
faceTexture = maybe (Left "") diffuseTex . material
faceColour :: Object -> IO ()
faceColour f =
either (const (setColour (ambientColour m)
(diffuseColour m)
(specularColour m)))
(const (setColour (Color4 (1.0 :: GLfloat) 1.0 1.0 1.0)
(Color4 (1.0 :: GLfloat) 1.0 1.0 1.0)
(Color4 (1.0 :: GLfloat) 1.0 1.0 1.0)))
(diffuseTex m)
where
m = maybe (error "Face has no material") id $ material f
texID :: Object -> GLuint
texID = either (const 0) unTexObj . faceTexture
where
unTexObj (TextureObject x) = x
setTexturing :: Object -> IO ()
setTexturing o =
case faceTexture o of
Left _ -> texture Texture2D $= Disabled
Right t -> do texture Texture2D $= Enabled
textureBinding Texture2D $= Just t
isTextured :: Object -> Bool
isTextured = either (const False) (const True) . faceTexture
renderList :: BufferSet -> [Object] -> PrimitiveMode -> IO ()
renderList bs x f =
do renderPrimitive f $ forM_ x (renderCalls bs)
renderCalls :: BufferSet -> Object -> IO ()
renderCalls bs f =
do faceColour f
maybe (return ()) (mapM_ (renderOperation3 bs)) $ points f
renderObject :: BufferSet -> Object -> IO ()
renderObject bs (OFace _ ps) =
renderPrimitive Polygon $ forM_ ps (renderOperation3 bs)
renderObject bs (OTriangle _ ps) =
renderPrimitive Triangles $ forM_ ps (renderOperation3 bs)
renderObject bs (OQuad _ ps) =
renderPrimitive Quads $ forM_ ps (renderOperation3 bs)
renderObject bs (OLine ps) =
renderPrimitive LineStrip $ forM_ ps (renderOperation2 bs)
renderObject bs (OPoint ps) =
renderPrimitive Points $ forM_ ps (renderOperation1 bs)
renderOperation3 :: BufferSet -> VTriple -> IO ()
renderOperation3 (vs,ts,ns) (v,t,n) =
let nop = maybe top ((>> top) . normal . (ns !)) n
top = maybe vop ((>> vop) . texCoord . (ts !)) t
vop = vertex (vs ! v)
in nop
renderOperation2 :: BufferSet -> VDouble -> IO ()
renderOperation2 bs (v,t) = renderOperation3 bs (v,Nothing,t)
renderOperation1 :: BufferSet -> Int -> IO ()
renderOperation1 bs v = renderOperation3 bs (v,Nothing,Nothing)
isTriangle :: Object -> Bool
isTriangle (OTriangle _ _) = True
isTriangle _ = False
isQuad :: Object -> Bool
isQuad (OQuad _ _ ) = True
isQuad _ = False
isPolygon :: Object -> Bool
isPolygon (OFace _ _) = True
isPolygon _ = False
setColour :: (ColorComponent a, ColorComponent b, ColorComponent c) =>
Color4 a -> Color4 b -> Color4 c -> IO ()
setColour _ d _ = color d
{- do materialAmbient FrontAndBack $= a
materialDiffuse FrontAndBack $= d
materialSpecular FrontAndBack $= s -}
{-renderNormals :: BufferSet -> VTriple -> IO ()
renderNormals (vs,_,ns) (v,_,n) =
case n of
Just n' -> vertex (vs ! v) >> vertex ((vs ! v) ..+^^ (ns ! n'))
Nothing -> return ()
(..+^^) :: Vertex4 GLfloat -> Normal3 GLfloat -> Vertex4 GLfloat
(..+^^) (Vertex4 x y z w) (Normal3 i j k) = Vertex4 (x+i) (y+j) (z+k) w-}
geometry :: ObjFile -> MtlFile -> ObjModel
geometry (OF f) mtls =
OM bs (unsmoothedObjects ++ smoothedObjects)
where
vertexBuffer = listArray (1,length vertexList ) vertexList
normalBuffer = listArray (1,length fullNormalList) fullNormalList
texCoordBuffer = listArray (1,length texCoordList ) texCoordList
vertexList = map vToVertex . filter isVertex $ f
normalList = map vnToNormal . filter isNormal $ f
fullNormalList = normalList ++ concat newNormals
texCoordList = map vtToTexCoord . filter isTexCoord $ f
bs = (vertexBuffer,texCoordBuffer,normalBuffer)
unsmoothedObjects = maybe [] id (M.lookup Nothing objects)
(smoothedObjects,newNormals,_) =
foldr (smoothGroup vertexBuffer)
([],[],length normalList + 1)
smoothingGroups
smoothingGroups = M.elems . M.filterWithKey (\k _ -> k /= Nothing)
$ objects
objects = fst6 $ foldl (addObj mtls)
(M.empty,whiteMat,Nothing,1,1,1)
(filter (anyOf [isNormal,isTexCoord,isVertex
,isObject,isUseMtl,isSmoothG]) f)
fst6 :: (a,b,c,d,e,f) -> a
fst6 (x,_,_,_,_,_) = x
addObj :: MtlFile
-> (Map (Maybe Int) [Object],Material,Maybe Int,Int,Int,Int)
-> Statement
-> (Map (Maybe Int) [Object],Material,Maybe Int,Int,Int,Int)
addObj (MF mtls) (os,_,sg,vc,nc,tc) (UseMtl m) =
maybe (error ("Material not found: " ++ show m))
(\mtl' -> (os,mtl',sg,vc,nc,tc))
(M.lookup m mtls)
addObj _ (os,cm,sg,vc,nc,tc) (P ps) =
(M.insertWith (++) sg [OPoint (map (mkAbs vc) ps)] os, cm,sg,vc,nc,tc)
addObj _ (os,cm,sg,vc,nc,tc) (L ps) =
(M.insertWith (++) sg [OLine (absoluteRefs2 vc tc ps)] os, cm,sg,vc,nc,tc)
addObj _ (os,cm,sg,vc,nc,tc) (F ps) =
case length ps of
3 -> (M.insertWith (++) sg [OTriangle cm (absoluteRefs3 vc nc tc ps)] os
,cm,sg,vc,nc,tc)
4 -> (M.insertWith (++) sg [OQuad cm (absoluteRefs3 vc nc tc ps)] os
,cm,sg,vc,nc,tc)
_ -> (M.insertWith (++) sg [OFace cm (absoluteRefs3 vc nc tc ps)] os
,cm,sg,vc,nc,tc)
addObj _ (os,cm,sg,vc,nc,tc) (V _ _ _ _) = (os,cm,sg,vc+1,nc ,tc )
addObj _ (os,cm,sg,vc,nc,tc) (VN _ _ _) = (os,cm,sg,vc ,nc+1,tc )
addObj _ (os,cm,sg,vc,nc,tc) (VT _ _ _) = (os,cm,sg,vc ,nc ,tc+1)
addObj _ (os,cm,_ ,vc,nc,tc) (SG s) = (os,cm,s ,vc ,nc ,tc )
addObj _ (os,cm,sg,vc,nc,tc) _ = (os,cm,sg,vc ,nc ,tc )
smoothGroup :: VertexBuffer -> [Object]
-> ([Object],[[Normal3 GLfloat]],Int)
-> ([Object],[[Normal3 GLfloat]],Int)
smoothGroup vb g (os,ns,nns) =
(gos ++ os,gns : ns, nns + (length gns))
where
gos = map (applyNormals normalMap) g
normalMap = M.fromList $ zip vs [nns..]
gns = map (makeNormal vb g) vs
vs = concatMap objVerticies g
applyNormals :: Map Int Int -> Object -> Object
applyNormals m (OFace mat vs) = OFace mat (appNorms m vs)
applyNormals m (OTriangle mat vs) = OTriangle mat (appNorms m vs)
applyNormals m (OQuad mat vs) = OQuad mat (appNorms m vs)
applyNormals _ x = x
appNorms :: Map Int Int -> [VTriple] -> [VTriple]
appNorms m vs = map (\(v,t,n) -> case n of
Just _ -> (v,t,n )
Nothing -> (v,t,M.lookup v m))
vs
makeNormal :: VertexBuffer -> [Object] -> Int -> Normal3 GLfloat
makeNormal vb os =
uncurry3 Normal3 . averageVec
. map (uncurry crossProduct . createVectors
. lookupVerticies vb)
. (findVertexNeighbors os)
where
findVertexNeighbors :: [Object] -> Int -> [(Int,Int,Int)]
findVertexNeighbors objs v = foldr (findVertexPair v) [] objs
findVertexPair :: Int -> Object -> [(Int,Int,Int)] -> [(Int,Int,Int)]
findVertexPair v (OFace _ vtripples) x = findVP v vtripples x
findVertexPair v (OTriangle _ vtripples) x = findVP v vtripples x
findVertexPair v (OQuad _ vtripples) x = findVP v vtripples x
findVertexPair _ _ x = x
findVP v vtripples ns =
maybe ns (:ns) (find3 v (map trippleVertex vtripples))
where
find3 :: Int -> [Int] -> Maybe (Int,Int,Int)
find3 x ys = find3' x (length ys) $ cycle ys
find3' :: Int -> Int -> [Int] -> Maybe (Int,Int,Int)
find3' _ 0 _ = Nothing
find3' x r (l:c:n:ys)
| x == c = Just (l,c,n)
| otherwise = find3' x (r-1) (c:n:ys)
find3' _ _ _ =
error "find3' called incorrectly. Input list not infinite."
lookupVerticies :: VertexBuffer
-> (Int,Int,Int)
-> (Vertex4 GLfloat,Vertex4 GLfloat,Vertex4 GLfloat)
lookupVerticies buff (a,b,c) = (buff ! a, buff ! b, buff ! c)
createVectors :: (Vertex4 GLfloat,Vertex4 GLfloat,Vertex4 GLfloat)
-> ((GLfloat,GLfloat,GLfloat),(GLfloat,GLfloat,GLfloat))
createVectors (a,b,c) = (a .-. b,c .-. b)
crossProduct :: Num a => (a,a,a) -> (a,a,a) -> (a,a,a)
crossProduct (x,y,z) (x',y',z') =
(y * z' - z * y', z * x' - x * z', x * y' - y * x')
averageVec :: Floating a => [(a,a,a)] -> (a,a,a)
averageVec [] = error "Average vectors: no vectors to average."
averageVec xs = normalise ((sumVec (map normalise xs)) ^/ (fromIntegral $ length xs))
normalise :: Floating a => (a,a,a) -> (a,a,a)
normalise x = x ^/ (mag x)
sumVec = foldr1 (^+^)
mag (x,y,z) = sqrt (x * x + y * y + z * z)
(^+^) (x,y,z) (x',y',z') = (x + x', y + y', z + z')
(.-.) (Vertex4 x y z w) (Vertex4 x' y' z' w') =
(x * w - x' * w', y * w - y' * w', z * w - z' * w')
v ^/ s = v ^* (1 / s)
(x,y,z) ^* s = (x * s, y * s, z * s)
objVerticies :: Object -> [Int]
objVerticies (OFace _ vs) = map trippleVertex vs
objVerticies (OTriangle _ vs) = map trippleVertex vs
objVerticies (OQuad _ vs) = map trippleVertex vs
objVerticies _ = []
mkAbs :: Int -> Int -> Int
mkAbs c x = if x < 0 then c+x else x
absoluteRefs2 :: Int -> Int -> [(Int,Maybe Int)] -> [(Int,Maybe Int)]
absoluteRefs2 c c' =
uncurry zip . (\(x,y) -> (map (mkAbs c) x
,map (liftM (mkAbs c')) y)) . unzip
absoluteRefs3 :: Int -> Int -> Int -> [(Int,Maybe Int,Maybe Int)]
-> [(Int,Maybe Int,Maybe Int)]
absoluteRefs3 c c' c'' =
uncurry3 zip3 . (\(x,y,z) -> (map (mkAbs c) x
,map (liftM (mkAbs c')) y
,map (liftM (mkAbs c'')) z)) . unzip3
uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d
uncurry3 f (x,y,z) = f x y z
trippleVertex :: (Int,Maybe Int,Maybe Int) -> Int
trippleVertex (v,_,_) = v
offsetObjects :: Int -> Int -> Int -> [Object] -> [Object]
offsetObjects vo no to = map (offsetObj vo no to)
offsetObj :: Int -> Int -> Int -> Object -> Object
offsetObj vo no to (OFace m ts) =
OFace m $ map (\(x,y,z) -> (x-vo
,y >>= return . ((flip (-)) no)
,z >>= return . ((flip (-)) to))) ts
offsetObj vo no to (OTriangle m ts) =
OTriangle m $ map (\(x,y,z) -> (x-vo
,y >>= return . ((flip (-)) no)
,z >>= return . ((flip (-)) to))) ts
offsetObj vo no to (OQuad m ts) =
OQuad m $ map (\(x,y,z) -> (x-vo
,y >>= return . ((flip (-)) no)
,z >>= return . ((flip (-)) to))) ts
offsetObj vo _ to (OLine ts) =
OLine $ map (\(x,z) -> (x-vo
,z >>= return . ((flip (-)) to))) ts
offsetObj vo _ _ (OPoint ts) =
OPoint $ map ((flip (-)) vo) ts
objFile :: ObjModel -> ObjFile
objFile (OM (vb,tb,nb) os) =
OF $ concat [writeBuffer vertexToV vb
,writeBuffer texCoordToVT tb
,writeBuffer normalToVN nb
,map writeObject (offsetObjects (-1) (-1) (-1) os)]
where
writeBuffer :: (a -> Statement) -> Array Int a -> [Statement]
writeBuffer f b =
map f $ elems b
writeObject :: Object -> Statement
writeObject (OFace _ fs) = F fs
writeObject (OTriangle _ fs) = F fs
writeObject (OQuad _ fs) = F fs
writeObject (OLine ls) = L ls
writeObject (OPoint ps) = P ps
vnToNormal :: Statement -> Normal3 GLfloat
vnToNormal (VN i j k) = Normal3 i j k
vnToNormal _ = error "Obj statement was not a normal."
vtToTexCoord :: Statement -> TexCoord2 GLfloat
vtToTexCoord (VT u v _) = TexCoord2 u v
vtToTexCoord _ = error "Obj statement was not a texture coordinate."
vToVertex :: Statement -> Vertex4 GLfloat
vToVertex (V x y z w) = Vertex4 x y z w
vToVertex _ = error "Obj statement was not a vertex."
vertexToV :: Vertex4 GLfloat -> Statement
vertexToV (Vertex4 x y z w) = V x y z w
normalToVN :: Normal3 GLfloat -> Statement
normalToVN (Normal3 i j k) = VN i j k
texCoordToVT :: TexCoord2 GLfloat -> Statement
texCoordToVT (TexCoord2 u v) = VT u v 0.0
prop_geomUnGeom :: ObjModel -> Property
prop_geomUnGeom x =
((((flip geometry) (MF M.empty)) . objFile $ x) =-= x)
geometryTests :: IO ()
geometryTests = do putStr "prop_geomUnGeom: "
quickCheck prop_geomUnGeom