{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NumericUnderscores #-}
module Numeric.Floating.IEEE.Internal.Classify where
import           Data.Bits
import           GHC.Float.Compat (castDoubleToWord64, castFloatToWord32,
                                   isDoubleFinite, isFloatFinite)
import           MyPrelude

default ()

-- |
-- IEEE 754 @isNormal@ operation.
isNormal :: RealFloat a => a -> Bool
isNormal :: a -> Bool
isNormal a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isDenormalized a
x)
{-# NOINLINE [1] isNormal #-}
{-# RULES
"isNormal/Float" isNormal = isFloatNormal
"isNormal/Double" isNormal = isDoubleNormal
  #-}

isFloatNormal :: Float -> Bool
isFloatNormal :: Float -> Bool
isFloatNormal Float
x = let w :: Word32
w = Float -> Word32
castFloatToWord32 Float
x Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7f80_0000
                  in Word32
w Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0 Bool -> Bool -> Bool
&& Word32
w Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0x7f80_0000

isDoubleNormal :: Double -> Bool
isDoubleNormal :: Double -> Bool
isDoubleNormal Double
x = let w :: Word64
w = Double -> Word64
castDoubleToWord64 Double
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x7ff0_0000_0000_0000
                   in Word64
w Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0 Bool -> Bool -> Bool
&& Word64
w Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0x7ff0_0000_0000_0000

-- |
-- Returns @True@ if the argument is normal, subnormal, or zero.
--
-- IEEE 754 @isFinite@ operation.
isFinite :: RealFloat a => a -> Bool
isFinite :: a -> Bool
isFinite a
x = Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x)
{-# NOINLINE [1] isFinite #-}
{-# RULES
"isFinite/Float"
  isFinite = \x -> isFloatFinite x /= 0
"isFinite/Double"
  isFinite = \x -> isDoubleFinite x /= 0
  #-}

-- |
-- Returns @True@ if the argument is zero.
--
-- IEEE 754 @isZero@ operation.
isZero :: RealFloat a => a -> Bool
isZero :: a -> Bool
isZero a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0

-- |
-- Returns @True@ if the argument is negative (including negative zero).
--
-- Since 'RealFloat' constraint is insufficient to query the sign of NaNs,
-- this function treats all NaNs as positive.
-- See also "Numeric.Floating.IEEE.NaN".
--
-- IEEE 754 @isSignMinus@ operation.
isSignMinus :: RealFloat a => a -> Bool
isSignMinus :: a -> Bool
isSignMinus a
x = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 Bool -> Bool -> Bool
|| a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
x

-- |
-- Comparison with IEEE 754 @totalOrder@ predicate.
--
-- Floating-point numbers are ordered as,
-- \(-\infty < \text{negative reals} < -0 < +0 < \text{positive reals} < +\infty < \mathrm{NaN}\).
--
-- Since 'RealFloat' constraint is insufficient to query the sign and payload of NaNs,
-- this function treats all NaNs as positive and does not make distinction between them.
-- See also "Numeric.Floating.IEEE.NaN".
--
-- Also, for the same reason, this function cannot distinguish the members of a cohort.
compareByTotalOrder :: RealFloat a => a -> a -> Ordering
compareByTotalOrder :: a -> a -> Ordering
compareByTotalOrder a
x a
y
  | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y = Ordering
LT
  | a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
x = Ordering
GT
  | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then
               Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
y) (a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
x)
             else
               Ordering
EQ
  | Bool
otherwise = Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x) (a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
y) -- The sign bit and payload of NaNs are ignored
-- TODO: Specialize for Float, Double

-- |
-- Comparison with IEEE 754 @totalOrderMag@ predicate.
--
-- Equivalent to @'compareByTotalOrder' (abs x) (abs y)@.
compareByTotalOrderMag :: RealFloat a => a -> a -> Ordering
compareByTotalOrderMag :: a -> a -> Ordering
compareByTotalOrderMag a
x a
y = a -> a -> Ordering
forall a. RealFloat a => a -> a -> Ordering
compareByTotalOrder (a -> a
forall a. Num a => a -> a
abs a
x) (a -> a
forall a. Num a => a -> a
abs a
y)

-- isCanonical :: a -> Bool

-- data PartialOrdering = LT | EQ | GT | UNORD

-- |
-- The classification of floating-point values.
data Class = SignalingNaN
           | QuietNaN
           | NegativeInfinity
           | NegativeNormal
           | NegativeSubnormal
           | NegativeZero
           | PositiveZero
           | PositiveSubnormal
           | PositiveNormal
           | PositiveInfinity
           deriving (Class -> Class -> Bool
(Class -> Class -> Bool) -> (Class -> Class -> Bool) -> Eq Class
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Class -> Class -> Bool
$c/= :: Class -> Class -> Bool
== :: Class -> Class -> Bool
$c== :: Class -> Class -> Bool
Eq, Eq Class
Eq Class
-> (Class -> Class -> Ordering)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Class)
-> (Class -> Class -> Class)
-> Ord Class
Class -> Class -> Bool
Class -> Class -> Ordering
Class -> Class -> Class
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Class -> Class -> Class
$cmin :: Class -> Class -> Class
max :: Class -> Class -> Class
$cmax :: Class -> Class -> Class
>= :: Class -> Class -> Bool
$c>= :: Class -> Class -> Bool
> :: Class -> Class -> Bool
$c> :: Class -> Class -> Bool
<= :: Class -> Class -> Bool
$c<= :: Class -> Class -> Bool
< :: Class -> Class -> Bool
$c< :: Class -> Class -> Bool
compare :: Class -> Class -> Ordering
$ccompare :: Class -> Class -> Ordering
$cp1Ord :: Eq Class
Ord, Int -> Class -> ShowS
[Class] -> ShowS
Class -> String
(Int -> Class -> ShowS)
-> (Class -> String) -> ([Class] -> ShowS) -> Show Class
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Class] -> ShowS
$cshowList :: [Class] -> ShowS
show :: Class -> String
$cshow :: Class -> String
showsPrec :: Int -> Class -> ShowS
$cshowsPrec :: Int -> Class -> ShowS
Show, ReadPrec [Class]
ReadPrec Class
Int -> ReadS Class
ReadS [Class]
(Int -> ReadS Class)
-> ReadS [Class]
-> ReadPrec Class
-> ReadPrec [Class]
-> Read Class
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Class]
$creadListPrec :: ReadPrec [Class]
readPrec :: ReadPrec Class
$creadPrec :: ReadPrec Class
readList :: ReadS [Class]
$creadList :: ReadS [Class]
readsPrec :: Int -> ReadS Class
$creadsPrec :: Int -> ReadS Class
Read, Int -> Class
Class -> Int
Class -> [Class]
Class -> Class
Class -> Class -> [Class]
Class -> Class -> Class -> [Class]
(Class -> Class)
-> (Class -> Class)
-> (Int -> Class)
-> (Class -> Int)
-> (Class -> [Class])
-> (Class -> Class -> [Class])
-> (Class -> Class -> [Class])
-> (Class -> Class -> Class -> [Class])
-> Enum Class
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Class -> Class -> Class -> [Class]
$cenumFromThenTo :: Class -> Class -> Class -> [Class]
enumFromTo :: Class -> Class -> [Class]
$cenumFromTo :: Class -> Class -> [Class]
enumFromThen :: Class -> Class -> [Class]
$cenumFromThen :: Class -> Class -> [Class]
enumFrom :: Class -> [Class]
$cenumFrom :: Class -> [Class]
fromEnum :: Class -> Int
$cfromEnum :: Class -> Int
toEnum :: Int -> Class
$ctoEnum :: Int -> Class
pred :: Class -> Class
$cpred :: Class -> Class
succ :: Class -> Class
$csucc :: Class -> Class
Enum)

-- |
-- Classifies a floating-point value.
--
-- Since 'RealFloat' constraint is insufficient to query signaling status of a NaN, this function treats all NaNs as quiet.
-- See also "Numeric.Floating.IEEE.NaN".
classify :: RealFloat a => a -> Class
classify :: a -> Class
classify a
x | a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x                 = Class
QuietNaN
           | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0, a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x     = Class
NegativeInfinity
           | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0, a -> Bool
forall a. RealFloat a => a -> Bool
isDenormalized a
x = Class
NegativeSubnormal
           | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0                   = Class
NegativeNormal
           | a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
x        = Class
NegativeZero
           | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0                  = Class
PositiveZero
           | a -> Bool
forall a. RealFloat a => a -> Bool
isDenormalized a
x        = Class
PositiveSubnormal
           | a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x            = Class
PositiveInfinity
           | Bool
otherwise               = Class
PositiveNormal
{-# NOINLINE [1] classify #-}
{-# RULES
"classify/Float" classify = classifyFloat
"classify/Double" classify = classifyDouble
  #-}

classifyFloat :: Float -> Class
classifyFloat :: Float -> Class
classifyFloat Float
x = let w :: Word32
w = Float -> Word32
castFloatToWord32 Float
x
                      s :: Bool
s = Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
w Int
31 -- sign bit
                      e :: Word32
e = (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
23) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff -- exponent (8 bits)
                      m :: Word32
m = Word32
w Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x007f_ffff -- mantissa (23 bits without leading 1)
                   in case (Bool
s, Word32
e, Word32
m) of
                        (Bool
True,  Word32
0,    Word32
0) -> Class
NegativeZero
                        (Bool
False, Word32
0,    Word32
0) -> Class
PositiveZero
                        (Bool
True,  Word32
0,    Word32
_) -> Class
NegativeSubnormal
                        (Bool
False, Word32
0,    Word32
_) -> Class
PositiveSubnormal
                        (Bool
True,  Word32
0xff, Word32
0) -> Class
NegativeInfinity
                        (Bool
False, Word32
0xff, Word32
0) -> Class
PositiveInfinity
                        (Bool
_,     Word32
0xff, Word32
_) -> Class
QuietNaN -- treat all NaNs as quiet
                        (Bool
True,  Word32
_,    Word32
_) -> Class
NegativeNormal
                        (Bool
False, Word32
_,    Word32
_) -> Class
PositiveNormal

classifyDouble :: Double -> Class
classifyDouble :: Double -> Class
classifyDouble Double
x = let w :: Word64
w = Double -> Word64
castDoubleToWord64 Double
x
                       s :: Bool
s = Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word64
w Int
63 -- sign bit
                       e :: Word64
e = (Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
52) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x7ff -- exponent (11 bits)
                       m :: Word64
m = Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x000f_ffff_ffff_ffff -- mantissa (52 bits without leading 1)
                   in case (Bool
s, Word64
e, Word64
m) of
                        (Bool
True,  Word64
0,     Word64
0) -> Class
NegativeZero
                        (Bool
False, Word64
0,     Word64
0) -> Class
PositiveZero
                        (Bool
True,  Word64
0,     Word64
_) -> Class
NegativeSubnormal
                        (Bool
False, Word64
0,     Word64
_) -> Class
PositiveSubnormal
                        (Bool
True,  Word64
0x7ff, Word64
0) -> Class
NegativeInfinity
                        (Bool
False, Word64
0x7ff, Word64
0) -> Class
PositiveInfinity
                        (Bool
_,     Word64
0x7ff, Word64
_) -> Class
QuietNaN -- treat all NaNs as quiet
                        (Bool
True,  Word64
_,     Word64
_) -> Class
NegativeNormal
                        (Bool
False, Word64
_,     Word64
_) -> Class
PositiveNormal