module Data.SciRatio
(
SciRatio
, SciRational
, (.^)
, fracSignificand
, base10Exponent
, (^!)
, (^^!)
, fromSciRatio
, intLog
) where
import Data.Ratio ((%), denominator, numerator)
import Data.Hashable (Hashable(hashWithSalt))
import Data.Monoid (mappend)
infixr 8 ^!, ^^!
infixl 7 :^, .^
infixl 1 ~~
data SciRatio a b = !a :^ !b deriving Eq
type SciRational = SciRatio Rational Integer
instance (Fractional a, Real a, Integral b, Read a, Read b) =>
Read (SciRatio a b) where
readsPrec p = readParen (p > prec) $ \ r -> do
(x, s) <- readsPrec (succ prec) r
(".^", t) <- lex s
(y, u) <- readsPrec (succ prec) t
return (x .^ y, u)
instance (Show a, Show b) => Show (SciRatio a b) where
showsPrec p (x :^ a) = showParen (p > prec) $
showsPrec (succ prec) x .
showString " .^ " .
showsPrec (succ prec) a
instance (Real a, Integral b, Ord a) => Ord (SciRatio a b) where
compare (x :^ a) (y :^ b) = case compare s t of
EQ -> case s of
EQ -> EQ
LT -> invert thecase
GT -> thecase
k -> k
where x' = toRational x
y' = toRational y
s = compare x 0
t = compare y 0
absM = abs (numerator x' * denominator y')
absN = abs (numerator y' * denominator x')
invert GT = LT
invert EQ = EQ
invert LT = GT
thecase = case (intLog 10 absM, intLog 10 absN) of
((lremM, ilogM), (lremN, ilogN)) ->
case compare 0 ( b a
+ ilogN ilogM
+ fromInteger digN fromInteger digM ) of
EQ -> case compare digM digN of
EQ -> compare lremM lremN
LT -> compare lremM (dropLSD (digN digM) lremN) `mappend` LT
GT -> compare (dropLSD (digM digN) lremM) lremN `mappend` GT
k -> k
where digM = 1 + imLog 10 lremM
digN = 1 + imLog 10 lremN
instance (Hashable a, Hashable b) => Hashable (SciRatio a b) where
hashWithSalt s (r :^ e) = hashWithSalt s (magic, r, e)
where magic = 0xaaa80d6b :: Int
instance (Fractional a, Real a, Integral b) => Num (SciRatio a b) where
p + q = (x + y) .^ c where (x, y, c) = p ~~ q
p q = (x y) .^ c where (x, y, c) = p ~~ q
x :^ a * (y :^ b) = x * y .^ (a + b)
abs (y :^ b) = abs y :^ b
negate (y :^ b) = negate y :^ b
signum = (:^ 0) . signum . fracSignificand
fromInteger = (.^ 0) . fromInteger
instance (Fractional a, Real a, Integral b) => Fractional (SciRatio a b) where
x :^ a / (y :^ b) = x / y .^ (a b)
recip (y :^ b) = recip y .^ (b)
fromRational = (.^ 0) . fromRational
instance (Fractional a, Real a, Integral b) => Real (SciRatio a b) where
toRational (y :^ b) = toRational y * 10 ^^ b
instance (Fractional a, Real a, Integral b) => RealFrac (SciRatio a b) where
properFraction q = (\ (n, p) -> (n, fromRational p))
. properFraction $ toRational q
instance (Fractional a, Real a, Integral b) => Enum (SciRatio a b) where
succ = fromRational . succ . toRational
pred = fromRational . pred . toRational
toEnum = fromRational . toEnum
fromEnum = fromEnum . toRational
enumFrom = fmap fromRational . enumFrom . toRational
enumFromThen x = fmap fromRational
. enumFromThen (toRational x)
. toRational
enumFromTo x = fmap fromRational
. enumFromTo (toRational x)
. toRational
enumFromThenTo x y = fmap fromRational
. enumFromThenTo (toRational x) (toRational y)
. toRational
prec :: Int
prec = 7
(.^) :: (Fractional a, Real a, Integral b) =>
a
-> b
-> SciRatio a b
x .^ y = canonicalize $ x :^ y
fracSignificand :: SciRatio a b -> a
fracSignificand (x :^ _) = x
base10Exponent :: SciRatio a b -> b
base10Exponent (_ :^ x) = x
fromSciRatio :: (Real a, Integral b, Fractional c) => SciRatio a b -> c
fromSciRatio (x :^ y) = realToFrac x * 10 ^^ y
(^^!) :: (Fractional a, Real a, Integral b, Integral c) =>
SciRatio a b -> c -> SciRatio a b
(x :^ a) ^^! b = x ^^ b :^ (a * fromIntegral b)
(^!) :: (Real a, Integral b, Integral c) =>
SciRatio a b -> c -> SciRatio a b
(x :^ a) ^! b = x ^ b :^ (a * fromIntegral b)
(~~) :: (Fractional a, Integral b) => SciRatio a b -> SciRatio a b -> (a, a, b)
x :^ a ~~ y :^ b = (x * 10 ^^ (a c), y * 10 ^^ (b c), c)
where c = if abs a <= abs b then a else b
intLog :: (Integral a, Integral b) =>
a
-> a
-> (a, b)
intLog base = go 0 1 0
where go _ _ _ 0 = (0, 0)
go _ 0 e i = (i, e)
go maxe next e i =
if i `mod` power == 0
then go maxe' next' (e + next) (i `div` power)
else go next'' next'' e i
where power = base ^ next
maxe' = if maxe == 0 then maxe else maxe next
next' = if maxe == 0 then next * 2 else maxe `div` 2
next'' = next `div` 2
imLog :: Integral a => a -> a -> a
imLog b n | n < b = 0
| True = let l = 2 * imLog (b * b) n in doDiv (n `div` (b ^ l)) l
where doDiv x l | x < b = l
| True = doDiv (x `div` b) (l + 1)
dropLSD :: Integer -> Integer -> Integer
dropLSD k n | k <= 0 = n
| otherwise = dropLSD (k 1) (n `div` 10)
canonicalize :: (Fractional a, Real a, Integral b) =>
SciRatio a b -> SciRatio a b
canonicalize (0 :^ _) = 0 :^ 0
canonicalize (r :^ e) =
let r' = toRational r in
case (intLog 10 (numerator r'), intLog 2 (denominator r')) of
((n, ne), (d, e2)) -> case intLog 5 d of
(d', e5) -> case compare e2 e5 of
EQ -> fromRational (n % d') :^ (e + ne e5)
LT -> fromRational ((n * 2 ^ (e5 e2)) % d') :^ (e + ne e5)
GT -> fromRational ((n * 5 ^ (e2 e5)) % d') :^ (e + ne e2)