-- |
-- Module      : Test.LeanCheck.Tiers
-- Copyright   : (c) 2015-2020 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- LeanCheck is a simple enumerative property-based testing library.
--
-- This module provides advanced functions for manipulating 'tiers'.
-- Most definitions given here are exported by "Test.LeanCheck", except:
--   'listCons',
--   'choices',
--   'setChoices' and
--   'bagChoices'.
module Test.LeanCheck.Tiers
  (
  -- * Additional tiers constructors
    listCons
  , setCons
  , bagCons
  , mapCons
  , noDupListCons

  , maybeCons0
  , maybeCons1
  , maybeCons2

  -- * Products of tiers
  , product3
  , product3With
  , productMaybeWith

  -- * Tiers of lists
  , listsOf
  , bagsOf
  , setsOf
  , noDupListsOf
  , products
  , maps
  , listsOfLength

  -- * Tiers of pairs
  , distinctPairs
  , distinctPairsWith
  , unorderedPairs
  , unorderedPairsWith
  , unorderedDistinctPairs
  , unorderedDistinctPairsWith

  , deleteT
  , normalizeT
  , catMaybesT
  , mapMaybeT
  , discardT
  , discardLaterT
  , nubT

  -- * Tiers of choices
  , choices
  , setChoices
  , bagChoices

  -- * Showing and printing lists-of-tiers
  -- | Lists-of-tiers are already show instances as their type is just @[[a]]@.
  --   The following functions are alternatives to 'print' and 'show' with one
  --   element per line and can be useful for debugging.
  , printTiers
  , showTiers

  , finite
  )
where

import Test.LeanCheck.Basic
import Data.Maybe (catMaybes)

-- | Given a constructor that takes a list,
--   return tiers of applications of this constructor.
--
-- This is basically a type-restricted version of 'cons1'.
-- You should use 'cons1' instead: this serves more as an illustration of how
-- 'setCons' and 'bagCons' work (see source).
listCons :: Listable a => ([a] -> b) -> [[b]]
listCons :: ([a] -> b) -> [[b]]
listCons  =  (([a] -> b) -> [[[a]]] -> [[b]]
forall a b. (a -> b) -> [[a]] -> [[b]]
`mapT` [[a]] -> [[[a]]]
forall a. [[a]] -> [[[a]]]
listsOf [[a]]
forall a. Listable a => [[a]]
tiers)

-- | Given a constructor that takes a bag of elements (as a list),
--   lists tiers of applications of this constructor.
--
-- For example, a @Bag@ represented as a list.
--
-- > bagCons Bag
bagCons :: Listable a => ([a] -> b) -> [[b]]
bagCons :: ([a] -> b) -> [[b]]
bagCons  =  (([a] -> b) -> [[[a]]] -> [[b]]
forall a b. (a -> b) -> [[a]] -> [[b]]
`mapT` [[a]] -> [[[a]]]
forall a. [[a]] -> [[[a]]]
bagsOf [[a]]
forall a. Listable a => [[a]]
tiers)

-- | Given a constructor that takes a set of elements (as a list),
--   lists tiers of applications of this constructor.
--
-- A naive 'Listable' instance for the 'Data.Set.Set' (of "Data.Set")
-- would read:
--
-- > instance Listable a => Listable (Set a) where
-- >   tiers  =  cons0 empty \/ cons2 insert
--
-- The above instance has a problem: it generates repeated sets.
-- A more efficient implementation that does not repeat sets is given by:
--
-- >   tiers  =  setCons fromList
--
-- Alternatively, you can use 'setsOf' direclty.
setCons :: Listable a => ([a] -> b) -> [[b]]
setCons :: ([a] -> b) -> [[b]]
setCons  =  (([a] -> b) -> [[[a]]] -> [[b]]
forall a b. (a -> b) -> [[a]] -> [[b]]
`mapT` [[a]] -> [[[a]]]
forall a. [[a]] -> [[[a]]]
setsOf [[a]]
forall a. Listable a => [[a]]
tiers)

-- | Given a constructor that takes a map of elements (encoded as a list),
--   lists tiers of applications of this constructor
--
--   So long as the underlying 'Listable' enumerations have no repetitions,
--   this will generate no repetitions.
--
--   This allows defining an efficient implementation of `tiers` that does not
--   repeat maps given by:
--
--   >   tiers  =  mapCons fromList
mapCons :: (Listable a, Listable b) => ([(a,b)] -> c) -> [[c]]
mapCons :: ([(a, b)] -> c) -> [[c]]
mapCons  =  (([(a, b)] -> c) -> [[[(a, b)]]] -> [[c]]
forall a b. (a -> b) -> [[a]] -> [[b]]
`mapT` [[a]] -> [[b]] -> [[[(a, b)]]]
forall a b. [[a]] -> [[b]] -> [[[(a, b)]]]
maps [[a]]
forall a. Listable a => [[a]]
tiers [[b]]
forall a. Listable a => [[a]]
tiers)

-- | Given a constructor that takes a list with no duplicate elements,
--   return tiers of applications of this constructor.
noDupListCons :: Listable a => ([a] -> b) -> [[b]]
noDupListCons :: ([a] -> b) -> [[b]]
noDupListCons  =  (([a] -> b) -> [[[a]]] -> [[b]]
forall a b. (a -> b) -> [[a]] -> [[b]]
`mapT` [[a]] -> [[[a]]]
forall a. [[a]] -> [[[a]]]
noDupListsOf [[a]]
forall a. Listable a => [[a]]
tiers)

-- | Like 'cons0' but lifted over a 'Maybe' value.
--
-- Only a 'Just' value will be returned.
maybeCons0 :: Maybe b -> [[b]]
maybeCons0 :: Maybe b -> [[b]]
maybeCons0 Maybe b
Nothing   =  []
maybeCons0 (Just b
x)  =  [[b
x]]

-- | Like 'cons1' but lifted over a 'Maybe' result.
--
-- This discard 'Nothing' values.
-- Only 'Just' values are returned.
maybeCons1 :: Listable a => (a -> Maybe b) -> [[b]]
maybeCons1 :: (a -> Maybe b) -> [[b]]
maybeCons1 a -> Maybe b
f  =  [[b]] -> [[b]]
forall a. [[a]] -> [[a]]
delay ([[b]] -> [[b]]) -> [[b]] -> [[b]]
forall a b. (a -> b) -> a -> b
$ (a -> Maybe b) -> [[a]] -> [[b]]
forall a b. (a -> Maybe b) -> [[a]] -> [[b]]
mapMaybeT a -> Maybe b
f [[a]]
forall a. Listable a => [[a]]
tiers

-- | Like 'cons2' but lifted over a 'Maybe' result.
--
-- This discard 'Nothing' values.
-- Only 'Just' values are returned.
--
-- Useful when declaring generators which have pre-conditions:
--
-- > data Fraction  =  Fraction Int Int
-- >
-- > mkFraction _ 0  =  Nothing
-- > mkFraction n d  =  Fraction n d
-- >
-- > instance Listable Fraction where
-- >   tiers  =  maybeCons2 mkFraction
maybeCons2 :: (Listable a, Listable b) => (a -> b -> Maybe c) -> [[c]]
maybeCons2 :: (a -> b -> Maybe c) -> [[c]]
maybeCons2 a -> b -> Maybe c
f  =  [[c]] -> [[c]]
forall a. [[a]] -> [[a]]
delay ([[c]] -> [[c]]) -> [[c]] -> [[c]]
forall a b. (a -> b) -> a -> b
$ ((a, b) -> Maybe c) -> [[(a, b)]] -> [[c]]
forall a b. (a -> Maybe b) -> [[a]] -> [[b]]
mapMaybeT ((a -> b -> Maybe c) -> (a, b) -> Maybe c
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> b -> Maybe c
f) [[(a, b)]]
forall a. Listable a => [[a]]
tiers

-- | Like '><', but over 3 lists of tiers.
product3 :: [[a]] -> [[b]]-> [[c]] -> [[(a,b,c)]]
product3 :: [[a]] -> [[b]] -> [[c]] -> [[(a, b, c)]]
product3  =  (a -> b -> c -> (a, b, c))
-> [[a]] -> [[b]] -> [[c]] -> [[(a, b, c)]]
forall a b c d.
(a -> b -> c -> d) -> [[a]] -> [[b]] -> [[c]] -> [[d]]
product3With (\a
x b
y c
z -> (a
x,b
y,c
z))

-- | Like 'productWith', but over 3 lists of tiers.
product3With :: (a->b->c->d) -> [[a]] -> [[b]] -> [[c]] -> [[d]]
product3With :: (a -> b -> c -> d) -> [[a]] -> [[b]] -> [[c]] -> [[d]]
product3With a -> b -> c -> d
f [[a]]
xss [[b]]
yss [[c]]
zss  =  ((c -> d) -> c -> d) -> [[c -> d]] -> [[c]] -> [[d]]
forall a b c. (a -> b -> c) -> [[a]] -> [[b]] -> [[c]]
productWith (c -> d) -> c -> d
forall a b. (a -> b) -> a -> b
($) ((a -> b -> c -> d) -> [[a]] -> [[b]] -> [[c -> d]]
forall a b c. (a -> b -> c) -> [[a]] -> [[b]] -> [[c]]
productWith a -> b -> c -> d
f [[a]]
xss [[b]]
yss) [[c]]
zss

-- | Take the product of lists of tiers
--   by a function returning a 'Maybe' value
--   discarding 'Nothing' values.
productMaybeWith :: (a->b->Maybe c) -> [[a]] -> [[b]] -> [[c]]
productMaybeWith :: (a -> b -> Maybe c) -> [[a]] -> [[b]] -> [[c]]
productMaybeWith a -> b -> Maybe c
_ [[a]]
_ []  =  []
productMaybeWith a -> b -> Maybe c
_ [] [[b]]
_  =  []
productMaybeWith a -> b -> Maybe c
f ([a]
xs:[[a]]
xss) [[b]]
yss  =  ([b] -> [c]) -> [[b]] -> [[c]]
forall a b. (a -> b) -> [a] -> [b]
map ([a]
xs [a] -> [b] -> [c]
**) [[b]]
yss
                                 [[c]] -> [[c]] -> [[c]]
forall a. [[a]] -> [[a]] -> [[a]]
\/ [[c]] -> [[c]]
forall a. [[a]] -> [[a]]
delay ((a -> b -> Maybe c) -> [[a]] -> [[b]] -> [[c]]
forall a b c. (a -> b -> Maybe c) -> [[a]] -> [[b]] -> [[c]]
productMaybeWith a -> b -> Maybe c
f [[a]]
xss [[b]]
yss)
  where
  [a]
xs ** :: [a] -> [b] -> [c]
** [b]
ys  =  [Maybe c] -> [c]
forall a. [Maybe a] -> [a]
catMaybes [ a -> b -> Maybe c
f a
x b
y | a
x <- [a]
xs, b
y <- [b]
ys ]

-- | Takes as argument tiers of element values;
--   returns tiers of pairs with distinct element values.
--
-- When argument tiers have no repeated elements:
--
-- > distinctPairs xss  =  xss >< xss  `suchThat` uncurry (/=)
distinctPairs :: [[a]] -> [[(a,a)]]
distinctPairs :: [[a]] -> [[(a, a)]]
distinctPairs  =  (a -> a -> (a, a)) -> [[a]] -> [[(a, a)]]
forall a b. (a -> a -> b) -> [[a]] -> [[b]]
distinctPairsWith (,)

-- | 'distinctPairs' by a given function:
--
-- > distinctPairsWith f  =  mapT (uncurry f) . distinctPairs
distinctPairsWith :: (a -> a -> b) -> [[a]] -> [[b]]
distinctPairsWith :: (a -> a -> b) -> [[a]] -> [[b]]
distinctPairsWith a -> a -> b
f  =  [[[[b]]]] -> [[b]]
forall a. [[[[a]]]] -> [[a]]
concatT ([[[[b]]]] -> [[b]]) -> ([[a]] -> [[[[b]]]]) -> [[a]] -> [[b]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [[a]] -> [[b]]) -> [[a]] -> [[[[b]]]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
choicesWith (\a
e -> (a -> b) -> [[a]] -> [[b]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT (a -> a -> b
f a
e))

-- | Takes as argument tiers of element values;
--   returns tiers of unordered pairs where, in enumeration order,
--   the first element is less than or equal to the second.
--
-- The name of this function is perhaps a misnomer.  But in mathematics,
-- an unordered pair is a pair where you don't care about element order, e.g.:
-- @(1,2) = (2,1)@.  This function will enumerate canonical versions of such
-- pairs where the first element is less than the second.
--
-- The returned element pairs can be seen as bags with two elements.
--
-- When argument tiers are listed in 'Ord':
--
-- > distinctPairs xss  =  xss >< xss  `suchThat` uncurry (<=)
unorderedPairs :: [[a]] -> [[(a,a)]]
unorderedPairs :: [[a]] -> [[(a, a)]]
unorderedPairs  =  (a -> a -> (a, a)) -> [[a]] -> [[(a, a)]]
forall a b. (a -> a -> b) -> [[a]] -> [[b]]
unorderedPairsWith (,)

-- | 'unorderedPairs' by a given function:
--
-- > unorderedPairsWith f  =  mapT (uncurry f) . unorderedPairs
unorderedPairsWith :: (a -> a -> b) -> [[a]] -> [[b]]
unorderedPairsWith :: (a -> a -> b) -> [[a]] -> [[b]]
unorderedPairsWith a -> a -> b
f  =  [[[[b]]]] -> [[b]]
forall a. [[[[a]]]] -> [[a]]
concatT ([[[[b]]]] -> [[b]]) -> ([[a]] -> [[[[b]]]]) -> [[a]] -> [[b]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [[a]] -> [[b]]) -> [[a]] -> [[[[b]]]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
bagChoicesWith (\a
e -> (a -> b) -> [[a]] -> [[b]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT (a -> a -> b
f a
e))

-- | Takes as argument tiers of element values;
--   returns tiers of unordered pairs where, in enumeration order,
--   the first element is strictly less than the second.
--
-- The returned element pairs can be seen as sets with two elements.
--
-- When argument tiers are listed in 'Ord':
--
-- > distinctPairs xss  =  xss >< xss  `suchThat` uncurry (<)
unorderedDistinctPairs :: [[a]] -> [[(a,a)]]
unorderedDistinctPairs :: [[a]] -> [[(a, a)]]
unorderedDistinctPairs  =  (a -> a -> (a, a)) -> [[a]] -> [[(a, a)]]
forall a b. (a -> a -> b) -> [[a]] -> [[b]]
unorderedDistinctPairsWith (,)

-- | 'unorderedPairs' by a given function:
--
-- > unorderedDistinctPairsWith f  =  mapT (uncurry f) . unorderedDistinctPairs
unorderedDistinctPairsWith :: (a -> a -> b) -> [[a]] -> [[b]]
unorderedDistinctPairsWith :: (a -> a -> b) -> [[a]] -> [[b]]
unorderedDistinctPairsWith a -> a -> b
f  =  [[[[b]]]] -> [[b]]
forall a. [[[[a]]]] -> [[a]]
concatT ([[[[b]]]] -> [[b]]) -> ([[a]] -> [[[[b]]]]) -> [[a]] -> [[b]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [[a]] -> [[b]]) -> [[a]] -> [[[[b]]]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
setChoicesWith (\a
e -> (a -> b) -> [[a]] -> [[b]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT (a -> a -> b
f a
e))

-- | Takes as argument tiers of element values;
--   returns tiers of lists of elements.
--
-- > listsOf [[]]  =  [[[]]]
--
-- > listsOf [[x]]  =  [ [[]]
-- >                   , [[x]]
-- >                   , [[x,x]]
-- >                   , [[x,x,x]]
-- >                   , ...
-- >                   ]
--
-- > listsOf [[x],[y]]  =  [ [[]]
-- >                       , [[x]]
-- >                       , [[x,x],[y]]
-- >                       , [[x,x,x],[x,y],[y,x]]
-- >                       , ...
-- >                       ]
listsOf :: [[a]] -> [[[a]]]
listsOf :: [[a]] -> [[[a]]]
listsOf [[a]]
xss  =  [a] -> [[[a]]]
forall a. a -> [[a]]
cons0 []
             [[[a]]] -> [[[a]]] -> [[[a]]]
forall a. [[a]] -> [[a]] -> [[a]]
\/ [[[a]]] -> [[[a]]]
forall a. [[a]] -> [[a]]
delay ((a -> [a] -> [a]) -> [[a]] -> [[[a]]] -> [[[a]]]
forall a b c. (a -> b -> c) -> [[a]] -> [[b]] -> [[c]]
productWith (:) [[a]]
xss ([[a]] -> [[[a]]]
forall a. [[a]] -> [[[a]]]
listsOf [[a]]
xss))

-- | Takes the product of N lists of tiers, producing lists of length N.
--
-- Alternatively,
-- takes as argument a list of lists of tiers of elements;
-- returns lists combining elements of each list of tiers.
--
-- > products [xss]  =  mapT (:[]) xss
-- > products [xss,yss]  =  mapT (\(x,y) -> [x,y]) (xss >< yss)
-- > products [xss,yss,zss]  =  product3With (\x y z -> [x,y,z]) xss yss zss
products :: [ [[a]] ] -> [[ [a] ]]
products :: [[[a]]] -> [[[a]]]
products  =  ([[a]] -> [[[a]]] -> [[[a]]]) -> [[[a]]] -> [[[a]]] -> [[[a]]]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((a -> [a] -> [a]) -> [[a]] -> [[[a]]] -> [[[a]]]
forall a b c. (a -> b -> c) -> [[a]] -> [[b]] -> [[c]]
productWith (:)) [[[]]]

-- | Delete the first occurence of an element in a tier.
--
-- For normalized lists-of-tiers without repetitions, the following holds:
--
-- > deleteT x  =  normalizeT . (`suchThat` (/= x))
deleteT :: Eq a => a -> [[a]] -> [[a]]
deleteT :: a -> [[a]] -> [[a]]
deleteT a
_ []  =  []
deleteT a
y ([]:[[a]]
xss)  =  [] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: a -> [[a]] -> [[a]]
forall a. Eq a => a -> [[a]] -> [[a]]
deleteT a
y [[a]]
xss
deleteT a
y [[a
x]]        | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y     =  []
deleteT a
y ((a
x:[a]
xs):[[a]]
xss) | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y     =  [a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
xss
                       | Bool
otherwise  =  [[a
x]] [[a]] -> [[a]] -> [[a]]
forall a. [[a]] -> [[a]] -> [[a]]
\/ a -> [[a]] -> [[a]]
forall a. Eq a => a -> [[a]] -> [[a]]
deleteT a
y ([a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
xss)

-- | Normalizes tiers by removing up to 12 empty tiers from the end of a list
--   of tiers.
--
-- > normalizeT [xs0,xs1,...,xsN,[]]     =  [xs0,xs1,...,xsN]
-- > normalizeT [xs0,xs1,...,xsN,[],[]]  =  [xs0,xs1,...,xsN]
--
-- The arbitrary limit of 12 tiers is necessary as this function would loop if
-- there is an infinite trail of empty tiers.
normalizeT :: [[a]] -> [[a]]
normalizeT :: [[a]] -> [[a]]
normalizeT []  =  []
normalizeT [[]]  =  []
normalizeT [[],[]]  =  []
normalizeT [[],[],[]]  =  []
normalizeT [[],[],[],[]]  =  []
normalizeT [[],[],[],[], []]  =  []
normalizeT [[],[],[],[], [],[]]  =  []
normalizeT [[],[],[],[], [],[],[]]  =  []
normalizeT [[],[],[],[], [],[],[],[]]  =  []
normalizeT [[],[],[],[], [],[],[],[], []]  =  []
normalizeT [[],[],[],[], [],[],[],[], [],[]]  =  []
normalizeT [[],[],[],[], [],[],[],[], [],[],[]]  =  []
normalizeT [[],[],[],[], [],[],[],[], [],[],[],[]]  =  []
normalizeT ([a]
xs:[[a]]
xss)  =  [a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]] -> [[a]]
forall a. [[a]] -> [[a]]
normalizeT [[a]]
xss

-- | Concatenate tiers of maybes
catMaybesT :: [[Maybe a]] -> [[a]]
catMaybesT :: [[Maybe a]] -> [[a]]
catMaybesT  =  ([Maybe a] -> [a]) -> [[Maybe a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes

-- | Like 'Data.Maybe.mapMaybe' but for tiers.
mapMaybeT :: (a -> Maybe b) -> [[a]] -> [[b]]
mapMaybeT :: (a -> Maybe b) -> [[a]] -> [[b]]
mapMaybeT a -> Maybe b
f  =  [[Maybe b]] -> [[b]]
forall a. [[Maybe a]] -> [[a]]
catMaybesT ([[Maybe b]] -> [[b]]) -> ([[a]] -> [[Maybe b]]) -> [[a]] -> [[b]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe b) -> [[a]] -> [[Maybe b]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT a -> Maybe b
f

-- | Discard elements _not_ matching a predicate.
--
-- > discardT odd [[1],[2,3],[4]]  =  [[],[2],[4]]
discardT :: (a -> Bool) -> [[a]] -> [[a]]
discardT :: (a -> Bool) -> [[a]] -> [[a]]
discardT a -> Bool
p  =  (a -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [[a]] -> [[a]]
filterT (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p)

-- | Discard later elements maching a binary predicate
--   (in relation to an earlier element).
--
-- > discardLaterT (>) [[0],[1],[-1],[2],[-2],...]  =  [[0],[],[-1],[],[-2],...]
-- > discardLaterT (==) [[0],[0,1],[0,1,2],[0,1,2,3],...]  =  [[0],[1],[2],[3]]
--
-- This function is quite innefficient, use with care.
-- Consuming the n-th element takes @O(n^2)@ operations.
discardLaterT :: (a -> a -> Bool) -> [[a]] -> [[a]]
discardLaterT :: (a -> a -> Bool) -> [[a]] -> [[a]]
discardLaterT a -> a -> Bool
d []            =  []
discardLaterT a -> a -> Bool
d ([]:[[a]]
xss)      =  [] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: (a -> a -> Bool) -> [[a]] -> [[a]]
forall a. (a -> a -> Bool) -> [[a]] -> [[a]]
discardLaterT a -> a -> Bool
d [[a]]
xss
discardLaterT a -> a -> Bool
d ((a
x:[a]
xs):[[a]]
xss)  =  [[a
x]]
                              [[a]] -> [[a]] -> [[a]]
forall a. [[a]] -> [[a]] -> [[a]]
\/ (a -> a -> Bool) -> [[a]] -> [[a]]
forall a. (a -> a -> Bool) -> [[a]] -> [[a]]
discardLaterT a -> a -> Bool
d ((a -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [[a]] -> [[a]]
discardT (a -> a -> Bool
`d` a
x) ([a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
xss))

-- | Removes repetitions from tiers.
--
-- > nubT [[0],[0,1],[0,1,2],[0,1,2,3],...]  =  [[0],[1],[2],[3],...]
-- > nubT [[0],[-1,0,1],[-2,-1,0,1,2],...]  =  [[0],[-1,1],[-2,2],...]
--
-- Consuming the n-th element takes @O(n^2)@ operations.
nubT :: Ord a => [[a]] -> [[a]]
nubT :: [[a]] -> [[a]]
nubT  =  (a -> a -> Bool) -> [[a]] -> [[a]]
forall a. (a -> a -> Bool) -> [[a]] -> [[a]]
discardLaterT a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)

-- | Takes as argument tiers of element values;
--   returns tiers of lists with no repeated elements.
--
-- > noDupListsOf [[0],[1],[2],...] ==
-- >   [ [[]]
-- >   , [[0]]
-- >   , [[1]]
-- >   , [[0,1],[1,0],[2]]
-- >   , [[0,2],[2,0],[3]]
-- >   , ...
-- >   ]
noDupListsOf :: [[a]] -> [[[a]]]
noDupListsOf :: [[a]] -> [[[a]]]
noDupListsOf =
  ([[]][[a]] -> [[[a]]] -> [[[a]]]
forall a. a -> [a] -> [a]
:) ([[[a]]] -> [[[a]]]) -> ([[a]] -> [[[a]]]) -> [[a]] -> [[[a]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[[[a]]]]] -> [[[a]]]
forall a. [[[[a]]]] -> [[a]]
concatT ([[[[[a]]]]] -> [[[a]]])
-> ([[a]] -> [[[[[a]]]]]) -> [[a]] -> [[[a]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [[a]] -> [[[a]]]) -> [[a]] -> [[[[[a]]]]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
choicesWith (\a
x [[a]]
xss -> ([a] -> [a]) -> [[[a]]] -> [[[a]]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([[a]] -> [[[a]]]
forall a. [[a]] -> [[[a]]]
noDupListsOf [[a]]
xss))

-- | Takes as argument tiers of element values;
--   returns tiers of size-ordered lists of elements possibly with repetition.
--
-- > bagsOf [[0],[1],[2],...] =
-- >   [ [[]]
-- >   , [[0]]
-- >   , [[0,0],[1]]
-- >   , [[0,0,0],[0,1],[2]]
-- >   , [[0,0,0,0],[0,0,1],[0,2],[1,1],[3]]
-- >   , [[0,0,0,0,0],[0,0,0,1],[0,0,2],[0,1,1],[0,3],[1,2],[4]]
-- >   , ...
-- >   ]
bagsOf :: [[a]] -> [[[a]]]
bagsOf :: [[a]] -> [[[a]]]
bagsOf  =  ([[]][[a]] -> [[[a]]] -> [[[a]]]
forall a. a -> [a] -> [a]
:) ([[[a]]] -> [[[a]]]) -> ([[a]] -> [[[a]]]) -> [[a]] -> [[[a]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[[[a]]]]] -> [[[a]]]
forall a. [[[[a]]]] -> [[a]]
concatT ([[[[[a]]]]] -> [[[a]]])
-> ([[a]] -> [[[[[a]]]]]) -> [[a]] -> [[[a]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [[a]] -> [[[a]]]) -> [[a]] -> [[[[[a]]]]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
bagChoicesWith (\a
x [[a]]
xss -> ([a] -> [a]) -> [[[a]]] -> [[[a]]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([[a]] -> [[[a]]]
forall a. [[a]] -> [[[a]]]
bagsOf [[a]]
xss))


-- | Takes as argument tiers of element values;
--   returns tiers of size-ordered lists of elements without repetition.
--
-- > setsOf [[0],[1],[2],...] =
-- >   [ [[]]
-- >   , [[0]]
-- >   , [[1]]
-- >   , [[0,1],[2]]
-- >   , [[0,2],[3]]
-- >   , [[0,3],[1,2],[4]]
-- >   , [[0,1,2],[0,4],[1,3],[5]]
-- >   , ...
-- >   ]
--
-- Can be used in the constructor of specialized 'Listable' instances.
-- For 'Data.Set.Set' (from "Data.Set"), we would have:
--
-- > instance Listable a => Listable (Set a) where
-- >   tiers  =  mapT fromList $ setsOf tiers
setsOf :: [[a]] -> [[[a]]]
setsOf :: [[a]] -> [[[a]]]
setsOf  =  ([[]][[a]] -> [[[a]]] -> [[[a]]]
forall a. a -> [a] -> [a]
:) ([[[a]]] -> [[[a]]]) -> ([[a]] -> [[[a]]]) -> [[a]] -> [[[a]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[[[a]]]]] -> [[[a]]]
forall a. [[[[a]]]] -> [[a]]
concatT ([[[[[a]]]]] -> [[[a]]])
-> ([[a]] -> [[[[[a]]]]]) -> [[a]] -> [[[a]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [[a]] -> [[[a]]]) -> [[a]] -> [[[[[a]]]]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
setChoicesWith (\a
x [[a]]
xss -> ([a] -> [a]) -> [[[a]]] -> [[[a]]]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([[a]] -> [[[a]]]
forall a. [[a]] -> [[[a]]]
setsOf [[a]]
xss))

-- | Takes as arguments tiers of source and target values;
--   returns tiers of maps from the source to the target encoded as lists
--   without repetition.
maps :: [[a]] -> [[b]] -> [[[(a,b)]]]
maps :: [[a]] -> [[b]] -> [[[(a, b)]]]
maps [[a]]
xss [[b]]
yss  =  ([a] -> [[[(a, b)]]]) -> [[[a]]] -> [[[(a, b)]]]
forall a b. (a -> [[b]]) -> [[a]] -> [[b]]
concatMapT [a] -> [[[(a, b)]]]
forall b. [b] -> [[[(b, b)]]]
mapsFor ([[a]] -> [[[a]]]
forall a. [[a]] -> [[[a]]]
setsOf [[a]]
xss)
  where
--mapsFor :: [a] -> [[ [(a,b)] ]]
  mapsFor :: [b] -> [[[(b, b)]]]
mapsFor [b]
xs  =  [b] -> [b] -> [(b, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [b]
xs ([b] -> [(b, b)]) -> [[[b]]] -> [[[(b, b)]]]
forall a b. (a -> b) -> [[a]] -> [[b]]
`mapT` [[[b]]] -> [[[b]]]
forall a. [[[a]]] -> [[[a]]]
products ([[b]] -> b -> [[b]]
forall a b. a -> b -> a
const [[b]]
yss (b -> [[b]]) -> [b] -> [[[b]]]
forall a b. (a -> b) -> [a] -> [b]
`map` [b]
xs)

-- | Lists tiers of choices.
-- Choices are pairs of values and tiers excluding that value.
--
-- > choices [[False,True]] == [[(False,[[True]]),(True,[[False]])]]
-- > choices [[1],[2],[3]]
-- >   == [ [(1,[[],[2],[3]])]
-- >      , [(2,[[1],[],[3]])]
-- >      , [(3,[[1],[2],[]])] ]
--
-- Each choice is sized by the extracted element.
choices :: [[a]] -> [[(a,[[a]])]]
choices :: [[a]] -> [[(a, [[a]])]]
choices  =  (a -> [[a]] -> (a, [[a]])) -> [[a]] -> [[(a, [[a]])]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
choicesWith (,)

-- | Like 'choices', but allows a custom function.
choicesWith :: (a -> [[a]] -> b) -> [[a]] -> [[b]]
choicesWith :: (a -> [[a]] -> b) -> [[a]] -> [[b]]
choicesWith a -> [[a]] -> b
f []            =  []
choicesWith a -> [[a]] -> b
f [[]]          =  []
choicesWith a -> [[a]] -> b
f ([]:[[a]]
xss)      =  [] [b] -> [[b]] -> [[b]]
forall a. a -> [a] -> [a]
: (a -> [[a]] -> b) -> [[a]] -> [[b]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
choicesWith (\a
y [[a]]
yss -> a -> [[a]] -> b
f a
y ([][a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]] -> [[a]]
forall a. [[a]] -> [[a]]
normalizeT [[a]]
yss)) [[a]]
xss
choicesWith a -> [[a]] -> b
f ((a
x:[a]
xs):[[a]]
xss)  =  [[a -> [[a]] -> b
f a
x ([a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
xss)]]
                            [[b]] -> [[b]] -> [[b]]
forall a. [[a]] -> [[a]] -> [[a]]
\/ (a -> [[a]] -> b) -> [[a]] -> [[b]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
choicesWith (\a
y ([a]
ys:[[a]]
yss) -> a -> [[a]] -> b
f a
y ((a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
yss)) ([a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
xss)

-- | Like 'choices' but lists tiers of non-decreasing (ascending) choices.
--   Used to construct 'bagsOf' values.
--
-- > bagChoices [[False,True]] =
-- >   [ [(False,[[False,True]]), (True,[[True]])]
-- >   ]
--
-- > bagChoices [[1],[2],[3],...] =
-- >   [ [(1,[[1],[2],[3],...])]
-- >   , [(2,[[ ],[2],[3],...])]
-- >   , [(3,[[ ],[ ],[3],...])]
-- >   , ...
-- >   ]
bagChoices :: [[a]] -> [[(a,[[a]])]]
bagChoices :: [[a]] -> [[(a, [[a]])]]
bagChoices  =  (a -> [[a]] -> (a, [[a]])) -> [[a]] -> [[(a, [[a]])]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
bagChoicesWith (,)

-- | Like 'bagChoices' but customized by a function.
bagChoicesWith :: (a -> [[a]] -> b) -> [[a]] -> [[b]]
bagChoicesWith :: (a -> [[a]] -> b) -> [[a]] -> [[b]]
bagChoicesWith a -> [[a]] -> b
f []            =  []
bagChoicesWith a -> [[a]] -> b
f [[]]          =  []
bagChoicesWith a -> [[a]] -> b
f ([]:[[a]]
xss)      =  [] [b] -> [[b]] -> [[b]]
forall a. a -> [a] -> [a]
: (a -> [[a]] -> b) -> [[a]] -> [[b]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
bagChoicesWith (\a
y [[a]]
yss -> a -> [[a]] -> b
f a
y ([][a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
yss)) [[a]]
xss
bagChoicesWith a -> [[a]] -> b
f ((a
x:[a]
xs):[[a]]
xss)  =  [[a -> [[a]] -> b
f a
x ((a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
xss)]]
                               [[b]] -> [[b]] -> [[b]]
forall a. [[a]] -> [[a]] -> [[a]]
\/ (a -> [[a]] -> b) -> [[a]] -> [[b]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
bagChoicesWith a -> [[a]] -> b
f ([a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
xss)

-- | Like 'choices' but lists tiers of strictly ascending choices.
--   Used to construct 'setsOf' values.
--
-- > setChoices [[False,True]] == [[(False,[[True]]),(True,[[]])]]
-- > setChoices [[1],[2],[3]]
-- >   == [ [(1,[[],[2],[3]])]
-- >      , [(2,[[],[],[3]])]
-- >      , [(3,[[],[],[]])]
-- >      ]
setChoices :: [[a]] -> [[(a,[[a]])]]
setChoices :: [[a]] -> [[(a, [[a]])]]
setChoices  =  (a -> [[a]] -> (a, [[a]])) -> [[a]] -> [[(a, [[a]])]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
setChoicesWith (,)

-- | Like 'setChoices' but customized by a function.
setChoicesWith :: (a -> [[a]] -> b) -> [[a]] -> [[b]]
setChoicesWith :: (a -> [[a]] -> b) -> [[a]] -> [[b]]
setChoicesWith a -> [[a]] -> b
f []            =  []
setChoicesWith a -> [[a]] -> b
f [[]]          =  []
setChoicesWith a -> [[a]] -> b
f ([]:[[a]]
xss)      =  [] [b] -> [[b]] -> [[b]]
forall a. a -> [a] -> [a]
: (a -> [[a]] -> b) -> [[a]] -> [[b]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
setChoicesWith (\a
y [[a]]
yss -> a -> [[a]] -> b
f a
y ([][a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]] -> [[a]]
forall a. [[a]] -> [[a]]
normalizeT [[a]]
yss)) [[a]]
xss
setChoicesWith a -> [[a]] -> b
f ((a
x:[a]
xs):[[a]]
xss)  =  [[a -> [[a]] -> b
f a
x ([a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
xss)]]
                               [[b]] -> [[b]] -> [[b]]
forall a. [[a]] -> [[a]] -> [[a]]
\/ (a -> [[a]] -> b) -> [[a]] -> [[b]]
forall a b. (a -> [[a]] -> b) -> [[a]] -> [[b]]
setChoicesWith a -> [[a]] -> b
f ([a]
xs[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
xss)

-- | Takes as argument an integer length and tiers of element values;
--   returns tiers of lists of element values of the given length.
--
-- > listsOfLength 3 [[0],[1],[2],[3],[4]...] =
-- >   [ [[0,0,0]]
-- >   , [[0,0,1],[0,1,0],[1,0,0]]
-- >   , [[0,0,2],[0,1,1],[0,2,0],[1,0,1],[1,1,0],[2,0,0]]
-- >   , ...
-- >   ]
listsOfLength :: Int -> [[a]] -> [[[a]]]
listsOfLength :: Int -> [[a]] -> [[[a]]]
listsOfLength Int
n [[a]]
xss  =  [[[a]]] -> [[[a]]]
forall a. [[[a]]] -> [[[a]]]
products (Int -> [[a]] -> [[[a]]]
forall a. Int -> a -> [a]
replicate Int
n [[a]]
xss)




-- -- Showing tiers of values -- --

-- | Shows a list of strings, one element per line.
--   The returned string _does not_ end with a line break.
--
-- > listLines []  =  "[]"
-- > listLines ["0"]  =  "[0]"
-- > listLines ["0","1"]  =  "[ 0\n\
-- >                          \, 1\n\
-- >                          \]"
listLines :: [String] -> String
listLines :: [String] -> String
listLines []  =  String
"[]"
listLines [String
s] | Char
'\n' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
s  =  String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
listLines [String]
ss  =  (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]")
              (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
              ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> String -> String
beside ([String
"[ "] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
forall a. a -> [a]
repeat String
", ")
              ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
ss
  where
  beside :: String -> String -> String
  beside :: String -> String -> String
beside String
s  =  String -> String
forall a. [a] -> [a]
init
            (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
            ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> String -> String
forall a. [a] -> [a] -> [a]
(++) ([String
s] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
forall a. a -> [a]
repeat (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' '))
            ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines


-- | Shows a list, one element per line.
--   The returned string _does not_ end with a line break.
--
-- > listLines []  =  "[]"
-- > listLines [0]  =  "[0]"
-- > listLines [0,1]  =  "[ 0\n\
-- >                     \, 1\n\
-- >                     \]"
showListLines :: Show a => [a] -> String
showListLines :: [a] -> String
showListLines  =  [String] -> String
listLines ([String] -> String) -> ([a] -> [String]) -> [a] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show

-- | Shows a list of strings, adding @...@ to the end when longer than given
--   length.
--
-- > dotsLongerThan 3 ["1","2"]          =  [1,2]
-- > dotsLongerThan 3 ["1","2","3","4"]  = [1,2,3,...]
-- > dotsLongerThan 5 $ map show [1..]   = [1,2,3,4,5,...]
dotsLongerThan :: Int -> [String] -> [String]
dotsLongerThan :: Int -> [String] -> [String]
dotsLongerThan Int
n [String]
xs  =  Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
n [String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"..." | Bool -> Bool
not (Bool -> Bool) -> ([String] -> Bool) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
n [String]
xs]

-- | Alternative to 'show' for 'tiers' with one element per line.
--   (useful for debugging, see also 'printTiers').
--
--   This function can be useful when debugging your 'Listable' instances.
showTiers :: Show a => Int -> [[a]] -> String
showTiers :: Int -> [[a]] -> String
showTiers Int
n  =  [String] -> String
listLines ([String] -> String) -> ([[a]] -> [String]) -> [[a]] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
dotsLongerThan Int
n ([String] -> [String]) -> ([[a]] -> [String]) -> [[a]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> String) -> [[a]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> String
forall a. Show a => [a] -> String
showListLines

-- | Alternative to 'print' for 'tiers' with one element per line.
--   (useful for debugging, see also 'showTiers').
--
-- > > printTiers 3 (tiers :: [[Int]])
-- > [ [0]
-- > , [1]
-- > , [-1]
-- > , ...
-- > ]
-- > > printTiers 3 (tiers :: [[Bool]])
-- > [ [ False
-- >   , True
-- >   ]
-- > ]
--
-- This function can be useful when debugging your 'Listable' instances.
printTiers :: Show a => Int -> [[a]] -> IO ()
printTiers :: Int -> [[a]] -> IO ()
printTiers Int
n  =  String -> IO ()
putStrLn (String -> IO ()) -> ([[a]] -> String) -> [[a]] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[a]] -> String
forall a. Show a => Int -> [[a]] -> String
showTiers Int
n

-- | Checks if a list-of-tiers is finite.
--
-- **Warning:** this is just an approximation, a list-of-tiers is considered
--              finite if it has less than 13 values.  This function may give
--              false negatives.
finite :: [[a]] -> Bool
finite :: [[a]] -> Bool
finite  =  [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> ([[a]] -> [a]) -> [[a]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
12 ([a] -> [a]) -> ([[a]] -> [a]) -> [[a]] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> ([[a]] -> [[a]]) -> [[a]] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[a]] -> [[a]]
forall a. Int -> [a] -> [a]
take Int
60
-- NOTE: `take 60` is there because otherwise this function would not
-- terminate in a tier-of-lists with an infinite tail of empty tiers, like:
-- > import Test.LeanCheck.Function.ListsOfPairs
-- > map length (tiers :: [[ Nat -> () ]]) [1,0,0,0,0,0,...]
-- maybe this `take 60` has to be copied in other places of LeanCheck to avoid
-- similar issues of non-temrination.