{-# LANGUAGE NoImplicitPrelude #-}
module Number.FixedPoint.Check where

import qualified Number.FixedPoint as FP

import qualified MathObj.PowerSeries.Example as PSE

import qualified Algebra.Transcendental as Trans
import qualified Algebra.Algebraic      as Algebraic
import qualified Algebra.RealField      as RealField
import qualified Algebra.Field          as Field
import qualified Algebra.Real           as Real
import qualified Algebra.Ring           as Ring
import qualified Algebra.Additive       as Additive
import qualified Algebra.ZeroTestable   as ZeroTestable

import PreludeBase
import NumericPrelude   hiding (fromRational')

import qualified Prelude        as P98
import qualified NumericPrelude as NP


{- * Types -}

data T = Cons {denominator :: Integer, numerator :: Integer}


{- * Conversion -}

cons :: Integer -> Integer -> T
cons = Cons

{- ** other number types -}

fromFloat :: RealField.C a => Integer -> a -> T
fromFloat den x =
   cons den (FP.fromFloat den x)

fromInteger' :: Integer -> Integer -> T
fromInteger' den x =
   cons den (x * den)

fromRational' :: Integer -> Rational -> T
fromRational' den x =
   cons den (round (x * NP.fromInteger den))

fromFloatBasis :: RealField.C a => Integer -> Int -> a -> T
fromFloatBasis basis numDigits =
   fromFloat (ringPower numDigits basis)

fromIntegerBasis :: Integer -> Int -> Integer -> T
fromIntegerBasis basis numDigits =
   fromInteger' (ringPower numDigits basis)

fromRationalBasis :: Integer -> Int -> Rational -> T
fromRationalBasis basis numDigits =
   fromRational' (ringPower numDigits basis)

-- | denominator conversion
fromFixedPoint :: Integer -> T -> T
fromFixedPoint denDst (Cons denSrc x) =
   cons denDst (FP.fromFixedPoint denDst denSrc x)


{- * Lift core function -}

lift0 :: Integer -> (Integer -> Integer) -> T
lift0 den f = Cons den (f den)

lift1 :: (Integer -> Integer -> Integer) -> (T -> T)
lift1 f (Cons xd xn) = Cons xd (f xd xn)

lift2 :: (Integer -> Integer -> Integer -> Integer) -> (T -> T -> T)
lift2 f (Cons xd xn) (Cons yd yn) =
   commonDenominator xd yd $ Cons xd (f xd xn yn)

commonDenominator :: Integer -> Integer -> a -> a
commonDenominator xd yd z =
   if xd == yd
     then z
     else error "Number.FixedPoint: denominators differ"


{- * Show -}

appPrec :: Int
appPrec  = 10

instance Show T where
  showsPrec p (Cons den num) =
    showParen (p >= appPrec)
       (showString "FixedPoint.cons " . shows den
          . showString " " . shows num)


defltDenominator :: Integer
defltDenominator = 10^100

defltShow :: T -> String
defltShow (Cons den x) =
   FP.showPositionalDec den x



instance Additive.C T where
   zero   = cons defltDenominator zero
   (+)    = lift2 FP.add
   (-)    = lift2 FP.sub
   negate (Cons xd xn) = Cons xd (negate xn)


instance Ring.C T where
   one         = cons defltDenominator defltDenominator
   fromInteger = fromInteger' defltDenominator . NP.fromInteger
   (*)         = lift2 FP.mul
   -- the default instance of (^) cumulates rounding errors but is faster
   -- x^n           = lift1 (pow n) x


instance Field.C T where
   (/)   = lift2 FP.divide
   recip = lift1 FP.recip
   fromRational' = fromRational' defltDenominator . NP.fromRational'


instance Algebraic.C T where
   sqrt   = lift1 FP.sqrt
   root n = lift1 (FP.root n)


-- these function are only implemented for the convergence radius of their Taylor expansions
instance Trans.C T where
   pi    = lift0 defltDenominator FP.piConst
   exp   = lift1 FP.exp
   log   = lift1 FP.ln
   {-
   logBase
   (**)
   -}
   sin   = lift1 (FP.evalPowerSeries PSE.sin)
   cos   = lift1 (FP.evalPowerSeries PSE.cos)
   -- tan   = lift1 (FP.evalPowerSeries PSE.tan)
   asin  = lift1 (FP.evalPowerSeries PSE.asin)
   atan  = lift1 FP.arctan
   {-
   acos  = lift1 (FP.evalPowerSeries PSE.acos)
   sinh  = lift1 (FP.evalPowerSeries PSE.sinh)
   tanh  = lift1 (FP.evalPowerSeries PSE.tanh)
   cosh  = lift1 (FP.evalPowerSeries PSE.cosh)
   asinh = lift1 (FP.evalPowerSeries PSE.asinh)
   atanh = lift1 (FP.evalPowerSeries PSE.atanh)
   acosh = lift1 (FP.evalPowerSeries PSE.acosh)
   -}


instance ZeroTestable.C T where
   isZero (Cons _ xn)  =  isZero xn

instance Eq T where
   (Cons xd xn) == (Cons yd yn) =
      commonDenominator xd yd (xn==yn)

instance Ord T where
   compare (Cons xd xn) (Cons yd yn) =
      commonDenominator xd yd (compare xn yn)

instance Real.C T where
   abs = lift1 (const abs)
   -- use default implementation for signum

instance RealField.C T where
   splitFraction (Cons xd xn) =
      let (int, frac) = divMod xd xn
      in  (fromInteger int, Cons xd frac)



-- legacy instances for work with GHCi
legacyInstance :: a
legacyInstance =
   error "legacy Ring.C instance for simple input of numeric literals"

instance P98.Num T where
   fromInteger = fromInteger' defltDenominator
   negate = negate --for unary minus
   (+)    = legacyInstance
   (*)    = legacyInstance
   abs    = legacyInstance
   signum = legacyInstance

instance P98.Fractional T where
   fromRational = fromRational' defltDenominator . fromRational
   (/) = legacyInstance