{-# LANGUAGE FlexibleInstances #-}
module Numeric.Decimal.Encoding (
Decimal32
, Decimal64
, Decimal128
, Pdecimal32
, Pdecimal64
, Pdecimal128
, Format
, Parameters
, K32
, K64
, K128
, KPlus32
, KTimes2
, DecimalCoefficient
, BinaryCoefficient
) where
import Prelude hiding (exponent)
import Data.Binary (Binary(get, put), Get)
import Data.Binary.Bits.Get (BitGet, getBool, getWord8, getWord16be, runBitGet)
import Data.Binary.Bits.Put (BitPut, putBool, putWord8, putWord16be, runBitPut)
import Data.Bits (bit, shiftL, shiftR, testBit, (.&.), (.|.))
import Data.Word (Word8, Word16)
import Numeric.Decimal.Number
import Numeric.Decimal.Precision
type Decimal32 = ExtendedDecimal Pdecimal32
type Decimal64 = ExtendedDecimal Pdecimal64
type Decimal128 = ExtendedDecimal Pdecimal128
type Pdecimal32 = Format K32 DecimalCoefficient
type Pdecimal64 = Format K64 DecimalCoefficient
type Pdecimal128 = Format K128 DecimalCoefficient
class Parameters k where
paramK32 :: k -> Int
paramP :: Parameters k => k -> Int
paramP k = 9 * paramK32 k - 2
paramEmax :: Parameters k => k -> Exponent
paramEmax k = 3 * 2^(paramK32 k * 2 + 3)
paramBias :: Parameters k => k -> Exponent
paramBias k = paramEmax k + fromIntegral (paramP k - 2)
paramW :: Parameters k => k -> Int
paramW k = paramK32 k * 2 + 4
paramT10 :: Parameters k => k -> Int
paramT10 k = 3 * paramK32 k - 1
data K32
instance Parameters K32 where
paramK32 _ = 1
type K64 = KPlus32 K32
type K128 = KTimes2 K64
data KPlus32 k
instance Parameters k => Parameters (KPlus32 k) where
paramK32 t = paramK32 (minus32 t) + 1
where minus32 :: KPlus32 k -> k
minus32 = undefined
data KTimes2 k
instance Parameters k => Parameters (KTimes2 k) where
paramK32 t = paramK32 (div2 t) * 2
where div2 :: KTimes2 k -> k
div2 = undefined
class CoefficientEncoding c
data DecimalCoefficient
instance CoefficientEncoding DecimalCoefficient
data BinaryCoefficient
instance CoefficientEncoding BinaryCoefficient
data Format k c
formatK :: Format k c -> k
formatK = undefined
instance Parameters k => Precision (Format k c) where
precision = Just . paramP . formatK
eMax = Just . paramEmax . formatK
instance Parameters k => FinitePrecision (Format k c)
instance Parameters k => Binary (Decimal (Format k DecimalCoefficient) r) where
put d = runBitPut $ putDecimal (paramW k) (paramT10 k) (paramBias k) d
where k = formatK (decimalFormat d)
decimalFormat :: Decimal (Format k c) r -> Format k c
decimalFormat = undefined
get = result
where result = runBitGet $ getDecimal (paramW k) (paramT10 k) (paramBias k)
k = formatK (getDecimalFormat result)
getDecimalFormat :: Get (Decimal (Format k c) r) -> Format k c
getDecimalFormat = undefined
dpd2bcd :: Word16 -> (Word8, Word8, Word8)
dpd2bcd dpd = case mask 0 0xe of
0xe -> case mask 4 0x6 of
0x6 -> ( c7, f4, i0)
0x4 -> (a9b8c7, f4, i0)
0x2 -> ( c7, d9e8f4, i0)
_ -> ( c7, f4, g9h8i0)
0xc -> ( c7, d6e5f4, g9h8i0)
0xa -> (a9b8c7, f4, g6h5i0)
0x8 -> (a9b8c7, d6e5f4, i0)
_ -> (a9b8c7, d6e5f4, g2h1i0)
where a9b8c7 = mask 7 7
d6e5f4 = mask 4 7
d9e8f4 = mask 7 6 .|. mask 4 1
g2h1i0 = mask 0 7
g6h5i0 = mask 4 6 .|. mask 0 1
g9h8i0 = mask 7 6 .|. mask 0 1
i0 = 8 .|. mask 0 1
f4 = 8 .|. mask 4 1
c7 = 8 .|. mask 7 1
mask :: Int -> Word8 -> Word8
mask s m = fromIntegral (shiftR dpd s) .&. m
bcd2dpd :: Word8 -> Word8 -> Word8 -> Word16
bcd2dpd d2 d1 d0 = case (d2 < 8, d1 < 8, d0 < 8) of
(True , True , True ) -> a9b8c7 .|. d6e5f4 .|. g2h1i0
(True , True , False) -> a9b8c7 .|. d6e5f4 .|. 0x08 .|. i0
(True , False, True ) -> a9b8c7 .|. g6h5 .|. f4 .|. 0x0a .|. i0
(False, True , True ) -> g9h8 .|. c7 .|. d6e5f4 .|. 0x0c .|. i0
(False, False, True ) -> g9h8 .|. c7 .|. f4 .|. 0x0e .|. i0
(False, True , False) -> d9e8 .|. c7 .|. f4 .|. 0x2e .|. i0
(True , False, False) -> a9b8c7 .|. f4 .|. 0x4e .|. i0
(False, False, False) -> c7 .|. f4 .|. 0x6e .|. i0
where a9b8c7 = isolate d2 7 7
c7 = isolate d2 1 7
d6e5f4 = isolate d1 7 4
d9e8 = isolate d1 6 7
f4 = isolate d1 1 4
g2h1i0 = isolate d0 7 0
g6h5 = isolate d0 6 4
g9h8 = isolate d0 6 7
i0 = isolate d0 1 0
isolate :: Word8 -> Word8 -> Int -> Word16
isolate d m = shiftL (fromIntegral $ d .&. m)
data CombinationField = Finite { exponentMSBs :: Word8
, coefficientMSD :: Word8 }
| Infinity
| NotANumber
getCommon :: BitGet (Sign, CombinationField)
getCommon = do
sign <- toEnum . fromEnum <$> getBool
bits <- getWord8 5
let cf = case bits of
0x1e -> Infinity
0x1f -> NotANumber
_ -> let ab = shiftR bits 3 in case ab of
0x03 -> Finite { exponentMSBs = shiftR bits 1 .&. 0x03
, coefficientMSD = 0x08 .|. (bits .&. 0x01)
}
_ -> Finite { exponentMSBs = ab
, coefficientMSD = bits .&. 0x07
}
return (sign, cf)
putCommon :: Sign -> CombinationField -> BitPut ()
putCommon sign cf = do
putBool (toEnum . fromEnum $ sign)
let bits = case cf of
Finite { exponentMSBs = msbs, coefficientMSD = msd }
| msd < 8 -> shiftL msbs 3 .|. msd
| otherwise -> 0x18 .|. shiftL msbs 1 .|. (msd .&. 0x01)
Infinity -> 0x1e
NotANumber -> 0x1f
putWord8 5 bits
getCoefficient :: CombinationField -> Int -> BitGet Coefficient
getCoefficient = getCoefficient' . getMSD
where getCoefficient' :: Coefficient -> Int -> BitGet Coefficient
getCoefficient' ic 0 = return ic
getCoefficient' ic n = do
(a, b, c) <- dpd2bcd <$> getWord16be 10
let v = fromIntegral a * 100 + fromIntegral b * 10 + fromIntegral c
getCoefficient' (ic * 1000 + v) (pred n)
getMSD :: CombinationField -> Coefficient
getMSD Finite { coefficientMSD = msd } = fromIntegral msd
getMSD _ = 0
getDecimal :: Int -> Int -> Exponent -> BitGet (Decimal p r)
getDecimal ecbits cclen bias = do
(sign, cf) <- getCommon
ec <- getWord16be ecbits
coefficient <- getCoefficient cf cclen
return $ case cf of
Finite { exponentMSBs = msbs } ->
let ee = shiftL (fromIntegral msbs) ecbits .|. fromIntegral ec
in Num { sign = sign, coefficient = coefficient, exponent = ee - bias }
Infinity -> Inf { sign = sign }
NotANumber ->
let s = testBit ec (ecbits - 1)
in NaN { sign = sign, signaling = s, payload = coefficient }
putDecimal :: Int -> Int -> Exponent -> Decimal p r -> BitPut ()
putDecimal ecbits cclen bias x = do
let msd : cc = digits x
(cf, ee) = case x of
Num { exponent = e } ->
let cf = Finite { exponentMSBs = fromIntegral (shiftR ee ecbits)
, coefficientMSD = msd
}
in (cf, fromIntegral $ e + bias)
Inf{} -> (Infinity, 0)
NaN { signaling = s } -> (NotANumber, if s then bit (ecbits - 1) else 0)
putCommon (sign x) cf
putWord16be ecbits (ee .&. (bit ecbits - 1))
putDigits cc
where digits :: Decimal p r -> [Word8]
digits x = let ds = case x of
Num { coefficient = c } -> digits' c
NaN { payload = p } -> digits' p
Inf { } -> []
in replicate (1 + cclen * 3 - length ds) 0 ++ ds
digits' :: Coefficient -> [Word8]
digits' = go []
where go ds 0 = ds
go ds c = let (q, r) = c `quotRem` 10
in go (fromIntegral r : ds) q
putDigits :: [Word8] -> BitPut ()
putDigits (a : b : c : rest) = do
putWord16be 10 (bcd2dpd a b c)
putDigits rest
putDigits [] = return ()
putDigits _ = error "putDigits: invalid # digits"