{-# 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 + (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
        -- 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
    typeName _ = "extended rationals"
    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