module DSMC.Traceables.Parser
( parseBody
, parseBodyFile
)
where
import Prelude as P
import Control.Applicative
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Data.Attoparsec.Char8
import Data.ByteString.Char8 as B
import qualified Data.Map as M
import qualified DSMC.Traceables as T
import DSMC.Util.Vector
type TableT a k v = StateT (M.Map k v) a
addEntry :: (Ord k, Monad a) => k -> v -> TableT a k v ()
addEntry key value = liftM (M.insert key value) get >>= put
getEntry :: (Ord k, Monad a) => k -> TableT a k v (Maybe v)
getEntry key = liftM (M.lookup key) get
type CSGParser = TableT Parser String T.Body
lp :: Parser Char
lp = char '('
rp :: Parser Char
rp = char ')'
eq :: Parser Char
eq = char '='
cancer :: Parser Char
cancer = char ';'
comma :: Parser Char
comma = char ','
triple :: Parser Point
triple = (,,) <$> double
<*>
(skipSpace *> comma *> skipSpace *>
double
<* skipSpace <* comma <* skipSpace)
<*>
double
keywords :: [String]
keywords = [ "solid"
, "tlo"
, "plane"
, "sphere"
, "cylinder"
, "cone"
]
varName :: CSGParser String
varName = do
k <- lift $ many1 (letter_ascii <|> digit)
case (P.elem k keywords) of
False -> return k
True -> fail $ "Unexpected keyword: " ++ k
readName :: CSGParser T.Body
readName = do
k <- varName
v <- getEntry k
case v of
Just b -> return b
_ -> fail $ "Undefined solid: " ++ k
plane :: Parser T.Body
plane = T.plane <$>
(string "plane" *> skipSpace *> lp *> skipSpace *> triple) <*>
(skipSpace *> cancer *> skipSpace *> triple <* skipSpace <* rp)
sphere :: Parser T.Body
sphere = T.sphere <$>
(string "sphere" *> skipSpace *> lp *> skipSpace *> triple) <*>
(skipSpace *> cancer *> skipSpace *> double <* skipSpace <* rp)
cylinder :: Parser T.Body
cylinder = T.cylinderFrustum <$>
(string "cylinder" *> skipSpace *> lp *> skipSpace *> triple) <*>
(skipSpace *> cancer *> skipSpace *> triple) <*>
(skipSpace *> cancer *> skipSpace *> double <* skipSpace <* rp)
cone :: Parser T.Body
cone = T.coneFrustum <$>
((,) <$>
(string "cone" *> skipSpace *> lp *> skipSpace *> triple) <*>
(skipSpace *> cancer *> skipSpace *> double)) <*>
((,) <$>
(skipSpace *> cancer *> skipSpace *> triple) <*>
(skipSpace *> cancer *> skipSpace *> double <* skipSpace <* rp))
primitive :: Parser T.Body
primitive = plane <|> sphere <|> cylinder <|> cone
complement :: CSGParser T.Body
complement = T.complement <$> (lift (string "not" *> skipSpace) *> body)
union :: CSGParser T.Body
union = binary "or" T.unite
intersection :: CSGParser T.Body
intersection = binary "and" T.intersect
binary :: ByteString -> (T.Body -> T.Body -> T.Body) -> CSGParser T.Body
binary op compose = do
b1 <- uncomposedBody
lift (skipSpace *> string op *> skipSpace)
b2 <- body
return $ compose b1 b2
statement :: CSGParser ()
statement = do
lift $ string "solid" *> skipSpace
k <- varName
lift $ skipSpace <* eq <* skipSpace
v <- body <* lift (cancer *> skipSpace)
addEntry k v
body :: CSGParser T.Body
body = union <|> intersection <|> complement <|> uncomposedBody
uncomposedBody :: CSGParser T.Body
uncomposedBody = lift primitive <|> readName
topLevel :: CSGParser T.Body
topLevel = lift (string "tlo" *> skipSpace) *>
readName
<* lift (cancer <* skipSpace)
comment :: Parser ()
comment = char '#' >> (manyTill anyChar endOfLine) >> return ()
geoFile :: CSGParser T.Body
geoFile = (many1 $ lift comment <|> statement) *> topLevel
parseBody :: ByteString -> Either String T.Body
parseBody input =
case (parseOnly (runStateT geoFile M.empty) input) of
Right (b, _) -> Right b
Left msg -> Left msg
parseBodyFile :: FilePath -> IO (Either String T.Body)
parseBodyFile file = do
res <- E.try $ B.readFile file
return $ case res of
Right d -> parseBody d
Left e -> Left $ show (e :: E.IOException)