1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
module Data.Obj3D.Parser ( Vertex
, VertexNormal
, TexCoord
, 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 TexCoord = (Float, Float)
type FaceVertex = (Integer, Maybe Integer, Maybe Integer)
type Face = (FaceVertex, FaceVertex, FaceVertex)
data ObjLine = VertexLine Vertex | TexCoordLine TexCoord | VertexNormalLine VertexNormal | FaceLine Face | ObjectLine String | UnknownLine String | EmptyLine
deriving Show
data ParserState = ParserState
{ vertexCount :: Integer
, texCoordCount :: 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 $ texCoordCount 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)
texCoordLine :: Parser ObjLine
texCoordLine = do
try $ do
string "vt"
spaces
u <- float
spaces
v <- float
optional $ do
spaces
float
updateState $ \state -> state {texCoordCount = 1 + texCoordCount state}
return $ TexCoordLine (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 <|> texCoordLine <|> 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)
|
