http://research.preferred.jp/2011/07/intern2011_problem/

Frequency.hs

module Main where

import Control.Arrow
import Control.Monad.ST
import Debug.Trace
import System.Random

import Test.QuickCheck
import Test.QuickCheck.Gen

import qualified Data.Map as M
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV

frequencyMax :: Ord a => [a] -> a
frequencyMax xs = runST $ do
  v <- V.unsafeThaw $ V.fromList xs
  loop 0 1 v
  where
    loop h i v
      | i < MV.length v = do
        x <- MV.read v h
        y <- MV.read v i
        if (x /= y)
          then do
            MV.swap v (h + 1) i
            loop (h + 2) (i + 1) v
          else loop h (i + 1) v
      | otherwise = MV.read v (i - 1)

frequencyMax' :: Ord a => [a] -> a
frequencyMax' xs =
  fst $ M.foldrWithKey step (undefined, 0) $
  M.fromListWith (+) $ zip xs (repeat 1)
  where
    step k a (k', a')
      | a < a'    = (k', a')
      | otherwise = (k, a)

shuffle :: (Ord a, RandomGen g) => g -> [a] -> [a]
shuffle g xs = loop [] g $ V.fromList xs
  where
    delete i v =
      let (xs, ys) = V.splitAt i v
      in (V.head ys, xs V.++ V.tail ys)
    loop acc g v
      | V.null v  = acc
      | otherwise =
        let (i, g') = randomR (V.minIndex v, V.maxIndex v) g
            (x, v') = delete i v
        in loop (x:acc) g' v'

patternString :: Gen String
patternString = MkGen $ \g size ->
   let count     = (size `div` 2) + 1
       range     = ('A', 'Z')
       (xs, g')  = first (replicate count) $ randomR range g
       (ys, g'') = map fst &&& snd . last $
                   take (size - count) $
                   iterate (randomR range . snd) $ randomR range g'
   in if null ys
        then xs
        else shuffle g'' $ xs ++ ys

testFrequencyMax :: String -> Bool
testFrequencyMax xs = frequencyMax xs == frequencyMax' xs

main = do
  quickCheckWith stdArgs { maxSuccess = 1000 } $
                 forAll (sized $ \size -> resize (max size 1) patternString)
                        testFrequencyMax