日本情報オリンピック 第5回 予選 第4問目

今回も思い切り富豪化してしまった...orz
この手の問題は何かツボというか急所というかそういうのがあるのかな?

module Main (main) where

import Data.List
import System
import Control.Monad
import Control.Monad.State

type Cups = [Int]

data Ts = Ts Cups Cups Cups deriving (Show, Eq)

move :: Ts -> [Ts]
move (Ts xs ys zs) = [Ts x y zs | (x,y) <- ns] ++ [Ts xs y z | (y,z) <- ms]
  where
    ns = move' xs ys
    ms = move' ys zs

move' :: Cups -> Cups -> [(Cups,Cups)]
move' xs ys
  | xs == [] && ys == [] = [([],[])]
  | xs == []             = [([y], reverse rys)]
  | ys == []             = [(reverse rxs, [x])]
  | otherwise            = case compare x y of 
                             LT -> [(xs ++ [y], reverse rys)]
                             EQ -> [(xs ++ [y], reverse rys),(reverse rxs, ys ++ [x])]
                             GT -> [(reverse rxs, ys ++ [x])]
  where
    (x:rxs) = reverse xs
    (y:rys) = reverse ys

moveN :: Int -> Ts -> [Bool]
moveN n ts = evalState (sequence (replicate (n + 1) moveS)) [ts]

moveS :: State [Ts] Bool
moveS = do
    tss <- get
    result <- return $ filter ((==) False . flip elem tss) $ nub $ concatMap move tss
    if or $ map match result
        then return True
        else put result >> return False

execute :: Int -> Ts -> Int
execute n ts
  | match ts  = 0
  | n == 0    = -1
  | otherwise = count 0 $ moveN n ts

match (Ts _ [] []) = True
match (Ts [] [] _) = True
match otherwise    = False

count n [] = -1
count n (x:xs)
  | x == True = n + 1
  | otherwise = count (n + 1) xs

main :: IO ()
main = do
    (inputFile:_) <- getArgs
    ls <- liftM lines $ readFile inputFile
    let
        limit = read $ last $ words $ head ls
        trays = makeTs $ map (map read . tail . words) $ tail ls
        result = execute limit trays
    writeFile "output.txt" $ show result
  where
    makeTs (x:y:z:_) = Ts x y z