module Test.Falsify.Range (
Range
, uniform
, inclusive
, enum
, withOrigin
, skewedBy
, origin
, constant
, fromProperFraction
, towards
, eval
) where
import Data.Bits
import Data.Functor.Identity
import Data.List.NonEmpty (NonEmpty(..))
import Data.Ord
import Data.Word
import qualified Data.List.NonEmpty as NE
import Data.Falsify.ProperFraction (ProperFraction(..))
import Data.Falsify.WordN (WordN)
import Test.Falsify.Internal.Range
import qualified Data.Falsify.WordN as WordN
constant :: a -> Range a
constant :: forall a. a -> Range a
constant = a -> Range a
forall a. a -> Range a
Constant
fromProperFraction :: WordN.Precision -> (ProperFraction -> a) -> Range a
fromProperFraction :: forall a. Precision -> (ProperFraction -> a) -> Range a
fromProperFraction Precision
p ProperFraction -> a
f = Precision -> (WordN -> a) -> Range a
forall a. Precision -> (WordN -> a) -> Range a
FromWordN Precision
p ((WordN -> a) -> Range a) -> (WordN -> a) -> Range a
forall a b. (a -> b) -> a -> b
$ ProperFraction -> a
f (ProperFraction -> a) -> (WordN -> ProperFraction) -> WordN -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WordN -> ProperFraction
WordN.toProperFraction
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 [] = a -> Range a
forall a. a -> Range a
Constant a
o
towards a
o (Range a
r:[Range a]
rs) = NonEmpty (Range (a, a)) -> Range a
forall b a. Ord b => NonEmpty (Range (a, b)) -> Range a
Smallest (NonEmpty (Range (a, a)) -> Range a)
-> NonEmpty (Range (a, a)) -> Range a
forall a b. (a -> b) -> a -> b
$ (Range a -> Range (a, a))
-> NonEmpty (Range a) -> NonEmpty (Range (a, a))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Range a -> Range (a, a)
aux (Range a
r Range a -> [Range a] -> NonEmpty (Range a)
forall a. a -> [a] -> NonEmpty a
:| [Range a]
rs)
where
aux :: Range a -> Range (a, a)
aux :: Range a -> Range (a, a)
aux = (a -> (a, a)) -> Range a -> Range (a, a)
forall a b. (a -> b) -> Range a -> Range b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> (a, a)) -> Range a -> Range (a, a))
-> (a -> (a, a)) -> Range a -> Range (a, a)
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 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
o = a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
o
| Bool
otherwise = a
o a -> a -> a
forall a. Num a => a -> a -> a
- a
x
uniform :: forall a. (Integral a, FiniteBits a, Bounded a) => Range a
uniform :: forall a. (Integral a, FiniteBits a, Bounded a) => Range a
uniform = Precision -> (WordN -> a) -> Range a
forall a. Precision -> (WordN -> a) -> Range a
FromWordN Precision
precision ((WordN -> a) -> Range a) -> (WordN -> a) -> Range a
forall a b. (a -> b) -> a -> b
$ \WordN
x ->
if Bool
isUnsigned
then Word64 -> a
toUnsigned (WordN -> Word64
WordN.forgetPrecision WordN
x)
else Word64 -> a
toSigned (WordN -> Word64
WordN.forgetPrecision WordN
x)
where
precision :: WordN.Precision
precision :: Precision
precision = Word8 -> Precision
WordN.Precision (Word8 -> Precision) -> Word8 -> Precision
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ a -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (a
forall a. HasCallStack => a
undefined :: a)
isUnsigned :: Bool
isUnsigned :: Bool
isUnsigned = a -> a
forall a. Num a => a -> a
signum (-a
1 :: a) a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1
toUnsigned :: Word64 -> a
toUnsigned :: Word64 -> a
toUnsigned = Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral
toSigned :: Word64 -> a
toSigned :: Word64 -> a
toSigned Word64
x
| Word64
x Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
maxPos = Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x
| Bool
otherwise = (a
forall a. Bounded a => a
maxBound :: a) a -> a -> a
forall a. Num a => a -> a -> a
- Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x
where
maxPos :: Word64
maxPos :: Word64
maxPos = a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
forall a. Bounded a => a
maxBound :: a)
inclusive :: forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
inclusive :: forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
inclusive = Double -> (a, a) -> Range a
forall a. (FiniteBits a, Integral a) => Double -> (a, a) -> Range a
skewedBy Double
0
enum :: Enum a => (a, a) -> Range a
enum :: forall a. Enum a => (a, a) -> Range a
enum (a
x, a
y) = Int -> a
forall a. Enum a => Int -> a
toEnum (Int -> a) -> Range Int -> Range a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Range Int
forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
inclusive (a -> Int
forall a. Enum a => a -> Int
fromEnum a
x, a -> Int
forall a. Enum a => a -> Int
fromEnum a
y)
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
= [Char] -> Range a
forall a. HasCallStack => [Char] -> a
error [Char]
"withOrigin: origin not within bounds"
| a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
= a -> Range a
forall a. a -> Range a
Constant a
x
| a
o a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x
= (a, a) -> Range a
forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
inclusive (a
x, a
y)
| a
o a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
= (a, a) -> Range a
forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
inclusive (a
y, a
x)
| Bool
otherwise =
a -> [Range a] -> Range a
forall a. (Ord a, Num a) => a -> [Range a] -> Range a
towards a
o [
(a, a) -> Range a
forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
inclusive (a
o, a
y)
, (a, a) -> Range a
forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
inclusive (a
o, a
x)
]
where
originInBounds :: Bool
originInBounds :: Bool
originInBounds
| a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
o Bool -> Bool -> Bool
&& a
o a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y = Bool
True
| a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
o Bool -> Bool -> Bool
&& a
o a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
x = Bool
True
| Bool
otherwise = Bool
False
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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = a -> Range a
forall a. a -> Range a
constant a
x
| a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y = let p :: Precision
p = a -> Precision
forall a. FiniteBits a => a -> Precision
precisionRequiredToRepresent (a
y a -> a -> a
forall a. Num a => a -> a -> a
- a
x)
in Precision -> (ProperFraction -> a) -> Range a
forall a. Precision -> (ProperFraction -> a) -> Range a
fromProperFraction Precision
p ((ProperFraction -> a) -> Range a)
-> (ProperFraction -> a) -> Range a
forall a b. (a -> b) -> a -> b
$ \(ProperFraction Double
f) -> Double -> a
roundDown Double
f
| Bool
otherwise = let p :: Precision
p = a -> Precision
forall a. FiniteBits a => a -> Precision
precisionRequiredToRepresent (a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
y)
in Precision -> (ProperFraction -> a) -> Range a
forall a. Precision -> (ProperFraction -> a) -> Range a
fromProperFraction Precision
p ((ProperFraction -> a) -> Range a)
-> (ProperFraction -> a) -> Range a
forall a b. (a -> b) -> a -> b
$ \(ProperFraction Double
f) -> Double -> a
roundUp Double
f
where
x', y' :: Double
x' :: Double
x' = a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x
y' :: Double
y' = a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
y
roundDown, roundUp :: Double -> a
roundDown :: Double -> a
roundDown Double
f = Double -> a
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> a) -> Double -> a
forall a b. (a -> b) -> a -> b
$ Double
x' Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
skew Double
f Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
y' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
x' Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1)
roundUp :: Double -> a
roundUp Double
f = Double -> a
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> a) -> Double -> a
forall a b. (a -> b) -> a -> b
$ Double
x' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double
skew Double
f Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
x' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y' Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1)
pos, neg :: Double -> Double
pos :: Double -> Double
pos Double
f = Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- ((Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
f Double -> Double -> Double
forall a. Floating a => a -> a -> a
** (Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1)) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ ( Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1)))
neg :: Double -> Double
neg Double
f = (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
f) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** (Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1)) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double -> Double
forall a. Num a => a -> a
abs Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1))
skew :: Double -> Double
skew :: Double -> Double
skew | Double
s Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 = Double -> Double
forall a. a -> a
id
| Double
s Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 = Double -> Double
pos
| Bool
otherwise = Double -> Double
neg
precisionRequiredToRepresent :: forall a. FiniteBits a => a -> WordN.Precision
precisionRequiredToRepresent :: forall a. FiniteBits a => a -> Precision
precisionRequiredToRepresent a
x = Int -> Precision
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Precision) -> Int -> Precision
forall a b. (a -> b) -> a -> b
$
Int
7 Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` (a -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (a
forall a. HasCallStack => a
undefined :: a) Int -> Int -> Int
forall a. Num a => a -> a -> a
- a -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros a
x)
origin :: Range a -> a
origin :: forall a. Range a -> a
origin = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (Range a -> Identity a) -> Range a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Precision -> Identity WordN) -> Range a -> Identity a
forall (f :: * -> *) a.
Applicative f =>
(Precision -> f WordN) -> Range a -> f a
eval (\Precision
p -> WordN -> Identity WordN
forall a. a -> Identity a
Identity (WordN -> Identity WordN) -> WordN -> Identity WordN
forall a b. (a -> b) -> a -> b
$ Precision -> WordN
WordN.zero Precision
p)
eval :: forall f a.
Applicative f
=> (WordN.Precision -> f WordN) -> Range a -> f a
eval :: forall (f :: * -> *) a.
Applicative f =>
(Precision -> f WordN) -> Range a -> f a
eval Precision -> f WordN
genWordN = Range a -> f a
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 -> x -> f x
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x
FromWordN Precision
p WordN -> x
f -> WordN -> x
f (WordN -> x) -> f WordN -> f x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Precision -> f WordN
genWordN Precision
p
Smallest NonEmpty (Range (x, b))
rs -> NonEmpty (x, b) -> x
forall b x. Ord b => NonEmpty (x, b) -> x
smallest (NonEmpty (x, b) -> x) -> f (NonEmpty (x, b)) -> f x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (f (x, b)) -> f (NonEmpty (x, b))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
NonEmpty (f a) -> f (NonEmpty a)
sequenceA ((Range (x, b) -> f (x, b))
-> NonEmpty (Range (x, b)) -> NonEmpty (f (x, b))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Range (x, b) -> f (x, b)
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 = (x, b) -> x
forall a b. (a, b) -> a
fst ((x, b) -> x)
-> (NonEmpty (x, b) -> (x, b)) -> NonEmpty (x, b) -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (x, b) -> (x, b)
forall a. NonEmpty a -> a
NE.head (NonEmpty (x, b) -> (x, b))
-> (NonEmpty (x, b) -> NonEmpty (x, b))
-> NonEmpty (x, b)
-> (x, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((x, b) -> (x, b) -> Ordering)
-> NonEmpty (x, b) -> NonEmpty (x, b)
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy (((x, b) -> b) -> (x, b) -> (x, b) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (x, b) -> b
forall a b. (a, b) -> b
snd)