module Data.Binary.IEEE754 (
getFloat16be, getFloat16le
, getFloat32be, getFloat32le
, getFloat64be, getFloat64le
, putFloat32be, putFloat32le
, putFloat64be, putFloat64le
, floatToWord, wordToFloat
, doubleToWord, wordToDouble
) where
import Prelude hiding (exp)
import Data.Bits (shiftL, shiftR, (.|.), (.&.))
import qualified Data.Binary.Get as G
import qualified Data.Binary.Put as P
import qualified Foreign as F
getFloat16be :: G.Get Float
getFloat16be = fmap toFloat16 G.getWord16be
getFloat16le :: G.Get Float
getFloat16le = fmap toFloat16 G.getWord16le
getFloat32be :: G.Get Float
getFloat32be = fmap toFloat G.getWord32be
getFloat32le :: G.Get Float
getFloat32le = fmap toFloat G.getWord32le
getFloat64be :: G.Get Double
getFloat64be = fmap toFloat G.getWord64be
getFloat64le :: G.Get Double
getFloat64le = fmap toFloat G.getWord64le
putFloat32be :: Float -> P.Put
putFloat32be = P.putWord32be . fromFloat
putFloat32le :: Float -> P.Put
putFloat32le = P.putWord32le . fromFloat
putFloat64be :: Double -> P.Put
putFloat64be = P.putWord64be . fromFloat
putFloat64le :: Double -> P.Put
putFloat64le = P.putWord64le . fromFloat
floatToWord :: Float -> F.Word32
floatToWord = fromFloat
wordToFloat :: F.Word32 -> Float
wordToFloat = toFloat
doubleToWord :: Double -> F.Word64
doubleToWord = fromFloat
wordToDouble :: F.Word64 -> Double
wordToDouble = toFloat
toFloat :: (F.Storable word, F.Storable float) => word -> float
toFloat word = F.unsafePerformIO $ F.alloca $ \buf -> do
F.poke (F.castPtr buf) word
F.peek buf
fromFloat :: (F.Storable word, F.Storable float) => float -> word
fromFloat float = F.unsafePerformIO $ F.alloca $ \buf -> do
F.poke (F.castPtr buf) float
F.peek buf
toFloat16 :: F.Word16 -> Float
toFloat16 word16 = toFloat (sign32 .|. word32) where
sign16 = word16 .&. 0x8000
exp16 = word16 .&. 0x7C00
frac16 = word16 .&. 0x3FF
sign32 = if sign16 > 0
then 0x80000000
else 0
word32 :: F.Word32
word32 | word16 .&. 0x7FFF == 0 = 0
| exp16 == 0x7C00 = special
| otherwise = shiftL exp32 23 .|. shiftL frac32 13
special = if frac16 == 0
then 0x7F800000
else 0x7FC00000 .|. fromIntegral frac16
(exp32, frac32) = if exp16 > 0
then normalised
else denormalised
normalised = (exp, frac) where
exp = (fromIntegral exp16 `shiftR` 10) 15 + 127
frac = fromIntegral frac16
denormalised = (exp, frac) where
exp = (fromIntegral exp16 `shiftR` 10) 15 + 127 e
(e, frac ) = step 0 (shiftL frac16 1) where
step acc x = if x .&. 0x400 == 0
then step (acc + 1) (shiftL x 1)
else (acc, fromIntegral x .&. 0x3FF)