-- This file is part of Goatee.
--
-- Copyright 2014-2021 Bryan Gardiner
--
-- Goatee is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- Goatee is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with Goatee.  If not, see <http://www.gnu.org/licenses/>.

-- | Base-10 arbitrary-precision floating-point numbers.
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)

-- | A base-10, infinite-precision, floating-point number.  Implemented as an
-- infinite-precision significand together with an exponent, such that the
-- numeric value is equal to @'significand' f * (10 ^ 'exponent' f)@.  The
-- exponent is a limited-precision 'Int', because some operations may break if
-- the exponent is larger (specifically 'show' and 'toDouble').  This shouldn't
-- be an issue for Goatee.
--
-- These values form an integral domain.
--
-- The 'Show' instance always outputs in decimal notation, never scientific
-- notation.  Examples:
--
-- > 300   (never trailing .0 if there's no fractional part)
-- > 0.1   (never redundant trailing or leading zeros)
--
-- Similarly, the 'Read' instance accepts numbers matching the regex
-- @-?\\d+(\\.\\d+)?(e-?\\d+)?@.  Scientific exponent notation is supported for
-- reading, for ease of converting 'Double's to 'Bigfloat's.
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 significand exponent@ creates a 'Bigfloat' value whose numeric
-- value is @significand * (10 ^ exponent)@.
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

-- | Converts a 'Double' to a 'Bigfloat' (with as much precision as the 'Double'
-- 'Show' instance provides).
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

-- | Converts a 'Bigfloat' to a 'Double', lossily.
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 amount float@ adds @shift@ zeros onto the right side of @float@'s
-- numerator while keeping the numeric value the same.  @amount@ must be
-- non-negative.
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)

-- | Reduces a 'Bigfloat' to canonical form, keeping the numeric value the same
-- but removing trailing zeros from the numerator.
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)

-- | Converts two 'Bigfloat's so that they have the same number of decimal
-- places, so that 'Integer' arithmetic may be performed directly on their
-- 'significand's.
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)

-- | Lifts a function on two 'Integer's to a function on 'Bigfloat's.
--
-- This is not exported from this module because it's not a general lift
-- function: the given function only operates on the significands, so operations
-- that require the exponent (such as multiplication) can't use this function.
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