module Data.Number.ER.Real.Base.Rational
(
ExtendedRational(..)
)
where
import Prelude hiding (isNaN)
import qualified Data.Number.ER.Real.Base as B
import qualified Data.Number.ER.ExtendedInteger as EI
import Data.Number.ER.PlusMinus
import Data.Number.ER.Misc
import Data.Ratio
import Data.Typeable
import Data.Generics.Basics
import Data.Binary
data ExtendedRational =
NaN
| Infinity PlusMinus
| Finite Rational
deriving (Typeable, Data)
instance Binary ExtendedRational where
put NaN = putWord8 0
put (Infinity a) = putWord8 1 >> put a
put (Finite a) = putWord8 2 >> put a
get = do
tag_ <- getWord8
case tag_ of
0 -> return NaN
1 -> get >>= \a -> return (Infinity a)
2 -> get >>= \a -> return (Finite a)
_ -> fail "no parse"
eratSign :: ExtendedRational -> PlusMinus
eratSign NaN = error "ExtendedRational: eratSign: NaN"
eratSign (Infinity s) = s
eratSign (Finite r)
| r < 0 = Minus
| otherwise = Plus
liftToERational1 ::
(Rational -> Rational) ->
(ExtendedRational -> ExtendedRational)
liftToERational1 f (Finite r) =
Finite (f r)
liftToERational2 ::
(Rational -> Rational -> Rational) ->
(ExtendedRational -> ExtendedRational -> ExtendedRational)
liftToERational2 f (Finite r1) (Finite r2) =
Finite (f r1 r2)
instance Show ExtendedRational
where
show = showERational 6 True False
showERational numDigits _showGran showComponents =
showER
where
showER NaN = "NaN"
showER (Infinity pm) =
show pm ++ "oo"
showER (Finite r) | r == 0 =
"0"
showER (Finite r) =
decimal
++ (if showComponents then components else "")
where
components = "{" ++ show r ++ "}"
decimal =
show pm
++ show digit1 ++ "." ++ (concat $ map show $ take numDigits digits)
++ "E" ++ show dexp
pm | r < 0 = Minus
| otherwise = Plus
dexp = dexpBound zerosCount
digit1 : digits =
drop zerosCount preDigits
dexpBound =
2 + (intLogUp 10 num) (intLogUp 10 dnm)
num = numerator absr
dnm = denominator absr
absr = abs r
(zerosCount, preDigits) =
getDigits 0 $ absr / (10 ^^ dexpBound)
getDigits prevZeros rr
| digit == 0 = (zerosCount, digit : digits)
| otherwise = (prevZeros, digit : digits)
where
digit :: Integer
digit = truncate rr
(zerosCount, digits) =
getDigits zerosNow ((rr (fromInteger digit)) * 10)
zerosNow
| digit == 0 = prevZeros + 1
| otherwise = 0
instance Eq ExtendedRational where
NaN == _ =
False
_ == NaN =
False
(Infinity pm1) == (Infinity pm2) = (pm1 == pm2)
(Finite r1) == (Finite r2) = r1 == r2
_ == _ = False
isNaN NaN = True
isNaN _ = False
instance Ord ExtendedRational where
compare _ NaN =
error "comparing NaN - aborting"
compare NaN _ =
error "comparing NaN - aborting"
compare (Infinity pm1) (Infinity pm2) =
compare pm1 pm2
compare _ (Infinity Plus) = LT
compare _ (Infinity Minus) = GT
compare (Infinity Plus) _ = GT
compare (Infinity Minus) _ = LT
compare (Finite r1) (Finite r2) = compare r1 r2
instance Num ExtendedRational where
fromInteger n = Finite (fromInteger n)
abs NaN = NaN
abs (Infinity _) = Infinity Plus
abs r = liftToERational1 abs r
signum NaN = NaN
signum (Infinity Plus) = 1
signum (Infinity Minus) = 1
signum r = liftToERational1 signum r
negate NaN = NaN
negate (Infinity s) = Infinity (signNeg s)
negate (Finite r) = Finite (negate r)
NaN + _ = NaN
_ + NaN = NaN
(Infinity Plus) + (Infinity Minus) = NaN
(Infinity Minus) + (Infinity Plus) = NaN
(Infinity s) + _ = Infinity s
_ + (Infinity s) = Infinity s
r1 + r2 = liftToERational2 (+) r1 r2
NaN * _ = NaN
_ * NaN = NaN
(Infinity _) * (Finite r) | r == 0 = NaN
(Finite r) * (Infinity _) | r == 0 = NaN
r * (Infinity s) = Infinity $ signMult s (eratSign r)
(Infinity s) * r = Infinity $ signMult s (eratSign r)
r1 * r2 = liftToERational2 (*) r1 r2
instance Fractional ExtendedRational where
fromRational rat = Finite rat
recip NaN = NaN
recip (Infinity s) = 0
recip (Finite r)
| r == 0 = Infinity Plus
| otherwise = (Finite $ recip r)
instance Real ExtendedRational where
toRational (Finite r) = r
toRational r = error $ "cannot convert " ++ show r ++ " to Rational"
instance RealFrac ExtendedRational where
properFraction (Finite r) =
(a, Finite b)
where
(a,b) = properFraction r
properFraction r =
error $ "ExtendedRational: RealFrac: no integral part in " ++ show r
instance B.ERRealBase ExtendedRational
where
defaultGranularity _ = 10
getApproxBinaryLog (Finite r)
| r == 0 =
EI.MinusInfinity
| otherwise =
(intLogUp 2 (abs $ numerator $ r))
(intLogUp 2 (abs $ denominator $ r))
getApproxBinaryLog (Infinity _) = EI.PlusInfinity
getApproxBinaryLog (NaN) = error "RationalBase: getApproxBinaryLog: NaN"
getGranularity _ = 0
setMinGranularity _ = id
setGranularity _ = id
getMaxRounding _ = 0
isERNaN = isNaN
erNaN = NaN
isPlusInfinity (Infinity Plus) = True
isPlusInfinity _ = False
plusInfinity = Infinity Plus
fromDouble = fromRational . toRational
toDouble (Infinity Plus) = 1/0
toDouble (Infinity Minus) = 1/0
toDouble (NaN) = 0/0
toDouble (Finite r) = fromRational r
fromFloat = fromRational . toRational
toFloat (Infinity Plus) = 1/0
toFloat (Infinity Minus) = 1/0
toFloat (NaN) = 0/0
toFloat (Finite r) = fromRational r
showDiGrCmp = showERational