106 lines
3.5 KiB
Haskell
106 lines
3.5 KiB
Haskell
module Lib
|
|
( exprparser, evaluate, replaceVars
|
|
) where
|
|
import Control.Applicative((<*))
|
|
|
|
import Data.Ratio
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map
|
|
|
|
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 = []
|
|
}
|
|
|
|
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_digits <- many digit
|
|
let decimal = read decimal_digits :: Integer
|
|
let natural_length = length . show $ natural
|
|
let decimal_length = length decimal_digits
|
|
let numerator = natural * (10 ^ decimal_length) + decimal
|
|
let denominator = 10 ^ (decimal_length + natural_length - 1)
|
|
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
|
|
rationalPower' _ _ = error "Powers with unnatural numbers are not supported yet"
|
|
|
|
term = m_parens exprparser
|
|
<|> fmap Variable m_identifier
|
|
<|> fmap Constant constantInteger
|
|
<|> fmap Constant constantRational
|
|
|
|
replaceVars :: Expr -> Map.Map String Rational -> Expr
|
|
replaceVars (Variable name) vs = Constant . maybe (0 % 1) id $ Map.lookup name vs
|
|
replaceVars (Binary op a b) vs = Binary op (replaceVars a vs) (replaceVars b vs)
|
|
replaceVars (Constant c) vs = Constant c
|
|
|
|
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)
|