Ticket #2143: sort.hs

File sort.hs, 3.1 KB (added by guest, 6 years ago)

The module running Criterion on GHC & YHC sorts

Line 
1{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables #-}
2
3import System.IO.Unsafe (unsafePerformIO)
4import Criterion.Main (defaultMain, bgroup, bench)
5import System.IO
6import System.Random
7import qualified Data.List
8
9main = do -- s <- shakespeare
10          defaultMain  [ bgroup "ascending ints" [bench "ghc" $ run' ghcSort, bench "yhc" $ run' yhcSort],
11
12                          bgroup "des" [bench "ghc" $ run'' ghcSort, bench "yhc" $ run'' yhcSort],
13                          bgroup "random" [bench "ghc" $ run''' ghcSort, bench "yhc" $ run''' yhcSort],
14                          bgroup "shakespeare" [bench "ghc" $ run'''' ghcSort, bench "yhc" $ run'''' yhcSort]
15                        ]
16
17-- run', run'', run''', run'''' ::([a] -> [a]) -> IO Bool
18run' = runOnce sortedNs
19run'' = runOnce reverseSortedNs
20run''' = runOnce randomNums
21run'''' = runOnce shakespeare
22
23-- runOnce :: ([Int] -> [Int]) -> IO Bool
24{-# NOINLINE runOnce #-}
25runOnce generator s  = putStr (if (isSorted ( s (generator (10^6::Int)))) then "T" else "False") >> return ()
26
27-- verify
28isSorted x = x == Data.List.sort x
29
30-- corpus
31sortedNs x = take x [(1::Int)..]
32reverseSortedNs = reverse . sortedNs
33
34randomNums :: Int -> [Int]
35randomNums x = take x $ randoms $ unsafePerformIO $ newStdGen
36
37shakespeare = const $ unsafePerformIO $ readFile "shaks12.txt"
38
39-- YHC functions
40yhcSort :: (Ord a) => [a] -> [a]
41yhcSort =  yhcSortBy compare
42  where
43    yhcSortBy :: (a -> a -> Ordering) -> [a] -> [a]
44    yhcSortBy cmp = mergeAll . sequences
45     where
46        sequences (a:b:xs)
47          | a `cmp` b == GT = descending b [a]  xs
48          | otherwise       = ascending  b (a:) xs
49        sequences xs = [xs]
50
51        descending a as (b:bs)
52          | a `cmp` b == GT = descending b (a:as) bs
53        descending a as bs  = (a:as): sequences bs
54
55        ascending a as (b:bs)
56          | a `cmp` b /= GT = ascending b (\ys -> as (a:ys)) bs
57        ascending a as bs   = as [a]: sequences bs
58
59        mergeAll [x] = x
60        mergeAll xs  = mergeAll (mergePairs xs)
61
62        mergePairs (a:b:xs) = merge a b: mergePairs xs
63        mergePairs xs       = xs
64
65        merge as@(a:as') bs@(b:bs')
66          | a `cmp` b == GT = b:merge as  bs'
67          | otherwise       = a:merge as' bs
68        merge [] bs         = bs
69        merge as []         = as
70
71-- GHC functions
72ghcSort :: forall a. (Ord a) => [a] -> [a]
73ghcSort l = mergesort compare l
74 where
75    mergesort :: (a -> a -> Ordering) -> [a] -> [a]
76    mergesort cmp = mergesort' cmp . map wrap
77
78    mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a]
79    mergesort' _   [] = []
80    mergesort' _   [xs] = xs
81    mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss)
82
83    merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]]
84    merge_pairs _   [] = []
85    merge_pairs _   [xs] = [xs]
86    merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss
87
88    merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
89    merge _   [] ys = ys
90    merge _   xs [] = xs
91    merge cmp (x:xs) (y:ys)
92     = case x `cmp` y of
93            GT -> y : merge cmp (x:xs)   ys
94            _  -> x : merge cmp    xs (y:ys)
95
96    wrap :: a -> [a]
97    wrap x = [x]