{-# Language ScopedTypeVariables #-}
module Numeric.MathExpr
    ( evaluate
    , Settings (..)
    , defaultFunctions
    , defaultOperators
    ) where
      import Data.Default.Class
      import Data.Maybe (isJust, fromJust)
      import Data.List (find)

      -- | Operators are in the form (character, precedence, function)
      -- Example: ('+', 0, (+)), ('', 1, ())
      -- (higher the precedence, the sooner the operator operates)
      --
      -- Functions are in the form (name, function)
      -- Example: ("ln", log)
      data Settings = Settings { Settings -> [(Char, Int, Double -> Double -> Double)]
operators :: [(Char, Int, Double -> Double -> Double)]
                               , Settings -> [(String, Double -> Double)]
functions :: [(String, Double -> Double)]
                               }
      -- | Operators are in the form (character, precedence, function)
      -- Example: ('+', 0, (+)), ('', 1, ())
      -- (higher the precedence, the sooner the operator operates)
      defaultOperators :: [(Char, Int, Double -> Double -> Double)]
defaultOperators = [
          (Char
'+', Int
0, Double -> Double -> Double
forall a. Num a => a -> a -> a
(+)), (Char
'-', Int
0, (-)),
          (Char
'*', Int
1, Double -> Double -> Double
forall a. Num a => a -> a -> a
(*)), (Char
'/', Int
1, Double -> Double -> Double
forall a. Fractional a => a -> a -> a
(/)),
          (Char
'^', Int
2, Double -> Double -> Double
forall a. Floating a => a -> a -> a
(**))
        ]

      -- | Functions are in the form (name, function)
      -- Example: ("ln", log)
      defaultFunctions :: [(String, Double -> Double)]
defaultFunctions = [(String
"ln", Double -> Double
forall a. Floating a => a -> a
log), (String
"sin", Double -> Double
forall a. Floating a => a -> a
sin), (String
"cos", Double -> Double
forall a. Floating a => a -> a
cos)]

      instance Default Settings where
        def :: Settings
def = Settings :: [(Char, Int, Double -> Double -> Double)]
-> [(String, Double -> Double)] -> Settings
Settings { operators :: [(Char, Int, Double -> Double -> Double)]
operators = [(Char, Int, Double -> Double -> Double)]
defaultOperators
                       , functions :: [(String, Double -> Double)]
functions = [(String, Double -> Double)]
defaultFunctions
                       }
      toPostfix :: Settings -> String -> String
      toPostfix :: Settings -> String -> String
toPostfix Settings
settings String
s = [String] -> [String] -> String -> String
helper (String -> [String]
tokenize String
s) [] []
        where
          ops :: [(Char, Int, Double -> Double -> Double)]
ops = Settings -> [(Char, Int, Double -> Double -> Double)]
operators Settings
settings
          fns :: [(String, Double -> Double)]
fns = Settings -> [(String, Double -> Double)]
functions Settings
settings

          helper :: [String] -> [String] -> String -> String
          helper :: [String] -> [String] -> String -> String
helper [] [String]
os String
out = String
out String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
os
          helper (String
c:[String]
cs) [String]
os String
out
            | String -> Char
forall a. [a] -> a
head String
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' = [String] -> [String] -> String -> String
helper [String]
cs (String
cString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
os) String
out
            | String -> Char
forall a. [a] -> a
head String
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' Bool -> Bool -> Bool
&& [String] -> String
forall a. [a] -> a
head [String]
os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"(" = [String] -> [String] -> String -> String
helper [String]
cs ([String] -> [String]
forall a. [a] -> [a]
tail [String]
os) String
out
            | String -> Char
forall a. [a] -> a
head String
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' = [String] -> [String] -> String -> String
helper (String
cString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
cs) ([String] -> [String]
forall a. [a] -> [a]
tail [String]
os) (String
out String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
pad ([String] -> String
forall a. [a] -> a
head [String]
os))
            | String -> Bool
isOperator String
c Bool -> Bool -> Bool
&& ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
os Bool -> Bool -> Bool
|| String -> Maybe Int
precedence String
c Maybe Int -> Maybe Int -> Bool
forall a. Ord a => a -> a -> Bool
> String -> Maybe Int
precedence ([String] -> String
forall a. [a] -> a
head [String]
os)) = [String] -> [String] -> String -> String
helper [String]
cs (String
cString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
os) String
out
            | String -> Bool
isOperator String
c = [String] -> [String] -> String -> String
helper (String
cString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
cs) ([String] -> [String]
forall a. [a] -> [a]
tail [String]
os) (String
out String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
pad ([String] -> String
forall a. [a] -> a
head [String]
os))
            | Bool
otherwise = [String] -> [String] -> String -> String
helper [String]
cs [String]
os (String
out String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
pad String
c)

          isOperator :: String -> Bool
isOperator String
cs = String -> Bool
isOp String
cs Bool -> Bool -> Bool
|| String -> Bool
isFunction String
cs
          isOp :: String -> Bool
isOp String
cs = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ (String -> Char
forall a. [a] -> a
head String
cs) Char -> [(Char, Int, Double -> Double -> Double)] -> Maybe Int
forall a b c. Eq a => a -> [(a, b, c)] -> Maybe b
`triLookup` [(Char, Int, Double -> Double -> Double)]
ops
          isFunction :: String -> Bool
isFunction String
cs = Maybe (Double -> Double) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Double -> Double) -> Bool)
-> Maybe (Double -> Double) -> Bool
forall a b. (a -> b) -> a -> b
$ String
cs String -> [(String, Double -> Double)] -> Maybe (Double -> Double)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, Double -> Double)]
fns
          precedence :: String -> Maybe Int
precedence String
cs
            | String -> Bool
isFunction String
cs = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
999
            | Bool
otherwise = (String -> Char
forall a. [a] -> a
head String
cs) Char -> [(Char, Int, Double -> Double -> Double)] -> Maybe Int
forall a b c. Eq a => a -> [(a, b, c)] -> Maybe b
`triLookup` [(Char, Int, Double -> Double -> Double)]
ops

      tokenize :: String -> [String]
      tokenize :: String -> [String]
tokenize String
str = String -> [String]
words (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String
helper String
str
        where
          helper :: String -> String
          helper :: String -> String
helper [] = []
          helper (Char
c:String
cs)
            | Char -> Bool
isAlphanumeric Char
c = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
helper String
cs
            | Char -> Bool
isSymbol Char
c = String -> String
pad [Char
c] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
helper String
cs

      replaceVariables :: String -> [(String, Double)] -> String
      replaceVariables :: String -> [(String, Double)] -> String
replaceVariables String
str [] = String
str
      replaceVariables String
str [(String, Double)]
vars = (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
replace (String -> [String]
tokenize String
str)
        where
          replace :: String -> String
replace String
c
            | String -> Bool
isVariable String
c = String -> String
pad (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Double -> String
forall a. Show a => a -> String
show (Double -> String) -> Double -> String
forall a b. (a -> b) -> a -> b
$ Maybe Double -> Double
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Double -> Double) -> Maybe Double -> Double
forall a b. (a -> b) -> a -> b
$ String
c String -> [(String, Double)] -> Maybe Double
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, Double)]
vars
            | Bool
otherwise = String -> String
pad String
c

          isVariable :: String -> Bool
isVariable String
c = Maybe Double -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Double -> Bool) -> Maybe Double -> Bool
forall a b. (a -> b) -> a -> b
$ String
c String -> [(String, Double)] -> Maybe Double
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, Double)]
vars

      -- | Evaluate an expression
      -- Example: `evaluate def "x + y ^ 2" [("x", 1), ("y", 2)]
      evaluate :: Settings -> String -> [(String, Double)] -> Double
      evaluate :: Settings -> String -> [(String, Double)] -> Double
evaluate Settings
settings String
expr [(String, Double)]
vars =
        let postfix :: String
postfix = Settings -> String -> String
toPostfix Settings
settings String
expr
            replaced :: String
replaced = String -> [(String, Double)] -> String
replaceVariables String
postfix [(String, Double)]
vars
        in [String] -> [String] -> Double
helper (String -> [String]
tokenize String
replaced) []
        where
          ops :: [(Char, Int, Double -> Double -> Double)]
ops = Settings -> [(Char, Int, Double -> Double -> Double)]
operators Settings
settings
          fns :: [(String, Double -> Double)]
fns = Settings -> [(String, Double -> Double)]
functions Settings
settings

          helper :: [String] -> [String] -> Double
          -- negative numbers come in the form ["num", "-"]
          helper :: [String] -> [String] -> Double
helper [] [String
o] = String -> Double
forall a. Read a => String -> a
read String
o
          helper [String
n, String
"-"] [] = Double -> Double
forall a. Num a => a -> a
negate (Double -> Double) -> (String -> Double) -> String -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Double
forall a. Read a => String -> a
read (String -> Double) -> String -> Double
forall a b. (a -> b) -> a -> b
$ String
n
          helper [String
"-"] [String
n] = Double -> Double
forall a. Num a => a -> a
negate (Double -> Double) -> (String -> Double) -> String -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Double
forall a. Read a => String -> a
read (String -> Double) -> String -> Double
forall a b. (a -> b) -> a -> b
$ String
n
          helper (String
c:[String]
cs) [String]
os
            | String
c String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-" Bool -> Bool -> Bool
&& [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
os Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 =
                let Double
result :: Double = Double -> Double
forall a. Num a => a -> a
negate (Double -> Double) -> ([String] -> Double) -> [String] -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Double
forall a. Read a => String -> a
read (String -> Double) -> ([String] -> String) -> [String] -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. [a] -> a
head ([String] -> Double) -> [String] -> Double
forall a b. (a -> b) -> a -> b
$ [String]
cs
                in [String] -> [String] -> Double
helper ([String] -> [String]
forall a. [a] -> [a]
tail [String]
cs) ([String] -> Double) -> [String] -> Double
forall a b. (a -> b) -> a -> b
$ (Double -> String
forall a. Show a => a -> String
show Double
result) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
os
            | String -> Bool
isOperator String
c Bool -> Bool -> Bool
&& [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
os Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 =
                let result :: Double
result = (String -> Double -> Double -> Double
operatorFunction String
c) (String -> Double
forall a. Read a => String -> a
read (String -> Double) -> ([String] -> String) -> [String] -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. [a] -> a
head ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
tail ([String] -> Double) -> [String] -> Double
forall a b. (a -> b) -> a -> b
$ [String]
os) (String -> Double
forall a. Read a => String -> a
read (String -> Double) -> ([String] -> String) -> [String] -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. [a] -> a
head ([String] -> Double) -> [String] -> Double
forall a b. (a -> b) -> a -> b
$ [String]
os) 
                in [String] -> [String] -> Double
helper [String]
cs ([String] -> Double) -> [String] -> Double
forall a b. (a -> b) -> a -> b
$ (Double -> String
forall a. Show a => a -> String
show Double
result) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
2 [String]
os
            | String -> Bool
isFunction String
c =
                let result :: Double
result = (String -> Double -> Double
function String
c) (String -> Double
forall a. Read a => String -> a
read (String -> Double) -> ([String] -> String) -> [String] -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. [a] -> a
head ([String] -> Double) -> [String] -> Double
forall a b. (a -> b) -> a -> b
$ [String]
os)
                in [String] -> [String] -> Double
helper [String]
cs ([String] -> Double) -> [String] -> Double
forall a b. (a -> b) -> a -> b
$ (Double -> String
forall a. Show a => a -> String
show Double
result) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
forall a. [a] -> [a]
tail [String]
os
            | Bool
otherwise = [String] -> [String] -> Double
helper [String]
cs (String
cString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
os)

          isOperator :: String -> Bool
isOperator String
cs = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ (String -> Char
forall a. [a] -> a
head String
cs) Char -> [(Char, Int, Double -> Double -> Double)] -> Maybe Int
forall a b c. Eq a => a -> [(a, b, c)] -> Maybe b
`triLookup` [(Char, Int, Double -> Double -> Double)]
ops
          isFunction :: String -> Bool
isFunction String
cs = Maybe (Double -> Double) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Double -> Double) -> Bool)
-> Maybe (Double -> Double) -> Bool
forall a b. (a -> b) -> a -> b
$ String
cs String -> [(String, Double -> Double)] -> Maybe (Double -> Double)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, Double -> Double)]
fns

          function :: String -> Double -> Double
function String
cs = Maybe (Double -> Double) -> Double -> Double
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Double -> Double) -> Double -> Double)
-> Maybe (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ String
cs String -> [(String, Double -> Double)] -> Maybe (Double -> Double)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, Double -> Double)]
fns
          operatorFunction :: String -> Double -> Double -> Double
operatorFunction String
cs = case ((Char, Int, Double -> Double -> Double) -> Bool)
-> [(Char, Int, Double -> Double -> Double)]
-> Maybe (Char, Int, Double -> Double -> Double)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Char
a, Int
_, Double -> Double -> Double
_) -> Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Char
forall a. [a] -> a
head String
cs) [(Char, Int, Double -> Double -> Double)]
ops of
                                  Just (Char
_, Int
_, Double -> Double -> Double
c) -> Double -> Double -> Double
c
                                  Maybe (Char, Int, Double -> Double -> Double)
Nothing -> (Double -> Double) -> Double -> Double -> Double
forall a b. a -> b -> a
const (Double -> Double -> Double
forall a b. a -> b -> a
const Double
0)
          isParen :: String -> Bool
isParen String
cs = String -> Char
forall a. [a] -> a
head String
cs Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'(', Char
')']

      alphanumeric :: String
alphanumeric = Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: [Char
'a'..Char
'z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9']
      isAlphanumeric :: Char -> Bool
isAlphanumeric = (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
alphanumeric)
      isSymbol :: Char -> Bool
isSymbol = Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
alphanumeric)  

      triLookup :: (Eq a) => a -> [(a, b, c)] -> Maybe b
      triLookup :: a -> [(a, b, c)] -> Maybe b
triLookup a
a [(a, b, c)]
x = a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
a ([(a, b)] -> Maybe b) -> [(a, b)] -> Maybe b
forall a b. (a -> b) -> a -> b
$ ((a, b, c) -> (a, b)) -> [(a, b, c)] -> [(a, b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
a, b
b, c
_) -> (a
a, b
b)) [(a, b, c)]
x

      pad :: String -> String
      pad :: String -> String
pad String
x = Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
' ']