module Data.Binary.IEEE754 (
parseFloatBE, parseFloatLE
,getFloat16be, getFloat16le
,getFloat32be, getFloat32le
,getFloat64be, getFloat64le
,getFloat
,exponentWidth
,bitSlice
,splitRawIEEE754
,unbias
,mergeFloat
,Exponent
,Fraction
,BitCount
) where
import Data.Bits ((.&.), shiftL, shiftR)
import Data.Word (Word8)
import Data.List (foldl')
import qualified Data.ByteString as B
import Data.Binary.Get (Get, getByteString)
parseFloatBE :: (RealFloat a) => [Word8] -> a
parseFloatBE = parseFloat
parseFloatLE :: (RealFloat a) => [Word8] -> a
parseFloatLE = parseFloat . reverse
getFloat16be :: Get Float
getFloat16be = getFloat 16 parseFloatBE
getFloat16le :: Get Float
getFloat16le = getFloat 16 parseFloatLE
getFloat32be :: Get Float
getFloat32be = getFloat 32 parseFloatBE
getFloat32le :: Get Float
getFloat32le = getFloat 32 parseFloatLE
getFloat64be :: Get Double
getFloat64be = getFloat 64 parseFloatBE
getFloat64le :: Get Double
getFloat64le = getFloat 64 parseFloatLE
type Exponent = Int
type Fraction = Integer
type BitCount = Int
getFloat :: (RealFloat a) => BitCount -> ([Word8] -> a) -> Get a
getFloat width parser = do
bytes <- getByteString width
(return . parser . B.unpack) bytes
parseFloat :: (RealFloat a) => [Word8] -> a
parseFloat bs = merge' (splitRawIEEE754 bs)
where merge' (sign, e, f) = encode' (mergeFloat e f width) * signFactor sign
encode' (f, e) = encodeFloat f e
signFactor s = if s then (1) else 1
width = length bs * 8
exponentWidth :: BitCount -> BitCount
exponentWidth k
| k == 16 = 5
| k == 32 = 8
| k `mod` 32 == 0 = ceiling (4 * (log2 k)) 13
| otherwise = error "Invalid length of floating-point value"
bitSlice :: [Word8] -> BitCount -> BitCount -> Integer
bitSlice bs = sliceInt (foldl' step 0 bs) bitCount
where step acc w = (shiftL acc 8) + (fromIntegral w)
bitCount = ((length bs) * 8)
sliceInt :: Integer -> BitCount -> BitCount -> BitCount -> Integer
sliceInt x xBitCount s e = fromIntegral $ (x .&. startMask) `shiftR` (xBitCount e)
where startMask = n1Bits (xBitCount s)
n1Bits n = (2 `iExp` n) 1
splitRawIEEE754 :: [Word8] -> (Bool, Exponent, Fraction)
splitRawIEEE754 bs = (sign, exp, frac)
where sign = (head bs .&. 0x80) == 0x80
exp = fromIntegral $ bitSlice bs 1 (1 + w)
frac = bitSlice bs (1 + w) (length bs * 8)
w = exponentWidth $ length bs * 8
unbias :: Exponent -> BitCount -> Exponent
unbias e eWidth = e + 1 (2 `iExp` (eWidth 1))
mergeFloat :: Exponent -> Fraction -> BitCount -> (Integer, Int)
mergeFloat 0 0 _ = (0, 0)
mergeFloat e f width
| e == eMax = error "Infinity/NaN not supported"
| otherwise = case e of
0 -> (f, (fWidth) + (unbiasedE + 1))
_ -> (f + (1 `shiftL` fWidth), (fWidth) + unbiasedE)
where eWidth = exponentWidth width
fWidth = width eWidth 1
eMax = (2 `iExp` eWidth) 1
unbiasedE = unbias e (eWidth)
log2 = (logBase 2) . fromIntegral
iExp b e = floor $ (fromIntegral b) ** (fromIntegral e)