summaryrefslogtreecommitdiffstats
path: root/src/Data/Obj3D
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/Data/Obj3D
downloadobj-model-67e1d2569baa712c40be26998dd3661ad8f3caa4.tar
obj-model-67e1d2569baa712c40be26998dd3661ad8f3caa4.zip
Initial commit
Diffstat (limited to 'src/Data/Obj3D')
-rw-r--r--src/Data/Obj3D/Parser.hs174
1 files changed, 174 insertions, 0 deletions
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)