ICPC

http://www.acm-japan.org/past-icpc/domestic2006/contest/all_ja.html の Problem D。
非常にめんどくさかった。しかも長いし汚い。

import System
import Data.Array
import Data.Maybe
import Control.Monad.State
import Text.ParserCombinators.Parsec

type Board = Array (Int, Int) Char
data Game  = Game { pos   :: (Int, Int)
                  , board :: Board
                  , ok    :: Bool
                  } deriving Show

bfs :: (a -> [b]) -> [a] -> [b]
bfs f queue = foldr (?a b -> f a ++ b) [] queue

trymax = 10
findloop queue (sizex, sizey) = 
    let findloop' queue c | c <= trymax && found = c
                          | c <= trymax = findloop' newqueue (c+1)
                          | otherwise   = -1
            where found    = any judge queue
                  newqueue = bfs step queue
    in findloop' queue 0
        where
          judge = ?game -> ok game
          step game = catMaybes [stepR,stepU,stepL,stepD]
              where
                (x,y) = pos game
                b     = board game
                stepR = go $ zip [x..sizex] (repeat y)
                stepU = go $ zip (repeat x) [y,y-1..1]
                stepL = go $ zip [x,x-1..1] (repeat y)
                stepD = go $ zip (repeat x) [y..sizey]
                go :: [(Int, Int)] -> Maybe Game
                go []  = Nothing
                go (pt:pts) | ok pt && isStop = Just go'
                            | otherwise    = Nothing
                    where
                      go' = case b!(head pt13) of
                              '3' -> game { ok=True }
                              '1' -> game { board=b//[((head pt13),'0')]
                                          , pos=move (x,y) (head pt13)
                                          }
                      pt13 = filter f pts
                      ok (x,y) = and [x>0,y>0,x<=sizex,y<=sizey,b!(x,y)/='1']
                      isStop = pt13 /= []
                      f (x,y) = (b!(x,y)=='1')||(b!(x,y)=='3')
                      move (fromx,fromy) (tox,toy)
                          | fromy==toy && tox>fromx = (tox-1,toy)
                          | fromy==toy && tox<fromx = (tox+1,toy)
                          | fromx==tox && toy>fromy = (tox,toy-1)
                          | fromx==tox && toy<fromy = (tox,toy+1)
-- parsers --
size :: Parser (Int, Int)
size = do x <- many1 digit
          spaces
          y <- many1 digit
          spaces
          return (read x, read y)
input :: Parser ((Int, Int), Array (Int, Int) Char)
input = do size <- size
           board <- many1 number
           eof
           return (size, listArray ((1,1), size) board)
    where number = do d <- digit
                      spaces
                      return d
-- main --
main :: IO ()
main = do (filepath:_) <- getArgs
          src <- readFile filepath
          case parse input "" src of
            Left _ -> putStrLn "Parse Error!"
            Right (size, board) ->
                let spos = startpos board
                    start = Game { pos = spos
                                 , board = board//[(spos,'0')]
                                 , ok = False} in
                print $ findloop [start] size
    where startpos board = fromJust $
            lookup '2' (map (?(x,y)->(y,x)) $ assocs board)