「人材獲得作戦・４ 試験問題ほか」を解こうとしている（帰ってきた・未完）

ちょっと間をあけてしまったけれど d:id:i_k_b:20100117:1263720610 の続き。
昨日の朝、電車の中でロジックを考えたコード:

import Control.Monad
import Data.List

type Depth     = Int
type Cordinate = (Int, Int)
type Position  = (Depth, Cordinate)
type Board     = [String]
type State     = (Position, Board)

main :: IO ()
main = do
  input <- fmap lines getContents
  let answer = solve [] $ (next.from) input
  putStrLn $ unlines $ map unlines $ take 10 answer

solve :: [Position] -> [State] -> [Board]
solve _ [] = mzero
solve vs ((p@(d,c),b):queue)
  | on 'G'                       = return b `mplus` solve vs queue
  | on ' ' && null eq            = solve (p:vs)  (queue ++ (next.modify) (p,b))
  | on ' ' && (fst.head) eq <= d = solve (p:neq) (queue ++ (next.modify) (p,b))
  | otherwise                    = solve vs queue
 where on       = (== b!!snd c!!fst c)
       (eq,neq) = partition ((== c).snd) vs

next :: State -> [State]
next ((d,(x,y)),b) = zip ns (repeat b)
  where ns = [(d+1,p) | p <- [(x,y-1),(x,y+1),(x-1,y),(x+1,y)]]

from :: Board -> State
from input = (startOf input, input)

startOf :: Board -> Position
startOf input = head [(0,(x,y)) |
  (y,cs) <- zip [0..] input, (x,c) <- zip [0..] cs, c=='S']

modify :: State -> State
modify ((d,c@(x,y)),b) = ((d,c), putAt y (putAt x '$' (b!!y)) b)
  where putAt n v vs = take n vs ++ v : drop (n+1) vs

solve　第一引数の既訪リストを、盤上の現在位置を含むもの (eq) と含まないもの (neq) で分割。 eq が空なら探索を継続、 eq が空でなくて既訪の探索深さが現在位置に至るまでの探索深さと同じか小さい (小さくなることはないはず。未確認) 場合もやはり探索を継続。一方現在位置に至るまでの探索深さが既訪のものより大きくなる場合、最短経路にはなりえないのでこの探索を放棄。
とまあ、こういった考えをごくごく素直に表現したつもり。しかしやっぱりあっさりとは帰ってこないね…。