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)