-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
-- HasCallStack is redundant only if -O is passed.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
-- | Miscellaneous functions on numbers.  Things that could have gone in
-- Numeric.
module Util.Num where
import           Prelude hiding (sum)
import qualified Control.Exception as Exception
import           Data.Bifunctor (second)
import qualified Data.Bits as Bits
import qualified Data.Fixed as Fixed
import qualified Data.List as List
import qualified Data.Text as Text
import           Data.Text (Text)
import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Text.Lazy.Builder as Text.Lazy.Builder
import qualified Data.Text.Lazy.Builder.RealFloat as Lazy.Builder.RealFloat

import qualified GHC.Prim as Prim
import qualified GHC.Types as Types
import qualified Numeric

import qualified GHC.Stack as Stack


-- * show

-- | Show a word as binary.
--
-- Warning: for some reason, Integer is an instance of Bits, but bitSize will
-- crash.
binary :: Bits.Bits a => a -> String
binary :: forall a. Bits a => a -> String
binary a
b = case forall a. Bits a => a -> Maybe Int
Bits.bitSizeMaybe a
b of
    Maybe Int
Nothing -> String
""
    Just Int
bits -> forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
extract [Int
bitsforall a. Num a => a -> a -> a
-Int
1, Int
bitsforall a. Num a => a -> a -> a
-Int
2 .. Int
0]
    where
    extract :: Int -> Char
extract Int
i = if forall a. Bits a => a -> Int -> Bool
Bits.testBit a
b Int
i then Char
'1' else Char
'0'

hex :: (Integral a, Show a) => Int -> a -> Text
hex :: forall a. (Integral a, Show a) => Int -> a -> Text
hex Int
pad a
n = forall a. Monoid a => [a] -> a
mconcat
    [ if a
n forall a. Ord a => a -> a -> Bool
< a
0 then Text
"-" else Text
""
    , Int -> Text -> Text
Text.replicate (Int
pad forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
s) Text
"0"
    , Text
s
    ]
    where s :: Text
s = String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. (Integral a, Show a) => a -> ShowS
Numeric.showHex (forall a. Num a => a -> a
abs a
n) String
""

showHigit :: Int -> Maybe Char
showHigit :: Int -> Maybe Char
showHigit Int
c = case Int
c of
    Int
0 -> forall a. a -> Maybe a
Just Char
'0'; Int
1 -> forall a. a -> Maybe a
Just Char
'1'; Int
2 -> forall a. a -> Maybe a
Just Char
'2'; Int
3 -> forall a. a -> Maybe a
Just Char
'3'
    Int
4 -> forall a. a -> Maybe a
Just Char
'4'; Int
5 -> forall a. a -> Maybe a
Just Char
'5'; Int
6 -> forall a. a -> Maybe a
Just Char
'6'; Int
7 -> forall a. a -> Maybe a
Just Char
'7'
    Int
8 -> forall a. a -> Maybe a
Just Char
'8'; Int
9 -> forall a. a -> Maybe a
Just Char
'9'; Int
10 -> forall a. a -> Maybe a
Just Char
'a'; Int
11 -> forall a. a -> Maybe a
Just Char
'b'
    Int
12 -> forall a. a -> Maybe a
Just Char
'c'; Int
13 -> forall a. a -> Maybe a
Just Char
'd'; Int
14 -> forall a. a -> Maybe a
Just Char
'e'; Int
15 -> forall a. a -> Maybe a
Just Char
'f'
    Int
_ -> forall a. Maybe a
Nothing

zeroPad :: Show a => Int -> a -> Text
zeroPad :: forall a. Show a => Int -> a -> Text
zeroPad Int
digits a
n = Int -> Text -> Text
Text.replicate (Int
digits forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
s) Text
"0" forall a. Semigroup a => a -> a -> a
<> Text
s
    where s :: Text
s = String -> Text
Text.pack (forall a. Show a => a -> String
show a
n)

-- | Display a float with the given precision, dropping trailing and leading
-- zeros.  Haskell requires a 0 before the decimal point, so this produces
-- non-Haskell numbers.
showFloat :: RealFloat a => Int -> a -> Text
showFloat :: forall a. RealFloat a => Int -> a -> Text
showFloat Int
precision = Text -> Text
drop0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RealFloat a => Maybe Int -> a -> Text
showFloat0 (forall a. a -> Maybe a
Just Int
precision)
    where
    drop0 :: Text -> Text
drop0 Text
t
        | Text
t forall a. Eq a => a -> a -> Bool
== Text
"0" = Text
"0"
        | Just Text
rest <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"-0." Text
t = Text
"-." forall a. Semigroup a => a -> a -> a
<> Text
rest
        | Just Text
rest <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"0." Text
t = Char -> Text -> Text
Text.cons Char
'.' Text
rest
        | Bool
otherwise = Text
t

-- | Fancy decimal float formatting.  Show up to the given precision, like
-- 'showFloat', unless it would be all 0s.  In that case, show the minimum
-- necessary to get to a non-zero.
showFloatP :: RealFloat a => Bool -> Int -> a -> Text
showFloatP :: forall a. RealFloat a => Bool -> Int -> a -> Text
showFloatP Bool
leadingZero Int
precision a
num
    | a
num forall a. Eq a => a -> a -> Bool
== a
0 = if forall a. RealFloat a => a -> Bool
isNegativeZero a
num then Text
"-0" else Text
"0"
    | (Char -> Bool) -> Text -> Bool
Text.all (forall a. Eq a => a -> a -> Bool
==Char
'0') Text
inPrecision =
        Text -> Text
prependInt forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
takeWhile1 (forall a. Eq a => a -> a -> Bool
==Char
'0') (Text -> Text
strip0 Text
frac)
    | Bool
otherwise = Text -> Text
prependInt forall a b. (a -> b) -> a -> b
$ Text -> Text
strip0 Text
inPrecision
    where
    numS :: Text
numS = forall a. RealFloat a => Maybe Int -> a -> Text
showFloat0 forall a. Maybe a
Nothing a
num
    (Text
int, Text
frac) = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Int -> Text -> Text
Text.drop Int
1) forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> (Text, Text)
Text.break (forall a. Eq a => a -> a -> Bool
==Char
'.') Text
numS
    intS :: Text
intS = (if Bool
leadingZero then forall a. a -> a
id else Text -> Text
drop0) Text
int forall a. Semigroup a => a -> a -> a
<> Text
"."
    inPrecision :: Text
inPrecision = Int -> Text -> Text
Text.take Int
precision Text
frac
    takeWhile1 :: (Char -> Bool) -> Text -> Text
takeWhile1 Char -> Bool
f Text
t = Int -> Text -> Text
Text.take (Int
1 forall a. Num a => a -> a -> a
+ Text -> Int
Text.length ((Char -> Bool) -> Text -> Text
Text.takeWhile Char -> Bool
f Text
t)) Text
t
    prependInt :: Text -> Text
prependInt = (Char -> Bool) -> Text -> Text
Text.dropWhileEnd (forall a. Eq a => a -> a -> Bool
==Char
'.') forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
intS<>)

    drop0 :: Text -> Text
drop0 Text
t
        | Text
"-0" Text -> Text -> Bool
`Text.isPrefixOf` Text
t = Text
"-"
        | Text
"0" Text -> Text -> Bool
`Text.isPrefixOf` Text
t = Text
""
        | Bool
otherwise = Text
t
    strip0 :: Text -> Text
strip0 = (Char -> Bool) -> Text -> Text
Text.dropWhileEnd (forall a. Eq a => a -> a -> Bool
==Char
'0')

-- | Like 'showFloat', but use a leading 0, so haskell can parse it.
showFloat0 :: RealFloat a => Maybe Int -> a -> Text
showFloat0 :: forall a. RealFloat a => Maybe Int -> a -> Text
showFloat0 Maybe Int
precision =
    Text -> Text
dropTrailing0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.Lazy.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
Text.Lazy.Builder.toLazyText
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RealFloat a => FPFormat -> Maybe Int -> a -> Builder
Lazy.Builder.RealFloat.formatRealFloat FPFormat
Lazy.Builder.RealFloat.Fixed
        Maybe Int
precision
    where
    dropTrailing0 :: Text -> Text
dropTrailing0
        | forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Ord a => a -> a -> Bool
>Int
0) Maybe Int
precision =
            (Char -> Bool) -> Text -> Text
Text.dropWhileEnd (forall a. Eq a => a -> a -> Bool
==Char
'.') forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.dropWhileEnd (forall a. Eq a => a -> a -> Bool
==Char
'0')
        | Bool
otherwise = forall a. a -> a
id

-- * assert

-- | Like @div@, but assert that it divides evenly.
assertDiv :: Stack.HasCallStack => Integral a => a -> a -> a
assertDiv :: forall a. (HasCallStack, Integral a) => a -> a -> a
assertDiv a
a a
b = forall a. HasCallStack => Bool -> a -> a
Exception.assert (a
a forall a. Integral a => a -> a -> a
`mod` a
b forall a. Eq a => a -> a -> Bool
== a
0) forall a b. (a -> b) -> a -> b
$ a
a forall a. Integral a => a -> a -> a
`div` a
b

assertIntegral :: (Stack.HasCallStack, RealFrac f, Integral i) => f -> i
assertIntegral :: forall f i. (HasCallStack, RealFrac f, Integral i) => f -> i
assertIntegral f
frac = forall a. HasCallStack => Bool -> a -> a
Exception.assert (f
f forall a. Eq a => a -> a -> Bool
== f
0) i
i
    where (i
i, f
f) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction f
frac

-- * read

readDigit :: Char -> Maybe Int
readDigit :: Char -> Maybe Int
readDigit Char
c = case Char
c of
    Char
'0' -> forall a. a -> Maybe a
Just Int
0; Char
'1' -> forall a. a -> Maybe a
Just Int
1; Char
'2' -> forall a. a -> Maybe a
Just Int
2; Char
'3' -> forall a. a -> Maybe a
Just Int
3; Char
'4' -> forall a. a -> Maybe a
Just Int
4
    Char
'5' -> forall a. a -> Maybe a
Just Int
5; Char
'6' -> forall a. a -> Maybe a
Just Int
6; Char
'7' -> forall a. a -> Maybe a
Just Int
7; Char
'8' -> forall a. a -> Maybe a
Just Int
8; Char
'9' -> forall a. a -> Maybe a
Just Int
9
    Char
_ -> forall a. Maybe a
Nothing

-- * transform

-- | Prelude sum is lazy, for silly reasons.
sum :: (Foldable t, Num a) => t a -> a
sum :: forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' forall a. Num a => a -> a -> a
(+) a
0

roundDigits :: (RealFrac a, Fractional b) => Int -> a -> b
roundDigits :: forall a b. (RealFrac a, Fractional b) => Int -> a -> b
roundDigits Int
digits = (forall a. Fractional a => a -> a -> a
/ (b
10forall a b. (Num a, Integral b) => a -> b -> a
^Int
digits)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* (a
10forall a b. (Num a, Integral b) => a -> b -> a
^Int
digits))

-- | Round up to the nearest factor above the given number.
roundUp :: (Integral factor, Real a) => factor -> a -> factor
roundUp :: forall factor a. (Integral factor, Real a) => factor -> a -> factor
roundUp factor
factor a
n =
    forall a b. (RealFrac a, Integral b) => a -> b
ceiling (forall a b. (Real a, Fractional b) => a -> b
realToFrac a
n forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Num a => a -> a
abs factor
factor)) forall a. Num a => a -> a -> a
* forall a. Num a => a -> a
abs factor
factor
{-# INLINEABLE roundUp #-}

roundDown :: (Integral factor, Real a) => factor -> a -> factor
roundDown :: forall factor a. (Integral factor, Real a) => factor -> a -> factor
roundDown factor
factor a
n =
    forall a b. (RealFrac a, Integral b) => a -> b
floor (forall a b. (Real a, Fractional b) => a -> b
realToFrac a
n forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Num a => a -> a
abs factor
factor)) forall a. Num a => a -> a -> a
* forall a. Num a => a -> a
abs factor
factor
{-# INLINEABLE roundDown #-}

roundDownD :: Double -> Double -> Double
roundDownD :: Double -> Double -> Double
roundDownD Double
factor Double
n = Double -> Double
floorD (Double
n forall a. Fractional a => a -> a -> a
/ forall a. Num a => a -> a
abs Double
factor) forall a. Num a => a -> a -> a
* forall a. Num a => a -> a
abs Double
factor

roundToD :: Double -> Double -> Double
roundToD :: Double -> Double -> Double
roundToD Double
factor Double
n = Double -> Double
roundD (Double
n forall a. Fractional a => a -> a -> a
/ forall a. Num a => a -> a
abs Double
factor) forall a. Num a => a -> a -> a
* forall a. Num a => a -> a
abs Double
factor

-- | Clamp a value to be between @low@ and @high@.
clamp :: Ord a => a -> a -> a -> a
clamp :: forall a. Ord a => a -> a -> a -> a
clamp a
low a
high = forall a. Ord a => a -> a -> a
min a
high forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
max a
low

-- | Confine the given value lie between the first two arguments, but using
-- modulus, not clamping.
restrict :: Real a => a -> a -> a -> a
restrict :: forall a. Real a => a -> a -> a -> a
restrict a
low a
high
    | a
high forall a. Eq a => a -> a -> Bool
== a
low = forall a b. a -> b -> a
const a
low -- avoid dividing by 0 in fmod
    | Bool
otherwise = (forall a. Num a => a -> a -> a
+a
low) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Real a => a -> a -> a
`fmod` (a
highforall a. Num a => a -> a -> a
-a
low)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract a
low

inRange :: Ord a => a -> a -> a -> Bool
inRange :: forall a. Ord a => a -> a -> a -> Bool
inRange a
low a
high a
x = a
low forall a. Ord a => a -> a -> Bool
<= a
x Bool -> Bool -> Bool
&& a
x forall a. Ord a => a -> a -> Bool
< a
high

-- | Scale @v@, which is between 0 and 1 inclusive, to be between @low@ and
-- @high@.  If @v@ is not in the 0--1 range, the result will be out of the
-- low--high range.
--
-- This is linear interpolate, or lerp.
{-# INLINEABLE scale #-}
{-# SPECIALIZE scale :: Double -> Double -> Double -> Double #-}
{-# SPECIALIZE scale :: Float -> Float -> Float -> Float #-}
scale :: (Eq a, Num a) => a -> a -> a -> a
scale :: forall a. (Eq a, Num a) => a -> a -> a -> a
scale a
low a
high a
v
    -- Some calls to scale are likely to have 0 or 1.  If low and high are
    -- complicated expressions its nice to avoid evaluating them.
    | a
v forall a. Eq a => a -> a -> Bool
== a
0 = a
low
    | a
v forall a. Eq a => a -> a -> Bool
== a
1 = a
high
    | Bool
otherwise = a
v forall a. Num a => a -> a -> a
* (a
highforall a. Num a => a -> a -> a
-a
low) forall a. Num a => a -> a -> a
+ a
low

-- | Normalize @v@, which is between @low@ and @high@ inclusive, to be between
-- 0 and 1.  As with 'scale', if @v@ is not in range, the result will not be
-- in range either.
{-# INLINEABLE normalize #-}
{-# SPECIALIZE normalize :: Double -> Double -> Double -> Double #-}
{-# SPECIALIZE normalize :: Float -> Float -> Float -> Float #-}
normalize :: (Eq a, Fractional a) => a -> a -> a -> a
normalize :: forall a. (Eq a, Fractional a) => a -> a -> a -> a
normalize a
low a
high a
v
    | a
low forall a. Eq a => a -> a -> Bool
== a
high Bool -> Bool -> Bool
&& a
v forall a. Eq a => a -> a -> Bool
== a
low = a
0 -- avoid a divide by zero
    | a
v forall a. Eq a => a -> a -> Bool
== a
high = a
1
    | Bool
otherwise = (a
vforall a. Num a => a -> a -> a
-a
low) forall a. Fractional a => a -> a -> a
/ (a
highforall a. Num a => a -> a -> a
-a
low)

infixl 7 `fmod` -- match `mod`

-- | fmod is in a bizarre place.
{-# SPECIALIZE fmod :: Double -> Double -> Double #-}
fmod :: Real a => a -> a -> a
fmod :: forall a. Real a => a -> a -> a
fmod = forall a. Real a => a -> a -> a
Fixed.mod'

{-# SPECIALIZE fDivMod :: Double -> Double -> (Int, Double) #-}
fDivMod :: (Integral div, RealFrac mod) => mod -> mod -> (div, mod)
fDivMod :: forall div mod.
(Integral div, RealFrac mod) =>
mod -> mod -> (div, mod)
fDivMod mod
a mod
b = (forall a b. (RealFrac a, Integral b) => a -> b
floor (mod
a forall a. Fractional a => a -> a -> a
/ mod
b), forall a. Real a => a -> a -> a
fmod mod
a mod
b)

integral :: RealFrac a => a -> Bool
integral :: forall a. RealFrac a => a -> Bool
integral = (forall a. Eq a => a -> a -> Bool
==a
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction

asIntegral :: (RealFrac frac, Integral int) => frac -> Maybe int
asIntegral :: forall frac int. (RealFrac frac, Integral int) => frac -> Maybe int
asIntegral frac
n
    | frac
f forall a. Eq a => a -> a -> Bool
== frac
0 = forall a. a -> Maybe a
Just int
i
    | Bool
otherwise = forall a. Maybe a
Nothing
    where (int
i, frac
f) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction frac
n

-- | realToFrac doesn't preserve the special float values and is inefficient.
--
-- There are some RULEs for this, but they aren't reliable.
d2f :: Double -> Float
d2f :: Double -> Float
d2f (Types.D# Double#
d) = Float# -> Float
Types.F# (Double# -> Float#
Prim.double2Float# Double#
d)

f2d :: Float -> Double
f2d :: Float -> Double
f2d (Types.F# Float#
f) = Double# -> Double
Types.D# (Float# -> Double#
Prim.float2Double# Float#
f)

-- | Conversion that clamps at INT_MIN / INT_MAX.
d2i :: Double -> Int
d2i :: Double -> Int
d2i Double
d = forall a b. (RealFrac a, Integral b) => a -> b
floor (forall a. Ord a => a -> a -> a -> a
clamp Double
minInt Double
maxInt Double
d)
    where
    maxInt :: Double
maxInt = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int)
    minInt :: Double
minInt = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
minBound :: Int)

i2d :: Int -> Double
i2d :: Int -> Double
i2d = forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- Versions of floor and round that don't go through an int conversion.
foreign import ccall unsafe "floor" floorD :: Double -> Double
foreign import ccall unsafe "floorf" floorF :: Float -> Float
foreign import ccall unsafe "round" roundD :: Double -> Double
foreign import ccall unsafe "roundf" roundF :: Float -> Float