{-# LANGUAGE OverloadedStrings #-}
module Data.CSG.Parser
( parseGeometry
, parseGeometryFile
)
where
import Prelude as P
import Control.Applicative
import qualified Control.Exception as E
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Data.Attoparsec.ByteString.Char8
import Data.ByteString.Char8 as B
import qualified Data.Map as M
import Data.Vec3 hiding (Vec3, Matrix)
import qualified Data.CSG as CSG
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 = fmap (M.insert key value) get >>= put
getEntry :: (Ord k, Monad a) => k -> TableT a k v (Maybe v)
getEntry key = fmap (M.lookup key) get
type CSGParser = TableT Parser String CSG.Solid
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 CSG.Point
triple = fmap fromXYZ $
(,,) <$> double
<*>
(skipSpace *> comma *> skipSpace *>
double
<* skipSpace <* comma <* skipSpace)
<*>
double
keywords :: [String]
keywords = [ "solid"
, "tlo"
, "orthobrick"
, "plane"
, "sphere"
, "cylinder"
, "cone"
]
varName :: CSGParser String
varName = do
k <- lift $ many1 (letter_ascii <|> digit)
if k `P.notElem` keywords
then return k
else fail ("Unexpected keyword when reading a solid name: " ++ k)
readName :: CSGParser CSG.Solid
readName = do
k <- varName
v <- getEntry k
case v of
Just b -> return b
_ -> fail $ "Undefined solid: " ++ k
plane :: Parser CSG.Solid
plane = CSG.plane <$>
(string "plane" *> skipSpace *> lp *> skipSpace *> triple) <*>
(skipSpace *> cancer *> skipSpace *> triple <* skipSpace <* rp)
orthobrick :: Parser CSG.Solid
orthobrick = CSG.cuboid <$>
(string "orthobrick" *> skipSpace *> lp *> skipSpace *> triple) <*>
(skipSpace *> cancer *> skipSpace *> triple <* skipSpace <* rp)
sphere :: Parser CSG.Solid
sphere = CSG.sphere <$>
(string "sphere" *> skipSpace *> lp *> skipSpace *> triple) <*>
(skipSpace *> cancer *> skipSpace *> double <* skipSpace <* rp)
cylinder :: Parser CSG.Solid
cylinder = CSG.cylinderFrustum <$>
(string "cylinder" *> skipSpace *> lp *> skipSpace *> triple) <*>
(skipSpace *> cancer *> skipSpace *> triple) <*>
(skipSpace *> cancer *> skipSpace *> double <* skipSpace <* rp)
cone :: Parser CSG.Solid
cone = CSG.coneFrustum <$>
((,) <$>
(string "cone" *> skipSpace *> lp *> skipSpace *> triple) <*>
(skipSpace *> cancer *> skipSpace *> double)) <*>
((,) <$>
(skipSpace *> cancer *> skipSpace *> triple) <*>
(skipSpace *> cancer *> skipSpace *> double <* skipSpace <* rp))
primitive :: Parser CSG.Solid
primitive = plane <|> orthobrick <|> sphere <|> cylinder <|> cone
complement :: CSGParser CSG.Solid
complement = CSG.complement <$> (lift (string "not" *> skipSpace) *> solid)
union :: CSGParser CSG.Solid
union = binary "or" CSG.unite
intersection :: CSGParser CSG.Solid
intersection = binary "and" CSG.intersect
binary :: ByteString -> (CSG.Solid -> CSG.Solid -> CSG.Solid) -> CSGParser CSG.Solid
binary op compose = do
b1 <- uncomposedSolid
lift (skipSpace *> string op *> skipSpace)
b2 <- solid
return $ compose b1 b2
statement :: CSGParser ()
statement = do
lift $ skipSpace *> string "solid" *> skipSpace
k <- varName
lift $ skipSpace <* eq <* skipSpace
v <- solid <* lift (cancer *> skipSpace)
addEntry k v
solid :: CSGParser CSG.Solid
solid = union <|> intersection <|> complement <|> uncomposedSolid
uncomposedSolid :: CSGParser CSG.Solid
uncomposedSolid = lift primitive <|> readName
topLevel :: CSGParser CSG.Solid
topLevel = lift (string "tlo" *> skipSpace) *>
readName
<* lift (cancer <* skipSpace)
comment :: Parser ()
comment = char '#' >> manyTill anyChar endOfLine >> return ()
geoFile :: CSGParser CSG.Solid
geoFile = many1 (lift comment <|> statement) *> topLevel
parseGeometry :: ByteString -> Either String CSG.Solid
parseGeometry input =
case parseOnly (runStateT geoFile M.empty) input of
Right (b, _) -> Right b
Left msg -> Left msg
parseGeometryFile :: FilePath -> IO (Either String CSG.Solid)
parseGeometryFile file = do
res <- E.try $ B.readFile file
return $ case res of
Right d -> parseGeometry d
Left e -> Left $ show (e :: E.IOException)