summaryrefslogtreecommitdiffstats
path: root/src
diff options
context:
space:
mode:
authorMatthias Schiffer <matthias@gamezock.de>2010-04-11 20:45:20 +0200
committerMatthias Schiffer <matthias@gamezock.de>2010-04-11 20:45:20 +0200
commit67e1d2569baa712c40be26998dd3661ad8f3caa4 (patch)
tree650af2373deafae186ceffff3f9ae43d5379f2d4 /src
downloadobj-model-67e1d2569baa712c40be26998dd3661ad8f3caa4.tar
obj-model-67e1d2569baa712c40be26998dd3661ad8f3caa4.zip
Initial commit
Diffstat (limited to 'src')
-rw-r--r--src/Data/Obj3D.hs63
-rw-r--r--src/Data/Obj3D/Parser.hs174
2 files changed, 237 insertions, 0 deletions
diff --git a/src/Data/Obj3D.hs b/src/Data/Obj3D.hs
new file mode 100644
index 0000000..c25deb8
--- /dev/null
+++ b/src/Data/Obj3D.hs
@@ -0,0 +1,63 @@
+module Data.Obj3D ( processObj
+ , loadObj
+ , loadObjFile
+ , Vertex
+ , VertexNormal
+ , TexCoords
+ , FaceVertex
+ , Face
+ , SourceName
+ , ParseError
+ ) where
+
+import Control.Arrow
+import Control.Monad
+import Data.Maybe
+
+import Data.Obj3D.Parser
+
+data ObjModel = ObjModel
+ { objVertices :: [Vertex]
+ , objTexCoords :: [TexCoords]
+ , objNormals :: [VertexNormal]
+ , objFaces :: [[Face]]
+ } deriving Show
+
+processObj :: [ObjLine] -> ObjModel
+processObj objlines = ObjModel
+ { objVertices = vertices
+ , objTexCoords = texcoords
+ , objNormals = normals
+ , objFaces = faces
+ }
+ where
+ vertices = catMaybes $ map vertex objlines
+ vertex (VertexLine v) = Just v
+ vertex _ = Nothing
+
+ texcoords = catMaybes $ map texcoord objlines
+ texcoord (TexCoordsLine v) = Just v
+ texcoord _ = Nothing
+
+
+ normals = catMaybes $ map normal objlines
+ normal (VertexNormalLine n) = Just n
+ normal _ = Nothing
+
+ faces = filter (not . null) $ map (catMaybes . map face) $ splitLines objlines
+ face (FaceLine f) = Just f
+ face _ = Nothing
+
+ splitLines [] = []
+ splitLines l = let (l1, l2) = break isObjectLine l
+ in l1 : (if null l2 then [] else splitLines $ tail l2)
+
+ isObjectLine (ObjectLine _) = True
+ isObjectLine _ = False
+
+
+loadObj :: SourceName -> String -> Either ParseError ObjModel
+loadObj fname = right processObj . parseObj fname
+
+loadObjFile :: SourceName -> IO (Either ParseError ObjModel)
+loadObjFile fname = liftM (loadObj fname) $ readFile fname
diff --git a/src/Data/Obj3D/Parser.hs b/src/Data/Obj3D/Parser.hs
new file mode 100644
index 0000000..2d3dbce
--- /dev/null
+++ b/src/Data/Obj3D/Parser.hs
@@ -0,0 +1,174 @@
+module Data.Obj3D.Parser ( Vertex
+ , VertexNormal
+ , TexCoords
+ , FaceVertex
+ , Face
+ , ObjLine(..)
+ , parseObj
+ , SourceName
+ , ParseError
+ ) where
+
+import Control.Monad
+import Text.ParserCombinators.Parsec hiding (space, spaces, Parser)
+
+
+type Vertex = (Float, Float, Float)
+type VertexNormal = (Float, Float, Float)
+type TexCoords = (Float, Float)
+type FaceVertex = (Integer, Maybe Integer, Maybe Integer)
+type Face = (FaceVertex, FaceVertex, FaceVertex)
+
+data ObjLine = VertexLine Vertex | TexCoordsLine TexCoords | VertexNormalLine VertexNormal | FaceLine Face | ObjectLine String | UnknownLine String | EmptyLine
+ deriving Show
+
+data ParserState = ParserState
+ { vertexCount :: Integer
+ , texCoordsCount :: Integer
+ , vertexNormalCount :: Integer
+ }
+
+type Parser a = GenParser Char ParserState a
+
+
+noNewline :: Parser Char
+noNewline = noneOf "\n"
+
+validChar :: Parser Char
+validChar = noneOf "\n#"
+
+space :: Parser Char
+space = oneOf " \t"
+
+spaces :: Parser String
+spaces = many1 space
+
+float :: Parser Float
+float = ( do
+ sign <- option "" $ string "-"
+ intpart <- many1 digit
+ fracpart <- option "0" $ do
+ char '.'
+ many1 digit
+ return $ read $ sign ++ intpart ++ "." ++ fracpart
+ ) <?> "float"
+
+integer :: Parser Integer
+integer = ( do
+ sign <- option "" $ string "-"
+ digits <- many1 digit
+ return $ read $ sign ++ digits
+ ) <?> "integer"
+
+relativeInteger :: Integer -> Parser Integer
+relativeInteger rel = do
+ value <- integer
+ let absval = if value < 0 then (rel + value + 1) else value
+ when (absval <= 0 || absval > rel) $ fail $ "invalid index " ++ show value
+ return absval
+
+faceVertex :: Parser FaceVertex
+faceVertex = do
+ state <- getState
+ v <- liftM (subtract 1) $ relativeInteger $ vertexCount state
+ (t, n) <- option (Nothing, Nothing) $ do
+ char '/'
+ t <- option Nothing $ liftM (Just . subtract 1) $ relativeInteger $ texCoordsCount state
+ n <- option Nothing $ do
+ char '/'
+ option Nothing $ liftM (Just . subtract 1) $ relativeInteger $ vertexNormalCount state
+ return (t, n)
+ return (v, t, n)
+
+comment :: Parser String
+comment = do
+ char '#'
+ many noNewline
+
+vertexLine :: Parser ObjLine
+vertexLine = do
+ try $ do
+ string "v"
+ spaces
+ x <- float
+ spaces
+ y <- float
+ spaces
+ z <- float
+ optional $ do
+ spaces
+ float
+ updateState $ \state -> state {vertexCount = 1 + vertexCount state}
+ return $ VertexLine (x, y, z)
+
+texCoordsLine :: Parser ObjLine
+texCoordsLine = do
+ try $ do
+ string "vt"
+ spaces
+ u <- float
+ spaces
+ v <- float
+ optional $ do
+ spaces
+ float
+ updateState $ \state -> state {texCoordsCount = 1 + texCoordsCount state}
+ return $ TexCoordsLine (u, v)
+
+vertexNormalLine :: Parser ObjLine
+vertexNormalLine = do
+ try $ do
+ string "vn"
+ spaces
+ x <- float
+ spaces
+ y <- float
+ spaces
+ z <- float
+ updateState $ \state -> state {vertexNormalCount = 1 + vertexNormalCount state}
+ return $ VertexNormalLine (x, y, z)
+
+faceLine :: Parser ObjLine
+faceLine = do
+ try $ do
+ string "f"
+ spaces
+ v1 <- faceVertex
+ spaces
+ v2 <- faceVertex
+ spaces
+ v3 <- faceVertex
+ return $ FaceLine (v1, v2, v3)
+
+objectLine :: Parser ObjLine
+objectLine = do
+ try $ do
+ string "o"
+ spaces
+ name <- many1 (alphaNum <|> oneOf "._")
+ return $ ObjectLine name
+
+anyLine :: Parser ObjLine
+anyLine = liftM UnknownLine $ many1 validChar
+
+emptyLine :: Parser ObjLine
+emptyLine = return EmptyLine
+
+line :: Parser ObjLine
+line = do
+ optional spaces
+ l <- vertexLine <|> texCoordsLine <|> vertexNormalLine <|> faceLine <|> objectLine <|> anyLine <|> emptyLine
+ optional spaces
+ optional comment
+ newline
+ return l
+
+obj :: Parser [ObjLine]
+obj = do
+ lines <- many line
+ eof
+ return lines
+
+
+parseObj :: SourceName -> String -> Either ParseError [ObjLine]
+parseObj = runParser obj (ParserState 0 0 0)