{-# 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)
import GHC.Real (denominator, numerator)

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

toNNInt :: Term -> Maybe Integer
toNNInt (Measured Integer
sf (BigDecimal Integer
v Natural
s)) =
  if Natural
s forall a. Eq a => a -> a -> Bool
== Natural
0 Bool -> Bool -> Bool
&& Integer
v forall a. Ord a => a -> a -> Bool
>= Integer
0 then forall a. a -> Maybe a
Just Integer
v else forall a. Maybe a
Nothing
toNNInt (Constant Rational
a) =
  if forall a. Ratio a -> a
denominator Rational
a forall a. Eq a => a -> a -> Bool
== Integer
1 Bool -> Bool -> Bool
&& Rational
a forall a. Ord a => a -> a -> Bool
>= Rational
0 then forall a. a -> Maybe a
Just (forall a. Ratio a -> a
numerator Rational
a) else forall a. Maybe a
Nothing
exprNNInt :: Term -> Either a Integer
exprNNInt Term
e
  | Just Integer
n <- Term -> Maybe Integer
toNNInt Term
e = forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
n
  | Bool
otherwise = forall a b. a -> Either a b
Left a
"non-integer exponent"

-- | 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 -> forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
"evaluate' crashed because: " 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 (Literal Term
a) = forall a b. b -> Either a b
Right Term
a
evaluate (Prec1 [(Op, Expr)]
xs) = case [(Op, Expr)]
xs of
  [] -> forall a b. a -> Either a b
Left Text
"should not happen"
  [(Op
_, Literal Term
a)] -> forall a b. b -> Either a b
Right Term
a
  [(Op, Expr)]
xs -> do
    [(Op, Term)]
evaledSubs <- 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (Term -> Bool
isMeasured forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Op, Term)]
evaledSubs
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Op, Term)]
measured
      then forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Rational -> Term
Constant Rational
computed
      else
        let minDP :: Integer
minDP = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum 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 forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BigDecimal -> Term
forceDP Integer
minDP forall a b. (a -> b) -> a -> b
$ forall a. Fractional a => Rational -> a
fromRational Rational
computed
evaluate (Prec2 [(Op, Expr)]
xs) = case [(Op, Expr)]
xs of
  [] -> forall a b. a -> Either a b
Left Text
"should not happen"
  [(Op
_, Literal Term
a)] -> forall a b. b -> Either a b
Right Term
a
  [(Op, Expr)]
xs -> do
    [(Op, Term)]
evaledSubs <- 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (Term -> Bool
isMeasured forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Op, Term)]
evaledSubs
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Op, Term)]
measured
      then forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Rational -> Term
Constant Rational
computed
      else
        let min :: Integer
min = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Term -> Integer
numSigFigs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ [(Op, Term)]
measured
         in forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BigDecimal -> Term
forceSF Integer
min forall a b. (a -> b) -> a -> b
$ forall a. Fractional a => Rational -> a
fromRational Rational
computed
evaluate (Exp Expr
b Expr
e) = do
  Term
res <- Expr -> Either Text Term
evaluate Expr
b
  Integer
exp <- Expr -> Either Text Term
evaluate Expr
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a}. IsString a => Term -> Either a Integer
exprNNInt
  case Term
res of
    (Measured Integer
sf BigDecimal
bd) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Integer -> BigDecimal -> Term
forceSF Integer
sf (BigDecimal
bd forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
exp)
    (Constant Rational
a) -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Term
Constant forall a b. (a -> b) -> a -> b
$ Rational
a forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
exp
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 forall a. Ord a => a -> a -> Bool
<= BigDecimal
0
        then do
          forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"cannot evaluate log(" forall a. Semigroup a => a -> a -> a
<> Term -> Text
display Term
v forall a. Semigroup a => a -> a -> a
<> Text
"), argument is not positive"
        else
          forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BigDecimal -> Term
forceDP (forall a. Num a => a -> a
negate Integer
sf) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> BigDecimal
BD.fromString
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. PrintfType r => String -> r
printf String
"%f"
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Floating a => a -> a -> a
logBase (Float
10 :: Float)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac
            forall a b. (a -> b) -> a -> b
$ BigDecimal
bd
    (Constant Rational
a) -> 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 forall a. Ord a => a -> a -> Bool
>= Integer
0 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Term -> Text
display Term
arg forall a. Semigroup a => a -> a -> a
<> Text
" has 0 significant decimal places so exp(" forall a. Semigroup a => a -> a -> a
<> Term -> Text
display Term
arg forall a. Semigroup a => a -> a -> a
<> Text
") is undefined"
              | Natural
s forall a. Eq a => a -> a -> Bool
== Natural
0 -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BigDecimal -> Term
forceSF (forall a. Num a => a -> a
negate Integer
dp) forall a b. (a -> b) -> a -> b
$ Integer -> Natural -> BigDecimal
BigDecimal (Integer
10 forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
v) Natural
1
              | BigDecimal
bd forall a. Ord a => a -> a -> Bool
> BigDecimal
308 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"exp(" forall a. Semigroup a => a -> a -> a
<> Term -> Text
display Term
arg forall a. Semigroup a => a -> a -> a
<> Text
") is too big! sorry"
              | Bool
otherwise ->
                forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BigDecimal -> Term
forceSF (forall a. Num a => a -> a
negate Integer
dp) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> BigDecimal
BD.fromString
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. PrintfType r => String -> r
printf String
"%f"
                  forall a b. (a -> b) -> a -> b
$ (Double
10 :: Double) forall a. Floating a => a -> a -> a
** forall a b. (Real a, Fractional b) => a -> b
realToFrac BigDecimal
bd
    (Constant Rational
a) -> 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 =
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Either Text Rational -> (Op, Rational) -> Either Text Rational
comb (forall a b. b -> Either a b
Right Rational
identity) (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Term -> Rational
extractRat 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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) = 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 = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Rational
a forall a. Num a => a -> a -> a
+ Rational
b
doOp Op
Sub Rational
a Rational
b = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Rational
a forall a. Num a => a -> a -> a
- Rational
b
doOp Op
Mul Rational
a Rational
b = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Rational
a forall a. Num a => a -> a -> a
* Rational
b
doOp Op
Div Rational
a Rational
b = if Rational
b forall a. Eq a => a -> a -> Bool
== Rational
0 then forall a b. a -> Either a b
Left Text
"division by zero error" else forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Rational
a forall a. Fractional a => a -> a -> a
/ Rational
b

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