diff options
| -rw-r--r-- | .gitignore | 2 | ||||
| -rw-r--r-- | LICENSE | 26 | ||||
| -rw-r--r-- | Setup.lhs | 3 | ||||
| -rw-r--r-- | obj-model.cabal | 16 | ||||
| -rw-r--r-- | src/Data/Obj3D.hs | 63 | ||||
| -rw-r--r-- | src/Data/Obj3D/Parser.hs | 174 |
6 files changed, 284 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..733412c --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*~ +dist @@ -0,0 +1,26 @@ +Copyright (c) The Regents of the University of California. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 index 0000000..5bde0de --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/obj-model.cabal b/obj-model.cabal new file mode 100644 index 0000000..97ccbdc --- /dev/null +++ b/obj-model.cabal @@ -0,0 +1,16 @@ +name: obj-model +version: 0.1 +synopsis: OBJ model file loader +description: Parsec-based parser for Wavefront OBJ 3D models +category: Parsing, Graphics +license: BSD3 +license-file: LICENSE +author: Matthias Schiffer +maintainer: matthias@gamezock.de +build-type: Simple +Cabal-Version: >=1.2 + +library + build-depends: base >= 4, parsec + exposed-modules: Data.Obj3D, Data.Obj3D.Parser + hs-source-dirs: src 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) |