```{-# OPTIONS -fno-implicit-prelude #-}
{- |
Copyright   :  (c) Henning Thielemann 2006

Maintainer  :  numericprelude@henning-thielemann.de
Stability   :  provisional

Interface to "Number.Positional" which dynamically checks for equal bases.
-}
module Number.Positional.Check where

import qualified Number.Positional as Pos

import qualified Number.Complex as Complex

-- import qualified Algebra.Module             as Module
import qualified Algebra.RealTranscendental as RealTrans
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.ZeroTestable       as ZeroTestable

import qualified PreludeBase as P
import qualified Prelude     as P98

import PreludeBase as P
import NumericPrelude as NP

{- |
The value @Cons b e m@
represents the number @b^e * (m!!0 \/ 1 + m!!1 \/ b + m!!2 \/ b^2 + ...)@.
The interpretation of exponent is chosen such that
@floor (logBase b (Cons b e m)) == e@.
That is, it is good for multiplication and logarithms.
(Because of the necessity to normalize the multiplication result,
the alternative interpretation wouldn't be more complicated.)
However for base conversions, roots, conversion to fixed point and
working with the fractional part
the interpretation
@b^e * (m!!0 \/ b + m!!1 \/ b^2 + m!!2 \/ b^3 + ...)@
would fit better.
The digits in the mantissa range from @1-base@ to @base-1@.
The representation is not unique
and cannot be made unique in finite time.
This way we avoid infinite carry ripples.
-}
data T = Cons {base :: Int, exponent :: Int, mantissa :: Pos.Mantissa}
deriving (Show)

{- * basic helpers -}

{- |
Shift digits towards zero by partial application of carries.
E.g. 1.8 is converted to 2.(-2)
If the digits are in the range @(1-base, base-1)@
the resulting digits are in the range @((1-base)/2-2, (base-1)/2+2)@.
The result is still not unique,
but may be useful for further processing.
-}
compress :: T -> T
compress = lift1 Pos.compress

{- | perfect carry resolution, works only on finite numbers -}
carry :: T -> T
carry (Cons b ex xs) =
let ys = scanr (\x (c,_) -> divMod (x+c) b) (0,undefined) xs
digits = map snd (init ys)
in  prependDigit (fst (head ys)) (Cons b ex digits)

prependDigit :: Int -> T -> T
prependDigit 0 x = x
prependDigit x (Cons b ex xs) =
Cons b (ex+1) (x:xs)

{- * conversions -}

lift0 :: (Int -> Pos.T) -> T
lift0 op =
uncurry (Cons defltBase) (op defltBase)

lift1 :: (Int -> Pos.T -> Pos.T) -> T -> T
lift1 op (Cons xb xe xm) =
uncurry (Cons xb) (op xb (xe, xm))

lift2 :: (Int -> Pos.T -> Pos.T -> Pos.T) -> T -> T -> T
lift2 op (Cons xb xe xm) (Cons yb ye ym) =
let zb = commonBasis xb yb
in  uncurry (Cons zb) (op xb (xe, xm) (ye, ym))

commonBasis :: Pos.Basis -> Pos.Basis -> Pos.Basis
commonBasis xb yb =
if xb == yb
then xb
else error "Number.Positional: bases differ"

fromBaseInteger :: Int -> Integer -> T
fromBaseInteger b n =
uncurry (Cons b) (Pos.fromBaseInteger b n)

fromBaseRational :: Int -> Rational -> T
fromBaseRational b r =
uncurry (Cons b) (Pos.fromBaseRational b r)

defltBaseRoot :: Pos.Basis
defltBaseRoot = 10

defltBaseExp :: Pos.Exponent
defltBaseExp = 3
-- exp 4   let  (sqrt 0.5) fail

defltBase :: Pos.Basis
defltBase = ringPower defltBaseExp defltBaseRoot

defltShow :: T -> String
defltShow (Cons xb xe xm) =
if xb == defltBase
then Pos.showBasis defltBaseRoot defltBaseExp (xe,xm)
else error "defltShow: wrong base"

zero   = fromBaseInteger defltBase 0
(-)    = lift2 Pos.sub
negate = lift1 Pos.neg

instance Ring.C T where
one           = fromBaseInteger defltBase 1
fromInteger n = fromBaseInteger defltBase n
(*)           = lift2 Pos.mul

{-
instance Module.C T T where
(*>) = (*)
-}

instance Field.C T where
(/)   = lift2 Pos.divide
recip = lift1 Pos.reciprocal

instance Algebraic.C T where
sqrt   = lift1 Pos.sqrtNewton
root n = lift1 (flip Pos.root n)
x ^/ y = lift1 (flip Pos.power y) x

instance Trans.C T where
pi     = lift0 Pos.piConst

exp    = lift1 Pos.exp
log    = lift1 Pos.ln

sin    = lift1 (\b -> snd . Pos.cosSin b)
cos    = lift1 (\b -> fst . Pos.cosSin b)
tan    = lift1 Pos.tan

atan   = lift1 Pos.arctan

{-
sinh   = lift1 (\b -> snd . Pos.cosSinh b)
cosh   = lift1 (\b -> snd . Pos.cosSinh b)
-}

instance ZeroTestable.C T where
isZero (Cons xb xe xm) =
Pos.cmp xb (xe,xm) Pos.zero == EQ

instance Eq T where
(Cons xb xe xm) == (Cons yb ye ym) =
Pos.cmp (commonBasis xb yb) (xe,xm) (ye,ym) == EQ

instance Ord T where
compare (Cons xb xe xm) (Cons yb ye ym) =
Pos.cmp (commonBasis xb yb) (xe,xm) (ye,ym)

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

instance RealField.C T where
splitFraction (Cons xb xe xm) =
let (int, frac) = Pos.toFixedPoint xb (xe,xm)
in  (fromInteger int, Cons xb (-1) frac)

instance RealTrans.C T where
atan2  = lift2 (curry . Pos.angle)

-- for complex numbers

instance Complex.Power T where
power     = Complex.defltPow

-- 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 = fromBaseInteger defltBase
negate = negate --for unary minus
(+)    = legacyInstance
(*)    = legacyInstance
abs    = legacyInstance
signum = legacyInstance

instance P98.Fractional T where
fromRational = fromBaseRational defltBase . fromRational
(/) = legacyInstance

{-
MathObj.PowerSeries.approx MathObj.PowerSeries.Example.exp (Number.Positional.fromBaseInteger 10 1) List.!! 30 :: Number.Positional.Check.T
-}
```