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