2008 の Round2 の D (Google Code Jam 2008)

やってみた，というか書いてみた．
遅いなー

import Data.List
import Data.Array
import Control.Monad
import Text.Printf
import Data.Bits

main = do
  (n:_) <- getList :: IO [Int]
  forM_ [1..n] $ \i -> do
         (k:_) <- getList
         cs <- getLine
         printf "Case #%d: %d\n" i (minArray k cs)

split :: Int -> [a] -> [[a]]
split k xs = takeWhile (not.null).map (take k).iterate (drop k) $ xs

cost, lastCost :: (Eq a) => [[a]] -> Int -> Int -> Int
cost ccs p q = length.filter (uncurry (/=)) $ zip ps qs
    where ps = map (!!p) ccs
          qs = map (!!q) ccs
lastCost ccs p q = length.filter (uncurry (/=)) $ zip ps qs
    where ps = map (!!p) ccs
          qs = map (!!q) $ tail ccs

minArray :: (Eq a) => Int -> [a] -> Int
minArray k cs = succ.minimum $ [size i j| i <- [0..k-1], j <- [0..k-1], i /= j]
    where ccs = split k cs
          fill = (2::Int) ^ k - 1
          costA = fArray (uncurry $ cost ccs) ((0,0),(k-1,k-1))
          size s t = sA ! (fill, t) + lastCost ccs s t
              where sA = fArray spart ((0,0),(fill,k-1))
                    spart (u,v) | null ws   = costA!(s, v)
                                | otherwise = minimum [sA!(clearBit u w, w) + costA !(w, v) | w <- ws]
                                where ws = filter (testBit u) $ delete s [0..k-1]

fArray :: (Ix i) => (i -> b) -> (i, i) -> Array i b
fArray f (l,u) = listArray (l,u).map f.range $ (l,u)

getList :: Read a => IO [a]
getList = liftM (map read.words) getLine

うーん，これは書きかたが悪いのか，それとも，Haskellだから遅いのか．
どっちでも，困るなー．

ちなみに，MemoTrieだと遅すぎた．

計算量は O(2^k * k ^2)ぐらいなはず，なんだが． k <= 16だから，10^7ぐらい．
トラクタブルなはずだが，遅い．