97 lines
3 KiB
Haskell
97 lines
3 KiB
Haskell
module Lib
|
|
( exprparser, evaluate
|
|
) where
|
|
import Control.Applicative((<*))
|
|
|
|
import Data.Ratio
|
|
|
|
import Text.Parsec
|
|
import Text.Parsec.Char
|
|
import Text.Parsec.String
|
|
import Text.Parsec.Expr
|
|
import Text.Parsec.Token
|
|
import Text.Parsec.Language
|
|
|
|
data Expr = Variable String | Constant Rational | Binary BinaryOperator Expr Expr
|
|
deriving Show
|
|
data BinaryOperator = Plus | Minus | Multiply | Divide | Power
|
|
deriving Show
|
|
|
|
naturalRatio a = a % 1
|
|
|
|
def = emptyDef{ commentStart = ""
|
|
, commentEnd = ""
|
|
, identStart = letter <|> char '_'
|
|
, identLetter = alphaNum <|> char '_'
|
|
, opStart = oneOf "+-/*^"
|
|
, opLetter = oneOf "+-/*^"
|
|
, reservedOpNames = ["+", "-", "/", "*", "^"]
|
|
, reservedNames = ["pi", "e"]
|
|
}
|
|
|
|
TokenParser{ parens = m_parens
|
|
, identifier = m_identifier
|
|
, reservedOp = m_reservedOp
|
|
, reserved = m_reserved
|
|
, semiSep1 = m_semiSep1
|
|
, natural = m_natural
|
|
, integer = m_integer
|
|
, whiteSpace = m_whiteSpace } = makeTokenParser def
|
|
|
|
exprparser :: Parser Expr
|
|
exprparser = buildExpressionParser table term <?> "expression"
|
|
|
|
table = [
|
|
[
|
|
Infix (m_reservedOp "^" >> return (Binary Power)) AssocLeft
|
|
],
|
|
[
|
|
Infix (m_reservedOp "*" >> return (Binary Multiply)) AssocLeft,
|
|
Infix (m_reservedOp "/" >> return (Binary Divide)) AssocLeft
|
|
],
|
|
[
|
|
Infix (m_reservedOp "+" >> return (Binary Plus)) AssocLeft,
|
|
Infix (m_reservedOp "-" >> return (Binary Minus)) AssocLeft
|
|
]
|
|
]
|
|
|
|
constantInteger :: Parser Rational
|
|
constantInteger = try (do
|
|
n <- m_integer
|
|
notFollowedBy . char $ '.'
|
|
return (n % 1)
|
|
)
|
|
|
|
constantRational :: Parser Rational
|
|
constantRational = do
|
|
natural <- m_natural
|
|
_ <- char '.'
|
|
decimal <- m_natural
|
|
let natural_length = length . show $ natural
|
|
let decimal_length = length . show $ decimal
|
|
let numerator = natural * (10 ^ decimal_length) + decimal
|
|
let denominator = 10 ^ (decimal_length + natural_length - 2)
|
|
return (numerator % denominator)
|
|
|
|
{-
|
|
- a/b ^ c/d
|
|
- (a ^ c/d) / b ^ (c/d)
|
|
- root(a ^ c, d) / root(b ^ c, d)
|
|
-}
|
|
rationalPower :: Rational -> Rational -> Rational
|
|
rationalPower a b = rationalPower' (numerator a, denominator a) (numerator b, denominator b)
|
|
where
|
|
rationalPower' (a, b) (c, 1) = a ^ c % b ^ c
|
|
|
|
term = m_parens exprparser
|
|
<|> fmap Variable m_identifier
|
|
<|> fmap Constant constantInteger
|
|
<|> fmap Constant constantRational
|
|
|
|
evaluate :: Expr -> Rational
|
|
evaluate (Constant c) = c
|
|
evaluate (Binary Plus a b) = evaluate a + evaluate b
|
|
evaluate (Binary Minus a b) = evaluate a - evaluate b
|
|
evaluate (Binary Divide a b) = evaluate a / evaluate b
|
|
evaluate (Binary Multiply a b) = evaluate a * evaluate b
|
|
evaluate (Binary Power a b) = rationalPower (evaluate a) (evaluate b)
|