module Game.Goatee.Common.Bigfloat (
Bigfloat, encode,
significand, exponent,
fromDouble, toDouble,
) where
import Data.Char (isDigit, isSpace)
import Data.Function (on)
import Prelude hiding (exponent, significand)
data Bigfloat = Bigfloat
{ significand :: !Integer
, exponent :: !Int
}
zero, one, negOne :: Bigfloat
zero = Bigfloat 0 0
one = Bigfloat 1 0
negOne = Bigfloat (1) 0
instance Eq Bigfloat where
x == y = let (Bigfloat xv xe, Bigfloat yv ye) = normalize2 x y
in xe == ye && xv == yv
instance Ord Bigfloat where
compare = (uncurry (compare `on` significand) .) . normalize2
instance Num Bigfloat where
(+) = lift2 (+)
() = lift2 ()
Bigfloat xv xe * Bigfloat yv ye = reduce $ Bigfloat (xv * yv) (xe + ye)
negate (Bigfloat v e) = Bigfloat (v) e
abs x@(Bigfloat v e) = if v >= 0 then x else Bigfloat (v) e
signum (Bigfloat v _)
| v == 0 = zero
| v > 0 = one
| otherwise = negOne
fromInteger v = reduce $ Bigfloat v 0
instance Show Bigfloat where
show (Bigfloat v e) =
let (addSign, vs) = if v >= 0
then (id, show v)
else (('-':), show (v))
vl = length vs
in addSign $ case e of
0 -> vs
e | e > 0 -> vs ++ replicate e '0'
| e <= vl -> '0' : '.' : replicate ((e) vl) '0' ++ vs
_ -> let (hd, tl) = splitAt (vl + e) vs
in hd ++ '.' : tl
instance Read Bigfloat where
readsPrec _ s =
let (s', neg) = case s of
'-':s' -> (s', True)
_ -> (s, False)
(whole, s'') = span isDigit s'
in if null whole
then []
else case s'' of
'.':s''' -> let (fractional, s'''') = span isDigit s'''
in if null fractional
then []
else succeedIfTerminatedProperly neg whole fractional s''''
s''' -> succeedIfTerminatedProperly neg whole [] s'''
where succeedIfTerminatedProperly neg whole fractional rest =
let makeResult exp =
encode (fromInteger $
read $
(if neg then ('-':) else id) $
whole ++ fractional)
(length fractional + exp)
in if isValidEndOfNumber rest
then [(makeResult 0, rest)]
else case rest of
'e':exps -> let (addExpNeg, exps') = case exps of
'-':exps' -> (('-':), exps')
_ -> (id, exps)
(hd, tl) = span isDigit exps'
in if null hd
then []
else let exp = read (addExpNeg exps') :: Int
in [(makeResult exp, tl) | isValidEndOfNumber tl]
_ -> []
isValidEndOfNumber rest = case rest of
[] -> True
c:_ | isSpace c -> True
_ -> False
encode :: Integer -> Int -> Bigfloat
encode = (reduce .) . Bigfloat
fromDouble :: Double -> Bigfloat
fromDouble = read . show
toDouble :: Bigfloat -> Double
toDouble = read . show
shift :: Int -> Bigfloat -> Bigfloat
shift amount float@(Bigfloat v e) =
if amount < 0
then error $ "bigfloatShift: Can't shift by a negative amount. amount = " ++
show amount ++ ", float = " ++ show float
else Bigfloat (v * 10 ^ amount) (e amount)
reduce :: Bigfloat -> Bigfloat
reduce x@(Bigfloat v e) =
if v == 0
then zero
else let zeros = length $ takeWhile (== '0') $ reverse $ show v
in if zeros == 0
then x
else Bigfloat (v `div` (10 ^ zeros)) (e + zeros)
normalize2 :: Bigfloat -> Bigfloat -> (Bigfloat, Bigfloat)
normalize2 x y =
let xe = exponent x
ye = exponent y
in if xe == ye
then (x, y)
else if xe < ye
then (x, shift (ye xe) y)
else (shift (xe ye) x, y)
lift2 :: (Integer -> Integer -> Integer) -> Bigfloat -> Bigfloat -> Bigfloat
lift2 f x y =
let (Bigfloat xv xe, Bigfloat yv _) = normalize2 x y
in reduce $ Bigfloat (f xv yv) xe