BFS.hs

-- (c) 2000-2005 by Martin Erwig [see file COPYRIGHT]
-- | Breadth-First Search Algorithms

module Data.Graph.Inductive.Query.BFS(
    -- * BFS Node List
    bfs,bfsn,bfsWith,bfsnWith,
    -- * Node List With Depth Info
    level,leveln,
    -- * BFS Edges
    bfe,bfen,
    -- * BFS Tree
    bft,lbft,
    -- * Shortest Path (Number of Edges)
    esp,lesp
) where


import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Internal.Queue
import Data.Graph.Inductive.Internal.RootPath

-- bfs (node list ordered by distance)
--
bfsnInternal :: Graph gr => (Context a b -> c) -> Queue Node -> gr a b -> [c]
bfsnInternal f q g | queueEmpty q || isEmpty g = []
                   | otherwise                 =
       case match v g of
        (Just c, g')  -> f c:bfsnInternal f (queuePutList (suc' c) q') g'
        (Nothing, g') -> bfsnInternal f q' g'
        where (v,q') = queueGet q

bfsnWith :: Graph gr => (Context a b -> c) -> [Node] -> gr a b -> [c]
bfsnWith f vs = bfsnInternal f (queuePutList vs mkQueue)

bfsn :: Graph gr => [Node] -> gr a b -> [Node]
bfsn = bfsnWith node'

bfsWith :: Graph gr => (Context a b -> c) -> Node -> gr a b -> [c]
bfsWith f v = bfsnInternal f (queuePut v mkQueue)

bfs :: Graph gr => Node -> gr a b -> [Node]
bfs = bfsWith node'


-- level (extension of bfs giving the depth of each node)
--
level :: Graph gr => Node -> gr a b -> [(Node,Int)]
level v = leveln [(v,0)]

suci c i = zip (suc' c) (repeat i)

leveln :: Graph gr => [(Node,Int)] -> gr a b -> [(Node,Int)]
leveln []         _             = []
leveln _          g | isEmpty g = []
leveln ((v,j):vs) g = case match v g of
                        (Just c,g')  -> (v,j):leveln (vs++suci c (j+1)) g'
                        (Nothing,g') -> leveln vs g'  


-- bfe (breadth first edges)
-- remembers predecessor information
--
bfenInternal :: Graph gr => Queue Edge -> gr a b -> [Edge]
bfenInternal q g | queueEmpty q || isEmpty g = []
                 | otherwise                 = 
      case match v g of
        (Just c, g')  -> (u,v):bfenInternal (queuePutList (outU c) q') g'
        (Nothing, g') -> bfenInternal q' g'
        where ((u,v),q') = queueGet q

bfen :: Graph gr => [Edge] -> gr a b -> [Edge]
bfen vs g = bfenInternal (queuePutList vs mkQueue) g

bfe :: Graph gr => Node -> gr a b -> [Edge]
bfe v = bfen [(v,v)]

outU c = map (\(v,w,_)->(v,w)) (out' c)


-- bft (breadth first search tree)
-- here: with inward directed trees
--
-- bft :: Node -> gr a b -> IT.InTree Node
-- bft v g = IT.build $ map swap $ bfe v g
--           where swap (x,y) = (y,x)
-- 
-- sp (shortest path wrt to number of edges)
--
-- sp :: Node -> Node -> gr a b -> [Node]
-- sp s t g = reverse $ IT.rootPath (bft s g) t


-- faster shortest paths 
-- here: with root path trees
-- 
bft :: Graph gr => Node -> gr a b -> RTree
bft v = bf (queuePut [v] mkQueue)

bf :: Graph gr => Queue Path -> gr a b -> RTree
bf q g | queueEmpty q || isEmpty g = []
       | otherwise                 =
       case match v g of
         (Just c, g')  -> p:bf (queuePutList (map (:p) (suc' c)) q') g'
         (Nothing, g') -> bf q' g'
         where (p@(v:_),q') = queueGet q

esp :: Graph gr => Node -> Node -> gr a b -> Path
esp s t = getPath t . bft s


-- lesp is a version of esp that returns labeled paths
-- Note that the label of the first node in a returned path is meaningless;
-- all other nodes are paired with the label of their incoming edge. 
--
lbft :: Graph gr => Node -> gr a b -> LRTree b
lbft v g = case (out g v) of 
             []         -> [LP []]
             (v',_,l):_ -> lbf (queuePut (LP [(v',l)]) mkQueue) g

lbf :: Graph gr => Queue (LPath b) -> gr a b -> LRTree b
lbf q g | queueEmpty q || isEmpty g = []
        | otherwise                 =
       case match v g of
         (Just c, g') ->
             LP p:lbf (queuePutList (map (\v' -> LP (v':p)) (lsuc' c)) q') g'
         (Nothing, g') -> lbf q' g'
         where ((LP (p@((v,_):_))),q') = queueGet q

lesp :: Graph gr => Node -> Node -> gr a b -> LPath b
lesp s t = getLPath t . lbft s