-- 
-- (c) Susumu Katayama
--
{-# LANGUAGE MagicHash, CPP #-}
module MagicHaskeller.Classify(randomTestFilter, filterBF, filterRc, filterDB -- , filterDBPos
               , ofilterDB, opreexecute, CmpBot, cmpBot, cmpBotIO -- used by ClassifyDM.hs
               , FiltrableBF
               ) where
#define CHTO
import Control.Monad.Search.Combinatorial
-- import Types(Subst) -- Substにspecializeする必要はないけど．
import Data.Maybe
import Control.Monad(mplus)

import MagicHaskeller.Instantiate
import GHC.Exts(unsafeCoerce#)
-- import Data.Array((!))
import MagicHaskeller.Execute(unsafeExecute) -- :: CoreExpr -> a
import MagicHaskeller.TyConLib
import MagicHaskeller.Types
import MagicHaskeller.DebMT
import MagicHaskeller.MyDynamic
#ifdef CHTO
import System.IO.Unsafe
import MagicHaskeller.TimeOut
import Control.Concurrent(yield)
import Data.IORef
#endif
import MagicHaskeller.T10(mergesortWithBy, mergeWithBy, mergesortWithByBot, mergeWithByBot, diffSortedBy, diffSortedByBot)

#ifdef DEBUG
import Test.QuickCheck
#endif

import MagicHaskeller.Expression

import MagicHaskeller.ProgramGenerator
import MagicHaskeller.Options

import Language.Haskell.TH.Ppr
-- import ReadLambdaExpr(exprToTHExp)
-- import ToString

import System.IO
-- import Debug.Trace
trace :: p -> p -> p
trace p
str p
e = p
e


-- randomTestFilter :: MemoDeb -> Matrix CoreExpr -> Matrix CoreExpr, but I do not like to import ProgGen.
-- randomTestFilter (_,_,tcl,rtrie) typ = toMx . filterDB' id tcl rtrie typ . fromMx
randomTestFilter :: a -> Type -> m AnnExpr -> m AnnExpr
randomTestFilter a
md = TyConLib -> RTrie -> Opt () -> Type -> m AnnExpr -> m AnnExpr
forall (m :: * -> *).
FiltrableBF m =>
TyConLib -> RTrie -> Opt () -> Type -> m AnnExpr -> m AnnExpr
filterBF (a -> TyConLib
forall a. WithCommon a => a -> TyConLib
extractTCL a
md) (a -> RTrie
forall a. WithCommon a => a -> RTrie
extractRTrie a
md) (Common -> Opt ()
opt (Common -> Opt ()) -> Common -> Opt ()
forall a b. (a -> b) -> a -> b
$ a -> Common
forall a. WithCommon a => a -> Common
extractCommon a
md)
filterBF :: FiltrableBF m => TyConLib -> RTrie -> Opt () -> Type -> m AnnExpr -> m AnnExpr
filterBF :: TyConLib -> RTrie -> Opt () -> Type -> m AnnExpr -> m AnnExpr
filterBF TyConLib
tcl RTrie
rtrie Opt ()
pto Type
typ
    = case String -> Order -> Order
forall p p. p -> p -> p
trace (Type -> String
forall a. Show a => a -> String
show Type
typ) (Order -> Order) -> Order -> Order
forall a b. (a -> b) -> a -> b
$
           TyConLib -> RTrie -> Type -> Order
typeToRandomsOrd TyConLib
tcl RTrie
rtrie Type
typ of
                           Order
Nothing        -> m AnnExpr -> m AnnExpr
forall a. a -> a
id
                           Just ([],  PackedOrd
op) -> ((Dynamic, AnnExpr) -> AnnExpr)
-> m (Dynamic, AnnExpr) -> m AnnExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Dynamic, AnnExpr) -> AnnExpr
forall a b. (a, b) -> b
snd (m (Dynamic, AnnExpr) -> m AnnExpr)
-> (m AnnExpr -> m (Dynamic, AnnExpr)) -> m AnnExpr -> m AnnExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmpBot Dynamic -> m (Dynamic, AnnExpr) -> m (Dynamic, AnnExpr)
forall (m :: * -> *) k e.
FiltrableBF m =>
CmpBot k -> m (k, e) -> m (k, e)
ofilter (PackedOrd
op,Opt ()
pto) (m (Dynamic, AnnExpr) -> m (Dynamic, AnnExpr))
-> (m AnnExpr -> m (Dynamic, AnnExpr))
-> m AnnExpr
-> m (Dynamic, AnnExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnnExpr -> (Dynamic, AnnExpr))
-> m AnnExpr -> m (Dynamic, AnnExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnExpr -> (Dynamic, AnnExpr)
opreexecute
--                           Just (rnds,op) -> unscanl . fmap snd . repEqClsBy_simple op . fmap (spreexecute rnds) -- Feb. 10, 2007のnotesの最後の辺り参照．Matrixの場合．
                           Just ([Dynamic]
rnds,PackedOrd
op) -> (([Dynamic], AnnExpr) -> AnnExpr)
-> m ([Dynamic], AnnExpr) -> m AnnExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Dynamic], AnnExpr) -> AnnExpr
forall a b. (a, b) -> b
snd (m ([Dynamic], AnnExpr) -> m AnnExpr)
-> (m AnnExpr -> m ([Dynamic], AnnExpr)) -> m AnnExpr -> m AnnExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmpBot Dynamic -> m ([Dynamic], AnnExpr) -> m ([Dynamic], AnnExpr)
forall (m :: * -> *) k e.
FiltrableBF m =>
CmpBot k -> m ([k], e) -> m ([k], e)
sfilter (PackedOrd
op,Opt ()
pto) (m ([Dynamic], AnnExpr) -> m ([Dynamic], AnnExpr))
-> (m AnnExpr -> m ([Dynamic], AnnExpr))
-> m AnnExpr
-> m ([Dynamic], AnnExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AnnExpr -> ([Dynamic], AnnExpr))
-> m AnnExpr -> m ([Dynamic], AnnExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Dynamic -> Dynamic)
-> [Dynamic] -> AnnExpr -> ([Dynamic], AnnExpr)
spreexecute (Dynamic -> Type -> Dynamic -> Dynamic
uncurryDyn (TyConLib -> Dynamic
mkUncurry TyConLib
tcl) Type
typ) [Dynamic]
rnds)
spreexecute :: (Dynamic -> Dynamic)
-> [Dynamic] -> AnnExpr -> ([Dynamic], AnnExpr)
spreexecute 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 (String -> Dynamic -> Dynamic -> Dynamic
dynAppErr String
"in Classify.spreexecute" Dynamic
f) [Dynamic]
rnds, AnnExpr
e)

opreexecute :: AnnExpr -> (Dynamic, AnnExpr)
opreexecute :: AnnExpr -> (Dynamic, AnnExpr)
opreexecute e :: AnnExpr
e@(AE CoreExpr
_ Dynamic
dyn) = (Dynamic
dyn, AnnExpr
e)

unscanl :: Ord e => Matrix e -> Matrix e
unscanl :: Matrix e -> Matrix e
unscanl = (e -> e -> Ordering) -> Matrix e -> Matrix e
forall k. (k -> k -> Ordering) -> Matrix k -> Matrix k
unscanlBy e -> e -> Ordering
forall a. Ord a => a -> a -> Ordering
compare

type CmpBot k = (k->k->Ordering, Opt ()) -- Comparison that can return a bottom (i.e., either timeout or error).

class Search m => FiltrableBF m where
    sfilter :: CmpBot k -> m ([k],e) -> m ([k],e)
    ofilter :: CmpBot k -> m (k,e) -> m (k,e)
instance FiltrableBF Matrix where
    sfilter :: CmpBot k -> Matrix ([k], e) -> Matrix ([k], e)
sfilter = CmpBot k -> Matrix ([k], e) -> Matrix ([k], e)
forall k e. CmpBot k -> Matrix ([k], e) -> Matrix ([k], e)
sfilterMx
    ofilter :: CmpBot k -> Matrix (k, e) -> Matrix (k, e)
ofilter = CmpBot k -> Matrix (k, e) -> Matrix (k, e)
forall k e. CmpBot k -> Matrix (k, e) -> Matrix (k, e)
ofilterMx
instance FiltrableBF Recomp where
    sfilter :: CmpBot k -> Recomp ([k], e) -> Recomp ([k], e)
sfilter = CmpBot k -> Recomp ([k], e) -> Recomp ([k], e)
forall k e. CmpBot k -> Recomp ([k], e) -> Recomp ([k], e)
sfilterRc
    ofilter :: CmpBot k -> Recomp (k, e) -> Recomp (k, e)
ofilter = CmpBot k -> Recomp (k, e) -> Recomp (k, e)
forall k e. CmpBot k -> Recomp (k, e) -> Recomp (k, e)
ofilterRc
instance FiltrableBF DBound where
    sfilter :: CmpBot k -> DBound ([k], e) -> DBound ([k], e)
sfilter = CmpBot k -> DBound ([k], e) -> DBound ([k], e)
forall k e. CmpBot k -> DBound ([k], e) -> DBound ([k], e)
sfilterDB
    ofilter :: CmpBot k -> DBound (k, e) -> DBound (k, e)
ofilter = CmpBot k -> DBound (k, e) -> DBound (k, e)
forall k e. CmpBot k -> DBound (k, e) -> DBound (k, e)
ofilterDB

-- x この[([k],e)]の部分は，本当のところStreamTrieで実装した方が効率的なはず．

sfilterMx :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e)
-- sfilter op (Mx xss) = unscanlByList op $ foldr (mergeMxBy op) undefined (map (repEqClsBy op) xss)
-- x これだと，mergeMxByがプログラムサイズのことを知らずに最初の1個のkeyの比較から始めてしまう ... と思ったけど実はそうでもない．mergeMxByが(Mx (_:ys))のように先頭をdropするのがポイントで，たとえば(map repEqClsBy xss) !! nは先頭のn個分が(結果として)dropされることになる．
-- x やっぱダメ．
-- x 多分問題は，eqClsByは深さ２以降も深さ１にdependしていて，そうなるとサイズ２以降のプログラムが...みたいな感じ
sfilterMx :: CmpBot k -> Matrix ([k], e) -> Matrix ([k], e)
sfilterMx CmpBot k
op Matrix ([k], e)
mx = String -> Matrix ([k], e) -> Matrix ([k], e)
forall p p. p -> p -> p
trace String
"sfilterMx" (Matrix ([k], e) -> Matrix ([k], e))
-> Matrix ([k], e) -> Matrix ([k], e)
forall a b. (a -> b) -> a -> b
$
                      CmpBot k -> Matrix ([k], e) -> Matrix ([k], e)
forall k e. CmpBot k -> Matrix ([k], e) -> Matrix ([k], e)
unscanlByList CmpBot k
op (Matrix ([k], e) -> Matrix ([k], e))
-> Matrix ([k], e) -> Matrix ([k], e)
forall a b. (a -> b) -> a -> b
$ CmpBot k -> Matrix ([k], e) -> Matrix ([k], e)
forall k e. CmpBot k -> Matrix ([k], e) -> Matrix ([k], e)
repEqClsBy CmpBot k
op Matrix ([k], e)
mx

filterDB :: TyConLib -> RTrie -> Opt () -> Type -> DBound AnnExpr -> DBound AnnExpr
filterDB :: TyConLib
-> RTrie -> Opt () -> Type -> DBound AnnExpr -> DBound AnnExpr
filterDB = TyConLib
-> RTrie -> Opt () -> Type -> DBound AnnExpr -> DBound AnnExpr
forall (m :: * -> *).
FiltrableBF m =>
TyConLib -> RTrie -> Opt () -> Type -> m AnnExpr -> m AnnExpr
filterBF
{-
filterDBPos :: TyConLib -> RTrie -> Type -> DBound (Possibility AnnExpr) -> DBound (Possibility AnnExpr)
filterDBPos tcl rtrie typ
    = case typeToRandomsOrd tcl rtrie typ of
        Nothing        -> id
        Just ([], op)  -> fmap snd . ofilterDBPos op . fmap (\(x,s,i) -> (map opreexecute x, s, i))
        Just (rnds,op) -> fmap snd . sfilterDBPos op . fmap (\(x,s,i) -> (fmap (spreexecuteNTO (uncurryDyn (mkUncurry tcl) typ) rnds) x,  s,  i))
-}
filterRc :: TyConLib -> RTrie -> Opt () -> Type -> Recomp AnnExpr -> Recomp AnnExpr
filterRc :: TyConLib
-> RTrie -> Opt () -> Type -> Recomp AnnExpr -> Recomp AnnExpr
filterRc = TyConLib
-> RTrie -> Opt () -> Type -> Recomp AnnExpr -> Recomp AnnExpr
forall (m :: * -> *).
FiltrableBF m =>
TyConLib -> RTrie -> Opt () -> Type -> m AnnExpr -> m AnnExpr
filterBF

-- x この[([k],e)]の部分は，本当のところStreamTrieで実装した方が効率的なはず．

sfilterRc :: CmpBot k -> Recomp ([k],e) -> Recomp ([k],e)
-- sfilter op (Mx xss) = unscanlByList op $ foldr (mergeMxBy op) undefined (map (repEqClsBy op) xss)
-- x これだと，mergeMxByがプログラムサイズのことを知らずに最初の1個のkeyの比較から始めてしまう ... と思ったけど実はそうでもない．mergeMxByが(Mx (_:ys))のように先頭をdropするのがポイントで，たとえば(map repEqClsBy xss) !! nは先頭のn個分が(結果として)dropされることになる．
-- x やっぱダメ．
-- x 多分問題は，eqClsByは深さ２以降も深さ１にdependしていて，そうなるとサイズ２以降のプログラムが...みたいな感じ
sfilterRc :: CmpBot k -> Recomp ([k], e) -> Recomp ([k], e)
sfilterRc CmpBot k
op Recomp ([k], e)
mx = String -> Recomp ([k], e) -> Recomp ([k], e)
forall p p. p -> p -> p
trace String
"sfilter" (Recomp ([k], e) -> Recomp ([k], e))
-> Recomp ([k], e) -> Recomp ([k], e)
forall a b. (a -> b) -> a -> b
$
                     CmpBot k -> Recomp ([k], e) -> Recomp ([k], e)
forall k e. CmpBot k -> Recomp ([k], e) -> Recomp ([k], e)
unscanlByListRc CmpBot k
op (Recomp ([k], e) -> Recomp ([k], e))
-> Recomp ([k], e) -> Recomp ([k], e)
forall a b. (a -> b) -> a -> b
$ CmpBot k -> Recomp ([k], e) -> Recomp ([k], e)
forall k e. CmpBot k -> Recomp ([k], e) -> Recomp ([k], e)
repEqClsByRc CmpBot k
op Recomp ([k], e)
mx
{-
mergeReps :: (k->k->Ordering) -> Int -> [Matrix ([k],e)] -> Matrix ([k],e)
mergeReps op n ~(rs:rss) = trace "mergeReps" $
                           mergeMxBy op n rs (mergeReps op (n+1) rss)
-}


unscanlByList :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e)
unscanlByList :: CmpBot k -> Matrix ([k], e) -> Matrix ([k], e)
unscanlByList CmpBot k
op Matrix ([k], e)
mx = case Matrix ([k], e) -> Stream (Bag ([k], e))
forall a. Matrix a -> Stream (Bag a)
unMx Matrix ([k], e)
mx of yss :: Stream (Bag ([k], e))
yss@(Bag ([k], e)
xs:Stream (Bag ([k], e))
xss) -> Stream (Bag ([k], e)) -> Matrix ([k], e)
forall a. Stream (Bag a) -> Matrix a
Mx (Bag ([k], e)
xs Bag ([k], e) -> Stream (Bag ([k], e)) -> Stream (Bag ([k], e))
forall a. a -> [a] -> [a]
: (Int -> Bag ([k], e) -> Bag ([k], e) -> Bag ([k], e))
-> [Int]
-> Stream (Bag ([k], e))
-> Stream (Bag ([k], e))
-> Stream (Bag ([k], e))
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (CmpBot k -> Int -> Bag ([k], e) -> Bag ([k], e) -> Bag ([k], e)
forall a e.
CmpBot a -> Int -> [([a], e)] -> [([a], e)] -> [([a], e)]
deleteListByList CmpBot k
op) (CmpBot k -> [Int]
forall a a. (a, Opt a) -> [Int]
tcnrnds CmpBot k
op) Stream (Bag ([k], e))
xss Stream (Bag ([k], e))
yss)

unscanlByListMx :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e)
unscanlByListMx :: CmpBot k -> Matrix ([k], e) -> Matrix ([k], e)
unscanlByListMx CmpBot k
op Matrix ([k], e)
mx = (Int -> Bag ([k], e) -> Bag ([k], e) -> Bag ([k], e))
-> Matrix ([k], e) -> Matrix ([k], e) -> Matrix ([k], e)
forall a b c.
(Int -> Bag a -> Bag b -> Bag c)
-> Matrix a -> Matrix b -> Matrix c
zipDepth3Mx (\Int
dep -> CmpBot k -> Int -> Bag ([k], e) -> Bag ([k], e) -> Bag ([k], e)
forall a e.
CmpBot a -> Int -> [([a], e)] -> [([a], e)] -> [([a], e)]
deleteListByList CmpBot k
op (CmpBot k -> Int -> Int
forall a a. (a, Opt a) -> Int -> Int
fcnrnd CmpBot k
op (Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
dep))) Matrix ([k], e)
mx (Matrix ([k], e) -> Matrix ([k], e)
forall (m :: * -> *) a. Delay m => m a -> m a
delay Matrix ([k], e)
mx)

unscanlByListRc :: CmpBot k -> Recomp ([k],e) -> Recomp ([k],e)
unscanlByListRc :: CmpBot k -> Recomp ([k], e) -> Recomp ([k], e)
unscanlByListRc CmpBot k
op Recomp ([k], e)
rc = (Int -> Bag ([k], e) -> Bag ([k], e) -> Bag ([k], e))
-> Recomp ([k], e) -> Recomp ([k], e) -> Recomp ([k], e)
forall a b c.
(Int -> Bag a -> Bag b -> Bag c)
-> Recomp a -> Recomp b -> Recomp c
zipDepth3Rc (\Int
dep -> CmpBot k -> Int -> Bag ([k], e) -> Bag ([k], e) -> Bag ([k], e)
forall a e.
CmpBot a -> Int -> [([a], e)] -> [([a], e)] -> [([a], e)]
deleteListByList CmpBot k
op (CmpBot k -> Int -> Int
forall a a. (a, Opt a) -> Int -> Int
fcnrnd CmpBot k
op (Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
dep))) Recomp ([k], e)
rc (Recomp ([k], e) -> Recomp ([k], e)
forall (m :: * -> *) a. Delay m => m a -> m a
delay Recomp ([k], e)
rc)


deleteListByList :: CmpBot a -> Int -> [([a], e)] -> [([a], e)] -> [([a], e)]
deleteListByList CmpBot a
cmp Int
len [([a], e)]
xs [([a], e)]
ys = (([a], e) -> ([a], e) -> Maybe Ordering)
-> [([a], e)] -> [([a], e)] -> [([a], e)]
forall a t. (a -> t -> Maybe Ordering) -> [a] -> [t] -> [a]
dlbBot (Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
forall a e.
Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
liftCompareBot Int
len CmpBot a
cmp) [([a], e)]
xs [([a], e)]
ys

comparers :: Int -> CmpBot a -> [([a],e) -> ([a],e) -> Maybe Ordering]
comparers :: Int -> CmpBot a -> [([a], e) -> ([a], e) -> Maybe Ordering]
comparers Int
m CmpBot a
cmp = Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
forall a e.
Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
liftCompareBot Int
m CmpBot a
cmp (([a], e) -> ([a], e) -> Maybe Ordering)
-> [([a], e) -> ([a], e) -> Maybe Ordering]
-> [([a], e) -> ([a], e) -> Maybe Ordering]
forall a. a -> [a] -> [a]
: Int -> CmpBot a -> [([a], e) -> ([a], e) -> Maybe Ordering]
forall a e.
Int -> CmpBot a -> [([a], e) -> ([a], e) -> Maybe Ordering]
comparers (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) CmpBot a
cmp

liftCompare :: Int -> (a->a->Ordering) -> ([a],e) -> ([a],e) -> Ordering
liftCompare :: Int -> (a -> a -> Ordering) -> ([a], e) -> ([a], e) -> Ordering
liftCompare Int
m a -> a -> Ordering
cmp ([a]
xs,e
_) ([a]
ys,e
_) = Int -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering
forall a. Int -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering
liftCmp Int
m a -> a -> Ordering
cmp [a]
xs [a]
ys
liftCmp :: Int -> (a->a->Ordering) -> [a] -> [a] -> Ordering
-- liftCmp len cmp xs ys = fromMaybe (error "liftCmp") $ liftCmpBot len cmp xs ys
liftCmp :: Int -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering
liftCmp Int
0   a -> a -> Ordering
cmp [a]
xs     [a]
ys     = Ordering
EQ
liftCmp Int
_   a -> a -> Ordering
_   []     []     = Ordering
EQ
liftCmp Int
len a -> a -> Ordering
cmp (a
x:[a]
xs) (a
y:[a]
ys) = String -> Ordering -> Ordering
forall p p. p -> p -> p
trace String
"liftCmp" (Ordering -> Ordering) -> Ordering -> Ordering
forall a b. (a -> b) -> a -> b
$
                                   case a -> a -> Ordering
cmp a
x a
y of
                                                Ordering
EQ -> String -> Ordering -> Ordering
forall p p. p -> p -> p
trace String
"just eq" (Ordering -> Ordering) -> Ordering -> Ordering
forall a b. (a -> b) -> a -> b
$
                                                           Int -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering
forall a. Int -> (a -> a -> Ordering) -> [a] -> [a] -> Ordering
liftCmp (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) a -> a -> Ordering
cmp [a]
xs [a]
ys
                                                Ordering
c       -> String -> Ordering -> Ordering
forall p p. p -> p -> p
trace String
"otherwise" 
                                                           Ordering
c

liftCompareBot :: Int -> CmpBot a -> ([a],e) -> ([a],e) -> Maybe Ordering
liftCompareBot :: Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
liftCompareBot 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
liftCmpBot Int
m CmpBot a
cmp [a]
xs [a]
ys
liftCmpBot :: Int -> CmpBot a -> [a] -> [a] -> Maybe Ordering
#ifdef CHTO
liftCmpBot :: Int -> CmpBot a -> [a] -> [a] -> Maybe Ordering
liftCmpBot 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
liftCmp Int
len a -> a -> Ordering
cmp [a]
xs [a]
ys
{-
                         | otherwise     =    liftCmpBot' len cmp xs ys
liftCmpBot' 0   _   _      _      = Just EQ
liftCmpBot' _   _   []     _      = Nothing
liftCmpBot' _   _   (_:_)  []     = Nothing
liftCmpBot' len cmp (x:xs) (y:ys) = trace "liftCmpBot" $
                                   case unsafePerformIO $ maybeWithTO pto $ return $ cmp x y of
                                                Just EQ -> trace "just eq" $
                                                           liftCmpBot' (len-1) cmp xs ys
                                                c       -> trace "otherwise" 
                                                           c
-}
cmpBot :: (t -> t -> a2, Opt a1) -> t -> t -> Maybe a2
cmpBot (t -> t -> a2
cmp,Opt a1
pto) t
x t
y = Opt a1 -> a2 -> Maybe a2
forall a1 a2. Opt a1 -> a2 -> Maybe a2
unsafeWithPTOOpt Opt a1
pto (a2 -> Maybe a2) -> a2 -> Maybe a2
forall a b. (a -> b) -> a -> b
$ t -> t -> a2
cmp t
x t
y
cmpBotIO :: (t -> t -> a2, Opt a1) -> t -> t -> IO (Maybe a2)
cmpBotIO (t -> t -> a2
cmp,Opt a1
pto) t
x t
y = Opt a1 -> IO a2 -> IO (Maybe a2)
forall a1 a2. Opt a1 -> IO a2 -> IO (Maybe a2)
maybeWithTOOpt Opt a1
pto (IO a2 -> IO (Maybe a2)) -> IO a2 -> IO (Maybe a2)
forall a b. (a -> b) -> a -> b
$ a2 -> IO a2
forall (m :: * -> *) a. Monad m => a -> m a
return (a2 -> IO a2) -> a2 -> IO a2
forall a b. (a -> b) -> a -> b
$! t -> t -> a2
cmp t
x t
y
#else
liftCmpBot len (cmp,_pto) xs ys                 = Just $ liftCmp len cmp xs ys
cmpBot (cmp,_pto) x y = Just $ cmp x y
cmpBotIO (cmp,pto) x y = return $ Just $ cmp x y
#endif
-- dlb = deleteListBy

dlbBot :: (a -> t -> Maybe Ordering) -> [a] -> [t] -> [a]
dlbBot a -> t -> Maybe Ordering
cmps [a]
xs [t]
ys = (a -> t -> Maybe Ordering) -> [a] -> [t] -> [a]
forall a t. (a -> t -> Maybe Ordering) -> [a] -> [t] -> [a]
diffSortedByBot a -> t -> Maybe Ordering
cmps [a]
xs [t]
ys
dlb :: (a -> t -> Ordering) -> [a] -> [t] -> [a]
dlb a -> t -> Ordering
cmps [a]
xs [t]
ys = (a -> t -> Ordering) -> [a] -> [t] -> [a]
forall a t. (a -> t -> Ordering) -> [a] -> [t] -> [a]
diffSortedBy a -> t -> Ordering
cmps [a]
xs [t]
ys
{-
dlbBot cmps xs ys = diffSortedByBot cmps (mergesortWithByBot undefined cmps xs) (mergesortWithByBot undefined cmps ys)
dlb cmps xs ys = diffSortedBy cmps (mergesortWithBy undefined cmps xs) (mergesortWithBy undefined cmps ys)
-}

{-
repEqClsBy_simple :: (k->k->Ordering) -> Matrix ([k],e) -> Matrix ([k],e)
repEqClsBy_simple cmp (Mx xss) = Mx $ zipWith (\dep ys -> mergesortWithByBot const (liftCompareBot dep cmp) $ filterEligibles dep ys) cnrnds $ scanl1_recompute (++) xss
scanl1_recompute :: (a -> a -> a) -> [a] -> [a]
scanl1_recompute f xs = [ foldl1 f $ take i xs | i <- [1..] ]
-}

repEqClsBy_simple :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e)
repEqClsBy_simple :: CmpBot k -> Matrix ([k], e) -> Matrix ([k], e)
repEqClsBy_simple CmpBot k
cmp Matrix ([k], e)
mx = Stream (Bag ([k], e)) -> Matrix ([k], e)
forall a. Stream (Bag a) -> Matrix a
Mx (Stream (Bag ([k], e)) -> Matrix ([k], e))
-> Stream (Bag ([k], e)) -> Matrix ([k], e)
forall a b. (a -> b) -> a -> b
$ (Int -> Bag ([k], e) -> Bag ([k], e))
-> [Int] -> Stream (Bag ([k], e)) -> Stream (Bag ([k], e))
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
dep Bag ([k], e)
ys -> (([k], e) -> ([k], e) -> ([k], e))
-> (([k], e) -> ([k], e) -> Maybe Ordering)
-> Bag ([k], e)
-> Bag ([k], e)
forall k. (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
mergesortWithByBot ([k], e) -> ([k], e) -> ([k], e)
forall a b. a -> b -> a
const (Int -> CmpBot k -> ([k], e) -> ([k], e) -> Maybe Ordering
forall a e.
Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
liftCompareBot Int
dep CmpBot k
cmp) Bag ([k], e)
ys) (CmpBot k -> [Int]
forall a a. (a, Opt a) -> [Int]
cnrnds CmpBot k
cmp) (Stream (Bag ([k], e)) -> Stream (Bag ([k], e)))
-> Stream (Bag ([k], e)) -> Stream (Bag ([k], e))
forall a b. (a -> b) -> a -> b
$ Matrix ([k], e) -> Stream (Bag ([k], e))
forall a. Matrix a -> Stream (Bag a)
unMx (Matrix ([k], e) -> Stream (Bag ([k], e)))
-> Matrix ([k], e) -> Stream (Bag ([k], e))
forall a b. (a -> b) -> a -> b
$ Matrix ([k], e) -> Matrix ([k], e)
forall (m :: * -> *) x. Search m => m x -> m x
scanl1BF Matrix ([k], e)
mx

repEqClsByMx :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e)
repEqClsByMx :: CmpBot k -> Matrix ([k], e) -> Matrix ([k], e)
repEqClsByMx CmpBot k
cmp Matrix ([k], e)
mx = (Int -> Bag ([k], e) -> Bag ([k], e))
-> Matrix ([k], e) -> Matrix ([k], e)
forall a b. (Int -> Bag a -> Bag b) -> Matrix a -> Matrix b
zipDepthMx (\Int
dep Bag ([k], e)
ys -> let n :: Int
n = CmpBot k -> Int -> Int
forall a a. (a, Opt a) -> Int -> Int
fcnrnd CmpBot k
cmp Int
dep in (([k], e) -> ([k], e) -> ([k], e))
-> (([k], e) -> ([k], e) -> Maybe Ordering)
-> Bag ([k], e)
-> Bag ([k], e)
forall k. (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
mergesortWithByBot ([k], e) -> ([k], e) -> ([k], e)
forall a b. a -> b -> a
const (Int -> CmpBot k -> ([k], e) -> ([k], e) -> Maybe Ordering
forall a e.
Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
liftCompareBot Int
n CmpBot k
cmp) Bag ([k], e)
ys) (Matrix ([k], e) -> Matrix ([k], e))
-> Matrix ([k], e) -> Matrix ([k], e)
forall a b. (a -> b) -> a -> b
$ Matrix ([k], e) -> Matrix ([k], e)
forall (m :: * -> *) x. Search m => m x -> m x
scanl1BF Matrix ([k], e)
mx

repEqClsByRc :: CmpBot k -> Recomp ([k],e) -> Recomp ([k],e)
repEqClsByRc :: CmpBot k -> Recomp ([k], e) -> Recomp ([k], e)
repEqClsByRc CmpBot k
cmp Recomp ([k], e)
mx = (Int -> Bag ([k], e) -> Bag ([k], e))
-> Recomp ([k], e) -> Recomp ([k], e)
forall a b. (Int -> Bag a -> Bag b) -> Recomp a -> Recomp b
zipDepthRc (\Int
dep Bag ([k], e)
ys -> let n :: Int
n = CmpBot k -> Int -> Int
forall a a. (a, Opt a) -> Int -> Int
fcnrnd CmpBot k
cmp Int
dep in (([k], e) -> ([k], e) -> ([k], e))
-> (([k], e) -> ([k], e) -> Maybe Ordering)
-> Bag ([k], e)
-> Bag ([k], e)
forall k. (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
mergesortWithByBot ([k], e) -> ([k], e) -> ([k], e)
forall a b. a -> b -> a
const (Int -> CmpBot k -> ([k], e) -> ([k], e) -> Maybe Ordering
forall a e.
Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
liftCompareBot Int
n CmpBot k
cmp) Bag ([k], e)
ys) (Recomp ([k], e) -> Recomp ([k], e))
-> Recomp ([k], e) -> Recomp ([k], e)
forall a b. (a -> b) -> a -> b
$ Recomp ([k], e) -> Recomp ([k], e)
forall (m :: * -> *) x. Search m => m x -> m x
scanl1BF Recomp ([k], e)
mx

eqClsBy_naive :: CmpBot a -> Matrix ([a],b) -> Matrix [([a],b)]
eqClsBy_naive :: CmpBot a -> Matrix ([a], b) -> Matrix [([a], b)]
eqClsBy_naive CmpBot a
cmp (Mx Stream [([a], b)]
xss) = Stream (Stream [([a], b)]) -> Matrix [([a], b)]
forall a. Stream (Bag a) -> Matrix a
Mx (Stream (Stream [([a], b)]) -> Matrix [([a], b)])
-> Stream (Stream [([a], b)]) -> Matrix [([a], b)]
forall a b. (a -> b) -> a -> b
$ (Int -> [([a], b)] -> Stream [([a], b)])
-> [Int] -> Stream [([a], b)] -> Stream (Stream [([a], b)])
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
dep [([a], b)]
ys -> [([a], b)]
ys [([a], b)]
-> (([a], b) -> ([a], b) -> Maybe Ordering) -> Stream [([a], b)]
forall a. [a] -> (a -> a -> Maybe Ordering) -> [[a]]
/// Int -> CmpBot a -> ([a], b) -> ([a], b) -> Maybe Ordering
forall a e.
Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
liftCompareBot Int
dep CmpBot a
cmp) (CmpBot a -> [Int]
forall a a. (a, Opt a) -> [Int]
cnrnds CmpBot a
cmp) (Stream [([a], b)] -> Stream (Stream [([a], b)]))
-> Stream [([a], b)] -> Stream (Stream [([a], b)])
forall a b. (a -> b) -> a -> b
$ ([([a], b)] -> [([a], b)] -> [([a], b)])
-> Stream [([a], b)] -> Stream [([a], b)]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 [([a], b)] -> [([a], b)] -> [([a], b)]
forall a. [a] -> [a] -> [a]
(++) Stream [([a], b)]
xss

{- 多少効率化しようかとも思ったけど，とりあえずは本当にnaiveにやる
eqClsBy_naive cmp mx =         scanl (mergeBy cmp) (eqClsByFstNs cmp mx)

scanlx cmp [a0,a1,...] = [a0, mergeBy 
-}


{-
ncmp = 5
fcnrnd = (1+ncmp+)
-}
fcnrnd :: (a, Opt a) -> Int -> Int
fcnrnd (a
_,Opt a
opt) = Opt a -> Int -> Int
forall a. Opt a -> Int -> Int
fcnrand Opt a
opt
cnrnds :: (a, Opt a) -> [Int]
cnrnds  (a, Opt a)
tup = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((a, Opt a) -> Int -> Int
forall a a. (a, Opt a) -> Int -> Int
fcnrnd (a, Opt a)
tup) [Int
0..]
tcnrnds :: (a, Opt a) -> [Int]
tcnrnds (a, Opt a)
tup = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((a, Opt a) -> Int -> Int
forall a a. (a, Opt a) -> Int -> Int
fcnrnd (a, Opt a)
tup) [Int
1..]

-- repEqClsBy cmp = [([k]の最初の1個のみを見たときの同値類分解の代表元たち), ([k]の最初の2個のみを見たときの同値類分解の代表元たち), ([k]の最初の3個のみを見たときの同値類分解の代表元たち), ....]
repEqClsBy :: CmpBot k -> Matrix ([k],e) -> Matrix ([k],e)
repEqClsBy :: CmpBot k -> Matrix ([k], e) -> Matrix ([k], e)
repEqClsBy CmpBot k
cmp = String -> Matrix ([k], e) -> Matrix ([k], e)
forall p p. p -> p -> p
trace String
"repEqClsBy" (Matrix ([k], e) -> Matrix ([k], e))
-> (Matrix ([k], e) -> Matrix ([k], e))
-> Matrix ([k], e)
-> Matrix ([k], e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
                 ([([k], e)] -> ([k], e)) -> Matrix [([k], e)] -> Matrix ([k], e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [([k], e)] -> ([k], e)
forall a. [a] -> a
head (Matrix [([k], e)] -> Matrix ([k], e))
-> (Matrix ([k], e) -> Matrix [([k], e)])
-> Matrix ([k], e)
-> Matrix ([k], e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmpBot k -> Matrix ([k], e) -> Matrix [([k], e)]
forall a b. CmpBot a -> Matrix ([a], b) -> Matrix [([a], b)]
eqClsBy CmpBot k
cmp
-- eqClsByの結果の深さn番目には，[k]の最初のn個をcmpで比較したときの同値関係による同値類分解が入っている．
-- x 深さ1でサイズ1なやつらを同値類分解 : 深さ1での分解結果を2文字目で同値類分解したヤツと，サイズ2のやつらを2文字分見て同値類分解したやつらをマージ : 深さ2での分解結果を3文字目で同値類分解した奴と，....
eqClsBy :: CmpBot a -> Matrix ([a],b) -> Matrix [([a],b)]
eqClsBy :: CmpBot a -> Matrix ([a], b) -> Matrix [([a], b)]
eqClsBy cb :: CmpBot a
cb@(a -> a -> Ordering
cmp,Opt ()
opt) Matrix ([a], b)
mx = Stream (Bag [([a], b)]) -> Matrix [([a], b)]
forall a. Stream (Bag a) -> Matrix a
Mx (Stream (Bag [([a], b)]) -> Matrix [([a], b)])
-> Stream (Bag [([a], b)]) -> Matrix [([a], b)]
forall a b. (a -> b) -> a -> b
$
                 (Bag [([a], b)] -> (Int, Bag [([a], b)]) -> Bag [([a], b)])
-> Bag [([a], b)]
-> [(Int, Bag [([a], b)])]
-> Stream (Bag [([a], b)])
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (\Bag [([a], b)]
xs (Int
n,Bag [([a], b)]
ys) -> (([a], b) -> ([a], b) -> Maybe Ordering)
-> Bag [([a], b)] -> Bag [([a], b)] -> Bag [([a], b)]
forall k. (k -> k -> Maybe Ordering) -> [[k]] -> [[k]] -> [[k]]
mergeBy (Int -> CmpBot a -> ([a], b) -> ([a], b) -> Maybe Ordering
forall a e.
Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
liftCompareBot Int
n CmpBot a
cb) ((a -> a -> Ordering) -> Int -> Bag [([a], b)] -> Bag [([a], b)]
forall a e.
(a -> a -> Ordering) -> Int -> [[([a], e)]] -> [[([a], e)]]
eqClsByNth a -> a -> Ordering
cmp Int
n Bag [([a], b)]
xs) Bag [([a], b)]
ys) Bag [([a], b)]
ecb0 ([(Int, Bag [([a], b)])] -> Stream (Bag [([a], b)]))
-> [(Int, Bag [([a], b)])] -> Stream (Bag [([a], b)])
forall a b. (a -> b) -> a -> b
$ [Int] -> Stream (Bag [([a], b)]) -> [(Int, Bag [([a], b)])]
forall a b. [a] -> [b] -> [(a, b)]
zip (CmpBot a -> [Int]
forall a a. (a, Opt a) -> [Int]
tcnrnds CmpBot a
cb) Stream (Bag [([a], b)])
ecbs
{- scanlの1行の代わりにこっちを使ってた．
                 let result = ecb0 : zipWith3 (\n xs ys -> mergeBy (liftCompareBot n cmp) (eqClsByNth n xs) ys) (tail cnrnds) result ecbs
                 in result
-}
    where Mx (Bag [([a], b)]
ecb0:Stream (Bag [([a], b)])
ecbs) = CmpBot a -> Matrix ([a], b) -> Matrix [([a], b)]
forall a b. CmpBot a -> Matrix ([a], b) -> Matrix [([a], b)]
eqClsByFstNs CmpBot a
cb Matrix ([a], b)
mx
-- n-2番目のequivalenceでのquotient setを元に，n-1番目のequivalenceで細分．むしろ，refineという関数を定義した方がよい?
eqClsByNth :: (a->a->Ordering) -> Int -> [[([a],e)]] -> [[([a],e)]]
eqClsByNth :: (a -> a -> Ordering) -> Int -> [[([a], e)]] -> [[([a], e)]]
eqClsByNth a -> a -> Ordering
cmp Int
n = ([([a], e)] -> [[([a], e)]]) -> [[([a], e)]] -> [[([a], e)]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([([a], e)]
-> (([a], e) -> ([a], e) -> Maybe Ordering) -> [[([a], e)]]
forall a. [a] -> (a -> a -> Maybe Ordering) -> [[a]]
/// (\ ([a]
xs,e
_) ([a]
ys,e
_) -> Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ a -> a -> Ordering
cmp ([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!(Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) ([a]
ys[a] -> Int -> a
forall a. [a] -> Int -> a
!!(Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)))))

eqClsByFstNs :: CmpBot a -> Matrix ([a],b) -> Matrix [([a],b)]
eqClsByFstNs :: CmpBot a -> Matrix ([a], b) -> Matrix [([a], b)]
eqClsByFstNs CmpBot a
cmp (Mx Stream [([a], b)]
tss) = Stream (Stream [([a], b)]) -> Matrix [([a], b)]
forall a. Stream (Bag a) -> Matrix a
Mx (Stream (Stream [([a], b)]) -> Matrix [([a], b)])
-> Stream (Stream [([a], b)]) -> Matrix [([a], b)]
forall a b. (a -> b) -> a -> b
$ (Int -> [([a], b)] -> Stream [([a], b)])
-> [Int] -> Stream [([a], b)] -> Stream (Stream [([a], b)])
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [([a], b)] -> Stream [([a], b)]
forall e. Int -> [([a], e)] -> [[([a], e)]]
eqClsByFstN (CmpBot a -> [Int]
forall a a. (a, Opt a) -> [Int]
cnrnds CmpBot a
cmp) Stream [([a], b)]
tss
    where eqClsByFstN :: Int -> [([a], e)] -> [[([a], e)]]
eqClsByFstN Int
n = ([([a], e)]
-> (([a], e) -> ([a], e) -> Maybe Ordering) -> [[([a], e)]]
forall a. [a] -> (a -> a -> Maybe Ordering) -> [[a]]
/// Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
forall a e.
Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
liftCompareBot Int
n CmpBot a
cmp)

isLongEnough :: t -> [a] -> Bool
isLongEnough t
0 [a]
_      = Bool
True
isLongEnough t
_ []     = Bool
False
isLongEnough t
n (a
x:[a]
xs) = t -> [a] -> Bool
isLongEnough (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) [a]
xs

-- This used to be used as a preprocessor of sorting, but such use turned out to be no use for efficiency and make timeout-related discussion more complicated. Search filterEligibles in notes.
filterEligibles :: Int -> [([k],e)] -> [([k],e)]
#ifdef CHTO
filterEligibles :: Int -> [([k], e)] -> [([k], e)]
filterEligibles Int
n = (([k], e) -> Bool) -> [([k], e)] -> [([k], e)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> [k] -> Bool
forall t a. (Eq t, Num t) => t -> [a] -> Bool
isLongEnough Int
n ([k] -> Bool) -> (([k], e) -> [k]) -> ([k], e) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([k], e) -> [k]
forall a b. (a, b) -> a
fst)
#else
filterEligibles _ = id
#endif

mergeBy :: (k -> k -> Maybe Ordering) -> [[k]] -> [[k]] -> [[k]]
mergeBy :: (k -> k -> Maybe Ordering) -> [[k]] -> [[k]] -> [[k]]
mergeBy k -> k -> Maybe Ordering
cmp = ([k] -> [k] -> [k])
-> ([k] -> [k] -> Maybe Ordering) -> [[k]] -> [[k]] -> [[k]]
forall k.
(k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k] -> [k]
mergeWithByBot [k] -> [k] -> [k]
forall a. [a] -> [a] -> [a]
(++) (\[k]
x [k]
y -> [k] -> k
forall a. [a] -> a
head [k]
x k -> k -> Maybe Ordering
`cmp` [k] -> k
forall a. [a] -> a
head [k]
y)
-- この辺(mergeBy)のネーミングもいまいち

{-
mergeMxBy :: (k->k->Ordering) -> Int -> Matrix ([k],e) -> Matrix ([k],e) -> Matrix ([k],e)
mergeMxBy op len (Mx ~(xs:xss)) (Mx yss) = Mx (xs : zipWith3 (\i xs ys -> mergeBy (\ (ks,_) (ls,_) -> liftCmp i op ks ls) i (filterEligibles i xs) (filterEligibles i ys)) [len..] xss yss)
-- mergeはtrieにおけるunionByみたいな感じ．
mergeBy :: (k->k->Ordering) -> Int -> [k] -> [k] -> [k]
mergeBy op len xs ys = foldl (insertBy (\x y -> op x y == EQ)) xs ys
insertBy :: (k->k->Bool) -> [k] -> k -> [k]
insertBy op xs y = case filter (op y) xs of [] -> y:xs -- 先頭に逆順に加えてOKだったとは思うのだが，一応気を付ける
                                            _  -> xs
-}

sfilterDB :: CmpBot k -> DBound ([k],e) -> DBound ([k],e)
sfilterDB :: CmpBot k -> DBound ([k], e) -> DBound ([k], e)
sfilterDB CmpBot k
cmp (DB Int -> Bag (([k], e), Int)
f) = (Int -> Bag (([k], e), Int)) -> DBound ([k], e)
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag (([k], e), Int)) -> DBound ([k], e))
-> (Int -> Bag (([k], e), Int)) -> DBound ([k], e)
forall a b. (a -> b) -> a -> b
$ \Int
n -> ((([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]
mergesortWithByBot (\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 -> CmpBot k -> ([k], e) -> ([k], e) -> Maybe Ordering
forall a e.
Int -> CmpBot a -> ([a], e) -> ([a], e) -> Maybe Ordering
liftCompareBot (CmpBot k -> Int -> Int
forall a a. (a, Opt a) -> Int -> Int
fcnrnd CmpBot k
cmp Int
n) CmpBot k
cmp ([k], e)
k ([k], e)
l) (Int -> Bag (([k], e), Int)
f Int
n)
ofilterDB :: CmpBot k -> DBound (k,e) -> DBound (k,e)
ofilterDB :: CmpBot k -> DBound (k, e) -> DBound (k, e)
ofilterDB CmpBot k
cmp (DB Int -> Bag ((k, e), Int)
f) = (Int -> Bag ((k, e), Int)) -> DBound (k, e)
forall a. (Int -> Bag (a, Int)) -> DBound a
DB ((Int -> Bag ((k, e), Int)) -> DBound (k, e))
-> (Int -> Bag ((k, e), Int)) -> DBound (k, e)
forall a b. (a -> b) -> a -> b
$ \Int
n -> (((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]
mergesortWithByBot ((k, e), Int) -> ((k, e), Int) -> ((k, e), Int)
forall a b. a -> b -> a
const (\((k
k,e
_),Int
_) ((k
l,e
_),Int
_) -> CmpBot k -> k -> k -> Maybe Ordering
forall t t a2 a1. (t -> t -> a2, Opt a1) -> t -> t -> Maybe a2
cmpBot CmpBot k
cmp k
k k
l)  (Int -> Bag ((k, e), Int)
f Int
n)

ofilterRc :: CmpBot k -> Recomp (k,e) -> Recomp (k,e)
ofilterRc :: CmpBot k -> Recomp (k, e) -> Recomp (k, e)
ofilterRc CmpBot k
cmp Recomp (k, e)
rc = let sorted :: Recomp (k, e)
sorted = (Bag (k, e) -> Bag (k, e)) -> Recomp (k, e) -> Recomp (k, e)
forall (m :: * -> *) a b.
Search m =>
(Bag a -> Bag b) -> m a -> m b
mapDepth (((k, e) -> (k, e) -> (k, e))
-> ((k, e) -> (k, e) -> Maybe Ordering) -> Bag (k, e) -> Bag (k, e)
forall k. (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
mergesortWithByBot (k, e) -> (k, e) -> (k, e)
forall a b. a -> b -> a
const (k, e) -> (k, e) -> Maybe Ordering
forall b b. (k, b) -> (k, b) -> Maybe Ordering
op) Recomp (k, e)
rc
                       cumulative :: Recomp (k, e)
cumulative = (Bag (k, e) -> Bag (k, e) -> Bag (k, e))
-> Bag (k, e) -> Recomp (k, e) -> Recomp (k, e)
forall a b.
(Bag a -> Bag b -> Bag a) -> Bag a -> Recomp b -> Recomp a
scanlRc (((k, e) -> (k, e) -> (k, e))
-> ((k, e) -> (k, e) -> Maybe Ordering)
-> Bag (k, e)
-> Bag (k, e)
-> Bag (k, e)
forall k.
(k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k] -> [k]
mergeWithByBot (k, e) -> (k, e) -> (k, e)
forall a b. a -> b -> a
const (k, e) -> (k, e) -> Maybe Ordering
forall b b. (k, b) -> (k, b) -> Maybe Ordering
op) [] Recomp (k, e)
sorted
                   in (Int -> Bag (k, e) -> Bag (k, e) -> Bag (k, e))
-> Recomp (k, e) -> Recomp (k, e) -> Recomp (k, e)
forall a b c.
(Int -> Bag a -> Bag b -> Bag c)
-> Recomp a -> Recomp b -> Recomp c
zipDepth3Rc (\Int
_ -> ((k, e) -> (k, e) -> Maybe Ordering)
-> Bag (k, e) -> Bag (k, e) -> Bag (k, e)
forall a t. (a -> t -> Maybe Ordering) -> [a] -> [t] -> [a]
diffSortedByBot (k, e) -> (k, e) -> Maybe Ordering
forall b b. (k, b) -> (k, b) -> Maybe Ordering
op) Recomp (k, e)
sorted Recomp (k, e)
cumulative
    where op :: (k, b) -> (k, b) -> Maybe Ordering
op (k
k,b
_) (k
l,b
_) = CmpBot k -> k -> k -> Maybe Ordering
forall t t a2 a1. (t -> t -> a2, Opt a1) -> t -> t -> Maybe a2
cmpBot CmpBot k
cmp k
k k
l

ofilterMx :: CmpBot k -> Matrix (k,e) -> Matrix (k,e)
ofilterMx :: CmpBot k -> Matrix (k, e) -> Matrix (k, e)
ofilterMx CmpBot k
cmp (Mx Stream (Bag (k, e))
xss) = let sorted :: Stream (Bag (k, e))
sorted = (Bag (k, e) -> Bag (k, e))
-> Stream (Bag (k, e)) -> Stream (Bag (k, e))
forall a b. (a -> b) -> [a] -> [b]
map (((k, e) -> (k, e) -> (k, e))
-> ((k, e) -> (k, e) -> Maybe Ordering) -> Bag (k, e) -> Bag (k, e)
forall k. (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
mergesortWithByBot (k, e) -> (k, e) -> (k, e)
forall a b. a -> b -> a
const (k, e) -> (k, e) -> Maybe Ordering
forall b b. (k, b) -> (k, b) -> Maybe Ordering
op) Stream (Bag (k, e))
xss
                             cumulative :: Stream (Bag (k, e))
cumulative = (Bag (k, e) -> Bag (k, e) -> Bag (k, e))
-> Bag (k, e) -> Stream (Bag (k, e)) -> Stream (Bag (k, e))
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (((k, e) -> (k, e) -> (k, e))
-> ((k, e) -> (k, e) -> Maybe Ordering)
-> Bag (k, e)
-> Bag (k, e)
-> Bag (k, e)
forall k.
(k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k] -> [k]
mergeWithByBot (k, e) -> (k, e) -> (k, e)
forall a b. a -> b -> a
const (k, e) -> (k, e) -> Maybe Ordering
forall b b. (k, b) -> (k, b) -> Maybe Ordering
op) [] Stream (Bag (k, e))
sorted
                         in Stream (Bag (k, e)) -> Matrix (k, e)
forall a. Stream (Bag a) -> Matrix a
Mx (Stream (Bag (k, e)) -> Matrix (k, e))
-> Stream (Bag (k, e)) -> Matrix (k, e)
forall a b. (a -> b) -> a -> b
$ (Bag (k, e) -> Bag (k, e) -> Bag (k, e))
-> Stream (Bag (k, e))
-> Stream (Bag (k, e))
-> Stream (Bag (k, e))
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (((k, e) -> (k, e) -> Maybe Ordering)
-> Bag (k, e) -> Bag (k, e) -> Bag (k, e)
forall a t. (a -> t -> Maybe Ordering) -> [a] -> [t] -> [a]
diffSortedByBot (k, e) -> (k, e) -> Maybe Ordering
forall b b. (k, b) -> (k, b) -> Maybe Ordering
op) Stream (Bag (k, e))
sorted Stream (Bag (k, e))
cumulative
    where op :: (k, b) -> (k, b) -> Maybe Ordering
op (k
k,b
_) (k
l,b
_) = CmpBot k -> k -> k -> Maybe Ordering
forall t t a2 a1. (t -> t -> a2, Opt a1) -> t -> t -> Maybe a2
cmpBot CmpBot k
cmp k
k k
l
{- こっちの定義だと，sortedではなくcumulativeから[]:cumulativeを引くので，ちょっと非効率
ofilterMx cmp (Mx xss) = unscanlBy op $ Mx $ scanl1 (mergeWithBy const op) $ map (mergesortWithBy const op) xss
    where op (k,_) (l,_) = cmp k l
-}
{-
ofilterMx cmp (Mx xss) = unscanlBy op $ Mx $ map (map head . (/// (\x y -> Just (op x y)))) $ scanl1 (++) xss
    where op (k,_) (l,_) = cmp k l
-}
unscanlBy :: (k->k->Ordering) -> Matrix k -> Matrix k
unscanlBy :: (k -> k -> Ordering) -> Matrix k -> Matrix k
unscanlBy k -> k -> Ordering
op (Mx yss :: Stream (Bag k)
yss@(Bag k
xs:Stream (Bag k)
xss)) = Stream (Bag k) -> Matrix k
forall a. Stream (Bag a) -> Matrix a
Mx (Bag k
xs Bag k -> Stream (Bag k) -> Stream (Bag k)
forall a. a -> [a] -> [a]
: (Bag k -> Bag k -> Bag k)
-> Stream (Bag k) -> Stream (Bag k) -> Stream (Bag k)
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((k -> k -> Ordering) -> Bag k -> Bag k -> Bag k
forall a t. (a -> t -> Ordering) -> [a] -> [t] -> [a]
diffSortedBy k -> k -> Ordering
op) Stream (Bag k)
xss Stream (Bag k)
yss)

-- quotient set
(///) :: [a] -> (a->a->Maybe Ordering) -> [[a]]
[a]
ts /// :: [a] -> (a -> a -> Maybe Ordering) -> [[a]]
/// a -> a -> Maybe Ordering
cmp = ([a] -> [a] -> [a])
-> ([a] -> [a] -> Maybe Ordering) -> [[a]] -> [[a]]
forall k. (k -> k -> k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
mergesortWithByBot [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) (\[a]
x [a]
y -> [a] -> a
forall a. [a] -> a
head [a]
x a -> a -> Maybe Ordering
`cmp` [a] -> a
forall a. [a] -> a
head [a]
y) ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ (a -> [a]) -> [a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ts


#ifdef DEBUG
-- Properties

-- prop_sfilter = \x y i j hoge -> i /= j  ==>  (head $ unMx $ sfilter compare $ Mx ([([i],x),([j],y)]:hoge)) == sortBy (\k l -> compare (fst k) (fst l)) [([i],x),([j],y)::([Int],Int)]
prop_sfilter_exhaustive = \yss -> all longenough (concat yss) &&  unique (concat yss) && length yss < 6 ==> let xss = map (map (\x -> (x,()))) yss in  length (concat $ take 10 $ unMx $ sfilter (compare,Nothing) $ Mx (xss ++ repeat [])) == length (concat xss :: [([Int],())])

-- example: quickCheck (prop_sfilter 10 :: Propsf Int)
type Propsf a = [[[a]]] -> Property
prop_sfilter :: Ord a => Int -> Propsf a
prop_sfilter m = \yss -> length yss < m && all longenough (concat yss) ==> let xss = map (map (\x -> (x,()))) yss in (concat xss /// liftCompareBot m (compare,Nothing)) == (concat (take m (unMx $ sfilter (compare,Nothing) (Mx (xss ++ repeat [])))) /// liftCompareBot m (compare,Nothing))

unique [] = True
unique (x:xs) = all (/=x) xs && unique xs
longenough ks = length ks > 3+ncmp
#endif