{-# LANGUAGE TypeFamilies #-}------------------------------------------------------------------------------- |-- Module : Data.Graph.Algorithm.BreadthFirstSearch-- Copyright : (C) 2011 Edward Kmett-- License : BSD-style (see the file LICENSE)---- Maintainer : Edward Kmett <ekmett@gmail.com>-- Stability : experimental-- Portability : type families---- Breadth-first search----------------------------------------------------------------------------moduleData.Graph.Algorithm.BreadthFirstSearch(bfs,Bfs(..))whereimportControl.ApplicativeimportControl.MonadimportControl.Monad.Trans.ClassimportControl.Monad.Trans.State.StrictimportData.DefaultimportData.FoldableimportData.MonoidimportData.SequenceimportData.Graph.ClassimportData.Graph.Class.AdjacencyListimportData.Graph.PropertyMapimportData.Graph.Internal.Color-- | Breadth first search visitor dataBfsgm=Bfs{enterVertex::Vertexg->gm-- called the first time a vertex is discovered,grayTarget::Edgeg->gm-- called when we encounter a back edge to a vertex we're still processing,exitVertex::Vertexg->gm-- called once we have processed all descendants of a vertex,blackTarget::Edgeg->gm-- called when we encounter a cross edge to a vertex we've already finished}instanceGraphg=>Functor(Bfsg)wherefmapf(Bfsabcd)=Bfs(liftMf.a)(liftMf.b)(liftMf.c)(liftMf.d)instanceGraphg=>Applicative(Bfsg)wherepurea=Bfs(const(returna))(const(returna))(const(returna))(const(returna))m<*>n=Bfs(\v->enterVertexmv`ap`enterVertexnv)(\e->grayTargetme`ap`grayTargetne)(\v->exitVertexmv`ap`exitVertexnv)(\e->blackTargetme`ap`blackTargetne)instanceGraphg=>Monad(Bfsg)wherereturn=purem>>=f=Bfs(\v->enterVertexmv>>=($v).enterVertex.f)(\e->grayTargetme>>=($e).grayTarget.f)(\v->exitVertexmv>>=($v).exitVertex.f)(\e->blackTargetme>>=($e).blackTarget.f)instance(Graphg,Monoidm)=>Default(Bfsgm)wheredef=returnmemptyinstance(Graphg,Monoidm)=>Monoid(Bfsgm)wheremempty=returnmemptymappend=liftM2mappendgetS::Monadg=>k->StateT(Seqv,PropertyMapgkColor)gColorgetSk=dom<-getssndlift(getPmk)putS::Monadg=>k->Color->StateT(Seqv,PropertyMapgkColor)g()putSkv=dom<-getssndm'<-lift$putPmkvmodify$\(q,_)->(q,m')enqueue::Graphg=>Bfsgm->Vertexg->StateT(Seq(Vertexg),PropertyMapg(Vertexg)Color)gmenqueuevisv=dom<-getssndm'<-lift$putPmvGreymodify$\(q,_)->(q|>v,m')lift$enterVertexvisvdequeue::Monadg=>StateT(Seqv,s)gr->(v->StateT(Seqv,s)gr)->StateT(Seqv,s)grdequeuekeks=do(q,m)<-getcaseviewlqofEmptyL->ke(a:<q')->put(q',m)>>ksabfs::(AdjacencyListGraphg,Monoidm)=>Bfsgm->Vertexg->gmbfsvisv0=dom<-vertexMapWhiteevalStateT(enqueuevisv0>>=pump)(mempty,m)wherepumplhs=dequeue(returnlhs)$\v->doadjs<-lift$outEdgesvchildren<-foldrM(\em->dov'<-targetecolor<-getSv'liftM(`mappend`m)$casecolorofWhite->enqueuevisv'Grey->lift$grayTargetviseBlack->lift$blackTargetvise)memptyadjsputSvBlackrhs<-lift$exitVertexvisvpump$lhs`mappend`children`mappend`rhs