module Recognize.Parsing.MathParser
( MParser, parseMath, parseSimple', expr
) where
import Control.Monad
import Data.Char
import Data.Either
import Data.List
import Data.Maybe
import Domain.Math.Data.Relation
import Domain.Math.Expr.Data
import Domain.Math.Expr.Symbols
import Ideas.Common.Rewriting
import Ideas.Common.View
import Ideas.Utils.Parsing
import Prelude hiding ((^))
import Recognize.Data.Math
import Recognize.Data.MathParserOptions
import Recognize.Expr.Functions
import Recognize.Expr.Normalform
import Text.Parsec (Parsec)
import Util.String
type MParser = Parsec String MathParserOptions
parseMath :: MathParserOptions -> String -> (Bool, [Math])
parseMath opts s =
case parseSimple' opts (many1 chainedEquations) s of
Left msg -> (False, [ M s (Left (MathParseError msg)) ])
Right xs -> let (bs,ys) = unzip xs
in (or bs, [ M s (Right x) | x <- concat ys ])
chainedEquations :: MParser (Bool, [Expr])
chainedEquations = expr >>= chainedEquations' False
chainedEquations' :: Bool -> Expr -> MParser (Bool, [Expr])
chainedEquations' alreadyChained x = do
rel <- choice [notEqual, equal, lessThanOrEqualTo, lessThan, greaterThanOrEqualTo, greaterThan]
y <- expr
(gotChained, eqs) <- chainedEquations' True (if isVariable x then x else y)
let y_l = fromMaybe y (getMostLeft y)
let y' = if nf y_l == nf x && not (isVar y_l) then y_l else y
return (alreadyChained || gotChained, toExpr (makeType rel x y') : eqs)
<|>
return (False, [ x | not alreadyChained ])
equal :: MParser RelationType
equal = EqualTo <$ (
(try (spstring "==" >> return '=') <|> try (spchar '=' <* spaces <* spchar '=') <|> spchar '=') <* spaces
)
notEqual :: MParser RelationType
notEqual = NotEqualTo <$ (spstring "/=" <|> spstring "=/=") <* spaces
lessThan :: MParser RelationType
lessThan = LessThan <$ spchar '<' <* spaces
lessThanOrEqualTo :: MParser RelationType
lessThanOrEqualTo = LessThanOrEqualTo <$ spstring "<=" <* spaces
greaterThan :: MParser RelationType
greaterThan = GreaterThan <$ spchar '>' <* spaces
greaterThanOrEqualTo :: MParser RelationType
greaterThanOrEqualTo = GreaterThanOrEqualTo <$ spstring ">=" <* spaces
expr :: MParser Expr
expr = buildExpressionParser exprTable (term <* spaces)
term :: MParser Expr
term = foldl1 (*) <$> factor
factor :: MParser [Expr]
factor = do
n <- number
mx <- optionMaybe factor2
return (n : fromMaybe [] mx)
<|> factor2
factor2 :: MParser [Expr]
factor2 = do
xs <- many1 atom
mn <- optionMaybe number
return (xs ++ maybeToList mn)
atom :: MParser Expr
atom = getState >>= \opts ->
choice
[
try $ Sym functionCallSymbol <$> (choice (map spchar (fcallChars opts)) *> parens ((number <|> variable <$> var) `sepBy` (spchar ',' <* spaces)))
, (\x y -> Sym rootSymbol [x,y]) <$ spstring "root" <* spaces <*> expr <* spaces <*> expr
, variable <$> var
, parens (spaces *> expr <* spaces)
, brackets (spaces *> expr <* spaces)
, braces (spaces *> expr <* spaces)
]
where
fcallChars opts = ['f', 'g', 'h', 'F', 'G', 'H'] ++ functionCallWhitelist opts
exprTable :: [[Operator Char MathParserOptions Expr]]
exprTable =
[
[ Prefix (negate <$ spchar '-' <* spaces)
, Prefix (id <$ spchar '+' <* spaces)
]
, [ Prefix (Sqrt <$ spstring "sqrt" <* spaces)
]
,
[ Infix ((^) <$ spchar '^' <* spaces) AssocRight
]
, [ Infix ((*) <$ spchar '*' <* spaces) AssocLeft
, Infix ((/) <$ spchar '/' <* spaces) AssocLeft
, Infix ((/) <$ spchar ':' <* spaces) AssocLeft
]
, [ Infix ((+) <$ spchar '+' <* spaces) AssocLeft
, Infix ((-) <$ spchar '-' <* spaces) AssocLeft
, Infix ((-) <$ spchar '–' <* spaces) AssocLeft
]
]
var :: MParser String
var = getState >>= \opts ->
if multByConcatenation opts
then try $ do c <- satisfy isAlpha
when (c `elem` ("fghFGH" ++ functionCallWhitelist opts)) $ notFollowedBy (spchar '(')
return [c]
else many1 letter
parens :: MParser a -> MParser a
parens = between (spchar '(') (spchar ')')
brackets :: MParser a -> MParser a
brackets = between (spchar '[') (spchar ']')
braces :: MParser a -> MParser a
braces = between (spchar '{') (spchar '}')
spchar :: Char -> MParser Char
spchar c
| c == '/' = try (char c <* notFollowedBy (char '='))
| otherwise = char c
spstring :: String -> MParser String
spstring s = try (string s)
number :: MParser Expr
number = digitalNumber
<|> specialNumber
digitalNumber :: MParser Expr
digitalNumber = do
xs <- many1 digit
m <- optionMaybe (try ((char '.' <|> char ',') *> many1 digit))
case m of
Just ys -> return (toExpr (read (xs ++ "." ++ ys) :: Double))
Nothing -> return (toExpr (read xs :: Int))
specialNumber :: MParser Expr
specialNumber = (1 :/: 2) <$ string "½"
<|> (3 :/: 4) <$ string "¾"
<|> (1 :/: 4) <$ string "¼"
complete' :: MParser a -> MParser a
complete' p = spaces *> (p <* eof)
parseSimple' :: MathParserOptions -> MParser a -> String -> Either String a
parseSimple' opts p =
left show . runParser (complete' p) opts "" .
(if convertToLowercase opts then strToLower else id)