-- 
-- (c) Susumu Katayama
--
{-# LANGUAGE CPP #-}
#define CHTO
module MagicHaskeller.ClassifyDM(filterDM, filterList, filterListDB, filterDMIO, spreexecuteDM) where -- , filterDMTI) where

import Control.Monad.Search.Combinatorial
import Data.Maybe

import MagicHaskeller.Instantiate
import MagicHaskeller.Types
import MagicHaskeller.TyConLib
import MagicHaskeller.DebMT
import MagicHaskeller.MyDynamic
#ifdef CHTO
import System.IO.Unsafe
import MagicHaskeller.TimeOut
import Data.IORef
#endif
import MagicHaskeller.T10(mergesortWithBy, mergesortWithByBot, mergesortWithByBotIO)
import MagicHaskeller.PriorSubsts
import MagicHaskeller.Classify(opreexecute, ofilterDB, CmpBot, cmpBot, cmpBotIO) -- ofilterDB はこっちで定義されていてもいいようなもの．

import MagicHaskeller.Expression

import MagicHaskeller.ProgramGenerator(Common(..))
import MagicHaskeller.Options(Opt(..))

-- import Data.MapByBot

-- sortWithByBot f cmp = Data.MapByBot.elems . Data.MapByBot.fromListWith cmp (flip f) . map (\k -> (k,k))
sortWithByBot :: (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
sortWithByBot = (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
forall k. (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
mergesortWithByBot

select :: DBound ([[Dynamic]], AnnExpr) -> DBound ([Dynamic], AnnExpr)
-- select (DB f) = DB $ \n -> map (\((xss,ae),i) -> (((xss!!n), ae),i)) $ f n
select :: DBound ([[Dynamic]], AnnExpr) -> DBound ([Dynamic], AnnExpr)
select = (Int
 -> Bag (([[Dynamic]], AnnExpr), Int)
 -> Bag (([Dynamic], AnnExpr), Int))
-> DBound ([[Dynamic]], AnnExpr) -> DBound ([Dynamic], AnnExpr)
forall (m :: * -> *) a b.
DB m =>
(Int -> Bag (a, Int) -> Bag (b, Int)) -> m a -> m b
zipDepthDB ((Int
  -> Bag (([[Dynamic]], AnnExpr), Int)
  -> Bag (([Dynamic], AnnExpr), Int))
 -> DBound ([[Dynamic]], AnnExpr) -> DBound ([Dynamic], AnnExpr))
-> (Int
    -> Bag (([[Dynamic]], AnnExpr), Int)
    -> Bag (([Dynamic], AnnExpr), Int))
-> DBound ([[Dynamic]], AnnExpr)
-> DBound ([Dynamic], AnnExpr)
forall a b. (a -> b) -> a -> b
$ \Int
d -> ((([[Dynamic]], AnnExpr), Int) -> (([Dynamic], AnnExpr), Int))
-> Bag (([[Dynamic]], AnnExpr), Int)
-> Bag (([Dynamic], AnnExpr), Int)
forall a b. (a -> b) -> [a] -> [b]
map (\(([[Dynamic]]
xss,AnnExpr
ae),Int
i) -> ((([[Dynamic]]
xss[[Dynamic]] -> Int -> [Dynamic]
forall a. [a] -> Int -> a
!!Int
d), AnnExpr
ae),Int
i))

spreexecuteDM :: (Dynamic->Dynamic) -> [[Dynamic]] -> AnnExpr -> ([[Dynamic]], AnnExpr)
spreexecuteDM :: (Dynamic -> Dynamic)
-> [[Dynamic]] -> AnnExpr -> ([[Dynamic]], AnnExpr)
spreexecuteDM Dynamic -> Dynamic
uncurrier [[Dynamic]]
rnds e :: AnnExpr
e@(AE CoreExpr
_ Dynamic
dyn) = let f :: Dynamic
f = Dynamic -> Dynamic
uncurrier Dynamic
dyn in (([Dynamic] -> [Dynamic]) -> [[Dynamic]] -> [[Dynamic]]
forall a b. (a -> b) -> [a] -> [b]
map ({- forceList . -} (Dynamic -> Dynamic) -> [Dynamic] -> [Dynamic]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Dynamic -> Dynamic -> Dynamic
dynAppErr String
"in ClassifyDM.spreexecuteDM" Dynamic
f)) [[Dynamic]]
rnds,  AnnExpr
e)

sprDM :: (Dynamic->Dynamic) -> [[Dynamic]] -> AnnExpr -> Int -> ([Dynamic], AnnExpr)
sprDM :: (Dynamic -> Dynamic)
-> [[Dynamic]] -> AnnExpr -> Int -> ([Dynamic], AnnExpr)
sprDM Dynamic -> Dynamic
unc [[Dynamic]]
rnds AnnExpr
e Int
db = case (Dynamic -> Dynamic)
-> [[Dynamic]] -> AnnExpr -> ([[Dynamic]], AnnExpr)
spreexecuteDM Dynamic -> Dynamic
unc [[Dynamic]]
rnds AnnExpr
e of ([[Dynamic]]
xss, AnnExpr
ae) -> ([[Dynamic]]
xss[[Dynamic]] -> Int -> [Dynamic]
forall a. [a] -> Int -> a
!!Int
db, AnnExpr
ae)

forceList :: [a] -> [a]
forceList :: [a] -> [a]
forceList []        = []
forceList xs :: [a]
xs@(a
y:[a]
ys) = a
y a -> [a] -> [a]
`seq` [a] -> [a]
forall a. [a] -> [a]
forceList [a]
ys [a] -> [a] -> [a]
`seq` [a]
xs

-- filterList is convenient if inter-depth filtration is unnecessary (e.g. when you want to do complementary filtration).
filterList :: Common -> Type -> Int -> [AnnExpr] -> [AnnExpr]
filterList :: Common -> Type -> Int -> [AnnExpr] -> [AnnExpr]
filterList Common
cmn Type
typ Int
db
    = case [Int]
-> TyConLib -> RTrie -> Type -> Maybe ([[Dynamic]], PackedOrd)
typeToRandomsOrdDM (Opt () -> [Int]
forall a. Opt a -> [Int]
nrands (Opt () -> [Int]) -> Opt () -> [Int]
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn) (Common -> TyConLib
tcl Common
cmn) (Common -> RTrie
rt Common
cmn) Type
typ of
        Maybe ([[Dynamic]], PackedOrd)
Nothing         -> [AnnExpr] -> [AnnExpr]
forall a. a -> a
id
        Just ([], PackedOrd
op)   -> -- fmap snd . ofilterDB op . fmap opreexecute
                           (AnnExpr -> AnnExpr -> AnnExpr)
-> (AnnExpr -> AnnExpr -> Maybe Ordering) -> [AnnExpr] -> [AnnExpr]
forall k. (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
sortWithByBot AnnExpr -> AnnExpr -> AnnExpr
forall a b. a -> b -> a
const (\(AE CoreExpr
_ Dynamic
k) (AE CoreExpr
_ Dynamic
l) -> (PackedOrd, Opt ()) -> Dynamic -> Dynamic -> Maybe Ordering
forall t1 t2 a2 a1.
(t1 -> t2 -> a2, Opt a1) -> t1 -> t2 -> Maybe a2
cmpBot (PackedOrd
op, Common -> Opt ()
opt Common
cmn) Dynamic
k Dynamic
l)
        Just ([[Dynamic]]
rndss,PackedOrd
op) -> -- fmap snd . sfilterDM (nrands $ opt cmn) op . select . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss)
                           (([Dynamic], AnnExpr) -> AnnExpr)
-> [([Dynamic], AnnExpr)] -> [AnnExpr]
forall a b. (a -> b) -> [a] -> [b]
map ([Dynamic], AnnExpr) -> AnnExpr
forall a b. (a, b) -> b
snd ([([Dynamic], AnnExpr)] -> [AnnExpr])
-> ([AnnExpr] -> [([Dynamic], AnnExpr)]) -> [AnnExpr] -> [AnnExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                           (([Dynamic], AnnExpr)
 -> ([Dynamic], AnnExpr) -> ([Dynamic], AnnExpr))
-> (([Dynamic], AnnExpr) -> ([Dynamic], AnnExpr) -> Maybe Ordering)
-> [([Dynamic], AnnExpr)]
-> [([Dynamic], AnnExpr)]
forall k. (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
sortWithByBot ([Dynamic], AnnExpr)
-> ([Dynamic], AnnExpr) -> ([Dynamic], AnnExpr)
forall a b. a -> b -> a
const
                                              ([Int]
-> Int
-> (PackedOrd, Opt ())
-> ([Dynamic], AnnExpr)
-> ([Dynamic], AnnExpr)
-> Maybe Ordering
forall a e.
[Int] -> Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
nthCompareBot (Opt () -> [Int]
forall a. Opt a -> [Int]
nrands (Opt () -> [Int]) -> Opt () -> [Int]
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn) Int
db (PackedOrd
op, Common -> Opt ()
opt Common
cmn)) ([([Dynamic], AnnExpr)] -> [([Dynamic], AnnExpr)])
-> ([AnnExpr] -> [([Dynamic], AnnExpr)])
-> [AnnExpr]
-> [([Dynamic], AnnExpr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                           (AnnExpr -> ([Dynamic], AnnExpr))
-> [AnnExpr] -> [([Dynamic], AnnExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (\AnnExpr
ae -> (Dynamic -> Dynamic)
-> [[Dynamic]] -> AnnExpr -> Int -> ([Dynamic], AnnExpr)
sprDM (Dynamic -> Type -> Dynamic -> Dynamic
uncurryDyn (TyConLib -> Dynamic
mkUncurry (TyConLib -> Dynamic) -> TyConLib -> Dynamic
forall a b. (a -> b) -> a -> b
$ Common -> TyConLib
tcl Common
cmn) Type
typ) [[Dynamic]]
rndss AnnExpr
ae Int
db)
filterListDB ::  Common -> Type -> [AnnExpr] -> DBound [AnnExpr]
filterListDB :: Common -> Type -> [AnnExpr] -> DBound [AnnExpr]
filterListDB Common
cmn Type
typ [AnnExpr]
aes
    = (Int -> Bag ([AnnExpr], Int)) -> DBound [AnnExpr]
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag ([AnnExpr], Int)) -> DBound [AnnExpr])
-> (Int -> Bag ([AnnExpr], Int)) -> DBound [AnnExpr]
forall a b. (a -> b) -> a -> b
$ \Int
db -> [(Common -> Type -> Int -> [AnnExpr] -> [AnnExpr]
filterList Common
cmn Type
typ Int
db [AnnExpr]
aes,Int
db)]

filterDM :: DB m => Common -> Type -> m AnnExpr -> m AnnExpr
filterDM :: Common -> Type -> m AnnExpr -> m AnnExpr
filterDM Common
cmn Type
typ
    = case [Int]
-> TyConLib -> RTrie -> Type -> Maybe ([[Dynamic]], PackedOrd)
typeToRandomsOrdDM (Opt () -> [Int]
forall a. Opt a -> [Int]
nrands (Opt () -> [Int]) -> Opt () -> [Int]
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn) (Common -> TyConLib
tcl Common
cmn) (Common -> RTrie
rt Common
cmn) Type
typ of
        Maybe ([[Dynamic]], PackedOrd)
Nothing         -> m AnnExpr -> m AnnExpr
forall a. a -> a
id
        Just ([], PackedOrd
op)   -> -- fmap snd . ofilterDB op . fmap opreexecute
                           (Bag (AnnExpr, Int) -> Bag (AnnExpr, Int))
-> m AnnExpr -> m AnnExpr
forall (m :: * -> *) a b.
DB m =>
(Bag (a, Int) -> Bag (b, Int)) -> m a -> m b
mapDepthDB ((Bag (AnnExpr, Int) -> Bag (AnnExpr, Int))
 -> m AnnExpr -> m AnnExpr)
-> (Bag (AnnExpr, Int) -> Bag (AnnExpr, Int))
-> m AnnExpr
-> m AnnExpr
forall a b. (a -> b) -> a -> b
$ ((AnnExpr, Int) -> (AnnExpr, Int) -> (AnnExpr, Int))
-> ((AnnExpr, Int) -> (AnnExpr, Int) -> Maybe Ordering)
-> Bag (AnnExpr, Int)
-> Bag (AnnExpr, Int)
forall k. (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
sortWithByBot (AnnExpr, Int) -> (AnnExpr, Int) -> (AnnExpr, Int)
forall a b. a -> b -> a
const (\((AE CoreExpr
_ Dynamic
k),Int
_) ((AE CoreExpr
_ Dynamic
l),Int
_) -> (PackedOrd, Opt ()) -> Dynamic -> Dynamic -> Maybe Ordering
forall t1 t2 a2 a1.
(t1 -> t2 -> a2, Opt a1) -> t1 -> t2 -> Maybe a2
cmpBot (PackedOrd
op, Common -> Opt ()
opt Common
cmn) Dynamic
k Dynamic
l)
        Just ([[Dynamic]]
rndss,PackedOrd
op) -> -- fmap snd . sfilterDM (nrands $ opt cmn) op . select . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss)
                           (Int -> Bag (AnnExpr, Int) -> Bag (AnnExpr, Int))
-> m AnnExpr -> m AnnExpr
forall (m :: * -> *) a b.
DB m =>
(Int -> Bag (a, Int) -> Bag (b, Int)) -> m a -> m b
zipDepthDB (\Int
d -> ((([Dynamic], AnnExpr), Int) -> (AnnExpr, Int))
-> Bag (([Dynamic], AnnExpr), Int) -> Bag (AnnExpr, Int)
forall a b. (a -> b) -> [a] -> [b]
map (\(([Dynamic]
_dyns,AnnExpr
ae),Int
i) -> (AnnExpr
ae,Int
i)) (Bag (([Dynamic], AnnExpr), Int) -> Bag (AnnExpr, Int))
-> (Bag (AnnExpr, Int) -> Bag (([Dynamic], AnnExpr), Int))
-> Bag (AnnExpr, Int)
-> Bag (AnnExpr, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                             ((([Dynamic], AnnExpr), Int)
 -> (([Dynamic], AnnExpr), Int) -> (([Dynamic], AnnExpr), Int))
-> ((([Dynamic], AnnExpr), Int)
    -> (([Dynamic], AnnExpr), Int) -> Maybe Ordering)
-> Bag (([Dynamic], AnnExpr), Int)
-> Bag (([Dynamic], AnnExpr), Int)
forall k. (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
sortWithByBot (\x :: (([Dynamic], AnnExpr), Int)
x@(([Dynamic], AnnExpr)
_,Int
i) y :: (([Dynamic], AnnExpr), Int)
y@(([Dynamic], AnnExpr)
_,Int
j) -> if Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
j then (([Dynamic], AnnExpr), Int)
y else (([Dynamic], AnnExpr), Int)
x)
                                                                (\(([Dynamic], AnnExpr)
k,Int
_) (([Dynamic], AnnExpr)
l,Int
_) -> [Int]
-> Int
-> (PackedOrd, Opt ())
-> ([Dynamic], AnnExpr)
-> ([Dynamic], AnnExpr)
-> Maybe Ordering
forall a e.
[Int] -> Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
nthCompareBot (Opt () -> [Int]
forall a. Opt a -> [Int]
nrands (Opt () -> [Int]) -> Opt () -> [Int]
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn) Int
d (PackedOrd
op, Common -> Opt ()
opt Common
cmn) ([Dynamic], AnnExpr)
k ([Dynamic], AnnExpr)
l) (Bag (([Dynamic], AnnExpr), Int)
 -> Bag (([Dynamic], AnnExpr), Int))
-> (Bag (AnnExpr, Int) -> Bag (([Dynamic], AnnExpr), Int))
-> Bag (AnnExpr, Int)
-> Bag (([Dynamic], AnnExpr), Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                             ((AnnExpr, Int) -> (([Dynamic], AnnExpr), Int))
-> Bag (AnnExpr, Int) -> Bag (([Dynamic], AnnExpr), Int)
forall a b. (a -> b) -> [a] -> [b]
map (\(AnnExpr
ae,Int
i) -> ((Dynamic -> Dynamic)
-> [[Dynamic]] -> AnnExpr -> Int -> ([Dynamic], AnnExpr)
sprDM (Dynamic -> Type -> Dynamic -> Dynamic
uncurryDyn (TyConLib -> Dynamic
mkUncurry (TyConLib -> Dynamic) -> TyConLib -> Dynamic
forall a b. (a -> b) -> a -> b
$ Common -> TyConLib
tcl Common
cmn) Type
typ) [[Dynamic]]
rndss AnnExpr
ae Int
d, Int
i)))

filterDMIO :: Common -> Type -> DBound AnnExpr -> DBoundT IO AnnExpr
filterDMIO :: Common -> Type -> DBound AnnExpr -> DBoundT IO AnnExpr
filterDMIO Common
cmn Type
typ DBound AnnExpr
db
    = case [Int]
-> TyConLib -> RTrie -> Type -> Maybe ([[Dynamic]], PackedOrd)
typeToRandomsOrdDM (Opt () -> [Int]
forall a. Opt a -> [Int]
nrands (Opt () -> [Int]) -> Opt () -> [Int]
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn) (Common -> TyConLib
tcl Common
cmn) (Common -> RTrie
rt Common
cmn) Type
typ of
        Maybe ([[Dynamic]], PackedOrd)
Nothing         ->  DBound AnnExpr -> DBoundT IO AnnExpr
forall (m :: * -> *) a. Search m => DBound a -> m a
fromDB DBound AnnExpr
db
        Just ([], PackedOrd
op)   -> -- fmap snd . ofilterDB op . fmap opreexecute
                           (Int -> IO (Bag (AnnExpr, Int))) -> DBoundT IO AnnExpr
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> IO (Bag (AnnExpr, Int))) -> DBoundT IO AnnExpr)
-> (Int -> IO (Bag (AnnExpr, Int))) -> DBoundT IO AnnExpr
forall a b. (a -> b) -> a -> b
$ \Int
d -> ((AnnExpr, Int) -> (AnnExpr, Int) -> (AnnExpr, Int))
-> ((AnnExpr, Int) -> (AnnExpr, Int) -> IO (Maybe Ordering))
-> Bag (AnnExpr, Int)
-> IO (Bag (AnnExpr, Int))
forall k.
(k -> k -> k) -> (k -> k -> IO (Maybe Ordering)) -> [k] -> IO [k]
mergesortWithByBotIO (AnnExpr, Int) -> (AnnExpr, Int) -> (AnnExpr, Int)
forall a b. a -> b -> a
const (\((AE CoreExpr
_ Dynamic
k),Int
_) ((AE CoreExpr
_ Dynamic
l),Int
_) -> (PackedOrd, Opt ()) -> Dynamic -> Dynamic -> IO (Maybe Ordering)
forall t1 t2 a2 a1.
(t1 -> t2 -> a2, Opt a1) -> t1 -> t2 -> IO (Maybe a2)
cmpBotIO (PackedOrd
op, Common -> Opt ()
opt Common
cmn) Dynamic
k Dynamic
l) (Bag (AnnExpr, Int) -> IO (Bag (AnnExpr, Int)))
-> Bag (AnnExpr, Int) -> IO (Bag (AnnExpr, Int))
forall a b. (a -> b) -> a -> b
$ DBound AnnExpr -> Int -> Bag (AnnExpr, Int)
forall a. DBound a -> Int -> Bag (a, Int)
unDB DBound AnnExpr
db Int
d
        Just ([[Dynamic]]
rndss,PackedOrd
op) -> -- fmap snd . sfilterDM (nrands $ opt cmn) op . select . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss)
                           (Int -> IO (Bag (AnnExpr, Int))) -> DBoundT IO AnnExpr
forall (m :: * -> *) a. (Int -> m (Bag (a, Int))) -> DBoundT m a
DBT ((Int -> IO (Bag (AnnExpr, Int))) -> DBoundT IO AnnExpr)
-> (Int -> IO (Bag (AnnExpr, Int))) -> DBoundT IO AnnExpr
forall a b. (a -> b) -> a -> b
$ \Int
d -> (Bag (([Dynamic], AnnExpr), Int) -> Bag (AnnExpr, Int))
-> IO (Bag (([Dynamic], AnnExpr), Int)) -> IO (Bag (AnnExpr, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((([Dynamic], AnnExpr), Int) -> (AnnExpr, Int))
-> Bag (([Dynamic], AnnExpr), Int) -> Bag (AnnExpr, Int)
forall a b. (a -> b) -> [a] -> [b]
map (\ (([Dynamic]
_dyns,AnnExpr
ae),Int
i) -> (AnnExpr
ae,Int
i))) (IO (Bag (([Dynamic], AnnExpr), Int)) -> IO (Bag (AnnExpr, Int)))
-> IO (Bag (([Dynamic], AnnExpr), Int)) -> IO (Bag (AnnExpr, Int))
forall a b. (a -> b) -> a -> b
$
                                       ((([Dynamic], AnnExpr), Int)
 -> (([Dynamic], AnnExpr), Int) -> (([Dynamic], AnnExpr), Int))
-> ((([Dynamic], AnnExpr), Int)
    -> (([Dynamic], AnnExpr), Int) -> IO (Maybe Ordering))
-> Bag (([Dynamic], AnnExpr), Int)
-> IO (Bag (([Dynamic], AnnExpr), Int))
forall k.
(k -> k -> k) -> (k -> k -> IO (Maybe Ordering)) -> [k] -> IO [k]
mergesortWithByBotIO (\x :: (([Dynamic], AnnExpr), Int)
x@(([Dynamic], AnnExpr)
_,Int
i) y :: (([Dynamic], AnnExpr), Int)
y@(([Dynamic], AnnExpr)
_,Int
j) -> if Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
j then (([Dynamic], AnnExpr), Int)
y else (([Dynamic], AnnExpr), Int)
x)
                                                            (\ (([Dynamic], AnnExpr)
k,Int
_) (([Dynamic], AnnExpr)
l,Int
_) -> [Int]
-> Int
-> (PackedOrd, Opt ())
-> ([Dynamic], AnnExpr)
-> ([Dynamic], AnnExpr)
-> IO (Maybe Ordering)
forall a e.
[Int]
-> Int -> CmpBot a -> ([a], e) -> ([a], e) -> IO (Maybe Ordering)
nthCompareBotIO (Opt () -> [Int]
forall a. Opt a -> [Int]
nrands (Opt () -> [Int]) -> Opt () -> [Int]
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn) Int
d (PackedOrd
op, Common -> Opt ()
opt Common
cmn) ([Dynamic], AnnExpr)
k ([Dynamic], AnnExpr)
l)
                                                            (((AnnExpr, Int) -> (([Dynamic], AnnExpr), Int))
-> Bag (AnnExpr, Int) -> Bag (([Dynamic], AnnExpr), Int)
forall a b. (a -> b) -> [a] -> [b]
map (\(AnnExpr
ae,Int
i) -> ((Dynamic -> Dynamic)
-> [[Dynamic]] -> AnnExpr -> Int -> ([Dynamic], AnnExpr)
sprDM (Dynamic -> Type -> Dynamic -> Dynamic
uncurryDyn (TyConLib -> Dynamic
mkUncurry (TyConLib -> Dynamic) -> TyConLib -> Dynamic
forall a b. (a -> b) -> a -> b
$ Common -> TyConLib
tcl Common
cmn) Type
typ) [[Dynamic]]
rndss AnnExpr
ae Int
d, Int
i)) (Bag (AnnExpr, Int) -> Bag (([Dynamic], AnnExpr), Int))
-> Bag (AnnExpr, Int) -> Bag (([Dynamic], AnnExpr), Int)
forall a b. (a -> b) -> a -> b
$ DBound AnnExpr -> Int -> Bag (AnnExpr, Int)
forall a. DBound a -> Int -> Bag (a, Int)
unDB DBound AnnExpr
db Int
d)

-- depth bound(つまり，Int->[(a,Int)]における引数のInt)の代わりに，depth boundからの距離(つまり，Int->[(a,Int)]におけるInt->[(a,ここのInt)])を使ってnrndsの何番目かを決めるもの．
-- filterDMと違って，同じdepth boundでも違う乱数を使うので，filterList同様depthを跨いだfiltrationができず，結果はいまいち．
-- ただし，dynamicな関数自体をメモ化すれば，格段にメモにヒットしやすくなるはず．
filterDMlite :: Common -> Type -> DBound AnnExpr -> DBound AnnExpr
filterDMlite :: Common -> Type -> DBound AnnExpr -> DBound AnnExpr
filterDMlite Common
cmn Type
typ
    = case [Int]
-> TyConLib -> RTrie -> Type -> Maybe ([[Dynamic]], PackedOrd)
typeToRandomsOrdDM (Opt () -> [Int]
forall a. Opt a -> [Int]
nrands (Opt () -> [Int]) -> Opt () -> [Int]
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn) (Common -> TyConLib
tcl Common
cmn) (Common -> RTrie
rt Common
cmn) Type
typ of
        Maybe ([[Dynamic]], PackedOrd)
Nothing         -> DBound AnnExpr -> DBound AnnExpr
forall a. a -> a
id
        Just ([], PackedOrd
op)   -> -- fmap snd . ofilterDB op . fmap opreexecute
                           (Bag (AnnExpr, Int) -> Bag (AnnExpr, Int))
-> DBound AnnExpr -> DBound AnnExpr
forall (m :: * -> *) a b.
DB m =>
(Bag (a, Int) -> Bag (b, Int)) -> m a -> m b
mapDepthDB ((Bag (AnnExpr, Int) -> Bag (AnnExpr, Int))
 -> DBound AnnExpr -> DBound AnnExpr)
-> (Bag (AnnExpr, Int) -> Bag (AnnExpr, Int))
-> DBound AnnExpr
-> DBound AnnExpr
forall a b. (a -> b) -> a -> b
$ ((AnnExpr, Int) -> (AnnExpr, Int) -> (AnnExpr, Int))
-> ((AnnExpr, Int) -> (AnnExpr, Int) -> Maybe Ordering)
-> Bag (AnnExpr, Int)
-> Bag (AnnExpr, Int)
forall k. (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
sortWithByBot (AnnExpr, Int) -> (AnnExpr, Int) -> (AnnExpr, Int)
forall a b. a -> b -> a
const (\((AE CoreExpr
_ Dynamic
k),Int
_) ((AE CoreExpr
_ Dynamic
l),Int
_) -> (PackedOrd, Opt ()) -> Dynamic -> Dynamic -> Maybe Ordering
forall t1 t2 a2 a1.
(t1 -> t2 -> a2, Opt a1) -> t1 -> t2 -> Maybe a2
cmpBot (PackedOrd
op, Common -> Opt ()
opt Common
cmn) Dynamic
k Dynamic
l)
        Just ([[Dynamic]]
rndss,PackedOrd
op) -> -- fmap snd . sfilterDM (nrands $ opt cmn) op . select . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss)
                           (Int -> Bag (AnnExpr, Int) -> Bag (AnnExpr, Int))
-> DBound AnnExpr -> DBound AnnExpr
forall (m :: * -> *) a b.
DB m =>
(Int -> Bag (a, Int) -> Bag (b, Int)) -> m a -> m b
zipDepthDB (\Int
d -> ((([Dynamic], AnnExpr), Int) -> (AnnExpr, Int))
-> Bag (([Dynamic], AnnExpr), Int) -> Bag (AnnExpr, Int)
forall a b. (a -> b) -> [a] -> [b]
map (\(([Dynamic]
_dyns,AnnExpr
ae),Int
i) -> (AnnExpr
ae,Int
i)) (Bag (([Dynamic], AnnExpr), Int) -> Bag (AnnExpr, Int))
-> (Bag (AnnExpr, Int) -> Bag (([Dynamic], AnnExpr), Int))
-> Bag (AnnExpr, Int)
-> Bag (AnnExpr, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                             (([Dynamic], AnnExpr)
 -> ([Dynamic], AnnExpr) -> ([Dynamic], AnnExpr))
-> (([Dynamic], AnnExpr) -> ([Dynamic], AnnExpr) -> Maybe Ordering)
-> Int
-> Bag (([Dynamic], AnnExpr), Int)
-> Bag (([Dynamic], AnnExpr), Int)
forall b a.
(Ix b, Num b) =>
(a -> a -> a)
-> (a -> a -> Maybe Ordering) -> b -> [(a, b)] -> [(a, b)]
shrink ([Dynamic], AnnExpr)
-> ([Dynamic], AnnExpr) -> ([Dynamic], AnnExpr)
forall a b. a -> b -> a
const (\([Dynamic], AnnExpr)
k ([Dynamic], AnnExpr)
l -> [Int]
-> Int
-> (PackedOrd, Opt ())
-> ([Dynamic], AnnExpr)
-> ([Dynamic], AnnExpr)
-> Maybe Ordering
forall a e.
[Int] -> Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
nthCompareBot (Opt () -> [Int]
forall a. Opt a -> [Int]
nrands (Opt () -> [Int]) -> Opt () -> [Int]
forall a b. (a -> b) -> a -> b
$ Common -> Opt ()
opt Common
cmn) Int
d (PackedOrd
op, Common -> Opt ()
opt Common
cmn) ([Dynamic], AnnExpr)
k ([Dynamic], AnnExpr)
l) Int
d (Bag (([Dynamic], AnnExpr), Int)
 -> Bag (([Dynamic], AnnExpr), Int))
-> (Bag (AnnExpr, Int) -> Bag (([Dynamic], AnnExpr), Int))
-> Bag (AnnExpr, Int)
-> Bag (([Dynamic], AnnExpr), Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                             ((AnnExpr, Int) -> (([Dynamic], AnnExpr), Int))
-> Bag (AnnExpr, Int) -> Bag (([Dynamic], AnnExpr), Int)
forall a b. (a -> b) -> [a] -> [b]
map (\(AnnExpr
ae,Int
i) -> ((Dynamic -> Dynamic)
-> [[Dynamic]] -> AnnExpr -> Int -> ([Dynamic], AnnExpr)
sprDM (Dynamic -> Type -> Dynamic -> Dynamic
uncurryDyn (TyConLib -> Dynamic
mkUncurry (TyConLib -> Dynamic) -> TyConLib -> Dynamic
forall a b. (a -> b) -> a -> b
$ Common -> TyConLib
tcl Common
cmn) Type
typ) [[Dynamic]]
rndss AnnExpr
ae Int
i {- i, not d-}, Int
i)))

listCmp :: Int -> (a->a->Ordering) -> [a] -> [a] -> Ordering
listCmp :: Int -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering
listCmp Int
0 a -> a -> Ordering
cmp [a]
_      [a]
_      = Ordering
EQ
listCmp Int
n a -> a -> Ordering
cmp []     []     = Ordering
EQ
listCmp Int
n a -> a -> Ordering
cmp (a
x:[a]
xs) (a
y:[a]
ys) = case a -> a -> Ordering
cmp a
x a
y of Ordering
EQ -> Int -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering
forall a. Int -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering
listCmp (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) a -> a -> Ordering
cmp [a]
xs [a]
ys
                                              Ordering
c  -> Ordering
c

nthCompareBot :: [Int] -> Int -> CmpBot a -> ([a],e) -> ([a],e) -> Maybe Ordering
nthCompareBot :: [Int] -> Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
nthCompareBot [Int]
nrnds Int
m CmpBot a
cmp ([a]
xs,e
_) ([a]
ys,e
_) = Int -> CmpBot a -> [a] -> [a] -> Maybe Ordering
forall a. Int -> CmpBot a -> [a] -> [a] -> Maybe Ordering
listCmpBot ([Int]
nrnds [Int] -> Int -> Int
forall a. [a] -> Int -> a
!! Int
m) CmpBot a
cmp [a]
xs [a]
ys
listCmpBot :: Int -> CmpBot a -> [a] -> [a] -> Maybe Ordering
#ifdef CHTO
listCmpBot :: Int -> CmpBot a -> [a] -> [a] -> Maybe Ordering
listCmpBot Int
len (a -> a -> Ordering
cmp,Opt ()
pto) [a]
xs [a]
ys = Opt () -> Ordering -> Maybe Ordering
forall a1 a2. Opt a1 -> a2 -> Maybe a2
unsafeWithPTOOpt Opt ()
pto (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Int -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering
forall a. Int -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering
listCmp Int
len a -> a -> Ordering
cmp [a]
xs [a]
ys
#else
listCmpBot len (cmp,_)   xs ys = Just $ listCmp len cmp xs ys
#endif

nthCompareBotIO :: [Int] -> Int -> CmpBot a -> ([a],e) -> ([a],e) -> IO (Maybe Ordering)
nthCompareBotIO :: [Int]
-> Int -> CmpBot a -> ([a], e) -> ([a], e) -> IO (Maybe Ordering)
nthCompareBotIO [Int]
nrnds Int
m CmpBot a
cmp ([a]
xs,e
_) ([a]
ys,e
_) = Int -> CmpBot a -> [a] -> [a] -> IO (Maybe Ordering)
forall a. Int -> CmpBot a -> [a] -> [a] -> IO (Maybe Ordering)
listCmpBotIO ([Int]
nrnds [Int] -> Int -> Int
forall a. [a] -> Int -> a
!! Int
m) CmpBot a
cmp [a]
xs [a]
ys
listCmpBotIO :: Int -> CmpBot a -> [a] -> [a] -> IO (Maybe Ordering)
#ifdef CHTO
listCmpBotIO :: Int -> CmpBot a -> [a] -> [a] -> IO (Maybe Ordering)
listCmpBotIO Int
len (a -> a -> Ordering
cmp,Opt ()
pto) [a]
xs [a]
ys = Opt () -> IO Ordering -> IO (Maybe Ordering)
forall a1 a2. Opt a1 -> IO a2 -> IO (Maybe a2)
maybeWithTOOpt Opt ()
pto (IO Ordering -> IO (Maybe Ordering))
-> IO Ordering -> IO (Maybe Ordering)
forall a b. (a -> b) -> a -> b
$ Ordering -> IO Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return (Ordering -> IO Ordering) -> Ordering -> IO Ordering
forall a b. (a -> b) -> a -> b
$! Int -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering
forall a. Int -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering
listCmp Int
len a -> a -> Ordering
cmp [a]
xs [a]
ys
#else
listCmpBotIO len (cmp,_)   xs ys = return $ Just $ listCmp len cmp xs ys
#endif


sfilterDM :: [Int] -> CmpBot k -> DBound ([k],e) -> DBound ([k],e)
-- sfilterDM nrnds cmp (DB f) = DB $ \n -> sortWithByBot (\x@(_,i) y@(_,j) -> if i<j then y else x) (\(k,_) (l,_) -> nthCompareBot nrnds n cmp k l) (f n)
sfilterDM :: [Int] -> CmpBot k -> DBound ([k], e) -> DBound ([k], e)
sfilterDM [Int]
nrnds CmpBot k
cmp = (Int -> Bag (([k], e), Int) -> Bag (([k], e), Int))
-> DBound ([k], e) -> DBound ([k], e)
forall (m :: * -> *) a b.
DB m =>
(Int -> Bag (a, Int) -> Bag (b, Int)) -> m a -> m b
zipDepthDB ((Int -> Bag (([k], e), Int) -> Bag (([k], e), Int))
 -> DBound ([k], e) -> DBound ([k], e))
-> (Int -> Bag (([k], e), Int) -> Bag (([k], e), Int))
-> DBound ([k], e)
-> DBound ([k], e)
forall a b. (a -> b) -> a -> b
$ \Int
d -> ((([k], e), Int) -> (([k], e), Int) -> (([k], e), Int))
-> ((([k], e), Int) -> (([k], e), Int) -> Maybe Ordering)
-> Bag (([k], e), Int)
-> Bag (([k], e), Int)
forall k. (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
sortWithByBot (\x :: (([k], e), Int)
x@(([k], e)
_,Int
i) y :: (([k], e), Int)
y@(([k], e)
_,Int
j) -> if Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
j then (([k], e), Int)
y else (([k], e), Int)
x) (\(([k], e)
k,Int
_) (([k], e)
l,Int
_) -> [Int] -> Int -> CmpBot k -> ([k], e) -> ([k], e) -> Maybe Ordering
forall a e.
[Int] -> Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
nthCompareBot [Int]
nrnds Int
d CmpBot k
cmp ([k], e)
k ([k], e)
l)
{-
uniqDM :: (k->k->Ordering) -> DBound ([[k]],e) -> DBound ([[k]],e)
uniqDM cmp (DB f) = DB $ \n -> uniqByBot (\x@(_,i) y@(_,j) -> if i<j then y else x) (\(k,_) (l,_) -> nthCompareBot n cmp k l) (f n)

uniqByBot combiner op = ubb
    where ubb (x:xs@(y:ys)) = case x `op` y of Nothing -> ubb ys
                                               Just EQ -> ubb (combiner x y : ys)
                                               Just LT -> x : ubb xs
                                               Just GT -> y : ubb (x:ys)
          ubb x = x

filterDMTI :: TyConLib -> RTrie -> Type -> DBoundT (PriorSubsts []) AnnExpr -> DBoundT (PriorSubsts []) AnnExpr
filterDMTI tcl rtrie typ
    = case typeToRandomsOrdDM tcl rtrie typ of
        Nothing         -> id
        Just ([],   op) -> fmap snd . ofilterDBTI op . fmap opreexecute
        Just (rndss,op) -> fmap snd . sfilterDMTI op . fmap (spreexecuteDM (uncurryDyn (mkUncurry tcl) typ) rndss)

ofilterDBTI :: Functor f => (k->k->Ordering) -> DBoundT f (k,e) -> DBoundT f (k,e)
ofilterDBTI cmp (DBT f) = DBT $ \n -> fmap (mergesortWithBy (\x@(_,i) y@(_,j) -> if i<j then y else x) (\((k,_),_) ((l,_),_) -> cmp k l))
                                           (f n)
sfilterDMTI :: (k->k->Ordering) -> DBoundT (PriorSubsts []) ([[k]],e) -> DBoundT (PriorSubsts []) ([[k]],e)
sfilterDMTI cmp (DBT f) = DBT $ \n -> fmap (sortWithByBot (\x@(_,i) y@(_,j) -> if i<j then y else x) (\(k,_) (l,_) -> nthCompareBot n cmp k l))
                                           (f n)
-}