Haskell is a really great programming language. It is elegant, the type system is beautiful, and nowadays the compiler is quite good. I’ve been using functional languages off and on for more than 30 years. I studied at the University of Kent which is the home Miranda which is a precursor to Haskell. All this is a warning. I don’t use Haskell that much. The language has changed a lot since I last used it regularly, and so my code might not be optimal or idiomatic Haskell.

On some of our programs we teach the first year students Haskell. This includes their first algorithms course where they learn such things as search trees, hash tables, and some elementary graph algorithms. Since I had to co-teach our Haskell course at rather short notice, I had to do get up to speed with Haskell again. The hard part about learning a language is getting up to sped on idioms, the standard library and what cool libraries there are out there. One thing that always seems to be true is that almost every problem can be solved with Monads.

Some algorithms do not have natural functional implementations, and Breadth first search is one such algorithm. The way it is normally described involves picking a node, enqueuing it in a queue. Find all the neighbours explore the neighbours. Keep track of all the nodes that you have visited to avoid cycles. If you implement the algorithm naively in pure Haskell then you will need implement (or use the standard implementation) the visited set as some sort of search tree. You will then incur an $O(n\log n)$ overhead. You can do various things to improve the performance: use the IO Monad or use some of the approaches to functional graphs. Here I have chosen to live with the overhead. Even so, there are some interesting challenges especially when you want to list all breadth first traversals of a graph, rather than just one.

We will assume that we have a Queue and a Graph library with suitable functions (at the end of the post, I’ll give a simple implementation of these modules).

import qualified Queue_Seq as Q
import qualified  Graph_Simple as G

G.fromEdges :: Ord a => [(a, a)] -> G.Graph a
G.neighbours :: Ord a => G.Graph a -> a -> [a]

t1 = G.fromEdges [(1,2) , (1,3) , (2,4) , (2,5),  (3,6) , (3,7) ]
t1_neighbour_fun node =
G.neighbours t1 node
Q.empty :: Q.Queue a
Q.enqueue :: Q.Queue a -> a -> Q.Queue a
Q.enqueue_fromList ::  Q.Queue a -> [a] -> Q.Queue a
Q.dequeue :: Q.dequeue :: Q.Queue a -> (a, Q.Queue a)


So now we can translate the imperative algorithm into Haskell. The state is maintained by passing it around. First the main loop:

import qualified Data.Set as S
bfs_loop :: (G.Graph Integer) ->
(Q.Queue Integer) -> (S.Set Integer) -> [Integer] -> [Integer]
bfs_loop g c_queue c_visited c_path
|  (Q.isempty c_queue)     =  c_path
|  otherwise               =
let (next_node, c_dequed) = Q.dequeue c_queue
new_neighbours = G.neighbours g next_node
in
if not (next_node S.member c_visited)
then
let
new_visited = S.insert next_node c_visited
new_path = next_node : c_path
new_queue = Q.enqueue_fromList c_dequed new_neighbours
in
bfs_loop g new_queue new_visited new_path
else
bfs_loop g c_dequed c_visited c_path


There are probably better ways of writing the code. I tend to use lots of named expressions using let or where this makes the code a bit more verbose, but you actually know what is going on. If our queue is empty then there is nothing to do. Otherwise each time around the loop we dequeue an element, check if we have seen it before. If we have not seen it before, then look at the neighbours and enqueue them.

We then wrap the code up with a driver to make it more userfriendly

bfs g start_node =
let initial_queue = Q.enqueue Q.empty start_node
initial_visited = S.empty
initial_path = []
in
reverse (bfs_loop g initial_queue initial_visited initial_path)


For example

> bfs g1 1
[1,3,2,5,6,4]


## Finding all Breadth First Paths (The Level Algorithm)

I am not sure how you would modify an imperative implementation to list all bread first paths. Essentially you want some non-determinism. When you enqueue the neighbours of a node you need to consider all possible orders that you can enqueue them. I spent quite a lot of time look at various libraries that support non-determinism. Surely I could do something clever with Control.Monad.Logic. I started to write a version using Continuation-passing style to have a list of non-deterministic continuations of the computation. All of this was too hard for me.

A simple approach is to to construct breadth first traversal level by level. If you have a partial $[n_1,\ldots, n_k]$ breadth first traversal, then you find the first node $n_i$ in the list that does not have all of its neighbours in the list, and then explore the neighbours of that node. This gives you a set of possible continuations of that path. This made me think about paths as an abstract data type. The set visited in the above code it really to keep track if you are going to loop back on the path, and so it really should be part of your path datatype. This gives you code something like:

data Path a = Path [a] (S.Set a)
instance (Show a) =>  Show (Path a) where
show (Path l _) = "Path = " ++ (show (reverse l))
-- Insert the next node.

empty_path :: Path a
empty_path = (Path  []  S.empty)
-- Insert a node into the path. Note that
-- paths are stored backwards.

insert_node ::(Ord a) =>  Path a -> a -> Path a
insert_node (Path p_l p_s)  n =
(Path new_path  new_set)
where
new_path = n:p_l
new_set  = S.insert n p_s
last_node :: Path a -> a
last_node (Path p_l  _ ) = head p_l

-- tells you if the second argument has been seen.

visited :: (Ord a) =>  Path a -> a -> Bool
visited (Path _ p_s) n = n S.member p_s

visited_set :: (Ord a) => Path a -> (S.Set a) -> Bool
visited_set  (Path _ p_s) s = s S.isSubsetOf p_s
visited_list :: (Ord a) => Path a -> [a] -> Bool
visited_list  (Path _ p_s) l = (S.fromList l) S.isSubsetOf p_s
path_list :: Path a -> [a]
path_list (Path l _) = reverse l


You really should package this up in a module.

You can then write a function that extends a path

new_paths :: (Ord a) => (a -> [a]) -> (Path a) ->  [Path a]
new_paths  _ (Path [] _)  = []
new_paths  neighbour_fun current_path    =
let nodes = path_list current_path
all_neighbours_not_present =
filter  (\n -> not (visited_list current_path (neighbour_fun n)) )
nodes

in
if null all_neighbours_not_present
then
[]
else

-- paths_from_n :: (Ord a) => (a -> [a]) -> (Path a) -> a -> [Path a]
-- n has to be a node which does not have all neighbours. You do that
-- in new_paths not paths_from_n
paths_from_n neighbour_fun current_path n =
let new_neighbours =  (neighbour_fun n)
neighbours_not_in_path =
filter (\n -> not (visited current_path n)) new_neighbours
new_paths = map (insert_node current_path ) neighbours_not_in_path
in
new_paths


The argument neighbour_fun tells the neighbours of the current graph. The fact that we are working with the graph function is not really important.

Writing the recursion to get to the fixed point.

all_new_paths_next_lvl :: (Ord a) => (a -> [a]) -> [Path a] ->  [Path a]
all_new_paths_next_lvl _ []  = []
all_new_paths_next_lvl neighbour_fun path_list  =
concat (map (new_paths neighbour_fun) path_list)

all_new_paths :: (Ord a) => (a -> [a]) -> [Path a] -> [Path a]
all_new_paths neighbour_fun path_list =
let next_lvl = all_new_paths_next_lvl neighbour_fun path_list
in
if null next_lvl
then
path_list
else
all_new_paths neighbour_fun next_lvl



Finally the wrapper. Notice that we take our graph and construct the neighbourhood function.

bfs_level_algo g start_node =
all_new_paths neighbour_fun  [initial_path]
where
initial_path = insert_node empty_path start_node
neighbour_fun node =
G.neighbours g node



## Breath First Search again but with Paths.

Now we have a Path datatype we can rewrite our original implementation. This is a step to making a non-deterministic breadth first search.

bfs_path g start_node =
let initial_queue = Q.enqueue Q.empty start_node
initial_path = empty_path
neighbour_fun node =
G.neighbours g node
in
(bfs_path_loop neighbour_fun initial_queue initial_path)

bfs_path_loop :: (Ord a) => ( a -> [a]) ->(Q.Queue a)  ->
(Path a) -> (Path a)

bfs_path_loop neighbour_fun c_queue  c_path
|  (Q.isempty c_queue)     =  c_path
|  otherwise               =
let (next_node, c_dequed) = Q.dequeue c_queue
new_neighbours = neighbour_fun next_node
in
if not (visited c_path next_node)
then -- We have visited the node
let
new_path = insert_node c_path next_node
new_queue = Q.enqueue_fromList c_dequed new_neighbours
in
bfs_path_loop neighbour_fun new_queue new_path
else -- We have visited the node , but we still have to deque
bfs_path_loop neighbour_fun  c_dequed  c_path



We are going to use lists as a monad. Lists can be used to model non-determinism. Suppose you have a function f = \v -> [v, (-1)*v] this takes an number v and returns v and -v. The list gives you the two options. If you have a list, say [1,2] then applying f to that list should give you the list [1,-1,2,-2]. It is not hard to write the correct function. But this is built into Haskell via the List monad. For example:

Prelude> let f = \x -> [x, (-1)*x ] Prelude> [1,2]
>>= f [1,-1,2,-2]


There are a lot of tutorials on using Moands and the List monad, and I’m not going to repeat things here.

Before we get to non-determinism we are going to refactor our code a bit. We need a type to represent the current state of a compuation.

type BFS_State a = ( (a -> [a] ) ,  (Q.Queue a), (Path a) )


Then next_path dequeues a node from the current_queue and constructs the next path.

next_path :: (Ord a) =>  BFS_State a -> BFS_State a
next_path (neighbour_fun , current_queue , current_path) =
if Q.isempty current_queue
then
(neighbour_fun, current_queue,  current_path) -- The fixpoint of the function.
else
let (next_node, c_dequed) = Q.dequeue current_queue
new_neighbours = neighbour_fun next_node
in
if not (visited current_path  next_node)
then
let
new_path = insert_node current_path next_node
new_queue = Q.enqueue_fromList c_dequed new_neighbours
in
(neighbour_fun , new_queue , new_path)
else
(neighbour_fun ,  c_dequed ,  current_path)


We can then wrap this up in an iterator. At the moment we are just doing some re-factoring of the code to make it easier to use monads for non-determinism.

bfs_next_path_loop :: (Ord a) =>  BFS_State a -> BFS_State a
bfs_next_path_loop state  =
let
(new_fun, new_queue , new_path) = next_path state
in
if not (Q.isempty new_queue)
then
bfs_next_path_loop (new_fun, new_queue , new_path)
else
(new_fun, new_queue , new_path)

bfs_with_next_path g start_node =
let initial_queue = Q.enqueue Q.empty start_node
initial_path = empty_path
neighbour_fun node =
G.neighbours g node
(_,_,path) =
bfs_next_path_loop (neighbour_fun , initial_queue , initial_path)
in
path


## Using the list Monad for non-determinism.

So the key idea is that we are going to write a function that takes the current state and returns all possible continuations. When look at the neighbours of a node you have to consider all the possible permutations of enqueue operations. In Data.List there is a handy permutations function.

import Data.List
all_next_path :: (Ord a) =>  BFS_State a -> [BFS_State a]
all_next_path (neighbour_fun , current_queue , current_path) =
if Q.isempty current_queue
then
[(neighbour_fun, current_queue,  current_path)]
else
let (next_node, c_dequed) = Q.dequeue current_queue
new_neighbours = neighbour_fun next_node
all_permutations = permutations new_neighbours
in
if not (visited current_path  next_node)
then
let
new_path = insert_node current_path next_node
new_queues = map (\x ->  Q.enqueue_fromList c_dequed x)
all_permutations
new_states = map (\x -> (neighbour_fun, x , new_path) )
new_queues
in
new_states
else
[(neighbour_fun ,  c_dequed ,  current_path)]


The type signature of >>= when specialised to lists is [a] -> (a -> [b]) -> [b] (a can equal b). We have that all_next_path :: (Ord a) => BFS_State a -> [BFS_State a] so this means that we can use >>=. Again we can wrap up all_next_path into a function that does the iteration. To make sure that our algorithm terminates we stop trying to expand states where the queues are empty. This gives us some code that looks like:

bfs_all_paths_loop :: (Ord a) =>  [BFS_State a] -> [BFS_State a]
bfs_all_paths_loop state_list =
if (null state_list) then []
else
let next_paths =
state_list >>= all_next_path
(empty_queues , non_empty_queues ) =
partition state_queue_empty next_paths
in
(bfs_all_paths_loop non_empty_queues) ++ empty_queues


The use of ++ might be inefficient. I don’t know without some profiling and in a lazy complied language it is hard to know. If it is inefficient then you should probably use difference lists. I spent a long time trying to come up with a nice short equivalent formulation using the do notation. I’m not sure if there is. If anybody finds one, then please contact me. Again you will need to wrap the loop up in a more user friendly way.

bfs_with_all_paths  g start_node =
let
initial_queue = Q.enqueue Q.empty start_node
initial_path = empty_path
neighbour_fun node =
G.neighbours g node
state_list =
bfs_all_paths_loop  [(neighbour_fun , initial_queue , initial_path)]
in
map (\(a,b,c) -> c) state_list


With our above code we are iterating until a fixed point. States with an empty queue are saved as completed path. The above code mixes these together. Haskell’s Writer monad is designed for computations where you also want to log information. We can use this to record the complete path. Again there are lots of tutorials on the writer monad, and this post has gone on far to long. So here is the code.

The type deceleration

bfs_all_paths_loop_writer :: (Ord a) =>
[BFS_State a] -> Writer [BFS_State a] [BFS_State a]


Gives you a new Monad on top of the list monad [BFS_State a] where you use the list monad [BFS_State a]. Given an element x of this monad the function runWriter a gives you a pair (r,v) where r is an element of the recording type and v is an element of the writer class. In this code writer(v,r) allows you to construct an element of the writer monad where v is the value and r is the record. The writer monad does all the book keeping of gluing together the record logs.

import Control.Monad.Trans.Writer
bfs_all_paths_loop_writer :: (Ord a) =>
[BFS_State a] -> Writer [BFS_State a] [BFS_State a]
bfs_all_paths_loop_writer state_list =
if (null state_list) then writer ([],[])
else
let next_paths =
state_list >>= all_next_path
(empty_queues , non_empty_queues ) =
partition state_queue_empty next_paths
(new_states, history) =
runWriter (bfs_all_paths_loop_writer non_empty_queues)
in
writer(new_states, history mappend empty_queues)


The mappend function in this case is a fancy generic way of writing ++ for lists. There are lots of ways of improving the above code, and it could probably be written in more idiomatic Haskell. The expression writer ([],[]) could be rewritten using return. Using ++ on lists can be inefficient, and you might want to replace the type recording type [BFS_State a] with difference lists.

Again you want to wrap this up in something more user friendly.

bfs_with_all_paths_writer  g start_node =
let
initial_queue = Q.enqueue Q.empty start_node
initial_path = empty_path
neighbour_fun node =
G.neighbours g node
state_list =
snd (runWriter (bfs_all_paths_loop_writer  [(neighbour_fun , initial_queue , initial_path)]))
in
map (\(a,b,c) -> c) state_list


Again I tried to come up with something elegant using do blocks and guards, but failed. The problem with Monad transformers is that you often require nested do blocks to get the types right. There is a lift function lift that allows you get do down inside your tower of monad transformers.

## Extra Libraries

These are not meant to be efficient. I just wanted to check that I still understood how modules worked.

First Graph_Simple.hs

module Graph_Simple (fromEdges, neighbours , Graph (..) )  where
import qualified Data.Set as S

data Graph a = G (S.Set a , S.Set (a,a) )  deriving (Show)

allnodes [] = S.empty
allnodes ((v,w) : xs) =
let nodes_of_rest = (allnodes xs)
in
S.insert w (S.insert v nodes_of_rest)

fromEdges :: (Ord a) =>  [(a,a)] -> Graph a
fromEdges edge_list =
let nodes = allnodes  edge_list
edges = S.fromList edge_list
in
G (nodes, edges)

neighbours :: (Ord a) => Graph a -> a -> [a]
neighbours (G (nodes, edges) ) n =
if n S.member nodes
then
[ y | (x,y) <- S.toList (edges) , x == n]
else
error "Node not a member of the graph."


Then Queue_Seq.hs that implements queues using Haskell’s sequence data type.

module Queue_Seq (empty,
singelton,
enqueue,
dequeue,
isempty,
enqueue_fromList,
Queue (..) )  where

import qualified Data.Sequence as Seq

--- More efficient Queue data type.

data  Queue a  = Q (Seq.Seq a) deriving (Eq,Show)

empty  = Q Seq.empty

isempty :: Queue a -> Bool
isempty (Q q)  = case q of
Seq.Empty -> True
otherwise -> False

singelton :: a -> Queue a
singelton e = Q (Seq.singleton e)

enqueue :: Queue a -> a -> Queue a
enqueue (Q q)  a =
Q (a Seq.<| q)

dequeue :: Queue a -> ( a , Queue a)
dequeue (Q (new_q Seq.:|> elem))  =  (elem, (Q new_q))

enqueue_fromList :: Queue a -> [a] -> Queue a
enqueue_fromList q [] = q
enqueue_fromList q (x : xs) =
(enqueue qs x)
where
qs = enqueue_fromList q xs


You probably want to rewrite enqueue_fromList using foldl or one of its strict versions. ##### Justin Pearson
###### Docent in Computing Science

Lecturer and researcher at Uppsala University.