module Math.Integrators.RK.Parser
( readMatrixTable
)
where
import Data.Maybe
import Text.Parsec
import qualified Text.Parsec.Token as P
import Text.Parsec.Language (haskellDef)
import Text.Parsec.Expr
import Text.Parsec.String
import Math.Integrators.RK.Internal
readMatrixTable :: String -> [MExp]
readMatrixTable =
mapMaybe go . lines
where
go ('-':s) = Just Delimeter
go ('#':s) = Nothing
go (ls) | null.filter (==' ')$ ls = Nothing
| otherwise =
let (lhs,_:rhs) = span (/='|') ls
l = case filter (/= ' ') lhs of
"" -> Nothing
ls -> Just $! erun expr ls
in Just $ Row (l, map (erun expr) $! grp '&' rhs)
grp c s = case dropWhile (==c) s of
"" -> []
s' -> if any (/=' ') w then w : grp c c'' else grp c c''
where (w,c'') = break (==c) s'
lexer = P.makeTokenParser haskellDef { P.reservedOpNames = ["*","/","+","-","sqrt","sin","cos"] }
whiteSpace= P.whiteSpace lexer
lexeme = P.lexeme lexer
symbol = P.symbol lexer
float = P.float lexer
parens = P.parens lexer
natural = P.natural lexer
identifier= P.identifier lexer
reserved = P.reserved lexer
reservedOp= P.reservedOp lexer
expr :: Parser Double
expr = buildExpressionParser table factor
<?> "expression"
factor = parens expr
<|> try float
<|> fmap realToFrac natural
<?> "simple expression"
table = [ [prefix "-" negate]
, [prefix "sqrt" sqrt,prefix "sin" sin,prefix "cos" cos]
, [op "*" (*) AssocLeft, op "/" (/) AssocLeft]
, [op "+" (+) AssocLeft, op "-" () AssocLeft]
]
where
op s f assoc = Infix (do{ reservedOp s; return f} <?> "operator") assoc
prefix s f = Prefix (do { reservedOp s; return f} <?> "prefix")
erun :: Parser Double -> String -> Double
erun p input = erun' (do { whiteSpace ; x <- p ; eof; return x})
where
erun' p' = case (parse p' "" input) of
Left err -> error $ "Parse error at "++(show err)
Right x -> x