-- 
-- (c) Susumu Katayama
--
Combinators for Combinatorial Search:
The first part is a slight hack on Spivey 2000.
The second part is my (Susumu's) original which by recomputation refrains producing thunks.
The third part defines DBound, found in Spivey 2006.

\begin{code}
{-# OPTIONS -cpp -XUndecidableInstances -XMultiParamTypeClasses -XTypeSynonymInstances #-}
module Control.Monad.Search.Combinatorial(Matrix(..), (/\), (\/), Recomp(..), RecompT(..), rcToMx, mxToRc, Search(..), diag, Delay(..), msumMx, msumRc, listToRc, consMx, consRc, zipWithBF, printMx, printNMx, {- filterMx, -} mapDepthDB,
                               Bag, Stream, cat, toList, getDepth, scanl1BF, zipDepthMx, zipDepthRc, zipDepth3Mx, zipDepth3Rc, scanlRc,
                               DBound(..), DBoundT(..), zipDepthDB, DBMemo(..), Memoable(..), shrink, DB, dbtToRcT) where
import Control.Monad -- hiding (join) -- ... but still collided when using Hat.
import Control.Applicative -- necessary for backward compatibility
#ifdef HOOD
import Observe
#endif
#ifdef SEMIGROUP
import Data.Semigroup
#endif
import Data.Monoid -- Matrix, and any (MonadPlus a) => a, should be a Monoid.

#ifdef QUICKCHECK
import Test.QuickCheck hiding (shrink)
import Data.List(sort)
#endif
import MagicHaskeller.T10(mergesortWithBy, mergesortWithByBot)
import Control.Monad.State

import Data.Array

-- import AList -- append list used as the Bag

#ifdef SEMIGROUP
instance Semigroup (Matrix a) where
    <> :: Matrix a -> Matrix a -> Matrix a
(<>) = Matrix a -> Matrix a -> Matrix a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance Semigroup (Recomp a) where
    <> :: Recomp a -> Recomp a -> Recomp a
(<>) = Recomp a -> Recomp a -> Recomp a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance (Functor m, Monad m) => Semigroup (RecompT m a) where
    <> :: RecompT m a -> RecompT m a -> RecompT m a
(<>) = RecompT m a -> RecompT m a -> RecompT m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
#endif

-- instance (MonadPlus m) => Monoid (m a) where
instance Monoid (Matrix a) where
    mempty :: Matrix a
mempty  = Matrix a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    mappend :: Matrix a -> Matrix a -> Matrix a
mappend = Matrix a -> Matrix a -> Matrix a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance Monoid (Recomp a) where
    mempty :: Recomp a
mempty  = Recomp a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    mappend :: Recomp a -> Recomp a -> Recomp a
mappend = Recomp a -> Recomp a -> Recomp a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance (Functor m, Monad m) => Monoid (RecompT m a) where
    mempty :: RecompT m a
mempty  = RecompT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    mappend :: RecompT m a -> RecompT m a -> RecompT m a
mappend = RecompT m a -> RecompT m a -> RecompT m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

type Stream a = [a]

{-
type Bag a    = AList a
cat = concatAL
toList = flattenAL
-}
type Bag a = [a]
cat :: [[a]] -> [a]
cat = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
toList :: a -> a
toList = a -> a
forall a. a -> a
id

#ifdef QUICKCHECK
newtype Matrix a = Mx {unMx::Stream (Bag a)}
instance Show a => Show (Matrix a) where
    showsPrec _ (Mx xss) = ("Mx {unMx = "++) . shows (take 10 xss) . (" ...}"++)-- because we do not like to show infinite lists
#else
newtype Matrix a = Mx {Matrix a -> Stream (Bag a)
unMx::Stream (Bag a)} deriving Int -> Matrix a -> ShowS
[Matrix a] -> ShowS
Matrix a -> String
(Int -> Matrix a -> ShowS)
-> (Matrix a -> String) -> ([Matrix a] -> ShowS) -> Show (Matrix a)
forall a. Show a => Int -> Matrix a -> ShowS
forall a. Show a => [Matrix a] -> ShowS
forall a. Show a => Matrix a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Matrix a] -> ShowS
$cshowList :: forall a. Show a => [Matrix a] -> ShowS
show :: Matrix a -> String
$cshow :: forall a. Show a => Matrix a -> String
showsPrec :: Int -> Matrix a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Matrix a -> ShowS
Show
#endif
#ifdef HOOD
instance Observable a => Observable (Matrix a) where
    observer (Mx a) = send "Mx" (return Mx << a)
#endif
instance Applicative Matrix where
    pure :: a -> Matrix a
pure a
x = Stream (Bag a) -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx (a -> Bag a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x Bag a -> Stream (Bag a) -> Stream (Bag a)
forall a. a -> [a] -> [a]
: Stream (Bag a)
forall a. Stream (Bag a)
nils)
    <*> :: Matrix (a -> b) -> Matrix a -> Matrix b
(<*>)  = Matrix (a -> b) -> Matrix a -> Matrix b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad Matrix where
    return :: a -> Matrix a
return = a -> Matrix a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Mx Stream (Bag a)
x >>= :: Matrix a -> (a -> Matrix b) -> Matrix b
>>= a -> Matrix b
f  = Stream (Bag b) -> Matrix b
forall a. Stream (Bag a) -> Matrix a
Mx (Stream (Bag (Stream (Bag b))) -> Stream (Bag b)
forall a. Stream (Bag (Stream (Bag a))) -> Stream (Bag a)
jOIN ((Bag a -> Bag (Stream (Bag b)))
-> Stream (Bag a) -> Stream (Bag (Stream (Bag b)))
forall a b. (a -> b) -> [a] -> [b]
map ((a -> Stream (Bag b)) -> Bag a -> Bag (Stream (Bag b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Matrix b -> Stream (Bag b)
forall a. Matrix a -> Stream (Bag a)
unMx(Matrix b -> Stream (Bag b))
-> (a -> Matrix b) -> a -> Stream (Bag b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> Matrix b
f)) Stream (Bag a)
x))
instance Alternative Matrix where
    empty :: Matrix a
empty = Matrix a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    <|> :: Matrix a -> Matrix a -> Matrix a
(<|>) = Matrix a -> Matrix a -> Matrix a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance MonadPlus Matrix where
    mzero :: Matrix a
mzero = Stream (Bag a) -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx Stream (Bag a)
forall a. Stream (Bag a)
nils
    Mx Stream (Bag a)
xm mplus :: Matrix a -> Matrix a -> Matrix a
`mplus` Mx Stream (Bag a)
ym = Stream (Bag a) -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx ((Bag a -> Bag a -> Bag a)
-> Stream (Bag a) -> Stream (Bag a) -> Stream (Bag a)
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bag a -> Bag a -> Bag a
forall a. Monoid a => a -> a -> a
mappend Stream (Bag a)
xm Stream (Bag a)
ym)
nils :: Stream (Bag a)
nils :: Stream (Bag a)
nils = Bag a -> Stream (Bag a)
forall a. a -> [a]
repeat Bag a
forall a. Monoid a => a
mempty
a -> m b
p /\ :: (a -> m b) -> (t -> m a) -> t -> m b
/\ t -> m a
q = \t
x -> (t -> m a
q t
x m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m b
p)
t -> m a
p \/ :: (t -> m a) -> (t -> m a) -> t -> m a
\/ t -> m a
q = \t
x -> (t -> m a
p t
x m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` t -> m a
q t
x)
jOIN :: Stream (Bag (Stream (Bag a))) -> Stream (Bag a)
jOIN :: Stream (Bag (Stream (Bag a))) -> Stream (Bag a)
jOIN = (Bag (Stream (Bag a)) -> Bag a)
-> Stream (Bag (Stream (Bag a))) -> Stream (Bag a)
forall a b. (a -> b) -> [a] -> [b]
map (Stream (Bag a) -> Bag a
forall a. [[a]] -> [a]
cat(Stream (Bag a) -> Bag a)
-> (Bag (Stream (Bag a)) -> Stream (Bag a))
-> Bag (Stream (Bag a))
-> Bag a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Bag (Stream (Bag a)) -> Stream (Bag a)
forall a. [[a]] -> [a]
cat) (Stream (Bag (Stream (Bag a))) -> Stream (Bag a))
-> (Stream (Bag (Stream (Bag a))) -> Stream (Bag (Stream (Bag a))))
-> Stream (Bag (Stream (Bag a)))
-> Stream (Bag a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream (Bag (Stream (Bag a))) -> Stream (Bag (Stream (Bag a)))
forall a. Stream (Stream a) -> Stream (Stream a)
diag (Stream (Bag (Stream (Bag a))) -> Stream (Bag (Stream (Bag a))))
-> (Stream (Bag (Stream (Bag a))) -> Stream (Bag (Stream (Bag a))))
-> Stream (Bag (Stream (Bag a)))
-> Stream (Bag (Stream (Bag a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bag (Stream (Bag a)) -> Bag (Stream (Bag a)))
-> Stream (Bag (Stream (Bag a))) -> Stream (Bag (Stream (Bag a)))
forall a b. (a -> b) -> [a] -> [b]
map Bag (Stream (Bag a)) -> Bag (Stream (Bag a))
forall a. Stream (Stream a) -> Stream (Stream a)
trans

diag :: Stream (Stream a) -> Stream (Bag a)
diag :: Stream (Stream a) -> Stream (Stream a)
diag ((a
x:Stream a
xs):Stream (Stream a)
xss) = a -> Stream a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x Stream a -> Stream (Stream a) -> Stream (Stream a)
forall a. a -> [a] -> [a]
: (a -> Stream a -> Stream a)
-> Stream a -> Stream (Stream a) -> Stream (Stream a)
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> Stream a -> Stream a
forall (m :: * -> *) a. (Monoid (m a), Monad m) => a -> m a -> m a
cons Stream a
xs (Stream (Stream a) -> Stream (Stream a)
forall a. Stream (Stream a) -> Stream (Stream a)
diag Stream (Stream a)
xss)

cons :: a -> m a -> m a
cons a
a m a
b = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a m a -> m a -> m a
forall a. Monoid a => a -> a -> a
`mappend` m a
b

trans :: Bag (Stream a) -> Stream (Bag a)
trans :: Bag (Stream a) -> Bag (Stream a)
trans Bag (Stream a)
xss = (Stream a -> a) -> Bag (Stream a) -> Stream a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Stream a -> a
forall a. [a] -> a
head Bag (Stream a)
xss Stream a -> Bag (Stream a) -> Bag (Stream a)
forall a. a -> [a] -> [a]
: Bag (Stream a) -> Bag (Stream a)
forall a. Stream (Stream a) -> Stream (Stream a)
trans ((Stream a -> Stream a) -> Bag (Stream a) -> Bag (Stream a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Stream a -> Stream a
forall a. [a] -> [a]
tail Bag (Stream a)
xss)
-- Actually I am not sure why this definition is better than "trans = foldr (zipWith (:)) (repeat [])"....
-- (but the correction really worked in the profiling result.)

-- not sure if this is really needed.
instance Functor Matrix where
    fmap :: (a -> b) -> Matrix a -> Matrix b
fmap a -> b
f (Mx Stream (Bag a)
xss) = Stream (Bag b) -> Matrix b
forall a. Stream (Bag a) -> Matrix a
Mx ((Bag a -> Bag b) -> Stream (Bag a) -> Stream (Bag b)
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Bag a -> Bag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) Stream (Bag a)
xss)

instance Functor Recomp where
    fmap :: (a -> b) -> Recomp a -> Recomp b
fmap a -> b
f (Rc Int -> Bag a
xss) = (Int -> Bag b) -> Recomp b
forall a. (Int -> Bag a) -> Recomp a
Rc (\Int
d -> (a -> b) -> Bag a -> Bag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Int -> Bag a
xss Int
d))
instance Functor DBound where
    fmap :: (a -> b) -> DBound a -> DBound b
fmap a -> b
f (DB Int -> Bag (a, Int)
g) = (Int -> Bag (b, Int)) -> DBound b
forall a. (Int -> Bag (a, Int)) -> DBound a
DB (\Int
d -> ((a, Int) -> (b, Int)) -> Bag (a, Int) -> Bag (b, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a
x,Int
i)->(a -> b
f a
x,Int
i)) (Int -> Bag (a, Int)
g Int
d))
instance Functor f => Functor (RecompT f) where
    fmap :: (a -> b) -> RecompT f a -> RecompT f b
fmap a -> b
f (RcT Int -> f (Bag a)
g) = (Int -> f (Bag b)) -> RecompT f b
forall (m :: * -> *) a. (Int -> m (Bag a)) -> RecompT m a
RcT ((Int -> f (Bag b)) -> RecompT f b)
-> (Int -> f (Bag b)) -> RecompT f b
forall a b. (a -> b) -> a -> b
$ \Int
dep -> (Bag a -> Bag b) -> f (Bag a) -> f (Bag b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Bag a -> Bag b
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f) (Int -> f (Bag a)
g Int
dep)
instance Functor f => Functor (DBoundT f) where
    fmap :: (a -> b) -> DBoundT f a -> DBoundT f b
fmap a -> b
f (DBT Int -> f (Bag (a, Int))
g) = (Int -> f (Bag (b, Int))) -> DBoundT f b
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT (\Int
d -> (Bag (a, Int) -> Bag (b, Int))
-> f (Bag (a, Int)) -> f (Bag (b, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, Int) -> (b, Int)) -> Bag (a, Int) -> Bag (b, Int)
forall a b. (a -> b) -> [a] -> [b]
map (\(a
x,Int
i)->(a -> b
f a
x,Int
i))) (Int -> f (Bag (a, Int))
g Int
d))

-- should be slightly more efficient than msum
msumMx :: Bag a -> Matrix a
msumMx Bag a
xs = Stream (Bag a) -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx (Bag a
xs Bag a -> Stream (Bag a) -> Stream (Bag a)
forall a. a -> [a] -> [a]
: Stream (Bag a)
forall a. Stream (Bag a)
nils)
-- msumRc xs = Rc (const xs) 間違い
msumRc :: Bag a -> Recomp a
msumRc = Bag a -> Recomp a
forall a. Bag a -> Recomp a
listToRc
listToRc :: Bag a -> Recomp a
listToRc Bag a
l = (Int -> Bag a) -> Recomp a
forall a. (Int -> Bag a) -> Recomp a
Rc Int -> Bag a
forall a. (Eq a, Num a) => a -> Bag a
f where f :: a -> Bag a
f a
0 = Bag a
l
                        f a
_ = Bag a
forall a. Monoid a => a
mempty

{-
-- m is usually IO or ST s
accumulate :: Monad m => Matrix (m a) -> m (Matrix a)
accumulate (Mx xss) = fmap Mx (sequence (sequence xss))
-}
\end{code}

\begin{code}
type    DepthFst = [] -- ghc6.8 does not like "type DepthFst = Stream"
newtype Recomp a = Rc {Recomp a -> Int -> Bag a
unRc::Int->Bag a}
newtype RecompT m a = RcT {RecompT m a -> Int -> m (Bag a)
unRcT::Int -> m (Bag a)}
instance Applicative Recomp where
    pure :: a -> Recomp a
pure a
x = (Int -> Bag a) -> Recomp a
forall a. (Int -> Bag a) -> Recomp a
Rc Int -> Bag a
forall a (m :: * -> *).
(Eq a, Num a, Monad m, Monoid (m a)) =>
a -> m a
f where f :: a -> m a
f a
0 = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
                        f a
_ = m a
forall a. Monoid a => a
mempty
    <*> :: Recomp (a -> b) -> Recomp a -> Recomp b
(<*>)  = Recomp (a -> b) -> Recomp a -> Recomp b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad Recomp where
    return :: a -> Recomp a
return = a -> Recomp a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Rc Int -> Bag a
f >>= :: Recomp a -> (a -> Recomp b) -> Recomp b
>>= a -> Recomp b
g = (Int -> Bag b) -> Recomp b
forall a. (Int -> Bag a) -> Recomp a
Rc ( \Int
n  ->  [Bag b] -> Bag b
forall a. Monoid a => [a] -> a
mconcat ([Bag b] -> Bag b) -> [Bag b] -> Bag b
forall a b. (a -> b) -> a -> b
$  (Int -> Bag b) -> [Int] -> [Bag b]
forall a b. (a -> b) -> [a] -> [b]
map  (\Int
i -> [Bag b] -> Bag b
forall a. [[a]] -> [a]
cat ([Bag b] -> Bag b) -> [Bag b] -> Bag b
forall a b. (a -> b) -> a -> b
$ (a -> Bag b) -> Bag a -> [Bag b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
a -> Recomp b -> Int -> Bag b
forall a. Recomp a -> Int -> Bag a
unRc (a -> Recomp b
g a
a) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)) (Int -> Bag a
f Int
i))  [Int
0..Int
n] )
--    Rc f >>= g = Rc (\n -> [ y | i <- [0..n], x <- f i, y <- unRc (g x) (n-i) ]) -- Bag a = [a]の場合．
--    Rc f >>= g = Rc (\n -> concat $ map (\i -> concat $ map (\a -> unRc (g a) (n-i)) (f i)) [0..n]) -- STRecompに相当する書き方．とくに遅くはならない....

instance (Functor m, Monad m) => Applicative (RecompT m) where
    pure :: a -> RecompT m a
pure a
x = (Int -> m (Bag a)) -> RecompT m a
forall (m :: * -> *) a. (Int -> m (Bag a)) -> RecompT m a
RcT Int -> m (Bag a)
forall a (m :: * -> *). (Eq a, Num a, Monad m) => a -> m (Bag a)
f where f :: a -> m (Bag a)
f a
0 = Bag a -> m (Bag a)
forall (m :: * -> *) a. Monad m => a -> m a
return [a
x]
                         f a
_ = Bag a -> m (Bag a)
forall (m :: * -> *) a. Monad m => a -> m a
return []
    <*> :: RecompT m (a -> b) -> RecompT m a -> RecompT m b
(<*>)  = RecompT m (a -> b) -> RecompT m a -> RecompT m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance (Functor m, Monad m) => Monad (RecompT m) where
    return :: a -> RecompT m a
return = a -> RecompT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    RcT Int -> m (Bag a)
f >>= :: RecompT m a -> (a -> RecompT m b) -> RecompT m b
>>= a -> RecompT m b
g = (Int -> m (Bag b)) -> RecompT m b
forall (m :: * -> *) a. (Int -> m (Bag a)) -> RecompT m a
RcT ( \Int
n  -> let
                                 hoge :: Int -> m (Bag b)
hoge Int
i = do Bag a
xs <- Int -> m (Bag a)
f Int
i
                                             [Bag b]
xss <- (a -> m (Bag b)) -> Bag a -> m [Bag b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\a
x -> RecompT m b -> Int -> m (Bag b)
forall (m :: * -> *) a. RecompT m a -> Int -> m (Bag a)
unRcT (a -> RecompT m b
g a
x) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)) Bag a
xs
                                             Bag b -> m (Bag b)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bag b] -> Bag b
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Bag b]
xss)
                               in do [Bag b]
xss <- (Int -> m (Bag b)) -> [Int] -> m [Bag b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> m (Bag b)
hoge [Int
0..Int
n]
                                     Bag b -> m (Bag b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag b -> m (Bag b)) -> Bag b -> m (Bag b)
forall a b. (a -> b) -> a -> b
$ [Bag b] -> Bag b
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Bag b]
xss)

instance Alternative Recomp where
    empty :: Recomp a
empty = Recomp a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    <|> :: Recomp a -> Recomp a -> Recomp a
(<|>) = Recomp a -> Recomp a -> Recomp a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance MonadPlus Recomp where
    mzero :: Recomp a
mzero = (Int -> Bag a) -> Recomp a
forall a. (Int -> Bag a) -> Recomp a
Rc (Bag a -> Int -> Bag a
forall a b. a -> b -> a
const Bag a
forall a. Monoid a => a
mempty)
    Rc Int -> Bag a
f mplus :: Recomp a -> Recomp a -> Recomp a
`mplus` Rc Int -> Bag a
g = (Int -> Bag a) -> Recomp a
forall a. (Int -> Bag a) -> Recomp a
Rc (\Int
i -> Int -> Bag a
f Int
i Bag a -> Bag a -> Bag a
forall a. Monoid a => a -> a -> a
`mappend` Int -> Bag a
g Int
i)
instance (Functor m, Monad m) => Alternative (RecompT m) where
    empty :: RecompT m a
empty = RecompT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    <|> :: RecompT m a -> RecompT m a -> RecompT m a
(<|>) = RecompT m a -> RecompT m a -> RecompT m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance (Functor m, Monad m) => MonadPlus (RecompT m) where
    mzero :: RecompT m a
mzero = (Int -> m (Bag a)) -> RecompT m a
forall (m :: * -> *) a. (Int -> m (Bag a)) -> RecompT m a
RcT (m (Bag a) -> Int -> m (Bag a)
forall a b. a -> b -> a
const (m (Bag a) -> Int -> m (Bag a)) -> m (Bag a) -> Int -> m (Bag a)
forall a b. (a -> b) -> a -> b
$ Bag a -> m (Bag a)
forall (m :: * -> *) a. Monad m => a -> m a
return [])
    RcT Int -> m (Bag a)
f mplus :: RecompT m a -> RecompT m a -> RecompT m a
`mplus` RcT Int -> m (Bag a)
g = (Int -> m (Bag a)) -> RecompT m a
forall (m :: * -> *) a. (Int -> m (Bag a)) -> RecompT m a
RcT (\Int
i -> do Bag a
xs <- Int -> m (Bag a)
f Int
i        -- f i と g iの両方を実行することになるけど，IOで使う上で間違ってはいない．
                                        Bag a
ys <- Int -> m (Bag a)
g Int
i
                                        Bag a -> m (Bag a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag a
xsBag a -> Bag a -> Bag a
forall a. [a] -> [a] -> [a]
++Bag a
ys))

rcToMx :: Recomp a -> Matrix a
rcToMx :: Recomp a -> Matrix a
rcToMx (Rc Int -> Bag a
f) = Stream (Bag a) -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx ((Int -> Bag a) -> [Int] -> Stream (Bag a)
forall a b. (a -> b) -> [a] -> [b]
map Int -> Bag a
f [Int
0..])
{-
rcToMx (Rc f) = Mx (go 0)
    where go n = f n : go (n+1)
-}

mxToRc :: Matrix a -> Recomp a
mxToRc :: Matrix a -> Recomp a
mxToRc (Mx Stream (Bag a)
s) = (Int -> Bag a) -> Recomp a
forall a. (Int -> Bag a) -> Recomp a
Rc (Stream (Bag a)
sStream (Bag a) -> Int -> Bag a
forall a. [a] -> Int -> a
!!)

consMx :: Bag a -> Matrix a -> Matrix a
consMx :: Bag a -> Matrix a -> Matrix a
consMx Bag a
xs (Mx Stream (Bag a)
xss) = Stream (Bag a) -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx (Bag a
xs Bag a -> Stream (Bag a) -> Stream (Bag a)
forall a. a -> [a] -> [a]
: Stream (Bag a)
xss)

consRc :: Bag a -> Recomp a -> Recomp a
consRc :: Bag a -> Recomp a -> Recomp a
consRc Bag a
xs (Rc Int -> Bag a
f) = (Int -> Bag a) -> Recomp a
forall a. (Int -> Bag a) -> Recomp a
Rc Int -> Bag a
g where g :: Int -> Bag a
g Int
0 = Bag a
xs
                              g Int
n = Int -> Bag a
f (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

{-
-- mapDepthがあれば，定義する必要はない．
-- filterMx f (Mx xss) = Mx (map (filter f) xss)
filterMx f = mapDepth (filter f)
-}

class Search m => DB m where
    mapDepthDB :: (Bag (a,Int) -> Bag (b,Int)) -> m a -> m b
    zipDepthDB :: (Int -> Bag (a,Int) -> Bag (b,Int)) -> m a -> m b

instance DB DBound where
    mapDepthDB :: (Bag (a, Int) -> Bag (b, Int)) -> DBound a -> DBound b
mapDepthDB Bag (a, Int) -> Bag (b, Int)
f (DB Int -> Bag (a, Int)
g) = (Int -> Bag (b, Int)) -> DBound b
forall a. (Int -> Bag (a, Int)) -> DBound a
DB (Bag (a, Int) -> Bag (b, Int)
f(Bag (a, Int) -> Bag (b, Int))
-> (Int -> Bag (a, Int)) -> Int -> Bag (b, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> Bag (a, Int)
g)
    zipDepthDB :: (Int -> Bag (a, Int) -> Bag (b, Int)) -> DBound a -> DBound b
zipDepthDB Int -> Bag (a, Int) -> Bag (b, Int)
f (DB Int -> Bag (a, Int)
g) = (Int -> Bag (b, Int)) -> DBound b
forall a. (Int -> Bag (a, Int)) -> DBound a
DB (\Int
d -> Int -> Bag (a, Int) -> Bag (b, Int)
f Int
d (Int -> Bag (a, Int)
g Int
d))

instance (Functor m, Monad m) => DB (DBoundT m) where
    mapDepthDB :: (Bag (a, Int) -> Bag (b, Int)) -> DBoundT m a -> DBoundT m b
mapDepthDB Bag (a, Int) -> Bag (b, Int)
f (DBT Int -> m (Bag (a, Int))
g) = (Int -> m (Bag (b, Int))) -> DBoundT m b
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> m (Bag (b, Int))) -> DBoundT m b)
-> (Int -> m (Bag (b, Int))) -> DBoundT m b
forall a b. (a -> b) -> a -> b
$ (Bag (a, Int) -> Bag (b, Int))
-> m (Bag (a, Int)) -> m (Bag (b, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bag (a, Int) -> Bag (b, Int)
f (m (Bag (a, Int)) -> m (Bag (b, Int)))
-> (Int -> m (Bag (a, Int))) -> Int -> m (Bag (b, Int))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> m (Bag (a, Int))
g
    zipDepthDB :: (Int -> Bag (a, Int) -> Bag (b, Int)) -> DBoundT m a -> DBoundT m b
zipDepthDB Int -> Bag (a, Int) -> Bag (b, Int)
f (DBT Int -> m (Bag (a, Int))
g) = (Int -> m (Bag (b, Int))) -> DBoundT m b
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> m (Bag (b, Int))) -> DBoundT m b)
-> (Int -> m (Bag (b, Int))) -> DBoundT m b
forall a b. (a -> b) -> a -> b
$ \Int
d -> (Bag (a, Int) -> Bag (b, Int))
-> m (Bag (a, Int)) -> m (Bag (b, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Bag (a, Int) -> Bag (b, Int)
f Int
d) (Int -> m (Bag (a, Int))
g Int
d)

zipDepthMx :: (Int -> Bag a -> Bag b) -> Matrix a -> Matrix b
zipDepthMx :: (Int -> Bag a -> Bag b) -> Matrix a -> Matrix b
zipDepthMx Int -> Bag a -> Bag b
f (Mx Stream (Bag a)
xss) = Stream (Bag b) -> Matrix b
forall a. Stream (Bag a) -> Matrix a
Mx ((Int -> Bag a -> Bag b)
-> [Int] -> Stream (Bag a) -> Stream (Bag b)
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Bag a -> Bag b
f [Int
0..] Stream (Bag a)
xss)

zipDepthRc :: (Int -> Bag a -> Bag b) -> Recomp a -> Recomp b
zipDepthRc :: (Int -> Bag a -> Bag b) -> Recomp a -> Recomp b
zipDepthRc Int -> Bag a -> Bag b
f (Rc Int -> Bag a
g) = (Int -> Bag b) -> Recomp b
forall a. (Int -> Bag a) -> Recomp a
Rc (\Int
d -> Int -> Bag a -> Bag b
f Int
d (Int -> Bag a
g Int
d))

zipDepth3Mx :: (Int -> Bag a -> Bag b -> Bag c) -> Matrix a -> Matrix b -> Matrix c
zipDepth3Mx :: (Int -> Bag a -> Bag b -> Bag c)
-> Matrix a -> Matrix b -> Matrix c
zipDepth3Mx Int -> Bag a -> Bag b -> Bag c
f (Mx Stream (Bag a)
xss) (Mx Stream (Bag b)
yss) = Stream (Bag c) -> Matrix c
forall a. Stream (Bag a) -> Matrix a
Mx ((Int -> Bag a -> Bag b -> Bag c)
-> [Int] -> Stream (Bag a) -> Stream (Bag b) -> Stream (Bag c)
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> Bag a -> Bag b -> Bag c
f [Int
0..] Stream (Bag a)
xss Stream (Bag b)
yss)

zipDepth3Rc :: (Int -> Bag a -> Bag b -> Bag c) -> Recomp a -> Recomp b -> Recomp c
zipDepth3Rc :: (Int -> Bag a -> Bag b -> Bag c)
-> Recomp a -> Recomp b -> Recomp c
zipDepth3Rc Int -> Bag a -> Bag b -> Bag c
f (Rc Int -> Bag a
g) (Rc Int -> Bag b
h) = (Int -> Bag c) -> Recomp c
forall a. (Int -> Bag a) -> Recomp a
Rc (\Int
d -> Int -> Bag a -> Bag b -> Bag c
f Int
d (Int -> Bag a
g Int
d) (Int -> Bag b
h Int
d))

printMx :: Matrix a -> IO ()
printMx (Mx Stream (Bag a)
xss) = Integer -> Stream (Bag a) -> IO ()
forall (t :: * -> *) t a.
(Foldable t, Show t, Show a, Num t) =>
t -> [t a] -> IO ()
pmx Integer
0 Stream (Bag a)
xss
    where pmx :: t -> [t a] -> IO ()
pmx t
n (t a
xs:[t a]
xss) = do String -> IO ()
putStrLn (String
"\ndepth = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
n)
                              (a -> IO ()) -> t a -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> IO ()
forall a. Show a => a -> IO ()
print (t a -> t a
forall a. a -> a
toList t a
xs)
                              t -> [t a] -> IO ()
pmx (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1) [t a]
xss
          pmx t
n [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
printNMx :: Int -> Matrix a -> IO ()
printNMx Int
n (Mx Stream (Bag a)
xss) = Matrix a -> IO ()
forall a. Show a => Matrix a -> IO ()
printMx (Stream (Bag a) -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx (Int -> Stream (Bag a) -> Stream (Bag a)
forall a. Int -> [a] -> [a]
take Int
n Stream (Bag a)
xss))

-- join (liftM2 mtf mtx)よりもstrict
zipWithBF :: Monad m => (a -> b -> m c) -> m a -> m b -> m c
zipWithBF :: (a -> b -> m c) -> m a -> m b -> m c
zipWithBF a -> b -> m c
f m a
xss m b
yss = do a
x <- m a
xss
                         b
y <- m b
yss
                         (a -> b -> m c
f (a -> b -> m c) -> a -> b -> m c
forall a b. (a -> b) -> a -> b
$! a
x) (b -> m c) -> b -> m c
forall a b. (a -> b) -> a -> b
$! b
y

scanl1BF :: Search m => m x -> m x
scanl1BF :: m x -> m x
scanl1BF m x
bf = m x
bf m x -> m x -> m x
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` m x -> m x
forall (m :: * -> *) a. Delay m => m a -> m a
delay (m x -> m x
forall (m :: * -> *) x. Search m => m x -> m x
scanl1BF m x
bf)

scanlRc :: (Bag a -> Bag b -> Bag a) -> Bag a -> Recomp b -> Recomp a
scanlRc :: (Bag a -> Bag b -> Bag a) -> Bag a -> Recomp b -> Recomp a
scanlRc Bag a -> Bag b -> Bag a
f Bag a
xs Recomp b
rc = Recomp a
result where result :: Recomp a
result = Bag a
xs Bag a -> Recomp a -> Recomp a
forall a. Bag a -> Recomp a -> Recomp a
`consRc` (Int -> Bag a -> Bag b -> Bag a)
-> Recomp a -> Recomp b -> Recomp a
forall a b c.
(Int -> Bag a -> Bag b -> Bag c)
-> Recomp a -> Recomp b -> Recomp c
zipDepth3Rc (\Int
_ -> Bag a -> Bag b -> Bag a
f) Recomp a
result Recomp b
rc

-- making delay apart to implement zipWithConsFMT.
class Delay m where
    delay :: m a -> m a
    delay = Int -> m a -> m a
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay Int
1
    ndelay  :: Int -> m a -> m a
    ndelay  Int
n m a
x = (m a -> m a) -> m a -> [m a]
forall a. (a -> a) -> a -> [a]
iterate m a -> m a
forall (m :: * -> *) a. Delay m => m a -> m a
delay m a
x [m a] -> Int -> m a
forall a. [a] -> Int -> a
!! Int
n
    getDepth :: m Int

instance Delay DepthFst where
    delay :: DepthFst a -> DepthFst a
delay    = DepthFst a -> DepthFst a
forall a. a -> a
id
    ndelay :: Int -> DepthFst a -> DepthFst a
ndelay Int
_ = DepthFst a -> DepthFst a
forall a. a -> a
id
instance Delay Recomp where
    delay :: Recomp a -> Recomp a
delay (Rc Int -> Bag a
f) = (Int -> Bag a) -> Recomp a
forall a. (Int -> Bag a) -> Recomp a
Rc Int -> Bag a
g where g :: Int -> Bag a
g Int
0 = Bag a
forall a. Monoid a => a
mempty
                              g Int
n = Int -> Bag a
f (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    ndelay :: Int -> Recomp a -> Recomp a
ndelay Int
i (Rc Int -> Bag a
f) = (Int -> Bag a) -> Recomp a
forall a. (Int -> Bag a) -> Recomp a
Rc Int -> Bag a
g where g :: Int -> Bag a
g Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i     = Bag a
forall a. Monoid a => a
mempty
                                     | Bool
otherwise = Int -> Bag a
f (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)
    getDepth :: Recomp Int
getDepth = (Int -> [Int]) -> Recomp Int
forall a. (Int -> Bag a) -> Recomp a
Rc (\Int
d -> [Int
d])

instance Delay Matrix where
    delay :: Matrix a -> Matrix a
delay (Mx Stream (Bag a)
xm) = Stream (Bag a) -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx (Bag a
forall a. Monoid a => a
memptyBag a -> Stream (Bag a) -> Stream (Bag a)
forall a. a -> [a] -> [a]
:Stream (Bag a)
xm)
    ndelay :: Int -> Matrix a -> Matrix a
ndelay Int
0 Matrix a
mx = Matrix a
mx
    ndelay Int
i Matrix a
mx = Matrix a -> Matrix a
forall (m :: * -> *) a. Delay m => m a -> m a
delay (Matrix a -> Matrix a) -> Matrix a -> Matrix a
forall a b. (a -> b) -> a -> b
$ Int -> Matrix a -> Matrix a
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Matrix a
mx
    getDepth :: Matrix Int
getDepth = Recomp Int -> Matrix Int
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc Recomp Int
forall (m :: * -> *). Delay m => m Int
getDepth

instance Monad m => Delay (RecompT m) where
    delay :: RecompT m a -> RecompT m a
delay (RcT Int -> m (Bag a)
f) = (Int -> m (Bag a)) -> RecompT m a
forall (m :: * -> *) a. (Int -> m (Bag a)) -> RecompT m a
RcT Int -> m (Bag a)
g where g :: Int -> m (Bag a)
g Int
0 = Bag a -> m (Bag a)
forall (m :: * -> *) a. Monad m => a -> m a
return Bag a
forall a. Monoid a => a
mempty
                                g Int
n = Int -> m (Bag a)
f (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    ndelay :: Int -> RecompT m a -> RecompT m a
ndelay Int
i (RcT Int -> m (Bag a)
f) = (Int -> m (Bag a)) -> RecompT m a
forall (m :: * -> *) a. (Int -> m (Bag a)) -> RecompT m a
RcT Int -> m (Bag a)
g where g :: Int -> m (Bag a)
g Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i     = Bag a -> m (Bag a)
forall (m :: * -> *) a. Monad m => a -> m a
return Bag a
forall a. Monoid a => a
mempty
                                       | Bool
otherwise = Int -> m (Bag a)
f (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)

instance (Monad m, Delay m) => Delay (StateT s m) where
         delay :: StateT s m a -> StateT s m a
delay    = (m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT m (a, s) -> m (a, s)
forall (m :: * -> *) a. Delay m => m a -> m a
delay
         ndelay :: Int -> StateT s m a -> StateT s m a
ndelay Int
n = (m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT (Int -> m (a, s) -> m (a, s)
forall (m :: * -> *) a. Delay m => Int -> m a -> m a
ndelay Int
n)

class (Delay m, MonadPlus m, Functor m) => Search m where
    fromRc :: Recomp a -> m a
    toRc   :: m a -> Recomp a
    fromMx :: Matrix a -> m a
    toMx   :: m a -> Matrix a
    fromDB :: DBound a -> m a
    fromDF :: [a] -> m a   -- NB: this gives everything the top priority.
    toDF   :: m a -> [a]   -- NB: this drops the info of priority.
    -- | 'mapDepth' applies a function to the bag at each depth. 
    mapDepth :: (Bag a -> Bag b) -> m a -> m b
    -- | 'catBags' flattens each bag.
    catBags :: m (Bag a) -> m a
    catBags = (Bag (Bag a) -> Bag a) -> m (Bag a) -> m a
forall (m :: * -> *) a b.
Search m =>
(Bag a -> Bag b) -> m a -> m b
mapDepth Bag (Bag a) -> Bag a
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    -- | 'mergesortDepthWithBy' converts bags to sets, by (possibly sorting each bag and) removing duplicates.
    --   Efficiency on lists with lots of duplicates is required.
    mergesortDepthWithBy :: (k->k->k) -- ^ Combiner, which is used when there are equivalent elements (compared by the comparer specified by the next argument).
                                      --   The return value of this combiner should also be equivalent to the two arguments.
                         -> (k->k->Ordering) -- ^ Comparer
                         -> m k -> m k
    mergesortDepthWithBy k -> k -> k
combiner k -> k -> Ordering
comp = (Bag k -> Bag k) -> m k -> m k
forall (m :: * -> *) a b.
Search m =>
(Bag a -> Bag b) -> m a -> m b
mapDepth ((k -> k -> k) -> (k -> k -> Ordering) -> Bag k -> Bag k
forall k. (k -> k -> k) -> (k -> k -> Ordering) -> [k] -> [k]
mergesortWithBy k -> k -> k
combiner k -> k -> Ordering
comp)
    ifDepth :: (Int->Bool) -> m a -> m a -> m a
instance Search DepthFst where
    fromRc :: Recomp a -> DepthFst a
fromRc = Matrix a -> DepthFst a
forall (m :: * -> *) a. Search m => Matrix a -> m a
fromMx (Matrix a -> DepthFst a)
-> (Recomp a -> Matrix a) -> Recomp a -> DepthFst a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Recomp a -> Matrix a
forall (m :: * -> *) a. Search m => m a -> Matrix a
toMx
    toRc :: DepthFst a -> Recomp a
toRc   = DepthFst a -> Recomp a
forall a. Bag a -> Recomp a
listToRc
    fromMx :: Matrix a -> DepthFst a
fromMx = [DepthFst a] -> DepthFst a
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([DepthFst a] -> DepthFst a)
-> (Matrix a -> [DepthFst a]) -> Matrix a -> DepthFst a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matrix a -> [DepthFst a]
forall a. Matrix a -> Stream (Bag a)
unMx
    toMx :: DepthFst a -> Matrix a
toMx   = DepthFst a -> Matrix a
forall a. DepthFst a -> Matrix a
msumMx
    fromDB :: DBound a -> DepthFst a
fromDB (DB Int -> Bag (a, Int)
f) = [a
x | Int
d <- [Int
0..], (a
x,Int
_) <- Int -> Bag (a, Int)
f Int
d ]
    fromDF :: [a] -> [a]
fromDF = [a] -> [a]
forall a. a -> a
id
    toDF :: DepthFst a -> DepthFst a
toDF   = DepthFst a -> DepthFst a
forall a. a -> a
id
    mapDepth :: (Bag a -> Bag b) -> Bag a -> Bag b
mapDepth Bag a -> Bag b
f = [Bag b] -> Bag b
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Bag b] -> Bag b) -> (Bag a -> [Bag b]) -> Bag a -> Bag b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bag b) -> Bag a -> [Bag b]
forall a b. (a -> b) -> [a] -> [b]
map (Bag a -> Bag b
f (Bag a -> Bag b) -> (a -> Bag a) -> a -> Bag b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bag a -> Bag a
forall a. a -> [a] -> [a]
:[])) -- mapDepth /= id, because DepthFst is not a finite Bag but an infinite Stream.
    catBags :: DepthFst (Bag a) -> Bag a
catBags = DepthFst (Bag a) -> Bag a
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    mergesortDepthWithBy :: (k -> k -> k) -> (k -> k -> Ordering) -> DepthFst k -> DepthFst k
mergesortDepthWithBy k -> k -> k
_ k -> k -> Ordering
_ = DepthFst k -> DepthFst k
forall a. a -> a
id
    ifDepth :: (Int -> Bool) -> DepthFst a -> DepthFst a -> DepthFst a
ifDepth Int -> Bool
_ DepthFst a
t DepthFst a
_ = DepthFst a
t
instance Search Recomp where
    fromRc :: Recomp a -> Recomp a
fromRc = Recomp a -> Recomp a
forall a. a -> a
id
    toRc :: Recomp a -> Recomp a
toRc   = Recomp a -> Recomp a
forall a. a -> a
id
    fromMx :: Matrix a -> Recomp a
fromMx = Matrix a -> Recomp a
forall a. Matrix a -> Recomp a
mxToRc
    toMx :: Recomp a -> Matrix a
toMx   = Recomp a -> Matrix a
forall a. Recomp a -> Matrix a
rcToMx
    fromDB :: DBound a -> Recomp a
fromDB = DBound a -> Recomp a
forall (m :: * -> *) a. Search m => m a -> Recomp a
toRc
    fromDF :: [a] -> Recomp a
fromDF = [a] -> Recomp a
forall a. Bag a -> Recomp a
listToRc
    toDF :: Recomp a -> [a]
toDF   = Matrix a -> [a]
forall (m :: * -> *) a. Search m => Matrix a -> m a
fromMx (Matrix a -> [a]) -> (Recomp a -> Matrix a) -> Recomp a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Recomp a -> Matrix a
forall (m :: * -> *) a. Search m => m a -> Matrix a
toMx
    mapDepth :: (Bag a -> Bag b) -> Recomp a -> Recomp b
mapDepth Bag a -> Bag b
f (Rc Int -> Bag a
g) = (Int -> Bag b) -> Recomp b
forall a. (Int -> Bag a) -> Recomp a
Rc (Bag a -> Bag b
f(Bag a -> Bag b) -> (Int -> Bag a) -> Int -> Bag b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> Bag a
g)
    ifDepth :: (Int -> Bool) -> Recomp a -> Recomp a -> Recomp a
ifDepth Int -> Bool
pred (Rc Int -> Bag a
t) (Rc Int -> Bag a
f) = (Int -> Bag a) -> Recomp a
forall a. (Int -> Bag a) -> Recomp a
Rc Int -> Bag a
fun
        where fun :: Int -> Bag a
fun Int
depth | Int -> Bool
pred Int
depth = Int -> Bag a
t Int
depth
                        | Bool
otherwise  = Int -> Bag a
f Int
depth

instance (Functor m, Monad m) => Search (RecompT m) where
    fromRc :: Recomp a -> RecompT m a
fromRc (Rc Int -> Bag a
f) = (Int -> m (Bag a)) -> RecompT m a
forall (m :: * -> *) a. (Int -> m (Bag a)) -> RecompT m a
RcT (Bag a -> m (Bag a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag a -> m (Bag a)) -> (Int -> Bag a) -> Int -> m (Bag a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Bag a
f)
    toRc :: RecompT m a -> Recomp a
toRc   = String -> RecompT m a -> Recomp a
forall a. HasCallStack => String -> a
error String
"no toRc for RecompT"
    fromMx :: Matrix a -> RecompT m a
fromMx = Recomp a -> RecompT m a
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp a -> RecompT m a)
-> (Matrix a -> Recomp a) -> Matrix a -> RecompT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matrix a -> Recomp a
forall a. Matrix a -> Recomp a
mxToRc
    toMx :: RecompT m a -> Matrix a
toMx   = String -> RecompT m a -> Matrix a
forall a. HasCallStack => String -> a
error String
"no toMx for RecompT"
    fromDB :: DBound a -> RecompT m a
fromDB = Recomp a -> RecompT m a
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp a -> RecompT m a)
-> (DBound a -> Recomp a) -> DBound a -> RecompT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBound a -> Recomp a
forall (m :: * -> *) a. Search m => m a -> Recomp a
toRc
    fromDF :: [a] -> RecompT m a
fromDF = Recomp a -> RecompT m a
forall (m :: * -> *) a. Search m => Recomp a -> m a
fromRc (Recomp a -> RecompT m a)
-> ([a] -> Recomp a) -> [a] -> RecompT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Recomp a
forall a. Bag a -> Recomp a
listToRc
    toDF :: RecompT m a -> [a]
toDF = String -> RecompT m a -> [a]
forall a. HasCallStack => String -> a
error String
"no toDF for RecompT"
    mapDepth :: (Bag a -> Bag b) -> RecompT m a -> RecompT m b
mapDepth Bag a -> Bag b
f (RcT Int -> m (Bag a)
g) = (Int -> m (Bag b)) -> RecompT m b
forall (m :: * -> *) a. (Int -> m (Bag a)) -> RecompT m a
RcT (\Int
x -> (Bag a -> Bag b) -> m (Bag a) -> m (Bag b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bag a -> Bag b
f (Int -> m (Bag a)
g Int
x))
    ifDepth :: (Int -> Bool) -> RecompT m a -> RecompT m a -> RecompT m a
ifDepth Int -> Bool
pred (RcT Int -> m (Bag a)
t) (RcT Int -> m (Bag a)
f) = (Int -> m (Bag a)) -> RecompT m a
forall (m :: * -> *) a. (Int -> m (Bag a)) -> RecompT m a
RcT Int -> m (Bag a)
fun
        where fun :: Int -> m (Bag a)
fun Int
depth | Int -> Bool
pred Int
depth = Int -> m (Bag a)
t Int
depth
                        | Bool
otherwise  = Int -> m (Bag a)
f Int
depth

instance Search Matrix where
    fromRc :: Recomp a -> Matrix a
fromRc = Recomp a -> Matrix a
forall a. Recomp a -> Matrix a
rcToMx
    toRc :: Matrix a -> Recomp a
toRc   = Matrix a -> Recomp a
forall a. Matrix a -> Recomp a
mxToRc
    fromMx :: Matrix a -> Matrix a
fromMx = Matrix a -> Matrix a
forall a. a -> a
id
    toMx :: Matrix a -> Matrix a
toMx   = Matrix a -> Matrix a
forall a. a -> a
id
    fromDB :: DBound a -> Matrix a
fromDB = DBound a -> Matrix a
forall (m :: * -> *) a. Search m => m a -> Matrix a
toMx
    fromDF :: [a] -> Matrix a
fromDF = [a] -> Matrix a
forall a. DepthFst a -> Matrix a
msumMx
    toDF :: Matrix a -> [a]
toDF   = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> (Matrix a -> [[a]]) -> Matrix a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matrix a -> [[a]]
forall a. Matrix a -> Stream (Bag a)
unMx
    mapDepth :: (Bag a -> Bag b) -> Matrix a -> Matrix b
mapDepth Bag a -> Bag b
f (Mx Stream (Bag a)
xss) = Stream (Bag b) -> Matrix b
forall a. Stream (Bag a) -> Matrix a
Mx ((Bag a -> Bag b) -> Stream (Bag a) -> Stream (Bag b)
forall a b. (a -> b) -> [a] -> [b]
map Bag a -> Bag b
f Stream (Bag a)
xss)
    ifDepth :: (Int -> Bool) -> Matrix a -> Matrix a -> Matrix a
ifDepth Int -> Bool
pred (Mx Stream (Bag a)
ts) (Mx Stream (Bag a)
fs) = Stream (Bag a) -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx (Stream (Bag a) -> Matrix a) -> Stream (Bag a) -> Matrix a
forall a b. (a -> b) -> a -> b
$ (Int -> Bag a -> Bag a -> Bag a)
-> [Int] -> Stream (Bag a) -> Stream (Bag a) -> Stream (Bag a)
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> Bag a -> Bag a -> Bag a
forall p. Int -> p -> p -> p
chooser [Int
0..] Stream (Bag a)
ts Stream (Bag a)
fs
        where chooser :: Int -> p -> p -> p
chooser Int
depth p
t p
f | Int -> Bool
pred Int
depth = p
t
                                | Bool
otherwise  = p
f

#ifdef QUICKCHECK
instance Arbitrary a => Arbitrary (Matrix a) where
    arbitrary = liftM fromRc arbitrary -- Converting from Recomp makes sure that the outer list is infinite. 
instance Arbitrary a => Arbitrary (Recomp a) where
    arbitrary = liftM Rc arbitrary
instance Arbitrary a => Arbitrary (DBound a) where
--    arbitrary = liftM fromRc arbitrary
    arbitrary = liftM fromRc arbitrary
-- Having only one of the above two is not enough to test the converter (like fromRc) used here!
-- |arbitrary = liftM DB arbitrary| is not enough, because the annotated Int cannot be greater than the argument Int.
#endif

instance Show (Recomp a) where
    showsPrec :: Int -> Recomp a -> ShowS
showsPrec Int
_ Recomp a
_ = (String
"<Recomp>"String -> ShowS
forall a. [a] -> [a] -> [a]
++)
instance Show (DBound a) where
    showsPrec :: Int -> DBound a -> ShowS
showsPrec Int
_ DBound a
_ = (String
"<DBound>"String -> ShowS
forall a. [a] -> [a] -> [a]
++)

\end{code}

\begin{code}
-- aはあらかじめannotateしたものを用いる
categorizeDB :: DBound a -> Int -> Array Int [a]
categorizeDB :: DBound a -> Int -> Array Int [a]
categorizeDB (DB Int -> Bag (a, Int)
f) Int
b = Int -> Bag (a, Int) -> Array Int [a]
forall i a. (Ix i, Num i) => i -> [(a, i)] -> Array i [a]
categorize Int
b (Bag (a, Int) -> Array Int [a]) -> Bag (a, Int) -> Array Int [a]
forall a b. (a -> b) -> a -> b
$ Int -> Bag (a, Int)
f Int
b -- この辺は不要
categorize :: i -> [(a, i)] -> Array i [a]
categorize i
b [(a, i)]
ts = ([a] -> a -> [a]) -> [a] -> (i, i) -> [(i, a)] -> Array i [a]
forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray ((a -> [a] -> [a]) -> [a] -> a -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)) [] (i
0,i
b) ([(i, a)] -> Array i [a]) -> [(i, a)] -> Array i [a]
forall a b. (a -> b) -> a -> b
$ ((a, i) -> (i, a)) -> [(a, i)] -> [(i, a)]
forall a b. (a -> b) -> [a] -> [b]
map (a, i) -> (i, a)
forall b a. (b, a) -> (a, b)
swap [(a, i)]
ts
uncategorizeDB :: (Int -> Array Int [a]) -> DBound a
uncategorizeDB :: (Int -> Array Int [a]) -> DBound a
uncategorizeDB Int -> Array Int [a]
f = (Int -> Bag (a, Int)) -> DBound a
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag (a, Int)) -> DBound a)
-> (Int -> Bag (a, Int)) -> DBound a
forall a b. (a -> b) -> a -> b
$ \Int
b -> Array Int [a] -> Bag (a, Int)
forall b a. Ix b => Array b [a] -> [(a, b)]
uncategorize (Int -> Array Int [a]
f Int
b) -- これも不要
uncategorize :: Array b [a] -> [(a, b)]
uncategorize Array b [a]
ar = [ (a
x,b
i) | (b
i,[a]
xs) <- Array b [a] -> [(b, [a])]
forall i e. Ix i => Array i e -> [(i, e)]
assocs Array b [a]
ar, a
x <- [a]
xs ]

-- | shrinkDB can be used instead of mergesortDepthWithBy when you want to shrink each depth in different ways using different annotations.
shrinkDB :: (k->k->k) -> (k -> k -> Maybe Ordering) -> DBound k -> DBound k
shrinkDB :: (k -> k -> k) -> (k -> k -> Maybe Ordering) -> DBound k -> DBound k
shrinkDB k -> k -> k
combiner k -> k -> Maybe Ordering
comparer = (Int -> Bag (k, Int) -> Bag (k, Int)) -> DBound k -> DBound k
forall (m :: * -> *) a b.
DB m =>
(Int -> Bag (a, Int) -> Bag (b, Int)) -> m a -> m b
zipDepthDB ((Int -> Bag (k, Int) -> Bag (k, Int)) -> DBound k -> DBound k)
-> (Int -> Bag (k, Int) -> Bag (k, Int)) -> DBound k -> DBound k
forall a b. (a -> b) -> a -> b
$ (k -> k -> k)
-> (k -> k -> Maybe Ordering)
-> Int
-> Bag (k, Int)
-> Bag (k, Int)
forall b a.
(Ix b, Num b) =>
(a -> a -> a)
-> (a -> a -> Maybe Ordering) -> b -> [(a, b)] -> [(a, b)]
shrink k -> k -> k
combiner k -> k -> Maybe Ordering
comparer -- これも不要
shrink :: (a -> a -> a)
-> (a -> a -> Maybe Ordering) -> b -> [(a, b)] -> [(a, b)]
shrink   a -> a -> a
combiner a -> a -> Maybe Ordering
comparer = \b
b [(a, b)]
ts -> Array b [a] -> [(a, b)]
forall b a. Ix b => Array b [a] -> [(a, b)]
uncategorize (Array b [a] -> [(a, b)]) -> Array b [a] -> [(a, b)]
forall a b. (a -> b) -> a -> b
$ ([a] -> [a]) -> Array b [a] -> Array b [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> a -> a) -> (a -> a -> Maybe Ordering) -> [a] -> [a]
forall k. (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
mergesortWithByBot a -> a -> a
combiner a -> a -> Maybe Ordering
comparer) (Array b [a] -> Array b [a]) -> Array b [a] -> Array b [a]
forall a b. (a -> b) -> a -> b
$ b -> [(a, b)] -> Array b [a]
forall i a. (Ix i, Num i) => i -> [(a, i)] -> Array i [a]
categorize b
b [(a, b)]
ts

{-  元々こっちで定義してたけど，zipDepthDBを使った方が良さそうなので．
-- aはあらかじめannotateしたものを用いる
categorizeDB :: DBound a -> Int -> Array Int [a]
categorizeDB (DB f) b = accumArray (flip (:)) [] (0,b) $ map swap $ f b
uncategorizeDB :: (Int -> Array Int [a]) -> DBound a
uncategorizeDB f = DB $ \b -> [ (x,i) | (i,xs) <- assocs (f b), x <- xs ]

-- | shrinkDB can be used instead of mergesortDepthWithBy when you want to shrink each depth in different ways using different annotations.
shrinkDB :: (k->k->k) -> (k -> k -> Maybe Ordering) -> DBound k -> DBound k
-- shrinkDB combiner comparer db = uncategorizeDB (fmap (mergesortWithByBot combiner comparer) . categorizeDB db)
shrinkDB combiner comparer = uncategorizeDB . (.) (fmap (mergesortWithByBot combiner comparer)) . categorizeDB
-- Control.Monad.Instancesにinstance Functor (a->) where fmap = (.) が定義されている．どっちでもいいはずだけど，下の方が綺麗かなと．
-}

swap :: (b, a) -> (a, b)
swap (b
b,a
x) = (a
x,b
b)

newtype DBound  a = DB  {DBound a -> Int -> Bag (a, Int)
unDB :: Int -> Bag (a, Int)}
newtype DBoundT m a = DBT {DBoundT m a -> Int -> m (Bag (a, Int))
unDBT :: Int -> m (Bag (a, Int))}
instance Applicative DBound where
    pure :: a -> DBound a
pure a
x = (Int -> Bag (a, Int)) -> DBound a
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag (a, Int)) -> DBound a)
-> (Int -> Bag (a, Int)) -> DBound a
forall a b. (a -> b) -> a -> b
$ \Int
n -> [(a
x,Int
n)]
    <*> :: DBound (a -> b) -> DBound a -> DBound b
(<*>)  = DBound (a -> b) -> DBound a -> DBound b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad DBound where
    return :: a -> DBound a
return = a -> DBound a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    DB Int -> Bag (a, Int)
p >>= :: DBound a -> (a -> DBound b) -> DBound b
>>= a -> DBound b
f = (Int -> Bag (b, Int)) -> DBound b
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag (b, Int)) -> DBound b)
-> (Int -> Bag (b, Int)) -> DBound b
forall a b. (a -> b) -> a -> b
$ \Int
n -> [ (b
y,Int
s) | (a
x,Int
r) <- Int -> Bag (a, Int)
p Int
n, (b
y,Int
s) <- DBound b -> Int -> Bag (b, Int)
forall a. DBound a -> Int -> Bag (a, Int)
unDB (a -> DBound b
f a
x) Int
r ]
instance (Functor m, Monad m) => Applicative (DBoundT m) where
    pure :: a -> DBoundT m a
pure a
x = (Int -> m (Bag (a, Int))) -> DBoundT m a
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> m (Bag (a, Int))) -> DBoundT m a)
-> (Int -> m (Bag (a, Int))) -> DBoundT m a
forall a b. (a -> b) -> a -> b
$ \Int
n -> Bag (a, Int) -> m (Bag (a, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return [(a
x,Int
n)]
    <*> :: DBoundT m (a -> b) -> DBoundT m a -> DBoundT m b
(<*>)  = DBoundT m (a -> b) -> DBoundT m a -> DBoundT m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance (Functor m, Monad m) => Monad (DBoundT m) where
    return :: a -> DBoundT m a
return      = a -> DBoundT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    DBT Int -> m (Bag (a, Int))
p >>= :: DBoundT m a -> (a -> DBoundT m b) -> DBoundT m b
>>= a -> DBoundT m b
f = (Int -> m (Bag (b, Int))) -> DBoundT m b
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> m (Bag (b, Int))) -> DBoundT m b)
-> (Int -> m (Bag (b, Int))) -> DBoundT m b
forall a b. (a -> b) -> a -> b
$ \Int
n -> do Bag (a, Int)
ts <- Int -> m (Bag (a, Int))
p Int
n
                                 [Bag (b, Int)]
tss <- ((a, Int) -> m (Bag (b, Int))) -> Bag (a, Int) -> m [Bag (b, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(a
x,Int
r) -> DBoundT m b -> Int -> m (Bag (b, Int))
forall (m :: * -> *) a. DBoundT m a -> Int -> m (Bag (a, Int))
unDBT (a -> DBoundT m b
f a
x) Int
r) Bag (a, Int)
ts
                                 Bag (b, Int) -> m (Bag (b, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (b, Int) -> m (Bag (b, Int)))
-> Bag (b, Int) -> m (Bag (b, Int))
forall a b. (a -> b) -> a -> b
$ [Bag (b, Int)] -> Bag (b, Int)
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Bag (b, Int)]
tss
instance Alternative DBound where
    empty :: DBound a
empty = DBound a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    <|> :: DBound a -> DBound a -> DBound a
(<|>) = DBound a -> DBound a -> DBound a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance MonadPlus DBound where
    mzero :: DBound a
mzero               = (Int -> Bag (a, Int)) -> DBound a
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag (a, Int)) -> DBound a)
-> (Int -> Bag (a, Int)) -> DBound a
forall a b. (a -> b) -> a -> b
$ \Int
_ -> []
    DB Int -> Bag (a, Int)
p1 mplus :: DBound a -> DBound a -> DBound a
`mplus` DB Int -> Bag (a, Int)
p2 = (Int -> Bag (a, Int)) -> DBound a
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag (a, Int)) -> DBound a)
-> (Int -> Bag (a, Int)) -> DBound a
forall a b. (a -> b) -> a -> b
$ \Int
n -> Int -> Bag (a, Int)
p1 Int
n Bag (a, Int) -> Bag (a, Int) -> Bag (a, Int)
forall a. [a] -> [a] -> [a]
++ Int -> Bag (a, Int)
p2 Int
n
instance (Functor m, Monad m) => Alternative (DBoundT m) where
    empty :: DBoundT m a
empty = DBoundT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    <|> :: DBoundT m a -> DBoundT m a -> DBoundT m a
(<|>) = DBoundT m a -> DBoundT m a -> DBoundT m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance (Functor m, Monad m) => MonadPlus (DBoundT m) where
    mzero :: DBoundT m a
mzero               = (Int -> m (Bag (a, Int))) -> DBoundT m a
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> m (Bag (a, Int))) -> DBoundT m a)
-> (Int -> m (Bag (a, Int))) -> DBoundT m a
forall a b. (a -> b) -> a -> b
$ \Int
_ -> Bag (a, Int) -> m (Bag (a, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return []
    DBT Int -> m (Bag (a, Int))
p1 mplus :: DBoundT m a -> DBoundT m a -> DBoundT m a
`mplus` DBT Int -> m (Bag (a, Int))
p2 = (Int -> m (Bag (a, Int))) -> DBoundT m a
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> m (Bag (a, Int))) -> DBoundT m a)
-> (Int -> m (Bag (a, Int))) -> DBoundT m a
forall a b. (a -> b) -> a -> b
$ \Int
n -> (Bag (a, Int) -> Bag (a, Int) -> Bag (a, Int))
-> m (Bag (a, Int)) -> m (Bag (a, Int)) -> m (Bag (a, Int))
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bag (a, Int) -> Bag (a, Int) -> Bag (a, Int)
forall a. [a] -> [a] -> [a]
(++) (Int -> m (Bag (a, Int))
p1 Int
n) (Int -> m (Bag (a, Int))
p2 Int
n)
instance Delay DBound where
    delay :: DBound a -> DBound a
delay (DB Int -> Bag (a, Int)
p) = (Int -> Bag (a, Int)) -> DBound a
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag (a, Int)) -> DBound a)
-> (Int -> Bag (a, Int)) -> DBound a
forall a b. (a -> b) -> a -> b
$ \Int
n -> case Int
n of Int
0   -> []
                                        Int
n   -> Int -> Bag (a, Int)
p (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    ndelay :: Int -> DBound a -> DBound a
ndelay Int
i (DB Int -> Bag (a, Int)
p) = (Int -> Bag (a, Int)) -> DBound a
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag (a, Int)) -> DBound a)
-> (Int -> Bag (a, Int)) -> DBound a
forall a b. (a -> b) -> a -> b
$ \Int
n -> if Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
i then [] else Int -> Bag (a, Int)
p (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)
    getDepth :: DBound Int
getDepth = (Int -> Bag (Int, Int)) -> DBound Int
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag (Int, Int)) -> DBound Int)
-> (Int -> Bag (Int, Int)) -> DBound Int
forall a b. (a -> b) -> a -> b
$ \Int
n -> [ (Int
d, Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
d) | Int
d <- [Int
0..Int
n] ]
instance Monad m => Delay (DBoundT m) where
    delay :: DBoundT m a -> DBoundT m a
delay (DBT Int -> m (Bag (a, Int))
p) = (Int -> m (Bag (a, Int))) -> DBoundT m a
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> m (Bag (a, Int))) -> DBoundT m a)
-> (Int -> m (Bag (a, Int))) -> DBoundT m a
forall a b. (a -> b) -> a -> b
$ \Int
n -> case Int
n of Int
0   -> Bag (a, Int) -> m (Bag (a, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return []
                                          Int
n   -> Int -> m (Bag (a, Int))
p (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    ndelay :: Int -> DBoundT m a -> DBoundT m a
ndelay Int
i (DBT Int -> m (Bag (a, Int))
p) = (Int -> m (Bag (a, Int))) -> DBoundT m a
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> m (Bag (a, Int))) -> DBoundT m a)
-> (Int -> m (Bag (a, Int))) -> DBoundT m a
forall a b. (a -> b) -> a -> b
$ \Int
n -> if Int
nInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
i then Bag (a, Int) -> m (Bag (a, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return [] else Int -> m (Bag (a, Int))
p (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)
instance Search DBound where
    toRc :: DBound a -> Recomp a
toRc   (DB Int -> Bag (a, Int)
p) = (Int -> Bag a) -> Recomp a
forall a. (Int -> Bag a) -> Recomp a
Rc ((Int -> Bag a) -> Recomp a) -> (Int -> Bag a) -> Recomp a
forall a b. (a -> b) -> a -> b
$ \Int
n -> [ a
x | (a
x,Int
0) <- Int -> Bag (a, Int)
p Int
n ]
    fromRc :: Recomp a -> DBound a
fromRc (Rc Int -> Bag a
p) = (Int -> Bag (a, Int)) -> DBound a
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag (a, Int)) -> DBound a)
-> (Int -> Bag (a, Int)) -> DBound a
forall a b. (a -> b) -> a -> b
$ \Int
n -> [ (a
x,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) | Int
m <- [Int
0..Int
n], a
x <- Int -> Bag a
p Int
m ]

    toMx :: DBound a -> Matrix a
toMx (DB Int -> Bag (a, Int)
p) = Stream (Bag a) -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx [ [ a
x | (a
x,Int
0) <- Int -> Bag (a, Int)
p Int
n ] | Int
n <- [Int
0..] ]
    fromMx :: Matrix a -> DBound a
fromMx (Mx Stream (Bag a)
xss) = (Int -> Bag (a, Int)) -> DBound a
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag (a, Int)) -> DBound a)
-> (Int -> Bag (a, Int)) -> DBound a
forall a b. (a -> b) -> a -> b
$ \Int
n -> [Bag (a, Int)] -> Bag (a, Int)
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Bag (a, Int)] -> Bag (a, Int)) -> [Bag (a, Int)] -> Bag (a, Int)
forall a b. (a -> b) -> a -> b
$ (Int -> Bag a -> Bag (a, Int))
-> [Int] -> Stream (Bag a) -> [Bag (a, Int)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
r Bag a
xs -> (a -> (a, Int)) -> Bag a -> Bag (a, Int)
forall a b. (a -> b) -> [a] -> [b]
map (\a
x->(a
x,Int
r)) Bag a
xs) [Int
n,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1..Int
0] Stream (Bag a)
xss
    fromDB :: DBound a -> DBound a
fromDB = DBound a -> DBound a
forall a. a -> a
id
    fromDF :: [a] -> DBound a
fromDF [a]
xs = (Int -> Bag (a, Int)) -> DBound a
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag (a, Int)) -> DBound a)
-> (Int -> Bag (a, Int)) -> DBound a
forall a b. (a -> b) -> a -> b
$ \Int
n -> [ (a
x,Int
n) | a
x <- [a]
xs ]
    toDF :: DBound a -> [a]
toDF = Matrix a -> [a]
forall (m :: * -> *) a. Search m => m a -> [a]
toDF (Matrix a -> [a]) -> (DBound a -> Matrix a) -> DBound a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBound a -> Matrix a
forall (m :: * -> *) a. Search m => m a -> Matrix a
toMx
    mapDepth :: (Bag a -> Bag b) -> DBound a -> DBound b
mapDepth Bag a -> Bag b
f (DB Int -> Bag (a, Int)
g) = (Int -> Bag (b, Int)) -> DBound b
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag (b, Int)) -> DBound b)
-> (Int -> Bag (b, Int)) -> DBound b
forall a b. (a -> b) -> a -> b
$ \Int
d -> case Bag (a, Int) -> (Bag a, [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip (Bag (a, Int) -> (Bag a, [Int])) -> Bag (a, Int) -> (Bag a, [Int])
forall a b. (a -> b) -> a -> b
$ Int -> Bag (a, Int)
g Int
d of (Bag a
xs, [Int]
is) -> Bag b -> [Int] -> Bag (b, Int)
forall a b. [a] -> [b] -> [(a, b)]
zip (Bag a -> Bag b
f Bag a
xs) [Int]
is
    catBags :: DBound (Bag a) -> DBound a
catBags (DB Int -> Bag (Bag a, Int)
f) = (Int -> Bag (a, Int)) -> DBound a
forall a. (Int -> Bag (a, Int)) -> DBound a
DB (\Int
d -> [ (a
x,Int
i) | (Bag a
xs,Int
i) <- Int -> Bag (Bag a, Int)
f Int
d, a
x <- Bag a
xs ])
    mergesortDepthWithBy :: (k -> k -> k) -> (k -> k -> Ordering) -> DBound k -> DBound k
mergesortDepthWithBy k -> k -> k
combiner k -> k -> Ordering
rel = (Bag (k, Int) -> Bag (k, Int)) -> DBound k -> DBound k
forall (m :: * -> *) a b.
DB m =>
(Bag (a, Int) -> Bag (b, Int)) -> m a -> m b
mapDepthDB (((k, Int) -> (k, Int) -> (k, Int))
-> ((k, Int) -> (k, Int) -> Ordering)
-> Bag (k, Int)
-> Bag (k, Int)
forall k. (k -> k -> k) -> (k -> k -> Ordering) -> [k] -> [k]
mergesortWithBy (\ (k
k,Int
i) (k
l,Int
_) -> (k -> k -> k
combiner k
k k
l, Int
i))
                                                                    (\ (k
k,Int
i) (k
l,Int
j) -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
j Int
i of Ordering
EQ -> k -> k -> Ordering
rel k
k k
l -- Cheaper Int comparison is done in advance.
                                                                                                          Ordering
c  -> Ordering
c))     -- Shallower elements come earlier.
    ifDepth :: (Int -> Bool) -> DBound a -> DBound a -> DBound a
ifDepth Int -> Bool
pred (DB Int -> Bag (a, Int)
t) (DB Int -> Bag (a, Int)
f) = (Int -> Bag (a, Int)) -> DBound a
forall a. (Int -> Bag (a, Int)) -> DBound a
DB Int -> Bag (a, Int)
fun
        where fun :: Int -> Bag (a, Int)
fun Int
depth | Int -> Bool
pred Int
depth = Int -> Bag (a, Int)
t Int
depth
                        | Bool
otherwise  = Int -> Bag (a, Int)
f Int
depth

dbtToRcT :: DBoundT m a -> RecompT m a
dbtToRcT (DBT Int -> m (Bag (a, Int))
p) = (Int -> m (Bag a)) -> RecompT m a
forall (m :: * -> *) a. (Int -> m (Bag a)) -> RecompT m a
RcT ((Int -> m (Bag a)) -> RecompT m a)
-> (Int -> m (Bag a)) -> RecompT m a
forall a b. (a -> b) -> a -> b
$ \Int
n -> do Bag (a, Int)
t <- Int -> m (Bag (a, Int))
p Int
n
                                  Bag a -> m (Bag a)
forall (m :: * -> *) a. Monad m => a -> m a
return [ a
x | (a
x,Int
0) <- Bag (a, Int)
t ]

instance (Functor m, Monad m) => Search (DBoundT m) where
    toRc :: DBoundT m a -> Recomp a
toRc   = String -> DBoundT m a -> Recomp a
forall a. HasCallStack => String -> a
error String
"No toRc for DBoundT."
    fromRc :: Recomp a -> DBoundT m a
fromRc (Rc Int -> Bag a
p) = (Int -> m (Bag (a, Int))) -> DBoundT m a
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> m (Bag (a, Int))) -> DBoundT m a)
-> (Int -> m (Bag (a, Int))) -> DBoundT m a
forall a b. (a -> b) -> a -> b
$ \Int
n -> Bag (a, Int) -> m (Bag (a, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return [ (a
x,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
m) | Int
m <- [Int
0..Int
n], a
x <- Int -> Bag a
p Int
m ]

    toMx :: DBoundT m a -> Matrix a
toMx = String -> DBoundT m a -> Matrix a
forall a. HasCallStack => String -> a
error String
"No toMx for DBoundT"
    fromMx :: Matrix a -> DBoundT m a
fromMx (Mx Stream (Bag a)
xss) = (Int -> m (Bag (a, Int))) -> DBoundT m a
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> m (Bag (a, Int))) -> DBoundT m a)
-> (Int -> m (Bag (a, Int))) -> DBoundT m a
forall a b. (a -> b) -> a -> b
$ \Int
n -> Bag (a, Int) -> m (Bag (a, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (a, Int) -> m (Bag (a, Int)))
-> Bag (a, Int) -> m (Bag (a, Int))
forall a b. (a -> b) -> a -> b
$ [Bag (a, Int)] -> Bag (a, Int)
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Bag (a, Int)] -> Bag (a, Int)) -> [Bag (a, Int)] -> Bag (a, Int)
forall a b. (a -> b) -> a -> b
$ (Int -> Bag a -> Bag (a, Int))
-> [Int] -> Stream (Bag a) -> [Bag (a, Int)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
r Bag a
xs -> (a -> (a, Int)) -> Bag a -> Bag (a, Int)
forall a b. (a -> b) -> [a] -> [b]
map (\a
x->(a
x,Int
r)) Bag a
xs) [Int
n,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1..Int
0] Stream (Bag a)
xss
    fromDB :: DBound a -> DBoundT m a
fromDB (DB Int -> Bag (a, Int)
p) = (Int -> m (Bag (a, Int))) -> DBoundT m a
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> m (Bag (a, Int))) -> DBoundT m a)
-> (Int -> m (Bag (a, Int))) -> DBoundT m a
forall a b. (a -> b) -> a -> b
$ \Int
n -> Bag (a, Int) -> m (Bag (a, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (a, Int) -> m (Bag (a, Int)))
-> Bag (a, Int) -> m (Bag (a, Int))
forall a b. (a -> b) -> a -> b
$ Int -> Bag (a, Int)
p Int
n
    fromDF :: [a] -> DBoundT m a
fromDF [a]
xs = (Int -> m (Bag (a, Int))) -> DBoundT m a
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> m (Bag (a, Int))) -> DBoundT m a)
-> (Int -> m (Bag (a, Int))) -> DBoundT m a
forall a b. (a -> b) -> a -> b
$ \Int
n -> Bag (a, Int) -> m (Bag (a, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return [ (a
x,Int
n) | a
x <- [a]
xs ]
    toDF :: DBoundT m a -> [a]
toDF = String -> DBoundT m a -> [a]
forall a. HasCallStack => String -> a
error String
"No toDF for DBoundT"
    mapDepth :: (Bag a -> Bag b) -> DBoundT m a -> DBoundT m b
mapDepth Bag a -> Bag b
f (DBT Int -> m (Bag (a, Int))
g) = (Int -> m (Bag (b, Int))) -> DBoundT m b
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> m (Bag (b, Int))) -> DBoundT m b)
-> (Int -> m (Bag (b, Int))) -> DBoundT m b
forall a b. (a -> b) -> a -> b
$ \Int
d -> Int -> m (Bag (a, Int))
g Int
d m (Bag (a, Int))
-> (Bag (a, Int) -> m (Bag (b, Int))) -> m (Bag (b, Int))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bag (a, Int)
gd -> case Bag (a, Int) -> (Bag a, [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip (Bag (a, Int) -> (Bag a, [Int])) -> Bag (a, Int) -> (Bag a, [Int])
forall a b. (a -> b) -> a -> b
$ Bag (a, Int)
gd of (Bag a
xs, [Int]
is) -> Bag (b, Int) -> m (Bag (b, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (b, Int) -> m (Bag (b, Int)))
-> Bag (b, Int) -> m (Bag (b, Int))
forall a b. (a -> b) -> a -> b
$ Bag b -> [Int] -> Bag (b, Int)
forall a b. [a] -> [b] -> [(a, b)]
zip (Bag a -> Bag b
f Bag a
xs) [Int]
is
    catBags :: DBoundT m (Bag a) -> DBoundT m a
catBags (DBT Int -> m (Bag (Bag a, Int))
f) = (Int -> m (Bag (a, Int))) -> DBoundT m a
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT (\Int
d -> Int -> m (Bag (Bag a, Int))
f Int
d m (Bag (Bag a, Int))
-> (Bag (Bag a, Int) -> m (Bag (a, Int))) -> m (Bag (a, Int))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bag (Bag a, Int)
fd -> Bag (a, Int) -> m (Bag (a, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return [ (a
x,Int
i) | (Bag a
xs,Int
i) <- Bag (Bag a, Int)
fd, a
x <- Bag a
xs ])
    ifDepth :: (Int -> Bool) -> DBoundT m a -> DBoundT m a -> DBoundT m a
ifDepth Int -> Bool
pred (DBT Int -> m (Bag (a, Int))
t) (DBT Int -> m (Bag (a, Int))
f) = (Int -> m (Bag (a, Int))) -> DBoundT m a
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT Int -> m (Bag (a, Int))
fun
        where fun :: Int -> m (Bag (a, Int))
fun Int
depth | Int -> Bool
pred Int
depth = Int -> m (Bag (a, Int))
t Int
depth
                        | Bool
otherwise  = Int -> m (Bag (a, Int))
f Int
depth
#ifdef QUICKCHECK
-- 0からか1からかでややこしいので，一応quickCheckしておくべし．
prop_fromMxToMx, prop_fromRcToRc :: DBound Int -> Int -> Property
prop_fromMxToMx = \db d -> d>=0 ==> sort (unDB (fromMx (toMx db)) d) == sort (unDB db d) -- passed 100 tests
prop_fromRcToRc = \db d -> d>=0 ==> sort (unDB (fromRc (toRc db)) d) == sort (unDB db d) -- passed 100 tests

prop_toMxFromMx = \mx d -> (d>=0 && length (unMx mx) >= d) ==> take d (map sort (unMx (toMx (fromMx mx :: DBound Int)))) == take d (map sort (unMx mx)) -- passed 100 tests
prop_toRcFromRc = \rc d -> d>=0 ==> sort (unRc (toRc (fromRc rc :: DBound Int)) d) == sort (unRc rc d) -- passed 100 tests
#endif

-- Dunno if "Memoable" is a correct English. Or maybe I should use IsMemoOf?
class (Search n) => Memoable m n where -- なんかmをmonadにするのが面倒になってきたっていうか，その必要ないでしょ．
    tabulate  :: n a -> m a
    applyMemo :: m a -> n a
instance Memoable Matrix Recomp where
    tabulate :: Recomp a -> Matrix a
tabulate  (Rc Int -> Bag a
f)   = Stream (Bag a) -> Matrix a
forall a. Stream (Bag a) -> Matrix a
Mx (Stream (Bag a) -> Matrix a) -> Stream (Bag a) -> Matrix a
forall a b. (a -> b) -> a -> b
$ (Int -> Bag a) -> [Int] -> Stream (Bag a)
forall a b. (a -> b) -> [a] -> [b]
map Int -> Bag a
f [Int
0..]
    applyMemo :: Matrix a -> Recomp a
applyMemo (Mx Stream (Bag a)
xss) = (Int -> Bag a) -> Recomp a
forall a. (Int -> Bag a) -> Recomp a
Rc (Stream (Bag a)
xssStream (Bag a) -> Int -> Bag a
forall a. [a] -> Int -> a
!!)
instance Memoable DBMemo DBound where
    tabulate :: DBound a -> DBMemo a
tabulate  (DB  Int -> Bag (a, Int)
f)   = Stream (Bag (a, Int)) -> DBMemo a
forall a. Stream (Bag (a, Int)) -> DBMemo a
DBM (Stream (Bag (a, Int)) -> DBMemo a)
-> Stream (Bag (a, Int)) -> DBMemo a
forall a b. (a -> b) -> a -> b
$ (Int -> Bag (a, Int)) -> [Int] -> Stream (Bag (a, Int))
forall a b. (a -> b) -> [a] -> [b]
map Int -> Bag (a, Int)
f [Int
0..]
    applyMemo :: DBMemo a -> DBound a
applyMemo (DBM Stream (Bag (a, Int))
xss) = (Int -> Bag (a, Int)) -> DBound a
forall a. (Int -> Bag (a, Int)) -> DBound a
DB (Stream (Bag (a, Int))
xssStream (Bag (a, Int)) -> Int -> Bag (a, Int)
forall a. [a] -> Int -> a
!!)

newtype DBMemo a = DBM {DBMemo a -> Stream (Bag (a, Int))
unDBM :: Stream (Bag (a,Int))}
{-
instance Monad DBMemo where
    return x = tabulate $ return x -- コンパイル通る?
             -- = DBM $ map (\n->[(x,n)]) [0..]
    DBM p >>= f = DBM $ 
-}


\end{code}

\begin{code}
test'' :: Bag (Integer, Integer)
test'' = [Bag (Integer, Integer)] -> Bag (Integer, Integer)
forall a. Monoid a => [a] -> a
mconcat (Matrix (Integer, Integer) -> [Bag (Integer, Integer)]
forall a. Matrix a -> Stream (Bag a)
unMx Matrix (Integer, Integer)
test')
test' :: Matrix (Integer, Integer)
test' = do Integer
x <- Stream (Bag Integer) -> Matrix Integer
forall a. Stream (Bag a) -> Matrix a
Mx [Integer -> Bag Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
x | Integer
x<-[Integer
1..]]
           Integer
y <- Stream (Bag Integer) -> Matrix Integer
forall a. Stream (Bag a) -> Matrix a
Mx [Integer -> Bag Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
y | Integer
y<-[Integer
1..]]
           Bool -> Matrix ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
yInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
30)
           (Integer, Integer) -> Matrix (Integer, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
x,Integer
y)

main :: IO ()
main = Bag (Integer, Integer) -> IO ()
forall a. Show a => a -> IO ()
print Bag (Integer, Integer)
test''
\end{code}