diff --git a/Data/Binary/IEEE754.hs b/Data/Binary/IEEE754.hs deleted file mode 100644 --- a/Data/Binary/IEEE754.hs +++ /dev/null @@ -1,258 +0,0 @@ -{- Copyright (C) 2009 John Millikin - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . --} - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Data.Binary.IEEE754 ( - -- * Parsing - parseFloatBE, parseFloatLE - - ,getFloat16be, getFloat16le - ,getFloat32be, getFloat32le - ,getFloat64be, getFloat64le - - ,getFloat - - -- * Serializing - ,putFloat32be, putFloat32le - ,putFloat64be, putFloat64le - - ,putFloat - - -- * Parser implementation - ,exponentWidth - ,bitSlice - ,splitRawIEEE754 - ,unbias - ,mergeFloat - - -- * Serializer implementation - ,bias - ,encodeIntBE, encodeIntLE - ,floatToMerged - ,mergeFloatBits - ,floatComponents - - -- * Useful type aliases - ,Exponent - ,Fraction - ,BitCount - ,ByteCount -) where - -import Data.Bits ((.&.), (.|.), shiftL, shiftR, Bits) -import Data.Word (Word8) -import Data.List (foldl') - -import qualified Data.ByteString as B -import Data.Binary.Get (Get, getByteString) -import Data.Binary.Put (Put, putByteString) - ---------------------------------------------------------------------- - --- |Parse a big-endian byte list into a floating-point value. -parseFloatBE :: (RealFloat a) => [Word8] -> a -parseFloatBE = parseFloat - --- |Parse a little-endian byte list into a floating-point value. -parseFloatLE :: (RealFloat a) => [Word8] -> a -parseFloatLE = parseFloat . reverse - -getFloat16be :: Get Float -getFloat16be = getFloat (ByteCount 2) parseFloatBE - -getFloat16le :: Get Float -getFloat16le = getFloat (ByteCount 2) parseFloatLE - -getFloat32be :: Get Float -getFloat32be = getFloat (ByteCount 4) parseFloatBE - -getFloat32le :: Get Float -getFloat32le = getFloat (ByteCount 4) parseFloatLE - -getFloat64be :: Get Double -getFloat64be = getFloat (ByteCount 8) parseFloatBE - -getFloat64le :: Get Double -getFloat64le = getFloat (ByteCount 8) parseFloatLE - --- |Parse a floating-point value of the given width (in bytes) from within --- a Get monad. -getFloat :: (RealFloat a) => ByteCount -> ([Word8] -> a) -> Get a -getFloat (ByteCount width) parser = do - bytes <- getByteString width - (return . parser . B.unpack) bytes - ---------------------------------------------------------------------- - -putFloat32be :: Float -> Put -putFloat32be x = putFloat (ByteCount 4) encodeIntBE x - -putFloat32le :: Float -> Put -putFloat32le x = putFloat (ByteCount 4) encodeIntLE x - -putFloat64be :: Double -> Put -putFloat64be x = putFloat (ByteCount 8) encodeIntBE x - -putFloat64le :: Double -> Put -putFloat64le x = putFloat (ByteCount 8) encodeIntLE x - -putFloat :: (RealFloat a) => ByteCount -> (ByteCount -> Integer -> [Word8]) -> a -> Put -putFloat width f v = putByteString $ B.pack words' - where words' = f width (floatToMerged width v) - -floatComponents :: (RealFloat a) => ByteCount -> a -> (Bool, Fraction, Exponent) -floatComponents width v = - case (dFraction, dExponent, biasedE) of - (0, 0, _) -> (sign, 0, 0) - (_, _, 0) -> (sign, truncatedFraction + 1, 0) - _ -> (sign, truncatedFraction, biasedE) - where dFraction = Fraction $ fst (decodeFloat v) - dExponent = Exponent $ snd (decodeFloat v) - eWidth = exponentWidth (bitCount width) - fWidth = (bitCount width) - eWidth - 1 -- 1 for sign bit - biasedE = bias (dExponent + (fromIntegral fWidth)) eWidth - absFraction = abs dFraction - - -- Weird check is for detecting -0.0 - sign = (1.0 / v) < 0.0 - - -- Fraction needs to be truncated, depending on the exponent - truncatedFraction = absFraction - (1 `bitShiftL` fWidth) - -floatToMerged :: (RealFloat a) => ByteCount -> a -> Integer -floatToMerged width v = mergeFloatBits' (floatComponents width v) - where mergeFloatBits' (s, f, e) = mergeFloatBits fWidth eWidth s f e - eWidth = exponentWidth (bitCount width) - fWidth = (bitCount width) - eWidth - 1 -- 1 for sign bit - -mergeFloatBits :: BitCount -> BitCount -> Bool -> Fraction -> Exponent -> Integer -mergeFloatBits fWidth eWidth s f e = shiftedSign .|. shiftedFrac .|. shiftedExp - where sBit = (if s then 1 else 0) :: Integer - shiftedSign = (sBit `bitShiftL` (fWidth + eWidth)) :: Integer - shiftedExp = ((fromIntegral e) `bitShiftL` fWidth) :: Integer - shiftedFrac = fromIntegral f - --- |Encode an integer to a list of words, in big-endian format -encodeIntBE :: ByteCount -> Integer -> [Word8] -encodeIntBE 0 _ = [] -encodeIntBE width x = (encodeIntBE (width - 1) (x `shiftR` 8)) ++ [step] - where step = (fromIntegral x) .&. 0xFF - --- |Encode an integer to a list of words, in little-endian format -encodeIntLE :: ByteCount -> Integer -> [Word8] -encodeIntLE width x = reverse (encodeIntBE width x) - -bias :: Exponent -> BitCount -> Exponent -bias e eWidth = e - (1 - (2 `iExp` (eWidth - 1))) - ---------------------------------------------------------------------- - -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 = bitsInWord8 bs - --- |Considering a byte list as a sequence of bits, slice it from start --- inclusive to end exclusive, and return the resulting bit sequence as an --- integer -bitSlice :: [Word8] -> BitCount -> BitCount -> Integer -bitSlice bs = sliceInt (foldl' step 0 bs) bitCount' - where step acc w = (shiftL acc 8) + (fromIntegral w) - bitCount' = bitsInWord8 bs - --- |Slice a single integer by start and end bit location -sliceInt :: Integer -> BitCount -> BitCount -> BitCount -> Integer -sliceInt x xBitCount s e = fromIntegral $ (x .&. startMask) `bitShiftR` (xBitCount - e) - where startMask = n1Bits (xBitCount - s) - n1Bits n = (2 `iExp` n) - 1 - --- |Split a raw bit array into (sign, exponent, fraction) components. These --- components have not been processed (unbiased, added significant bit, --- etc). -splitRawIEEE754 :: [Word8] -> (Bool, Exponent, Fraction) -splitRawIEEE754 bs = (sign, exp', frac) - where sign = (head bs .&. 0x80) == 0x80 - exp' = Exponent (fromIntegral $ bitSlice bs 1 (1 + w)) - frac = Fraction (bitSlice bs (1 + w) (bitsInWord8 bs)) - w = exponentWidth $ bitsInWord8 bs - --- |Unbias an exponent -unbias :: Exponent -> BitCount -> Exponent -unbias e eWidth = e + 1 - (2 `iExp` (eWidth - 1)) - --- |Parse values into a form suitable for encodeFloat --- sign exponent fraction width-in-bits -> fraction, exponent -mergeFloat :: Exponent -> Fraction -> BitCount -> (Integer, Int) - --- Zero -mergeFloat 0 0 _ = (0, 0) - -mergeFloat e f width - -- Infinity / NaN (TODO) - | e == eMax = error "Infinity/NaN not supported" - - | otherwise = case e of - -- Denormalized - 0 -> (fromIntegral f, (fromIntegral unbiasedE + 1) - (fromIntegral fWidth)) - - -- Normalized - _ -> (fromIntegral f + (1 `bitShiftL` fWidth), (fromIntegral unbiasedE) - (fromIntegral fWidth)) - - where eWidth = exponentWidth width - fWidth = width - eWidth - 1 - eMax = (2 `iExp` eWidth) - 1 - unbiasedE = unbias e (eWidth) - ---------------------------------------------------------------------- - --- |Calculate the proper size of the exponent field, in bits, given the --- size of the full structure. -exponentWidth :: BitCount -> BitCount -exponentWidth k - | k == 16 = 5 - | k == 32 = 8 - | k `mod` 32 == 0 = ceiling (4 * (logBase 2 (fromIntegral k))) - 13 - | otherwise = error "Invalid length of floating-point value" - --- |Integral exponent -iExp :: (Integral a, Integral b, Integral c) => a -> b -> c -iExp b e = floor $ (fromIntegral b) ** (fromIntegral e) - -newtype Exponent = Exponent Int - deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits) - -newtype Fraction = Fraction Integer - deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits) - -newtype BitCount = BitCount Int - deriving (Show, Eq, Num, Ord, Real, Enum, Integral) - -newtype ByteCount = ByteCount Int - deriving (Show, Eq, Num, Ord, Real, Enum, Integral) - -bitCount :: ByteCount -> BitCount -bitCount (ByteCount x) = BitCount (x * 8) - -bitsInWord8 :: [Word8] -> BitCount -bitsInWord8 ws = bitCount (ByteCount (length ws)) - -bitShiftL :: (Bits a) => a -> BitCount -> a -bitShiftL x (BitCount n) = shiftL x n - -bitShiftR :: (Bits a) => a -> BitCount -> a -bitShiftR x (BitCount n) = shiftR x n diff --git a/Data/Binary/IEEE754.lhs b/Data/Binary/IEEE754.lhs new file mode 100644 --- /dev/null +++ b/Data/Binary/IEEE754.lhs @@ -0,0 +1,402 @@ +% Copyright (C) 2009 John Millikin +% +% This program is free software: you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation, either version 3 of the License, or +% any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program. If not, see . + +\ignore{ +\begin{code} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.Binary.IEEE754 ( + -- * Parsing + getFloat16be, getFloat16le + , getFloat32be, getFloat32le + , getFloat64be, getFloat64le + + -- * Serializing + , putFloat32be, putFloat32le + , putFloat64be, putFloat64le +) where + +import Data.Bits ((.&.), (.|.), shiftL, shiftR, Bits) +import Data.Word (Word8) +import Data.List (foldl') + +import qualified Data.ByteString as B +import Data.Binary.Get (Get, getByteString) +import Data.Binary.Put (Put, putByteString) +\end{code} +} + +\section{Parsing} + +\subsection{Public interface} + +\begin{code} +getFloat16be :: Get Float +getFloat16be = getFloat (ByteCount 2) splitBytes +\end{code} + +\begin{code} +getFloat16le :: Get Float +getFloat16le = getFloat (ByteCount 2) $ splitBytes . reverse +\end{code} + +\begin{code} +getFloat32be :: Get Float +getFloat32be = getFloat (ByteCount 4) splitBytes +\end{code} + +\begin{code} +getFloat32le :: Get Float +getFloat32le = getFloat (ByteCount 4) $ splitBytes . reverse +\end{code} + +\begin{code} +getFloat64be :: Get Double +getFloat64be = getFloat (ByteCount 8) splitBytes +\end{code} + +\begin{code} +getFloat64le :: Get Double +getFloat64le = getFloat (ByteCount 8) $ splitBytes . reverse +\end{code} + +\subsection{Implementation} + +Split the raw byte array into (sign, exponent, significand) components. +The exponent and signifcand are drawn directly from the bits in the +original float, and have not been unbiased or otherwise modified. + +\begin{code} +splitBytes :: [Word8] -> RawFloat +splitBytes bs = RawFloat width sign exp' sig expWidth sigWidth where + width = ByteCount (length bs) + nBits = bitsInWord8 bs + sign = if head bs .&. 0x80 == 0x80 + then Negative + else Positive + + expStart = 1 + expWidth = exponentWidth nBits + expEnd = expStart + expWidth + exp' = Exponent . fromIntegral $ bitSlice bs expStart expEnd + + sigWidth = nBits - expEnd + sig = Significand $ bitSlice bs expEnd nBits +\end{code} + +\subsubsection{Encodings and special values} + +The next step depends on the value of the exponent $e$, size of the +exponent field in bits $w$, and value of the significand. + +\begin{table}[h] +\begin{center} +\begin{tabular}{lrl} +\toprule +Exponent & Significand & Format \\ +\midrule +$0$ & $0$ & Zero \\ +$0$ & $> 0$ & Denormalised \\ +$1 \leq e \leq 2^w - 2$ & \textit{any} & Normalised \\ +$2^w-1$ & $0$ & Infinity \\ +$2^w-1$ & $> 0$ & NaN \\ +\bottomrule +\end{tabular} +\end{center} +\end{table} + +There's no built-in literals for Infinity or NaN, so they +are constructed using the {\tt Read} instances for {\tt Double} and +{\tt Float}. + +\begin{code} +merge :: (Read a, RealFloat a) => RawFloat -> a +merge f@(RawFloat _ _ e sig eWidth _) + | e == 0 = if sig == 0 + then 0.0 + else denormalised f + | e == eMax - 1 = if sig == 0 + then read "Infinity" + else read "NaN" + | otherwise = normalised f + where eMax = 2 `pow` eWidth +\end{code} + +If a value is normalised, its significand has an implied {\tt 1} bit +in its most-significant bit. The significand must be adjusted by +this value before being passed to {\tt encodeField}. + +\begin{code} +normalised :: RealFloat a => RawFloat -> a +normalised f = encodeFloat fraction exp' where + Significand sig = rawSignificand f + Exponent exp' = unbiased - sigWidth + + fraction = sig + (1 `bitShiftL` rawSignificandWidth f) + + sigWidth = fromIntegral $ rawSignificandWidth f + unbiased = unbias (rawExponent f) (rawExponentWidth f) +\end{code} + +For denormalised values, the implied {\tt 1} bit is the least-significant +bit of the exponent. + +\begin{code} +denormalised :: RealFloat a => RawFloat -> a +denormalised f = encodeFloat sig exp' where + Significand sig = rawSignificand f + Exponent exp' = unbiased - sigWidth + 1 + + sigWidth = fromIntegral $ rawSignificandWidth f + unbiased = unbias (rawExponent f) (rawExponentWidth f) +\end{code} + +By composing {\tt splitBytes} and {\tt merge}, the absolute value of the +float is calculated. Before being returned to the calling function, it +must be signed appropriately. + +\begin{code} +getFloat :: (Read a, RealFloat a) => ByteCount + -> ([Word8] -> RawFloat) -> Get a +getFloat (ByteCount width) parser = do + raw <- fmap (parser . B.unpack) $ getByteString width + let absFloat = merge raw + return $ case rawSign raw of + Positive -> absFloat + Negative -> -absFloat +\end{code} + +\section{Serialising} + +\subsection{Public interface} + +\begin{code} +putFloat32be :: Float -> Put +putFloat32be = putFloat (ByteCount 4) id +\end{code} + +\begin{code} +putFloat32le :: Float -> Put +putFloat32le = putFloat (ByteCount 4) reverse +\end{code} + +\begin{code} +putFloat64be :: Double -> Put +putFloat64be = putFloat (ByteCount 8) id +\end{code} + +\begin{code} +putFloat64le :: Double -> Put +putFloat64le = putFloat (ByteCount 8) reverse +\end{code} + +\subsection{Implementation} + +Serialisation is similar to parsing. First, the float is converted to +a structure representing raw bitfields. The values returned from +{\tt decodeFloat} are clamped to their expected lengths before being +stored in the {\tt RawFloat}. + +\begin{code} +splitFloat :: RealFloat a => ByteCount -> a -> RawFloat +splitFloat width x = raw where + raw = RawFloat width sign clampedExp clampedSig expWidth sigWidth + sign = if isNegativeNaN x || isNegativeZero x || x < 0 + then Negative + else Positive + clampedExp = clamp expWidth exp' + clampedSig = clamp sigWidth sig + (exp', sig) = case (dFraction, dExponent, biasedExp) of + (0, 0, _) -> (0, 0) + (_, _, 0) -> (0, Significand $ truncatedSig + 1) + _ -> (biasedExp, Significand truncatedSig) + expWidth = exponentWidth $ bitCount width + sigWidth = bitCount width - expWidth - 1 -- 1 for sign bit + + (dFraction, dExponent) = decodeFloat x + + rawExp = Exponent $ dExponent + fromIntegral sigWidth + biasedExp = bias rawExp expWidth + truncatedSig = abs dFraction - (1 `bitShiftL` sigWidth) +\end{code} + +Then, the {\tt RawFloat} is converted to a list of bytes by mashing all +the fields together into an {\tt Integer}, and chopping up that integer +in 8-bit blocks. + +\begin{code} +rawToBytes :: RawFloat -> [Word8] +rawToBytes raw = integerToBytes mashed width where + RawFloat width sign exp' sig expWidth sigWidth = raw + sign' :: Word8 + sign' = case sign of + Positive -> 0 + Negative -> 1 + mashed = mashBits sig sigWidth . + mashBits exp' expWidth . + mashBits sign' 1 $ 0 +\end{code} + +{\tt clamp}, given a maximum bit count and a value, will strip any 1-bits +in positions above the count. + +\begin{code} +clamp :: Bits a => BitCount -> a -> a +clamp = (.&.) . mask where + mask 1 = 1 + mask n | n > 1 = (mask (n - 1) `shiftL` 1) + 1 + mask _ = undefined +\end{code} + +For merging the fields, just shift the starting integer over a bit and +then \textsc{or} it with the next value. The weird parameter order allows +easy composition. + +\begin{code} +mashBits :: (Bits a, Integral a) => a -> BitCount -> Integer -> Integer +mashBits _ 0 x = x +mashBits y n x = (x `bitShiftL` n) .|. fromIntegral y +\end{code} + +Given an integer, read it in 255-block increments starting from the LSB. +Each increment is converted to a byte and added to the final list. + +\begin{code} +integerToBytes :: Integer -> ByteCount -> [Word8] +integerToBytes _ 0 = [] +integerToBytes x n = bytes where + bytes = integerToBytes (x `shiftR` 8) (n - 1) ++ [step] + step = fromIntegral x .&. 0xFF +\end{code} + +Finally, the raw parsing is wrapped up in {\tt Put}. The second parameter +allows the same code paths to be used for little- and big-endian +serialisation. + +\begin{code} +putFloat :: (RealFloat a) => ByteCount -> ([Word8] -> [Word8]) -> a -> Put +putFloat width f x = putByteString $ B.pack bytes where + bytes = f . rawToBytes . splitFloat width $ x +\end{code} + +\section{Raw float components} + +Information about the raw bit patterns in the float is stored in +{\tt RawFloat}, so they don't have to be passed around to the various +format cases. The exponent should be biased, and the significand +shouldn't have it's implied MSB (if applicable). + +\begin{code} +data RawFloat = RawFloat + { rawWidth :: ByteCount + , rawSign :: Sign + , rawExponent :: Exponent + , rawSignificand :: Significand + , rawExponentWidth :: BitCount + , rawSignificandWidth :: BitCount + } + deriving (Show) +\end{code} + +\section{Exponents} + +Calculate the proper size of the exponent field, in bits, given the +size of the full structure. + +\begin{code} +exponentWidth :: BitCount -> BitCount +exponentWidth k + | k == 16 = 5 + | k == 32 = 8 + | k `mod` 32 == 0 = ceiling (4 * logBase 2 (fromIntegral k)) - 13 + | otherwise = error "Invalid length of floating-point value" +\end{code} + +\begin{code} +bias :: Exponent -> BitCount -> Exponent +bias e eWidth = e - (1 - (2 `pow` (eWidth - 1))) +\end{code} + +\begin{code} +unbias :: Exponent -> BitCount -> Exponent +unbias e eWidth = e + 1 - (2 `pow` (eWidth - 1)) +\end{code} + +\section{Byte and bit counting} + +\begin{code} +data Sign = Positive | Negative + deriving (Show) + +newtype Exponent = Exponent Int + deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits) + +newtype Significand = Significand Integer + deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits) + +newtype BitCount = BitCount Int + deriving (Show, Eq, Num, Ord, Real, Enum, Integral) + +newtype ByteCount = ByteCount Int + deriving (Show, Eq, Num, Ord, Real, Enum, Integral) + +bitCount :: ByteCount -> BitCount +bitCount (ByteCount x) = BitCount (x * 8) + +bitsInWord8 :: [Word8] -> BitCount +bitsInWord8 = bitCount . ByteCount . length + +bitShiftL :: (Bits a) => a -> BitCount -> a +bitShiftL x (BitCount n) = shiftL x n + +bitShiftR :: (Bits a) => a -> BitCount -> a +bitShiftR x (BitCount n) = shiftR x n +\end{code} + +\section{Utility} + +Considering a byte list as a sequence of bits, slice it from start +inclusive to end exclusive, and return the resulting bit sequence as an +integer. + +\begin{code} +bitSlice :: [Word8] -> BitCount -> BitCount -> Integer +bitSlice bs = sliceInt (foldl' step 0 bs) bitCount' where + step acc w = shiftL acc 8 + fromIntegral w + bitCount' = bitsInWord8 bs +\end{code} + +Slice a single integer by start and end bit location + +\begin{code} +sliceInt :: Integer -> BitCount -> BitCount -> BitCount -> Integer +sliceInt x xBitCount s e = fromIntegral sliced where + sliced = (x .&. startMask) `bitShiftR` (xBitCount - e) + startMask = n1Bits (xBitCount - s) + n1Bits n = (2 `pow` n) - 1 +\end{code} + +Integral version of {\tt (**)} + +\begin{code} +pow :: (Integral a, Integral b, Integral c) => a -> b -> c +pow b e = floor $ fromIntegral b ** fromIntegral e +\end{code} + +Detect whether a float is {\tt $-$NaN} + +\begin{code} +isNegativeNaN :: RealFloat a => a -> Bool +isNegativeNaN x = isNaN x && (floor x > 0) +\end{code} diff --git a/data-binary-ieee754.cabal b/data-binary-ieee754.cabal --- a/data-binary-ieee754.cabal +++ b/data-binary-ieee754.cabal @@ -1,6 +1,6 @@ name: data-binary-ieee754 -version: 0.3 -synopsis: Parser/Serializer for IEEE-754 floating-point values +version: 0.4 +synopsis: Parser/Serialiser for IEEE-754 floating-point values description: Convert Float and Decimal values to/from raw octets. license: GPL license-file: License.txt @@ -13,8 +13,8 @@ bug-reports: mailto:jmillikin@gmail.com source-repository head - type: bzr - location: bzr+ssh://bazaar.launchpad.net/~jmillikin/%2Bjunk/data-binary-ieee754/ + type: darcs + location: http://patch-tag.com/r/data-binary-ieee754/pullrepo library build-depends: base >=3 && < 5, binary, bytestring