
module TRTParser ( RTObject (Prop, Object)
                 , RTProp (DProp, SProp, BProp)
                 , getObjectsFromFile
                 )
    where

import Control.Applicative hiding ((<|>), many)
import Control.Monad (MonadPlus(..))
import Data.Maybe (fromMaybe, fromJust)
import Text.ParserCombinators.Parsec hiding (space, spaces)
import ParserCommon

data RTProp = DProp [Double] | SProp String | BProp Bool
    deriving Show

data RTObject = Prop String RTProp
              | Object String String [RTObject]
    deriving Show

type RTObjectTable = [(String, RTObject)]
data RTState = RTState { materials :: RTObjectTable
                       , textures  :: RTObjectTable
                       }

type RTParser = GenParser Char RTState

dprop = do
    n <- sepEndBy1 word spaces
    equals
    v <- spaceSepList
    return $ Prop (unwords n) (DProp v)
    <?> "property"

sprop = do
    n <- sepEndBy1 word spaces
    equals
    spaces
    char '"'
    v <- manyTill (noneOf "\n\r ") (char '"')
    spaces >> (try comment <|> eol)
    return $ Prop (unwords n) (SProp v)

bprop = do
    n <- sepEndBy1 word spaces
    equals
    spaces
    bs <- try (string "True") <|> string "False"
    spaces >> (try comment <|> eol)
    return $ Prop (unwords n) (BProp $ bs == "True")

colour :: RTParser [Double]
colour = do
    c <- choice $ map (try . string . fst) colourMap
    return $ fromMaybe [0,0,0] $ lookup c colourMap
    <?> "colour"
    where
        colourMap = [ ("black",  [0, 0, 0])
                    , ("white",  [1, 1, 1])
                    , ("red",    [1, 0, 0])
                    , ("green",  [0, 1, 0])
                    , ("blue",   [0, 0, 1])
                    , ("yellow", [1, 1, 0])
                    , ("gray5",  [0.05, 0.05, 0.05])
                    , ("gray10", [0.10, 0.10, 0.10])
                    , ("gray15", [0.15, 0.15, 0.15])
                    , ("gray20", [0.20, 0.20, 0.20])
                    , ("gray25", [0.25, 0.25, 0.25])
                    , ("gray30", [0.30, 0.30, 0.30])
                    , ("gray35", [0.35, 0.35, 0.35])
                    , ("gray40", [0.40, 0.40, 0.40])
                    , ("gray45", [0.45, 0.45, 0.45])
                    , ("gray50", [0.50, 0.50, 0.50])
                    , ("gray55", [0.55, 0.55, 0.55])
                    , ("gray60", [0.60, 0.60, 0.60])
                    , ("gray65", [0.65, 0.65, 0.65])
                    , ("gray70", [0.70, 0.70, 0.70])
                    , ("gray75", [0.75, 0.75, 0.75])
                    , ("gray80", [0.80, 0.80, 0.80])
                    , ("gray85", [0.85, 0.85, 0.85])
                    , ("gray90", [0.90, 0.90, 0.90])
                    , ("gray95", [0.95, 0.95, 0.95])
                    ]

colourProp = do
    string "Colour"
    equals
    c <- colour
    spaces >> (try comment <|> eol)
    return $ Prop "Colour" (DProp c)
    <?> "colour property"

material :: RTParser RTObject
material = do
    st <- fmap materials getState
    m  <- choice $ map (try . string . fst) st
    let rt = lookup m st
    case rt of
         (Just _) -> return $ fromJust rt
         Nothing  -> fail $ "material not defined: " ++ m
    <?> "material name"

texture :: RTParser RTObject
texture = do
    st <- fmap textures getState
    t  <- choice $ map (string . fst) st
    let rt = lookup t st
    case rt of
         (Just _) -> return $ fromJust rt
         Nothing  -> fail $ "texture not defined: " ++ t
    <?> "texture name"

materialProp = do
    string "Material"
    equals
    m <- material
    spaces >> (try comment <|> eol)
    return m
    <?> "material property"

textureProp = do
    string "Texture"
    equals
    t <- texture
    spaces >> (try comment <|> eol)
    return t
    <?> "texture property"

global = dprop <|> sprop <|> bprop <?> "global property"

objName = do
    n  <- letter
    ns <- word <|> return ""
    string "::"
    obj <- many1 word
    spaces >> (try comment <|> eol)
    return $ (,) (n:ns) (unwords obj)
    <?> "object name"

objProp = do
    spaces
    p <-  try dprop
      <|> try sprop
      <|> try bprop
      <|> try colourProp  -- FIXME colour not actually appropriate for all objects
      <|> try textureProp -- FIXME not appropriate for all
      <|> materialProp    -- FIXME not appropriate for all
    return p
    <?> "object property"

object = do
    (name, obj) <- objName
    props <- many objProp
    return $ Object name obj props

block = do
    rt <- try global <|> object
    st <- getState
    case rt of
         obj@(Object name "Material" _) -> setState $ st { materials = ((name,obj):(materials st)) }
         obj@(Object name "Texture" _)  -> setState $ st { textures  = ((name,obj):(textures st)) }
         otherwise                      -> return ()
    many ignoreline
    return rt
    <?> "block"

trtFileParser :: RTParser [RTObject]
trtFileParser = do
    many ignoreline
    r <- many block
    return r

getObjectsFromFile :: String -> IO [RTObject]
getObjectsFromFile fn = do
    fileS <- readFile fn
    let initState = RTState { materials = [], textures = [] }
    case runParser trtFileParser initState fn fileS of
         Left e     -> do putStrLn "Failed parsing input file:"
                          print e
                          return []
         Right objs -> return objs

