我们将通过三部分搜索树来解决这个问题。首先，我们将构建一个Tree 代表通过问题的路径，每个状态都有分支。我们想找到到达具有特定条件的状态的最短路径，因此我们将编写一个breadth first search 来搜索任何Tree。对于您提供的示例问题，这还不够快，因此我们将使用 transposition table 改进广度优先搜索，它会跟踪我们已经探索过的状态以避免再次探索它们。
构建一棵树
我们假设您的棋盘以Array from Data.Array 表示
import Data.Array
type Board = Array (Int, Int) Char
board :: Board
board = listArray ((1,1),(3,4)) ("AAAA" ++ "ACCB" ++ "ADEF")
Data.Array 没有提供默认的简单方法来确保我们使用! 查找值的索引实际上在Array 的范围内。为方便起见，我们将提供一个安全版本，如果值在 Array 或 Nothing 中，则返回 Just v，否则返回。
import Data.Maybe
(!?) :: Ix i => Array i a -> i -> Maybe a
a !? i = if inRange (bounds a) i then Just (a ! i) else Nothing
拼图的State 可以用机器人的position 和机器人面对的direction 的组合来表示。
data State = State {position :: (Int, Int), direction :: (Int, Int)}
deriving (Eq, Ord, Show)
direction 是一个单位向量，可以添加到position 以获得新的position。我们可以旋转方向向量left或right和moveTowards。
right :: Num a => (a, a) -> (a, a)
right (down, across) = (across, -down)
left :: Num a => (a, a) -> (a, a)
left (down, across) = (-across, down)
moveTowards :: (Num a, Num b) => (a, b) -> (a, b) -> (a, b)
moveTowards (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)
要探索棋盘，我们需要能够从一个州确定哪些棋步是合法的。为此，命名移动会很有用，因此我们将创建一个数据类型来表示可能的移动。
import Prelude hiding (Right, Left)
data Move = Left | Right | Forward | Jump
deriving (Show)
要确定棋盘上哪些动作是合法的，我们需要知道我们正在使用哪个Board 以及机器人的State。这建议使用 moves :: Board -> State -> Move 类型，但我们将在每次移动后计算新状态，以确定移动是否合法，因此为了方便起见，我们还将返回新状态。
moves :: Board -> State -> [(Move, State)]
moves board (State pos dir) =
(if inRange (bounds board) pos then [(Right, State pos (right dir)), (Left, State pos (left dir))] else []) ++
(if next == Just here then [(Forward, State nextPos dir)] else []) ++
(if next == Just (succ here) then [(Jump, State nextPos dir)] else [])
where
here = fromMaybe 'A' (board !? pos)
nextPos = moveTowards dir pos
next = board !? nextPos
如果我们在董事会，我们可以转Left 和Right；我们在板上的限制保证moves 返回的所有States 在板上都有positions。如果在nextPos、next 位置持有的值与Just here 匹配，我们可以转到Forward（如果我们不在董事会，我们假设here 是'A'）。如果next 是Just 的继任者here，我们可以Jump 对其进行处理。如果next 不在板上，则为Nothing，并且不能匹配Just here 或Just (succ here)。
到目前为止，我们只是提供了问题的描述，还没有涉及到用树来回答问题。我们将使用Data.Tree 中定义的玫瑰树Tree。
data Tree a = Node {
rootLabel :: a, -- ^ label value
subForest :: Forest a -- ^ zero or more child trees
}
type Forest a = [Tree a]
Tree a 的每个节点都包含一个值 a 和一个分支列表，每个分支都是一个 Tree a。
我们将通过moves 函数以直接的方式构建Trees 的列表。我们将使moves 的每个结果成为Node 的rootLabel，并使分支成为我们explore 新状态时得到的Trees 列表。
import Data.Tree
explore :: Board -> State -> [Tree (Move, State)]
explore board = map go . moves board
where
go (label, state) = Node (label, state) (explore board state)
此时，我们的树是无限的；没有什么能阻止机器人在原地不停地旋转。我们不能画一个，但如果我们可以limit这棵树，我们可以画出几步。
limit :: Int -> Tree a -> Tree a
limit n (Node a ts)
| n <= 0 = Node a []
| otherwise = Node a (map (limit (n-1)) ts)
当我们从左下角开始面向State (4, 1) (-1, 0) 的棋盘时，我们将只显示树的前几级。
(putStrLn .
drawForest .
map (fmap (\(m, s) -> show (m, board ! position s)) . limit 2) .
explore board $ State (4, 1) (-1, 0))
(Forward,'A')
|
+- (Right,'A')
| |
| +- (Right,'A')
| |
| `- (Left,'A')
|
+- (Left,'A')
| |
| +- (Right,'A')
| |
| `- (Left,'A')
|
`- (Forward,'A')
|
+- (Right,'A')
|
+- (Left,'A')
|
`- (Forward,'A')
广度优先搜索
广度优先搜索先探索一个级别（跨越正在搜索的“广度”）的所有可能性，然后再下降到下一个级别（进入正在搜索的“深度”）。广度优先搜索找到到达目标的最短路径。对于我们的树，这意味着在探索内层中的任何内容之前先探索一层的所有内容。我们将通过创建一个节点队列来探索将我们在下一层中发现的节点添加到队列的末尾来实现这一点。队列将始终保存当前层的节点，然后是下一层的节点。它永远不会保存上一层的任何节点，因为在我们移动到下一层之前我们不会发现这些节点。
为了实现它，我们需要一个高效的队列，所以我们将使用sequence from Data.Sequence/
import Data.Sequence (viewl, ViewL (..), (><))
import qualified Data.Sequence as Seq
我们从要探索的节点的空队列Seq.empty 和进入Trees 的空路径[] 开始。我们用><（序列的串联）和go将初始可能性添加到queue的末尾。我们看queue 的开头。如果什么都没有，EmptyL，我们没有找到通往目标的路径并返回Nothing。如果那里有东西，并且它与目标 p 匹配，我们返回我们向后累积的路径。如果队列中的第一件事与目标不匹配，我们将其添加为路径的最新部分，并将其所有分支添加到 queued 的其余部分。
breadthFirstSearch :: (a -> Bool) -> [Tree a] -> Maybe [a]
breadthFirstSearch p = combine Seq.empty []
where
combine queue ancestors branches =
go (queue >< (Seq.fromList . map ((,) ancestors) $ branches))
go queue =
case viewl queue of
EmptyL -> Nothing
(ancestors, Node a bs) :< queued ->
if p a
then Just . reverse $ a:ancestors
else combine queued (a:ancestors) bs
这让我们可以为Boards 编写我们的第一个solve。这里方便的是moves返回的所有位置都在板上。
solve :: Char -> Board -> State -> Maybe [Move]
solve goal board = fmap (map fst) . breadthFirstSearch ((== goal) . (board !) . position . snd) . explore board
如果我们为我们的电路板运行它，它永远不会完成！好吧，最终它会，但我的餐巾纸计算表明它需要大约 4000 万步。通往迷宫尽头的路径有 16 步长，机器人经常会出现 3 个选项，说明每一步要做什么。
> solve 'F' board (State (4, 1) (-1, 0))
我们可以解决更小的难题，例如
AB
AC
*
我们可以用它来代表这个谜题的棋盘
smallBoard :: Board
smallBoard = listArray ((1,1),(2,2)) ("AB" ++ "AC")
我们 solve 它在寻找 'C' 从行开始 3 列 1 寻找编号较低的行。
> solve 'C' smallBoard (State (3, 1) (-1, 0))
Just [Forward,Forward,Right,Jump,Right,Jump]
转置表
当然，这个问题肯定比探索 4000 万条可能的路径更容易解决。大多数这些路径包括在原地旋转或随机地来回蜿蜒。退化路径都共享一个属性，它们不断访问它们已经访问过的状态。在breadthFirstSeach 代码中，这些路径不断将相同的节点添加到队列中。只需记住我们已经看到的节点，我们就可以摆脱所有这些额外的工作。
我们会记住我们已经用Set from Data.Set 看到的一组节点。
import qualified Data.Set as Set
在breadthFirstSearch 的签名中，我们将添加一个从节点标签到该节点分支表示的函数。只要节点外的所有分支都相同，则表示应该相等。为了快速将O(log n) 时间的表示与Set 进行比较，我们要求表示具有Ord 实例，而不仅仅是相等。 Ord 实例允许Set 检查binary search 的成员资格。
breadthFirstSearchUnseen:: Ord r => (a -> r) -> (a -> Bool) -> [Tree a] -> Maybe [a]
除了跟踪queue，breadthFirstSearchUnseen 还跟踪从Set.empty 开始的seen 的表示集。每次我们使用combine 将分支添加到queue 时，我们也会将表示添加到seen。我们只添加 unseen 分支，其表示不在我们已经 seen 的分支集中。
breadthFirstSearchUnseen repr p = combine Set.empty Seq.empty []
where
combine seen queued ancestors unseen =
go
(seen `Set.union` (Set.fromList . map (repr . rootLabel) $ unseen))
(queued >< (Seq.fromList . map ((,) ancestors ) $ unseen))
go seen queue =
case viewl queue of
EmptyL -> Nothing
(ancestors, Node a bs) :< queued ->
if p a
then Just . reverse $ ancestors'
else combine seen queued ancestors' unseen
where
ancestors' = a:ancestors
unseen = filter (flip Set.notMember seen . repr . rootLabel) bs
现在我们可以改进我们的solve 函数以使用breadthFirstSearchUnseen。一个节点的所有分支都由State 确定——到达该状态的Move 标签是无关紧要的——所以我们只使用(Move, State) 元组的snd 部分作为节点的表示。
solve :: Char -> Board -> State -> Maybe [Move]
solve goal board = fmap (map fst) . breadthFirstSearchUnseen snd ((== goal) . (board !) . position . snd) . explore board
我们现在可以非常快地solve原始拼图。
> solve 'F' board (State (4, 1) (-1, 0))
Just [Forward,Forward,Forward,Right,Forward,Forward,Forward,Right,Jump,Right,Jump,Forward,Left,Jump,Left,Jump,Jump]