summaryrefslogtreecommitdiffstats
path: root/src/Data/Obj3D/Parser.hs
blob: 408eab54c0cc4cfa83a10e6b6d3db3adeafa8771 (plain)
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)