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

Question

最近,我已经从Stackoverflow中的Graph中提出了构建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. 将点的所有未访问的邻居添加到当前树的子节点,队列和"已访问"列表
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循环for do blocks.(即我应该使用递归算法来克服它,还是应该考虑完全不同的策略)

考虑到我在上面提到的上一个问题中找到的答案之一,似乎答案应该如下所示:

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中看到了一些不使用状态monad的BFS示例,但我想了解更多关于如何处理状态monad并且无法找到使用状态monad实现BFS的任何示例.

提前致谢.

---

编辑:我想出了一些使用状态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))

编辑2:由于空间复杂性的一些代价,我已经提出了一个解决方案,使用图表返回并排队处理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)

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

Answer 1

将图形转换为Tree广度优先比简单地搜索图宽度优先要困难一些.如果您正在搜索图表,则只需要从单个分支返回.将图形转换为树时,结果需要包含多个分支的结果.

我们可以使用比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

我们可以稍微更一般地从任意数量的节点开始,并构建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要访问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)

我们还可以编写如何自己搜索Tree.

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从monadic展开以广度优先顺序构建s的方法.广度第一顺序将负责排队,我们只需要跟踪我们已经看到的节点的状态.

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,我们将使用变形金刚的Statemonad 跟踪一些状态; 状态将是我们已经看到的代表节点; 我们将使用monad.总的来说,我们需要提供一个功能.SetrState (Set.Set r)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

我们可以Graph根据我们的一般最短路径树构建来编写构建最短路径树

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