{- |
Module : Data.GraphViz.Algorithms
Description : Various algorithms on Graphviz graphs.
Copyright : (c) Matthew Sackman, Ivan Lazar Miljenovic
License : 3-Clause BSD-style
Maintainer : Ivan.Miljenovic@gmail.com
Defines various algorithms for use on 'DotRepr' graphs. These are
typically re-implementations of behaviour found in existing Graphviz
tools but without the I/O requirement.
-}moduleData.GraphViz.Algorithms(-- * Canonicalisation Options-- $optionsCanonicaliseOptions(..),defaultCanonOptions,dotLikeOptions-- * Canonicalisation,canonicalise,canonicaliseOptions-- * Dealing with transitive edges,transitiveReduction,transitiveReductionOptions)whereimportData.GraphViz.Attributes.Complete(Attributes,usedByClusters,defaultAttributeValue)importData.GraphViz.Attributes.SameimportData.GraphViz.TypesimportData.GraphViz.Types.CanonicalimportData.Function(on)importData.List(groupBy,sortBy,partition,(\\),sort,deleteBy)importData.Maybe(listToMaybe,mapMaybe,fromMaybe)importqualifiedData.DListasDListimportqualifiedData.MapasMapimportData.Map(Map)importqualifiedData.SetasSetimportData.Set(Set)importqualifiedData.FoldableasFimportControl.Arrow(first,second,(***))importControl.Monad(unless)importControl.Monad.Trans.State-- -----------------------------------------------------------------------------{- $options
For simplicity, many algorithms end up using the canonicalisation
functions to create the new 'DotGraph'. 'CanonicaliseOptions' allows
you to configure how the output is generated.
-}dataCanonicaliseOptions=COpts{-- | Place edges in the clusters-- where their nodes are rather-- than in the top-level graph.edgesInClusters::Bool-- | Put common 'Attributes' as-- top-level 'GlobalAttributes'.,groupAttributes::Bool}deriving(Eq,Ord,Show,Read)defaultCanonOptions::CanonicaliseOptionsdefaultCanonOptions=COpts{edgesInClusters=True,groupAttributes=True}-- | Options that are more like how @dot -Tcanon@ works.dotLikeOptions::CanonicaliseOptionsdotLikeOptions=COpts{edgesInClusters=True,groupAttributes=False}-- ------------------------------------------------------------------------------- | Implements similar functionality to @dot -Tcanon@. However, this-- method requires no IO and doesn't care about image locations, etc.---- This function will create a single explicit definition for every-- node in the original graph and place it in the appropriate-- position in the cluster hierarchy. All edges are found in the-- deepest cluster that contains both nodes. Currently node and-- edge attributes are not grouped into global ones.canonicalise::(DotReprdgn)=>dgn->DotGraphncanonicalise=canonicaliseOptionsdefaultCanonOptions-- | As with 'canonicalise', but allow custom 'CanonicaliseOptions'.canonicaliseOptions::(DotReprdgn)=>CanonicaliseOptions->dgn->DotGraphncanonicaliseOptionsoptsdg=cdg{strictGraph=graphIsStrictdg,directedGraph=graphIsDirecteddg,graphID=getIDdg}wherecdg=createCanonicaloptsgasclnles(gas,cl)=graphStructureInformationdgnl=nodeInformationTruedges=edgeInformationTruedgcreateCanonical::(Ordn)=>CanonicaliseOptions->GlobalAttributes->ClusterLookup->NodeLookupn->[DotEdgen]->DotGraphncreateCanonicaloptsgasclnles=DotGraph{strictGraph=undefined,directedGraph=undefined,graphID=undefined,graphStatements=gStmts}wheregStmts=DotStmts{attrStmts=gas',subGraphs=sgs,nodeStmts=topNs',edgeStmts=topEs'}gas'=nonEmptyGAs[gas,NodeAttrstopNAs,EdgeAttrstopEAs]nUnlook(n,(p,as))=(F.toListp,DotNodenas)ns=sortBy(compLists`on`fst).mapnUnlook$Map.toListnl(clustNs,topNs)=thisLevelns(clustEL,topEs)=ifedgesInClustersoptsthenedgeClustersnleselse(Map.empty,es)topClustAs=filterusedByClusters$attrsgastopClustAs'=toSAttrtopClustAstopNAs=mCommonnodeAttributestopNstopNAs'=toSAttrtopNAstopNs'=map(\dn->dn{nodeAttributes=nodeAttributesdn\\topNAs})topNstopEAs=mCommonedgeAttributestopEstopEAs'=toSAttrtopEAstopEs'=map(\de->de{edgeAttributes=edgeAttributesde\\topEAs})topEssgs=cluststopClustAstopClustAs'topNAstopNAs'topEAstopEAs'clustNsclustsoAsoAsSnAsnAsSeAseAsS=map(toClustoAsoAsSnAsnAsSeAseAsS).groupBy((==)`on`(listToMaybe.fst))-- Create a new cluster.toClustoAsoAsSnAsnAsSeAseAsScns=DotSG{isCluster=True,subGraphID=cID,subGraphStmts=stmts}wherecID=head.fst$headcns(nested,here)=thisLevel$map(firsttail)cnsstmts=DotStmts{attrStmts=sgAs,subGraphs=subSGs,nodeStmts=here',edgeStmts=edges'}sgAs=nonEmptyGAs[GraphAttrsas',NodeAttrsnas',EdgeAttrseas']subSGs=clustsasasSnasnasSeaseasSnestedas=attrs.snd$clMap.!cIDasS=toSAttrasas'=innerAttributesoAsoAsSasnas=mCommonnodeAttributesherenasS=toSAttrnasnas'=innerAttributesnAsnAsSnashere'=map(\dn->dn{nodeAttributes=nodeAttributesdn\\nas})hereeas=mCommonedgeAttributesedgeseasS=toSAttreaseas'=innerAttributeseAseAsSeasedges'=map(\de->de{edgeAttributes=edgeAttributesde\\eas})edgesedges=fromMaybe[]$cID`Map.lookup`clustELthisLevel=second(mapsnd).span(not.null.fst)mCommonf=ifgroupAttributesoptsthencommonAttrsfelseconst[]-- Same as compare for lists, except shorter lists are GTcompLists::(Orda)=>[a]->[a]->OrderingcompLists[][]=EQcompLists[]_=GTcompLists_[]=LTcompLists(x:xs)(y:ys)=casecomparexyofEQ->compListsxsysoth->othnonEmptyGAs::[GlobalAttributes]->[GlobalAttributes]nonEmptyGAs=filter(not.null.attrs)-- Return all attributes found in every value.commonAttrs::(a->Attributes)->[a]->AttributescommonAttrs_[]=[]commonAttrs_[_]=[]commonAttrsfxs=Set.toList.foldr1Set.intersection$map(Set.fromList.f)xs-- Assign each edge into the cluster it belongs in.edgeClusters::(Ordn)=>NodeLookupn->[DotEdgen]->(Map(MaybeGraphID)[DotEdgen],[DotEdgen])edgeClustersnl=(toM***mapsnd).partition(not.null.fst).mapinClustwherenl'=Map.map(F.toList.fst)nlinClustde@(DotEdgen1n2_)=(flip(,)de).mapfst.takeWhile(uncurry(==))$zip(nl'Map.!n1)(nl'Map.!n2)toM=Map.mapDList.toList.Map.fromListWith(flipDList.append).map(last***DList.singleton)-- Return only those attributes that are required within the inner-- sub-graph.innerAttributes::Attributes->SAttrs->Attributes->AttributesinnerAttributesouterouterSinner=sort$inner'++overridewhere-- Remove all Attributes that are also defined in the outer clusterinner'=inner\\outer-- Need to consider those Attributes that were defined /after/ this valueoverride=mapMaybedefAttr.unSame$outerS`Set.difference`toSAttrinner-- A version of defaultAttributeValue that returns Nothing if the-- value it is replacing /is/ the default.defAttra=casedefaultAttributeValueaofJusta'|a==a'->Nothingma'->ma'-- -----------------------------------------------------------------------------{- $transitive
In large, cluttered graphs, it can often be difficult to see what
is happening due to the number of edges being drawn. As such, it is
often useful to remove transitive edges from the graph before
visualising it.
For example, consider the following Dot graph:
> digraph {
> a -> b;
> a -> c;
> b -> c;
> }
This graph has the transitive edge @a -> c@ (as we can reach @c@ from @a@ via @b@).
Graphviz comes with the @tred@ program to perform these transitive
reductions. 'transitiveReduction' and 'transitiveReductionOptions'
are pure Haskell re-implementations of @tred@ with the following differences:
* @tred@ prints a message to stderr if a cycle is detected; these
functions do not.
* @tred@ preserves the original structure of the graph; these
functions use the canonicalisation functions above to create the new
graph (rather than re-implement creation functions for each one).
When a graph contains cycles, an arbitrary edge from that cycle is
ignored whilst calculating the transitive reduction. Multiple edges
are also reduced (such that only the first edge between two nodes is
kept).
Note that transitive reduction only makes sense for directed graphs;
for undirected graphs these functions are identical to the
canonicalisation functions above.
-}transitiveReduction::(DotReprdgn)=>dgn->DotGraphntransitiveReduction=transitiveReductionOptionsdefaultCanonOptionstransitiveReductionOptions::(DotReprdgn)=>CanonicaliseOptions->dgn->DotGraphntransitiveReductionOptionsoptsdg=cdg{strictGraph=graphIsStrictdg,directedGraph=graphIsDirecteddg,graphID=getIDdg}wherecdg=createCanonicaloptsgasclnles'(gas,cl)=graphStructureInformationdgnl=nodeInformationTruedges=edgeInformationTruedges'|graphIsDirecteddg=rmTransEdgeses|otherwise=esrmTransEdges::(Ordn)=>[DotEdgen]->[DotEdgen]rmTransEdges[]=[]rmTransEdgeses=concatMap(mapsnd.outgoing)$Map.elemsesMwheretes=tagEdgesesesMS=doedgeGraphtesns<-getsMapMap.keysmapM_(traversezeroTag)nsesM=fst$execStateesMS(Map.empty,Set.empty)typeTag=InttypeTagSet=SetInttypeTaggedEdgen=(Tag,DotEdgen)-- A "nonsense" tag to use as an initial valuezeroTag::TagzeroTag=0tagEdges::[DotEdgen]->[TaggedEdgen]tagEdges=zip[(succzeroTag)..]dataTaggedValuesn=TV{marked::Bool,incoming::[TaggedEdgen],outgoing::[TaggedEdgen]}deriving(Eq,Ord,Show,Read)defTV::TaggedValuesndefTV=TVFalse[][]typeTagMapn=Mapn(TaggedValuesn)typeTagStatena=State(TagMapn,TagSet)agetMap::TagStaten(TagMapn)getMap=getsfstgetsMap::(TagMapn->a)->TagStatenagetsMapf=gets(f.fst)modifyMap::(TagMapn->TagMapn)->TagStaten()modifyMapf=modify(firstf)getSet::TagStatenTagSetgetSet=getssndmodifySet::(TagSet->TagSet)->TagStaten()modifySetf=modify(secondf)-- Create the Map representing the graph from the edges.edgeGraph::(Ordn)=>[TaggedEdgen]->TagStaten()edgeGraph=mapM_addEdge.reversewhereaddEdgete=addValftvOut>>addValttvInwheree=sndtef=fromNodeet=toNodeeaddValntv=modifyMap(Map.insertWithmergeTVntv)tvIn=defTV{incoming=[te]}tvOut=defTV{outgoing=[te]}mergeTVtvNewtv=tv{incoming=incomingtvNew++incomingtv,outgoing=outgoingtvNew++outgoingtv}-- Perform a DFS to determine whether or not to keep each edge.traverse::(Ordn)=>Tag->n->TagStaten()traversetn=dosetMarkTruecheckIncomingoutEs<-getsMap(maybe[]outgoing.Map.lookupn)mapM_maybeRecurseoutEssetMarkFalsewheresetMarkmrk=modifyMap(Map.adjust(\tv->tv{marked=mrk})n)isMarkedmn'=maybeFalsemarked$n'`Map.lookup`mcheckIncoming=dom<-getsfstletes=incoming$mMap.!n(keepEs,delEs)=partition(keepEdgem)esmodifyMap(Map.adjust(\tv->tv{incoming=keepEs})n)modifySet(Set.union$Set.fromList(mapfstdelEs))mapM_delOtherEdgedelEswherekeepEdgem(t',e)=t==t'||not(isMarkedm$fromNodee)delOtherEdgete=modifyMap(Map.adjustdelE.fromNode$sndte)wheredelEtv=tv{outgoing=deleteBy((==)`on`fst)te$outgoingtv}maybeRecurse(t',e)=dom<-getMapdelSet<-getSetletn'=toNodeeunless(isMarkedmn'||t'`Set.member`delSet)$traverset'n'