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)