MagicHaskeller-0.8.5: MagicHaskeller/T10.hs

-- 
-- (c) Susumu Katayama 2009
--
module MagicHaskeller.T10 where
import Control.Monad
import MagicHaskeller.CoreLang
-- import PriorSubsts
import Data.List(partition, sortBy)
import Data.Monoid

import MagicHaskeller.Types

liftList :: MonadPlus m => [a] -> m a
liftList = msum . map return


-- Was:  scan10 = mapDepth tokoro10 . scanl1 (++)
scan10 (xs:xss) = scanl (\x y -> tokoro10 (x ++ y)) (tokoro10 xs) xss

-- mergesortWithBy const cmp = map head . groupBy (\x y -> cmp x y == EQ) . sortBy cmp, except that mergesortWithBy is quicker when the domain includes lots of duplicates.
-- (If there are no duplicates, implementation with sortBy should be quicker.)
-- Implementation of mergesort by Ian Lynagh which is found in GHC distributions was useful for implementing this.
mergesortWithBy :: (k->k->k) -> (k->k->Ordering) -> [k] -> [k]
mergesortWithBy op cmp = mergesortWithByBot op (\x y -> Just (cmp x y))

mergesortWithByBot :: (k->k->k) -> (k -> k -> Maybe Ordering) -> [k] -> [k]
mergesortWithByBot op cmp = mergesortWithByBot' op cmp . map return

mergesortWithByBot' :: (k->k->k) -> (k -> k -> Maybe Ordering) -> [[k]] -> [k]
mergesortWithByBot' op cmp [] = []
mergesortWithByBot' op cmp [xs] = xs
mergesortWithByBot' op cmp xss = mergesortWithByBot' op cmp (merge_pairsBot op cmp xss)

merge_pairsBot :: (k->k->k) -> (k -> k -> Maybe Ordering) -> [[k]] -> [[k]]
merge_pairsBot op cmp []          = []
merge_pairsBot op cmp [xs]        = [xs]
merge_pairsBot op cmp (xs:ys:xss) = mergeWithByBot op cmp xs ys : merge_pairsBot op cmp xss


mergeWithBy :: (k->k->k) -> (k->k->Ordering) -> [k] -> [k] -> [k]
mergeWithBy op cmp = mergeWithByBot op (\x y -> Just (cmp x y))

-- cmp returns Nothing when the comparison causes time-out.
mergeWithByBot :: (k->k->k) -> (k -> k -> Maybe Ordering) -> [k] -> [k] -> [k]
mergeWithByBot op cmp xs     []     = xs
mergeWithByBot op cmp []     ys     = ys
mergeWithByBot op cmp (x:xs) (y:ys)
    = case x `cmp` y of
        Just GT ->        y : mergeWithByBot op cmp (x:xs)   ys
        Just EQ -> x `op` y : mergeWithByBot op cmp    xs    ys
        Just LT -> x        : mergeWithByBot op cmp    xs (y:ys)
	Nothing -> mergeWithByBot op cmp xs ys
-- Actually it is questionable if we may remove both of the expressions compared just because comparison between them fails, because only one of them might be responsible.

-- filters only emptySubst
tokoro10nil    :: Eq k => [([a],[k],i)] -> [([a],[k],i)]
tokoro10nil xs =  case partition (\ (_,k,_) -> k==[] ) xs of
                                        ([], diff) -> diff
					(same@((_,_,i):_), diff) -> (concat (map (\ (a,_,_) -> a) same), [], i) : diff
{-
-- $B$A$c$s$H7W;;$7$F$J$$$1$I!$(BO(n^2)$B$/$i$$!)(B $B$?$@!$MWAG?t(Bn$B$O>/$J$$$C$]$$$N$G$3$C$A$NJ}$,B.$$$+$b(B
tokoro10             :: Eq k => [([a],k,i)] -> [([a],k,i)]
tokoro10 []          =  []
tokoro10 ((es,k,i):xs) =  case partition (\ (_,k',_) -> k==k' ) xs of
					(same, diff) -> (es ++ concat (map (\ (a,_,_) -> a) same), k, i) : tokoro10 diff
-}
{- quicksort$B$NJQ7A(B
tokoro10             :: (Eq k, Ord k) => [([a],k,i)] -> [([a],k,i)]
tokoro10 []             = []
tokoro10 ((t@(x,k,i)):ts) = case partition3 k ts of (ls,es,gs) -> tokoro10 ls ++ (x ++ concat es, k, i) : tokoro10 gs
partition3     :: (Eq k, Ord k) => k -> [(a,k,i)] -> ([(a,k,i)],[a],[(a,k,i)])
-- {-# INLINE partition3 #-}
partition3 k ts = foldr (select3 k) ([],[],[]) ts
select3 k t@(x,k',_) (ls,es,gs) = case k' `compare` k of LT -> (t:ls,   es,   gs)
						         EQ -> (  ls, x:es,   gs)
						         GT -> (  ls,   es, t:gs)
-}

-- merge sort could be much faster.
tokoro10             :: (Monoid a, Eq k, Ord k) => [(a,k,i)] -> [(a,k,i)]
tokoro10 = mergesortWithBy (\(xs,k,i) (ys,_,_) -> (xs `mappend` ys, k, i)) (\ (_,k,_) (_,l,_) -> k `compare` l)
{- sort$B$O$7$J$$$1$I!$<B$O$3$C$A$NJ}$,8zN($,0-$$$N$G$O(B? $BD9$5$KBP$7$F(B2$B>h$N%*!<%@!<$K$J$j$=$&!%%=!<%H$9$l$P!$(BO(n log n)$B!J8eH>$O(BO(n)$B$G$9$_$=$&!K$7$+$b!$(B(\\\)$B$r;H$&$K$O%=!<%H$7$F$J$$$H$@$a!%(B
tokoro10 :: (Eq k, Ord k) => [([a],k,i)] -> [([a],k,i)]
tokoro10 ((t@(xs,k,i)):ts) = case partition (\ (_,k',_) -> k'==k) ts of (es,ns) -> (xs ++ concat (map (\ (a,_,_) -> a) es),  k,  i) : tokoro10 ns
-}

tkr10 :: [(Type,Int)] -> [(Type,[Int])]
tkr10 = mergesortWithBy (\ (k,is) (_,js) -> (k,is++js)) (\ (k,_) (l,_) -> k `compare` l) . map (\(k,i)->(k,[i]))

-- Moved from DebMT.lhs
-- ? means Maybe
[]     !? n = Nothing
(x:xs) !? 0 = Just x
(x:xs) !? n = xs !? (n-1)


-- nlambda n e = iterate Lambda e !! n$B$NJ}$,H~$7$$!)8zN($O!)(B
nlambda 0 e = e
nlambda n e = Lambda $ nlambda (n-1) e