{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module Constrained.SumList where
import Data.Either (partitionEithers)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Semigroup (sconcat)
import System.Random (Random (..))
import Test.QuickCheck (Arbitrary, Gen, choose, shuffle, vectorOf)
import Constrained.Base
import Constrained.Conformance (conformsToSpec)
import Constrained.Core (Value (..))
import Constrained.GenT (
GE (..),
GenT,
MonadGenError (..),
oneofT,
pureGen,
push,
scaleT,
sizeT,
suchThatT,
tryGenT,
)
import Constrained.List (List (..), ListCtx (..))
import Constrained.NumSpec (
IntW (..),
MaybeBounded (..),
NumSpec (..),
Numeric,
geqSpec,
gtSpec,
leqSpec,
ltSpec,
nubOrd,
)
import Control.Applicative ((<|>))
import Control.Monad (guard)
import Data.List ((\\))
import Data.Maybe (fromMaybe, isNothing, listToMaybe)
import qualified Data.Set as Set
import GHC.Stack
import Prettyprinter hiding (cat)
class HasSpec a => Complete a where
simplifyA :: Specification a -> Specification a
genFromSpecA :: forall m. (HasCallStack, HasSpec a, MonadGenError m) => Specification a -> GenT m a
theAddA :: Numeric a => IntW '[a, a] a
theAddA = forall b. NumLike b => IntW '[b, b] b
AddW
noNegativeValues :: forall a. (Num a, Eq a, MaybeBounded a) => Bool
noNegativeValues :: forall a. (Num a, Eq a, MaybeBounded a) => Bool
noNegativeValues = forall a. MaybeBounded a => Maybe a
lowerBound @a forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just a
0
knownUpperBound ::
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a ->
Maybe a
knownUpperBound :: forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound (ExplainSpec [String]
_ Specification a
s) = forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification a
s
knownUpperBound Specification a
TrueSpec = forall a. MaybeBounded a => Maybe a
upperBound
knownUpperBound (MemberSpec NonEmpty a
as) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum NonEmpty a
as
knownUpperBound ErrorSpec {} = forall a. Maybe a
Nothing
knownUpperBound SuspendedSpec {} = forall a. MaybeBounded a => Maybe a
upperBound
knownUpperBound (TypeSpec (NumSpecInterval Maybe a
lo Maybe a
hi) [a]
cant) = Maybe a -> Maybe a -> Maybe a
upper (Maybe a
lo forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. MaybeBounded a => Maybe a
lowerBound) (Maybe a
hi forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. MaybeBounded a => Maybe a
upperBound)
where
upper :: Maybe a -> Maybe a -> Maybe a
upper Maybe a
_ Maybe a
Nothing = forall a. Maybe a
Nothing
upper Maybe a
Nothing (Just a
b) = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ [a
b, a
b forall a. Num a => a -> a -> a
- a
1 ..] forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
cant
upper (Just a
a) (Just a
b)
| a
a forall a. Eq a => a -> a -> Bool
== a
b = a
a forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
a forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
cant)
| Bool
otherwise = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ [a
b, a
b forall a. Num a => a -> a -> a
- a
1 .. a
a] forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
cant
knownLowerBound ::
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a ->
Maybe a
knownLowerBound :: forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownLowerBound (ExplainSpec [String]
_ Specification a
s) = forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownLowerBound Specification a
s
knownLowerBound Specification a
TrueSpec = forall a. MaybeBounded a => Maybe a
lowerBound
knownLowerBound (MemberSpec NonEmpty a
as) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum NonEmpty a
as
knownLowerBound ErrorSpec {} = forall a. Maybe a
Nothing
knownLowerBound SuspendedSpec {} = forall a. MaybeBounded a => Maybe a
lowerBound
knownLowerBound (TypeSpec (NumSpecInterval Maybe a
lo Maybe a
hi) [a]
cant) =
Maybe a -> Maybe a -> Maybe a
lower (Maybe a
lo forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. MaybeBounded a => Maybe a
lowerBound) (Maybe a
hi forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. MaybeBounded a => Maybe a
upperBound)
where
lower :: Maybe a -> Maybe a -> Maybe a
lower Maybe a
Nothing Maybe a
_ = forall a. Maybe a
Nothing
lower (Just a
a) Maybe a
Nothing = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ [a
a, a
a forall a. Num a => a -> a -> a
+ a
1 ..] forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
cant
lower (Just a
a) (Just a
b)
| a
a forall a. Eq a => a -> a -> Bool
== a
b = a
a forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a
a forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
cant)
| Bool
otherwise = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ [a
a, a
a forall a. Num a => a -> a -> a
+ a
1 .. a
b] forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
cant
isEmptyNumSpec ::
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) => Specification a -> Bool
isEmptyNumSpec :: forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Bool
isEmptyNumSpec = \case
ExplainSpec [String]
_ Specification a
s -> forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Bool
isEmptyNumSpec Specification a
s
ErrorSpec {} -> Bool
True
Specification a
TrueSpec -> Bool
False
MemberSpec NonEmpty a
_ -> Bool
False
SuspendedSpec {} -> Bool
False
TypeSpec TypeSpec a
i [a]
cant -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a. (Enum a, Num a, MaybeBounded a) => NumSpec a -> [a]
enumerateInterval TypeSpec a
i forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
cant
enumerateInterval :: (Enum a, Num a, MaybeBounded a) => NumSpec a -> [a]
enumerateInterval :: forall a. (Enum a, Num a, MaybeBounded a) => NumSpec a -> [a]
enumerateInterval (NumSpecInterval Maybe a
lo Maybe a
hi) =
case (Maybe a
lo forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. MaybeBounded a => Maybe a
lowerBound, Maybe a
hi forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. MaybeBounded a => Maybe a
upperBound) of
(Maybe a
Nothing, Maybe a
Nothing) -> forall {a}. [a] -> [a] -> [a]
interleave [a
0 ..] [-a
1, -a
2 ..]
(Maybe a
Nothing, Just a
b) -> [a
b, a
b forall a. Num a => a -> a -> a
- a
1 ..]
(Just a
a, Maybe a
Nothing) -> [a
a ..]
(Just a
a, Just a
b) -> [a
a .. a
b]
where
interleave :: [a] -> [a] -> [a]
interleave [] [a]
ys = [a]
ys
interleave (a
x : [a]
xs) [a]
ys = a
x forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
interleave [a]
ys [a]
xs
genNumList ::
forall a m.
( MonadGenError m
, Arbitrary a
, Integral a
, MaybeBounded a
, TypeSpec a ~ NumSpec a
,
Random a
, Complete a
) =>
Specification a ->
Specification a ->
GenT m [a]
genNumList :: forall a (m :: * -> *).
(MonadGenError m, Arbitrary a, Integral a, MaybeBounded a,
TypeSpec a ~ NumSpec a, Random a, Complete a) =>
Specification a -> Specification a -> GenT m [a]
genNumList Specification a
elemSIn Specification a
foldSIn = do
let extraElemConstraints :: Specification a
extraElemConstraints
| Just a
l <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownLowerBound Specification a
elemSIn
, a
0 forall a. Ord a => a -> a -> Bool
<= a
l
, Just a
u <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification a
foldSIn =
forall a. OrdLike a => a -> Specification a
leqSpec a
u
| Bool
otherwise = forall a. Specification a
TrueSpec
elemSIn' :: Specification a
elemSIn' = Specification a
elemSIn forall a. Semigroup a => a -> a -> a
<> Specification a
extraElemConstraints
Specification a
normElemS <- Specification a -> GenT m (Specification a)
normalize Specification a
elemSIn'
Specification a
normFoldS <- Specification a -> GenT m (Specification a)
normalize Specification a
foldSIn
let narrowedSpecs :: (Specification a, Specification a)
narrowedSpecs = forall a.
(TypeSpec a ~ NumSpec a, Arbitrary a, Integral a, Random a,
MaybeBounded a, Complete a) =>
(Specification a, Specification a)
-> (Specification a, Specification a)
narrowFoldSpecs (Specification a
normElemS, Specification a
normFoldS)
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a -> m a
explainNE
( forall a. [a] -> NonEmpty a
NE.fromList
[ String
"Can't generate list of ints with fold constraint"
, String
" elemSpec = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Specification a
elemSIn
, String
" normElemSpec = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Specification a
normElemS
, String
" foldSpec = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Specification a
foldSIn
]
)
forall a b. (a -> b) -> a -> b
$ forall (m' :: * -> *).
MonadGenError m' =>
(Specification a, Specification a) -> Int -> [a] -> GenT m' [a]
gen (Specification a, Specification a)
narrowedSpecs Int
50 [] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Gen [a]
shuffle
where
normalize :: Specification a -> GenT m (Specification a)
normalize (ExplainSpec [String]
es Specification a
x) = forall a. [String] -> Specification a -> Specification a
explainSpecOpt [String]
es forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Specification a -> GenT m (Specification a)
normalize Specification a
x
normalize spec :: Specification a
spec@SuspendedSpec {} = do
Int
sz <- forall (m :: * -> *). Monad m => GenT m Int
sizeT
Specification a
spec' <- Int -> Int -> Set a -> Specification a -> GenT m (Specification a)
buildMemberSpec Int
sz (Int
100 :: Int) forall a. Monoid a => a
mempty Specification a
spec
Specification a -> GenT m (Specification a)
normalize forall a b. (a -> b) -> a -> b
$ Specification a
spec'
normalize Specification a
spec =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. OrdLike a => a -> Specification a
geqSpec forall a. MaybeBounded a => Maybe a
lowerBound
forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. OrdLike a => a -> Specification a
leqSpec forall a. MaybeBounded a => Maybe a
upperBound
forall a. Semigroup a => a -> a -> a
<> Specification a
spec
buildMemberSpec :: Int -> Int -> Set a -> Specification a -> GenT m (Specification a)
buildMemberSpec Int
_ Int
0 Set a
es Specification a
_ =
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall a. [a] -> NonEmpty String -> Specification a
memberSpecList
(forall a. Set a -> [a]
Set.toList Set a
es)
(forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"In genNumList, in buildMemberSpec 'es' is the empty list, can't make a MemberSpec from that")
)
buildMemberSpec Int
sz Int
fuel Set a
es Specification a
spec = do
Maybe a
me <- forall (m :: * -> *) a. (Int -> Int) -> GenT m a -> GenT m a
scaleT (forall a b. a -> b -> a
const Int
sz) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadGenError m =>
GenT GE a -> GenT m (Maybe a)
tryGenT (forall a (m :: * -> *).
(Complete a, HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecA @a Specification a
spec)
let sz' :: Int
sz'
| Int
sz forall a. Ord a => a -> a -> Bool
> Int
100 = Int
sz
| forall a. Maybe a -> Bool
isNothing Maybe a
me = Int
2 forall a. Num a => a -> a -> a
* Int
sz forall a. Num a => a -> a -> a
+ Int
1
| Just a
e <- Maybe a
me, forall a. Ord a => a -> Set a -> Bool
Set.member a
e Set a
es = Int
2 forall a. Num a => a -> a -> a
* Int
sz forall a. Num a => a -> a -> a
+ Int
1
| Bool
otherwise = Int
sz
Int -> Int -> Set a -> Specification a -> GenT m (Specification a)
buildMemberSpec
Int
sz'
(Int
fuel forall a. Num a => a -> a -> a
- Int
1)
(forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set a
es (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> Set a -> Set a
Set.insert Set a
es) Maybe a
me)
Specification a
spec
gen ::
forall m'. MonadGenError m' => (Specification a, Specification a) -> Int -> [a] -> GenT m' [a]
gen :: forall (m' :: * -> *).
MonadGenError m' =>
(Specification a, Specification a) -> Int -> [a] -> GenT m' [a]
gen (Specification a
elemS, Specification a
foldS) Int
fuel [a]
lst
| Int
fuel forall a. Ord a => a -> a -> Bool
<= Int
0
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ a
0 forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
foldS =
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a
genErrorNE forall a b. (a -> b) -> a -> b
$
forall a. [a] -> NonEmpty a
NE.fromList
[ String
"Ran out of fuel in genNumList"
, String
" elemSpec =" forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Specification a
elemSIn
, String
" foldSpec = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Specification a
foldSIn
, String
" lst = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. [a] -> [a]
reverse [a]
lst)
]
| ErrorSpec NonEmpty String
err <- Specification a
foldS = forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a
genErrorNE NonEmpty String
err
| ErrorSpec {} <- Specification a
elemS = forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
lst
| a
0 forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
foldS = forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
[GenT GE a] -> GenT m a
oneofT [forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
lst, forall (m'' :: * -> *). MonadGenError m'' => GenT m'' [a]
nonemptyList @GE]
| Bool
otherwise = forall (m'' :: * -> *). MonadGenError m'' => GenT m'' [a]
nonemptyList
where
isUnsat :: (Specification a, Specification a) -> Bool
isUnsat (Specification a
elemSpec, Specification a
foldSpec) = forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Bool
isEmptyNumSpec Specification a
foldSpec Bool -> Bool -> Bool
|| Bool -> Bool
not (a
0 forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
foldSpec) Bool -> Bool -> Bool
&& forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Bool
isEmptyNumSpec Specification a
elemSpec
nonemptyList :: forall m''. MonadGenError m'' => GenT m'' [a]
nonemptyList :: forall (m'' :: * -> *). MonadGenError m'' => GenT m'' [a]
nonemptyList = do
(a
x, (Specification a, Specification a)
specs') <-
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a -> m a
explainNE
( forall a. [a] -> NonEmpty a
NE.fromList
[ String
"Generating an element:"
, String
" elemS = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Specification a
elemS
, String
" foldS = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Specification a
foldS
, String
" fuel = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
fuel
, String
" lst = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. [a] -> [a]
reverse [a]
lst)
]
)
forall a b. (a -> b) -> a -> b
$ do
Int
sz <- forall (m :: * -> *). Monad m => GenT m Int
sizeT
a
x <- forall a (m :: * -> *).
(Complete a, HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecA @a Specification a
elemS
let foldS' :: Specification a
foldS' = forall (t :: [*] -> * -> *) (as :: [*]) b a.
(Logic t, AppRequires t as b, HasSpec a) =>
t as b
-> ListCtx Value as (HOLE a) -> Specification b -> Specification a
propagate forall a. (Complete a, Numeric a) => IntW '[a, a] a
theAddA (forall {k} (a :: k). HOLE a a
HOLE forall (c :: * -> *) a (f :: * -> *) (as1 :: [*]).
c a -> List f as1 -> ListCtx f (a : as1) c
:? forall a. Show a => a -> Value a
Value a
x forall {k} (f :: k -> *) (a :: k) (as1 :: [k]).
f a -> List f as1 -> List f (a : as1)
:> forall {k} (f :: k -> *). List f '[]
Nil) Specification a
foldS
specs' :: (Specification a, Specification a)
specs' = forall a.
(TypeSpec a ~ NumSpec a, Arbitrary a, Integral a, Random a,
MaybeBounded a, Complete a) =>
a
-> Int
-> (Specification a, Specification a)
-> (Specification a, Specification a)
narrowByFuelAndSize (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
fuel forall a. Num a => a -> a -> a
- Int
1) Int
sz (Specification a
elemS, Specification a
foldS')
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x, (Specification a, Specification a)
specs')
forall a (m :: * -> *).
(Typeable a, MonadGenError m) =>
GenT m a -> (a -> Bool) -> GenT m a
`suchThatT` Bool -> Bool
not
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a}.
(TypeSpec a ~ NumSpec a, TypeSpec a ~ NumSpec a, HasSpec a, Ord a,
Ord a, Enum a, Enum a, Num a, Num a, MaybeBounded a,
MaybeBounded a) =>
(Specification a, Specification a) -> Bool
isUnsat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
forall (m' :: * -> *).
MonadGenError m' =>
(Specification a, Specification a) -> Int -> [a] -> GenT m' [a]
gen (Specification a, Specification a)
specs' (Int
fuel forall a. Num a => a -> a -> a
- Int
1) (a
x forall a. a -> [a] -> [a]
: [a]
lst)
narrowFoldSpecs ::
forall a.
( TypeSpec a ~ NumSpec a
, Arbitrary a
, Integral a
, Random a
, MaybeBounded a
, Complete a
) =>
(Specification a, Specification a) ->
(Specification a, Specification a)
narrowFoldSpecs :: forall a.
(TypeSpec a ~ NumSpec a, Arbitrary a, Integral a, Random a,
MaybeBounded a, Complete a) =>
(Specification a, Specification a)
-> (Specification a, Specification a)
narrowFoldSpecs (Specification a, Specification a)
specs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Specification a, Specification a)
specs forall a.
(TypeSpec a ~ NumSpec a, Arbitrary a, Integral a, Random a,
MaybeBounded a, Complete a) =>
(Specification a, Specification a)
-> (Specification a, Specification a)
narrowFoldSpecs ((Specification a, Specification a)
-> Maybe (Specification a, Specification a)
go (Specification a, Specification a)
specs)
where
go :: (Specification a, Specification a) -> Maybe (Specification a, Specification a)
go :: (Specification a, Specification a)
-> Maybe (Specification a, Specification a)
go (forall a. Complete a => Specification a -> Specification a
simplifyA -> Specification a
elemS, forall a. Complete a => Specification a -> Specification a
simplifyA -> Specification a
foldS) = case (Specification a
elemS, Specification a
foldS) of
(Specification a
_, ErrorSpec {}) -> forall a. Maybe a
Nothing
(Specification a, Specification a)
_ | forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Bool
isEmptyNumSpec Specification a
foldS -> forall a. a -> Maybe a
Just (Specification a
elemS, forall a. NonEmpty String -> Specification a
ErrorSpec (forall a. [a] -> NonEmpty a
NE.fromList [String
"Empty foldSpec:", forall a. Show a => a -> String
show Specification a
foldS]))
(ErrorSpec {}, MemberSpec NonEmpty a
ys) | forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
ys forall a. Eq a => a -> a -> Bool
== [a
0] -> forall a. Maybe a
Nothing
(ErrorSpec {}, Specification a
_)
| a
0 forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
foldS -> forall a. a -> Maybe a
Just (Specification a
elemS, forall a. NonEmpty a -> Specification a
MemberSpec (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
0))
| Bool
otherwise ->
forall a. a -> Maybe a
Just
( Specification a
elemS
, forall a. NonEmpty String -> Specification a
ErrorSpec forall a b. (a -> b) -> a -> b
$
forall a. [a] -> NonEmpty a
NE.fromList
[ String
"Empty elemSpec and non-zero foldSpec"
, forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall ann. Int -> Doc ann -> Doc ann
indent Int
2 forall a b. (a -> b) -> a -> b
$ Doc Any
"elemSpec =" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Specification a
elemS
, forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall ann. Int -> Doc ann -> Doc ann
indent Int
2 forall a b. (a -> b) -> a -> b
$ Doc Any
"foldSpec =" forall ann. Doc ann -> Doc ann -> Doc ann
/> forall a ann. Pretty a => a -> Doc ann
pretty Specification a
foldS
]
)
(Specification a, Specification a)
_
| Just a
lo <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownLowerBound Specification a
elemS
, a
0 forall a. Ord a => a -> a -> Bool
<= a
lo
, Just a
hi <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification a
foldS
,
forall a. a -> Maybe a -> a
fromMaybe Bool
True ((a
hi forall a. Ord a => a -> a -> Bool
<) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification a
elemS) ->
forall a. a -> Maybe a
Just (Specification a
elemS forall a. Semigroup a => a -> a -> a
<> forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (forall n. Maybe n -> Maybe n -> NumSpec n
NumSpecInterval (forall a. a -> Maybe a
Just a
lo) (forall a. a -> Maybe a
Just a
hi)), Specification a
foldS)
(Specification a, Specification a)
_
| Just a
lo <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownLowerBound Specification a
elemS
, a
0 forall a. Ord a => a -> a -> Bool
<= a
lo
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ a
0 forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
foldS
,
forall a. a -> Maybe a -> a
fromMaybe Bool
True ((a
lo forall a. Ord a => a -> a -> Bool
>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownLowerBound Specification a
foldS) ->
forall a. a -> Maybe a
Just (Specification a
elemS, Specification a
foldS forall a. Semigroup a => a -> a -> a
<> forall a. HasSpec a => TypeSpec a -> Specification a
typeSpec (forall n. Maybe n -> Maybe n -> NumSpec n
NumSpecInterval (forall a. a -> Maybe a
Just a
lo) forall a. Maybe a
Nothing))
(Specification a, Specification a)
_
| Just a
lo <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownLowerBound Specification a
elemS
, Just a
loS <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownLowerBound Specification a
foldS
, Just a
hi <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification a
elemS
, Just a
hiS <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification a
foldS
, a
hi forall a. Ord a => a -> a -> Bool
< a
loS
, a
lo forall a. Ord a => a -> a -> Bool
> a
hiS forall a. Num a => a -> a -> a
- a
lo ->
forall a. a -> Maybe a
Just
( forall a. NonEmpty String -> Specification a
ErrorSpec forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList [String
"Can't solve diophantine equation"]
, forall a. NonEmpty String -> Specification a
ErrorSpec forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList [String
"Can't solve diophantine equation"]
)
(Specification a, Specification a)
_ -> forall a. Maybe a
Nothing
narrowByFuelAndSize ::
forall a.
( TypeSpec a ~ NumSpec a
, Arbitrary a
, Integral a
, Random a
, MaybeBounded a
, Complete a
) =>
a ->
Int ->
(Specification a, Specification a) ->
(Specification a, Specification a)
narrowByFuelAndSize :: forall a.
(TypeSpec a ~ NumSpec a, Arbitrary a, Integral a, Random a,
MaybeBounded a, Complete a) =>
a
-> Int
-> (Specification a, Specification a)
-> (Specification a, Specification a)
narrowByFuelAndSize a
fuel Int
size (Specification a, Specification a)
specpair =
Int
-> (Specification a, Specification a)
-> (Specification a, Specification a)
loop (Int
100 :: Int) ((Specification a, Specification a)
-> (Specification a, Specification a)
onlyOnceTransformations forall a b. (a -> b) -> a -> b
$ (forall a.
(TypeSpec a ~ NumSpec a, Arbitrary a, Integral a, Random a,
MaybeBounded a, Complete a) =>
(Specification a, Specification a)
-> (Specification a, Specification a)
narrowFoldSpecs (Specification a, Specification a)
specpair))
where
loop :: Int
-> (Specification a, Specification a)
-> (Specification a, Specification a)
loop Int
0 (Specification a, Specification a)
specs =
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines
[ String
"narrowByFuelAndSize loops:"
, String
" fuel = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
fuel
, String
" size = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
size
, String
" specs = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Specification a, Specification a)
specs
, String
" narrowFoldSpecs spec = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a.
(TypeSpec a ~ NumSpec a, Arbitrary a, Integral a, Random a,
MaybeBounded a, Complete a) =>
(Specification a, Specification a)
-> (Specification a, Specification a)
narrowFoldSpecs (Specification a, Specification a)
specs)
, String
" go (narrowFoldSpecs specs) = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ((Specification a, Specification a)
-> Maybe (Specification a, Specification a)
go (forall a.
(TypeSpec a ~ NumSpec a, Arbitrary a, Integral a, Random a,
MaybeBounded a, Complete a) =>
(Specification a, Specification a)
-> (Specification a, Specification a)
narrowFoldSpecs (Specification a, Specification a)
specs))
]
loop Int
n (Specification a, Specification a)
specs = case (Specification a, Specification a)
-> Maybe (Specification a, Specification a)
go (Specification a, Specification a)
specs of
Maybe (Specification a, Specification a)
Nothing -> (Specification a, Specification a)
specs
Just (Specification a, Specification a)
specs' -> Int
-> (Specification a, Specification a)
-> (Specification a, Specification a)
loop (Int
n forall a. Num a => a -> a -> a
- Int
1) (forall a.
(TypeSpec a ~ NumSpec a, Arbitrary a, Integral a, Random a,
MaybeBounded a, Complete a) =>
(Specification a, Specification a)
-> (Specification a, Specification a)
narrowFoldSpecs (Specification a, Specification a)
specs')
onlyOnceTransformations :: (Specification a, Specification a)
-> (Specification a, Specification a)
onlyOnceTransformations (Specification a
elemS, Specification a
foldS)
| a
fuel forall a. Eq a => a -> a -> Bool
== a
1 = (Specification a
elemS forall a. Semigroup a => a -> a -> a
<> Specification a
foldS, Specification a
foldS)
| Bool
otherwise = (Specification a
elemS, Specification a
foldS)
canReach :: t -> t -> t -> Bool
canReach t
_ t
0 t
s = t
s forall a. Eq a => a -> a -> Bool
== t
0
canReach t
e t
currentfuel t
s
| t
s forall a. Ord a => a -> a -> Bool
<= t
e = t
0 forall a. Ord a => a -> a -> Bool
< t
currentfuel
| Bool
otherwise = t -> t -> t -> Bool
canReach t
e (t
currentfuel forall a. Num a => a -> a -> a
- t
1) (t
s forall a. Num a => a -> a -> a
- t
e)
safeNegate :: a -> a
safeNegate a
a
| Just a
u <- forall a. MaybeBounded a => Maybe a
upperBound
, a
a forall a. Ord a => a -> a -> Bool
< forall a. Num a => a -> a
negate a
u =
a
u
| Bool
otherwise = forall a. Num a => a -> a
negate a
a
divCeil :: a -> a -> a
divCeil a
a a
b
| a
b forall a. Num a => a -> a -> a
* a
d forall a. Ord a => a -> a -> Bool
< a
a = a
d forall a. Num a => a -> a -> a
+ a
1
| Bool
otherwise = a
d
where
d :: a
d = a
a forall a. Integral a => a -> a -> a
`div` a
b
go :: (Specification a, Specification a) -> Maybe (Specification a, Specification a)
go :: (Specification a, Specification a)
-> Maybe (Specification a, Specification a)
go (forall a. Complete a => Specification a -> Specification a
simplifyA -> Specification a
elemS, forall a. Complete a => Specification a -> Specification a
simplifyA -> Specification a
foldS)
| a
fuel forall a. Eq a => a -> a -> Bool
== a
0 = forall a. Maybe a
Nothing
| ErrorSpec {} <- Specification a
elemS = forall a. Maybe a
Nothing
| ErrorSpec {} <- Specification a
foldS = forall a. Maybe a
Nothing
| Just a
0 <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification a
elemS
, Just a
0 <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownLowerBound Specification a
elemS
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ a
0 forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
foldS =
forall a. a -> Maybe a
Just (forall a. NonEmpty String -> Specification a
ErrorSpec (forall a. [a] -> NonEmpty a
NE.fromList [String
"only 0 left"]), Specification a
foldS)
| Int
size forall a. Eq a => a -> a -> Bool
== Int
0
, a
0 forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
elemS =
forall a. a -> Maybe a
Just (Specification a
elemS forall a. Semigroup a => a -> a -> a
<> forall a. HasSpec a => a -> Specification a
notEqualSpec a
0, Specification a
foldS)
| MemberSpec NonEmpty a
ys <- Specification a
elemS
, let xs :: [a]
xs = forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
ys
, Just a
u <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification a
foldS
, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a
0 forall a. Ord a => a -> a -> Bool
<=) [a]
xs
, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a
0 forall a. Ord a => a -> a -> Bool
<) [a]
xs
, let xMinP :: a
xMinP = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (a
0 forall a. Ord a => a -> a -> Bool
<) [a]
xs
possible :: a -> Bool
possible a
x = a
x forall a. Eq a => a -> a -> Bool
== a
u Bool -> Bool -> Bool
|| a
xMinP forall a. Ord a => a -> a -> Bool
<= a
u forall a. Num a => a -> a -> a
- a
x
xs' :: [a]
xs' = forall a. (a -> Bool) -> [a] -> [a]
filter a -> Bool
possible [a]
xs
, [a]
xs' forall a. Eq a => a -> a -> Bool
/= [a]
xs =
forall a. a -> Maybe a
Just (forall a. [a] -> NonEmpty String -> Specification a
memberSpecList (forall a. Ord a => [a] -> [a]
nubOrd [a]
xs') (forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"None of " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [a]
xs forall {a}. [a] -> [a] -> [a]
++ String
" are possible")), Specification a
foldS)
| Just a
e <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownLowerBound Specification a
elemS
, a
e forall a. Ord a => a -> a -> Bool
> a
0
, Just a
s <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownLowerBound Specification a
foldS
, a
s forall a. Ord a => a -> a -> Bool
> a
0
, let c :: a
c = forall a. Integral a => a -> a -> a
divCeil a
s a
fuel
, a
e forall a. Ord a => a -> a -> Bool
< a
c =
forall a. a -> Maybe a
Just (Specification a
elemS forall a. Semigroup a => a -> a -> a
<> forall a. OrdLike a => a -> Specification a
geqSpec a
c, Specification a
foldS)
| Just a
e <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification a
elemS
, a
e forall a. Ord a => a -> a -> Bool
< a
0
, Just a
s <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification a
foldS
, a
s forall a. Ord a => a -> a -> Bool
< a
0
, let c :: a
c = forall a. Integral a => a -> a -> a
divCeil (forall {a}. (MaybeBounded a, Ord a, Num a) => a -> a
safeNegate a
s) a
fuel
, forall a. Num a => a -> a
negate a
c forall a. Ord a => a -> a -> Bool
< a
e
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (a
c forall a. Ord a => a -> a -> Bool
<) (forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification a
elemS) =
forall a. a -> Maybe a
Just (Specification a
elemS forall a. Semigroup a => a -> a -> a
<> forall a. OrdLike a => a -> Specification a
leqSpec a
c, Specification a
foldS)
| Just a
s <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownLowerBound Specification a
foldS
, a
s forall a. Ord a => a -> a -> Bool
> a
0
, Just a
e <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification a
elemS
, a
e forall a. Ord a => a -> a -> Bool
> a
0
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall {t} {t}. (Num t, Num t, Ord t, Ord t) => t -> t -> t -> Bool
canReach a
e (a
fuel forall a. Integral a => a -> a -> a
`div` a
2 forall a. Num a => a -> a -> a
+ a
1) a
s
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Ord a => a -> a -> Bool
<= a
0) (forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownLowerBound Specification a
elemS) =
forall a. a -> Maybe a
Just (Specification a
elemS forall a. Semigroup a => a -> a -> a
<> forall a. OrdLike a => a -> Specification a
gtSpec a
0, Specification a
foldS)
| Just a
s <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification a
foldS
, a
s forall a. Ord a => a -> a -> Bool
< a
0
, Just a
e <- forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownLowerBound Specification a
elemS
, a
e forall a. Ord a => a -> a -> Bool
< a
0
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall {t} {t}. (Num t, Num t, Ord t, Ord t) => t -> t -> t -> Bool
canReach (forall {a}. (MaybeBounded a, Ord a, Num a) => a -> a
safeNegate a
e) (a
fuel forall a. Integral a => a -> a -> a
`div` a
2 forall a. Num a => a -> a -> a
+ a
1) (forall {a}. (MaybeBounded a, Ord a, Num a) => a -> a
safeNegate a
s)
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (a
0 forall a. Ord a => a -> a -> Bool
<=) (forall a.
(TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>
Specification a -> Maybe a
knownUpperBound Specification a
elemS) =
forall a. a -> Maybe a
Just (Specification a
elemS forall a. Semigroup a => a -> a -> a
<> forall a. OrdLike a => a -> Specification a
ltSpec a
0, Specification a
foldS)
| Bool
otherwise = forall a. Maybe a
Nothing
genListWithSize ::
forall a m.
( Complete a
, TypeSpec a ~ NumSpec a
, MonadGenError m
, Random a
, Integral a
, Arbitrary a
, MaybeBounded a
, Complete Integer
, TypeSpec Integer ~ NumSpec Integer
) =>
Specification Integer ->
Specification a ->
Specification a ->
GenT m [a]
genListWithSize :: forall a (m :: * -> *).
(Complete a, TypeSpec a ~ NumSpec a, MonadGenError m, Random a,
Integral a, Arbitrary a, MaybeBounded a, Complete Integer,
TypeSpec Integer ~ NumSpec Integer) =>
Specification Integer
-> Specification a -> Specification a -> GenT m [a]
genListWithSize Specification Integer
sizeSpec Specification a
elemSpec Specification a
foldSpec
| Specification Integer
TrueSpec <- Specification Integer
sizeSpec = forall a (m :: * -> *).
(MonadGenError m, Arbitrary a, Integral a, MaybeBounded a,
TypeSpec a ~ NumSpec a, Random a, Complete a) =>
Specification a -> Specification a -> GenT m [a]
genNumList Specification a
elemSpec Specification a
foldSpec
| ErrorSpec NonEmpty String
_ <- Specification Integer
sizeSpec forall a. Semigroup a => a -> a -> a
<> forall a. OrdLike a => a -> Specification a
geqSpec Integer
0 =
forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a
fatalErrorNE
( forall a. [a] -> NonEmpty a
NE.fromList
[ String
"genListWithSize called with possible negative size"
, String
" sizeSpec = " forall {a}. [a] -> [a] -> [a]
++ forall a. HasSpec a => Specification a -> String
specName Specification Integer
sizeSpec
, String
" elemSpec = " forall {a}. [a] -> [a] -> [a]
++ forall a. HasSpec a => Specification a -> String
specName Specification a
elemSpec
, String
" foldSpec = " forall {a}. [a] -> [a] -> [a]
++ forall a. HasSpec a => Specification a -> String
specName Specification a
foldSpec
]
)
| Bool
otherwise = do
a
total <- forall a (m :: * -> *).
(Complete a, HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecA @a Specification a
foldSpec
let sizeAdjusted :: Specification Integer
sizeAdjusted =
if a
total forall a. Eq a => a -> a -> Bool
/= a
0
then Specification Integer
sizeSpec forall a. Semigroup a => a -> a -> a
<> forall a. OrdLike a => a -> Specification a
gtSpec Integer
0
else
if forall a. MaybeBounded a => Maybe a
lowerBound @a forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just a
0
then Specification Integer
sizeSpec forall a. Semigroup a => a -> a -> a
<> forall a. a -> Specification a
equalSpec Integer
0
else Specification Integer
sizeSpec forall a. Semigroup a => a -> a -> a
<> forall a. OrdLike a => a -> Specification a
gtSpec Integer
0
message :: [String]
message =
[ String
"\nGenSizedList fails"
, String
"sizespec = " forall {a}. [a] -> [a] -> [a]
++ forall a. HasSpec a => Specification a -> String
specName Specification Integer
sizeSpec
, String
"elemSpec = " forall {a}. [a] -> [a] -> [a]
++ forall a. HasSpec a => Specification a -> String
specName Specification a
elemSpec
, String
"foldSpec = " forall {a}. [a] -> [a] -> [a]
++ forall a. HasSpec a => Specification a -> String
specName Specification a
foldSpec
, String
"total choosen from foldSpec = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
total
, String
"size adjusted for total = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Specification Integer
sizeAdjusted
]
forall (m :: * -> *) a. MonadGenError m => [String] -> m a -> m a
push [String]
message forall a b. (a -> b) -> a -> b
$ do
Integer
count <- forall a (m :: * -> *).
(Complete a, HasCallStack, HasSpec a, MonadGenError m) =>
Specification a -> GenT m a
genFromSpecA @Integer Specification Integer
sizeAdjusted
case forall a. Ord a => a -> a -> Ordering
compare a
total a
0 of
Ordering
EQ ->
if Integer
count forall a. Eq a => a -> a -> Bool
== Integer
0
then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
else forall t (m :: * -> *).
(Integral t, Random t, MonadGenError m, TypeSpec t ~ NumSpec t,
Complete t) =>
Specification t -> t -> Integer -> GenT m [t]
pickPositive Specification a
elemSpec a
total Integer
count
Ordering
GT -> forall t (m :: * -> *).
(Integral t, Random t, MonadGenError m, TypeSpec t ~ NumSpec t,
Complete t) =>
Specification t -> t -> Integer -> GenT m [t]
pickPositive Specification a
elemSpec a
total Integer
count
Ordering
LT -> forall t (m :: * -> *).
(Integral t, Complete t, Random t, MonadGenError m,
TypeSpec t ~ NumSpec t) =>
Specification t -> t -> Integer -> GenT m [t]
pickNegative Specification a
elemSpec a
total Integer
count
pickPositive ::
forall t m.
(Integral t, Random t, MonadGenError m, TypeSpec t ~ NumSpec t, Complete t) =>
Specification t ->
t ->
Integer ->
GenT m [t]
pickPositive :: forall t (m :: * -> *).
(Integral t, Random t, MonadGenError m, TypeSpec t ~ NumSpec t,
Complete t) =>
Specification t -> t -> Integer -> GenT m [t]
pickPositive Specification t
elemspec t
total Integer
count = do
(Cost, Solution t)
sol <-
forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen forall a b. (a -> b) -> a -> b
$
forall t.
(Show t, Integral t, Random t) =>
t
-> t
-> (String, t -> Bool)
-> t
-> Int
-> Cost
-> Gen (Cost, Solution t)
pickAll
(forall n.
(Ord n, Complete n, TypeSpec n ~ NumSpec n) =>
n -> Specification n -> n
minFromSpec t
0 Specification t
elemspec)
(forall n.
(Ord n, Complete n, TypeSpec n ~ NumSpec n) =>
n -> Specification n -> n
maxFromSpec t
total Specification t
elemspec)
(forall a. HasSpec a => Specification a -> (String, a -> Bool)
predSpecPair Specification t
elemspec)
t
total
(forall a. Num a => Integer -> a
fromInteger Integer
count)
(Int -> Cost
Cost Int
0)
case forall a b. (a, b) -> b
snd (Cost, Solution t)
sol of
No [String]
msgs -> forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a
fatalErrorNE (forall a. [a] -> NonEmpty a
NE.fromList [String]
msgs)
Yes ([t]
x :| [[t]]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [t]
x
pickNegative ::
forall t m.
(Integral t, Complete t, Random t, MonadGenError m, TypeSpec t ~ NumSpec t) =>
Specification t ->
t ->
Integer ->
GenT m [t]
pickNegative :: forall t (m :: * -> *).
(Integral t, Complete t, Random t, MonadGenError m,
TypeSpec t ~ NumSpec t) =>
Specification t -> t -> Integer -> GenT m [t]
pickNegative Specification t
elemspec t
total Integer
count = do
(Cost, Solution t)
sol <-
forall (m :: * -> *) a. Applicative m => Gen a -> GenT m a
pureGen forall a b. (a -> b) -> a -> b
$
forall t.
(Show t, Integral t, Random t) =>
t
-> t
-> (String, t -> Bool)
-> t
-> Int
-> Cost
-> Gen (Cost, Solution t)
pickAll
(forall n.
(Ord n, Complete n, TypeSpec n ~ NumSpec n) =>
n -> Specification n -> n
minFromSpec (t
total forall a. Num a => a -> a -> a
+ (t
total forall a. Integral a => a -> a -> a
`div` t
4)) Specification t
elemspec)
(forall n.
(Ord n, Complete n, TypeSpec n ~ NumSpec n) =>
n -> Specification n -> n
maxFromSpec (t
0 forall a. Num a => a -> a -> a
- (t
total forall a. Integral a => a -> a -> a
`div` t
4)) Specification t
elemspec)
(forall a. HasSpec a => Specification a -> (String, a -> Bool)
predSpecPair Specification t
elemspec)
t
total
(forall a. Num a => Integer -> a
fromInteger Integer
count)
(Int -> Cost
Cost Int
0)
case forall a b. (a, b) -> b
snd (Cost, Solution t)
sol of
No [String]
msgs -> forall (m :: * -> *) a.
(MonadGenError m, HasCallStack) =>
NonEmpty String -> m a
fatalErrorNE (forall a. [a] -> NonEmpty a
NE.fromList [String]
msgs)
Yes ([t]
x :| [[t]]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [t]
x
specName :: forall a. HasSpec a => Specification a -> String
specName :: forall a. HasSpec a => Specification a -> String
specName (ExplainSpec [String
x] Specification a
_) = String
x
specName Specification a
x = forall a. Show a => a -> String
show Specification a
x
predSpecPair :: forall a. HasSpec a => Specification a -> (String, a -> Bool)
predSpecPair :: forall a. HasSpec a => Specification a -> (String, a -> Bool)
predSpecPair Specification a
spec = (forall a. HasSpec a => Specification a -> String
specName Specification a
spec, (forall a. HasSpec a => a -> Specification a -> Bool
`conformsToSpec` Specification a
spec))
minFromSpec ::
forall n.
(Ord n, Complete n, TypeSpec n ~ NumSpec n) =>
n ->
Specification n ->
n
minFromSpec :: forall n.
(Ord n, Complete n, TypeSpec n ~ NumSpec n) =>
n -> Specification n -> n
minFromSpec n
dv (ExplainSpec [String]
_ Specification n
spec) = forall n.
(Ord n, Complete n, TypeSpec n ~ NumSpec n) =>
n -> Specification n -> n
minFromSpec @n n
dv Specification n
spec
minFromSpec n
dv Specification n
TrueSpec = n
dv
minFromSpec n
dv s :: Specification n
s@(SuspendedSpec Var n
_ Pred
_) =
case forall a. Complete a => Specification a -> Specification a
simplifyA Specification n
s of
SuspendedSpec {} -> n
dv
Specification n
x -> forall n.
(Ord n, Complete n, TypeSpec n ~ NumSpec n) =>
n -> Specification n -> n
minFromSpec @n n
dv Specification n
x
minFromSpec n
dv (ErrorSpec NonEmpty String
_) = n
dv
minFromSpec n
_ (MemberSpec NonEmpty n
xs) = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum NonEmpty n
xs
minFromSpec n
dv (TypeSpec (NumSpecInterval Maybe n
lo Maybe n
_) [n]
_) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe n
dv forall a. a -> a
id Maybe n
lo
maxFromSpec ::
forall n.
(Ord n, Complete n, TypeSpec n ~ NumSpec n) =>
n ->
Specification n ->
n
maxFromSpec :: forall n.
(Ord n, Complete n, TypeSpec n ~ NumSpec n) =>
n -> Specification n -> n
maxFromSpec n
dv (ExplainSpec [String]
_ Specification n
spec) = forall n.
(Ord n, Complete n, TypeSpec n ~ NumSpec n) =>
n -> Specification n -> n
maxFromSpec @n n
dv Specification n
spec
maxFromSpec n
dv Specification n
TrueSpec = n
dv
maxFromSpec n
dv s :: Specification n
s@(SuspendedSpec Var n
_ Pred
_) =
case forall a. Complete a => Specification a -> Specification a
simplifyA Specification n
s of
SuspendedSpec {} -> n
dv
Specification n
x -> forall n.
(Ord n, Complete n, TypeSpec n ~ NumSpec n) =>
n -> Specification n -> n
maxFromSpec @n n
dv Specification n
x
maxFromSpec n
dv (ErrorSpec NonEmpty String
_) = n
dv
maxFromSpec n
_ (MemberSpec NonEmpty n
xs) = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum NonEmpty n
xs
maxFromSpec n
dv (TypeSpec (NumSpecInterval Maybe n
_ Maybe n
hi) [n]
_) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe n
dv forall a. a -> a
id Maybe n
hi
data Solution t = Yes (NonEmpty [t]) | No [String]
deriving (Solution t -> Solution t -> Bool
forall t. Eq t => Solution t -> Solution t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Solution t -> Solution t -> Bool
$c/= :: forall t. Eq t => Solution t -> Solution t -> Bool
== :: Solution t -> Solution t -> Bool
$c== :: forall t. Eq t => Solution t -> Solution t -> Bool
Eq)
instance Show t => Show (Solution t) where
show :: Solution t -> String
show (No [String]
xs) = String
"No" forall {a}. [a] -> [a] -> [a]
++ String
"\n" forall {a}. [a] -> [a] -> [a]
++ [String] -> String
unlines [String]
xs
show (Yes NonEmpty [t]
xs) = String
"Yes " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show NonEmpty [t]
xs
concatSolution :: Show t => t -> t -> String -> t -> Int -> [Solution t] -> Solution t
concatSolution :: forall t.
Show t =>
t -> t -> String -> t -> Int -> [Solution t] -> Solution t
concatSolution t
smallest t
largest String
pName t
total Int
count [Solution t]
sols =
case forall a b. [Either a b] -> ([a], [b])
partitionEithers (forall a b. (a -> b) -> [a] -> [b]
map (\case Yes NonEmpty [t]
x -> forall a b. a -> Either a b
Left NonEmpty [t]
x; No [String]
x -> forall a b. b -> Either a b
Right [String]
x) [Solution t]
sols) of
([], [String]
n : [[String]]
_) -> forall t. [String] -> Solution t
No [String]
n
(NonEmpty [t]
y : [NonEmpty [t]]
ys, [[String]]
_) -> forall t. NonEmpty [t] -> Solution t
Yes forall a b. (a -> b) -> a -> b
$ forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty [t]
y forall a. a -> [a] -> NonEmpty a
:| [NonEmpty [t]]
ys)
([], []) ->
forall t. [String] -> Solution t
No
[ String
"\nThe sample in pickAll was empty"
, String
" smallest = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
smallest
, String
" largest = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
largest
, String
" pred = " forall {a}. [a] -> [a] -> [a]
++ String
pName
, String
" total = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
total
, String
" count = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
count
]
newtype Cost = Cost Int deriving (Cost -> Cost -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cost -> Cost -> Bool
$c/= :: Cost -> Cost -> Bool
== :: Cost -> Cost -> Bool
$c== :: Cost -> Cost -> Bool
Eq, Int -> Cost -> ShowS
[Cost] -> ShowS
Cost -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cost] -> ShowS
$cshowList :: [Cost] -> ShowS
show :: Cost -> String
$cshow :: Cost -> String
showsPrec :: Int -> Cost -> ShowS
$cshowsPrec :: Int -> Cost -> ShowS
Show, Integer -> Cost
Cost -> Cost
Cost -> Cost -> Cost
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Cost
$cfromInteger :: Integer -> Cost
signum :: Cost -> Cost
$csignum :: Cost -> Cost
abs :: Cost -> Cost
$cabs :: Cost -> Cost
negate :: Cost -> Cost
$cnegate :: Cost -> Cost
* :: Cost -> Cost -> Cost
$c* :: Cost -> Cost -> Cost
- :: Cost -> Cost -> Cost
$c- :: Cost -> Cost -> Cost
+ :: Cost -> Cost -> Cost
$c+ :: Cost -> Cost -> Cost
Num, Eq Cost
Cost -> Cost -> Bool
Cost -> Cost -> Ordering
Cost -> Cost -> Cost
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Cost -> Cost -> Cost
$cmin :: Cost -> Cost -> Cost
max :: Cost -> Cost -> Cost
$cmax :: Cost -> Cost -> Cost
>= :: Cost -> Cost -> Bool
$c>= :: Cost -> Cost -> Bool
> :: Cost -> Cost -> Bool
$c> :: Cost -> Cost -> Bool
<= :: Cost -> Cost -> Bool
$c<= :: Cost -> Cost -> Bool
< :: Cost -> Cost -> Bool
$c< :: Cost -> Cost -> Bool
compare :: Cost -> Cost -> Ordering
$ccompare :: Cost -> Cost -> Ordering
Ord)
firstYesG ::
Monad m => Solution t -> (x -> Cost -> m (Cost, Solution t)) -> [x] -> Cost -> m (Cost, Solution t)
firstYesG :: forall (m :: * -> *) t x.
Monad m =>
Solution t
-> (x -> Cost -> m (Cost, Solution t))
-> [x]
-> Cost
-> m (Cost, Solution t)
firstYesG Solution t
nullSolution x -> Cost -> m (Cost, Solution t)
f [x]
xs Cost
c = [x] -> Cost -> m (Cost, Solution t)
go [x]
xs Cost
c
where
go :: [x] -> Cost -> m (Cost, Solution t)
go [] Cost
cost = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cost
cost, Solution t
nullSolution)
go [x
x] Cost
cost = x -> Cost -> m (Cost, Solution t)
f x
x (Cost
cost forall a. Num a => a -> a -> a
+ Cost
1)
go (x
x : [x]
more) Cost
cost = do
(Cost, Solution t)
ans <- x -> Cost -> m (Cost, Solution t)
f x
x (Cost
cost forall a. Num a => a -> a -> a
+ Cost
1)
case (Cost, Solution t)
ans of
(Cost
cost1, No [String]
_) -> [x] -> Cost -> m (Cost, Solution t)
go [x]
more Cost
cost1
(Cost
_, Yes NonEmpty [t]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cost, Solution t)
ans
noChoices :: Show t => Cost -> String -> t -> t -> t -> Int -> [(t, t)] -> Solution t
noChoices :: forall t.
Show t =>
Cost -> String -> t -> t -> t -> Int -> [(t, t)] -> Solution t
noChoices Cost
cost String
p t
smallest t
largest t
total Int
count [(t, t)]
samp =
forall t. [String] -> Solution t
No
[ String
"\nNo legal choice can be found, where for each sample (x,y)"
, String
"x+y = total && predicate x && predicate y"
, String
" predicate = " forall {a}. [a] -> [a] -> [a]
++ String
p
, String
" smallest = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
smallest
, String
" largest = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
largest
, String
" total = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
total
, String
" count = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
count
, String
" cost = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Cost
cost
, String
"Small sample of what was explored"
, forall a. Show a => a -> String
show [(t, t)]
samp
]
splitsOf :: Integral b => b -> [(b, b)]
splitsOf :: forall b. Integral b => b -> [(b, b)]
splitsOf b
count = [(b
i, b
j) | b
i <- [b
1 .. forall a. Integral a => a -> a -> a
div b
count b
2], let j :: b
j = b
count forall a. Num a => a -> a -> a
- b
i]
{-# SPECIALIZE splitsOf :: Int -> [(Int, Int)] #-}
pickAll ::
forall t.
(Show t, Integral t, Random t) =>
t ->
t ->
(String, t -> Bool) ->
t ->
Int ->
Cost ->
Gen (Cost, Solution t)
pickAll :: forall t.
(Show t, Integral t, Random t) =>
t
-> t
-> (String, t -> Bool)
-> t
-> Int
-> Cost
-> Gen (Cost, Solution t)
pickAll t
smallest t
largest (String
pName, t -> Bool
_) t
total Int
count Cost
cost
| Cost
cost forall a. Ord a => a -> a -> Bool
> Cost
1000 =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
( Cost
cost
, forall t. [String] -> Solution t
No
[ String
"\nPickAll exceeds cost limit " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Cost
cost
, String
" predicate = " forall {a}. [a] -> [a] -> [a]
++ String
pName
, String
" smallest = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
smallest
, String
" largest = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
largest
, String
" total = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
total
, String
" count = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
count
]
)
pickAll t
smallest t
largest (String
pName, t -> Bool
p) t
total Int
0 Cost
cost =
if t
total forall a. Eq a => a -> a -> Bool
== t
0 Bool -> Bool -> Bool
&& t -> Bool
p t
total
then forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cost
cost, forall t. NonEmpty [t] -> Solution t
Yes forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
else
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Cost
cost
, forall t. [String] -> Solution t
No
[ String
"We are trying to find list of length 0."
, String
" Whose sum is " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
total forall {a}. [a] -> [a] -> [a]
++ String
"."
, String
" That is only possible if the sum == 0."
, String
" All elements have to satisfy " forall {a}. [a] -> [a] -> [a]
++ String
pName
, String
" smallest = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
smallest
, String
" largest = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
largest
]
)
pickAll t
smallest t
largest (String
pName, t -> Bool
p) t
total Int
1 Cost
cost =
if t -> Bool
p t
total
then forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cost
cost, forall t. NonEmpty [t] -> Solution t
Yes forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure [t
total])
else forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cost
cost, forall t.
Show t =>
Cost -> String -> t -> t -> t -> Int -> [(t, t)] -> Solution t
noChoices Cost
cost String
pName t
smallest t
largest t
total Int
1 [(t
total, t
0)])
pickAll t
smallest t
largest (String
pName, t -> Bool
_) t
total Int
count Cost
cost
| t
smallest forall a. Ord a => a -> a -> Bool
> t
largest =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
( Cost
cost
, forall t. [String] -> Solution t
No
[ String
"\nThe feasible range to pickAll ["
forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
smallest
forall {a}. [a] -> [a] -> [a]
++ String
" .. "
forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Integral a => a -> a -> a
div t
total t
2)
forall {a}. [a] -> [a] -> [a]
++ String
"] was empty"
, String
" predicate = " forall {a}. [a] -> [a] -> [a]
++ String
pName
, String
" smallest = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
smallest
, String
" largest = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
largest
, String
" total = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
total
, String
" count = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
count
, String
" cost = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Cost
cost
]
)
pickAll t
smallest t
largest (String
pName, t -> Bool
p) t
total Int
2 Cost
cost = do
[(t, t)]
choices <- forall t.
(Random t, Integral t) =>
t -> t -> t -> t -> Int -> Gen [(t, t)]
smallSample t
smallest t
largest t
total t
1000 Int
100
case forall a. (a -> Bool) -> [a] -> [a]
filter (\(t
x, t
y) -> t -> Bool
p t
x Bool -> Bool -> Bool
&& t -> Bool
p t
y) [(t, t)]
choices of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Cost
cost forall a. Num a => a -> a -> a
+ Cost
1, forall t.
Show t =>
Cost -> String -> t -> t -> t -> Int -> [(t, t)] -> Solution t
noChoices Cost
cost String
pName t
smallest t
largest t
total Int
2 (forall a. Int -> [a] -> [a]
take Int
10 [(t, t)]
choices))
[(t, t)]
zs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Cost
cost forall a. Num a => a -> a -> a
+ Cost
1, forall t. NonEmpty [t] -> Solution t
Yes forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(t
x, t
y) -> [t
x, t
y]) [(t, t)]
zs))
pickAll t
smallest t
largest (String
pName, t -> Bool
p) t
total Int
count Cost
cost = do
[(t, t)]
choices <- forall t.
(Random t, Integral t) =>
t -> t -> t -> t -> Int -> Gen [(t, t)]
smallSample t
smallest t
largest t
total t
1000 Int
20
[(Int, Int)]
splits <-
if Int
count forall a. Ord a => a -> a -> Bool
>= Int
20
then forall a. [a] -> Gen [a]
shuffle forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
10 (forall b. Integral b => b -> [(b, b)]
splitsOf Int
count)
else
if t
total forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
count
then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> [a]
reverse (forall b. Integral b => b -> [(b, b)]
splitsOf Int
count))
else forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall b. Integral b => b -> [(b, b)]
splitsOf Int
count)
forall (m :: * -> *) t x.
Monad m =>
Solution t
-> (x -> Cost -> m (Cost, Solution t))
-> [x]
-> Cost
-> m (Cost, Solution t)
firstYesG
(forall t. [String] -> Solution t
No [String
"\nNo split has a solution", String
"cost = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Cost
cost])
(forall t.
(Random t, Show t, Integral t) =>
t
-> t
-> (String, t -> Bool)
-> t
-> [(t, t)]
-> (Int, Int)
-> Cost
-> Gen (Cost, Solution t)
doSplit t
smallest t
largest (String
pName, t -> Bool
p) t
total [(t, t)]
choices)
[(Int, Int)]
splits
Cost
cost
doSplit ::
(Random t, Show t, Integral t) =>
t ->
t ->
(String, t -> Bool) ->
t ->
[(t, t)] ->
(Int, Int) ->
Cost ->
Gen (Cost, Solution t)
doSplit :: forall t.
(Random t, Show t, Integral t) =>
t
-> t
-> (String, t -> Bool)
-> t
-> [(t, t)]
-> (Int, Int)
-> Cost
-> Gen (Cost, Solution t)
doSplit t
smallest t
largest (String
pName, t -> Bool
p) t
total [(t, t)]
sample (Int
i, Int
j) Cost
c = [(t, t)] -> Cost -> Gen (Cost, Solution t)
go [(t, t)]
sample Cost
c
where
go :: [(t, t)] -> Cost -> Gen (Cost, Solution t)
go ((t
x, t
y) : [(t, t)]
more) Cost
cost0 = do
(Cost
cost1, Solution t
ans1) <- forall t.
(Show t, Integral t, Random t) =>
t
-> t
-> (String, t -> Bool)
-> t
-> Int
-> Cost
-> Gen (Cost, Solution t)
pickAll t
smallest t
largest (String
pName, t -> Bool
p) t
x Int
i Cost
cost0
(Cost
cost2, Solution t
ans2) <- forall t.
(Show t, Integral t, Random t) =>
t
-> t
-> (String, t -> Bool)
-> t
-> Int
-> Cost
-> Gen (Cost, Solution t)
pickAll t
smallest t
largest (String
pName, t -> Bool
p) t
y Int
j Cost
cost1
case (Solution t
ans1, Solution t
ans2) of
(Yes NonEmpty [t]
ys, Yes NonEmpty [t]
zs) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Cost
cost2, forall t. NonEmpty [t] -> Solution t
Yes (forall a. [a] -> NonEmpty a
NE.fromList [[t]
a forall a. Semigroup a => a -> a -> a
<> [t]
b | [t]
a <- forall a. NonEmpty a -> [a]
NE.toList NonEmpty [t]
ys, [t]
b <- forall a. NonEmpty a -> [a]
NE.toList NonEmpty [t]
zs]))
(Solution t, Solution t)
_ -> [(t, t)] -> Cost -> Gen (Cost, Solution t)
go [(t, t)]
more Cost
cost2
go [] Cost
cost =
case [(t, t)]
sample of
[] ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
( Cost
cost
, forall t. [String] -> Solution t
No
[ String
"\nThe sample passed to doSplit [" forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
smallest forall {a}. [a] -> [a] -> [a]
++ String
" .. " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Integral a => a -> a -> a
div t
total t
2) forall {a}. [a] -> [a] -> [a]
++ String
"] was empty"
, String
" predicate = " forall {a}. [a] -> [a] -> [a]
++ String
pName
, String
" smallest = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
smallest
, String
" largest = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
largest
, String
" total " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
total
, String
" count = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
i forall a. Num a => a -> a -> a
+ Int
j)
, String
" split of count = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
i, Int
j)
]
)
((t
left, t
right) : [(t, t)]
_) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
( Cost
cost
, forall t. [String] -> Solution t
No
[ String
"\nAll choices in (genSizedList " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
i forall a. Num a => a -> a -> a
+ Int
j) forall {a}. [a] -> [a] -> [a]
++ String
" 'p' " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
total forall {a}. [a] -> [a] -> [a]
++ String
") have failed."
, String
"Here is 1 example failure."
, String
" smallest = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
smallest
, String
" largest = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
largest
, String
" total " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
total forall {a}. [a] -> [a] -> [a]
++ String
" = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
left forall {a}. [a] -> [a] -> [a]
++ String
" + " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
right
, String
" count = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
i forall a. Num a => a -> a -> a
+ Int
j) forall {a}. [a] -> [a] -> [a]
++ String
", split of count = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
i, Int
j)
, String
"We are trying to solve sub-problems like:"
, String
" split " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
left forall {a}. [a] -> [a] -> [a]
++ String
" into " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall {a}. [a] -> [a] -> [a]
++ String
" parts, where all parts meet 'p'"
, String
" split " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
right forall {a}. [a] -> [a] -> [a]
++ String
" into " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
j forall {a}. [a] -> [a] -> [a]
++ String
" parts, where all parts meet 'p'"
, String
"Predicate 'p' = " forall {a}. [a] -> [a] -> [a]
++ String
pName
, String
"A small prefix of the sample, elements (x,y) where x+y = " forall {a}. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
total
, [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map ((String
" " forall {a}. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (forall a. Int -> [a] -> [a]
take Int
10 [(t, t)]
sample))
]
)
{-# INLINE doSplit #-}
smallSample :: (Random t, Integral t) => t -> t -> t -> t -> Int -> Gen [(t, t)]
smallSample :: forall t.
(Random t, Integral t) =>
t -> t -> t -> t -> Int -> Gen [(t, t)]
smallSample t
smallest t
largest t
total t
bound Int
size
| t
largest forall a. Num a => a -> a -> a
- t
smallest forall a. Ord a => a -> a -> Bool
<= t
bound = do
forall a. [a] -> Gen [a]
shuffle forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Ord a => a -> a -> Bool
(<=)) [(t
x, t
total forall a. Num a => a -> a -> a
- t
x) | t
x <- [t
smallest .. t
total]]
| Bool
otherwise = do
[t]
choices <- forall a.
(Random a, Integral a) =>
a -> a -> Int -> Int -> Bool -> Gen [a]
fair t
smallest t
largest Int
size Int
5 Bool
True
forall a. [a] -> Gen [a]
shuffle [(t
x, t
total forall a. Num a => a -> a -> a
- t
x) | t
x <- [t]
choices]
{-# INLINE smallSample #-}
fair :: (Random a, Integral a) => a -> a -> Int -> Int -> Bool -> Gen [a]
fair :: forall a.
(Random a, Integral a) =>
a -> a -> Int -> Int -> Bool -> Gen [a]
fair a
smallest a
largest Int
size Int
precision Bool
isLarge =
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (a, a) -> Gen [a]
oneRange (if Bool
isLarge then [(a, a)]
largePrecision else [(a, a)]
smallPrecision)
where
raw :: [(a, a)]
raw = forall a b. (a -> b) -> [a] -> [b]
map forall a. Integral a => a -> (a, a)
logRange [forall t. Integral t => t -> t
logish a
smallest .. forall t. Integral t => t -> t
logish a
largest]
fixEnds :: (a, a) -> (a, a)
fixEnds (a
x, a
y) = (forall a. Ord a => a -> a -> a
max a
smallest a
x, forall a. Ord a => a -> a -> a
min a
largest a
y)
ranges :: [(a, a)]
ranges = forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> (a, a)
fixEnds [(a, a)]
raw
count :: Int
count = forall a. Integral a => a -> a -> a
div Int
size Int
precision
largePrecision :: [(a, a)]
largePrecision = forall a. Int -> [a] -> [a]
take Int
precision (forall a. [a] -> [a]
reverse [(a, a)]
ranges)
smallPrecision :: [(a, a)]
smallPrecision = forall a. Int -> [a] -> [a]
take Int
precision [(a, a)]
ranges
oneRange :: (a, a) -> Gen [a]
oneRange (a
x, a
y) = forall a. Int -> Gen a -> Gen [a]
vectorOf Int
count (forall a. Random a => (a, a) -> Gen a
choose (a
x, a
y))
logRange :: Integral a => a -> (a, a)
logRange :: forall a. Integral a => a -> (a, a)
logRange a
1 = (a
10, a
99)
logRange (-1) = (-a
9, -a
1)
logRange a
n = case forall a. Ord a => a -> a -> Ordering
compare a
n a
0 of
Ordering
EQ -> (a
0, a
9)
Ordering
LT -> (forall a. Num a => a -> a
negate (forall a. Integral a => a -> a -> a
div a
b a
10), forall a. Num a => a -> a
negate (forall a. Integral a => a -> a -> a
div a
a a
10))
Ordering
GT -> (a
10 forall a b. (Num a, Integral b) => a -> b -> a
^ a
n, a
10 forall a b. (Num a, Integral b) => a -> b -> a
^ (a
n forall a. Num a => a -> a -> a
+ a
1) forall a. Num a => a -> a -> a
- a
1)
where
(a
a, a
b) = forall a. Integral a => a -> (a, a)
logRange (forall a. Num a => a -> a
negate a
n)
logish :: Integral t => t -> t
logish :: forall t. Integral t => t -> t
logish t
n
| t
0 forall a. Ord a => a -> a -> Bool
<= t
n Bool -> Bool -> Bool
&& t
n forall a. Ord a => a -> a -> Bool
<= t
9 = t
0
| t
n forall a. Ord a => a -> a -> Bool
> t
9 = t
1 forall a. Num a => a -> a -> a
+ forall t. Integral t => t -> t
logish (t
n forall a. Integral a => a -> a -> a
`div` t
10)
| (-t
9) forall a. Ord a => a -> a -> Bool
<= t
n Bool -> Bool -> Bool
&& t
n forall a. Ord a => a -> a -> Bool
<= (-t
1) = -t
1
| Bool
True = forall a. Num a => a -> a
negate (t
1 forall a. Num a => a -> a -> a
+ forall t. Integral t => t -> t
logish (forall a. Num a => a -> a
negate t
n))