module Graphics.Formats.Obj.ObjModel
(geometryTests
,ObjModel()
,geometry,objFile
,renderONormals
) where
import Graphics.Formats
import Graphics.Formats.Obj.Contents
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 qualified Data.Map as M
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import Control.Monad
import Control.Applicative
data ObjModel = OM BufferSet [FObject]
deriving (Show)
type BufferSet = (VertexBuffer, TexCoordBuffer, NormalBuffer)
data NVTriple = NVT !Int !(Maybe Int) !Int
deriving (Eq, Ord, Show)
type VertexBuffer = Array Int (Vertex4 GLfloat)
type TexCoordBuffer = Array Int (TexCoord2 GLfloat)
type NormalBuffer = Array Int (Normal3 GLfloat)
data Object a = OFace Material [a]
| OQuad Material [a]
| OTriangle Material [a]
| OLine [VDouble]
| OPoint [Int]
deriving (Show,Eq,Ord)
type FObject = Object NVTriple
type IObject = Object VTriple
instance EqProp ObjModel where
m =-= m' = property (normalForm m == normalForm m')
normalForm :: ObjModel -> (BufferSet,[FObject])
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 (FObject) where
arbitrary = oneof [OFace <$> (return whiteMat) <*> (nonEmpty arbitrary)
,OTriangle <$> (return whiteMat)
<*> (setLength 3 arbitrary)
,OQuad <$> (return whiteMat)
<*> (setLength 4 arbitrary)
,OLine <$> (nonEmpty arbitrary)
,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 Arbitrary NVTriple where
arbitrary = NVT <$> positive <*> maybeGen positive <*> positive
coarbitrary (NVT v t n) = coarbitrary v . coarbitrary t . 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 preservingAttrib
[AllServerAttributes]
(do colorMaterial $= Just (Front, AmbientAndDiffuse)
mapM_ (renderOs bs) (unTextured:texturedGroups))
renderOs :: BufferSet -> [FObject] -> 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 a -> Maybe Material
material (OFace m _) = Just m
material (OTriangle m _) = Just m
material (OQuad m _) = Just m
material _ = Nothing
points :: Object a -> Maybe [a]
points (OFace _ ps) = Just ps
points (OTriangle _ ps) = Just ps
points (OQuad _ ps) = Just ps
points _ = Nothing
faceTexture :: Object a -> Either String TextureObject
faceTexture = maybe (Left "") diffuseTex . material
faceColour :: Object a -> 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 a -> GLuint
texID = either (const 0) unTexObj . faceTexture
where
unTexObj (TextureObject x) = x
setTexturing :: Object a -> IO ()
setTexturing o =
case faceTexture o of
Left _ -> texture Texture2D $= Disabled
Right t -> do texture Texture2D $= Enabled
textureBinding Texture2D $= Just t
isTextured :: Object a -> Bool
isTextured = either (const False) (const True) . faceTexture
renderList :: BufferSet -> [FObject] -> PrimitiveMode -> IO ()
renderList bs x f =
do renderPrimitive f $ forM_ x (renderCalls bs)
renderCalls :: BufferSet -> FObject -> IO ()
renderCalls bs f =
do faceColour f
maybe (return ()) (mapM_ (renderOperation3 bs)) $ points f
renderObject :: BufferSet -> FObject -> 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 -> NVTriple -> IO ()
renderOperation3 (vs,ts,ns) (NVT v t n) =
let nop = normal (ns ! n) >> top
top = maybe vop ((>> vop) . texCoord . (ts !)) t
vop = vertex (vs ! v)
in nop
renderOperation2 :: BufferSet -> VDouble -> IO ()
renderOperation2 (vs,ts,_) (VD v t) =
let top = maybe vop ((>> vop) . texCoord . (ts !)) t
vop = vertex (vs ! v)
in top
renderOperation1 :: BufferSet -> Int -> IO ()
renderOperation1 bs v = renderOperation2 bs (VD v Nothing)
isTriangle :: Object a -> Bool
isTriangle (OTriangle _ _) = True
isTriangle _ = False
isQuad :: Object a -> Bool
isQuad (OQuad _ _ ) = True
isQuad _ = False
isPolygon :: Object a -> Bool
isPolygon (OFace _ _) = True
isPolygon _ = False
setColour :: (ColorComponent a, ColorComponent b, ColorComponent c) =>
Color4 a -> Color4 b -> Color4 c -> IO ()
setColour _ d _ = color d
renderONormals :: BufferSet -> FObject -> IO ()
renderONormals bs o =
maybe (return ())
(renderPrimitive Lines . mapM_ (renderNormals bs)) $ points o
renderNormals :: BufferSet -> NVTriple -> IO ()
renderNormals (vs,_,ns) (NVT v _ n) =
vertex (vs ! v) >> vertex ((vs ! v) ..+^^ (ns ! n))
(..+^^) :: 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 = sNormalList ++ unsmoothedNormals
sNormalList = normalList ++ smoothedNormals
texCoordList = map vtToTexCoord . filter isTexCoord $ f
bs = (vertexBuffer,texCoordBuffer,normalBuffer)
unsmoothedGroup = maybe [] id (IM.lookup 0 objects)
(unsmoothedObjects,unsmoothedNormals,numNormals) =
foldl' (objectNormals (length sNormalList + numNormals + 1) vertexBuffer)
([],[],0)
unsmoothedGroup
smoothingGroups = IM.elems . IM.filterWithKey (\k _ -> k /= 0) $ objects
(smoothedObjects,smoothedNormals,numsNormals) =
foldl' (smoothGroup (length normalList + numsNormals + 1) vertexBuffer)
([],[],0)
smoothingGroups
objects = fst6 $ foldl' (addObj mtls) (IM.empty,whiteMat,0,1,1,1) f
fst6 :: (a,b,c,d,e,f) -> a
fst6 (x,_,_,_,_,_) = x
addObj :: MtlFile
-> (IntMap [IObject],Material,Int,Int,Int,Int)
-> Statement
-> (IntMap [IObject],Material,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) =
(IM.insertWith (++) sg [OPoint (map (mkAbs vc) ps)] os, cm,sg,vc,nc,tc)
addObj _ (os,cm,sg,vc,nc,tc) (L ps) =
(IM.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 -> (IM.insertWith (++) sg [OTriangle cm (absoluteRefs3 vc nc tc ps)] os
,cm,sg,vc,nc,tc)
4 -> (IM.insertWith (++) sg [OQuad cm (absoluteRefs3 vc nc tc ps)] os
,cm,sg,vc,nc,tc)
_ -> (IM.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 )
objectNormals :: Int -> VertexBuffer -> ([FObject],[Normal3 GLfloat],Int)
-> IObject
-> ([FObject],[Normal3 GLfloat],Int)
objectNormals loff vb (os,ns,nns) o =
(go : os, gns ++ ns, nns + vl)
where
go = applyNormals normalMap o
normalMap = IM.fromList $ zip vs [(loff nns vl)..]
gns = map (normalise . uncurry (flip crossProduct) . createVectors)
. take vl
. makeTripples
. map (vb !)
. drop (vl 1)
. cycle
$ vs
vl = length vs
vs = objVerticies o
makeTripples (x:y:z:xs) = (x,y,z) : makeTripples (y:z:xs)
makeTripples _ = error "not enough elements in list for makeTriples."
smoothGroup :: Int -> VertexBuffer -> ([FObject],[Normal3 GLfloat],Int)
-> [IObject]
-> ([FObject],[Normal3 GLfloat],Int)
smoothGroup loff vb (os,ns,nns) g =
(gos ++ os, gns ++ ns, nns + lgn)
where
gos = map (applyNormals normalMap) g
normalMap = IM.fromList $ zip vs [(loff nns lgn)..]
gns = map (makeNormal vb g) vs
lgn = length gns
vs = concatMap objVerticies g
applyNormals :: IntMap Int -> IObject -> FObject
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 _ (OLine vs) = OLine vs
applyNormals _ (OPoint vs) = OPoint vs
appNorms :: IntMap Int -> [VTriple] -> [NVTriple]
appNorms m vs =
map (\(VTr v t n) -> case n of
Just n' -> NVT v t n'
Nothing -> case v `IM.lookup` m of
Just n' -> NVT v t n'
Nothing -> error "Didn't gen normal")
vs
makeNormal :: VertexBuffer -> [IObject] -> Int -> Normal3 GLfloat
makeNormal vb os =
averageVec . map (uncurry (flip crossProduct) . createVectors
. lookupVerticies vb)
. (findVertexNeighbors os)
where
findVertexNeighbors :: [IObject] -> Int -> [(Int,Int,Int)]
findVertexNeighbors objs v = foldr (findVertexPair v) [] objs
findVertexPair :: Int -> IObject -> [(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 (r1) (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)
-> (Normal3 GLfloat,Normal3 GLfloat)
createVectors (a,b,c) = (a .-. b,c .-. b)
crossProduct :: Num a => Normal3 a -> Normal3 a -> Normal3 a
crossProduct (Normal3 x y z) (Normal3 x' y' z') =
Normal3 (y * z' z * y') (z * x' x * z') (x * y' y * x')
averageVec :: Floating a => [Normal3 a] -> Normal3 a
averageVec [] = error "Average vectors: no vectors to average."
averageVec xs = normalise ( (sumVec (map normalise xs))
^/ (fromIntegral $ length xs))
normalise :: Floating a => Normal3 a -> Normal3 a
normalise x = x ^/ (mag x)
sumVec :: Num a => [Normal3 a] -> Normal3 a
sumVec = foldr1 (^+^)
mag :: Floating a => Normal3 a -> a
mag (Normal3 x y z) = sqrt (x * x + y * y + z * z)
(^+^) :: Num a => Normal3 a -> Normal3 a -> Normal3 a
(^+^) (Normal3 x y z) (Normal3 x' y' z') =
Normal3 (x + x') (y + y') (z + z')
(.-.) :: Num a => Vertex4 a -> Vertex4 a -> Normal3 a
(.-.) (Vertex4 x y z w) (Vertex4 x' y' z' w') =
Normal3 (x * w x' * w') (y * w y' * w') (z * w z' * w')
(^/) :: Floating a => Normal3 a -> a -> Normal3 a
v ^/ s = v ^* (1 / s)
(^*) :: Num a => Normal3 a -> a -> Normal3 a
(Normal3 x y z) ^* s = Normal3 (x * s) (y * s) (z * s)
objVerticies :: IObject -> [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 -> [VDouble] -> [VDouble]
absoluteRefs2 c c' =
map (\(VD x y) -> VD (mkAbs c x) (mkAbs c' <$> y))
absoluteRefs3 :: Int -> Int -> Int -> [VTriple] -> [VTriple]
absoluteRefs3 c c' c'' =
map (\(VTr x y z) -> VTr (mkAbs c x) (mkAbs c' <$> y) (mkAbs c'' <$> z))
trippleVertex :: VTriple -> Int
trippleVertex (VTr v _ _) = v
offsetObjects :: Int -> Int -> Int -> [FObject] -> [FObject]
offsetObjects vo no to = map (offsetObj vo no to)
offsetObj :: Int -> Int -> Int -> FObject -> FObject
offsetObj vo to no (OFace m ts) =
OFace m $ map (\(NVT v t n) -> NVT (vvo)
(t >>= return . ((flip ()) to))
(nno)) ts
offsetObj vo no to (OTriangle m ts) =
OTriangle m $ map (\(NVT v t n) -> NVT (vvo)
(t >>= return . ((flip ()) to))
(nno)) ts
offsetObj vo no to (OQuad m ts) =
OQuad m $ map (\(NVT v t n) -> NVT (vvo)
(t >>= return . ((flip ()) to))
(nno)) ts
offsetObj vo _ to (OLine ts) =
OLine $ map (\(VD v t) -> VD (vvo) (t >>= 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 = map f . elems
writeObject :: FObject -> Statement
writeObject (OFace _ fs) = F (map nvToVTriple fs)
writeObject (OTriangle _ fs) = F (map nvToVTriple fs)
writeObject (OQuad _ fs) = F (map nvToVTriple fs)
writeObject (OLine ls) = L ls
writeObject (OPoint ps) = P ps
nvToVTriple (NVT v t n) = VTr v t (Just n)
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