module Data.Number.ER.Real.Base.CombinedMachineAP
(
ERMachineAP,
doubleDigits
)
where
import qualified Data.Number.ER.Real.Base as B
import qualified Data.Number.ER.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 Data.Ratio
data ERMachineAP b =
ERMachineAPMachineDouble
{
machapfltDoubleGranularity :: Granularity
,
machapfltDouble :: Double
}
|
ERMachineAPB
{
machapfltB :: b
}
deriving (Typeable, Data)
doubleDigits = floatDigits (0 :: Double)
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"
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
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