素朴なマージソート
code:MSort.hs
msort :: Ord a => a -> a
msort = msortBy compare
msortBy :: (a -> a -> Ordering) -> a -> a
msortBy cmp = mergeAll . sequences
where
sequeces (a:b:xs)
| a cmp b == GT = b, a : sequences xs
| otherwise = a, b : sequences xs
sequences xs = xs
mergeAll x = x
mergeAll xs = mergeAll (mergePairs xs)
mergePairs (a:b:xs) = let !x = merge a b
in x : mergePairs xs
mergePairs xs = xs
merge as@(a:as') bs@(b:bs')
| a cmp b == GT = b:merge as bs'
| otherwise = a:merge as' bs
merge [] bs = bs
merge as [] = as
モナド版
code:MMSort.hs
msort :: (Monad m, Ord a) => a -> m a
msort = msortBy compareM
msortBy :: (a -> a -> m Ordering) -> a -> m a
msortBy cmp = mergeAll <=< sequences
where
sequences (a:b:xs) = bool
((a,b :) <$> sequences xs)
((b,a :) <$> sequences xs)
. (GT ==) =<< cmp a b
mergeAll = \ case
x -> pure x
xs -> mergeAll =<< mergePairs xs
mergePairs = \ case
a:b:xs -> merge a b >>= \ x -> (x :) <$> mergePairs xs
xs -> pure xs
merge as@(a:as') bs@(b:bs')
= bool ((a :) <$> merge as' bs)
((b :) <$> merge as bs')
. (GT ==) =<< cmp a b
merge [] bs = pure bs
merge as [] = pure as