-- | Numerical ranges
module Test.Falsify.Range (
    Range -- opaque
    -- * Constructors
    -- ** Linear
  , between
  , enum
  , withOrigin
    -- ** Non-linear
  , skewedBy
    -- * Queries
  , origin
    -- * Primitive constructors
  , ProperFraction(..)
  , Precision(..)
  , constant
  , fromProperFraction
  , towards
    -- * Evalation
  , eval
  ) where

import Data.Bits
import Data.List.NonEmpty (NonEmpty(..))
import Data.Ord

import qualified Data.List.NonEmpty as NE

import Test.Falsify.Internal.Range
import Data.Functor.Identity

{-------------------------------------------------------------------------------
  Primitive ranges
-------------------------------------------------------------------------------}

-- | Range that is @x@ everywhere
constant :: a -> Range a
constant :: forall a. a -> Range a
constant = forall a. a -> Range a
Constant

-- | Construct @a@ given a fraction
--
-- Precondition: @f@ must be monotonically increasing or decreasing; i.e.
--
-- * for all @x <= y@, @f x <= f y@, /or/
-- * for all @x <= y@, @f y <= f x@
fromProperFraction :: Precision -> (ProperFraction -> a) -> Range a
fromProperFraction :: forall a. Precision -> (ProperFraction -> a) -> Range a
fromProperFraction = forall a. Precision -> (ProperFraction -> a) -> Range a
FromProperFraction

-- | Generate value in any of the specified ranges, then choose the one
-- that is closest to the specified origin
--
-- Precondition: the target must be within the bounds of all ranges.
towards :: forall a. (Ord a, Num a) => a -> [Range a] -> Range a
towards :: forall a. (Ord a, Num a) => a -> [Range a] -> Range a
towards a
o []     = forall a. a -> Range a
Constant a
o
towards a
o (Range a
r:[Range a]
rs) = forall b a. Ord b => NonEmpty (Range (a, b)) -> Range a
Smallest forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Range a -> Range (a, a)
aux (Range a
r forall a. a -> [a] -> NonEmpty a
:| [Range a]
rs)
  where
    aux :: Range a -> Range (a, a)
    aux :: Range a -> Range (a, a)
aux = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ \a
x -> (a
x, a -> a
distanceToOrigin a
x)

    distanceToOrigin :: a -> a
    distanceToOrigin :: a -> a
distanceToOrigin a
x
      | a
x forall a. Ord a => a -> a -> Bool
>= a
o    = a
x forall a. Num a => a -> a -> a
- a
o
      | Bool
otherwise = a
o forall a. Num a => a -> a -> a
- a
x

{-------------------------------------------------------------------------------
  Constructing ranges
-------------------------------------------------------------------------------}

-- | Uniform selection between the given bounds, shrinking towards first bound
between :: forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
between :: forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
between = forall a. (FiniteBits a, Integral a) => Double -> (a, a) -> Range a
skewedBy Double
0

-- | Variation on 'between' for types that are 'Enum' but not 'Integral'
--
-- This is useful for types such as 'Char'. However, since this relies on
-- 'Enum', it's limited by the precision of 'Int'.
enum :: Enum a => (a, a) -> Range a
enum :: forall a. Enum a => (a, a) -> Range a
enum (a
x, a
y) = forall a. Enum a => Int -> a
toEnum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
between (forall a. Enum a => a -> Int
fromEnum a
x, forall a. Enum a => a -> Int
fromEnum a
y)

-- | Selection within the given bounds, shrinking towards the specified origin
--
-- All else being equal, prefers values in the /second/ half of the range
-- (in the common case of say @withOrigin (-100, 100) 0@, this means we prefer
-- positive values).
withOrigin :: (Integral a, FiniteBits a) => (a, a) -> a -> Range a
withOrigin :: forall a. (Integral a, FiniteBits a) => (a, a) -> a -> Range a
withOrigin (a
x, a
y) a
o
  | Bool -> Bool
not Bool
originInBounds
  = forall a. HasCallStack => [Char] -> a
error [Char]
"withOrigin: origin not within bounds"

  -- Since origin must be within bounds, we must have x == o == y here
  | a
x forall a. Eq a => a -> a -> Bool
== a
y
  = forall a. a -> Range a
Constant a
x

  | a
o forall a. Eq a => a -> a -> Bool
== a
x
  = forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
between (a
x, a
y)

  | a
o forall a. Eq a => a -> a -> Bool
== a
y
  = forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
between (a
y, a
x)

-- Split the range into two halves. We are careful to do this only when needed:
-- if we didn't (i.e., if the origin /equals/ one of the endpoints), that would
-- result in a singleton range, and since that singleton range (by definition)
-- would be at the origin, we would only ever produce that one value.
  | Bool
otherwise =
      forall a. (Ord a, Num a) => a -> [Range a] -> Range a
towards a
o [
          forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
between (a
o, a
y)
        , forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
between (a
o, a
x)
        ]
  where
    originInBounds :: Bool
    originInBounds :: Bool
originInBounds
      | a
x forall a. Ord a => a -> a -> Bool
<= a
o Bool -> Bool -> Bool
&& a
o forall a. Ord a => a -> a -> Bool
<= a
y = Bool
True
      | a
y forall a. Ord a => a -> a -> Bool
<= a
o Bool -> Bool -> Bool
&& a
o forall a. Ord a => a -> a -> Bool
<= a
x = Bool
True
      | Bool
otherwise        = Bool
False

{-------------------------------------------------------------------------------
  Skew

  To introduce skew, we want something that is reasonably simply to implement
  but also has some reasonal properties. Suppose a skew of @s@ means that we
  generate value from the lower 20% of the range 60% of the time. Then:

  - Symmetry around the antidiagonal: we will generate a value from the
    upper 60% of the range 20% of the time.

  - Symmetry around the diagonal: a skew of @-s@ will mean we generate a value
    from the /upper/ 20% of the range 60% of the time.

  To derive the formula we use, suppose we start with a circle with radius 1,
  centered at the origin:

  > x^2 + y^2 == 1
  >       y^2 == 1 - x^2
  >       y   == (1 - x^2) ^ (1/2)

  In the interval [0, 1] this gives us the upper right quadrant of the circle,
  but we want the lower right:

  > y == 1 - ((1 - x^2) ^ (1/2))

  We can now vary that power.

  > y == 1 - ((1 - x^3) ^ (1/3))
  > y == 1 - ((1 - x^4) ^ (1/4))
  > ..

  If the power is 1, we get no skew:

  > y == 1 - ((1 - x^1) ^ (1/1))
  >   == 1 - (1 - x)
  >   == x

  We want a skew of 0 to mean no skew, so in terms of s:

  > y == 1 - ((1 - x^(s+1)) ^ (1/(s+1)))

  For negative values of @s@, we flip this around the diagonal:

  > y == 1 - (1 - ((1 - (1-x)^(s+1)) ^ (1/(s+1))))
  >   ==           (1 - (1-x)^(s+1)) ^ (1/(s+1))

  giving us

  > (1 - (1 - x)^2)^(1/2)  for s == -1
  > (1 - (1 - x)^3)^(1/3)  for s == -2
  > etc.
-------------------------------------------------------------------------------}

-- | Introduce skew (non-uniform selection)
--
-- A skew of @s == 0@ means no skew: uniform selection.
--
-- A positive skew @(s > 0)@ introduces a bias towards smaller values (this is
-- the typical use case). As example, for a skew of @s == 1@:
--
-- * We will generate a value from the lower 20% of the range 60% of the time.
-- * We will generate a value from the upper 60% of the range 20% of the time.
--
-- A negative skew @(s < 0)@ introduces a bias towards larger values. For a
-- skew of @s == 1@:
--
-- * We will generate a value from the upper 20% of the range 60% of the time.
-- * We will generate a value from the lower 60% of the range 20% of the time.
--
-- The table below lists values for the percentage of the range used, given a
-- percentage of the time (a value of 0 means a single value from the range):
--
-- >    | time%
-- >  s | 50% | 90%
-- > --------------
-- >  0 |  50 |  90
-- >  1 |  13 |  56
-- >  2 |   4 |  35
-- >  3 |   1 |  23
-- >  4 |   0 |  16
-- >  5 |   0 |  11
-- >  6 |   0 |   8
-- >  7 |   0 |   6
-- >  8 |   0 |   5
-- >  9 |   0 |   4
-- > 10 |   0 |   3
--
-- Will shrink towards @x@, independent of skew.
--
-- NOTE: The implementation currently uses something similar to μ-law encoding.
-- As a consequence, the generator gets increased precision near the end of the
-- range we skew towards, and less precision near the other end. This means that
-- not all values in the range can be produced.
skewedBy :: forall a. (FiniteBits a, Integral a) => Double -> (a, a) -> Range a
skewedBy :: forall a. (FiniteBits a, Integral a) => Double -> (a, a) -> Range a
skewedBy Double
s (a
x, a
y)
  | a
x forall a. Eq a => a -> a -> Bool
== a
y    = forall a. a -> Range a
constant a
x
  | a
x forall a. Ord a => a -> a -> Bool
< a
y     = let p :: Precision
p = forall a. FiniteBits a => a -> Precision
precisionRequiredToRepresent (a
y forall a. Num a => a -> a -> a
- a
x)
                in forall a. Precision -> (ProperFraction -> a) -> Range a
fromProperFraction Precision
p forall a b. (a -> b) -> a -> b
$ \(ProperFraction Double
f) -> Double -> a
roundDown Double
f
  | Bool
otherwise = let p :: Precision
p = forall a. FiniteBits a => a -> Precision
precisionRequiredToRepresent (a
x forall a. Num a => a -> a -> a
- a
y)
                in forall a. Precision -> (ProperFraction -> a) -> Range a
fromProperFraction Precision
p forall a b. (a -> b) -> a -> b
$ \(ProperFraction Double
f) -> Double -> a
roundUp   Double
f
  where
    x', y' :: Double
    x' :: Double
x' = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x
    y' :: Double
y' = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
y

    -- We have to be careful here. Perhaps the more obvious way to express this
    -- calculation is
    --
    -- > round $ x' + skew f * (y' - x')
    --
    -- However, this leads to a bad distribution of test data. Suppose we are
    -- generating values in the range [0 .. 2]. Then that call to 'round'
    -- would result in something like this:
    --
    -- >  0..............1..............2
    -- > [       /\             /\      ]
    -- >  ^^^^^^^^  ^^^^^^^^^^^^  ^^^^^^
    -- >     0            1           2
    --
    -- To avoid this heavy bias, we instead do this:
    --
    -- >  0..............1..............2..............3
    -- > [              /\             /\               ]
    -- >  ^^^^^^^^^^^^^^  ^^^^^^^^^^^^^  ^^^^^^^^^^^^^^^
    -- >        0                1              2
    --
    -- By insisting that the fraction is a /proper/ fraction (i.e., not equal to
    -- 1), we avoid generating @3@ (which would be outside the range).
    roundDown, roundUp :: Double -> a
    roundDown :: Double -> a
roundDown Double
f = forall a b. (RealFrac a, Integral b) => a -> b
floor   forall a b. (a -> b) -> a -> b
$ Double
x' forall a. Num a => a -> a -> a
+ Double -> Double
skew Double
f forall a. Num a => a -> a -> a
* (Double
y' forall a. Num a => a -> a -> a
- Double
x' forall a. Num a => a -> a -> a
+ Double
1)
    roundUp :: Double -> a
roundUp   Double
f = forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ Double
x' forall a. Num a => a -> a -> a
- Double -> Double
skew Double
f forall a. Num a => a -> a -> a
* (Double
x' forall a. Num a => a -> a -> a
- Double
y' forall a. Num a => a -> a -> a
+ Double
1)

    pos, neg :: Double -> Double
    pos :: Double -> Double
pos Double
f = Double
1 forall a. Num a => a -> a -> a
- ((Double
1 forall a. Num a => a -> a -> a
-      Double
f  forall a. Floating a => a -> a -> a
** (Double
s forall a. Num a => a -> a -> a
+ Double
1)) forall a. Floating a => a -> a -> a
** (Double
1 forall a. Fractional a => a -> a -> a
/ (    Double
s forall a. Num a => a -> a -> a
+ Double
1)))
    neg :: Double -> Double
neg Double
f =      (Double
1 forall a. Num a => a -> a -> a
- (Double
1 forall a. Num a => a -> a -> a
- Double
f) forall a. Floating a => a -> a -> a
** (Double
s forall a. Num a => a -> a -> a
+ Double
1)) forall a. Floating a => a -> a -> a
** (Double
1 forall a. Fractional a => a -> a -> a
/ (forall a. Num a => a -> a
abs Double
s forall a. Num a => a -> a -> a
+ Double
1))

    skew :: Double -> Double
    skew :: Double -> Double
skew | Double
s forall a. Eq a => a -> a -> Bool
== Double
0    = forall a. a -> a
id
         | Double
s forall a. Ord a => a -> a -> Bool
>= Double
0    = Double -> Double
pos
         | Bool
otherwise = Double -> Double
neg

{-------------------------------------------------------------------------------
  Precision
-------------------------------------------------------------------------------}

-- | Precision required to be able to choose within the given range
--
-- In order to avoid rounding errors, we set a lower bound on the precision.
-- This lower bound is verified in "TestSuite.Sanity.Range", which verifies that
-- for small ranges, the expected distribution is never off by more than 1%
-- from the actual distribution.
precisionRequiredToRepresent :: forall a. FiniteBits a => a -> Precision
precisionRequiredToRepresent :: forall a. FiniteBits a => a -> Precision
precisionRequiredToRepresent a
x = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$
    Int
7 forall a. Ord a => a -> a -> a
`max` (forall b. FiniteBits b => b -> Int
finiteBitSize (forall a. HasCallStack => a
undefined :: a) forall a. Num a => a -> a -> a
- forall b. FiniteBits b => b -> Int
countLeadingZeros a
x)

{-------------------------------------------------------------------------------
  Queries
-------------------------------------------------------------------------------}

-- | Origin of the range (value we shrink towards)
origin ::  Range a -> a
origin :: forall a. Range a -> a
origin = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Applicative f =>
(Precision -> f ProperFraction) -> Range a -> f a
eval (\Precision
_precision -> forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ Double -> ProperFraction
ProperFraction Double
0)

{-------------------------------------------------------------------------------
  Evaluation
-------------------------------------------------------------------------------}

-- | Evaluate a range, given an action to generate fractions
--
-- Most users will probably never need to call this function.
eval :: forall f a.
     Applicative f
  => (Precision -> f ProperFraction) -> Range a -> f a
eval :: forall (f :: * -> *) a.
Applicative f =>
(Precision -> f ProperFraction) -> Range a -> f a
eval Precision -> f ProperFraction
genFraction = forall x. Range x -> f x
go
  where
    go :: forall x. Range x -> f x
    go :: forall x. Range x -> f x
go Range x
r =
        case Range x
r of
          Constant x
x             -> forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x
          FromProperFraction Precision
p ProperFraction -> x
f -> ProperFraction -> x
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precision -> f ProperFraction
genFraction Precision
p
          Smallest NonEmpty (Range (x, b))
rs            -> forall b x. Ord b => NonEmpty (x, b) -> x
smallest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall x. Range x -> f x
go NonEmpty (Range (x, b))
rs)

    smallest :: Ord b => NonEmpty (x, b) -> x
    smallest :: forall b x. Ord b => NonEmpty (x, b) -> x
smallest = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NE.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd)