在 Haskell 中使用 State monad 进行广度优先搜索

Breadth-First Search using State monad in Haskell

最近,我在 Whosebug 中问了一个从 Graph 构建 DFS 树的问题,了解到可以使用 State Monad 简单地实现它。

虽然 DFS 只需要跟踪访问过的节点,以便我们可以使用 'Set' 或 'List' 或某种线性数据结构来跟踪访问过的节点,但 BFS 需要 'visited node' 和'queue'待完成的数据结构。

我的 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. dequeue point from queue
  2. add all unvisited neighbors of the point to current tree's child, queue and 'visited' list
  3. repeat this for next in queue

由于我们没有使用递归遍历进行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 的简约视图。另外,我真的不知道如何规避对 do 块使用 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-}

最后,如果由于某种原因无法使用状态 monad 实现 BFS,(我相信不是)请纠正我的错误假设。

我在 Haskell 中看到了 BFS 的一些示例,但没有使用 state monad,但我想了解更多有关如何处理 state monad 的信息,但找不到任何 BFS 实施示例使用状态 monad。

提前致谢。


编辑: 我想出了某种使用状态 monad 的算法,但我陷入了无限循环。

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:在 space 复杂性的代价下,我想出了一个解决方案,使用图 return 和队列来处理来获取 BFS 图。尽管它不是生成 BFS 的最佳解决方案 tree/graph,但它会起作用。

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)

EDIT3:我添加了图到树的转换函数。 运行 函数在 EDIT2 中,EDIT3 将产生 BFS 树。它不是计算时间方面的最佳算法,但我相信它对于像我这样的新手来说是直观且易于理解的:)

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

将图转换为 Tree 广度优先比简单 searching the graph breadth-first 更难一些。如果您正在搜索图表,您只需要从单个分支 return 。图转树时,结果需要包含多个分支的结果。

对于可以搜索或转换为树的内容,我们可以使用比 Graph a 更通用的类型。我们可以使用函数 a -> [a] 搜索或转换为树任何东西。对于 Graph,我们将使用函数 (Map.!) m,其中 mMap。使用换位搜索 table 具有类似

的签名
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

我们可以更一般地从任意数量的节点开始并构建一个 Forest 包含最早深度的每个可达节点。

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 queue of what nodes to visit next and a Set of nodes that have already been seen. If we instead kept track of nodes that have already been visited, then we could visit the same node multiple times if we find multiple paths to the node at the same depth. There's a more complete explanation

我们可以根据我们的一般搜索轻松编写搜索 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)

我们也可以编写如何搜索 Tree 自己。

import Data.Tree

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

造树

广度优先构建树 a lot more difficult. Fortunately Data.Tree 已经提供了从单子展开以广度优先顺序构建 Trees 的方法。广度优先顺序将负责排队,我们只需要跟踪我们已经看到的节点的状态。

unfoldTreeM_BF has the type Monad m => (b -> m (a, [b])) -> b -> m (Tree a). m is the Monad our computations will be in, b is the type of data we are going to build the tree based on, and a is the type for the labels of the tree. In order to use it to build a tree we need to make a function b -> m (a, [b]). We're going to rename a to l for label, and b to a, which is what we've been using for our nodes. We need to make an a -> m (l, [a]). For m, we'll use the State monad from transformers 跟踪一些状态;状态将是 Set 个节点,其表示 r 我们已经看到了;我们将使用 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 是一个 nubBy,它利用 Ord 实例而不是 Eq

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

我们可以按照我们一般的最短路径树构建

编写从 Graphs 构建最短路径树
shortestPathsGraph :: Ord a => Graph a -> [a] -> [Tree a]
shortestPathsGraph (Graph adj) = shortestPathTrees id id ((Map.!) adj)

我们可以做同样的事情来过滤 Forest 以仅通过 Forest.

的最短路径
shortestPathsTree :: Ord a => [Tree a] -> [Tree a]
shortestPathsTree = shortestPathTrees rootLabel rootLabel subForest

我的解决方案基于逐级工作(wrt. to BFS),另请参见

总体思路是:假设我们已经知道在我们的 BFS 的每个级别之前访问元素的集合作为集合列表。然后我们可以逐层遍历图,更新我们的集合列表,在途中构造输出Tree

诀窍是在这样的逐级遍历之后,我们将在每个级别之后 拥有访问元素的集合。这与列表 before 每个级别相同,只是移动了一位。所以通过 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 = []}
                                           ]}
                        ]}
      )