module Data.Unfolder
(
Unfolder(..)
, chooseMonadDefault
, between
, betweenD
, boundedEnum
, boundedEnumD
, Random(..)
, Arb(..)
, arbUnit
, NumConst(..)
, UnfolderTransformer(..)
, ala
, ala2
, ala3
, 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.Error
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 (Arbitrary(..))
import Test.QuickCheck.Gen (Gen(..))
import Data.Monoid (Monoid(..))
import Data.Maybe (catMaybes, listToMaybe)
import Data.Foldable (asum)
import Data.Traversable (traverse)
class Alternative f => Unfolder f where
choose :: [f x] -> f x
choose = asum
chooseInt :: Int -> f Int
chooseInt n = choose $ map pure [0 .. n 1]
chooseMonadDefault :: (Monad m, Unfolder m) => [m x] -> m x
chooseMonadDefault ms = chooseInt (length ms) >>= (ms !!)
between :: (Unfolder f, Enum a) => a -> a -> f a
between lb ub = (\x -> toEnum (x + fromEnum lb)) <$> chooseInt (1 + fromEnum ub fromEnum lb)
boundedEnum :: (Unfolder f, Bounded a, Enum a) => f a
boundedEnum = between minBound maxBound
betweenD :: (Unfolder f, Enum a) => a -> a -> f a
betweenD lb ub = betweenD' lb (fromEnum ub fromEnum lb)
where
betweenD' lb n | n < 0 = empty
| otherwise = choose [pure lb, betweenD' (succ lb) (pred n)]
boundedEnumD :: (Unfolder f, Bounded a, Enum a) => f a
boundedEnumD = betweenD minBound maxBound
instance MonadPlus m => Unfolder (WrappedMonad m)
instance (ArrowZero a, ArrowPlus a) => Unfolder (WrappedArrow a b)
instance Unfolder [] where
choose = concat
chooseInt n = [0 .. n 1]
instance Unfolder Maybe where
choose [] = Nothing
choose ms = head ms
chooseInt 0 = Nothing
chooseInt _ = Just 0
instance (Unfolder p, Unfolder q) => Unfolder (Product p q) where
choose ps = Pair (choose $ map fstP ps) (choose $ map sndP ps)
where
fstP (Pair p _) = p
sndP (Pair _ q) = q
chooseInt n = Pair (chooseInt n) (chooseInt n)
instance (Unfolder p, Applicative q) => Unfolder (Compose p q) where
choose = Compose . choose . map getCompose
chooseInt n = Compose $ pure <$> chooseInt n
instance Unfolder f => Unfolder (Reverse f) where
choose = Reverse . choose . map getReverse
chooseInt n = Reverse $ chooseInt n
instance Unfolder f => Unfolder (Backwards f) where
choose = Backwards . choose . map forwards
chooseInt n = Backwards $ chooseInt n
instance Unfolder f => Unfolder (Lift f)
instance (Functor m, Monad m, Error e) => Unfolder (ErrorT e m)
instance Applicative f => Unfolder (ListT f) where
choose ms = ListT $ concat <$> traverse runListT ms
chooseInt n = ListT $ pure [0 .. n 1]
instance (Functor m, Monad m) => Unfolder (MaybeT m) where
choose ms = MaybeT $ listToMaybe . catMaybes <$> mapM runMaybeT ms
chooseInt 0 = MaybeT $ return Nothing
chooseInt _ = MaybeT $ return (Just 0)
instance (Monoid w, MonadPlus m, Unfolder m) => Unfolder (RWST r w s m) where
choose ms = RWST $ \r s -> choose $ map (\m -> runRWST m r s) ms
instance (MonadPlus m, Unfolder m) => Unfolder (StateT s m) where
choose ms = StateT $ \s -> choose $ map (`runStateT` s) ms
instance Unfolder m => Unfolder (ReaderT r m) where
choose ms = ReaderT $ \r -> choose $ map (`runReaderT` r) ms
instance (Monoid w, Unfolder m) => Unfolder (WriterT w m) where
choose = WriterT . choose . map runWriterT
newtype Random g m a = Random { getRandom :: StateT g m a }
deriving (Functor, Applicative, Monad)
instance (Functor m, Monad m, R.RandomGen g) => Alternative (Random g m) where
empty = choose []
a <|> b = choose [a, b]
instance (Functor m, Monad m, R.RandomGen g) => MonadPlus (Random g m) where
mzero = choose []
mplus a b = choose [a, b]
instance (Functor m, Monad m, R.RandomGen g) => Unfolder (Random g m) where
choose = chooseMonadDefault
chooseInt 0 = Random . StateT $ const (fail "Random chooseInt 0")
chooseInt n = Random . StateT $ return . R.randomR (0, n 1)
class UnfolderTransformer t where
lift :: Unfolder f => f a -> t f a
ala :: (UnfolderTransformer t, Unfolder f) => (t f b -> f b) -> (t f a -> t f b) -> f a -> f b
ala lower f = lower . f . lift
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 lower f = ala lower . f . lift
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 lower f = ala2 lower . f . lift
newtype DualA f a = DualA { getDualA :: f a }
deriving (Eq, Show, Functor, Applicative)
instance Alternative f => Alternative (DualA f) where
empty = DualA empty
DualA a <|> DualA b = DualA (b <|> a)
instance Unfolder f => Unfolder (DualA f) where
choose = DualA . choose . reverse . map getDualA
chooseInt n = DualA $ (\x -> n 1 x) <$> chooseInt n
instance UnfolderTransformer DualA where
lift = DualA
data NT f g = NT { getNT :: forall a. f a -> g a }
newtype WithRec f a = WithRec { getWithRec :: ReaderT (Int -> NT f f) f a }
deriving (Functor, Applicative, Alternative)
instance Unfolder f => Unfolder (WithRec f) where
choose ms = WithRec . ReaderT $ \f ->
getNT (f 0) $ choose (map (\(WithRec (ReaderT m)) -> m (f . succ)) ms)
instance UnfolderTransformer WithRec where
lift = WithRec . ReaderT . const
withRec :: (Int -> NT f f) -> WithRec f a -> f a
withRec f = (`runReaderT` f) . getWithRec
limitDepth :: Unfolder f => Int -> WithRec f a -> f a
limitDepth m = withRec (\d -> NT $ if d == m then const empty else id)
newtype BFS f x = BFS { getBFS :: (Int, Split) -> Maybe [f x] }
type Split = Int -> [(Int, Int)]
instance Functor f => Functor (BFS f) where
fmap f = BFS . (fmap (map (fmap f)) .) . getBFS
instance Applicative f => Applicative (BFS f) where
pure = packBFS . pure
BFS ff <*> BFS fx = BFS $ \(d, split) -> flattenBFS $
[ liftA2 (liftA2 (<*>)) (ff (i, split)) (fx (j, split)) | (i, j) <- split d ]
instance Applicative f => Alternative (BFS f) where
empty = BFS $ \(d, _) -> if d == 0 then Just [] else Nothing
BFS fa <|> BFS fb = BFS $ \d -> flattenBFS [fa d, fb d]
instance Applicative f => Unfolder (BFS f) where
choose ms = BFS $ \(d, split) -> if d == 0 then Just [] else flattenBFS (map (`getBFS` (d 1, split)) ms)
instance UnfolderTransformer BFS where
lift = packBFS
bySum :: Split
bySum d = [(i, d i)| i <- [0 .. d]]
byMax :: Split
byMax d = [(i, d)| i <- [0 .. d 1]] ++ [(d, i)| i <- [0 .. d]]
bfsBy :: Unfolder f => Split -> BFS f x -> f x
bfsBy split (BFS f) = choose (loop 0) where loop d = maybe [] (++ loop (d + 1)) (f (d, split))
bfs :: Unfolder f => BFS f x -> f x
bfs = bfsBy byMax
bfsBySum :: Unfolder f => BFS f x -> f x
bfsBySum = bfsBy bySum
packBFS :: f x -> BFS f x
packBFS r = BFS $ \(d, _) -> if d == 0 then Just [r] else Nothing
flattenBFS :: [Maybe [a]] -> Maybe [a]
flattenBFS ms = case catMaybes ms of
[] -> Nothing
ms' -> Just (concat ms')
data Arb a = Arb Int (R.StdGen -> Int -> Maybe a)
instance Functor Arb where
fmap f (Arb i g) = Arb i $ fmap (fmap (fmap f)) g
instance Applicative Arb where
pure = Arb 0 . pure . pure . pure
Arb i1 ff <*> Arb i2 fx = Arb (i1 + i2) $
\r -> let (r1, r2) = R.split r in liftA2 (<*>) (ff r1) (fx r2)
instance Alternative Arb where
empty = Arb 0 (\_ _ -> Nothing)
Arb ia fa <|> Arb ib fb = Arb ((ia + ib + 1) `div` 2) $
\r n -> let (r1, r2) = R.split r in flattenArb r1 [fa r2 n, fb r2 n]
instance Unfolder Arb where
choose ms = Arb 1 g
where
g _ 0 = Nothing
g r n = let (r1, r2) = R.split r in
flattenArb r1 $ map (\(Arb i f) -> f r2 (n `div` max i 1)) ms
flattenArb :: R.StdGen -> [Maybe a] -> Maybe a
flattenArb r ms = case catMaybes ms of
[] -> Nothing
ms' -> Just $ ms' !! fst (R.randomR (0, length ms' 1) r)
arbUnit :: Arbitrary a => Arb a
arbUnit = Arb 0 (\r n -> Just $ unGen arbitrary r n)
newtype NumConst a x = NumConst { getNumConst :: a } deriving (Eq, Show)
instance Functor (NumConst a) where
fmap _ (NumConst a) = NumConst a
instance Num a => Applicative (NumConst a) where
pure _ = NumConst 1
NumConst a <*> NumConst b = NumConst $ a * b
instance Num a => Alternative (NumConst a) where
empty = NumConst 0
NumConst a <|> NumConst b = NumConst $ a + b
instance Num a => Unfolder (NumConst a) where
choose [] = empty
choose as = foldr1 (<|>) as