{-# LANGUAGE DeriveDataTypeable   #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-|
    Module      :  Data.Number.ER.Real.Base.CombinedMachineAP
    Description :  auto-switching hardware-software floats 
    Copyright   :  (c) Michal Konecny
    License     :  BSD3

    Maintainer  :  mik@konecny.aow.cz
    Stability   :  experimental
    Portability :  non-portable (requires fenv.h)

    Arbitrary precision floating point numbers that use
    machine double up to its precision.  When a higher
    granularity is required, it automatically switches 
    to another floating point type.
-}
module Data.Number.ER.Real.Base.CombinedMachineAP 
(
    ERMachineAP,
    doubleDigits
)
where

import qualified Data.Number.ER.Real.Base as B
import qualified Data.Number.ER.BasicTypes.ExtendedInteger as EI
import Data.Number.ER.Real.Base.MachineDouble
import Data.Number.ER.Real.Base.Float
import Data.Number.ER.BasicTypes
import Data.Number.ER.Misc

import Data.Typeable
import Data.Generics.Basics
import Data.Binary
--import BinaryDerive

import Data.Ratio

data ERMachineAP b =
    ERMachineAPMachineDouble
    {
        machapfltDoubleGranularity :: Granularity
        {-^ this has to be between 1 and 'doubleDigits' -}
    ,
        machapfltDouble :: Double
    }
    |    
    ERMachineAPB
    {
        machapfltB :: b
    }
    deriving (Typeable, Data)

doubleDigits = floatDigits (0 :: Double)

{- the following has been generated by BinaryDerive -}     
instance (Binary b) => (Binary (ERMachineAP b)) where
  put (ERMachineAPMachineDouble a b) = putWord8 0 >> put a >> put b
  put (ERMachineAPB a) = putWord8 1 >> put a
  get = do
    tag_ <- getWord8
    case tag_ of
      0 -> get >>= \a -> get >>= \b -> return (ERMachineAPMachineDouble a b)
      1 -> get >>= \a -> return (ERMachineAPB a)
      _ -> fail "no parse"
{- the above has been generated by BinaryDerive -}
    
lift1ERMachineAP ::
    (Double -> Double) ->
    (b -> b) ->
    (ERMachineAP b -> ERMachineAP b)
lift1ERMachineAP fD fB (ERMachineAPMachineDouble g d) = 
    ERMachineAPMachineDouble g (fD d) 
lift1ERMachineAP fD fB (ERMachineAPB b) = 
    ERMachineAPB (fB b) 

op1ERMachineAP ::
    (Double -> a) ->
    (b -> a) ->
    (ERMachineAP b -> a)
op1ERMachineAP fD fB (ERMachineAPMachineDouble g d) = 
    fD d 
op1ERMachineAP fD fB (ERMachineAPB b) = 
    fB b 

lift2ERMachineAP ::
    (B.ERRealBase b) =>
    (Double -> Double -> Double) ->
    (b -> b -> b) ->
    (ERMachineAP b -> ERMachineAP b -> ERMachineAP b)
lift2ERMachineAP fD fB 
        (ERMachineAPMachineDouble g1 d1) (ERMachineAPMachineDouble g2 d2) = 
    ERMachineAPMachineDouble (max g1 g2) (fD d1 d2)
lift2ERMachineAP fD fB 
        (ERMachineAPMachineDouble g1 d1) (ERMachineAPB b2) = 
    ERMachineAPB $ fB (B.fromDouble d1) b2
lift2ERMachineAP fD fB 
        (ERMachineAPB b1) (ERMachineAPMachineDouble g2 d2) = 
    ERMachineAPB $ fB b1 (B.fromDouble d2)
lift2ERMachineAP fD fB 
        (ERMachineAPB b1) (ERMachineAPB b2) = 
    ERMachineAPB $ fB b1 b2
    
op2ERMachineAP ::
    (B.ERRealBase b) =>
    (Double -> Double -> a) ->
    (b -> b -> a) ->
    (ERMachineAP b -> ERMachineAP b -> a)
op2ERMachineAP fD fB 
        (ERMachineAPMachineDouble g1 d1) (ERMachineAPMachineDouble g2 d2) = 
    fD d1 d2
op2ERMachineAP fD fB 
        (ERMachineAPMachineDouble g1 d1) (ERMachineAPB b2) = 
    fB (B.fromDouble d1) b2
op2ERMachineAP fD fB 
        (ERMachineAPB b1) (ERMachineAPMachineDouble g2 d2) = 
    fB b1 (B.fromDouble d2)
op2ERMachineAP fD fB 
        (ERMachineAPB b1) (ERMachineAPB b2) = 
    fB b1 b2
    
instance (B.ERRealBase b) => Show (ERMachineAP b)
    where
    show = showERMachineAP 6 True True
    
showERMachineAP numDigits showGran showComponents =
    showEMA
    where
    maybeGran gr
        | showGran = "{g=" ++ show gr ++ "}"
        | otherwise = ""
    maybeComps
        | showComponents = "{Double}"
        | otherwise = ""
    showEMA (ERMachineAPMachineDouble gr d) = 
        show d ++ (maybeGran gr) ++ maybeComps
    showEMA (ERMachineAPB b) = 
        B.showDiGrCmp numDigits showGran showComponents b


instance (B.ERRealBase b) => Eq (ERMachineAP b)
    where
    (==) = op2ERMachineAP (==) (==)
    
instance (B.ERRealBase b) => Ord (ERMachineAP b)
    where
    compare = op2ERMachineAP compare compare
    

    
instance (B.ERRealBase b) => Num (ERMachineAP b)
    where
    fromInteger n 
        | gran < doubleDigits = 
            ERMachineAPMachineDouble gran $ fromInteger n
        | otherwise = 
            ERMachineAPB b
        where
        gran = B.getGranularity b    
        b = fromInteger n
    abs = lift1ERMachineAP abs abs  
    signum = lift1ERMachineAP signum signum
    negate = lift1ERMachineAP negate negate
    (+) = lift2ERMachineAP (+) (+)
    (*) = lift2ERMachineAP (*) (*)
    
instance (B.ERRealBase b) => Fractional (ERMachineAP b)
    where
    fromRational rat =
        (fromInteger $ numerator rat) 
        / (fromInteger $ denominator rat)
    recip = lift1ERMachineAP recip recip
    (/) = lift2ERMachineAP (/) (/)
        
instance (B.ERRealBase b, Real b) => Real (ERMachineAP b)
    where
    toRational = op1ERMachineAP toRational toRational
    
instance (B.ERRealBase b, RealFrac b) => RealFrac (ERMachineAP b)
    where
    properFraction (ERMachineAPMachineDouble g d) =
        (a, ERMachineAPMachineDouble g remainder)
        where
        (a,remainder) = properFraction d 
    properFraction (ERMachineAPB b) =
        (a, ERMachineAPB remainder)
        where
        (a,remainder) = properFraction b 
        
        
instance (B.ERRealBase b) => B.ERRealBase (ERMachineAP b)
    where
    typeName _ = "auto switching double and " ++ (B.typeName (0::b))
    initialiseBaseArithmetic x = 
		do
		putStr $ "Base arithmetic:" ++ B.typeName x ++ "; "
		initMachineDouble
    defaultGranularity _ = (B.defaultGranularity (0 :: b))
    getApproxBinaryLog = 
        op1ERMachineAP doubleBinaryLog B.getApproxBinaryLog
        where
        doubleBinaryLog d
            | d < 0 =
                error $ "ERMachineAP: getApproxBinaryLog: negative argument " ++ show d 
            | d == 0 = EI.MinusInfinity 
            | d >= 1 =
                fromInteger $ intLogUp 2 $ ceiling d
            | d < 1 =
                negate $ fromInteger $ intLogUp 2 $ ceiling $ recip d
    getGranularity (ERMachineAPB b) = B.getGranularity b
    getGranularity (ERMachineAPMachineDouble gr _) = gr
    setMinGranularity gran (ERMachineAPMachineDouble g d) 
        | gran > doubleDigits =
            ERMachineAPB $ B.setMinGranularity gran $ B.fromDouble d
        | otherwise =
            ERMachineAPMachineDouble gran d
    setMinGranularity gran (ERMachineAPB b) = ERMachineAPB $ B.setMinGranularity gran b 
    setGranularity gran (ERMachineAPMachineDouble g d) 
        | gran > doubleDigits =
            ERMachineAPB $ B.setGranularity gran $ B.fromDouble d
        | otherwise =
            ERMachineAPMachineDouble gran d
    setGranularity gran (ERMachineAPB b)
        | gran <= doubleDigits =
            ERMachineAPMachineDouble gran $ B.toDouble b
        | otherwise = 
            ERMachineAPB $ B.setGranularity gran b 
    getMaxRounding _ = 
        error "ERMachineAP: getMaxRounding not implemented yet"
    isERNaN = op1ERMachineAP isNaN B.isERNaN
    erNaN = B.fromDouble (0/0)
    isPlusInfinity = 
        op1ERMachineAP (== 1/0) B.isPlusInfinity
    plusInfinity = B.fromDouble $ 1/0
    fromIntegerUp = fromInteger
    fromDouble d = 
        ERMachineAPMachineDouble (B.defaultGranularity (0 :: b)) d
    toDouble = op1ERMachineAP id B.toDouble
    fromFloat f = 
        ERMachineAPMachineDouble (B.defaultGranularity (0 :: b)) $
            fromRational $ toRational f
    toFloat = op1ERMachineAP (fromRational . toRational) B.toFloat 
    showDiGrCmp = showERMachineAP