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

haskell

人材獲得作戦・４ 試験問題ほか: 人生を書き換える者すらいた。 を読んで、こういう探索系の問題ってまともに解けた試しがないなあ、ということでチャレンジ中。どうせだったら不慣れな haskell の能力も磨こうとしたのが間違いか、停滞中。
うすらぼんやりと、このコードだと全解を求め終わるまで処理が止まらないんじゃないかとおもっている。遅延評価の効果を得るには（見つけた解を見つけるごとに表示したり） solve がタプルでなくリストを受け取り、リストを返す関数じゃないとダメとか、そういうことがあるんじゃないかとかなんとか。どこかの haskell ウィザードが愛の手を差し伸べてくれないかなあ…。
再帰呼び出しごとにブレークして束縛変数の値を確認する方法だとか、教えてもらえないかなあ。

-- file: solver.hs
import Data.List

main = do
  cs <- getContents
  let input  = lines cs
  let answer = solve ([], [(startOf input, input)])
  putStrLn $ unlines $ head $ answer

startOf x = fst $ head $ filter (\v -> 'S' == snd v) x'  where
  x' = concatMap (\(y,cs) -> zip (zip [0..] (repeat y)) cs) (zip [0..] x)

solve (as, []) = as
solve (as, ms) = let
  strip = map snd
  ms' = nub $ move ms
  in solve (as ++ (strip $ onGoal ms'), modify $ onSpace ms')

move = concatMap (\(p,b) -> zip [up p, dn p, lt p, rt p] (repeat b))  where
  up (x,y) = (x,y-1)
  dn (x,y) = (x,y+1)
  lt (x,y) = (x-1,y)
  rt (x,y) = (x+1,y)

include b (x,y) = x >= 0 && y >= 0 && x < length (head b) && y < length b
onGoal  = filter (\((x,y),b) -> b `include` (x,y) && 'G' == b!!y!!x)
onSpace = filter (\((x,y),b) -> b `include` (x,y) && ' ' == b!!y!!x)

modify = map (\((x,y),b) -> ((x,y), putAt y (putAt x '$' (b!!y)) b))
  where putAt n v vs = take n vs ++ v : drop (n+1) vs

このコードでも小さな盤面に対しては一応、答えをだしてくれる:

$ runghc solver.hs << EOF
> ********
> *S*    *
> *   ** *
> *   *G *
> ***    *
> *   ** *
> ********
> EOF
********
*S*    *
*$  ** *
*$$$*G *
***$$$ *
*   ** *
********

これに出題された問題を食わせると、ちっとも処理が返ってこない。全解を求めようとしているんじゃないかなとおもうゆえんである。

先に進めるためのアイディアとしては solve 関数の引数に訪問済みの場所を保存しておいて move した結果から訪問済みの場所を取り除く処理を入れる、というものがある。現状の処理は solve の再帰処理により、一歩ずつ進める可能性の盤面を全探索して広げているので、以前に訪問済みの場所は自動的に最短経路の候補から外してよいといえる。
ただ、すべての最短経路を求めるという（勝手に設定した）目標が達成できなくなるから不満が残るんだよなあ。