{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Numbers.CrackNum
(
FP(..), Precision(..), IPrecision(..), Kind(..)
, floatToFP, doubleToFP, stringToFP, integerToFP
, displayFP, displayWord
, floatToWord, wordToFloat, doubleToWord, wordToDouble
)
where
import Data.Bits (testBit, setBit, Bits)
import Data.Char (toLower)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.List (intercalate)
import Data.Maybe (isJust, fromJust, fromMaybe, catMaybes)
import Numeric
import Data.Numbers.CrackNum.Data
import Data.Numbers.CrackNum.Utils
import qualified Data.Numbers.FloatingHex as FH
import Data.Word (Word32, Word64)
import Data.Array.ST (newArray, readArray, MArray, STUArray)
import Data.Array.Unsafe (castSTUArray)
import GHC.ST (runST, ST)
integerToFP :: Precision -> Integer -> FP
integerToFP :: Precision -> Integer -> FP
integerToFP HP = Precision -> Int -> Int -> [Int] -> [Int] -> Integer -> FP
crack Precision
HP 15 15 [14, 13 .. 10] [9, 8 .. 0]
integerToFP SP = Precision -> Int -> Int -> [Int] -> [Int] -> Integer -> FP
crack Precision
SP 127 31 [30, 29 .. 23] [22, 21 .. 0]
integerToFP DP = Precision -> Int -> Int -> [Int] -> [Int] -> Integer -> FP
crack Precision
DP 1023 63 [62, 61 .. 52] [51, 50 .. 0]
spVal :: Bool -> Int -> [Bool] -> Float
spVal :: Bool -> Int -> [Bool] -> Float
spVal dn :: Bool
dn expVal :: Int
expVal fracBits :: [Bool]
fracBits = ((2::Float) Float -> Float -> Float
forall a. Floating a => a -> a -> a
** Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
expVal) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float
add1 Float
frac
where frac :: Float
frac = [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Float] -> Float) -> [Float] -> Float
forall a b. (a -> b) -> a -> b
$ (Bool -> Int -> Float) -> [Bool] -> [Int] -> [Float]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\b :: Bool
b i :: Int
i -> if Bool
b then (2::Float)Float -> Float -> Float
forall a. Floating a => a -> a -> a
**(-(Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i::Int))) else 0) [Bool]
fracBits [1..]
add1 :: Float -> Float
add1 | Bool
dn = Float -> Float
forall a. a -> a
id
| Bool
True = (1Float -> Float -> Float
forall a. Num a => a -> a -> a
+)
dpVal :: Bool -> Int -> [Bool] -> Double
dpVal :: Bool -> Int -> [Bool] -> Double
dpVal dn :: Bool
dn expVal :: Int
expVal fracBits :: [Bool]
fracBits = ((2::Double) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
expVal) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
add1 Double
frac
where frac :: Double
frac = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ (Bool -> Int -> Double) -> [Bool] -> [Int] -> [Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\b :: Bool
b i :: Int
i -> if Bool
b then (2::Double)Double -> Double -> Double
forall a. Floating a => a -> a -> a
**(-(Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i::Int))) else 0) [Bool]
fracBits [1..]
add1 :: Double -> Double
add1 | Bool
dn = Double -> Double
forall a. a -> a
id
| Bool
True = (1Double -> Double -> Double
forall a. Num a => a -> a -> a
+)
crack :: Precision -> Int -> Int -> [Int] -> [Int] -> Integer -> FP
crack :: Precision -> Int -> Int -> [Int] -> [Int] -> Integer -> FP
crack vPrec :: Precision
vPrec vBias :: Int
vBias signPos :: Int
signPos expPos :: [Int]
expPos fracPos :: [Int]
fracPos val :: Integer
val
= FP :: Integer
-> Precision
-> Bool
-> Int
-> Int
-> Int
-> [Bool]
-> String
-> Kind
-> FP
FP { intVal :: Integer
intVal = Integer
val
, prec :: Precision
prec = Precision
vPrec
, sign :: Bool
sign = Bool
vSign
, stExpt :: Int
stExpt = Int
vStoredExp
, expt :: Int
expt = Int
vStoredExp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
curBias
, bias :: Int
bias = Int
curBias
, fracBits :: [Bool]
fracBits = [Bool]
vFracBits
, bitLayOut :: String
bitLayOut = [[Bool]] -> String
layOut [[Bool
vSign], [Bool]
vExpBits, [Bool]
vFracBits]
, kind :: Kind
kind = Kind
vKind
}
where bit :: Int -> Bool
bit i :: Int
i = Integer
val Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i
vSign :: Bool
vSign = Int -> Bool
bit Int
signPos
vExpBits :: [Bool]
vExpBits = (Int -> Bool) -> [Int] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Bool
bit [Int]
expPos
vStoredExp :: Int
vStoredExp = [Bool] -> Int
forall a. Num a => [Bool] -> a
bv [Bool]
vExpBits
vFracBits :: [Bool]
vFracBits = (Int -> Bool) -> [Int] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Bool
bit [Int]
fracPos
isZero :: Bool
isZero = [Bool] -> Bool
all0 [Bool]
vExpBits Bool -> Bool -> Bool
&& [Bool] -> Bool
all0 [Bool]
vFracBits
isDenormal :: Bool
isDenormal = [Bool] -> Bool
all0 [Bool]
vExpBits Bool -> Bool -> Bool
&& [Bool] -> Bool
any1 [Bool]
vFracBits
isInfinity :: Bool
isInfinity = [Bool] -> Bool
all1 [Bool]
vExpBits Bool -> Bool -> Bool
&& [Bool] -> Bool
all0 [Bool]
vFracBits
isNAN :: Bool
isNAN = [Bool] -> Bool
all1 [Bool]
vExpBits Bool -> Bool -> Bool
&& [Bool] -> Bool
any1 [Bool]
vFracBits
vKind :: Kind
vKind | Bool
isZero = Bool -> Kind
Zero Bool
vSign
| Bool
isInfinity = Bool -> Kind
Infty Bool
vSign
| Bool
isNAN = if [Bool] -> Bool
forall a. [a] -> a
head [Bool]
vFracBits then Kind
QNaN else Kind
SNaN
| Bool
isDenormal = Kind
Denormal
| Bool
True = Kind
Normal
curBias :: Int
curBias = case Kind
vKind of
Denormal -> Int
vBias Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
_ -> Int
vBias
displayFP :: FP -> String
displayFP :: FP -> String
displayFP FP{Integer
intVal :: Integer
intVal :: FP -> Integer
intVal, Precision
prec :: Precision
prec :: FP -> Precision
prec, Bool
sign :: Bool
sign :: FP -> Bool
sign, Int
stExpt :: Int
stExpt :: FP -> Int
stExpt, Int
bias :: Int
bias :: FP -> Int
bias, Int
expt :: Int
expt :: FP -> Int
expt, [Bool]
fracBits :: [Bool]
fracBits :: FP -> [Bool]
fracBits, String
bitLayOut :: String
bitLayOut :: FP -> String
bitLayOut, Kind
kind :: Kind
kind :: FP -> Kind
kind} = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" [String]
ls
where ls :: [String]
ls = [ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inds1
, " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inds2
, " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inds3
, " Binary: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
bitLayOut
, " Hex: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Bool] -> String
hexDisp [Bool]
allBits
, " Precision: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Precision -> String
forall a. Show a => a -> String
show Precision
prec
, " Sign: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
sign then "Negative" else "Positive"
, " Exponent: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
expt String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (Stored: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
stExpt String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", Bias: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bias String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
, " Hex-float: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hexVal
, " Value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val
]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ " Note: Representation for NaN's is not unique." | Kind -> Bool
isNaNKind Kind
kind]
(inds1 :: String
inds1, inds2 :: String
inds2, inds3 :: String
inds3) = case Precision
prec of
HP -> (String
hpInds1, String
hpInds2, String
hpInds3)
SP -> (String
spInds1, String
spInds2, String
spInds3)
DP -> (String
dpInds1, String
dpInds2, String
dpInds3)
allBits :: [Bool]
allBits = case Precision
prec of
HP -> [Integer
intVal Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i | Int
i <- Int -> [Int]
forall a. (Num a, Enum a) => a -> [a]
startsAt 15]
SP -> [Integer
intVal Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i | Int
i <- Int -> [Int]
forall a. (Num a, Enum a) => a -> [a]
startsAt 31]
DP -> [Integer
intVal Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i | Int
i <- Int -> [Int]
forall a. (Num a, Enum a) => a -> [a]
startsAt 63]
where startsAt :: a -> [a]
startsAt n :: a
n = [a
n, a
na -> a -> a
forall a. Num a => a -> a -> a
-1 .. 0]
dup :: b -> (b, b)
dup x :: b
x = (b
x, b
x)
(val :: String
val, hexVal :: String
hexVal) = case Kind
kind of
Zero False -> ("+0.0", "0x0p+0")
Zero True -> ("-0.0", "-0x0p+0")
Infty False -> String -> (String, String)
forall b. b -> (b, b)
dup "+Infinity"
Infty True -> String -> (String, String)
forall b. b -> (b, b)
dup "-Infinity"
SNaN -> String -> (String, String)
forall b. b -> (b, b)
dup "NaN (Signaling)"
QNaN -> String -> (String, String)
forall b. b -> (b, b)
dup "NaN (Quietized)"
Denormal -> Bool -> String -> (String, String)
nval Bool
True " (DENORMAL)"
Normal -> Bool -> String -> (String, String)
nval Bool
False " (NORMAL)"
nval :: Bool -> String -> (String, String)
nval dn :: Bool
dn tag :: String
tag = (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag, String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vh)
where s :: String
s = if Bool
sign then "-" else "+"
vd :: String
vd = case Precision
prec of
HP -> Maybe Int -> Float -> String -> String
forall a. RealFloat a => Maybe Int -> a -> String -> String
showGFloat Maybe Int
forall a. Maybe a
Nothing (Bool -> Int -> [Bool] -> Float
spVal Bool
dn Int
expt [Bool]
fracBits) ""
SP -> Maybe Int -> Float -> String -> String
forall a. RealFloat a => Maybe Int -> a -> String -> String
showGFloat Maybe Int
forall a. Maybe a
Nothing (Bool -> Int -> [Bool] -> Float
spVal Bool
dn Int
expt [Bool]
fracBits) ""
DP -> Maybe Int -> Double -> String -> String
forall a. RealFloat a => Maybe Int -> a -> String -> String
showGFloat Maybe Int
forall a. Maybe a
Nothing (Bool -> Int -> [Bool] -> Double
dpVal Bool
dn Int
expt [Bool]
fracBits) ""
vh :: String
vh = case Precision
prec of
HP -> Float -> String -> String
forall a. RealFloat a => a -> String -> String
FH.showHFloat (Bool -> Int -> [Bool] -> Float
spVal Bool
dn Int
expt [Bool]
fracBits) ""
SP -> Float -> String -> String
forall a. RealFloat a => a -> String -> String
FH.showHFloat (Bool -> Int -> [Bool] -> Float
spVal Bool
dn Int
expt [Bool]
fracBits) ""
DP -> Double -> String -> String
forall a. RealFloat a => a -> String -> String
FH.showHFloat (Bool -> Int -> [Bool] -> Double
dpVal Bool
dn Int
expt [Bool]
fracBits) ""
instance Show FP where
show :: FP -> String
show = FP -> String
displayFP
displayWord :: IPrecision -> Integer -> String
displayWord :: IPrecision -> Integer -> String
displayWord iprec :: IPrecision
iprec intVal :: Integer
intVal = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" [String]
ls
where (sg :: Bool
sg, sz :: Int
sz) = IPrecision -> (Bool, Int)
sgSz IPrecision
iprec
ls :: [String]
ls = [ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
inds1 | Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
inds1]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inds2
, " Binary: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Bool] -> String
binDisp [Bool]
allBits
, " Hex: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Bool] -> String
hexDisp [Bool]
allBits
, " Type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IPrecision -> String
forall a. Show a => a -> String
show IPrecision
iprec
]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ " Sign: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
signBit then "Negative" else "Positive" | Bool
sg]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ " Value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val
]
(inds1 :: Maybe String
inds1, inds2 :: String
inds2) = case Int
sz of
8 -> (Maybe String
forall a. Maybe a
Nothing, String
bInds2)
16 -> (String -> Maybe String
forall a. a -> Maybe a
Just String
wInds1, String
wInds2)
32 -> (String -> Maybe String
forall a. a -> Maybe a
Just String
dInds1, String
dInds2)
64 -> (String -> Maybe String
forall a. a -> Maybe a
Just String
qInds1, String
qInds2)
_ -> String -> (Maybe String, String)
forall a. HasCallStack => String -> a
error (String -> (Maybe String, String))
-> String -> (Maybe String, String)
forall a b. (a -> b) -> a -> b
$ "displayWord: Unexpected size: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sz
allBits :: [Bool]
allBits = [Integer
intVal Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i | Int
i <- [Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-1, Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-2 .. 0]]
signBit :: Bool
signBit = [Bool] -> Bool
forall a. [a] -> a
head [Bool]
allBits
val :: String
val | Bool -> Bool
not Bool
sg = Integer -> String
forall a. Show a => a -> String
show Integer
intVal
| Bool
True = case IPrecision
iprec of
I8 -> Int8 -> String
forall a. Show a => a -> String
show (Int8 -> String) -> Int8 -> String
forall a b. (a -> b) -> a -> b
$ Int8 -> Int8
forall a. Bits a => a -> a
adjust (0::Int8)
I16 -> Int16 -> String
forall a. Show a => a -> String
show (Int16 -> String) -> Int16 -> String
forall a b. (a -> b) -> a -> b
$ Int16 -> Int16
forall a. Bits a => a -> a
adjust (0::Int16)
I32 -> Int32 -> String
forall a. Show a => a -> String
show (Int32 -> String) -> Int32 -> String
forall a b. (a -> b) -> a -> b
$ Int32 -> Int32
forall a. Bits a => a -> a
adjust (0::Int32)
I64 -> Int64 -> String
forall a. Show a => a -> String
show (Int64 -> String) -> Int64 -> String
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64
forall a. Bits a => a -> a
adjust (0::Int64)
_ -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ "displayWord: Unexpected type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IPrecision -> String
forall a. Show a => a -> String
show IPrecision
iprec
adjust :: Bits a => a -> a
adjust :: a -> a
adjust v :: a
v = (Int -> a -> a) -> a -> [Int] -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((a -> Int -> a) -> Int -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Int -> a
forall a. Bits a => a -> Int -> a
setBit) a
v [Int
i | (i :: Int
i, True) <- [Int] -> [Bool] -> [(Int, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] ([Bool] -> [Bool]
forall a. [a] -> [a]
reverse [Bool]
allBits)]
stringToFP :: Precision -> String -> FP
stringToFP :: Precision -> String -> FP
stringToFP precision :: Precision
precision input :: String
input
= case Precision
precision of
SP -> FP -> Maybe FP -> FP
forall a. a -> Maybe a -> a
fromMaybe (String -> FP
forall a. HasCallStack => String -> a
error (String -> FP) -> String -> FP
forall a b. (a -> b) -> a -> b
$ "*** stringToFP: Cannot read a valid SP number from: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
input) Maybe FP
mbF
DP -> FP -> Maybe FP -> FP
forall a. a -> Maybe a -> a
fromMaybe (String -> FP
forall a. HasCallStack => String -> a
error (String -> FP) -> String -> FP
forall a b. (a -> b) -> a -> b
$ "*** stringToFP: Cannot read a valid DP number from: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
input) Maybe FP
mbD
_ -> String -> FP
forall a. HasCallStack => String -> a
error (String -> FP) -> String -> FP
forall a b. (a -> b) -> a -> b
$ "*** stringToFP: Unsupported precision: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Precision -> String
forall a. Show a => a -> String
show Precision
precision
where i :: String
i = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '+') String
input)
specials :: [(String, (FP, FP))]
specials :: [(String, (FP, FP))]
specials = [ (String
s, (Float -> FP
floatToFP Float
f, Double -> FP
doubleToFP Double
d))
| (s :: String
s, (f :: Float
f, d :: Double
d)) <- [ ("infinity", ( Float
infinityF, Double
infinityD))
, ("-infinity", (-Float
infinityF, - Double
infinityD))
, ("0", ( 0, 0))
, ("-0", (-0, - 0))
, ("max", ( Float
maxFiniteF, Double
maxFiniteD))
, ("-max", (-Float
maxFiniteF, - Double
maxFiniteD))
, ("min", ( Float
minNormalF, Double
minNormalD))
, ("-min", (-Float
minNormalF, - Double
minNormalD))
, ("epsilon", ( Float
epsilonF, Double
epsilonD))] ]
[(String, (FP, FP))]
-> [(String, (FP, FP))] -> [(String, (FP, FP))]
forall a. [a] -> [a] -> [a]
++ [ ("ulp", (Precision -> Integer -> FP
integerToFP Precision
SP 1, Precision -> Integer -> FP
integerToFP Precision
DP 1))
, ("nan", (Precision -> Integer -> FP
integerToFP Precision
SP 0x7f800001, Precision -> Integer -> FP
integerToFP Precision
DP 0x7ff0000000000001))
, ("snan", (Precision -> Integer -> FP
integerToFP Precision
SP 0x7f800001, Precision -> Integer -> FP
integerToFP Precision
DP 0x7ff0000000000001))
, ("qnan", (Precision -> Integer -> FP
integerToFP Precision
SP 0x7fc00000, Precision -> Integer -> FP
integerToFP Precision
DP 0x7ff8000000000000))
]
infinityF, maxFiniteF, minNormalF, epsilonF :: Float
infinityF :: Float
infinityF = 1Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/0
maxFiniteF :: Float
maxFiniteF = 3.40282347e+38
minNormalF :: Float
minNormalF = 1.17549435e-38
epsilonF :: Float
epsilonF = 1.19209290e-07
infinityD, maxFiniteD, minNormalD, epsilonD :: Double
infinityD :: Double
infinityD = 1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0
maxFiniteD :: Double
maxFiniteD = 1.7976931348623157e+308
minNormalD :: Double
minNormalD = 2.2250738585072014e-308
epsilonD :: Double
epsilonD = 2.2204460492503131e-16
mbF, mbD :: Maybe FP
(mbF :: Maybe FP
mbF, mbD :: Maybe FP
mbD) = case (String
i String -> [(String, (FP, FP))] -> Maybe (FP, FP)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, (FP, FP))]
specials, String -> Maybe Float
forall a. (Read a, FloatingHexReader a) => String -> Maybe a
rd String
i :: Maybe Float, String -> Maybe Double
forall a. (Read a, FloatingHexReader a) => String -> Maybe a
rd String
i :: Maybe Double) of
(Just (f :: FP
f, d :: FP
d), _ , _ ) -> (FP -> Maybe FP
forall a. a -> Maybe a
Just FP
f, FP -> Maybe FP
forall a. a -> Maybe a
Just FP
d)
(Nothing, Just f :: Float
f, Just d :: Double
d) -> (FP -> Maybe FP
forall a. a -> Maybe a
Just (Float -> FP
floatToFP Float
f), FP -> Maybe FP
forall a. a -> Maybe a
Just (Double -> FP
doubleToFP Double
d))
(Nothing, Just f :: Float
f, _ ) -> (FP -> Maybe FP
forall a. a -> Maybe a
Just (Float -> FP
floatToFP Float
f), Maybe FP
forall a. Maybe a
Nothing)
(Nothing, _, Just d :: Double
d) -> (Maybe FP
forall a. Maybe a
Nothing, FP -> Maybe FP
forall a. a -> Maybe a
Just (Double -> FP
doubleToFP Double
d))
_ -> (Maybe FP
forall a. Maybe a
Nothing, Maybe FP
forall a. Maybe a
Nothing)
rd :: (Read a, FH.FloatingHexReader a) => String -> Maybe a
rd :: String -> Maybe a
rd s :: String
s = case [a
v | (v :: a
v, "") <- ReadS a
forall a. Read a => ReadS a
reads String
s] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes [String -> Maybe a
forall a. FloatingHexReader a => String -> Maybe a
FH.readHFloat String
s] of
[v :: a
v] -> a -> Maybe a
forall a. a -> Maybe a
Just a
v
_ -> Maybe a
forall a. Maybe a
Nothing
floatToFP :: Float -> FP
floatToFP :: Float -> FP
floatToFP = Precision -> Integer -> FP
integerToFP Precision
SP (Integer -> FP) -> (Float -> Integer) -> Float -> FP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word32 -> Integer) -> (Float -> Word32) -> Float -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Word32
floatToWord
doubleToFP :: Double -> FP
doubleToFP :: Double -> FP
doubleToFP = Precision -> Integer -> FP
integerToFP Precision
DP (Integer -> FP) -> (Double -> Integer) -> Double -> FP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Integer) -> (Double -> Word64) -> Double -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word64
doubleToWord
floatToWord :: Float -> Word32
floatToWord :: Float -> Word32
floatToWord x :: Float
x = (forall s. ST s Word32) -> Word32
forall a. (forall s. ST s a) -> a
runST (Float -> ST s Word32
forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast Float
x)
{-# INLINEABLE floatToWord #-}
wordToFloat :: Word32 -> Float
wordToFloat :: Word32 -> Float
wordToFloat x :: Word32
x = (forall s. ST s Float) -> Float
forall a. (forall s. ST s a) -> a
runST (Word32 -> ST s Float
forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast Word32
x)
{-# INLINEABLE wordToFloat #-}
doubleToWord :: Double -> Word64
doubleToWord :: Double -> Word64
doubleToWord x :: Double
x = (forall s. ST s Word64) -> Word64
forall a. (forall s. ST s a) -> a
runST (Double -> ST s Word64
forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast Double
x)
{-# INLINEABLE doubleToWord #-}
wordToDouble :: Word64 -> Double
wordToDouble :: Word64 -> Double
wordToDouble x :: Word64
x = (forall s. ST s Double) -> Double
forall a. (forall s. ST s a) -> a
runST (Word64 -> ST s Double
forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast Word64
x)
{-# INLINEABLE wordToDouble #-}
{-# INLINE cast #-}
cast :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b
cast :: a -> ST s b
cast x :: a
x = (Int, Int) -> a -> ST s (STUArray s Int a)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (0 :: Int, 0) a
x ST s (STUArray s Int a)
-> (STUArray s Int a -> ST s (STUArray s Int b))
-> ST s (STUArray s Int b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STUArray s Int a -> ST s (STUArray s Int b)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray ST s (STUArray s Int b) -> (STUArray s Int b -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (STUArray s Int b -> Int -> ST s b)
-> Int -> STUArray s Int b -> ST s b
forall a b c. (a -> b -> c) -> b -> a -> c
flip STUArray s Int b -> Int -> ST s b
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray 0