diff options
Diffstat (limited to 'src/Data')
| -rw-r--r-- | src/Data/Obj3D.hs | 63 | ||||
| -rw-r--r-- | src/Data/Obj3D/Parser.hs | 174 |
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) |