Question

我在代码审查中问了这个问题，但没有得到任何答案。我也在这里问了一个类似的问题，但我已经回过头来修改了实施。

我编写了一个BFS实现，它实现了基于tile的字段。它需要一个函数，对于可步行的瓷砖应该返回true，对于墙壁应该返回false。它还包括起点和终点。目前大约需要5秒才能找到从（0,0）到（1000,1000）的最短路径，这不是很糟糕，但实际上并不是很好。

这是我的代码：

import qualified Data.HashSet as H
import Data.Maybe (mapMaybe, isNothing)
import Data.List (foldl')

bfs :: 
    (Int -> Int -> Bool) -> -- The field function. Returns True if tile is empty, False if it's a wall
    (Int, Int) -> -- Starting position
    (Int, Int) -> -- Final position
    Int -- Minimal steps
bfs field start end = minSteps H.empty [start] 0
    where 
        minSteps visited queue steps
            |end `elem` queue = steps + 1
            |otherwise = minSteps newVisited newQueue (steps + 1)
            where
                (newVisited, newQueue) = foldl' aggr (visited, []) queue
                aggr (vis, q) node = if H.member node vis
                    then (H.insert node vis, neighbors node ++ q)
                    else (vis, q)
                neighbors (nx, ny) = filter (uncurry field) $ map (\(x, y) -> (nx + x, ny + y)) [(1, 0), (0, -1), (-1, 0), (0, 1)]

hugeField x y = x >= 0 && x <= 1000 && y >= 0 && y <= 1000

main = print $ bfs hugeField (0, 0) (1000, 1000)

这里有什么我可以提高的吗？也许采取不同的方法？

Answer 1

这是用于解决此问题的替代模式的代码转储。它创建了一个递归方案，它是concatMap，scanl和结结合的某种不圣洁的融合。它使用该递归方案来组合输出列表和节点队列以检查相同的数据结构。我想我也可以同时计算所有最短的路径，所以也是这样。

使用criterion软件包将此时间与原始软件包相比较，我发现这种方法在100x100时速度提高了40倍，并且仅在此之后得到了改善。但是，使用系统time命令进行测试表明没有真正的性能变化，大部分时间都在sys中使用，而不是user。这表明在系统级别的内存分配正在进行，我还没有考虑过。

无论遇到什么问题，我都认为你可能会对这里使用的整体方法感到满意。它所做的更改与Niklas所做的更改完全正交，因此将它们组合应该是可行的。如果你保持我投入的最短路径逻辑，请注意内存使用。

{-# LANGUAGE BangPatterns #-}

import qualified Data.HashSet as H

import Data.List
import Control.Arrow


bfs :: (Int -> Int -> Bool) ->
       (Int, Int) ->
       (Int, Int) ->
       Maybe Int
bfs field start end = lookup end . map (head &&& length) $ bfs' field start


bfs' :: (Int -> Int -> Bool) ->
        (Int, Int) ->
        [[(Int, Int)]]
bfs' field start = ouroboros visit [[start]] (H.singleton start)
  where
    visit (path@((x, y):_)) seen = (map (:path) neighbors,
                                    foldl' (flip H.insert) seen neighbors)
      where
        neighbors = filter (\n -> not (H.member n seen) && uncurry field n) $
                    map (\(dx, dy) -> (x + dx, y + dy)) diffs

    diffs = [(1, 0), (0, -1), (-1, 0), (0, 1)]


ouroboros :: (a -> b -> ([a], b)) -> [a] -> b -> [a]
ouroboros f start s0 = result
  where
    result = countAppend (go s0 result) 0 start
      where
        go _ _      0 = []
        go s (x:xs) n = case f x s of
            (ys, s') -> countAppend (go s' xs . (+ (n - 1))) 0 ys

    countAppend f = go
      where
        go !i (x:xs) = x : go (i + 1) xs
        go  i []     = f i

优化Haskell BFS实现

1 个答案: