{-# 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 x :: a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= 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 x :: Float
x = let w :: Word32
w = Float -> Word32
castFloatToWord32 Float
x Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. 0x7f80_0000
                  in Word32
w Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 Bool -> Bool -> Bool
&& Word32
w Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0x7f80_0000

isDoubleNormal :: Double -> Bool
isDoubleNormal :: Double -> Bool
isDoubleNormal x :: Double
x = let w :: Word64
w = Double -> Word64
castDoubleToWord64 Double
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. 0x7ff0_0000_0000_0000
                   in Word64
w Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 Bool -> Bool -> Bool
&& Word64
w Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= 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 x :: 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 x :: a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 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 x :: a
x = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< 0 Bool -> Bool -> Bool
|| a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
x

-- |
-- Comparison with IEEE 754 @totalOrder@ predicate.
--
-- 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".
--
-- Floating-point numbers are ordered as,
-- \(-\infty < \text{negative reals} < -0 < +0 < \text{positive reals} < +\infty < \mathrm{NaN}\).
compareByTotalOrder :: RealFloat a => a -> a -> Ordering
compareByTotalOrder :: a -> a -> Ordering
compareByTotalOrder x :: a
x y :: 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
== 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 x :: a
x y :: 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 x :: 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
< 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
< 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
< 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
== 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 x :: 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 31 -- sign bit
                      e :: Word32
e = (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` 23) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. 0xff -- exponent (8 bits)
                      m :: Word32
m = Word32
w Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. 0x007f_ffff -- mantissa (23 bits without leading 1)
                   in case (Bool
s, Word32
e, Word32
m) of
                        (True,  0,    0) -> Class
NegativeZero
                        (False, 0,    0) -> Class
PositiveZero
                        (True,  0,    _) -> Class
NegativeSubnormal
                        (False, 0,    _) -> Class
PositiveSubnormal
                        (True,  0xff, 0) -> Class
NegativeInfinity
                        (False, 0xff, 0) -> Class
PositiveInfinity
                        (_,     0xff, _) -> Class
QuietNaN -- treat all NaNs as quiet
                        (True,  _,    _) -> Class
NegativeNormal
                        (False, _,    _) -> Class
PositiveNormal

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