obj 0.1 → 0.1.1
raw patch · 9 files changed
+331/−298 lines, 9 filesdep +InfixApplicative
Dependencies added: InfixApplicative
Files
- examples/LoadObject.hs +4/−0
- obj.cabal +3/−2
- src/Graphics/Formats/Mtl/Contents.hs +10/−7
- src/Graphics/Formats/Mtl/Parse.hs +4/−13
- src/Graphics/Formats/Obj.hs +3/−1
- src/Graphics/Formats/Obj/Contents.hs +35/−26
- src/Graphics/Formats/Obj/ObjModel.hs +199/−154
- src/Graphics/Formats/Obj/Parse.hs +65/−88
- src/Graphics/Formats/Obj/ParserBits.hs +8/−7
examples/LoadObject.hs view
@@ -28,6 +28,9 @@ import Graphics.Formats import Graphics.Formats.Obj++import Graphics.Rendering.OpenGL+ import Codec.Image.DevIL -- | Load an object at a specified scale and render it.@@ -36,6 +39,7 @@ do [file,scale] <- System.getArgs ilInit simpleInit ("ObjModel: " ++ file)+ lightModelTwoSide $= Enabled dl <- objFromFile file [fst (splitFileName file)] >>= displayListR adapt . spinningR (read scale) . renderableG $ dl
obj.cabal view
@@ -1,6 +1,6 @@ Name: obj Cabal-Version: >= 1.2-Version: 0.1+Version: 0.1.1 Synopsis: Reads and writes obj models. Description: Reads and writes obj models. License: BSD3@@ -31,7 +31,8 @@ OpenGLCheck >= 0.1, bytestring >= 0.9, binary >= 0.4.2,- Codec-Image-DevIL >= 0.1+ Codec-Image-DevIL >= 0.1,+ InfixApplicative >= 1.0 Hs-Source-Dirs: src Ghc-Options: -O2 Exposed-Modules: Graphics.Formats.Obj
src/Graphics/Formats/Mtl/Contents.hs view
@@ -24,6 +24,7 @@ import Data.List import Graphics.Rendering.OpenGL+import Control.Applicative import Control.Monad import Test.QuickCheck@@ -32,10 +33,12 @@ import Codec.Image.DevIL -newtype MtlFile = MF (Map String Material)+import qualified Data.ByteString.Char8 as CBS++newtype MtlFile = MF (Map CBS.ByteString Material) deriving Show -data Material = Mat {name :: String+data Material = Mat {name :: CBS.ByteString ,matFile :: FilePath ,ambientColour :: Color4 GLfloat ,diffuseColour :: Color4 GLfloat@@ -56,8 +59,8 @@ arbitrary) arbitrary) (anyList nonSpace))- (anyList nonSpace)- coarbitrary m = coarbitrary (name m)+ (CBS.pack <$> anyList nonSpace)+ coarbitrary m = coarbitrary (CBS.unpack $ name m) . coarbitrary (matFile m) . coarbitrary (ambientColour m) . coarbitrary (diffuseColour m)@@ -107,7 +110,7 @@ loadTexture :: FilePath -> IO TextureObject loadTexture f = buildTexture =<< readImage f -setName :: Material -> String -> Material+setName :: Material -> CBS.ByteString -> Material setName m n = m {name = n} setMatFile :: Material -> FilePath -> Material@@ -132,7 +135,7 @@ setSpecularTexName m t = m {specularTex = Left t} emptyMat :: Material-emptyMat = Mat {name = ""+emptyMat = Mat {name = CBS.pack "" ,matFile = "" ,ambientColour = Color4 0.0 0.0 0.0 0.0 ,diffuseColour = Color4 0.0 0.0 0.0 0.0@@ -142,7 +145,7 @@ ,specularTex = Left ""} whiteMat :: Material-whiteMat = Mat {name = "white"+whiteMat = Mat {name = CBS.pack "white" ,matFile = "" ,ambientColour = Color4 1 1 1 1 ,diffuseColour = Color4 0.5 0.5 0.5 1
src/Graphics/Formats/Mtl/Parse.hs view
@@ -42,7 +42,7 @@ put (show b) >> put ' ' >> put (show a) get = undefined -buildMap :: [Material] -> M.Map String Material+buildMap :: [Material] -> M.Map CBS.ByteString Material buildMap x = M.fromList $ zip (map name x) x chunk :: CBS.ByteString -> CBS.ByteString -> [CBS.ByteString]@@ -58,16 +58,7 @@ get = undefined decodeMtl :: CBS.ByteString -> Material-decodeMtl = foldr ($) (Mat {name = ""- ,matFile = ""- ,ambientColour = Color4 0 0 0 1- ,diffuseColour = Color4 0 0 0 1- ,specularColour = Color4 0 0 0 1- ,ambientTex = Left ""- ,diffuseTex = Left ""- ,specularTex = Left ""})- . map decodeLine- . CBS.lines+decodeMtl = foldr ($) emptyMat . map decodeLine . CBS.lines decodeLine :: CBS.ByteString -> Material -> Material decodeLine = decodeLine' . consumeWS . removeComments@@ -93,10 +84,10 @@ else id colour :: (a -> Color4 GLfloat -> c) -> CBS.ByteString -> a -> c-colour f = (flip f) . makeColour . bSwords unsafeReadFloat+colour f = (flip f) . makeColour . map unsafeReadFloat . bsWords applyTex :: (a -> String -> c) -> CBS.ByteString -> a -> c-applyTex f = (flip f) . parseName+applyTex f = (flip f) . CBS.unpack . parseName makeColour :: [Float] -> Color4 GLfloat makeColour [r,g,b] = Color4 r g b 1
src/Graphics/Formats/Obj.hs view
@@ -30,6 +30,8 @@ import Graphics.Formats.Mtl.Contents import Graphics.Formats.Mtl.Parse () +import qualified Data.ByteString.Char8 as CBS+ -- | Loads an Obj model from a file given a list of search paths to find -- materials and textures at. objFromFile :: FilePath -> [FilePath] -> IO ObjModel@@ -37,7 +39,7 @@ do -- Parse the obj cs <- decodeFile x -- Find the material files and parse them too- let mtlfs = mtllibs cs+ let mtlfs = map CBS.unpack $ mtllibs cs files <- mapM (findFile sps) mtlfs mapM_ (putStrLn . ("Warning: File not found: " ++) . fst) . filter ((==Nothing) . snd)
src/Graphics/Formats/Obj/Contents.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE NoMonomorphismRestriction #-}-{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wall -funbox-strict-fields #-} ---------------------------------------------------------------------- -- | -- Module : Graphics.Formats.Obj.Contents@@ -12,7 +12,7 @@ -- Describes the concrete syntax of an Obj file ---------------------------------------------------------------------- module Graphics.Formats.Obj.Contents- (ObjFile(..),Statement(..),VTriple,VDouble+ (ObjFile(..),Statement(..),VTriple(..),VDouble(..) ,isVertex,isNormal,isTexCoord ,isPoints,isLines,isFace,isObject ,isUseMtl,isSmoothG@@ -23,8 +23,9 @@ import Control.Monad import Control.Applicative+import Control.Applicative.Infix -import Data.Char+import qualified Data.ByteString.Char8 as CBS newtype ObjFile = OF [Statement] deriving (Show,Eq)@@ -33,21 +34,23 @@ 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+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) -type VTriple = (Int, Maybe Int, Maybe Int)-type VDouble = (Int, Maybe Int)-type Group = String+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 =@@ -55,12 +58,10 @@ ,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)]+ ,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) =@@ -70,11 +71,19 @@ coarbitrary (P n) = coarbitrary n coarbitrary (L n) = coarbitrary n coarbitrary (F n) = coarbitrary n- coarbitrary (G n) = coarbitrary n+ coarbitrary (G n) = coarbitrary (map CBS.unpack n) coarbitrary (SG g) = coarbitrary g- coarbitrary (UseMtl xs) = coarbitrary xs- coarbitrary (MtlLib x) = coarbitrary x+ 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@@ -100,7 +109,7 @@ isFace _ = False isObject :: Statement -> Bool-isObject = liftA2 (||) isFace (liftA2 (||) isLines isPoints)+isObject = isFace <^(||)^> isLines <^(||)^> isPoints isUseMtl :: Statement -> Bool isUseMtl (UseMtl _) = True
src/Graphics/Formats/Obj/ObjModel.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE NoMonomorphismRestriction, TypeSynonymInstances #-}+{-# OPTIONS_GHC -Wall -funbox-strict-fields #-} ---------------------------------------------------------------------- -- | -- Module : Graphics.Formats.Obj.ObjModel@@ -15,11 +15,11 @@ (geometryTests ,ObjModel() ,geometry,objFile+ ,renderONormals ) where import Graphics.Formats import Graphics.Formats.Obj.Contents-import Graphics.Formats.Obj.ParserBits (anyOf) import Graphics.Formats.Mtl.Contents import Graphics.Rendering.OpenGL@@ -31,32 +31,37 @@ import Data.List import Data.Array import Data.Function-import Data.Map (Map)-import qualified Data.Map as M+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 [Object]+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 = OFace Material [VTriple]- | OQuad Material [VTriple]- | OTriangle Material [VTriple]- | OLine [VDouble]- | OPoint [Int]- deriving (Show,Eq,Ord)+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,[Object])+normalForm :: ObjModel -> (BufferSet,[FObject]) normalForm (OM (vb,tb,nb) os) = let lb = fst . bounds ub = snd . bounds@@ -79,23 +84,13 @@ 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)))+instance Arbitrary (FObject) where+ arbitrary = oneof [OFace <$> (return whiteMat) <*> (nonEmpty arbitrary) ,OTriangle <$> (return whiteMat)- <*> (setLength 3- ((>**<) positive- (maybeGen positive)- (maybeGen positive)))+ <*> (setLength 3 arbitrary) ,OQuad <$> (return whiteMat)- <*> (setLength 4- ((>**<) positive- (maybeGen positive)- (maybeGen positive)))- ,OLine <$> (nonEmpty- (positive >*< (maybeGen positive)))+ <*> (setLength 4 arbitrary)+ ,OLine <$> (nonEmpty arbitrary) ,OPoint <$> (nonEmpty positive)] coarbitrary (OFace _ n) = coarbitrary n coarbitrary (OTriangle _ n) = coarbitrary n@@ -103,16 +98,20 @@ 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 do colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse)+ in do colorMaterial $= Just (Front, AmbientAndDiffuse) mapM_ (renderOs bs) (unTextured:texturedGroups) -renderOs :: BufferSet -> [Object] -> IO ()+renderOs :: BufferSet -> [FObject] -> IO () renderOs bs os = case os of [] -> return ()@@ -120,23 +119,27 @@ renderList bs (filter isTriangle os) Triangles renderList bs (filter isQuad os) Quads mapM_ (renderObject bs) (filter isPolygon os)+{- setColour (Color4 (0.0 :: GLfloat) 1.0 0.0 1.0)+ (Color4 (0.0 :: GLfloat) 1.0 0.0 1.0)+ (Color4 (0.0 :: GLfloat) 1.0 0.0 1.0)+ mapM_ (renderONormals bs) os-} -material :: Object -> Maybe Material+material :: Object a -> Maybe Material material (OFace m _) = Just m material (OTriangle m _) = Just m material (OQuad m _) = Just m material _ = Nothing -points :: Object -> Maybe [VTriple]+points :: Object a -> Maybe [a] points (OFace _ ps) = Just ps points (OTriangle _ ps) = Just ps points (OQuad _ ps) = Just ps points _ = Nothing -faceTexture :: Object -> Either String TextureObject+faceTexture :: Object a -> Either String TextureObject faceTexture = maybe (Left "") diffuseTex . material -faceColour :: Object -> IO ()+faceColour :: Object a -> IO () faceColour f = either (const (setColour (ambientColour m) (diffuseColour m)@@ -148,31 +151,31 @@ where m = maybe (error "Face has no material") id $ material f -texID :: Object -> GLuint+texID :: Object a -> GLuint texID = either (const 0) unTexObj . faceTexture where unTexObj (TextureObject x) = x -setTexturing :: Object -> IO ()+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 -> Bool+isTextured :: Object a -> Bool isTextured = either (const False) (const True) . faceTexture -renderList :: BufferSet -> [Object] -> PrimitiveMode -> IO ()+renderList :: BufferSet -> [FObject] -> PrimitiveMode -> IO () renderList bs x f = do renderPrimitive f $ forM_ x (renderCalls bs) -renderCalls :: BufferSet -> Object -> IO ()+renderCalls :: BufferSet -> FObject -> IO () renderCalls bs f = do faceColour f maybe (return ()) (mapM_ (renderOperation3 bs)) $ points f -renderObject :: BufferSet -> Object -> IO ()+renderObject :: BufferSet -> FObject -> IO () renderObject bs (OFace _ ps) = renderPrimitive Polygon $ forM_ ps (renderOperation3 bs) renderObject bs (OTriangle _ ps) =@@ -184,46 +187,57 @@ 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+renderOperation3 :: BufferSet -> NVTriple -> IO ()+renderOperation3 (vs,ts,ns) (NVT v t n) =+ let nop = normal (ns ! n) >> top+ {-color ((\(Normal3 x y z) -> Color4 (clip x) (clip y) (clip z) 1.0) (ns ! n)) >> top -} top = maybe vop ((>> vop) . texCoord . (ts !)) t vop = vertex (vs ! v) in nop +{-clip :: GLfloat -> GLfloat+clip x = let v = (x + 1.0 / 2)+ in (if v < 0 then 0 else if v > 1 then 1 else v)-}+ renderOperation2 :: BufferSet -> VDouble -> IO ()-renderOperation2 bs (v,t) = renderOperation3 bs (v,Nothing,t)+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 = renderOperation3 bs (v,Nothing,Nothing)- -isTriangle :: Object -> Bool+renderOperation1 bs v = renderOperation2 bs (VD v Nothing)++isTriangle :: Object a -> Bool isTriangle (OTriangle _ _) = True isTriangle _ = False -isQuad :: Object -> Bool+isQuad :: Object a -> Bool isQuad (OQuad _ _ ) = True isQuad _ = False -isPolygon :: Object -> Bool+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-{- do materialAmbient FrontAndBack $= a- materialDiffuse FrontAndBack $= d- materialSpecular FrontAndBack $= s -}+{- do materialAmbient Front $= a+ materialDiffuse Front $= d+ materialSpecular Front $= 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 ()+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-}+(..+^^) (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 =@@ -234,43 +248,47 @@ texCoordBuffer = listArray (1,length texCoordList ) texCoordList vertexList = map vToVertex . filter isVertex $ f normalList = map vnToNormal . filter isNormal $ f- fullNormalList = normalList ++ concat newNormals+ fullNormalList = sNormalList ++ unsmoothedNormals+ sNormalList = normalList ++ smoothedNormals 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) + 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- -> (Map (Maybe Int) [Object],Material,Maybe Int,Int,Int,Int)+ -> (IntMap [IObject],Material,Int,Int,Int,Int) -> Statement- -> (Map (Maybe Int) [Object],Material,Maybe Int,Int,Int,Int)+ -> (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) =- (M.insertWith (++) sg [OPoint (map (mkAbs vc) ps)] os, cm,sg,vc,nc,tc)+ (IM.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)+ (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 -> (M.insertWith (++) sg [OTriangle cm (absoluteRefs3 vc nc tc ps)] os+ 3 -> (IM.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+ 4 -> (IM.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+ _ -> (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 )@@ -278,40 +296,64 @@ 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))+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 = M.fromList $ zip vs [nns..]+ normalMap = IM.fromList $ zip vs [(loff - nns - lgn)..] gns = map (makeNormal vb g) vs+ lgn = length gns vs = concatMap objVerticies g -applyNormals :: Map Int Int -> Object -> Object+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 _ x = x+applyNormals _ (OLine vs) = OLine vs+applyNormals _ (OPoint vs) = OPoint vs -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+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 -> [Object] -> Int -> Normal3 GLfloat+makeNormal :: VertexBuffer -> [IObject] -> Int -> Normal3 GLfloat makeNormal vb os =- uncurry3 Normal3 . averageVec- . map (uncurry crossProduct . createVectors- . lookupVerticies vb)- . (findVertexNeighbors os)+ averageVec . map (uncurry (flip crossProduct) . createVectors+ . lookupVerticies vb)+ . (findVertexNeighbors os) where- findVertexNeighbors :: [Object] -> Int -> [(Int,Int,Int)]+ findVertexNeighbors :: [IObject] -> Int -> [(Int,Int,Int)] findVertexNeighbors objs v = foldr (findVertexPair v) [] objs - findVertexPair :: Int -> Object -> [(Int,Int,Int)] -> [(Int,Int,Int)]+ 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@@ -335,33 +377,41 @@ -> (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)+createVectors :: (Vertex4 GLfloat,Vertex4 GLfloat,Vertex4 GLfloat)+ -> (Normal3 GLfloat,Normal3 GLfloat)+createVectors (a,b,c) = (a .-. b,c .-. b) -objVerticies :: Object -> [Int]+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@@ -370,42 +420,35 @@ 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 :: Int -> Int -> [VDouble] -> [VDouble] absoluteRefs2 c c' =- uncurry zip . (\(x,y) -> (map (mkAbs c) x- ,map (liftM (mkAbs c')) y)) . unzip+ map (\(VD x y) -> VD (mkAbs c x) (mkAbs c' <$> y)) -absoluteRefs3 :: Int -> Int -> Int -> [(Int,Maybe Int,Maybe Int)]- -> [(Int,Maybe Int,Maybe Int)]+absoluteRefs3 :: Int -> Int -> Int -> [VTriple] -> [VTriple] 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+ map (\(VTr x y z) -> VTr (mkAbs c x) (mkAbs c' <$> y) (mkAbs c'' <$> z)) -trippleVertex :: (Int,Maybe Int,Maybe Int) -> Int-trippleVertex (v,_,_) = v+trippleVertex :: VTriple -> Int+trippleVertex (VTr v _ _) = v -offsetObjects :: Int -> Int -> Int -> [Object] -> [Object]+offsetObjects :: Int -> Int -> Int -> [FObject] -> [FObject] 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 :: Int -> Int -> Int -> FObject -> FObject+offsetObj vo to no (OFace m ts) =+ OFace m $ map (\(NVT v t n) -> NVT (v-vo)+ (t >>= return . ((flip (-)) to))+ (n-no)) 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+ OTriangle m $ map (\(NVT v t n) -> NVT (v-vo)+ (t >>= return . ((flip (-)) to))+ (n-no)) 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+ OQuad m $ map (\(NVT v t n) -> NVT (v-vo)+ (t >>= return . ((flip (-)) to))+ (n-no)) ts offsetObj vo _ to (OLine ts) =- OLine $ map (\(x,z) -> (x-vo- ,z >>= return . ((flip (-)) to))) ts+ OLine $ map (\(VD v t) -> VD (v-vo)+ (t >>= return . ((flip (-)) to))) ts offsetObj vo _ _ (OPoint ts) = OPoint $ map ((flip (-)) vo) ts @@ -419,12 +462,14 @@ 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 :: 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
src/Graphics/Formats/Obj/Parse.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans -funbox-strict-fields #-} ---------------------------------------------------------------------- -- | -- Module : Graphics.Formats.Obj.Parse@@ -60,15 +60,13 @@ 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'+ 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 putByteString gs >> put '\n'+ put (SG g) = putString "s " >> putShow g >> put '\n'+ put (MtlLib m) = put "mtllib" >> putList putByteString m >> put '\n'+ put (UseMtl m) = put "usemtl " >> putByteString m >> put '\n' get = undefined @@ -78,15 +76,15 @@ putShow :: Show a => a -> Put putShow = putString . show -putList :: Binary a => (a -> Put) -> [a] -> Put+putList :: (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+putDouble (VD x (Just y)) = putShow x >> put '/' >> putShow y+putDouble (VD x Nothing ) = putShow x putTriple :: VTriple -> Put-putTriple (v,t,n) =+putTriple (VTr v t n) = putShow v >> case (t,n) of (Nothing,Just n') -> putString "//" >> putShow n'@@ -103,22 +101,21 @@ 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+ '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+ _ | (CBS.pack "vn") `CBS.isPrefixOf` s+ -> Just . runParse parseNormal . CBS.tail $ s+ _ | (CBS.pack "vt") `CBS.isPrefixOf` s+ -> Just . runParse parseTexCoord . CBS.tail $ s+ 'v' -> Just . runParse parseVertex $ s+ _ | (CBS.pack "mtllib") `CBS.isPrefixOf` s+ -> Just . MtlLib . runParse parseMtlLib . CBS.drop 5 $ s+ _ | (CBS.pack "usemtl") `CBS.isPrefixOf` s+ -> Just . UseMtl . runParse parseUseMtl . CBS.drop 5 $ s+ _ -> Nothing else Nothing runParse :: (CBS.ByteString -> a) -> CBS.ByteString -> a@@ -130,30 +127,43 @@ parsePoints :: CBS.ByteString -> [Int] parseLines :: CBS.ByteString -> [VDouble] parseFace :: CBS.ByteString -> [VTriple]-parsePoints = bSwords unsafeReadInt-parseLines = bSwords readDouble-parseFace = bSwords readTriple+parsePoints = map unsafeReadInt . bsWords+parseLines = map readDouble . bsWords+parseFace = map readTriple . bsWords -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+parseGroups :: CBS.ByteString -> [CBS.ByteString]+parseSmoothGroup :: CBS.ByteString -> Int+parseGroups = map parseName . bsWords+parseSmoothGroup = if' <$> (== CBS.pack "off") <*> (const 0) <*> unsafeReadInt -parseMtlLib :: CBS.ByteString -> [String]-parseUseMtl :: CBS.ByteString -> String-parseMtlLib = bSwords parseName-parseUseMtl = head . bSwords parseName+parseMtlLib :: CBS.ByteString -> [CBS.ByteString]+parseUseMtl :: CBS.ByteString -> CBS.ByteString+parseMtlLib = map parseName . bsWords+parseUseMtl = parseName . head . bsWords -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+parseNormal :: CBS.ByteString -> Statement+parseTexCoord :: CBS.ByteString -> Statement+parseVertex :: CBS.ByteString -> Statement+parseNormal s = let Just (x,s' ) = unsafeRFloat s+ Just (y,s'') = unsafeRFloat s'+ Just (z,_ ) = unsafeRFloat s''+ in VN x y z+parseTexCoord s = let Just (x,s') = unsafeRFloat s+ y = unsafeRFloat s'+ in case y of+ Just (y',r) -> case unsafeRFloat r of+ Just (z,_) -> VT x y' z+ Nothing -> VT x y' 0+ Nothing -> VT x 0 0+parseVertex 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',_) -> V x y z w'+ Nothing -> V x y z 1 + unsafeReadInt :: CBS.ByteString -> Int unsafeReadInt x = case CBS.readInt x of Just (i,_) -> i@@ -162,8 +172,8 @@ readDouble :: CBS.ByteString -> VDouble readDouble x = if CBS.length b > 1- then (unsafeReadInt a, Just . unsafeReadInt $ CBS.tail b)- else (unsafeReadInt a, Nothing)+ then VD (unsafeReadInt a) (Just . unsafeReadInt $ CBS.tail b)+ else VD (unsafeReadInt a) Nothing where (a,b) = CBS.break (=='/') x @@ -172,7 +182,7 @@ -- v, v/t, v//n, v/t/n readTriple :: CBS.ByteString -> VTriple readTriple vtns = - (v,t,n)+ VTr v t n where (vs,tnr) = CBS.break (=='/') vtns (ts,nr ) = if CBS.length tnr > 0@@ -190,43 +200,10 @@ 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 :: ObjFile -> [CBS.ByteString] mtllibs (OF f) = concatMap stmtMtlLibs f -stmtMtlLibs :: Statement -> [String]+stmtMtlLibs :: Statement -> [CBS.ByteString] stmtMtlLibs (MtlLib xs) = xs stmtMtlLibs _ = []
src/Graphics/Formats/Obj/ParserBits.hs view
@@ -14,7 +14,7 @@ module Graphics.Formats.Obj.ParserBits (unsafeReadFloat,unsafeRFloat ,anyOf- ,consumeWS,firstWord, bSwords,removeComments,parseName) where+ ,consumeWS,firstWord, bsWords,removeComments,parseName) where import Foreign import Foreign.C.String@@ -26,6 +26,7 @@ import Data.Maybe import Control.Applicative hiding ((<|>))+import Control.Applicative.Infix unsafeReadFloat :: CBS.ByteString -> Float unsafeReadFloat =@@ -59,9 +60,9 @@ anyOf :: [a -> Bool] -> a -> Bool anyOf = foldr (liftA2 (||)) (const False) -bSwords :: (CBS.ByteString -> a) -> CBS.ByteString -> [a]-bSwords f = map f . filter ((>0) . CBS.length)- . CBS.splitWith (liftA2 (||) (==' ') (=='\t'))+bsWords :: CBS.ByteString -> [CBS.ByteString]+bsWords =+ filter ((>0) . CBS.length) . CBS.splitWith ((==' ') <^(||)^> (=='\t')) removeComments :: CBS.ByteString -> CBS.ByteString removeComments bs = case CBS.split '#' bs of@@ -69,11 +70,11 @@ (x:_) -> x consumeWS :: CBS.ByteString -> CBS.ByteString-consumeWS = CBS.dropWhile (liftA2 (||) (==' ') (=='\t'))+consumeWS = CBS.dropWhile ((==' ') <^(||)^> (=='\t')) firstWord :: CBS.ByteString -> CBS.ByteString firstWord = CBS.takeWhile ( not . anyOf [(==' '), (=='\t'), (=='\n'), (=='\r')]) -parseName :: CBS.ByteString -> String-parseName = CBS.unpack . firstWord . consumeWS+parseName :: CBS.ByteString -> CBS.ByteString+parseName = firstWord . consumeWS