-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Unfolder
-- Copyright   :  (c) Sjoerd Visscher 2014
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  sjoerd@w3future.com
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Unfolders provide a way to unfold data structures.
-- They are basically 'Alternative' instances, but the 'choose' method
-- allows the unfolder to do something special for the recursive positions
-- of the data structure.
-----------------------------------------------------------------------------
{-# LANGUAGE
    GeneralizedNewtypeDeriving
  , RankNTypes
  , Trustworthy
  , CPP
  #-}

#if !defined(MIN_VERSION_containers)
#define MIN_VERSION_containers(x,y,z) 0
#endif

module Data.Unfolder
  (

  -- * Unfolder
    Unfolder(..)
  , chooseMonadDefault
  , chooseMapMonadDefault

  , between
  , betweenD
  , boundedEnum
  , boundedEnumD

  -- ** Unfolder instances
  , Random(..)

  , Arb(..)
  , arbUnit

  , NumConst(..)
  , Nth(..)

  -- * UnfolderTransformer
  , UnfolderTransformer(..)
  , ala
  , ala2
  , ala3

  -- ** UnfolderTransformer instances
  , DualA(..)

  , NT(..)
  , WithRec(..)
  , withRec
  , limitDepth

  , BFS(..)
  , Split
  , bfs
  , bfsBySum
  )
  where

import Control.Applicative
import Control.Monad
import Control.Arrow (ArrowZero, ArrowPlus)

import Data.Functor.Product
import Data.Functor.Compose
import Data.Functor.Reverse
import Control.Applicative.Backwards
import Control.Applicative.Lift
import Control.Monad.Trans.Except
import Control.Monad.Trans.List
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.RWS
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer

import qualified System.Random as R
import Test.QuickCheck (Arbitrary(..), Gen, oneof, elements, frequency, sized, resize)

import Data.Monoid (Monoid(..))
import Data.Maybe (catMaybes)
import qualified Data.Sequence as S


-- | Unfolders provide a way to unfold data structures.
-- The methods have default implementations in terms of 'Alternative',
-- but you can implement 'chooseMap' to act on recursive positions of the
-- data structure, or simply to provide a faster implementation than
-- 'foldr ((<|>) . f) empty'.
class Alternative f => Unfolder f where
  -- | Choose one of the values from the list.
  choose :: [f a] -> f a
  choose = (f a -> f a) -> [f a] -> f a
forall (f :: * -> *) a b. Unfolder f => (a -> f b) -> [a] -> f b
chooseMap f a -> f a
forall a. a -> a
id
  -- | Choose one of the values from the list and apply the given function.
  chooseMap :: (a -> f b) -> [a] -> f b
  chooseMap a -> f b
f = (a -> f b -> f b) -> f b -> [a] -> f b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (f b -> f b -> f b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (f b -> f b -> f b) -> (a -> f b) -> a -> f b -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f) f b
forall (f :: * -> *) a. Alternative f => f a
empty
  -- | Given a number 'n', return a number between '0' and 'n - 1'.
  chooseInt :: Int -> f Int
  chooseInt Int
n = (Int -> f Int) -> [Int] -> f Int
forall (f :: * -> *) a b. Unfolder f => (a -> f b) -> [a] -> f b
chooseMap Int -> f Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

-- | If an unfolder is monadic, 'choose' can be implemented in terms of 'chooseInt'.
chooseMonadDefault :: (Monad m, Unfolder m) => [m a] -> m a
chooseMonadDefault :: [m a] -> m a
chooseMonadDefault [m a]
ms = Int -> m Int
forall (f :: * -> *). Unfolder f => Int -> f Int
chooseInt ([m a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [m a]
ms) m Int -> (Int -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([m a]
ms [m a] -> Int -> m a
forall a. [a] -> Int -> a
!!)

-- | If an unfolder is monadic, 'chooseMap' can be implemented in terms of 'chooseInt'.
chooseMapMonadDefault :: (Monad m, Unfolder m) => (a -> m b) -> [a] -> m b
chooseMapMonadDefault :: (a -> m b) -> [a] -> m b
chooseMapMonadDefault a -> m b
f [a]
as = Int -> m Int
forall (f :: * -> *). Unfolder f => Int -> f Int
chooseInt ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as) m Int -> (Int -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m b
f (a -> m b) -> (Int -> a) -> Int -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a]
as [a] -> Int -> a
forall a. [a] -> Int -> a
!!)

-- | If a datatype is enumerable, we can use 'chooseInt' to generate a value.
-- This is the function to use if you want to unfold a datatype that has no type arguments (has kind @*@).
between :: (Unfolder f, Enum a) => a -> a -> f a
between :: a -> a -> f a
between a
lb a
ub = (\Int
x -> Int -> a
forall a. Enum a => Int -> a
toEnum (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int
forall a. Enum a => a -> Int
fromEnum a
lb)) (Int -> a) -> f Int -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> f Int
forall (f :: * -> *). Unfolder f => Int -> f Int
chooseInt (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int
forall a. Enum a => a -> Int
fromEnum a
ub Int -> Int -> Int
forall a. Num a => a -> a -> a
- a -> Int
forall a. Enum a => a -> Int
fromEnum a
lb)

-- | If a datatype is also bounded, we can choose between all possible values.
--
-- > boundedEnum = between minBound maxBound
boundedEnum :: (Unfolder f, Bounded a, Enum a) => f a
boundedEnum :: f a
boundedEnum = a -> a -> f a
forall (f :: * -> *) a. (Unfolder f, Enum a) => a -> a -> f a
between a
forall a. Bounded a => a
minBound a
forall a. Bounded a => a
maxBound

-- | 'betweenD' uses 'choose' to generate a value. It chooses between the lower bound and one
--   of the higher values. This means that f.e. breadth-first unfolding and arbitrary will prefer
--   lower values.
betweenD :: (Unfolder f, Enum a) => a -> a -> f a
betweenD :: a -> a -> f a
betweenD a
lb0 a
ub = a -> Int -> f a
forall t (f :: * -> *) a.
(Ord t, Num t, Unfolder f, Enum a, Enum t) =>
a -> t -> f a
betweenD' a
lb0 (a -> Int
forall a. Enum a => a -> Int
fromEnum a
ub Int -> Int -> Int
forall a. Num a => a -> a -> a
- a -> Int
forall a. Enum a => a -> Int
fromEnum a
lb0)
  where
    betweenD' :: a -> t -> f a
betweenD' a
lb t
n | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
0 = f a
forall (f :: * -> *) a. Alternative f => f a
empty
                   | Bool
otherwise = [f a] -> f a
forall (f :: * -> *) a. Unfolder f => [f a] -> f a
choose [a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
lb, a -> t -> f a
betweenD' (a -> a
forall a. Enum a => a -> a
succ a
lb) (t -> t
forall a. Enum a => a -> a
pred t
n)]

-- | > boundedEnumD = betweenD minBound maxBound
boundedEnumD :: (Unfolder f, Bounded a, Enum a) => f a
boundedEnumD :: f a
boundedEnumD = a -> a -> f a
forall (f :: * -> *) a. (Unfolder f, Enum a) => a -> a -> f a
betweenD a
forall a. Bounded a => a
minBound a
forall a. Bounded a => a
maxBound



-- | Derived instance.
instance MonadPlus m => Unfolder (WrappedMonad m)

-- | Derived instance.
instance (ArrowZero a, ArrowPlus a) => Unfolder (WrappedArrow a b)

-- | Don't choose but return all items.
instance Unfolder [] where
  choose :: [[a]] -> [a]
choose = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  chooseMap :: (a -> [b]) -> [a] -> [b]
chooseMap = (a -> [b]) -> [a] -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
  chooseInt :: Int -> [Int]
chooseInt Int
n = [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

-- | Always choose the first item.
instance Unfolder Maybe where
  choose :: [Maybe a] -> Maybe a
choose = (Maybe a -> Maybe a -> Maybe a) -> Maybe a -> [Maybe a] -> Maybe a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Maybe a -> Maybe a -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing
  chooseMap :: (a -> Maybe b) -> [a] -> Maybe b
chooseMap a -> Maybe b
f = (a -> Maybe b -> Maybe b) -> Maybe b -> [a] -> Maybe b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe b -> Maybe b -> Maybe b
forall a b. a -> b -> a
const (Maybe b -> Maybe b -> Maybe b)
-> (a -> Maybe b) -> a -> Maybe b -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
f) Maybe b
forall a. Maybe a
Nothing
  chooseInt :: Int -> Maybe Int
chooseInt Int
0 = Maybe Int
forall a. Maybe a
Nothing
  chooseInt Int
_ = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0

-- | Derived instance.
instance (Unfolder p, Unfolder q) => Unfolder (Product p q) where
  chooseMap :: (a -> Product p q b) -> [a] -> Product p q b
chooseMap a -> Product p q b
f [a]
as = p b -> q b -> Product p q b
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair ((a -> p b) -> [a] -> p b
forall (f :: * -> *) a b. Unfolder f => (a -> f b) -> [a] -> f b
chooseMap (Product p q b -> p b
forall (f :: * -> *) (g :: * -> *) a. Product f g a -> f a
fstP (Product p q b -> p b) -> (a -> Product p q b) -> a -> p b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Product p q b
f) [a]
as) ((a -> q b) -> [a] -> q b
forall (f :: * -> *) a b. Unfolder f => (a -> f b) -> [a] -> f b
chooseMap (Product p q b -> q b
forall (f :: * -> *) (g :: * -> *) a. Product f g a -> g a
sndP (Product p q b -> q b) -> (a -> Product p q b) -> a -> q b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Product p q b
f) [a]
as)
    where
      fstP :: Product f g a -> f a
fstP (Pair f a
p g a
_) = f a
p
      sndP :: Product f g a -> g a
sndP (Pair f a
_ g a
q) = g a
q
  chooseInt :: Int -> Product p q Int
chooseInt Int
n = p Int -> q Int -> Product p q Int
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair (Int -> p Int
forall (f :: * -> *). Unfolder f => Int -> f Int
chooseInt Int
n) (Int -> q Int
forall (f :: * -> *). Unfolder f => Int -> f Int
chooseInt Int
n)

-- | Derived instance.
instance (Unfolder p, Applicative q) => Unfolder (Compose p q) where
  chooseMap :: (a -> Compose p q b) -> [a] -> Compose p q b
chooseMap a -> Compose p q b
f = p (q b) -> Compose p q b
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (p (q b) -> Compose p q b)
-> ([a] -> p (q b)) -> [a] -> Compose p q b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> p (q b)) -> [a] -> p (q b)
forall (f :: * -> *) a b. Unfolder f => (a -> f b) -> [a] -> f b
chooseMap (Compose p q b -> p (q b)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose p q b -> p (q b)) -> (a -> Compose p q b) -> a -> p (q b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Compose p q b
f)
  chooseInt :: Int -> Compose p q Int
chooseInt Int
n = p (q Int) -> Compose p q Int
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (p (q Int) -> Compose p q Int) -> p (q Int) -> Compose p q Int
forall a b. (a -> b) -> a -> b
$ Int -> q Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> q Int) -> p Int -> p (q Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> p Int
forall (f :: * -> *). Unfolder f => Int -> f Int
chooseInt Int
n

-- | Derived instance.
instance Unfolder f => Unfolder (Reverse f) where
  chooseMap :: (a -> Reverse f b) -> [a] -> Reverse f b
chooseMap a -> Reverse f b
f = f b -> Reverse f b
forall k (f :: k -> *) (a :: k). f a -> Reverse f a
Reverse (f b -> Reverse f b) -> ([a] -> f b) -> [a] -> Reverse f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> [a] -> f b
forall (f :: * -> *) a b. Unfolder f => (a -> f b) -> [a] -> f b
chooseMap (Reverse f b -> f b
forall k (f :: k -> *) (a :: k). Reverse f a -> f a
getReverse (Reverse f b -> f b) -> (a -> Reverse f b) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Reverse f b
f)
  chooseInt :: Int -> Reverse f Int
chooseInt Int
n = f Int -> Reverse f Int
forall k (f :: k -> *) (a :: k). f a -> Reverse f a
Reverse (f Int -> Reverse f Int) -> f Int -> Reverse f Int
forall a b. (a -> b) -> a -> b
$ Int -> f Int
forall (f :: * -> *). Unfolder f => Int -> f Int
chooseInt Int
n

-- | Derived instance.
instance Unfolder f => Unfolder (Backwards f) where
  chooseMap :: (a -> Backwards f b) -> [a] -> Backwards f b
chooseMap a -> Backwards f b
f = f b -> Backwards f b
forall k (f :: k -> *) (a :: k). f a -> Backwards f a
Backwards (f b -> Backwards f b) -> ([a] -> f b) -> [a] -> Backwards f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> [a] -> f b
forall (f :: * -> *) a b. Unfolder f => (a -> f b) -> [a] -> f b
chooseMap (Backwards f b -> f b
forall k (f :: k -> *) (a :: k). Backwards f a -> f a
forwards (Backwards f b -> f b) -> (a -> Backwards f b) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Backwards f b
f)
  chooseInt :: Int -> Backwards f Int
chooseInt Int
n = f Int -> Backwards f Int
forall k (f :: k -> *) (a :: k). f a -> Backwards f a
Backwards (f Int -> Backwards f Int) -> f Int -> Backwards f Int
forall a b. (a -> b) -> a -> b
$ Int -> f Int
forall (f :: * -> *). Unfolder f => Int -> f Int
chooseInt Int
n

-- | Derived instance.
instance Unfolder f => Unfolder (Lift f)

-- | Derived instance.
instance (Functor m, Monad m, Monoid e) => Unfolder (ExceptT e m)

-- | Derived instance.
instance Applicative f => Unfolder (ListT f) where
  {-# INLINABLE chooseMap #-}
  chooseMap :: (a -> ListT f b) -> [a] -> ListT f b
chooseMap a -> ListT f b
f = f [b] -> ListT f b
forall (m :: * -> *) a. m [a] -> ListT m a
ListT (f [b] -> ListT f b) -> ([a] -> f [b]) -> [a] -> ListT f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f [b] -> f [b]) -> f [b] -> [a] -> f [b]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> f [b] -> f [b]
appRun ([b] -> f [b]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
    where
      appRun :: a -> f [b] -> f [b]
appRun a
x f [b]
ys = [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
(++) ([b] -> [b] -> [b]) -> f [b] -> f ([b] -> [b])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ListT f b -> f [b]
forall (m :: * -> *) a. ListT m a -> m [a]
runListT (a -> ListT f b
f a
x) f ([b] -> [b]) -> f [b] -> f [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f [b]
ys
  chooseInt :: Int -> ListT f Int
chooseInt Int
n = f [Int] -> ListT f Int
forall (m :: * -> *) a. m [a] -> ListT m a
ListT (f [Int] -> ListT f Int) -> f [Int] -> ListT f Int
forall a b. (a -> b) -> a -> b
$ [Int] -> f [Int]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

-- | Derived instance.
instance (Functor m, Monad m) => Unfolder (MaybeT m) where
  chooseMap :: (a -> MaybeT m b) -> [a] -> MaybeT m b
chooseMap a -> MaybeT m b
_ [] = m (Maybe b) -> MaybeT m b
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Maybe b -> m (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing)
  chooseMap a -> MaybeT m b
f (a
a : [a]
as) = m (Maybe b) -> MaybeT m b
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe b) -> MaybeT m b) -> m (Maybe b) -> MaybeT m b
forall a b. (a -> b) -> a -> b
$ do
    Maybe b
res <- MaybeT m b -> m (Maybe b)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (a -> MaybeT m b
f a
a)
    case Maybe b
res of
      Maybe b
Nothing -> MaybeT m b -> m (Maybe b)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m b -> m (Maybe b)) -> MaybeT m b -> m (Maybe b)
forall a b. (a -> b) -> a -> b
$ (a -> MaybeT m b) -> [a] -> MaybeT m b
forall (f :: * -> *) a b. Unfolder f => (a -> f b) -> [a] -> f b
chooseMap a -> MaybeT m b
f [a]
as
      Just b
_ -> Maybe b -> m (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
res
  chooseInt :: Int -> MaybeT m Int
chooseInt Int
0 = m (Maybe Int) -> MaybeT m Int
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Int) -> MaybeT m Int) -> m (Maybe Int) -> MaybeT m Int
forall a b. (a -> b) -> a -> b
$ Maybe Int -> m (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
  chooseInt Int
_ = m (Maybe Int) -> MaybeT m Int
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Int) -> MaybeT m Int) -> m (Maybe Int) -> MaybeT m Int
forall a b. (a -> b) -> a -> b
$ Maybe Int -> m (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0)

-- | Derived instance.
instance (Monoid w, MonadPlus m, Unfolder m) => Unfolder (RWST r w s m) where
  chooseMap :: (a -> RWST r w s m b) -> [a] -> RWST r w s m b
chooseMap a -> RWST r w s m b
f [a]
as = (r -> s -> m (b, s, w)) -> RWST r w s m b
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWST ((r -> s -> m (b, s, w)) -> RWST r w s m b)
-> (r -> s -> m (b, s, w)) -> RWST r w s m b
forall a b. (a -> b) -> a -> b
$ \r
r s
s -> (a -> m (b, s, w)) -> [a] -> m (b, s, w)
forall (f :: * -> *) a b. Unfolder f => (a -> f b) -> [a] -> f b
chooseMap (\a
a -> RWST r w s m b -> r -> s -> m (b, s, w)
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (a -> RWST r w s m b
f a
a) r
r s
s) [a]
as

-- | Derived instance.
instance (MonadPlus m, Unfolder m) => Unfolder (StateT s m) where
  chooseMap :: (a -> StateT s m b) -> [a] -> StateT s m b
chooseMap a -> StateT s m b
f [a]
as = (s -> m (b, s)) -> StateT s m b
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> m (b, s)) -> StateT s m b)
-> (s -> m (b, s)) -> StateT s m b
forall a b. (a -> b) -> a -> b
$ \s
s -> (a -> m (b, s)) -> [a] -> m (b, s)
forall (f :: * -> *) a b. Unfolder f => (a -> f b) -> [a] -> f b
chooseMap (\a
a -> a -> StateT s m b
f a
a StateT s m b -> s -> m (b, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
`runStateT` s
s) [a]
as

-- | Derived instance.
instance Unfolder m => Unfolder (ReaderT r m) where
  chooseMap :: (a -> ReaderT r m b) -> [a] -> ReaderT r m b
chooseMap a -> ReaderT r m b
f [a]
as = (r -> m b) -> ReaderT r m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m b) -> ReaderT r m b) -> (r -> m b) -> ReaderT r m b
forall a b. (a -> b) -> a -> b
$ \r
r -> (a -> m b) -> [a] -> m b
forall (f :: * -> *) a b. Unfolder f => (a -> f b) -> [a] -> f b
chooseMap (\a
a -> a -> ReaderT r m b
f a
a ReaderT r m b -> r -> m b
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` r
r) [a]
as

-- | Derived instance.
instance (Monoid w, Unfolder m) => Unfolder (WriterT w m) where
  chooseMap :: (a -> WriterT w m b) -> [a] -> WriterT w m b
chooseMap a -> WriterT w m b
f = m (b, w) -> WriterT w m b
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (m (b, w) -> WriterT w m b)
-> ([a] -> m (b, w)) -> [a] -> WriterT w m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m (b, w)) -> [a] -> m (b, w)
forall (f :: * -> *) a b. Unfolder f => (a -> f b) -> [a] -> f b
chooseMap (WriterT w m b -> m (b, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT w m b -> m (b, w))
-> (a -> WriterT w m b) -> a -> m (b, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> WriterT w m b
f)

-- | Don't choose but return all items.
instance Unfolder S.Seq where
#if MIN_VERSION_containers(0,5,6)
  chooseInt :: Int -> Seq Int
chooseInt Int
n = Int -> (Int -> Int) -> Seq Int
forall a. Int -> (Int -> a) -> Seq a
S.fromFunction Int
n Int -> Int
forall a. a -> a
id
#endif


newtype Random g m a = Random { Random g m a -> StateT g m a
getRandom :: StateT g m a }
  deriving (a -> Random g m b -> Random g m a
(a -> b) -> Random g m a -> Random g m b
(forall a b. (a -> b) -> Random g m a -> Random g m b)
-> (forall a b. a -> Random g m b -> Random g m a)
-> Functor (Random g m)
forall a b. a -> Random g m b -> Random g m a
forall a b. (a -> b) -> Random g m a -> Random g m b
forall g (m :: * -> *) a b.
Functor m =>
a -> Random g m b -> Random g m a
forall g (m :: * -> *) a b.
Functor m =>
(a -> b) -> Random g m a -> Random g m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Random g m b -> Random g m a
$c<$ :: forall g (m :: * -> *) a b.
Functor m =>
a -> Random g m b -> Random g m a
fmap :: (a -> b) -> Random g m a -> Random g m b
$cfmap :: forall g (m :: * -> *) a b.
Functor m =>
(a -> b) -> Random g m a -> Random g m b
Functor, Functor (Random g m)
a -> Random g m a
Functor (Random g m)
-> (forall a. a -> Random g m a)
-> (forall a b.
    Random g m (a -> b) -> Random g m a -> Random g m b)
-> (forall a b c.
    (a -> b -> c) -> Random g m a -> Random g m b -> Random g m c)
-> (forall a b. Random g m a -> Random g m b -> Random g m b)
-> (forall a b. Random g m a -> Random g m b -> Random g m a)
-> Applicative (Random g m)
Random g m a -> Random g m b -> Random g m b
Random g m a -> Random g m b -> Random g m a
Random g m (a -> b) -> Random g m a -> Random g m b
(a -> b -> c) -> Random g m a -> Random g m b -> Random g m c
forall a. a -> Random g m a
forall a b. Random g m a -> Random g m b -> Random g m a
forall a b. Random g m a -> Random g m b -> Random g m b
forall a b. Random g m (a -> b) -> Random g m a -> Random g m b
forall a b c.
(a -> b -> c) -> Random g m a -> Random g m b -> Random g m c
forall g (m :: * -> *). Monad m => Functor (Random g m)
forall g (m :: * -> *) a. Monad m => a -> Random g m a
forall g (m :: * -> *) a b.
Monad m =>
Random g m a -> Random g m b -> Random g m a
forall g (m :: * -> *) a b.
Monad m =>
Random g m a -> Random g m b -> Random g m b
forall g (m :: * -> *) a b.
Monad m =>
Random g m (a -> b) -> Random g m a -> Random g m b
forall g (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Random g m a -> Random g m b -> Random g m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Random g m a -> Random g m b -> Random g m a
$c<* :: forall g (m :: * -> *) a b.
Monad m =>
Random g m a -> Random g m b -> Random g m a
*> :: Random g m a -> Random g m b -> Random g m b
$c*> :: forall g (m :: * -> *) a b.
Monad m =>
Random g m a -> Random g m b -> Random g m b
liftA2 :: (a -> b -> c) -> Random g m a -> Random g m b -> Random g m c
$cliftA2 :: forall g (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Random g m a -> Random g m b -> Random g m c
<*> :: Random g m (a -> b) -> Random g m a -> Random g m b
$c<*> :: forall g (m :: * -> *) a b.
Monad m =>
Random g m (a -> b) -> Random g m a -> Random g m b
pure :: a -> Random g m a
$cpure :: forall g (m :: * -> *) a. Monad m => a -> Random g m a
$cp1Applicative :: forall g (m :: * -> *). Monad m => Functor (Random g m)
Applicative, Applicative (Random g m)
a -> Random g m a
Applicative (Random g m)
-> (forall a b.
    Random g m a -> (a -> Random g m b) -> Random g m b)
-> (forall a b. Random g m a -> Random g m b -> Random g m b)
-> (forall a. a -> Random g m a)
-> Monad (Random g m)
Random g m a -> (a -> Random g m b) -> Random g m b
Random g m a -> Random g m b -> Random g m b
forall a. a -> Random g m a
forall a b. Random g m a -> Random g m b -> Random g m b
forall a b. Random g m a -> (a -> Random g m b) -> Random g m b
forall g (m :: * -> *). Monad m => Applicative (Random g m)
forall g (m :: * -> *) a. Monad m => a -> Random g m a
forall g (m :: * -> *) a b.
Monad m =>
Random g m a -> Random g m b -> Random g m b
forall g (m :: * -> *) a b.
Monad m =>
Random g m a -> (a -> Random g m b) -> Random g m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Random g m a
$creturn :: forall g (m :: * -> *) a. Monad m => a -> Random g m a
>> :: Random g m a -> Random g m b -> Random g m b
$c>> :: forall g (m :: * -> *) a b.
Monad m =>
Random g m a -> Random g m b -> Random g m b
>>= :: Random g m a -> (a -> Random g m b) -> Random g m b
$c>>= :: forall g (m :: * -> *) a b.
Monad m =>
Random g m a -> (a -> Random g m b) -> Random g m b
$cp1Monad :: forall g (m :: * -> *). Monad m => Applicative (Random g m)
Monad)
instance (Functor m, Monad m, R.RandomGen g) => Alternative (Random g m) where
  empty :: Random g m a
empty = [Random g m a] -> Random g m a
forall (f :: * -> *) a. Unfolder f => [f a] -> f a
choose []
  Random g m a
a <|> :: Random g m a -> Random g m a -> Random g m a
<|> Random g m a
b = [Random g m a] -> Random g m a
forall (f :: * -> *) a. Unfolder f => [f a] -> f a
choose [Random g m a
a, Random g m a
b]
instance (Functor m, Monad m, R.RandomGen g) => MonadPlus (Random g m) where
  mzero :: Random g m a
mzero = [Random g m a] -> Random g m a
forall (f :: * -> *) a. Unfolder f => [f a] -> f a
choose []
  mplus :: Random g m a -> Random g m a -> Random g m a
mplus Random g m a
a Random g m a
b = [Random g m a] -> Random g m a
forall (f :: * -> *) a. Unfolder f => [f a] -> f a
choose [Random g m a
a, Random g m a
b]
-- | Choose randomly.
instance (Functor m, Monad m, R.RandomGen g) => Unfolder (Random g m) where
  choose :: [Random g m a] -> Random g m a
choose = [Random g m a] -> Random g m a
forall (m :: * -> *) a. (Monad m, Unfolder m) => [m a] -> m a
chooseMonadDefault
  chooseMap :: (a -> Random g m b) -> [a] -> Random g m b
chooseMap = (a -> Random g m b) -> [a] -> Random g m b
forall (m :: * -> *) a b.
(Monad m, Unfolder m) =>
(a -> m b) -> [a] -> m b
chooseMapMonadDefault
  chooseInt :: Int -> Random g m Int
chooseInt Int
n = StateT g m Int -> Random g m Int
forall g (m :: * -> *) a. StateT g m a -> Random g m a
Random (StateT g m Int -> Random g m Int)
-> ((g -> m (Int, g)) -> StateT g m Int)
-> (g -> m (Int, g))
-> Random g m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g -> m (Int, g)) -> StateT g m Int
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((g -> m (Int, g)) -> Random g m Int)
-> (g -> m (Int, g)) -> Random g m Int
forall a b. (a -> b) -> a -> b
$ (Int, g) -> m (Int, g)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int, g) -> m (Int, g)) -> (g -> (Int, g)) -> g -> m (Int, g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> g -> (Int, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
R.randomR (Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)


-- | A variant of Test.QuickCheck.Gen, with failure
-- and a count of the number of recursive positions and parameter positions.
data Arb a = Arb Int Int (Gen (Maybe a))

instance Functor Arb where
  fmap :: (a -> b) -> Arb a -> Arb b
fmap a -> b
f (Arb Int
r Int
p Gen (Maybe a)
g) = Int -> Int -> Gen (Maybe b) -> Arb b
forall a. Int -> Int -> Gen (Maybe a) -> Arb a
Arb Int
r Int
p (Gen (Maybe b) -> Arb b) -> Gen (Maybe b) -> Arb b
forall a b. (a -> b) -> a -> b
$ (Maybe a -> Maybe b) -> Gen (Maybe a) -> Gen (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) Gen (Maybe a)
g

instance Applicative Arb where
  pure :: a -> Arb a
pure = Int -> Int -> Gen (Maybe a) -> Arb a
forall a. Int -> Int -> Gen (Maybe a) -> Arb a
Arb Int
0 Int
0 (Gen (Maybe a) -> Arb a) -> (a -> Gen (Maybe a)) -> a -> Arb a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> Gen (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Gen (Maybe a)) -> (a -> Maybe a) -> a -> Gen (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Arb Int
r1 Int
p1 Gen (Maybe (a -> b))
ff <*> :: Arb (a -> b) -> Arb a -> Arb b
<*> Arb Int
r2 Int
p2 Gen (Maybe a)
fx = Int -> Int -> Gen (Maybe b) -> Arb b
forall a. Int -> Int -> Gen (Maybe a) -> Arb a
Arb (Int
r1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r2) (Int
p1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
p2) (Gen (Maybe b) -> Arb b) -> Gen (Maybe b) -> Arb b
forall a b. (a -> b) -> a -> b
$ (Maybe (a -> b) -> Maybe a -> Maybe b)
-> Gen (Maybe (a -> b)) -> Gen (Maybe a) -> Gen (Maybe b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) Gen (Maybe (a -> b))
ff Gen (Maybe a)
fx

instance Alternative Arb where
  empty :: Arb a
empty = Int -> Int -> Gen (Maybe a) -> Arb a
forall a. Int -> Int -> Gen (Maybe a) -> Arb a
Arb Int
0 Int
0 (Maybe a -> Gen (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)
  Arb Int
r1 Int
p1 Gen (Maybe a)
g1 <|> :: Arb a -> Arb a -> Arb a
<|> Arb Int
r2 Int
p2 Gen (Maybe a)
g2 = Int -> Int -> Gen (Maybe a) -> Arb a
forall a. Int -> Int -> Gen (Maybe a) -> Arb a
Arb (Int
r1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r2) (Int
p1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
p2) (Gen (Maybe a) -> Arb a) -> Gen (Maybe a) -> Arb a
forall a b. (a -> b) -> a -> b
$ Gen (Maybe a)
g1 Gen (Maybe a) -> (Maybe a -> Gen (Maybe a)) -> Gen (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe a
a -> Gen (Maybe a)
g2 Gen (Maybe a) -> (Maybe a -> Gen (Maybe a)) -> Gen (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe a
b -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Gen a -> Gen (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Gen a
forall a. [a] -> Gen a
elements ([Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes [Maybe a
a, Maybe a
b])

-- | Limit the depth of the generated data structure by
-- dividing the given size by the number of recursive positions.
instance Unfolder Arb where
  choose :: [Arb a] -> Arb a
choose [Arb a]
as = Int -> Int -> Gen (Maybe a) -> Arb a
forall a. Int -> Int -> Gen (Maybe a) -> Arb a
Arb Int
1 Int
0 (Gen (Maybe a) -> Arb a) -> Gen (Maybe a) -> Arb a
forall a b. (a -> b) -> a -> b
$ (Int -> Gen (Maybe a)) -> Gen (Maybe a)
forall a. (Int -> Gen a) -> Gen a
sized Int -> Gen (Maybe a)
g
    where
      g :: Int -> Gen (Maybe a)
g Int
n = [(Int, Gen (Maybe a))] -> Gen (Maybe a)
forall a. [(Int, Gen (Maybe a))] -> Gen (Maybe a)
freq ([(Int, Gen (Maybe a))] -> Gen (Maybe a))
-> [(Int, Gen (Maybe a))] -> Gen (Maybe a)
forall a b. (a -> b) -> a -> b
$ (Arb a -> [(Int, Gen (Maybe a))])
-> [Arb a] -> [(Int, Gen (Maybe a))]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Arb a -> [(Int, Gen (Maybe a))]
forall a. Arb a -> [(Int, Gen (Maybe a))]
f [Arb a]
as
        where
          (Int
recPosCount, Int
parPosCount) = (Arb a -> (Int, Int) -> (Int, Int))
-> (Int, Int) -> [Arb a] -> (Int, Int)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Arb Int
r Int
p Gen (Maybe a)
_) (Int
rc, Int
pc) -> (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rc, Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pc)) (Int
0, Int
0) [Arb a]
as
          recSize :: Int
recSize = (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
parPosCount) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
recPosCount
          f :: Arb a -> [(Int, Gen (Maybe a))]
f (Arb Int
r Int
p Gen (Maybe a)
gen) = if (Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
recSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) Bool -> Bool -> Bool
|| (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) then [] else [(Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
recSize, Int -> Gen (Maybe a) -> Gen (Maybe a)
forall a. Int -> Gen a -> Gen a
resize (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
recSize) Gen (Maybe a)
gen)]
          freq :: [(Int, Gen (Maybe a))] -> Gen (Maybe a)
freq [] = Maybe a -> Gen (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
          freq [(Int, Gen (Maybe a))]
as = [(Int, Gen (Maybe a))] -> Gen (Maybe a)
forall a. [(Int, Gen a)] -> Gen a
frequency [(Int, Gen (Maybe a))]
as

arbUnit :: Arbitrary a => Arb a
arbUnit :: Arb a
arbUnit = Int -> Int -> Gen (Maybe a) -> Arb a
forall a. Int -> Int -> Gen (Maybe a) -> Arb a
Arb Int
0 Int
1 (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Gen a -> Gen (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
forall a. Arbitrary a => Gen a
arbitrary)


-- | Variant of 'Data.Functor.Constant' that does multiplication of the constants for @\<*>@ and addition for @\<|>@.
newtype NumConst a x = NumConst { NumConst a x -> a
getNumConst :: a } deriving (NumConst a x -> NumConst a x -> Bool
(NumConst a x -> NumConst a x -> Bool)
-> (NumConst a x -> NumConst a x -> Bool) -> Eq (NumConst a x)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a x. Eq a => NumConst a x -> NumConst a x -> Bool
/= :: NumConst a x -> NumConst a x -> Bool
$c/= :: forall a x. Eq a => NumConst a x -> NumConst a x -> Bool
== :: NumConst a x -> NumConst a x -> Bool
$c== :: forall a x. Eq a => NumConst a x -> NumConst a x -> Bool
Eq, Int -> NumConst a x -> ShowS
[NumConst a x] -> ShowS
NumConst a x -> String
(Int -> NumConst a x -> ShowS)
-> (NumConst a x -> String)
-> ([NumConst a x] -> ShowS)
-> Show (NumConst a x)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a x. Show a => Int -> NumConst a x -> ShowS
forall a x. Show a => [NumConst a x] -> ShowS
forall a x. Show a => NumConst a x -> String
showList :: [NumConst a x] -> ShowS
$cshowList :: forall a x. Show a => [NumConst a x] -> ShowS
show :: NumConst a x -> String
$cshow :: forall a x. Show a => NumConst a x -> String
showsPrec :: Int -> NumConst a x -> ShowS
$cshowsPrec :: forall a x. Show a => Int -> NumConst a x -> ShowS
Show)
instance Functor (NumConst a) where
  fmap :: (a -> b) -> NumConst a a -> NumConst a b
fmap a -> b
_ (NumConst a
a) = a -> NumConst a b
forall a x. a -> NumConst a x
NumConst a
a
instance Num a => Applicative (NumConst a) where
  pure :: a -> NumConst a a
pure a
_ = a -> NumConst a a
forall a x. a -> NumConst a x
NumConst a
1
  NumConst a
a <*> :: NumConst a (a -> b) -> NumConst a a -> NumConst a b
<*> NumConst a
b = a -> NumConst a b
forall a x. a -> NumConst a x
NumConst (a -> NumConst a b) -> a -> NumConst a b
forall a b. (a -> b) -> a -> b
$ a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
b
instance Num a => Alternative (NumConst a) where
  empty :: NumConst a a
empty = a -> NumConst a a
forall a x. a -> NumConst a x
NumConst a
0
  NumConst a
a <|> :: NumConst a a -> NumConst a a -> NumConst a a
<|> NumConst a
b = a -> NumConst a a
forall a x. a -> NumConst a x
NumConst (a -> NumConst a a) -> a -> NumConst a a
forall a b. (a -> b) -> a -> b
$ a
a a -> a -> a
forall a. Num a => a -> a -> a
+ a
b
-- | Unfolds to a constant numeric value. Useful for counting shapes.
instance Num a => Unfolder (NumConst a)


data Nth a = Nth
  { Nth a -> Integer
size :: Integer
  , Nth a -> Integer -> a
getNth :: Integer -> a
  }
instance Functor Nth where
  fmap :: (a -> b) -> Nth a -> Nth b
fmap a -> b
f (Nth Integer
sizeA Integer -> a
as) = Integer -> (Integer -> b) -> Nth b
forall a. Integer -> (Integer -> a) -> Nth a
Nth Integer
sizeA (a -> b
f (a -> b) -> (Integer -> a) -> Integer -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> a
as)
instance Applicative Nth where
  pure :: a -> Nth a
pure a
a = Integer -> (Integer -> a) -> Nth a
forall a. Integer -> (Integer -> a) -> Nth a
Nth Integer
1 (a -> Integer -> a
forall a b. a -> b -> a
const a
a)
  Nth Integer
sizeF Integer -> a -> b
fs <*> :: Nth (a -> b) -> Nth a -> Nth b
<*> Nth Integer
sizeA Integer -> a
as = Integer -> (Integer -> b) -> Nth b
forall a. Integer -> (Integer -> a) -> Nth a
Nth (Integer
sizeF Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
sizeA) ((Integer -> b) -> Nth b) -> (Integer -> b) -> Nth b
forall a b. (a -> b) -> a -> b
$ \Integer
n ->
    let (Integer
l, Integer
r) = Integer
n Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`divMod` Integer
sizeA in Integer -> a -> b
fs Integer
l (Integer -> a
as Integer
r)
instance Alternative Nth where
  empty :: Nth a
empty = Integer -> (Integer -> a) -> Nth a
forall a. Integer -> (Integer -> a) -> Nth a
Nth Integer
0 (a -> Integer -> a
forall a b. a -> b -> a
const a
forall a. HasCallStack => a
undefined)
  Nth Integer
sizeA Integer -> a
as <|> :: Nth a -> Nth a -> Nth a
<|> Nth Integer
sizeB Integer -> a
bs = Integer -> (Integer -> a) -> Nth a
forall a. Integer -> (Integer -> a) -> Nth a
Nth (Integer
sizeA Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
sizeB) ((Integer -> a) -> Nth a) -> (Integer -> a) -> Nth a
forall a b. (a -> b) -> a -> b
$ \Integer
n ->
    if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
sizeA then Integer -> a
as Integer
n else Integer -> a
bs (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
sizeA)
-- | Get the nth value from the sequence of all possible values.
instance Unfolder Nth where
  chooseInt :: Int -> Nth Int
chooseInt Int
n = Integer -> (Integer -> Int) -> Nth Int
forall a. Integer -> (Integer -> a) -> Nth a
Nth (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n) Integer -> Int
forall a. Num a => Integer -> a
fromInteger


-- | An 'UnfolderTransformer' changes the way an 'Unfolder' unfolds.
class UnfolderTransformer t where
  -- | Lift a computation from the argument unfolder to the constructed unfolder.
  lift :: Unfolder f => f a -> t f a

-- | Run an unfolding function with one argument using an 'UnfolderTransformer', given a way to run the transformer.
ala :: (UnfolderTransformer t, Unfolder f) => (t f b -> f b) -> (t f a -> t f b) -> f a -> f b
ala :: (t f b -> f b) -> (t f a -> t f b) -> f a -> f b
ala t f b -> f b
lower t f a -> t f b
f = t f b -> f b
lower (t f b -> f b) -> (f a -> t f b) -> f a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t f a -> t f b
f (t f a -> t f b) -> (f a -> t f a) -> f a -> t f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> t f a
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
(UnfolderTransformer t, Unfolder f) =>
f a -> t f a
lift

-- | Run an unfolding function with two arguments using an 'UnfolderTransformer', given a way to run the transformer.
ala2 :: (UnfolderTransformer t, Unfolder f) => (t f c -> f c) -> (t f a -> t f b -> t f c) -> f a -> f b -> f c
ala2 :: (t f c -> f c) -> (t f a -> t f b -> t f c) -> f a -> f b -> f c
ala2 t f c -> f c
lower t f a -> t f b -> t f c
f = (t f c -> f c) -> (t f b -> t f c) -> f b -> f c
forall (t :: (* -> *) -> * -> *) (f :: * -> *) b a.
(UnfolderTransformer t, Unfolder f) =>
(t f b -> f b) -> (t f a -> t f b) -> f a -> f b
ala t f c -> f c
lower ((t f b -> t f c) -> f b -> f c)
-> (f a -> t f b -> t f c) -> f a -> f b -> f c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t f a -> t f b -> t f c
f (t f a -> t f b -> t f c)
-> (f a -> t f a) -> f a -> t f b -> t f c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> t f a
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
(UnfolderTransformer t, Unfolder f) =>
f a -> t f a
lift

-- | Run an unfolding function with three arguments using an 'UnfolderTransformer', given a way to run the transformer.
ala3 :: (UnfolderTransformer t, Unfolder f) => (t f d -> f d) -> (t f a -> t f b -> t f c -> t f d) -> f a -> f b -> f c -> f d
ala3 :: (t f d -> f d)
-> (t f a -> t f b -> t f c -> t f d) -> f a -> f b -> f c -> f d
ala3 t f d -> f d
lower t f a -> t f b -> t f c -> t f d
f = (t f d -> f d) -> (t f b -> t f c -> t f d) -> f b -> f c -> f d
forall (t :: (* -> *) -> * -> *) (f :: * -> *) c a b.
(UnfolderTransformer t, Unfolder f) =>
(t f c -> f c) -> (t f a -> t f b -> t f c) -> f a -> f b -> f c
ala2 t f d -> f d
lower ((t f b -> t f c -> t f d) -> f b -> f c -> f d)
-> (f a -> t f b -> t f c -> t f d) -> f a -> f b -> f c -> f d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t f a -> t f b -> t f c -> t f d
f (t f a -> t f b -> t f c -> t f d)
-> (f a -> t f a) -> f a -> t f b -> t f c -> t f d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> t f a
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
(UnfolderTransformer t, Unfolder f) =>
f a -> t f a
lift


-- | 'DualA' flips the @\<|>@ operator from `Alternative`.
newtype DualA f a = DualA { DualA f a -> f a
getDualA :: f a }
  deriving (DualA f a -> DualA f a -> Bool
(DualA f a -> DualA f a -> Bool)
-> (DualA f a -> DualA f a -> Bool) -> Eq (DualA f a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (f :: * -> *) a. Eq (f a) => DualA f a -> DualA f a -> Bool
/= :: DualA f a -> DualA f a -> Bool
$c/= :: forall (f :: * -> *) a. Eq (f a) => DualA f a -> DualA f a -> Bool
== :: DualA f a -> DualA f a -> Bool
$c== :: forall (f :: * -> *) a. Eq (f a) => DualA f a -> DualA f a -> Bool
Eq, Int -> DualA f a -> ShowS
[DualA f a] -> ShowS
DualA f a -> String
(Int -> DualA f a -> ShowS)
-> (DualA f a -> String)
-> ([DualA f a] -> ShowS)
-> Show (DualA f a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (f :: * -> *) a. Show (f a) => Int -> DualA f a -> ShowS
forall (f :: * -> *) a. Show (f a) => [DualA f a] -> ShowS
forall (f :: * -> *) a. Show (f a) => DualA f a -> String
showList :: [DualA f a] -> ShowS
$cshowList :: forall (f :: * -> *) a. Show (f a) => [DualA f a] -> ShowS
show :: DualA f a -> String
$cshow :: forall (f :: * -> *) a. Show (f a) => DualA f a -> String
showsPrec :: Int -> DualA f a -> ShowS
$cshowsPrec :: forall (f :: * -> *) a. Show (f a) => Int -> DualA f a -> ShowS
Show, a -> DualA f b -> DualA f a
(a -> b) -> DualA f a -> DualA f b
(forall a b. (a -> b) -> DualA f a -> DualA f b)
-> (forall a b. a -> DualA f b -> DualA f a) -> Functor (DualA f)
forall a b. a -> DualA f b -> DualA f a
forall a b. (a -> b) -> DualA f a -> DualA f b
forall (f :: * -> *) a b. Functor f => a -> DualA f b -> DualA f a
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> DualA f a -> DualA f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> DualA f b -> DualA f a
$c<$ :: forall (f :: * -> *) a b. Functor f => a -> DualA f b -> DualA f a
fmap :: (a -> b) -> DualA f a -> DualA f b
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> DualA f a -> DualA f b
Functor, Functor (DualA f)
a -> DualA f a
Functor (DualA f)
-> (forall a. a -> DualA f a)
-> (forall a b. DualA f (a -> b) -> DualA f a -> DualA f b)
-> (forall a b c.
    (a -> b -> c) -> DualA f a -> DualA f b -> DualA f c)
-> (forall a b. DualA f a -> DualA f b -> DualA f b)
-> (forall a b. DualA f a -> DualA f b -> DualA f a)
-> Applicative (DualA f)
DualA f a -> DualA f b -> DualA f b
DualA f a -> DualA f b -> DualA f a
DualA f (a -> b) -> DualA f a -> DualA f b
(a -> b -> c) -> DualA f a -> DualA f b -> DualA f c
forall a. a -> DualA f a
forall a b. DualA f a -> DualA f b -> DualA f a
forall a b. DualA f a -> DualA f b -> DualA f b
forall a b. DualA f (a -> b) -> DualA f a -> DualA f b
forall a b c. (a -> b -> c) -> DualA f a -> DualA f b -> DualA f c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (f :: * -> *). Applicative f => Functor (DualA f)
forall (f :: * -> *) a. Applicative f => a -> DualA f a
forall (f :: * -> *) a b.
Applicative f =>
DualA f a -> DualA f b -> DualA f a
forall (f :: * -> *) a b.
Applicative f =>
DualA f a -> DualA f b -> DualA f b
forall (f :: * -> *) a b.
Applicative f =>
DualA f (a -> b) -> DualA f a -> DualA f b
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> DualA f a -> DualA f b -> DualA f c
<* :: DualA f a -> DualA f b -> DualA f a
$c<* :: forall (f :: * -> *) a b.
Applicative f =>
DualA f a -> DualA f b -> DualA f a
*> :: DualA f a -> DualA f b -> DualA f b
$c*> :: forall (f :: * -> *) a b.
Applicative f =>
DualA f a -> DualA f b -> DualA f b
liftA2 :: (a -> b -> c) -> DualA f a -> DualA f b -> DualA f c
$cliftA2 :: forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> DualA f a -> DualA f b -> DualA f c
<*> :: DualA f (a -> b) -> DualA f a -> DualA f b
$c<*> :: forall (f :: * -> *) a b.
Applicative f =>
DualA f (a -> b) -> DualA f a -> DualA f b
pure :: a -> DualA f a
$cpure :: forall (f :: * -> *) a. Applicative f => a -> DualA f a
$cp1Applicative :: forall (f :: * -> *). Applicative f => Functor (DualA f)
Applicative)

instance Alternative f => Alternative (DualA f) where
  empty :: DualA f a
empty = f a -> DualA f a
forall (f :: * -> *) a. f a -> DualA f a
DualA f a
forall (f :: * -> *) a. Alternative f => f a
empty
  DualA f a
a <|> :: DualA f a -> DualA f a -> DualA f a
<|> DualA f a
b = f a -> DualA f a
forall (f :: * -> *) a. f a -> DualA f a
DualA (f a
b f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> f a
a)

-- | Reverse the list passed to choose.
instance Unfolder f => Unfolder (DualA f) where
  chooseMap :: (a -> DualA f b) -> [a] -> DualA f b
chooseMap a -> DualA f b
f = f b -> DualA f b
forall (f :: * -> *) a. f a -> DualA f a
DualA (f b -> DualA f b) -> ([a] -> f b) -> [a] -> DualA f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> [a] -> f b
forall (f :: * -> *) a b. Unfolder f => (a -> f b) -> [a] -> f b
chooseMap (DualA f b -> f b
forall (f :: * -> *) a. DualA f a -> f a
getDualA (DualA f b -> f b) -> (a -> DualA f b) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DualA f b
f) ([a] -> f b) -> ([a] -> [a]) -> [a] -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse
  chooseInt :: Int -> DualA f Int
chooseInt Int
n = f Int -> DualA f Int
forall (f :: * -> *) a. f a -> DualA f a
DualA (f Int -> DualA f Int) -> f Int -> DualA f Int
forall a b. (a -> b) -> a -> b
$ (\Int
x -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x) (Int -> Int) -> f Int -> f Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> f Int
forall (f :: * -> *). Unfolder f => Int -> f Int
chooseInt Int
n

instance UnfolderTransformer DualA where
  lift :: f a -> DualA f a
lift = f a -> DualA f a
forall (f :: * -> *) a. f a -> DualA f a
DualA


-- | Natural transformations
data NT f g = NT { NT f g -> forall a. f a -> g a
getNT :: forall a. f a -> g a }

newtype WithRec f a = WithRec { WithRec f a -> ReaderT (Int -> NT f f) f a
getWithRec :: ReaderT (Int -> NT f f) f a }
  deriving (a -> WithRec f b -> WithRec f a
(a -> b) -> WithRec f a -> WithRec f b
(forall a b. (a -> b) -> WithRec f a -> WithRec f b)
-> (forall a b. a -> WithRec f b -> WithRec f a)
-> Functor (WithRec f)
forall a b. a -> WithRec f b -> WithRec f a
forall a b. (a -> b) -> WithRec f a -> WithRec f b
forall (f :: * -> *) a b.
Functor f =>
a -> WithRec f b -> WithRec f a
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> WithRec f a -> WithRec f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> WithRec f b -> WithRec f a
$c<$ :: forall (f :: * -> *) a b.
Functor f =>
a -> WithRec f b -> WithRec f a
fmap :: (a -> b) -> WithRec f a -> WithRec f b
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> WithRec f a -> WithRec f b
Functor, Functor (WithRec f)
a -> WithRec f a
Functor (WithRec f)
-> (forall a. a -> WithRec f a)
-> (forall a b. WithRec f (a -> b) -> WithRec f a -> WithRec f b)
-> (forall a b c.
    (a -> b -> c) -> WithRec f a -> WithRec f b -> WithRec f c)
-> (forall a b. WithRec f a -> WithRec f b -> WithRec f b)
-> (forall a b. WithRec f a -> WithRec f b -> WithRec f a)
-> Applicative (WithRec f)
WithRec f a -> WithRec f b -> WithRec f b
WithRec f a -> WithRec f b -> WithRec f a
WithRec f (a -> b) -> WithRec f a -> WithRec f b
(a -> b -> c) -> WithRec f a -> WithRec f b -> WithRec f c
forall a. a -> WithRec f a
forall a b. WithRec f a -> WithRec f b -> WithRec f a
forall a b. WithRec f a -> WithRec f b -> WithRec f b
forall a b. WithRec f (a -> b) -> WithRec f a -> WithRec f b
forall a b c.
(a -> b -> c) -> WithRec f a -> WithRec f b -> WithRec f c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (f :: * -> *). Applicative f => Functor (WithRec f)
forall (f :: * -> *) a. Applicative f => a -> WithRec f a
forall (f :: * -> *) a b.
Applicative f =>
WithRec f a -> WithRec f b -> WithRec f a
forall (f :: * -> *) a b.
Applicative f =>
WithRec f a -> WithRec f b -> WithRec f b
forall (f :: * -> *) a b.
Applicative f =>
WithRec f (a -> b) -> WithRec f a -> WithRec f b
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> WithRec f a -> WithRec f b -> WithRec f c
<* :: WithRec f a -> WithRec f b -> WithRec f a
$c<* :: forall (f :: * -> *) a b.
Applicative f =>
WithRec f a -> WithRec f b -> WithRec f a
*> :: WithRec f a -> WithRec f b -> WithRec f b
$c*> :: forall (f :: * -> *) a b.
Applicative f =>
WithRec f a -> WithRec f b -> WithRec f b
liftA2 :: (a -> b -> c) -> WithRec f a -> WithRec f b -> WithRec f c
$cliftA2 :: forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> WithRec f a -> WithRec f b -> WithRec f c
<*> :: WithRec f (a -> b) -> WithRec f a -> WithRec f b
$c<*> :: forall (f :: * -> *) a b.
Applicative f =>
WithRec f (a -> b) -> WithRec f a -> WithRec f b
pure :: a -> WithRec f a
$cpure :: forall (f :: * -> *) a. Applicative f => a -> WithRec f a
$cp1Applicative :: forall (f :: * -> *). Applicative f => Functor (WithRec f)
Applicative, Applicative (WithRec f)
WithRec f a
Applicative (WithRec f)
-> (forall a. WithRec f a)
-> (forall a. WithRec f a -> WithRec f a -> WithRec f a)
-> (forall a. WithRec f a -> WithRec f [a])
-> (forall a. WithRec f a -> WithRec f [a])
-> Alternative (WithRec f)
WithRec f a -> WithRec f a -> WithRec f a
WithRec f a -> WithRec f [a]
WithRec f a -> WithRec f [a]
forall a. WithRec f a
forall a. WithRec f a -> WithRec f [a]
forall a. WithRec f a -> WithRec f a -> WithRec f a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
forall (f :: * -> *). Alternative f => Applicative (WithRec f)
forall (f :: * -> *) a. Alternative f => WithRec f a
forall (f :: * -> *) a.
Alternative f =>
WithRec f a -> WithRec f [a]
forall (f :: * -> *) a.
Alternative f =>
WithRec f a -> WithRec f a -> WithRec f a
many :: WithRec f a -> WithRec f [a]
$cmany :: forall (f :: * -> *) a.
Alternative f =>
WithRec f a -> WithRec f [a]
some :: WithRec f a -> WithRec f [a]
$csome :: forall (f :: * -> *) a.
Alternative f =>
WithRec f a -> WithRec f [a]
<|> :: WithRec f a -> WithRec f a -> WithRec f a
$c<|> :: forall (f :: * -> *) a.
Alternative f =>
WithRec f a -> WithRec f a -> WithRec f a
empty :: WithRec f a
$cempty :: forall (f :: * -> *) a. Alternative f => WithRec f a
$cp1Alternative :: forall (f :: * -> *). Alternative f => Applicative (WithRec f)
Alternative)

-- | Applies a certain function depending on the depth at every recursive position.
instance Unfolder f => Unfolder (WithRec f) where
  chooseMap :: (a -> WithRec f b) -> [a] -> WithRec f b
chooseMap a -> WithRec f b
h [a]
as = ReaderT (Int -> NT f f) f b -> WithRec f b
forall (f :: * -> *) a. ReaderT (Int -> NT f f) f a -> WithRec f a
WithRec (ReaderT (Int -> NT f f) f b -> WithRec f b)
-> (((Int -> NT f f) -> f b) -> ReaderT (Int -> NT f f) f b)
-> ((Int -> NT f f) -> f b)
-> WithRec f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int -> NT f f) -> f b) -> ReaderT (Int -> NT f f) f b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (((Int -> NT f f) -> f b) -> WithRec f b)
-> ((Int -> NT f f) -> f b) -> WithRec f b
forall a b. (a -> b) -> a -> b
$ \Int -> NT f f
f ->
    NT f f -> forall a. f a -> f a
forall (f :: * -> *) (g :: * -> *). NT f g -> forall a. f a -> g a
getNT (Int -> NT f f
f Int
0) (f b -> f b) -> f b -> f b
forall a b. (a -> b) -> a -> b
$ (a -> f b) -> [a] -> f b
forall (f :: * -> *) a b. Unfolder f => (a -> f b) -> [a] -> f b
chooseMap ((Int -> NT f f) -> WithRec f b -> f b
forall (f :: * -> *) a. (Int -> NT f f) -> WithRec f a -> f a
withRec (Int -> NT f f
f (Int -> NT f f) -> (Int -> Int) -> Int -> NT f f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Enum a => a -> a
succ) (WithRec f b -> f b) -> (a -> WithRec f b) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> WithRec f b
h) [a]
as

instance UnfolderTransformer WithRec where
  lift :: f a -> WithRec f a
lift = ReaderT (Int -> NT f f) f a -> WithRec f a
forall (f :: * -> *) a. ReaderT (Int -> NT f f) f a -> WithRec f a
WithRec (ReaderT (Int -> NT f f) f a -> WithRec f a)
-> (f a -> ReaderT (Int -> NT f f) f a) -> f a -> WithRec f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int -> NT f f) -> f a) -> ReaderT (Int -> NT f f) f a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (((Int -> NT f f) -> f a) -> ReaderT (Int -> NT f f) f a)
-> (f a -> (Int -> NT f f) -> f a)
-> f a
-> ReaderT (Int -> NT f f) f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> (Int -> NT f f) -> f a
forall a b. a -> b -> a
const

-- | Apply a certain function of type @f a -> f a@ to the result of a 'choose'.
-- The depth is passed as 'Int', so you can apply a different function at each depth.
-- Because of a @forall@, the function needs to be wrapped in a 'NT' constructor.
-- See 'limitDepth' for an example how to use this function.
withRec :: (Int -> NT f f) -> WithRec f a -> f a
withRec :: (Int -> NT f f) -> WithRec f a -> f a
withRec Int -> NT f f
f = (ReaderT (Int -> NT f f) f a -> (Int -> NT f f) -> f a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Int -> NT f f
f) (ReaderT (Int -> NT f f) f a -> f a)
-> (WithRec f a -> ReaderT (Int -> NT f f) f a)
-> WithRec f a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithRec f a -> ReaderT (Int -> NT f f) f a
forall (f :: * -> *) a. WithRec f a -> ReaderT (Int -> NT f f) f a
getWithRec

-- | Limit the depth of an unfolding.
limitDepth :: Unfolder f => Int -> WithRec f a -> f a
limitDepth :: Int -> WithRec f a -> f a
limitDepth Int
m = (Int -> NT f f) -> WithRec f a -> f a
forall (f :: * -> *) a. (Int -> NT f f) -> WithRec f a -> f a
withRec (\Int
d -> (forall a. f a -> f a) -> NT f f
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> NT f g
NT ((forall a. f a -> f a) -> NT f f)
-> (forall a. f a -> f a) -> NT f f
forall a b. (a -> b) -> a -> b
$ if Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
m then f a -> f a -> f a
forall a b. a -> b -> a
const f a
forall (f :: * -> *) a. Alternative f => f a
empty else f a -> f a
forall a. a -> a
id)



-- | Return a generator of values of a given depth.
-- Returns 'Nothing' if there are no values of that depth or deeper.
-- The depth is the number of 'choose' calls.
newtype BFS f x = BFS { BFS f x -> (Int, Split) -> Maybe [f x]
getBFS :: (Int, Split) -> Maybe [f x] }

type Split = Int -> [(Int, Int)]

instance Functor f => Functor (BFS f) where
  fmap :: (a -> b) -> BFS f a -> BFS f b
fmap a -> b
f = ((Int, Split) -> Maybe [f b]) -> BFS f b
forall (f :: * -> *) x. ((Int, Split) -> Maybe [f x]) -> BFS f x
BFS (((Int, Split) -> Maybe [f b]) -> BFS f b)
-> (BFS f a -> (Int, Split) -> Maybe [f b]) -> BFS f a -> BFS f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([f a] -> [f b]) -> Maybe [f a] -> Maybe [f b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f a -> f b) -> [f a] -> [f b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)) (Maybe [f a] -> Maybe [f b])
-> ((Int, Split) -> Maybe [f a]) -> (Int, Split) -> Maybe [f b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (((Int, Split) -> Maybe [f a]) -> (Int, Split) -> Maybe [f b])
-> (BFS f a -> (Int, Split) -> Maybe [f a])
-> BFS f a
-> (Int, Split)
-> Maybe [f b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BFS f a -> (Int, Split) -> Maybe [f a]
forall (f :: * -> *) x. BFS f x -> (Int, Split) -> Maybe [f x]
getBFS

instance Applicative f => Applicative (BFS f) where
  pure :: a -> BFS f a
pure = f a -> BFS f a
forall (f :: * -> *) x. f x -> BFS f x
packBFS (f a -> BFS f a) -> (a -> f a) -> a -> BFS f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  BFS (Int, Split) -> Maybe [f (a -> b)]
ff <*> :: BFS f (a -> b) -> BFS f a -> BFS f b
<*> BFS (Int, Split) -> Maybe [f a]
fx = ((Int, Split) -> Maybe [f b]) -> BFS f b
forall (f :: * -> *) x. ((Int, Split) -> Maybe [f x]) -> BFS f x
BFS (((Int, Split) -> Maybe [f b]) -> BFS f b)
-> ((Int, Split) -> Maybe [f b]) -> BFS f b
forall a b. (a -> b) -> a -> b
$ \(Int
d, Split
split) -> [Maybe [f b]] -> Maybe [f b]
forall a. [Maybe [a]] -> Maybe [a]
flattenBFS ([Maybe [f b]] -> Maybe [f b]) -> [Maybe [f b]] -> Maybe [f b]
forall a b. (a -> b) -> a -> b
$
    [ ([f (a -> b)] -> [f a] -> [f b])
-> Maybe [f (a -> b)] -> Maybe [f a] -> Maybe [f b]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((f (a -> b) -> f a -> f b) -> [f (a -> b)] -> [f a] -> [f b]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)) ((Int, Split) -> Maybe [f (a -> b)]
ff (Int
i, Split
split)) ((Int, Split) -> Maybe [f a]
fx (Int
j, Split
split)) | (Int
i, Int
j) <- Split
split Int
d ]

instance Applicative f => Alternative (BFS f) where
  empty :: BFS f a
empty = ((Int, Split) -> Maybe [f a]) -> BFS f a
forall (f :: * -> *) x. ((Int, Split) -> Maybe [f x]) -> BFS f x
BFS (((Int, Split) -> Maybe [f a]) -> BFS f a)
-> ((Int, Split) -> Maybe [f a]) -> BFS f a
forall a b. (a -> b) -> a -> b
$ \(Int
d, Split
_) -> if Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [f a] -> Maybe [f a]
forall a. a -> Maybe a
Just [] else Maybe [f a]
forall a. Maybe a
Nothing
  BFS (Int, Split) -> Maybe [f a]
fa <|> :: BFS f a -> BFS f a -> BFS f a
<|> BFS (Int, Split) -> Maybe [f a]
fb = ((Int, Split) -> Maybe [f a]) -> BFS f a
forall (f :: * -> *) x. ((Int, Split) -> Maybe [f x]) -> BFS f x
BFS (((Int, Split) -> Maybe [f a]) -> BFS f a)
-> ((Int, Split) -> Maybe [f a]) -> BFS f a
forall a b. (a -> b) -> a -> b
$ \(Int, Split)
d -> [Maybe [f a]] -> Maybe [f a]
forall a. [Maybe [a]] -> Maybe [a]
flattenBFS [(Int, Split) -> Maybe [f a]
fa (Int, Split)
d, (Int, Split) -> Maybe [f a]
fb (Int, Split)
d]

-- | Choose between values of a given depth only.
instance Applicative f => Unfolder (BFS f) where
  chooseMap :: (a -> BFS f b) -> [a] -> BFS f b
chooseMap a -> BFS f b
f [a]
as = ((Int, Split) -> Maybe [f b]) -> BFS f b
forall (f :: * -> *) x. ((Int, Split) -> Maybe [f x]) -> BFS f x
BFS (((Int, Split) -> Maybe [f b]) -> BFS f b)
-> ((Int, Split) -> Maybe [f b]) -> BFS f b
forall a b. (a -> b) -> a -> b
$ \(Int
d, Split
split) -> if Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [f b] -> Maybe [f b]
forall a. a -> Maybe a
Just [] else [Maybe [f b]] -> Maybe [f b]
forall a. [Maybe [a]] -> Maybe [a]
flattenBFS ((a -> Maybe [f b]) -> [a] -> [Maybe [f b]]
forall a b. (a -> b) -> [a] -> [b]
map (\a
a -> a -> BFS f b
f a
a BFS f b -> (Int, Split) -> Maybe [f b]
forall (f :: * -> *) x. BFS f x -> (Int, Split) -> Maybe [f x]
`getBFS` (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Split
split)) [a]
as)

instance UnfolderTransformer BFS where
  lift :: f a -> BFS f a
lift = f a -> BFS f a
forall (f :: * -> *) x. f x -> BFS f x
packBFS

bySum :: Split
bySum :: Split
bySum Int
d = [(Int
i, Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)| Int
i <- [Int
0 .. Int
d]]

byMax :: Split
byMax :: Split
byMax Int
d = [(Int
i, Int
d)| Int
i <- [Int
0 .. Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]] [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++ [(Int
d, Int
i)| Int
i <- [Int
0 .. Int
d]]

bfsBy :: Unfolder f => Split -> BFS f x -> f x
bfsBy :: Split -> BFS f x -> f x
bfsBy Split
split (BFS (Int, Split) -> Maybe [f x]
f) = [f x] -> f x
forall (f :: * -> *) a. Unfolder f => [f a] -> f a
choose (Int -> [f x]
loop Int
0) where loop :: Int -> [f x]
loop Int
d = [f x] -> ([f x] -> [f x]) -> Maybe [f x] -> [f x]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([f x] -> [f x] -> [f x]
forall a. [a] -> [a] -> [a]
++ Int -> [f x]
loop (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) ((Int, Split) -> Maybe [f x]
f (Int
d, Split
split))

-- | Change the order of unfolding to be breadth-first, by maximum depth of the components.
bfs :: Unfolder f => BFS f x -> f x
bfs :: BFS f x -> f x
bfs = Split -> BFS f x -> f x
forall (f :: * -> *) x. Unfolder f => Split -> BFS f x -> f x
bfsBy Split
byMax

-- | Change the order of unfolding to be breadth-first, by the sum of depths of the components.
bfsBySum :: Unfolder f => BFS f x -> f x
bfsBySum :: BFS f x -> f x
bfsBySum = Split -> BFS f x -> f x
forall (f :: * -> *) x. Unfolder f => Split -> BFS f x -> f x
bfsBy Split
bySum

packBFS :: f x -> BFS f x
packBFS :: f x -> BFS f x
packBFS f x
r = ((Int, Split) -> Maybe [f x]) -> BFS f x
forall (f :: * -> *) x. ((Int, Split) -> Maybe [f x]) -> BFS f x
BFS (((Int, Split) -> Maybe [f x]) -> BFS f x)
-> ((Int, Split) -> Maybe [f x]) -> BFS f x
forall a b. (a -> b) -> a -> b
$ \(Int
d, Split
_) -> if Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [f x] -> Maybe [f x]
forall a. a -> Maybe a
Just [f x
r] else Maybe [f x]
forall a. Maybe a
Nothing

flattenBFS :: [Maybe [a]] -> Maybe [a]
flattenBFS :: [Maybe [a]] -> Maybe [a]
flattenBFS [Maybe [a]]
ms = case [Maybe [a]] -> [[a]]
forall a. [Maybe a] -> [a]
catMaybes [Maybe [a]]
ms of
  [] -> Maybe [a]
forall a. Maybe a
Nothing
  [[a]]
ms' -> [a] -> Maybe [a]
forall a. a -> Maybe a
Just ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
ms')