{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK prune #-}

-- |
-- This module contains effectively one function of interest, which is 'evaluate'.
-- It takes an 'Expr' and evaluates it, applying the correct significant
-- figure rules. To display the resulting 'Term' that 'evaluate' may return, see 'display'.
module Data.SigFig.Evaluate
  ( evaluate,
    evaluate',
  )
where

import Data.BigDecimal (BigDecimal (..))
import Data.BigDecimal qualified as BD
import Data.Foldable (foldl')
import Data.SigFig.Types
import Data.SigFig.Util
import Data.Text (Text)
import Data.Text qualified as T
import Control.Arrow (second)
import Text.Printf (printf)

isMeasured :: Term -> Bool
isMeasured (Measured Integer
_ BigDecimal
_) = Bool
True
isMeasured (Constant Rational
_) = Bool
False

-- | Like 'evaluate', but assume the result is a valid term and crash otherwise.
evaluate' :: Expr -> Term
evaluate' :: Expr -> Term
evaluate' Expr
s = case Expr -> Either Text Term
evaluate Expr
s of
  Left Text
e -> [Char] -> Term
forall a. HasCallStack => [Char] -> a
error ([Char] -> Term) -> (Text -> [Char]) -> Text -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> Term) -> Text -> Term
forall a b. (a -> b) -> a -> b
$ Text
"evaluate' crashed because: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e
  Right Term
e -> Term
e

-- | Given an expression tree, evaluate it and return either an error or result.
evaluate :: Expr -> Either Text Term
evaluate :: Expr -> Either Text Term
evaluate (Leaf Term
a) = Term -> Either Text Term
forall a b. b -> Either a b
Right Term
a
evaluate (Prec1 [(Op, Expr)]
xs) = case [(Op, Expr)]
xs of
  [] -> Text -> Either Text Term
forall a b. a -> Either a b
Left Text
"should not happen"
  [(Op
_, Leaf Term
a)] -> Term -> Either Text Term
forall a b. b -> Either a b
Right Term
a
  [(Op, Expr)]
xs -> do
    [(Op, Term)]
evaledSubs <- [(Op, Expr)] -> Either Text [(Op, Term)]
forall a. [(a, Expr)] -> Either Text [(a, Term)]
evaluateSubtrees [(Op, Expr)]
xs
    Rational
computed <- [(Op, Term)] -> Rational -> Either Text Rational
computeUnconstrained [(Op, Term)]
evaledSubs Rational
0
    let measured :: [(Op, Term)]
measured = ((Op, Term) -> Bool) -> [(Op, Term)] -> [(Op, Term)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Term -> Bool
isMeasured (Term -> Bool) -> ((Op, Term) -> Term) -> (Op, Term) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Op, Term) -> Term
forall a b. (a, b) -> b
snd) [(Op, Term)]
evaledSubs
    if [(Op, Term)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Op, Term)]
measured
      then Term -> Either Text Term
forall a b. b -> Either a b
Right (Term -> Either Text Term) -> Term -> Either Text Term
forall a b. (a -> b) -> a -> b
$ Rational -> Term
Constant Rational
computed
      else
        let minDP :: Integer
minDP = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ [Integer -> BigDecimal -> Integer
rightmostSignificantPlace Integer
sf BigDecimal
bd | (Op
_, Measured Integer
sf BigDecimal
bd) <- [(Op, Term)]
measured]
         in Term -> Either Text Term
forall a b. b -> Either a b
Right (Term -> Either Text Term)
-> (BigDecimal -> Term) -> BigDecimal -> Either Text Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BigDecimal -> Term
forceDP Integer
minDP (BigDecimal -> Either Text Term) -> BigDecimal -> Either Text Term
forall a b. (a -> b) -> a -> b
$ Rational -> BigDecimal
forall a. Fractional a => Rational -> a
fromRational Rational
computed
evaluate (Prec2 [(Op, Expr)]
xs) = case [(Op, Expr)]
xs of
  [] -> Text -> Either Text Term
forall a b. a -> Either a b
Left Text
"should not happen"
  [(Op
_, Leaf Term
a)] -> Term -> Either Text Term
forall a b. b -> Either a b
Right Term
a
  [(Op, Expr)]
xs -> do
    [(Op, Term)]
evaledSubs <- [(Op, Expr)] -> Either Text [(Op, Term)]
forall a. [(a, Expr)] -> Either Text [(a, Term)]
evaluateSubtrees [(Op, Expr)]
xs
    Rational
computed <- [(Op, Term)] -> Rational -> Either Text Rational
computeUnconstrained [(Op, Term)]
evaledSubs Rational
1
    let measured :: [(Op, Term)]
measured = ((Op, Term) -> Bool) -> [(Op, Term)] -> [(Op, Term)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Term -> Bool
isMeasured (Term -> Bool) -> ((Op, Term) -> Term) -> (Op, Term) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Op, Term) -> Term
forall a b. (a, b) -> b
snd) [(Op, Term)]
evaledSubs
    if [(Op, Term)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Op, Term)]
measured
      then Term -> Either Text Term
forall a b. b -> Either a b
Right (Term -> Either Text Term) -> Term -> Either Text Term
forall a b. (a -> b) -> a -> b
$ Rational -> Term
Constant Rational
computed
      else
        let min :: Integer
min = [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Integer] -> Integer)
-> ([(Op, Term)] -> [Integer]) -> [(Op, Term)] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Op, Term) -> Integer) -> [(Op, Term)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Term -> Integer
numSigFigs (Term -> Integer) -> ((Op, Term) -> Term) -> (Op, Term) -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Op, Term) -> Term
forall a b. (a, b) -> b
snd) ([(Op, Term)] -> Integer) -> [(Op, Term)] -> Integer
forall a b. (a -> b) -> a -> b
$ [(Op, Term)]
measured
         in Term -> Either Text Term
forall a b. b -> Either a b
Right (Term -> Either Text Term)
-> (BigDecimal -> Term) -> BigDecimal -> Either Text Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BigDecimal -> Term
forceSF Integer
min (BigDecimal -> Either Text Term) -> BigDecimal -> Either Text Term
forall a b. (a -> b) -> a -> b
$ Rational -> BigDecimal
forall a. Fractional a => Rational -> a
fromRational Rational
computed
evaluate (Exp Expr
b Integer
e) = do
  Term
res <- Expr -> Either Text Term
evaluate Expr
b
  case Term
res of
    (Measured Integer
sf BigDecimal
bd) -> Term -> Either Text Term
forall a b. b -> Either a b
Right (Term -> Either Text Term) -> Term -> Either Text Term
forall a b. (a -> b) -> a -> b
$ Integer -> BigDecimal -> Term
forceSF Integer
sf (BigDecimal
bd BigDecimal -> Integer -> BigDecimal
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
e)
    (Constant Rational
a) -> Term -> Either Text Term
forall a b. b -> Either a b
Right (Term -> Either Text Term)
-> (Rational -> Term) -> Rational -> Either Text Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Term
Constant (Rational -> Either Text Term) -> Rational -> Either Text Term
forall a b. (a -> b) -> a -> b
$ Rational
a Rational -> Integer -> Rational
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
e
evaluate (Apply Function
Log10 Expr
e) = do
  Term
res <- Expr -> Either Text Term
evaluate Expr
e
  case Term
res of
    v :: Term
v@(Measured Integer
sf BigDecimal
bd) ->
      if BigDecimal
bd BigDecimal -> BigDecimal -> Bool
forall a. Ord a => a -> a -> Bool
<= BigDecimal
0
        then do
          Text -> Either Text Term
forall a b. a -> Either a b
Left (Text -> Either Text Term) -> Text -> Either Text Term
forall a b. (a -> b) -> a -> b
$ Text
"cannot evaluate log(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Term -> Text
display Term
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"), argument is not positive"
        else
          Term -> Either Text Term
forall a b. b -> Either a b
Right (Term -> Either Text Term)
-> (BigDecimal -> Term) -> BigDecimal -> Either Text Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BigDecimal -> Term
forceDP (Integer -> Integer
forall a. Num a => a -> a
negate Integer
sf) (BigDecimal -> Term)
-> (BigDecimal -> BigDecimal) -> BigDecimal -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> BigDecimal
BD.fromString
            ([Char] -> BigDecimal)
-> (BigDecimal -> [Char]) -> BigDecimal -> BigDecimal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Float -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%f"
            (Float -> [Char]) -> (BigDecimal -> Float) -> BigDecimal -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float -> Float
forall a. Floating a => a -> a -> a
logBase (Float
10 :: Float)
            (Float -> Float) -> (BigDecimal -> Float) -> BigDecimal -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BigDecimal -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac
            (BigDecimal -> Either Text Term) -> BigDecimal -> Either Text Term
forall a b. (a -> b) -> a -> b
$ BigDecimal
bd
    (Constant Rational
a) -> Text -> Either Text Term
forall a b. a -> Either a b
Left Text
"taking the log of a constant is unsupported"
evaluate (Apply Function
Antilog10 Expr
e) = do
  Term
res <- Expr -> Either Text Term
evaluate Expr
e
  case Term
res of
    arg :: Term
arg@(Measured Integer
sf BigDecimal
bd') ->
      let bd :: BigDecimal
bd@(BigDecimal Integer
v Natural
s) = BigDecimal -> BigDecimal
BD.nf BigDecimal
bd'
          dp :: Integer
dp = Integer -> BigDecimal -> Integer
rightmostSignificantPlace Integer
sf BigDecimal
bd
       in if
              | Integer
dp Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 -> Text -> Either Text Term
forall a b. a -> Either a b
Left (Text -> Either Text Term) -> Text -> Either Text Term
forall a b. (a -> b) -> a -> b
$ Term -> Text
display Term
arg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has 0 significant decimal places so exp(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Term -> Text
display Term
arg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") is undefined"
              | Natural
s Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
0 -> Term -> Either Text Term
forall a b. b -> Either a b
Right (Term -> Either Text Term)
-> (BigDecimal -> Term) -> BigDecimal -> Either Text Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BigDecimal -> Term
forceSF (Integer -> Integer
forall a. Num a => a -> a
negate Integer
dp) (BigDecimal -> Either Text Term) -> BigDecimal -> Either Text Term
forall a b. (a -> b) -> a -> b
$ Integer -> Natural -> BigDecimal
BigDecimal (Integer
10 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
v) Natural
1
              | BigDecimal
bd BigDecimal -> BigDecimal -> Bool
forall a. Ord a => a -> a -> Bool
> BigDecimal
308 -> Text -> Either Text Term
forall a b. a -> Either a b
Left (Text -> Either Text Term) -> Text -> Either Text Term
forall a b. (a -> b) -> a -> b
$ Text
"exp(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Term -> Text
display Term
arg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") is too big! sorry"
              | Bool
otherwise ->
                Term -> Either Text Term
forall a b. b -> Either a b
Right (Term -> Either Text Term)
-> (Double -> Term) -> Double -> Either Text Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BigDecimal -> Term
forceSF (Integer -> Integer
forall a. Num a => a -> a
negate Integer
dp) (BigDecimal -> Term) -> (Double -> BigDecimal) -> Double -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> BigDecimal
BD.fromString
                  ([Char] -> BigDecimal)
-> (Double -> [Char]) -> Double -> BigDecimal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Double -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%f"
                  (Double -> Either Text Term) -> Double -> Either Text Term
forall a b. (a -> b) -> a -> b
$ (Double
10 :: Double) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** BigDecimal -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac BigDecimal
bd
    (Constant Rational
a) -> Text -> Either Text Term
forall a b. a -> Either a b
Left Text
"taking the antilog of a constant is unsupported"

computeUnconstrained :: [(Op, Term)] -> Rational -> Either Text Rational
computeUnconstrained :: [(Op, Term)] -> Rational -> Either Text Rational
computeUnconstrained [(Op, Term)]
terms Rational
identity =
  (Either Text Rational -> (Op, Rational) -> Either Text Rational)
-> Either Text Rational -> [(Op, Rational)] -> Either Text Rational
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Either Text Rational -> (Op, Rational) -> Either Text Rational
comb (Rational -> Either Text Rational
forall a b. b -> Either a b
Right Rational
identity) ((Term -> Rational) -> (Op, Term) -> (Op, Rational)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Term -> Rational
extractRat ((Op, Term) -> (Op, Rational)) -> [(Op, Term)] -> [(Op, Rational)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Op, Term)]
terms)
  where
    comb :: Either Text Rational -> (Op, Rational) -> Either Text Rational
comb Either Text Rational
e (Op
o, Rational
a) = Either Text Rational
e Either Text Rational
-> (Rational -> Either Text Rational) -> Either Text Rational
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Rational -> Rational -> Either Text Rational)
-> Rational -> Rational -> Either Text Rational
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Op -> Rational -> Rational -> Either Text Rational
doOp Op
o) Rational
a
    extractRat :: Term -> Rational
extractRat (Measured Integer
_ BigDecimal
v) = BigDecimal -> Rational
forall a. Real a => a -> Rational
toRational BigDecimal
v
    extractRat (Constant Rational
v) = Rational
v

doOp :: Op -> Rational -> Rational -> Either Text Rational
doOp :: Op -> Rational -> Rational -> Either Text Rational
doOp Op
Add Rational
a Rational
b = Rational -> Either Text Rational
forall a b. b -> Either a b
Right (Rational -> Either Text Rational)
-> Rational -> Either Text Rational
forall a b. (a -> b) -> a -> b
$ Rational
a Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
b
doOp Op
Sub Rational
a Rational
b = Rational -> Either Text Rational
forall a b. b -> Either a b
Right (Rational -> Either Text Rational)
-> Rational -> Either Text Rational
forall a b. (a -> b) -> a -> b
$ Rational
a Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
b
doOp Op
Mul Rational
a Rational
b = Rational -> Either Text Rational
forall a b. b -> Either a b
Right (Rational -> Either Text Rational)
-> Rational -> Either Text Rational
forall a b. (a -> b) -> a -> b
$ Rational
a Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
b
doOp Op
Div Rational
a Rational
b = if Rational
b Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0 then Text -> Either Text Rational
forall a b. a -> Either a b
Left Text
"division by zero error" else Rational -> Either Text Rational
forall a b. b -> Either a b
Right (Rational -> Either Text Rational)
-> Rational -> Either Text Rational
forall a b. (a -> b) -> a -> b
$ Rational
a Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
b

evaluateSubtrees :: [(a, Expr)] -> Either Text [(a, Term)]
evaluateSubtrees :: [(a, Expr)] -> Either Text [(a, Term)]
evaluateSubtrees [(a, Expr)]
xs = ((a, Either Text Term) -> Either Text (a, Term))
-> [(a, Either Text Term)] -> Either Text [(a, Term)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (a, Either Text Term) -> Either Text (a, Term)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ([(a, Either Text Term)] -> Either Text [(a, Term)])
-> [(a, Either Text Term)] -> Either Text [(a, Term)]
forall a b. (a -> b) -> a -> b
$ (Expr -> Either Text Term) -> (a, Expr) -> (a, Either Text Term)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Expr -> Either Text Term
evaluate ((a, Expr) -> (a, Either Text Term))
-> [(a, Expr)] -> [(a, Either Text Term)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, Expr)]
xs