summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--.gitignore2
-rw-r--r--LICENSE26
-rw-r--r--Setup.lhs3
-rw-r--r--obj-model.cabal16
-rw-r--r--src/Data/Obj3D.hs63
-rw-r--r--src/Data/Obj3D/Parser.hs174
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
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..c7a0aa4
--- /dev/null
+++ b/LICENSE
@@ -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)