# Solve a maze in the form of a 2D array using BFS - Haskell

Suggestions for improving coding style are greatly appreciated.

import qualified Data.List as L
import qualified Data.Map.Strict as M
import qualified Data.Vector as V

type Queue a = ([a], [a])

emptyQueue = ([], [])

pushListToAnother fromLst toLst = L.foldl' (\ys x -> (x:ys)) toLst fromLst

enqueue :: Queue a -> a -> Queue a
enqueue (inList, outList) x = ((x:inList), outList)

dequeue :: Queue a -> Maybe (a, Queue a)
dequeue (inList, outList) = case outList of
(y:ys) -> Just (y, (inList, ys))
[]     -> if (null inList) then Nothing else dequeue ([], reverse inList)

massEnqueue :: Queue a -> [a] -> Queue a
massEnqueue (inList, outList) items = ((pushListToAnother items inList), outList)

-- consider moving the above Queue code into a separate module.

type Grid a = V.Vector (V.Vector a)
type Indices = (Int, Int)

access grid (x, y) =  (grid V.! x) V.! y

massInsert :: Ord k => [(k, v)] -> M.Map k v -> M.Map k v
massInsert elems theMap = L.foldl' (\m (k, v) -> M.insert k v m) theMap elems

validAndTraversable :: (a -> Bool) -> Grid a -> Indices -> Bool
validAndTraversable traversability grid xy@(x, y) = let xbound = V.length grid in
let ybound = V.length (V.head grid) in
let withinBounds = (x >= 0) && (x < xbound) && (y >= 0) && (y < ybound) in
withinBounds && (traversability (access grid xy))

getPath :: Ord a => M.Map a a -> a -> a -> [a]
getPath visitedFromMap start current = pathHelper visitedFromMap start current []
where pathHelper prevIndicesMap start current path = let newPath = (current:path) in
if current == start
then newPath
else case (M.lookup current prevIndicesMap) of
Nothing -> []
Just e -> (pathHelper prevIndicesMap start e) $! newPath mazeSolverLoop :: Indices -> (Indices -> a -> Bool) -> (a -> Bool) -> Grid a -> Queue Indices -> M.Map Indices Indices -> [Indices] mazeSolverLoop start isFinish traversability mazeGrid queue visitedFromMap = let item = dequeue queue in case item of Nothing -> [] Just (currentXY, rest) -> if isFinish currentXY (access mazeGrid currentXY) then getPath visitedFromMap start currentXY else let (x, y) = currentXY in let potentialNeighbors = [(x+1, y), (x, y+1), (x-1, y), (x, y-1)] in let isVisitable = \xy -> (validAndTraversable traversability mazeGrid xy) && (M.notMember xy visitedFromMap) in let unvisitedNeighbors = filter isVisitable potentialNeighbors in let newVisitedFromMap = massInsert (map (\xy -> (xy, currentXY)) unvisitedNeighbors) visitedFromMap in let newQueue = massEnqueue rest unvisitedNeighbors in (mazeSolverLoop start isFinish traversability mazeGrid newQueue)$! newVisitedFromMap

-- the solving functions

findUnknownFinish :: Indices -> (Indices -> a -> Bool) -> (a -> Bool) -> Grid a -> [Indices]
findUnknownFinish start isFinish traversability grid = let validityPredicate = validAndTraversable traversability grid in
if validityPredicate start
then let m = M.singleton start start in
let q = enqueue emptyQueue start in
mazeSolverLoop start isFinish traversability grid q m
else []

findKnownFinish :: Indices -> Indices -> (a -> Bool) -> Grid a -> [Indices]
findKnownFinish start finish traversability grid = let isFinish = (\xy _ -> xy == finish) in
findUnknownFinish start isFinish traversability grid

escapeMaze :: Indices -> (a -> Bool) -> Grid a -> [Indices]
escapeMaze start traversability grid = let isOnBounds = \b x -> (x == 0) || (x == (b-1)) in
let xbound = V.length grid in
let ybound = V.length (V.head grid) in
let isFinish = \(x, y) _ -> (isOnBounds xbound x) || (isOnBounds ybound y) in
findUnknownFinish start isFinish traversability grid

escapeMazeV2 :: Indices -> (a -> Bool) -> Grid a -> [Indices]
escapeMazeV2 start traversability grid = let isOnBounds = \b x -> (x == 0) || (x == (b-1)) in
let xbound = V.length grid in
let ybound = V.length (V.head grid) in
let isFinish = \(x, y) _ -> (isOnBounds xbound x) || (isOnBounds ybound y) in
let acceptableFinish = \xy a -> (isFinish xy a) && (xy /= start) in
findUnknownFinish start acceptableFinish traversability grid

maze1 = V.fromList [(V.fromList [1,1,1,1,1,1,0]),
(V.fromList [0,0,0,0,0,0,0]),
(V.fromList [1,1,1,1,1,1,0]),
(V.fromList [0,0,0,0,0,0,0]),
(V.fromList [0,1,1,1,1,1,1]),
(V.fromList [0,0,0,0,0,0,0]),
(V.fromList [1,1,1,0,1,1,1]),
(V.fromList [0,0,0,0,0,0,0]),
(V.fromList [0,1,1,1,1,1,0])]

show_solve_maze1 = let solve_maze1 = findKnownFinish (1,0) (8,6) (\a -> a == 0) maze1 in
mapM_ (putStrLn.show) solve_maze1

maze2 = V.fromList (map V.fromList ["xxxxxxxxxxxxxxxxxxxxx",
"x            x      x",
"xx xxxx xxxxxx xxx  x",
"x   x   x      x xx x",
"x xxxxx xxxxxxxx  x x",
"x x              xx x",
"xxxxxx  xxxxx xxxx  x",
"x    xxxx   x x     x",
"x xx  x x x x x x xxx",
"x  xx x   x x x x   x",
"xx  x x x xxx xxx xxx",
"x  xx   x           x",
"xxxx  x xxxxxx xxxx x",
"x    xx x x    x    x",
"xxxxxx  x x xxxxx xxx",
"x      xx x     x x x",
"xxx x xx  xxx xxx x x",
"x x x       x   x   x",
"x x xxxxxx xxxx xxx x",
"x      x           ox",
"x xxxxxxxxxxxxxxxxxxx"])

show_solve_maze2 = let solve_maze2 = findUnknownFinish (1,1) (\_ a -> a == 'o') (\a -> a /= 'x') maze2 in
mapM_ (putStrLn.show) solve_maze2

show_solve_maze2v2 = let solve_maze2 = escapeMaze (1,1) (\a -> a /= 'x') maze2 in
mapM_ (putStrLn.show) solve_maze2

maze3 = V.fromList (map V.fromList ["###########",
"#         #",
"# ##### # #",
"    #   # #",
"### # ### #",
"#     #   #",
"# # ### ###",
"# #   #    ",
"# ### # # #",
"#     #   #",
"###########"])

show_solve_maze3_v1 = let solve_maze3_v1 = escapeMazeV2 (3,0) (\a -> a /= '#') maze3 in
mapM_ (putStrLn.show) solve_maze3_v1

show_solve_maze3_v2 = let solve_maze3_v2 = escapeMazeV2 (7,10) (\a -> a /= '#') maze3 in
mapM_ (putStrLn.show) solve_maze3_v2


Some general ideas:

• Always give types to top level functions. It improves readability of your code very much.
• Unless you really need to, it's better to use existing data structures than inventing your own. Instead of using Queue, you could as well use Data.Sequence.
• Some of the Queue functions can be simplified, often using first from Control.Arrow:

pushListToAnother :: [a] -> [a] -> [a]
pushListToAnother fromLst = (reverse fromLst ++)

enqueue :: Queue a -> a -> Queue a
enqueue q x = first (x :) q

massEnqueue :: Queue a -> [a] -> Queue a
massEnqueue q items = first (pushListToAnother items) q

• Strictly adhere to having some maximum number of columns (often people use 72, 78 or 80). Code that goes too far to the right is very much unreadable.

• Instead of let f = foo in let g = bar in boo use just let f = foo ; g = bar in boo. For example:

validAndTraversable :: (a -> Bool) -> Grid a -> Indices -> Bool
validAndTraversable traversability grid xy@(x, y) =
let xbound = V.length grid
withinBounds = (x >= 0) && (x < xbound) && (y >= 0) && (y < ybound)
in withinBounds && (traversability (access grid xy))

• Prefer guards over if/then/else. Usually it leads to more concise code and it's more idiomatic. Pattern guards can be even more helpful.

getPath :: Ord a => M.Map a a -> a -> a -> [a]
getPath visitedFromMap start current =
pathHelper visitedFromMap start current []
where
pathHelper prevIndicesMap start current path
| current == start
= newPath
| Just e <- M.lookup current prevIndicesMap
= (pathHelper prevIndicesMap start e) $! newPath | otherwise = [] where newPath = (current:path)  • Avoid code repetition, for example multiple calls to the same function, if you can factor the call out: maze1 = V.fromList . map V.fromList$
[ [1,1,1,1,1,1,0]
, [0,0,0,0,0,0,0]
, [1,1,1,1,1,1,0]
, [0,0,0,0,0,0,0]
, [0,1,1,1,1,1,1]
, [0,0,0,0,0,0,0]
, [1,1,1,0,1,1,1]
, [0,0,0,0,0,0,0]
, [0,1,1,1,1,1,0]
]

• Use hlint, it'll give you a lot of useful hints.

• I will definitely check out Control.Arrow and Pattern Guards. (I only have a basic understanding of monads and have yet to learn about arrows.) Thanks! Commented Feb 15, 2014 at 21:02
• @dxh For using first you don't need to know anything about arrows. The point is that -> is also an instance of Arrow, and so if first is specialized to -> we get (b -> c) -> ((b, d) -> (c, d)). That is, it uses a function to act on the first part of a tuple.
– Petr
Commented Feb 15, 2014 at 21:07
• We've been looking for a Haskell guru to join our chat room for some time now, and it looks like you would be a good fit. :) Commented Feb 15, 2014 at 22:26