170 lines
6.6 KiB
Haskell
170 lines
6.6 KiB
Haskell
-- hc - haskell command line calculator using rational numbers
|
|
-- Copyright (C) 2024 VegOwOtenks
|
|
--
|
|
-- This program is free software: you can redistribute it and/or modify
|
|
-- it under the terms of the GNU Affero General Public License as published by
|
|
-- the Free Software Foundation, either version 3 of the License, or
|
|
-- (at your option) any later version.
|
|
--
|
|
-- This program is distributed in the hope that it will be useful,
|
|
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
-- GNU Affero General Public License for more details.
|
|
--
|
|
-- You should have received a copy of the GNU Affero General Public License
|
|
-- along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
--
|
|
-- contact me via vegowotenks at jossco dot de
|
|
module Lib
|
|
( exprparser, evaluate, replaceVars, Expr, extractVariableDefinitions, updateVariables, parseFullString
|
|
) 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 | VariableDefinition String 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
|
|
|
|
parseFullString s = parse (m_whiteSpace *> exprparser <* eof) "<stdin>" s
|
|
|
|
exprparser :: Parser Expr
|
|
exprparser = buildExpressionParser table term <?> "expression"
|
|
|
|
table = [
|
|
[
|
|
Infix (m_reservedOp "^" >> return (Binary Power)) AssocLeft,
|
|
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
|
|
_ <- m_whiteSpace
|
|
n <- m_integer
|
|
_ <- m_whiteSpace
|
|
notFollowedBy . char $ '.'
|
|
return (n % 1)
|
|
)
|
|
|
|
constantRational :: Parser Rational
|
|
constantRational = do
|
|
natural <- m_natural
|
|
_ <- char '.'
|
|
_ <- m_whiteSpace
|
|
decimal_digits <- many1 digit
|
|
_ <- m_whiteSpace
|
|
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
|
|
return (numerator % denominator)
|
|
|
|
variableDefinition :: Parser Expr
|
|
variableDefinition = try (do
|
|
name <- m_identifier
|
|
_ <- char '='
|
|
value <- exprparser
|
|
return (VariableDefinition name value)
|
|
)
|
|
|
|
term = m_parens exprparser
|
|
<|> variableDefinition
|
|
<|> fmap Variable m_identifier
|
|
<|> fmap Constant constantInteger
|
|
<|> fmap Constant constantRational
|
|
|
|
extractVariableDefinitions :: Expr -> [(String,Expr)]
|
|
extractVariableDefinitions (VariableDefinition name value) = [(name, value)]
|
|
extractVariableDefinitions (Binary _ a b) = extractVariableDefinitions a ++ extractVariableDefinitions b
|
|
extractVariableDefinitions (Constant _) = []
|
|
extractVariableDefinitions (Variable _) = []
|
|
|
|
updateVariables :: [(String, Expr)] -> Map String Rational -> Either String (Map String Rational)
|
|
updateVariables ds vs = foldl updateVariable (Right vs) ds
|
|
|
|
updateVariable :: Either String (Map String Rational) -> (String, Expr) -> Either String (Map String Rational)
|
|
updateVariable (Left e) _ = Left e
|
|
updateVariable (Right vs) (name, e) = case updateVariables nvs vs of
|
|
Left e -> Left $ "In definition of variable '" ++ name ++ "':\n" ++ e
|
|
Right uvs -> case replaceVars e uvs of
|
|
Left e -> Left $ "In definition of variable '" ++ name ++ "':\n" ++ e
|
|
Right exp -> Right $ Map.insert name (evaluate exp) uvs
|
|
where
|
|
nvs = extractVariableDefinitions e
|
|
|
|
replaceVars :: Expr -> Map.Map String Rational -> Either String Expr
|
|
replaceVars (Constant c) vs = Right $ Constant c
|
|
replaceVars (Variable name) vs = maybe (Left ("Usage of unknown variable: '" ++ name ++ "'\nSuggestion: define the variable\n++ " ++ name ++ "=42")) (Right . Constant . id) $ Map.lookup name vs
|
|
replaceVars (VariableDefinition name _) vs = replaceVars (Variable name) vs
|
|
replaceVars (Binary op l r) vs = case leftBranch of
|
|
Left s -> Left s
|
|
Right a -> case rightBranch of
|
|
Left s -> Left s
|
|
Right b -> Right $ Binary op a b
|
|
where
|
|
leftBranch = replaceVars l vs
|
|
rightBranch = replaceVars r vs
|
|
|
|
{-
|
|
- 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)
|
|
| c >= 0 = a ^ c % b ^ c
|
|
| otherwise = 1 / rationalPower (a % b) (-c % 1)
|
|
rationalPower' _ _ = error "Powers with unnatural numbers are not supported yet"
|
|
|
|
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)
|
|
evaluate (VariableDefinition _ _) = error "Unreachable Code"
|
|
evaluate (Variable _) = error "Unreachable Code"
|