Benchmark of Rope Intranet counting function

Rope Intranet benchmark

-- | This program benchmarks different versions of the counting function for
-- the Rope Intranet problem for Google Code Jam 
-- http://code.google.com/codejam/contest/dashboard?c=619102#.
--
-- To compile:
-- >>> ghc -O2 --make bench.hs
--
-- To run (Windows):
-- >>> Bench

module Main where

--import Prelude hiding (init, (++), filter, length, foldr, take, zip, sum, map)
--import Data.List.Stream
import Data.List
import System.Random
import Criterion.Main

-- | This is how I would like to write the check for crossed pairs. I find it
-- clearly expresses what it does and it uses the pairs function we wrote in
-- the first session, unchanged.
--
-- It is easily fast enough for the Code Jam large data set. Using the List
-- Stream module as a replacement for the standard list allows more fusion
-- resulting in a 30% speed improvement.
elegant :: [(Int, Int)] -> Int
elegant = length . filter crossed . pairs

crossed :: ((Int, Int), (Int, Int)) -> Bool
crossed ((l1, r1), (l2, r2)) =
    (l1 < l2) /= (r1 < r2)
    
pairs :: [a] -> [(a, a)]
pairs xs = [(x,y) | (x:ys) <- tails xs, y <- ys]

-- This optimised pairs implementation doesn't seem to be any faster.

--pairs :: [a] -> [(a, a)]
--pairs = foldr pair [] . init . tails
--    where
--      pair (x:xs) ps = foldr ((:) . (,) x) ps xs

-- | This version was hand optimized to be fast. We could also replace the
-- folds with recursion, but it makes almost no difference. I tried
-- explicitly using unboxed ints, but the optimizer already does this for us, 
-- so we gain nothing. 
--
-- It is not very clear what this version does, but it is about 3 times faster
-- than the elegant solution above.
handCoded :: [(Int, Int)] -> Int
handCoded = foldl' handCoded' 0 . init . tails
    where
      handCoded' a ((l1, r1):xs) = foldl' test a xs
        where
          test a (l2, r2)
            | (l1 < l2) /= (r1 < r2) = a + 1
            | otherwise              = a

-- | By combining all the steps into a single list comprehension, we get a
-- function that is easy to follow, if not very descriptive.
--
-- This is only 50% slower than the hand coded version.
compromise :: [(Int, Int)] -> Int
compromise xs = length [ ()
                       | ((l1,r1):ys) <- tails xs
                       , (l2,r2)      <- ys
                       , (l1 < l2) /= (r1 < r2)
                       ]

-- | This version shows that choosing an efficient algorithm is more important
-- than micro-optimizing code. At 100 pairs (with random distribution), this 
-- version performs about the same as the hand coded version and has not been 
-- optimized at all. At 1000 pairs, it is 5x faster.
--
-- I think the overall approach is clear, but the code that counts the swaps
-- could probably be clearer. It uses a modified quick sort to count the
-- number of swaps that would be required to re-sort on the right hand value,
-- rather than actually sorting. A merge sort algorithm would be better as it
-- gives O(n log(n)) worst case whereas quick sort gives O(n^2) worst case.
efficient :: [(Int, Int)] -> Int
efficient = countSwaps . map snd . sort
    where
      countSwaps []     = 0
      countSwaps (x:xs) = countSwaps less + swaps + countSwaps greater
        where
          (less, greater, swaps) = split 1 xs
          split _ [] = ([], [], 0)
          split j (x':xs') 
            | x' < x    = let (l, g, s) = split j     xs' in (x':l,    g, s + j)
            | otherwise = let (l, g, s) = split (j+1) xs' in (   l, x':g, s    )

-- | We use Criterion to benchmark the different versions. We run each function
-- multiple times with the same random test data.
main :: IO ()
main = do
    testData <- genTestData
    defaultMain
      [ bench "elegant"    $ nf elegant    testData
      , bench "hand coded" $ nf handCoded  testData
      , bench "compromise" $ nf compromise testData
      , bench "efficient"  $ nf efficient  testData
      ]

-- | Generates a list of 100 random pairs of integers.
genTestData :: IO [(Int, Int)]
genTestData = do
    as <- randomsIO
    bs <- randomsIO
    return . take 100 $ zip as bs
    
randomsIO :: Random a => IO [a]
randomsIO = newStdGen >>= return . randoms