Haskell Quiz/Secret Santas/Solution Anton

-- Ruby quiz 2 - Haskell solution
-- Copyright (C) 2011 Anton Pirogov
import Data.List
import Data.Function

main = do
  xs <- fmap (mix . prepare . parse) getContents
  putStr $ format xs

parse = map (\(a:b:c) -> (a,b)) . map words . lines

prepare = sortBy size . groupBy family . sortBy lastname
  where lastname = compare `on` snd
        family = (==) `on` snd
        size = compare `on` length

mix = foldl1 (\a b -> ziprest a b ++ (concat $ zipWith (\x y -> x:[y]) a b))
  where ziprest a b = let diff = length b - length a in
                        if diff /= 0
                        then drop (length b - diff) b
                        else drop (length a + diff) a

format = unlines . map (\(a,b) -> a++" "++b)

{-Explaination:
  Takes standard input, splits, sorts and groups by family,
  then it merges the families by zipping them into each other,
  starting with the small ones, always prepending the "overhanging"
  rest members to the result (as zip drops the last elements of the
  longer list). By prepending the rests its ensured that in the
  next zipping  these members get mixed up too.
-}

Because no additional shuffling of the names is done, the result for a given list is always the same and depends on the name order (as the pre-sorting does not look at the first names), so to get different results, you have to pre-shuffle the list... example usage with shuffling (assuming a unix shell):

shuf namefile | runhaskell rubyquiz2.hs