Optimizing a Haskell BFS implementation

Question

I have asked this question in code review but didn't get any answers. I've also asked a similar question here but I've come back with a revised implementation.

I wrote a BFS implementation that walks a tile-based field. It takes a function that should return true for walkable tiles and false for walls. It also takes the start and end points. It currently takes about 5 seconds to find the shortest path from (0, 0) to (1000, 1000) which isn't bad, but it really isn't great.

Here's my code:

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)

Is there anything here that I could improve? Maybe take a different approach?

Answer 1

Here's a code dump of an alternate pattern for solving this. It creates a recursion scheme that's some sort of unholy fusion of concatMap, scanl, and knot tying. It uses that recursion scheme to combine the output list and queue of nodes to check into the same data structure. I figured I might as well calculate all shortest paths at the same time, so that's thrown in, too.

Using the criterion package to time this vs your original, I found this approach was 40x faster at 100x100, and only improved past that. However, testing with the system time command showed no real performance change, with most of the time used in sys, rather than user. This suggests something is going on with memory allocation at the system level that I haven't looked into.

Regardless of that problem, I thought you might be entertained by the overall approach in use here. The changes it makes are completely orthogonal to the changes Niklas makes, so combining them should be feasible. Just watch out for memory use if you keep the shortest paths logic I threw in.

{-# 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