import Data.List
import qualified Test.QuickCheck as QC
import System.Random
import Criterion.Main
import Data.Bits
import qualified Data.Vector.Mutable as VM
import qualified Data.Vector as V
import Data.Word
import System.IO.Unsafe
import Data.Bits
lsdSort :: (Ord a, Bits a, Num a) => [a] -> [a]
lsdSort = fixSort positiveLsdSort
msdSort :: (Ord a, Bits a, Num a) => [a] -> [a]
msdSort = fixSort positiveMsdSort
-- Fix a sort that puts negative numbers at the end, like positiveLsdSort and positiveMsdSort
fixSort :: (Bits a, Ord a, Num a)=>([a]->[a]) -> [a] -> [a]
fixSort sorter list = uncurry (flip (++)) (break (< 0) (sorter list))
positiveLsdSort :: (Bits a) => [a] -> [a]
positiveLsdSort list = foldl step list [0..bitSize (head list)] where
step list bit = uncurry (++) (partition (not . flip testBit bit) list)
positiveMsdSort :: (Bits a) => [a] -> [a]
positiveMsdSort list = aux (bitSize (head list) - 1) list where
aux _ [] = []
aux (-1) list = list
aux bit list = aux (bit - 1) lower ++ aux (bit - 1) upper where
(lower, upper) = partition (not . flip testBit bit) list
msort :: Ord a =>[a] -> [a]
msort xs
| n < 2 = xs
| otherwise = merge (msort x1s) (msort x2s)
where
n = length xs
(x1s,x2s) = splitAt (n`quot`2) xs
merge xs ys = case (xs,ys) of
([], ys') -> ys'
(xs', []) -> xs'
(x:xs',y:ys') | x < y -> x : merge xs' ys
| otherwise -> y : merge xs ys'
isort :: Ord a => [a] -> [a]
isort xs = foldr insert [] xs
where
insert x [] = [x]
insert x (y:ys) = if x<y then x:y:ys
else y: insert x ys
qsort :: Ord a => [a] -> [a]
qsort [] = []
qsort [x] = [x]
qsort xs =
let
pivot = mot
(x1s,x2s,pivots) = foldl (\(ys,zs,pivots) x->
if x<pivot
then (x:ys,zs,pivots)
else if x>pivot
then (ys,x:zs,pivots)
else (ys,zs,x:pivots)) ([],[],[]) xs
in qsort x1s ++ pivots ++ qsort x2s
where
mot =
let n = length xs
(a,b,c) = (xs !! 0, (xs !! (n`quot`2)), xs !! (n-1))
in if a>b
then if a<c
then a
else if c>b
then c
else b
else if b<c
then b
else if c>a
then c
else a
rsort :: [Word32] -> [Word32]
rsort xs = unsafePerformIO $ do
let base = 16
add_bucket :: Int -> Word32 -> VM.IOVector [Word32] -> VM.IOVector [Word32]
add_bucket i n b = unsafePerformIO $ do
lst <- VM.read b i
VM.write b i (n:lst)
return b
clear b = mapM_ (\i-> VM.write b i []) [0..base-1]
bucket <- VM.replicate base [] :: IO (VM.IOVector [Word32])
let loop = return $ foldl body xs [0..7]
where
body :: [Word32] -> Word32 -> [Word32]
body nums n = unsafePerformIO $ do
v <- V.freeze (foldl disp bucket nums)
clear bucket
return $ V.foldr gather [] v
where
disp :: VM.IOVector [Word32]->Word32->VM.IOVector [Word32]
disp b val = add_bucket (fromIntegral ((val`shiftR`fromIntegral (n`shiftL`fromIntegral 2)).&.0xf)) val b
gather :: [Word32]->[Word32] -> [Word32]
gather b nums = foldl (\xs x->x:xs) nums b
loop
prop_msort :: [Word32]->Bool
prop_msort xs = msort xs == sort xs && sort xs == isort xs && sort xs == qsort xs && sort xs == rsort xs &&
lsdSort xs == sort xs && msdSort xs == sort xs
deepCheck p = QC.quickCheckWith (QC.stdArgs { QC.maxSize = 1000}) p
n :: Word32
n = 4096 * 16
tl :: [Word32]->[Word32]
tl = take (fromIntegral n)
main = do
putStrLn $ "list size " ++ show n
deepCheck prop_msort
g <- getStdGen
let rl = randomRs (0,n) g
let (s,rs) = ([(0::Word32)..],[(n-1::Word32),n-2..])
let rnd = tl rl
srt = tl s
rsrt = tl rs
defaultMain [
bgroup "msdSort" [
bench "random" $ nf msdSort rnd,
bench "sorted" $ nf msdSort srt,
bench "reverse sorted" $ nf msdSort rsrt
],
bgroup "lsdSort" [
bench "random" $ nf lsdSort rnd,
bench "sorted" $ nf lsdSort srt,
bench "reverse sorted" $ nf lsdSort rsrt
],
bgroup "qsort" [
bench "random" $ nf qsort rnd,
bench "sorted" $ nf qsort srt,
bench "reverse sorted" $ nf qsort rsrt
],
bgroup "sort" [
bench "random" $ nf sort rnd,
bench "sorted" $ nf sort srt,
bench "reverse sorted" $ nf sort rsrt
],
bgroup "msort" [
bench "random" $ nf msort rnd,
bench "sorted" $ nf msort srt,
bench "reverse sorted" $ nf msort rsrt
],{-
bgroup "isort" [
bench "random" $ nf isort rnd,
bench "sorted" $ nf isort srt,
bench "reverse sorted" $ nf isort rsrt
],-}
bgroup "rsort" [
bench "random" $ nf rsort rnd,
bench "sorted" $ nf rsort srt,
bench "reverse sorted" $ nf rsort rsrt
]
]
print $ take 10 $ rsort rnd
