在Haskell中使用状态单子进行广度优先搜索

Question

最近，我在Stackoverflow上提出了一个有关从图中构建DFS树的问题，并学习到可以通过使用State Monad来简单实现。

Haskell中的DFS

尽管DFS仅需要跟踪已访问的节点，因此我们可以使用'Set'或'List'或某种线性数据结构来跟踪已访问的节点，但BFS需要使用“已访问节点”和“队列”数据结构才能完成。

我的BFS伪代码如下：

Q = empty queue
T = empty Tree
mark all nodes except u as unvisited
while Q is nonempty do
u = deq(Q)
    for each vertex v ∈ Adj(u)
        if v is not visited 
        then add edge (u,v) to T
             Mark v as visited and enq(v)

从伪代码中可以推断出，每次迭代只需执行3个步骤。

1. 从队列中取消排队的点
2. 将该点所有未访问的邻居添加到当前树的子节点、队列和“visited”列表中
3. 重复上述步骤直至处理完队列中的下一个点

由于我们不使用递归遍历BFS搜索，因此需要其他遍历方法，如while循环。我查阅了hackage中的loop-while包，但它似乎已经过时。

我认为我需要类似于以下代码的东西：

{-...-}
... =   evalState (bfs) ((Set.singleton start),[start])
where 
    neighbors x = Map.findWithDefault [] x adj 
    bfs =do (vis,x:queue)<-get
             map (\neighbor ->
                  if (Set.member neighbor vis)
                  then put(vis,queue) 
                  else put ((Set.insert neighbor vis), queue++[neighbor]) >> (addToTree neighbor)
                 )  neighbors x
            (vis,queue)<-get
         while (length queue > 0)

我知道这个实现非常错误，但这应该能够提供我认为BFS应该如何实现的最简视图。另外，我真的不知道如何规避使用while循环来进行块操作。(例如，我应该使用递归算法来克服它，还是应该考虑完全不同的策略)

考虑到我在上面链接的先前问题中找到的一个答案，答案似乎应该像这样：

newtype Graph a = Graph (Map.Map a [a]) deriving (Ord, Eq, Show)
data Tree a = Tree a [Tree a] deriving (Ord, Eq, Show)

bfs :: (Ord a) => Graph a -> a -> Tree a
bfs (Graph adj) start = evalState (bfs') ((Set.singleton start),[start])
    where
        bfs' = {-part where I don't know-}

最后，如果由于某种原因无法使用状态单子实现BFS（我相信不会出现这种情况），请纠正我的错误假设。

我看过一些在Haskell中实现BFS的例子，但是它们没有使用状态单子。我想了解更多关于如何处理状态单子的内容，但是找不到任何使用状态单子实现BFS的例子。

提前感谢。

---

编辑： 我想出了一种使用状态单子的算法，但却陷入了无限循环。

bfs :: (Ord a) => Graph a -> a -> Tree a
bfs (Graph adj) start = evalState (bfs' (Graph adj) start) (Set.singleton start)

bfs' :: (Ord a) => Graph a -> a -> State (Set.Set a) (Tree a)
bfs' (Graph adj) point= do
                        vis <- get
                        let neighbors x = Map.findWithDefault [] x adj
                        let addableNeighbors (x:xs) =   if Set.member x vis
                                                        then addableNeighbors(xs)
                                                        else x:addableNeighbors(xs)
                        let addVisited (vis) (ns) = Set.union (vis) $ Set.fromList ns
                        let newVisited = addVisited vis $ addableNeighbors $ neighbors point
                        put newVisited
                        return (Tree point $ map (flip evalState newVisited) (map (bfs' (Graph adj)) $ addableNeighbors $ neighbors point))

EDIT2: 通过使用图来返回和队列来处理，我想出了一种获取BFS图的解决方案。尽管它不是生成BFS树/图的最佳解决方案，但它可以工作。

bfs :: (Ord a) => Graph a -> a -> Graph a
bfs (Graph adj) start = evalState (bfs' (Graph adj) (Graph(Map.empty))  [start]) (Set.singleton start)


bfs':: (Ord a) => Graph a -> Graph a -> [a] -> State (Set.Set a) (Graph a)
bfs' _ (Graph ret) [] = return (Graph ret)
bfs' (Graph adj) (Graph ret) (p:points)= do
                                        vis <- get
                                        let neighbors x = Map.findWithDefault [] x adj
                                        let addableNeighbors ns
                                                | null ns = []
                                                | otherwise =   if Set.member (head ns) vis
                                                                then addableNeighbors(tail ns)
                                                                else (head ns):addableNeighbors(tail ns)
                                        let addVisited (v) (ns) = Set.union (v) $ Set.fromList ns
                                        let unVisited = addableNeighbors $ neighbors p
                                        let newVisited = addVisited vis unVisited
                                        let unionGraph (Graph g1) (Graph g2) = Graph (Map.union g1 g2)
                                        put newVisited
                                        bfs' (Graph adj) (unionGraph (Graph ret) (Graph (Map.singleton p unVisited))) (points ++ unVisited)

编辑3: 我添加了将图转换为树的转换函数。在编辑2和编辑3中运行该函数将产生BFS Tree。从计算时间方面来看，这不是最佳算法，但我相信对像我这样的新手来说它很直观易懂 :)

graphToTree :: (Ord a) => Graph a -> a -> Tree a
graphToTree (Graph adj) point  = Tree point $ map (graphToTree (Graph adj)) $ neighbors point
    where neighbors x = Map.findWithDefault [] x adj

- MazaYong

---

将命令式算法翻译成函数式语言最多也只能说是困难，有时甚至是不可能的。将伪代码一对一地翻译成Haskell很可能会非常丑陋。一个好的起点是一个函数 bfs' :: Ord a => Graph a -> a -> State (S.Set a) (Tree a)，它从给定节点开始执行BFS，S.Set a 是已访问节点。你不需要保留节点队列 - 在命令式环境中，这只是方便，但在这里并非如此。 - user2407038

Answer 1

将图形按广度优先转换为树状结构比仅仅按广度优先搜索图形要困难得多。如果您正在搜索图形，则只需要从单个分支返回即可。当将图形转换为树时，结果需要包括来自多个分支的结果。

我们可以使用比Graph a更通用的类型来搜索或转换为树状结构。我们可以搜索或转换任何具有函数a -> [a]的内容。对于Graph，我们将使用函数(Map.!) m，其中m是Map。使用转置表进行搜索的签名如下：

breadthFirstSearchUnseen:: Ord r => (a -> r) -> -- how to compare `a`s 
                           (a -> Bool) ->       -- where to stop
                           (a -> [a]) ->        -- where you can go from an `a`
                           [a] ->               -- where to start
                           Maybe [a]

将该函数转换为包含每个可达节点的最早深度的树具有以下签名：

shortestPathTree :: Ord r => (a -> r) -> -- how to compare `a`s
                    (a -> l)             -- what label to put in the tree
                    (a -> [a]) ->        -- where you can go from an `a`
                    a ->                 -- where to start
                    Tree l

我们可以从任意数量的节点开始，构建一个包含最早深度可达节点的森林。

shortestPathTrees :: Ord r => (a -> r) -> -- how to compare `a`s
                     (a -> l)             -- what label to put in the tree
                     (a -> [a]) ->        -- where you can go from an `a`
                     [a] ->               -- where to start
                     [Tree l]

搜索

将图转换为树并不能帮助我们进行搜索，我们可以在原始图上执行广度优先搜索。

import Data.Sequence (viewl, ViewL (..), (><))
import qualified Data.Sequence as Seq
import qualified Data.Set as Set

breadthFirstSearchUnseen:: Ord r => (a -> r) -> (a -> Bool) -> (a -> [a]) -> [a] -> Maybe [a]
breadthFirstSearchUnseen repr p expand = combine Set.empty Seq.empty []
    where
        combine seen queued ancestors unseen =
            go
                (seen  `Set.union` (Set.fromList . map repr            $ unseen))
                (queued ><         (Seq.fromList . map ((,) ancestors) $ unseen))
        go seen queue =
            case viewl queue of
                EmptyL -> Nothing
                (ancestors, a) :< 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) . expand $ a

上述搜索算法中维护的状态是要访问的节点的Seq队列和已经看到的节点的Set。如果我们改为跟踪已经访问过的节点，则在同一深度找到多条通往同一节点的路径时，可能会多次访问同一个节点。在我编写这个广度优先搜索答案中，有一个更完整的解释。

我们可以轻松地按照我们的一般搜索方法编写搜索Graph。

import qualified Data.Map as Map

newtype Graph a = Graph (Map.Map a [a]) deriving (Ord, Eq, Show)

bfsGraph :: (Ord a) => Graph a -> (a -> Bool) -> [a] -> Maybe [a]
bfsGraph (Graph adj) test = breadthFirstSearchUnseen id test ((Map.!) adj)

我们也可以编写如何搜索树本身的代码。

import Data.Tree

bfsTrees :: (Ord a) => (a -> Bool) -> [Tree a] -> Maybe [a]
bfsTrees test = fmap (map rootLabel) . breadthFirstSearchUnseen rootLabel (test . rootLabel) subForest

构建树

广度优先构建树更加困难。幸运的是，Data.Tree已经提供了从单子展开中以广度优先顺序构建Tree的方法。广度优先顺序将负责排队，我们只需要跟踪已经看到的节点的状态。

unfoldTreeM_BF的类型为Monad m => (b -> m (a, [b])) -> b -> m (Tree a)。其中，m是我们计算所在的Monad，b是我们将基于其构建树的数据类型，a是树标签的类型。为了使用它来构建一棵树，我们需要创建一个函数b -> m (a, [b])。我们将会把a重命名为标签l，把b重命名为节点a。我们需要创建一个a -> m (l, [a])。对于m，我们将使用State monad从transformers中跟踪一些状态；状态将是我们已经看到其表示r的节点的Set；我们将使用State (Set.Set r) monad。总体而言，我们需要提供一个a -> State (Set.Set r) (l, [a])函数。

expandUnseen :: Ord r => (a -> r) -> (a -> l) -> (a -> [a]) -> a -> State (Set.Set r) (l, [a])
expandUnseen repr label expand a = do
    seen <- get
    let unseen = filter (flip Set.notMember seen . repr) . uniqueBy repr . expand $ a
    put . Set.union seen . Set.fromList . map repr $ unseen
    return (label a, unseen)

为了构建树，我们运行由 unfoldForestM_BF 构建的状态计算。

shortestPathTrees :: Ord r => (a -> r) -> (a -> l) -> (a -> [a]) -> [a] -> [Tree l]
shortestPathTrees repr label expand = run . unfoldForestM_BF k . uniqueBy repr
    where
        run = flip evalState Set.empty
        k = expandUnseen repr label expand

uniqueBy 是一个利用 Ord 实例而不是 Eq 的 nubBy。

uniqueBy :: Ord r => (a -> r) -> [a] -> [a]
uniqueBy repr = go Set.empty
    where
        go seen []     = []
        go seen (x:xs) =
            if Set.member (repr x) seen
            then go seen xs
            else x:go (Set.insert (repr x) seen) xs

我们可以根据通用的最短路径树构建方法，编写关于Graph的最短路径树构建。

shortestPathsGraph :: Ord a => Graph a -> [a] -> [Tree a]
shortestPathsGraph (Graph adj) = shortestPathTrees id id ((Map.!) adj)

我们可以对过滤 Forest 以仅保留最短路径进行相同的操作。

shortestPathsTree :: Ord a => [Tree a] -> [Tree a]
shortestPathsTree = shortestPathTrees rootLabel rootLabel subForest

- Cirdec

Answer 2

我的解决方案基于逐层工作（相对于BFS），请参见此问题和答案。

总体思路是：假设我们已经知道了每个BFS级别之前访问的元素集合作为一组集合的列表。然后，我们可以逐层遍历图形，更新我们的集合列表，构建输出Tree。

诀窍在于，在这样的逐层遍历之后，我们将拥有每个级别之后访问的元素集合。这与每个级别之前的列表相同，只是向右移动了一个位置。因此，通过tying the knot，我们可以使用移位输出作为该过程的输入。

import Control.Monad.State
import qualified Data.Map as M
import Data.Maybe (fromMaybe, catMaybes)
import qualified Data.Set as S
import Data.Tree

newtype Graph a = Graph (M.Map a [a])
    deriving (Ord, Eq, Show)

tagBfs :: (Ord a) => Graph a -> a -> Maybe (Tree a)
tagBfs (Graph g) s = let (t, sets) = runState (thread s) (S.empty : sets)
                      in t
  where
    thread x = do
        sets@(s : subsets) <- get
        case M.lookup x g of
            Just vs | not (S.member x s) -> do
                -- recursively create sub-nodes and update the subsets list
                let (nodes, subsets') = runState
                                          (catMaybes `liftM` mapM thread vs) subsets
                -- put the new combined list of sets
                put (S.insert x s : subsets')
                -- .. and return the node
                return . Just $ Node x nodes
            _ -> return Nothing -- node not in the graph, or already visited

在以下示例上运行tagBfs example2 'b'

example2 :: Graph Char
example2 = Graph $ M.fromList
    [ ('a', ['b', 'c', 'd'])
    , ('b', ['a'])
    , ('c', [])
    , ('d', [])
    ]

产生

Just (Node {rootLabel = 'b',
            subForest = [Node {rootLabel = 'a',
                               subForest = [Node {rootLabel = 'c',
                                                  subForest = []},
                                            Node {rootLabel = 'd',
                                                  subForest = []}
                                           ]}
                        ]}
      )

- Petr