-- A Generic Breadth First Search Function
module BFS(breadth_first_search, breadth_first_visit, 
           BFSVisitor(..), Color(..)) where
  import Graph
  import PropertyMap
  import Queue

  class (Graph g e v) => BFSVisitor vis q a g e v where
    discover_vertex :: vis -> v -> g -> q -> a -> (a,q)
    examine_vertex :: vis -> v -> g -> q -> a -> (a,q)
    examine_edge :: vis -> e -> g -> q -> a -> (a,q)
    tree_edge :: vis -> e -> g -> q -> a -> (a,q)
    non_tree_edge :: vis -> e -> g -> q -> a -> (a,q)
    gray_target :: vis -> e -> g -> q -> a -> (a,q)
    black_target :: vis -> e -> g -> q -> a -> (a,q)
    finish_vertex :: vis -> v -> g -> q -> a -> (a,q)
    -- default implementations do nothing
    discover_vertex vis v g q a = (a,q)
    examine_vertex vis v g q a = (a,q)
    examine_edge vis e g q a = (a,q)
    tree_edge vis e g q a = (a,q)
    non_tree_edge vis e g q a = (a,q)
    gray_target vis e g q a = (a,q)
    black_target vis e g q a = (a,q)
    finish_vertex vis v g q a = (a,q)

  data Color = White | Gray | Black

  breadth_first_search ::
    (VertexListGraph g v, IncidenceGraph g e v, Ord v,
     BFSVisitor vis (Seq v) a g e v) => 
    g -> v -> vis -> a -> a
  breadth_first_search g s vis init = 
    let q = empty
        c = init_map (vertices g) White
    in breadth_first_visit g s vis init q c

  breadth_first_visit ::
    (VertexListGraph g v, IncidenceGraph g e v,
     Ord v, Queue q v, ReadWritePropertyMap c v Color,
     BFSVisitor vis q a g e v) => 
    g -> v -> vis -> a -> q -> c -> a
  breadth_first_visit g s vis init q1 c = 
    let (x,q2) = discover_vertex vis s g q1 init
        c1 = put c s Gray 
        q3 = push s q2 
    in bfs_while_loop x q3 c1
    where
      bfs_while_loop x1 q1 c = 
        if (is_empty q1) then x1
        else
          let u = front q1
              q2 = pop q1
              (x2,q3) = examine_vertex vis u g q2 x1
              bfs_inner_loop q1 x1 c [] = 
                  let (x2, q2) = finish_vertex vis u g q1 x1
                  in bfs_while_loop x2 q2 c
              bfs_inner_loop q1 x1 c1 (e:es) =
                let v = tgt e g
                    (x2,q2) = examine_edge vis e g q1 x1
                    vc = get c1 v
                in case vc of
                  White -> 
                    let (x3,q3) = tree_edge vis e g q2 x2
                        c2 = put c1 v Gray 
                        (x4,q4) = discover_vertex vis v g q3 x3
                    in bfs_inner_loop (push v q4) x4 c2 es
                  Gray -> 
                    let (x3,q3) = gray_target vis e g q2 x2
                    in bfs_inner_loop q3 x3 c1 es
                  Black -> 
                    let (x3,q3) = black_target vis e g q2 x2
                        c2 = put c1 u Black
                    in bfs_inner_loop q3 x3 c2 es
          in bfs_inner_loop q3 x2 c (out_edges u g)