-- Copyright (c) David Amos, 2008. All rights reserved.-- |A module defining a polymorphic data type for (simple, undirected) graphs,-- together with constructions of some common families of graphs,-- new from old constructions, and calculation of simple properties of graphs.moduleMath.Combinatorics.GraphwhereimportqualifiedData.ListasLimportData.Maybe(isJust)importqualifiedData.MapasMimportqualifiedData.SetasSimportControl.Arrow((&&&))importMath.Common.ListSetimportMath.Algebra.Group.PermutationGrouphiding(fromDigits,fromBinary)importMath.Algebra.Group.SchreierSimsasSS-- Main source: Godsil & Royle, Algebraic Graph Theory-- COMBINATORICS-- Some functions we'll usesetxs=maphead$L.group$L.sortxs-- subsets of a set (returned in "binary" order)powerset[]=[[]]powerset(x:xs)=letp=powersetxsinp++map(x:)p-- |combinationsOf k xs returns the subsets of xs of size k.-- If xs is in ascending order, then the returned list is in ascending ordercombinationsOf::(Integralt)=>t->[a]->[[a]]combinationsOf0_=[[]]combinationsOf_[]=[]combinationsOfk(x:xs)|k>0=map(x:)(combinationsOf(k-1)xs)++combinationsOfkxs-- GRAPH-- |Datatype for graphs, represented as a list of vertices and a list of edges.-- Both the list of vertices and the list of edges, and also the 2-element lists representing the edges,-- are required to be in ascending order, without duplicates.dataGrapha=G[a][[a]]deriving(Eq,Ord,Show)-- we require that vs, es, and each individual e are sortedisSetSystemxsbs=isListSetxs&&isListSetbs&&allisListSetbs&&all(`isSubset`xs)bsisGraphvses=isSetSystemvses&&all((==2).length)es-- |Safe constructor for graph from lists of vertices and edges.-- graph (vs,es) checks that vs and es are valid before returning the graph.graph::(Ordt)=>([t],[[t]])->Graphtgraph(vs,es)|isGraphvses=Gvses-- isValid g = g where g = G vs estoGraph(vs,es)|isGraphvs'es'=Gvs'es'wherevs'=L.sortvses'=L.sort$mapL.sortes-- note that calling isListSet on a sorted list still checks that there are no duplicatesvertices(Gvs_)=vsedges(G_es)=es-- OTHER REPRESENTATIONS-- incidence matrix of a graph-- (rows and columns indexed by edges and vertices respectively)-- (warning: in the literature it is often the other way round)incidenceMatrix(Gvses)=[[ifv`elem`ethen1else0|v<-vs]|e<-es]fromIncidenceMatrixm=graph(vs,es)wheren=L.genericLength$headmvs=[1..n]es=L.sort$mapedgemedgerow=[v|(1,v)<-ziprowvs]adjacencyMatrix(Gvses)=[[ifL.sort[i,j]`S.member`es'then1else0|j<-vs]|i<-vs]wherees'=S.fromListesfromAdjacencyMatrixm=graph(vs,es)wheren=L.genericLengthmvs=[1..n]es=es'1mes'i(r:rs)=[[i,j]|(j,1)<-dropi(zipvsr)]++es'(i+1)rses'_[]=[]-- SOME SIMPLE FAMILIES OF GRAPHSnullGraph::GraphInt-- type signature needednullGraph=G[][]-- |c n is the cyclic graph on n verticesc::(Integralt)=>t->Graphtcn=graph(vs,es)wherevs=[1..n]es=L.insert[1,n][[i,i+1]|i<-[1..n-1]]-- automorphism group is D2n-- |k n is the complete graph on n verticesk::(Integralt)=>t->Graphtkn=graph(vs,es)wherevs=[1..n]es=[[i,j]|i<-[1..n-1],j<-[i+1..n]]-- == combinationsOf 2 [1..n]-- automorphism group is Sn-- The complete bipartite graph on m and n vertices-- kb :: (Integral t) => t -> t -> Graph tkbmn=to1n$kb'mn-- The complete bipartite graph on m left and n right vertices-- kb :: (Integral t) => t -> t -> Graph (Either t t)kb'mn=graph(vs,es)wherevs=mapLeft[1..m]++mapRight[1..n]es=[[Lefti,Rightj]|i<-[1..m],j<-[1..n]]-- automorphism group is Sm*Sn (plus a flip if m==n)q'k=graph(vs,es)wherevs=sequence$replicatek[0,1]-- ptsAn k f2es=[[u,v]|[u,v]<-combinationsOf2vs,hammingDistanceuv==1]hammingDistanceasbs=length$filterid$zipWith(/=)asbs-- can probably type-coerce this to be Graph [F2] if requiredqk=fromBinary$q'k{-
-- note, this definition only in versions >0.1.3
q'' k = gmap (\v -> v <.> pows2) (q' k) where
pows2 = reverse $ take k $ iterate (*2) 1
u <.> v = sum $ zipWith (*) u v
gmap f (G vs es) = G (map f vs) ((map . map) f es)
-}tetrahedron=k4cube=q3octahedron=graph(vs,es)wherevs=[1..6]es=combinationsOf2vsL.\\[[1,6],[2,5],[3,4]]dodecahedron=toGraph(vs,es)wherevs=[1..20]es=[[1,2],[2,3],[3,4],[4,5],[5,1],[6,7],[7,8],[8,9],[9,10],[10,11],[11,12],[12,13],[13,14],[14,15],[15,6],[16,17],[17,18],[18,19],[19,20],[20,16],[1,6],[2,8],[3,10],[4,12],[5,14],[7,16],[9,17],[11,18],[13,19],[15,20]]icosahedron=toGraph(vs,es)wherevs=[1..12]es=[[1,2],[1,3],[1,4],[1,5],[1,6],[2,3],[3,4],[4,5],[5,6],[6,2],[7,12],[8,12],[9,12],[10,12],[11,12],[7,8],[8,9],[9,10],[10,11],[11,7],[2,7],[7,3],[3,8],[8,4],[4,9],[9,5],[5,10],[10,6],[6,11],[11,2]]-- convert a graph to have [1..n] as verticesto1n(Gvses)=graph(vs',es')wheremapping=M.fromList$zipvs[1..]-- the mapping from vs to [1..n]vs'=M.elemsmappinges'=[map(mappingM.!)e|e<-es]-- the edges will already be sorted correctly by construction-- |Given a graph with vertices which are lists of small integers, eg [1,2,3],-- return a graph with vertices which are the numbers obtained by interpreting these as digits, eg 123.-- The caller is responsible for ensuring that this makes sense (eg that the small integers are all < 10)fromDigits::Integrala=>Graph[a]->GraphafromDigits(Gvses)=graph(vs',es')wherevs'=mapfromDigits'vses'=(map.map)fromDigits'es-- |Given a graph with vertices which are lists of 0s and 1s,-- return a graph with vertices which are the numbers obtained by interpreting these as binary digits.-- For example, [1,1,0] -> 6.fromBinary::Integrala=>Graph[a]->GraphafromBinary(Gvses)=graph(vs',es')wherevs'=mapfromBinary'vses'=(map.map)fromBinary'es-- this definition only in versions >0.1.3petersen=graph(vs,es)wherevs=combinationsOf2[1..5]es=[[v1,v2]|[v1,v2]<-combinationsOf2vs,disjointv1v2]-- == kneser 5 2 == j 5 2 0-- == complement $ lineGraph' $ k 5-- == complement $ t' 5-- NEW GRAPHS FROM OLDcomplement(Gvses)=graph(vs,es')wherees'=combinationsOf2vs\\es-- es' = [e | e <- combinationsOf 2 vs, e `notElem` es]lineGraphg=to1n$lineGraph'glineGraph'(Gvses)=graph(es,[[ei,ej]|ei<-es,ej<-dropWhile(<=ei)es,ei`intersect`ej/=[]])-- SIMPLE PROPERTIES OF GRAPHSorderg=length(verticesg)sizeg=length(edgesg)-- also called degreevalency(Gvses)v=length$filter(v`elem`)esvalenciesg@(Gvses)=map(head&&&length)$L.group$L.sort$map(valencyg)vsregularParamg=casevalenciesgof[(v,_)]->Justv_->NothingisRegularg=isJust$regularParamgisCubicg=regularParamg==Just3nbrs(Gvses)v=[u|[u,v']<-es,v==v']++[w|[v',w]<-es,v==v']-- if the graph is valid, then the neighbours will be returned in ascending order-- find paths from x to y using bfs-- by definition, a path is a subgraph isomorphic to a "line" - it can't have self-crossings-- (a walk allows self-crossings, a trail allows self-crossings but no edge reuse)findPathsg@(Gvses)xy=mapreverse$bfs[[x]]wherebfs((z:zs):nodes)|z==y=(z:zs):bfsnodes|otherwise=bfs(nodes++[(w:z:zs)|w<-nbrsgz,w`notElem`zs])bfs[]=[]-- length of the shortest path from x to ydistancegxy=casefindPathsgxyof[]->-1-- infinitep:ps->lengthp-1-- |The diameter of a graph is maximum distance between two distinct verticesdiameter::(Ordt)=>Grapht->Intdiameterg@(Gvses)|isConnectedg=maximum$mapmaxDistancevs|otherwise=-1wheremaxDistancev=length(distancePartitiongv)-1-- find cycles starting at x-- by definition, a cycle is a subgraph isomorphic to a cyclic graph - it can't have self-crossings-- (a circuit allows self-crossings but not edge reuse)findCyclesg@(Gvses)x=[reverse(x:z:zs)|z:zs<-bfs[[x]],z`elem`nbrsx,lengthzs>1]wherenbrsx=nbrsgxbfs((z:zs):nodes)=(z:zs):bfs(nodes++[w:z:zs|w<-nbrsgz,w`notElem`zs])bfs[]=[]-- |The girth of a graph is the size of the smallest cycle that it contains.-- Note: If the graph contains no cycles, we return -1, representing infinity.girth::(Eqt)=>Grapht->Intgirthg@(Gvses)=minimum'$mapminCyclevswhereminimum'xs=let(zs,nzs)=L.partition(==0)xsinifnullnzsthen-1elseminimumnzsminCyclev=casefindCyclesgvof[]->0c:cs->lengthc-1-- because v occurs twice in c, as startpoint and endpoint-- circumference = max cycle - Bollobas p104distancePartitiongv=distancePartition'S.empty(S.singletonv)wheredistancePartition'interiorboundary|S.nullboundary=[]|otherwise=letinterior'=S.unioninteriorboundaryboundary'=foldlS.unionS.empty[S.fromList(nbrsgx)|x<-S.toListboundary]S.\\interior'inS.toListboundary:distancePartition'interior'boundary'-- the connected component to which v belongscomponentgv=concat$distancePartitiongvisConnectedg@(G(v:vs)es)=length(componentgv)==length(v:vs)isConnected(G[][])=True-- MORE GRAPHS-- Generalized Johnson graph, Godsil & Royle p9-- Also called generalised Kneser graph, http://en.wikipedia.org/wiki/Kneser_graphjvki|v>=k&&k>=i=graph(vs,es)wherevs=combinationsOfk[1..v]es=[[v1,v2]|[v1,v2]<-combinationsOf2vs,length(v1`intersect`v2)==i]-- j v k i is isomorphic to j v (v-k) (v-2k+i), so may as well have v >= 2k-- kneser v k | v >= 2*k = j v k 0-- |kneser n k returns the kneser graph KG n,k --- whose vertices are the k-element subsets of [1..n], with edges joining disjoint subsetskneser::(Integralt)=>t->t->Graph[t]knesernk|2*k<=n=graph(vs,es)wherevs=combinationsOfk[1..n]es=[[v1,v2]|[v1,v2]<-combinationsOf2vs,disjointv1v2]johnsonvk|v>=2*k=jvk(k-1)bipartiteKnesernk|2*k<n=graph(vs,es)wherevs=mapLeft(combinationsOfk[1..n])++mapRight(combinationsOf(n-k)[1..n])es=[[Leftu,Rightv]|u<-combinationsOfk[1..n],v<-combinationsOf(n-k)[1..n],u`isSubset`v]desargues1=bipartiteKneser52-- Generalised Petersen graphs-- http://en.wikipedia.org/wiki/Petersen_graphgpnk|2*k<n=toGraph(vs,es)wherevs=mapLeft[0..n-1]++mapRight[0..n-1]es=(map.map)Left[[i,(i+1)`mod`n]|i<-[0..n-1]]++[[Lefti,Righti]|i<-[0..n-1]]++(map.map)Right[[i,(i+k)`mod`n]|i<-[0..n-1]]petersen2=gp52prismn=gpn1durer=gp62mobiusKantor=gp83dodecahedron2=gp102desargues2=gp103