幅優先探索(Breadth first search) で迷路を解いてみる

幅優先探索(Breadth first search)で迷路を解いてみました。
wikipedia に記述されている幅優先探索(Breadth first search)は以下の手順で探索します。

1. 根ノードを空のキューに加える。
2. ノードをキューの先頭から取り出し、以下の処理を行う。
   • ノードが探索対象であれば、探索をやめ結果を返す。
   • そうでない場合、ノードの子で未探索のものを全てキューに追加する。
3. 3. もしキューが空ならば、グラフ内の全てのノードに対して処理が行われたので、探索をやめ"not found"と結果を返す。
4. 2に戻る。

import Data.List
import qualified Data.Vector as V

-- 関数と引数を逆に記述する関数
--「F# をまねる」
-- http://d.hatena.ne.jp/kazu-yamamoto/20110218/1297992233
infixl 0 |>
(|>) :: a -> (a -> b) -> b
a |> f = f a

data Point = P {x,y::Int} deriving (Show,Eq)

toUp, toDown, toLeft, toRight :: Point -> Point
toUp    p = p{y =(y p)-1}
toDown  p = p{y =(y p)+1}
toLeft  p = p{x =(x p)-1}
toRight p = p{x =(x p)+1}

data Node  = Nil |
             Node{ point::Point, distance::Int, char ::Char,
                   up, down, left, right, parent :: Node}deriving (Show)

instance Eq Node where
 (==) x y = point x == point y

isGoal, isStart :: Node -> Bool
isGoal  node = char node == 'G'
isStart node = char node == 'S'

mazeString :: [String]
mazeString = [ "**************************" ,
              "*S* *                    *" ,
              "* * *  *  *************  *" ,
              "* *   *    ************  *" ,
              "*    *                   *" ,
              "************** ***********" ,
              "*                        *" ,
              "** ***********************" ,
              "*      *              G  *" ,
              "*  *      *********** *  *" ,
              "*    *        ******* *  *" ,
              "*       *                *" ,
              "**************************" ]

type Maze = V.Vector (V.Vector Char)

maze :: Maze
maze = V.fromList $ map V.fromList mazeString

showMaze :: Maze -> String
showMaze m = concat $ intersperse "\n" $ map V.toList $ V.toList m

xMax, yMax :: Int
xMax = (V.length (maze V.! 0)) - 1
yMax = (V.length maze) - 1

-- 二次元Vector より取得
pointChar :: Maze -> Point -> Char
pointChar maze (P x y)  = (maze V.! y) V.! x

-- 二次元Vectorへ書き込み
putCharMaze :: Char -> Maze -> Point ->  Maze
putCharMaze c maze (P x y) = maze V.// [(y , (maze V.! y) V.// [(x,c)])]

searchChar :: Char -> Maze -> Point -> Point
searchChar c maze p =
 if pointChar maze p == c
     then p
     else if y p == 0
         then if x p == 0
             then P{x=(-1),y=(-1)}
             else searchChar c maze $ toLeft p
         else if x p == 0
             then searchChar c maze p{x=xMax ,y = y (toUp p)}
             else searchChar c maze $ toLeft p

-- P {x = 1, y = 1}
start :: Point
start = searchChar 'S' maze P{x=xMax,y=yMax}

-- P {x = 22, y = 8}
goal :: Point
goal = searchChar 'G' maze P{x=xMax,y=yMax}

root = Node{ point = start, distance=0, char = 'S',
            up = Nil, down = Nil, left = Nil, right = Nil, parent =  Nil}

isOutOfMaze :: Point -> Bool
isOutOfMaze p = x p < 0 || y p< 0 || x p > xMax || y p > yMax

isChar :: Char -> Point -> Maze -> Bool
isChar c p maze = pointChar maze p == c

addNode :: Node -> Maze -> V.Vector Node -> V.Vector Node
addNode node maze queue
   | V.elem node queue         = queue
   | isOutOfMaze newPoint      = queue
   | isChar '*'  newPoint maze = queue
   | otherwise                 = V.snoc queue node
   where
       newPoint = point node

queue :: V.Vector Node
queue = V.snoc V.empty root --   1. 根ノードを空のキューに加える。

searchTree :: Maze -> V.Vector Node -> Maybe Node
searchTree maze queue =
   if V.null queue
       then Nothing --   3. もしキューが空ならば、グラフ内の全てのノードに対して処理が行われたので、
                    --      探索をやめ"not found"と結果を返す。
       else if isGoal node
                 then Just node              -- * ノードが探索対象であれば、探索をやめ結果を返す。
                 else searchTree maze queue' -- * そうでない場合、ノードの子で未探索のものを全てキューに追加

   where
       --   2. ノードをキューの先頭から取り出
       node  = V.head queue 

       --  上下左右のNodeをqueueに追加
       queue' = (V.tail queue)
                       |> addNode (setParent newNodeUp    node{up    = newNodeUp   }) maze
                       |> addNode (setParent newNodeDown  node{down  = newNodeDown }) maze
                       |> addNode (setParent newNodeLeft  node{left  = newNodeLeft }) maze
                       |> addNode (setParent newNodeRight node{right = newNodeRight}) maze

       setParent n p = n{ parent = p }
       newNodeUp     = newNode toUp
       newNodeDown   = newNode toDown
       newNodeLeft   = newNode toLeft
       newNodeRight  = newNode toRight
       newNode fMove = Node{ point = newPoint, distance = (distance node) + 1,
                             char = pointChar maze newPoint,
                             up = Nil, down = Nil, left = Nil, right = Nil,
                             parent = Nil}
           where newPoint = fMove (point node)

-- Goal Node から親をたどって '$' を記入
writeRoute :: Maze -> Node -> Maze
writeRoute maze node
    | isStart node = maze -- Start で終了
    | isGoal node  = writeRoute maze $ parent node
    | otherwise    = writeRoute (putCharMaze '$' maze $ point node) (parent node)


main :: IO ()
main = case searchTree maze queue of
    Nothing   -> putStrLn "not found"
    Just node -> putStrLn $ showMaze $ writeRoute maze node

{-
*Main> :main
**************************
*S* *$$$$                *
*$* *$ *$ *************  *
*$*$$$* $  ************  *
*$$$ *  $$$$$$$          *
**************$***********
* $$$$$$$$$$$$$          *
**$***********************
* $$$  *$$$$$$$$$$$$$$G  *
*  *$$$$$ *********** *  *
*    *        ******* *  *
*       *                *
**************************
-}