{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK prune #-}
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"
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
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