work-site/content/courses/h4life/h4life-sorting.hs

170 lines
7.1 KiB
Haskell
Raw Normal View History

2018-09-22 23:40:20 +02:00
{- sorting.hs
This file contains the examples on monads to be shown in the fourth
class of the course "Haskell for Life", by Sergiu Ivanov
(sivanov@lacl.fr):
http://lacl.fr/~sivanov/doku.php?id=en:haskell_for_life
This file is meant to be read sequentially.
This file is distributed under the Creative Commons Attribution Alone
licence.-}
import Control.Parallel (par, pseq)
import Control.DeepSeq (force, NFData, deepseq)
import System.Random (getStdGen, randoms)
import System.Environment (getArgs)
import System.Clock
-- | This is an implementation of Quicksort.
--
-- We always choose the head of the list as the pivot, then we put the
-- elements smaller than the pivot in 'lesser', and those greater than
-- the pivot in 'greater'. We then sort the two lists and put them
-- together with the pivot in between.
--
-- The 'Ord' typeclass requires comparison operators (like >=) to be
-- defined for the type.
qsort :: Ord a => [a] -> [a]
qsort [] = []
qsort (pivot:rest) = lesser ++ pivot:greater
where lesser = qsort [x | x <- rest, x < pivot]
greater = qsort [y | y <- rest, y >= pivot]
-- | This is a parallel implementation of Quicksort.
--
-- We would like to have 'lesser' and 'greater' evaluated in parallel.
-- To assure that, we may feel tempted to say
--
-- lesser `par` (lesser ++ pivot:greater)
--
-- In this case the runtime will get the information that we would
-- like 'lesser' evaluated in parallel, ... and then the main thread
-- will start evaluating the arguments to '(++)', sometimes starting
-- with the very same 'lesser'! This means parallel evaluation of
-- 'lesser' will only be initiated if we get lucky and the runtime
-- starts evaluating the second argument of '(++)' before the first
-- one. In order to give 'lesser' some time to get evaluated, we
-- shall therefore also require that 'greater' be evaluated before
-- list concatenation is done, like this:
--
-- lesser `par` ( greater `pseq` (lesser ++ pivot:greater) )
--
-- Moreover, since both `par` and `pseq` are right-associative, we can
-- drop some of the parentheses:
--
-- lesser `par` greater `pseq` (lesser ++ pivot:greater)
--
-- Now, even though everything seems nice and shiny, there's still a
-- big problem: 'par' and 'pseq' only assure some very "shallow"
-- evaluation of their left argument. In the case of our sorting
-- routine this essentially means that only the first elements of
-- 'lesser' and 'greater' are actually evaluated, in parallel, while
-- the rest of the lists are evaluated when the sorted result is
-- _actually_ needed (e.g. when we want to print it); and that
-- evaluation is done sequentially. Therefore, despite our clever
-- usage of 'par' and 'pseq', the greater part of the sorting is done
-- quite sequentially.
--
-- To solve this problem, we should force deep (complete) evaluation
-- of 'lesser' and 'greater' using the aptly named 'force' function:
--
-- force lesser `par` force greater `pseq` (lesser ++ pivot:greater)
--
-- In this case we will really get our sorting executed in parallel.
--
-- We need to use the function 'force' on lists of type 'a', and thus
-- on values of type 'a' as well. The existence of the function
-- 'force' is expressed by the typeclass 'NFData'.
parQsort :: (Ord a, NFData a) => [a] -> [a]
parQsort [] = []
parQsort (pivot:rest) = force lesser
`par` force greater
`pseq` (lesser ++ pivot:greater)
where lesser = parQsort [x | x <- rest, x < pivot]
greater = parQsort [y | y <- rest, y >= pivot]
-- | Now, just for fun, let's consider the number of times we use
-- 'par': we apply it in every node of the recursion tree in
-- 'parQsort', and there more nodes in this recursion tree than there
-- elements in the array to sort! That's actually a problem, since
-- 'par' is not exactly free, even though it's not really costly
-- either.
--
-- To avoid allocating separate jobs for very small lists, we will
-- only use `par` for sorting lists longer than a certain threshold.
--
-- The symbol '@' allows us to refer to the deconstructed list. Thus,
-- when we pattern match on an argument using 'list@(x:xs)' instead of
-- just '(x:xs)', we can use 'list' to refer to the original (not
-- deconstructed) value of the parameter (i.e. to 'list = (x:xs)').
parnQsort :: (Ord a, NFData a) => Int -> [a] -> [a]
parnQsort _ [] = []
parnQsort d list@(pivot:rest) | length list >= d = lesser
`par` greater
`pseq` (lesser ++ pivot:greater)
| otherwise = lesser ++ pivot:greater
where lesser = parnQsort d [x | x <- rest, x < pivot]
greater = parnQsort d [y | y <- rest, y >= pivot]
-- | Produces a sequence of random integers of the given length.
--
-- Pseudo-random numbers are usually generating from some information
-- from the outer world, that is why we have to work within the IO
-- monad.
randomInts :: Int -> IO [Int]
randomInts n = do
gen <- getStdGen -- Get the global random number generator.
let ints = randoms gen -- Get an infinite list of random 'Int's.
return $ take n ints -- Return the first 'n' random values.
-- | Runs an IO action and then outputs the running time.
--
-- Let's look at the type signature: according to its return type,
-- this function is in the IO monad, and it returns a 'TimeSpec', a
-- type defined in 'Data.Clock' that contains two fields: one for
-- seconds and another one for nanoseconds. The only argument of this
-- function is an _unevaluated_ value (a thunk) which the function
-- will evaluate and measure the time it took. The evaluation will be
-- forced via the 'deepseq' function, and the existence of this
-- function for the type 'a' is guaranteed by requiring that it should
-- belong to the 'NFData' typeclass.
clockedRun :: NFData a => a -> IO TimeSpec
clockedRun x = do
-- We get the time from the monotonic clock: its value can never be
-- changed, so we do not risk getting biased results.
start <- getTime Monotonic
end <- x `deepseq` getTime Monotonic
return (diffTimeSpec start end)
-- | Let's test all three functions.
main :: IO ()
main = do
args <- getArgs -- Get the command line arguments.
-- If there are some arguments, treat the first one as the length of
-- the list; otherwise, use the default length: 100000 with many zeros.
let n | null args = 100000
| otherwise = read (head args)
-- Generate the random list.
putStrLn $ "Generating " ++ show n ++ " random integers."
list <- randomInts n
-- Run the sequential Quicksort and measure the time.
seqTime <- clockedRun (qsort list)
putStrLn $ "Sequential Quicksort worked in " ++ show (nsec seqTime) ++ " ns."
-- Run the first version of parallel Quicksort and measure the time.
parTime <- clockedRun (parQsort list)
putStrLn $ "Parallel Quicksort (abusive variant) worked in " ++ show (nsec parTime) ++ " ns."
-- Run the cleverer version of parallel Quicksort and measure the
-- time. Don't use 'par' for lists having less than 1000 elements.
parnTime <- clockedRun (parnQsort 1000 list)
putStrLn $ "Parallel Quicksort (cleverer variant) worked in " ++ show (nsec parnTime) ++ " ns."