MagicHaskeller-0.8.5: MagicHaskeller/ClassifyDM.hs

-- 
-- (c) Susumu Katayama 2009
--
module MagicHaskeller.ClassifyDM(filterDM, filterList, filterListDB, filterDMlite, 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 MagicHaskeller.MHTH(unsafeWithPTO)
import Data.IORef
#endif
import MagicHaskeller.T10(mergesortWithBy, mergesortWithByBot)
import MagicHaskeller.PriorSubsts
import MagicHaskeller.Classify(opreexecute, ofilterDB, CmpBot) -- ofilterDB ¤Ï¤³¤Ã¤Á¤ÇÄêµÁ¤µ¤ì¤Æ¤¤¤Æ¤â¤¤¤¤¤è¤¦¤Ê¤â¤Î¡¥

import MagicHaskeller.Expression

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

select :: DBound ([[Dynamic]], AnnExpr) -> DBound ([Dynamic], AnnExpr)
-- select (DB f) = DB $ \n -> map (\((xss,ae),i) -> (((xss!!n), ae),i)) $ f n
select = zipDepthDB $ \d -> map (\((xss,ae),i) -> (((xss!!d), ae),i))

spreexecuteDM :: (Dynamic->Dynamic) -> [[Dynamic]] -> AnnExpr -> ([[Dynamic]], AnnExpr)
spreexecuteDM uncurrier rnds e@(AE _ dyn) = let f = uncurrier dyn in (map ({- forceList . -} map (dynApp f)) rnds,  e)

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

forceList :: [a] -> [a]
forceList []        = []
forceList xs@(y:ys) = y `seq` forceList ys `seq` 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 cmn typ db
    = case typeToRandomsOrdDM (nrands $ opt cmn) (tcl cmn) (rt cmn) typ of
        Nothing         -> id
        Just ([], op)   -> -- fmap snd . ofilterDB op . fmap opreexecute
                           mergesortWithBy const (\(AE _ k) (AE _ l) -> op k l)
        Just (rndss,op) -> -- fmap snd . sfilterDM (nrands $ opt cmn) op . select . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss)
                           map snd .
                           mergesortWithByBot const
                                              (nthCompareBot (nrands $ opt cmn) db (op, timeout $ opt cmn)) .
                           map (\ae -> sprDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss ae db)
filterListDB ::  Common -> Type -> [AnnExpr] -> DBound [AnnExpr]
filterListDB cmn typ aes
    = DB $ \db -> [(filterList cmn typ db aes,db)]

filterDM :: Common -> Type -> DBound AnnExpr -> DBound AnnExpr
filterDM cmn typ
    = case typeToRandomsOrdDM (nrands $ opt cmn) (tcl cmn) (rt cmn) typ of
        Nothing         -> id
        Just ([], op)   -> -- fmap snd . ofilterDB op . fmap opreexecute
                           mapDepthDB $ mergesortWithBy const (\((AE _ k),_) ((AE _ l),_) -> op k l)
        Just (rndss,op) -> -- fmap snd . sfilterDM (nrands $ opt cmn) op . select . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss)
                           zipDepthDB (\d -> map (\((_dyns,ae),i) -> (ae,i)) .
                                             mergesortWithByBot (\x@(_,i) y@(_,j) -> if i<j then y else x)
                                                                (\(k,_) (l,_) -> nthCompareBot (nrands $ opt cmn) d (op, timeout $ opt cmn) k l) .
                                             map (\(ae,i) -> (sprDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss ae d, i)))
-- 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 cmn typ
    = case typeToRandomsOrdDM (nrands $ opt cmn) (tcl cmn) (rt cmn) typ of
        Nothing         -> id
        Just ([], op)   -> -- fmap snd . ofilterDB op . fmap opreexecute
                           mapDepthDB $ mergesortWithBy const (\((AE _ k),_) ((AE _ l),_) -> op k l)
        Just (rndss,op) -> -- fmap snd . sfilterDM (nrands $ opt cmn) op . select . fmap (spreexecuteDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss)
                           zipDepthDB (\d -> map (\((_dyns,ae),i) -> (ae,i)) .
                                             shrink const (\k l -> nthCompareBot (nrands $ opt cmn) d (op, timeout $ opt cmn) k l) d .
                                             map (\(ae,i) -> (sprDM (uncurryDyn (mkUncurry $ tcl cmn) typ) rndss ae i {- i, not d-}, i)))

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

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


sfilterDM :: [Int] -> CmpBot k -> DBound ([k],e) -> DBound ([k],e)
-- sfilterDM nrnds cmp (DB f) = DB $ \n -> mergesortWithByBot (\x@(_,i) y@(_,j) -> if i<j then y else x) (\(k,_) (l,_) -> nthCompareBot nrnds n cmp k l) (f n)
sfilterDM nrnds cmp = zipDepthDB $ \d -> mergesortWithByBot (\x@(_,i) y@(_,j) -> if i<j then y else x) (\(k,_) (l,_) -> nthCompareBot nrnds d cmp k 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 (mergesortWithByBot (\x@(_,i) y@(_,j) -> if i<j then y else x) (\(k,_) (l,_) -> nthCompareBot n cmp k l))
                                           (f n)
-}