Haskell卒業!

■ [アルゴリズム]復習(時事問題) 14:56

前にやった時事問題「演習(時事問題5) - Haskell卒業! - haskell」を復習してみた。

迷路のスタートからゴールまでの探索で最短経路の１つを図示せよという問題。前よりは勉強したから、BFS、ダイクストラ、Ａ＊でも何でもできると思うけど、コストが常に１だからダイクストラとかでなくても答え出る。BFSで十分だなぁ...と。枝狩り付き(メモ)のBFSでやることにした。

何を勘違いしたのか、通った位置だけ記録すればいいのに通った順番まで記録してしまった。まぁ、いいや...

やり方はスタート地点からBFSして、一度通った位置をメモするだけ。キューには高々(N * M)要素なので、よほど広いマップでない限り大丈夫なはず。キューはSequence使うつもりが面倒なのでリストにした...

前に書いたコードは純粋だったのに、今はIOベタベタ。なんかレベルが落ちてる気がしないでもない...

数十分でできたけど、赤い人たちなら瞬殺(冗談抜きで１０分かからなそう)だなぁ...

main :: IO ()
main = do
  n : m : _ <- map read . words <$> getLine
  let r = ((1, 1), (n, m))
  buf <- replicateM n (take m <$> getLine)
      >>= newListArray r . concat :: IO (IOUArray (Int, Int) Char)
  maze <- freeze buf :: IO (UArray (Int, Int) Char)
  memo <- newArray r False :: IO (IOUArray (Int, Int) Bool)
  route <- newArray_ r :: IO (IOArray (Int, Int) (Int, Int))
  let search c = find ((== c) . (maze !)) $ range r
      Just start = search 'S'
      Just goal  = search 'G'
      neighbours (i, j) = filter ((&&) <$> inRange r <*> (/= '*') . (maze !))
                        $ [(i + 1, j), (i - 1, j), (i, j + 1), (i, j - 1)] 
      bfs (idx : queue)
        | idx == goal = return True
        | otherwise   = do
            candidates <- forM (neighbours idx) $ \idx' -> do
              checked <- readArray memo idx'
              case checked of
                True -> return []
                _    -> do
                writeArray memo idx' True
                writeArray route idx' idx
                return [idx']
            bfs (queue ++ concat candidates)
      bfs _ = return False
      printMaze = do
        let fillRoute idx
              | idx == start = return ()
              | idx == goal  = readArray route idx >>= fillRoute
              | otherwise    = do
                  idx' <- readArray route idx
                  writeArray buf idx '#'
                  fillRoute idx'
        fillRoute goal
        forM_ [1 .. n] $ \i -> do
          s <- forM [1 .. m] $ \j -> readArray buf (i, j)
          putStrLn s
  found <- bfs [start]
  if found
    then putStrLn "\nFound..." >> printMaze
    else putStrLn "\nNo routes to 'G' found..."

-- 10 10
-- **********
-- * *     G*
-- * *    ***
-- * **     *
-- * * **** *
-- * *    * *
-- *   ** * *
-- *  ***   *
-- *S********
-- **********
--
-- Found...
-- **********
-- * *   ##G*
-- * *   #***
-- * **  ###*
-- * * ****#*
-- * *####*#*
-- *###**#*#*
-- *# ***###*
-- *S********
-- **********