Initial commit

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)