{-# LANGUAGE NoImplicitPrelude #-}
module Numeric.Floating.IEEE.Internal.GenericArith where
import           Data.Proxy
import           MyPrelude
import           Numeric.Floating.IEEE.Internal.Classify
import           Numeric.Floating.IEEE.Internal.Conversion
import           Numeric.Floating.IEEE.Internal.FMA

default ()

-- $setup
-- >>> :m + Data.Proxy
-- >>> import Numeric.Floating.IEEE.Internal.GenericArith

infixl 6 `genericAdd`, `genericSub`
infixl 7 `genericMul`, `genericDiv`

-- |
-- IEEE 754 @addition@ operation.
genericAdd :: (RealFloat a, RealFloat b) => a -> a -> b
genericAdd :: forall a b. (RealFloat a, RealFloat b) => a -> a -> b
genericAdd a
x a
y | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 Bool -> Bool -> Bool
&& a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = a -> b
forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
y)
               | a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
x Bool -> Bool -> Bool
&& a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
y = Rational -> b
forall a. Fractional a => Rational -> a
fromRational (a -> Rational
forall a. Real a => a -> Rational
toRational a
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ a -> Rational
forall a. Real a => a -> Rational
toRational a
y)
               | Bool
otherwise = a -> b
forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
y)
{-# NOINLINE [1] genericAdd #-}

-- |
-- IEEE 754 @subtraction@ operation.
genericSub :: (RealFloat a, RealFloat b) => a -> a -> b
genericSub :: forall a b. (RealFloat a, RealFloat b) => a -> a -> b
genericSub a
x a
y | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 Bool -> Bool -> Bool
&& a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = a -> b
forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
y)
               | a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
x Bool -> Bool -> Bool
&& a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
y = Rational -> b
forall a. Fractional a => Rational -> a
fromRational (a -> Rational
forall a. Real a => a -> Rational
toRational a
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- a -> Rational
forall a. Real a => a -> Rational
toRational a
y)
               | Bool
otherwise = a -> b
forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
y)
{-# NOINLINE [1] genericSub #-}

-- |
-- IEEE 754 @multiplication@ operation.
genericMul :: (RealFloat a, RealFloat b) => a -> a -> b
genericMul :: forall a b. (RealFloat a, RealFloat b) => a -> a -> b
genericMul a
x a
y | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 Bool -> Bool -> Bool
|| a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = a -> b
forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
y)
               | a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
x Bool -> Bool -> Bool
&& a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
y = Rational -> b
forall a. Fractional a => Rational -> a
fromRational (a -> Rational
forall a. Real a => a -> Rational
toRational a
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* a -> Rational
forall a. Real a => a -> Rational
toRational a
y)
               | Bool
otherwise = a -> b
forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
y)
{-# NOINLINE [1] genericMul #-}

-- |
-- IEEE 754 @division@ operation.
genericDiv :: (RealFloat a, RealFloat b) => a -> a -> b
genericDiv :: forall a b. (RealFloat a, RealFloat b) => a -> a -> b
genericDiv a
x a
y | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 Bool -> Bool -> Bool
|| a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = a -> b
forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
y)
               | a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
x Bool -> Bool -> Bool
&& a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
y = Rational -> b
forall a. Fractional a => Rational -> a
fromRational (a -> Rational
forall a. Real a => a -> Rational
toRational a
x Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ a -> Rational
forall a. Real a => a -> Rational
toRational a
y)
               | Bool
otherwise = a -> b
forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
y)
{-# NOINLINE [1] genericDiv #-}

{-
-- |
-- IEEE 754 @squareRoot@ operation.
genericSqrt :: (RealFloat a, RealFloat b) => a -> b
genericSqrt x | x == 0 = realFloatToFrac x
              | x > 0, isFinite x = error "not implemented yet"
              | otherwise = realFloatToFrac (sqrt x)
-}

-- |
-- IEEE 754 @fusedMultiplyAdd@ operation.
genericFusedMultiplyAdd :: (RealFloat a, RealFloat b) => a -> a -> a -> b
genericFusedMultiplyAdd :: forall a b. (RealFloat a, RealFloat b) => a -> a -> a -> b
genericFusedMultiplyAdd a
a a
b a
c
  | a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
a Bool -> Bool -> Bool
&& a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
b Bool -> Bool -> Bool
&& a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
c = case a -> Rational
forall a. Real a => a -> Rational
toRational a
a Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* a -> Rational
forall a. Real a => a -> Rational
toRational a
b Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ a -> Rational
forall a. Real a => a -> Rational
toRational a
c of
                                               Rational
0 | a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero (a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
b a -> a -> a
forall a. Num a => a -> a -> a
+ a
c) -> -b
0
                                               Rational
r -> Rational -> b
forall a. Fractional a => Rational -> a
fromRational Rational
r
  | a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
a Bool -> Bool -> Bool
&& a -> Bool
forall a. RealFloat a => a -> Bool
isFinite a
b = a -> b
forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac a
c -- c is Infinity or NaN
  | Bool
otherwise = a -> b
forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
b a -> a -> a
forall a. Num a => a -> a -> a
+ a
c)
{-# NOINLINE [1] genericFusedMultiplyAdd #-}

{-# RULES
"genericAdd/a->a" genericAdd = (+)
"genericSub/a->a" genericSub = (-)
"genericMul/a->a" genericMul = (*)
"genericDiv/a->a" genericDiv = (/)
"genericFusedMultiplyAdd/a->a" genericFusedMultiplyAdd = fusedMultiplyAdd
  #-}

-- | Returns True if @a@ is a subtype of @b@
--
-- >>> isSubFloatingType (undefined :: Float) (undefined :: Double)
-- True
-- >>> isSubFloatingType (undefined :: Double) (undefined :: Float)
-- False
-- >>> isSubFloatingType (undefined :: Double) (undefined :: Double)
-- True
isSubFloatingType :: (RealFloat a, RealFloat b) => a -> b -> Bool
isSubFloatingType :: forall a b. (RealFloat a, RealFloat b) => a -> b -> Bool
isSubFloatingType a
a b
b = Bool
ieeeA Bool -> Bool -> Bool
&& Bool
ieeeB Bool -> Bool -> Bool
&& Integer
baseA Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
baseB Bool -> Bool -> Bool
&& Int
eminB Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
eminA Bool -> Bool -> Bool
&& Int
emaxA Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
emaxB Bool -> Bool -> Bool
&& Int
digitsA Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
digitsB
  where
    ieeeA :: Bool
ieeeA = a -> Bool
forall a. RealFloat a => a -> Bool
isIEEE a
a
    ieeeB :: Bool
ieeeB = b -> Bool
forall a. RealFloat a => a -> Bool
isIEEE b
b
    baseA :: Integer
baseA = a -> Integer
forall a. RealFloat a => a -> Integer
floatRadix a
a
    baseB :: Integer
baseB = b -> Integer
forall a. RealFloat a => a -> Integer
floatRadix b
b
    (Int
eminA,Int
emaxA) = a -> (Int, Int)
forall a. RealFloat a => a -> (Int, Int)
floatRange a
a
    (Int
eminB,Int
emaxB) = b -> (Int, Int)
forall a. RealFloat a => a -> (Int, Int)
floatRange b
b
    digitsA :: Int
digitsA = a -> Int
forall a. RealFloat a => a -> Int
floatDigits a
a
    digitsB :: Int
digitsB = b -> Int
forall a. RealFloat a => a -> Int
floatDigits b
b

-- | Returns True if @a@ is a subtype of @b@
--
-- >>> isSubFloatingTypeProxy (Proxy :: Proxy Float) (Proxy :: Proxy Double)
-- True
-- >>> isSubFloatingTypeProxy (Proxy :: Proxy Double) (Proxy :: Proxy Float)
-- False
-- >>> isSubFloatingTypeProxy (Proxy :: Proxy Double) (Proxy :: Proxy Double)
-- True
isSubFloatingTypeProxy :: (RealFloat a, RealFloat b) => Proxy a -> Proxy b -> Bool
isSubFloatingTypeProxy :: forall a b.
(RealFloat a, RealFloat b) =>
Proxy a -> Proxy b -> Bool
isSubFloatingTypeProxy Proxy a
proxyA Proxy b
proxyB = a -> b -> Bool
forall a b. (RealFloat a, RealFloat b) => a -> b -> Bool
isSubFloatingType (a
forall a. HasCallStack => a
undefined a -> Proxy a -> a
forall a (proxy :: * -> *). a -> proxy a -> a
`asProxyTypeOf` Proxy a
proxyA) (b
forall a. HasCallStack => a
undefined b -> Proxy b -> b
forall a (proxy :: * -> *). a -> proxy a -> a
`asProxyTypeOf` Proxy b
proxyB)