Haskell - 使用树计算最短路径

时间：2014-12-31 04:59:15

标签： haskell graph path-finding

我正在尝试在haskell中编写代码，从A点到F点，在棋盘游戏中，本质上是一个Matrix，遵循最短的路径。

这是董事会：

AAAA
ACCB
ADEF
*
0 0 N

机器人进入字母A，在底部（它是*），并且必须到达F，在板的底部是坐标，x = 0，y = 0，并指向北。 F坐标为（3,0）

诀窍是，它不能跳过多个字母，它可以从A到B，B到C等，它可以遍历类型的字母（A到A，B到B，等）

它只能向前移动并转弯（左，右）所以让我去F的路径将是

前进，前进，右转，前进，前进，前进，右转，跳转，右转，跳转，前进，左转，跳转，左转，前进，前进

一旦达到F，就完成了。

我想尝试这种方法，使用树

                  A
                 / \
                A   D
               / \ 
              /   \
             A     C
            / \   / \
           /   \ D   C
          A     
         / \  
        /   \ 
       A
      /
     /
    A
   / \
  B   A
 / \  
C   F

之后我只需要验证正确的路径和最短的权利吗？

问题是，我没有那么多使用树木的经验。

你会指出任何其他方式来获得最佳途径吗？

非常感谢你。

1 个答案:

答案 0 :(得分：8)

我们通过分三部分搜索树来解决这个问题。首先，我们将构建一个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的范围内。为方便起见，我们会提供一个安全版本，如果值在Just v或Array，则返回Nothing。

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;我们在董事会上的限制保证State返回的所有moves都有position s在董事会上。如果nextPos，next位置的值与Just here的值相匹配，我们就可以Forward到它（如果我们离开董事会，我们会假设什么here是'A'）。如果next是Just here的继承者，我们可以Jump。next如果Nothing不在Just here，则为Just (succ here)且无法与Tree或data Tree a = Node { rootLabel :: a, -- ^ label value subForest :: Forest a -- ^ zero or more child trees } type Forest a = [Tree a] 匹配。

到目前为止，我们刚刚提供了问题的描述，并没有触及用树回答问题。我们将使用Data.Tree中定义的玫瑰树Tree a。

a

Tree a的每个节点都包含一个值Tree和一个分支列表，每个分支都是moves。

我们将从moves函数以简单的方式构建rootLabel列表。我们将Node Tree explore的{​​{1}}的每个结果生成，并将分支设为我们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')

当我们从import Data.Sequence (viewl, ViewL (..), (><)) import qualified Data.Sequence as Seq 的左下角开始朝向棋盘时，我们只会显示树的前几层。

Seq.empty

广度优先搜索

广度优先搜索在下降到下一个级别（进入＆＃34;深度＆＃34;是什么）之前，在一个级别（跨越＆＃34;广度＆＃34;正在搜索的内容）中探索所有可能性。被搜查）。广度优先搜索找到目标的最短路径。对于我们的树，这意味着在探索内层中的任何内容之前，在一层探索所有内容。我们通过创建节点队列来探索将我们在下一层中发现的节点添加到队列末尾来实现这一目标。队列将始终保留当前层的节点，后跟下一层的节点。它永远不会保留层中的任何节点，因为在我们移动到下一层之前，我们不会发现这些节点。

为了实现这一点，我们需要一个有效的队列，因此我们将使用sequence from Data.Sequence / 

[]

我们从要探索的空节点Tree开始，到queue s的空路径><开始。我们在go 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 匹配，我们将返回我们向后累积的路径。如果队列中的第一件事与目标不匹配，我们将其添加为路径的最新部分，并将其所有分支添加到solve的剩余部分。

Board

这让我们可以为moves编写第一个solve :: Char -> Board -> State -> Maybe [Move] solve goal board = fmap (map fst) . breadthFirstSearch ((== goal) . (board !) . position . snd) . explore board 。这里很方便，从> solve 'F' board (State (4, 1) (-1, 0)) 返回的所有职位都在董事会上。

AB
AC
*

如果我们为我们的电路板运行它，它永远不会完成！好吧，最终它会，但我的餐巾纸计算表明它将需要大约4000万步。迷宫末端的路径长达16步，机器人经常会看到3个选项，可以在每个步骤中执行操作。

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] 开始寻找breadthFirstSeach，寻找较低编号的行。

import qualified Data.Set as Set

换位表

当然，这个问题必须比探索4000万条可能的路径更容易解决。大多数这些路径包括旋转到位或随机地来回蜿蜒。退化路径都共享一个属性，他们继续访问他们已经访问过的状态。在breadthFirstSearch代码中，这些路径不断向队列添加相同的节点。我们可以通过记住我们已经看过的节点来摆脱所有这些额外的工作。

我们已经记住了Set from Data.Set已经看过的节点集。

O(log n)

对于Set的签名，我们将从节点的标签添加函数到该节点的分支的表示。只要节点外的所有分支都相同，表示应该相等。为了快速比较Ord时间中的表示与Ord，我们要求表示具有Set实例而不仅仅是相等。 breadthFirstSearchUnseen:: Ord r => (a -> r) -> (a -> Bool) -> [Tree a] -> Maybe [a] 实例允许queue使用binary search检查成员身份。

breadthFirstSearchUnseen

除了跟踪seen之外，Set.empty还会跟踪queue开始的combine表示形式。每次我们使用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。节点中的所有分支都由snd确定 - 到达该状态的(Move, State)标签无关紧要 - 所以我们只使用solve :: Char -> Board -> State -> Maybe [Move] solve goal board = fmap (map fst) . breadthFirstSearchUnseen snd ((== goal) . (board !) . position . snd) . explore board 的{​​{1}}部分元组作为节点的表示。

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] 原始拼图。

{{1}}
相关问题
最新问题