Fixed.hs

{-# LANGUAGE BangPatterns, DeriveDataTypeable, Rank2Types, MonoLocalBinds #-}
{- |
Module      :  Numeric.VariablePrecision.Fixed
Copyright   :  (c) Claude Heiland-Allen 2012
License     :  BSD3

Maintainer  :  claude@mathr.co.uk
Stability   :  unstable
Portability :  BangPatterns, DeriveDataTypeable, Rank2Types, MonoLocalBinds

Variable precision software fixed point based on @Integer@.

Accuracy has not been extensively verified.

Example:

> reifyPrecision 1000 $ \prec ->
>    show $ auto (355 :: VFixed N15) / 113 `atPrecision` prec

-}
module Numeric.VariablePrecision.Fixed
  ( VFixed()
  , DFixed(..)
  , toDFixed
  , fromDFixed
  , withDFixed
  ) where

import Data.Data (Data())
import Data.Typeable (Typeable())

import Data.Bits (bit, shiftL, shiftR)
import Data.Ratio ((%), numerator, denominator)

import Numeric (readSigned, readFloat)
import Text.FShow.Raw (BinDecode(..), binDecFormat, FormatStyle(Generic))

import Numeric.VariablePrecision.Precision
import Numeric.VariablePrecision.Precision.Reify


-- | A software implementation of fixed point arithmetic, using an
--   'Integer' adjusted to @p@ bits after the binary point.
newtype VFixed p = F Integer
  deriving (Data, Typeable)


instance HasPrecision VFixed where
  -- default implementation


instance VariablePrecision VFixed where
  adjustPrecision = self
    where
      self (F x)
        | s > 0 = F (x `shiftL` s)
        | s < 0 = F (x `shiftR` negate s)
        | otherwise = F x
      s = naturalNumberAsInt (undefined `asPrecOut` self) - naturalNumberAsInt (undefined `asPrecIn` self)
      asPrecIn :: p -> (t p -> t q) -> p
      asPrecIn _ _ = undefined
      asPrecOut :: q -> (t p -> t q) -> q
      asPrecOut _ _ = undefined


instance NaturalNumber p => BinDecode (VFixed p) where
  decode l@(F x) = (x, negate . fromIntegral . precision $ l)
  showDigits l = 2 + floor ((1 + fromIntegral (precision l)) * logBase 10 2 :: Double)


instance NaturalNumber p => Show (VFixed p) where

  show = binDecFormat (Generic (Just (-5, 5))) Nothing


instance NaturalNumber p => Read (VFixed p) where

  readsPrec _ = readSigned readFloat -- FIXME ignores precedence?


instance NaturalNumber p => Eq (VFixed p) where F x == F y = x == y


instance NaturalNumber p => Ord (VFixed p) where F x `compare` F y = x `compare` y


instance NaturalNumber p => Num (VFixed p) where
  F x + F y = F $  x + y
  F x - F y = F $  x - y
  l@(F x) * F y = F $ (x * y) `shiftR` fromIntegral (precision l)
  negate (F x) = F (negate x)
  abs (F x) = F (abs x)
  signum (F x)
    | x > 0 = 1
    | x < 0 = -1
    | otherwise = 0
  fromInteger x = let r = F (x `shiftL` fromIntegral (precision r)) in r


instance NaturalNumber p => Fractional (VFixed p) where
  l@(F x) / F y = F ((x `shiftL` fromIntegral (precision l)) `quot` y)
  fromRational x =
    let r = F ((numerator x `shiftL` fromIntegral (precision r)) `quot` denominator x) in r


instance NaturalNumber p => Real (VFixed p) where
  toRational l@(F x) = x % (bit . fromIntegral . precision) l


instance NaturalNumber p => RealFrac (VFixed p) where
  properFraction f@(F x) = w (fromIntegral n, g)
    where
      w (a, b)
        | a < 0 && b /= 0 = (a + 1, b - 1)
        | otherwise = (a, b)
      n = x `shiftR` p
      p = fromIntegral (precision f)
      g = F (x - (n `shiftL` p))


-- | A concrete format suitable for storage or wire transmission.
data DFixed = DFixed{ dxPrecision :: !Word, dxMantissa :: !Integer }
  deriving (Eq, Ord, Read, Show, Data, Typeable)


-- | Freeze a 'VFixed'.
toDFixed :: NaturalNumber p => VFixed p -> DFixed
toDFixed f@(F m) = DFixed (precision f) m


-- | Thaw a 'DFixed'.  Results in 'Nothing' on precision mismatch.
fromDFixed :: NaturalNumber p => DFixed -> Maybe (VFixed p)
fromDFixed d@(DFixed _ m)
  | dxPrecision d == precision result = Just result
  | otherwise = Nothing
  where
    result = F m  --  -XMonoLocalBinds


-- | Thaw a 'DFixed' to its natural precision.
withDFixed :: DFixed -> (forall p . NaturalNumber p => VFixed p -> r) -> r
withDFixed (DFixed p m) f = reifyPrecision p $ \prec -> f (F m `atPrecision` prec)