module Data.Fixed.Binary
( div'
, mod'
, divMod'
, Fixed ()
, SuperTypeable (..)
, HasResolution (..)
, E0, E1, E2, E4, E8, E10, E16, E20, E30, E32, E64
, S, P
, fixedRadix, fixedSize, fromRealFloat
, (:+), (*.)
, (:-), (/.)
) where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.Bits
import Data.Fixed (div', mod', divMod')
import Data.Function
import Data.Int
import Data.List
import Data.Maybe
import Data.Ratio
import Data.Typeable
import Data.Word
import Text.Read
import qualified Text.Read.Lex as L
import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Generic.Mutable as VGM
import qualified Data.Vector.Unboxed as VU
newtype Fixed r a = Fixed { unFixed :: a }
deriving (Enum, Eq, Ord, Typeable)
newtype instance VU.MVector s (Fixed r a) = MVFixed { unMVFixed :: VU.MVector s a }
newtype instance VU.Vector (Fixed r a) = VFixed { unVFixed :: VU.Vector a }
instance VGM.MVector VU.MVector a => VGM.MVector VU.MVector (Fixed r a) where
basicLength = VGM.basicLength . unMVFixed
basicUnsafeSlice i n = MVFixed . VGM.basicUnsafeSlice i n . unMVFixed
basicOverlaps = VGM.basicOverlaps `on` unMVFixed
basicUnsafeNew = liftM MVFixed . VGM.basicUnsafeNew
basicUnsafeReplicate n = liftM MVFixed . VGM.basicUnsafeReplicate n . unFixed
basicUnsafeRead (MVFixed mv) = liftM Fixed . VGM.basicUnsafeRead mv
basicUnsafeWrite (MVFixed mv) i = VGM.basicUnsafeWrite mv i . unFixed
basicClear = VGM.basicClear . unMVFixed
basicSet (MVFixed mv) = VGM.basicSet mv . unFixed
basicUnsafeCopy = VGM.basicUnsafeCopy `on` unMVFixed
basicUnsafeGrow (MVFixed mv) = liftM MVFixed . VGM.basicUnsafeGrow mv
instance VG.Vector VU.Vector a => VG.Vector VU.Vector (Fixed r a) where
basicUnsafeFreeze = liftM VFixed . VG.basicUnsafeFreeze . unMVFixed
basicUnsafeThaw = liftM MVFixed . VG.basicUnsafeThaw . unVFixed
basicLength = VG.basicLength . unVFixed
basicUnsafeSlice i n = VFixed . VG.basicUnsafeSlice i n . unVFixed
basicUnsafeIndexM (VFixed v) = liftM Fixed . VG.basicUnsafeIndexM v
basicUnsafeCopy (MVFixed mv) = VG.basicUnsafeCopy mv . unVFixed
elemseq (VFixed v) = VG.elemseq v . unFixed
instance VU.Unbox a => VU.Unbox (Fixed r a)
inFixed :: (a -> b) -> (Fixed r a -> Fixed s b)
inFixed = (Fixed .) . (. unFixed)
inFixed2 :: (a -> b -> c) -> (Fixed r a -> Fixed s b -> Fixed t c)
inFixed2 = (inFixed .) . (. unFixed)
class HasResolution r where
resolution :: Num a => Fixed r a -> Int
withResolution :: (HasResolution r, Num a) => (Int -> Fixed r a) -> Fixed r a
withResolution f = withType (f . resolution)
where withType :: (Fixed r a -> Fixed r a) -> Fixed r a
withType g = g undefined
readNumber :: Num a => (L.Lexeme -> ReadPrec a) -> ReadPrec a
readNumber convert =
parens
( do x <- lexP
case x of
L.Symbol "-" -> do y <- lexP
n <- convert y
return (negate n)
_ -> convert x
)
convertFrac :: Fractional a => L.Lexeme -> ReadPrec a
convertFrac (L.Int i) = return (fromInteger i)
convertFrac (L.Rat r) = return (fromRational r)
convertFrac _ = pfail
instance ( HasResolution r, Bits a, Bits (Super a), Integral a
, Integral (Super a), SuperTypeable a) => Read (Fixed r a) where
readPrec = readNumber convertFrac
instance ( HasResolution r, Bits a, Bits (Super a), Integral a
, Integral (Super a), SuperTypeable a) => Show (Fixed r a) where
show (properFraction -> (i, f)) =
show (i :: Integer) ++ "." ++ (uncurry pad . second (show . numerator) .
fromJust . find ((==1) . denominator . snd) .
iterate (succ *** (*10)) . (,) 0 $
toRational f)
where pad n str = replicate (n length str) '0' ++ str
instance ( HasResolution r, Bits a, Bits (Super a), Integral a, Num (Super a)
, Integral (Super a), SuperTypeable a) => Num (Fixed r a) where
(+) = inFixed2 (+)
() = inFixed2 ()
Fixed x * Fixed y = withResolution $ Fixed . subCast . shiftR (superCast x * superCast y)
negate = inFixed negate
abs = inFixed abs
signum (Fixed x) = withResolution $ \s -> Fixed $ signum x `shiftL` s
fromInteger i = withResolution $ Fixed . shiftL (fromInteger i)
instance ( HasResolution r, Bits a, Bits (Super a), Integral a
, Integral (Super a), SuperTypeable a) => Real (Fixed r a) where
toRational x = toRational (unFixed x) / toRational (2 ^ resolution x :: Integer)
instance ( HasResolution r, Bits a, Bits (Super a), Integral a
, Integral (Super a), SuperTypeable a) => Fractional (Fixed r a) where
a / b = Fixed . subCast $ (superCast (unFixed a) `shiftL` resolution a) `div` superCast (unFixed b)
recip x = Fixed . subCast $ (1 `shiftL` (2 * resolution x)) `div` superCast (unFixed x)
fromRational r = withResolution $ \s ->
Fixed . floor $ (numerator r `shiftL` s) % denominator r
instance ( HasResolution r, Bits a, Bits (Super a), Integral a
, Integral (Super a), SuperTypeable a) => RealFrac (Fixed r a) where
properFraction a = let i = truncate a in (i, a fromIntegral i)
truncate = truncate . toRational
round = round . toRational
ceiling = ceiling . toRational
floor = floor . toRational
fixedRadix :: (Integral a, Num b) => Fixed r a -> Fixed r b
fixedRadix = inFixed fromIntegral
fixedSize :: (HasResolution r, HasResolution s, Bits a) => Fixed r a -> Fixed s a
fixedSize x = withResolution $ \s -> Fixed $ unFixed x `shift` (s resolution x)
(*.) :: (Num (Super a), SuperTypeable a) => Fixed r a -> Fixed s a -> Fixed (r :+ s) a
(*.) = inFixed2 ((fmap subCast . (*)) `on` superCast)
(/.) :: Integral a => Fixed r a -> Fixed s a -> Fixed (r :- s) a
(/.) = inFixed2 div
toRealFloat :: (HasResolution r, Integral a, RealFloat b) => Fixed r a -> b
toRealFloat = liftA2 encodeFloat (fromIntegral . unFixed) (negate . resolution)
fromRealFloat :: (RealFloat a, HasResolution r, Num b) => a -> Fixed r b
fromRealFloat x = let (s,e) = decodeFloat x
in withResolution $ \t -> Fixed . fromIntegral $ shiftBaseExp s (floatRadix x) (t + e)
shiftBaseExp :: Integer -> Integer -> Int -> Integer
shiftBaseExp x b e | e < 0 = x `div` (b ^ negate e)
| otherwise = x * (b ^ e)
data E0
data S n
type family a :+ b
type instance E0 :+ b = b
type instance S a :+ b = S (a :+ b)
type family a :- b
type instance a :- E0 = a
type instance S a :- S b = a :- b
type family P a
type instance P (S a) = a
type E1 = S E0
type E2 = E1 :+ E1
type E4 = E2 :+ E2
type E8 = E4 :+ E4
type E10 = S (S E8)
type E16 = E8 :+ E8
type E20 = E10 :+ E10
type E30 = E20 :+ E10
type E32 = E16 :+ E16
type E64 = E32 :+ E32
instance HasResolution n => HasResolution (S n) where
resolution = succ . resolution' undefined
where resolution' :: (HasResolution n, Num a) =>
Fixed n a -> Fixed (S n) a -> Int
resolution' dummy = const $ resolution dummy
instance HasResolution E0 where
resolution = const 0
class SuperTypeable a where
type Super a
superCast :: a -> Super a
subCast :: Super a -> a
instance (SuperTypeable a, Num a, Num (Super a), Integral a, Integral (Super a)) =>
SuperTypeable (Fixed r a) where
type Super (Fixed r a) = Fixed r (Super a)
superCast = fixedRadix
subCast = fixedRadix
instance SuperTypeable Word8 where
type Super Word8 = Word16
superCast = fromIntegral
subCast = fromIntegral
instance SuperTypeable Word16 where
type Super Word16 = Word32
superCast = fromIntegral
subCast = fromIntegral
instance SuperTypeable Word32 where
type Super Word32 = Word64
superCast = fromIntegral
subCast = fromIntegral
instance SuperTypeable Word64 where
type Super Word64 = Integer
superCast = fromIntegral
subCast = fromIntegral
instance SuperTypeable Word where
#ifdef i386_HOST_ARCH
type Super Word = Word64
#else
type Super Word = Integer
#endif
superCast = fromIntegral
subCast = fromIntegral
instance SuperTypeable Int8 where
type Super Int8 = Int16
superCast = fromIntegral
subCast = fromIntegral
instance SuperTypeable Int16 where
type Super Int16 = Int32
superCast = fromIntegral
subCast = fromIntegral
instance SuperTypeable Int32 where
type Super Int32 = Int64
superCast = fromIntegral
subCast = fromIntegral
instance SuperTypeable Int64 where
type Super Int64 = Integer
superCast = fromIntegral
subCast = fromIntegral
instance SuperTypeable Int where
#ifdef i386_HOST_ARCH
type Super Int = Int64
#else
type Super Int = Integer
#endif
superCast = fromIntegral
subCast = fromIntegral
instance SuperTypeable Integer where
type Super Integer = Integer
superCast = id
subCast = id