{-# LANGUAGE DeriveDataTypeable   #-}
{-|
Module      :  Data.Number.ER.Real.Base.Rational
Description :  rational numbers with infinities
Copyright   :  (c) Michal Konecny
License     :  BSD3

Maintainer  :  mik@konecny.aow.cz
Stability   :  experimental
Portability :  portable

Unlimited size rational numbers extended with signed infinities and NaN.

These can serve as endpoints of 'Data.Number.ER.Real.Approx.Interval.ERInterval'.

To be imported qualified, usually with prefix ERAT.
-}
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)

{- the following has been generated by BinaryDerive -}
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"
{- the above has been generated by BinaryDerive -}

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 = -- upper bound of dexp: f/10^dexpBound < 1
2 + (intLog 10 num) - (intLog 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
-- error "cannot compare NaN"
_ == NaN =
False
-- error "cannot compare NaN"
(Infinity pm1) == (Infinity pm2) = (pm1 == pm2)
(Finite r1) == (Finite r2) = r1 == r2
_ == _ = False

isNaN NaN = True
isNaN _ = False

instance Ord ExtendedRational where
{- compare NaN -}
compare _ NaN =
error "comparing NaN - aborting"
compare NaN _ =
error "comparing NaN - aborting"
{- compare infty -}
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 regular -}
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)
{- addition -}
-- NaN
NaN + _ = NaN
_ + NaN = NaN
-- Infty
(Infinity Plus) + (Infinity Minus) = NaN
(Infinity Minus) + (Infinity Plus) = NaN
(Infinity s) + _ = Infinity s
_ + (Infinity s) = Infinity s
-- regular
r1 + r2 = liftToERational2 (+) r1 r2
{- multiplication -}
-- NaN
NaN * _ = NaN
_ * NaN = NaN
-- Infty
(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)
-- regular
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 =
(intLog 2 (abs \$ numerator \$ r))
-
(intLog 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