Facially Complete Planar Embedding

Author

Eric W. Weisstein
August 22, 2024

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/FaciallyCompletePlanarEmbedding.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/FaciallyCompletePlanarEmbedding.html.

©2024 Wolfram Research, Inc. except for portions noted otherwise

Definition

From Stan Wagon 2024-08-20:

A plane graph is facially complete if it becomes complete when edges are added for every two vertices that lie on a common face.

FaciallyCompleteGraphQ[g_Graph]:=Module[
(* assumes graph given is a planar embedding of a planar graph *)
{faces,newedges},
faces=Select[IGraphM`IGFaces[IGraphM`IGCoordinatesToEmbedding[g]],Length[#]>3&];
newedges=Complement[Union@@(Subsets[Sort[#],{2}]&/@faces),List@@@(Sort/@EdgeList[g])];
CompleteGraphQ[EdgeAdd[g,UndirectedEdge@@@newedges]]
]

Compute

<<MathWorld`Graphs`

2-connected planar graphs with n nodes

A021103

Planar2ConnectedGraphs[n_]:=Select[PlanarConnectedGraphs[n],KVertexConnectedGraphQ[#,2]&]

Table[Length@Planar2ConnectedGraphs[n],{n,8}]

2-connected plane graphs with n nodes

A034889

Planar2ConnectedGraphEmbeddings[n_]:=Flatten[PlanarGraphEmbeddings[PlanarGraph[#]]&/@Planar2ConnectedGraphs[n]]

Table[Length@Planar2ConnectedGraphEmbeddings[n],{n,7}]//Timing

Table[Length@Flatten@Import[FileNameJoin[{"/Users/eww/Documents/Mathematica/Paclets/GraphData/Enumerations/Planar2ConnectedEmbeddings","Planar2ConnectedEmbeddings_0"<>ToString[n]<>".m"}]],{n,8}]//Timing

GraphicsGrid[
Flatten[
Partition[#,UpTo[5]]&/@DeleteCases[Table[StyleGraphs/@Planar2ConnectedGraphEmbeddings[n],{n,5}],{}],1],Dividers->{{Thick,{True},Thick},{Thick,Thick,Thick,True,Thick}}]

Facially complete

A375617

Table[Count[Planar2ConnectedGraphEmbeddings[n],_?FaciallyCompleteGraphQ],{n,6}]//Timing

Table[Count[Planar2ConnectedGraphEmbeddings[n],_?FaciallyCompleteGraphQ],{n,7}]//Timing

Table[Count[Flatten@Import[FileNameJoin[{"/Users/eww/Documents/Mathematica/Paclets/GraphData/Enumerations/Planar2ConnectedEmbeddings","Planar2ConnectedEmbeddings_0"<>ToString[n]<>".m"}]],_?FaciallyCompleteGraphQ],{n,8}]//Timing

GraphicsGrid[
Flatten[
Partition[#,UpTo[6]]&/@DeleteCases[Table[StyleGraphs/@Select[Planar2ConnectedGraphEmbeddings[n],FaciallyCompleteGraphQ],{n,6}],{}],1],Dividers->{{Thick,{True},Thick},{Thick,Thick,Thick,Thick,True,True,Thick}}]

Counts

A375617

These numbers count the 2-connected facially complete plane graphs with n vertices

prism[n_]:=Floor[((n-3)^2+6)/12]
tetrahedral[n_]:=type1[n-1]
bipartite[n_]:=type1[n-2]
wheel[n_]:=(Mod[n-1,2]+3)2^Quotient[n-1,2]/4+DivisorSum[n-1,EulerPhi[#]2^((n-1)/#)&]/(2(n-1))-3
cycle[n_]:=Module[{f,F,x},
f[x_,m_]:=x+Sum[(Binomial[s-2,r-1]Binomial[r+s-1,s]x^s)/r,{r,m},{s,2,m}];
F[x_,m_]:=Series[((3x^2-2x f[x,m]+f[x,m]^2)-(2+2x+7x^2-4x f[x,m]+2f[x,m]^2)f[x^2,m]+2f[x^2,m]^2)/(4(2f[x^2,m]-1))+Sum[If[Mod[k,d]==0,(EulerPhi[d]f[x^d,m]^(k/d))/k,0],{k,3,m},{d,k}]/2,{x,0,m}];
CoefficientList[F[x,n],x][[-1]]]

a[1]=a[2]=0;
a[n_]:=prism[n]+tetrahedral[n]+bipartite[n]+wheel[n]+cycle[n]

(seq=Table[a[n],{n,40}])//Timing

Very slightly faster to define f and F globally:

f[x_,m_]:=x+Sum[(Binomial[s-2,r-1]Binomial[r+s-1,s]x^s)/r,{r,m},{s,2,m}]
F[x_,m_]:=Series[((3x^2-2x f[x,m]+f[x,m]^2)-(2+2x+7x^2-4x f[x,m]+2f[x,m]^2)f[x^2,m]+2f[x^2,m]^2)/(4(2f[x^2,m]-1))+Sum[If[Mod[k,d]==0,(EulerPhi[d]f[x^d,m]^(k/d))/k,0],{k,3,m},{d,k}]/2,{x,0,m}]

cycle[n_]:=CoefficientList[F[x,n],x][[-1]]

(seq=Table[a[n],{n,40}])//Timing

seq=Monitor[Table[a[n],{n,100}],n];//Timing

BFile[seq,375617,"~/b375617.txt"]

A001399[n_]:=Round[(n+3)^2/12]

Table[type1[n]-A001399[n-6],{n,40}]//Union

Table[type2[n]-A001399[n-7],{n,40}]//Union

Table[type3[n]-A001399[n-8],{n,40}]//Union

A056342[n_]:=(Mod[n,2]+3)2^Quotient[n,2]/4+DivisorSum[n,EulerPhi[#]2^(n/#)&]/(2n)-2

Table[type4[n]-(A056342[n-1]-1),{n,3,20}]

A001004[n_]:=Module[{f,F,x},
f[x_,m_]:=x+Sum[(Binomial[s-2,r-1]Binomial[r+s-1,s]x^s)/r,{r,m},{s,2,m}];
F[x_,m_]:=Series[((3x^2-2x f[x,m]+f[x,m]^2)-(2+2x+7x^2-4x f[x,m]+2f[x,m]^2)f[x^2,m]+2f[x^2,m]^2)/(4(2f[x^2,m]-1))+Sum[If[Mod[k,d]==0,(EulerPhi[d]f[x^d,m]^(k/d))/k,0],{k,3,m},{d,k}]/2,{x,0,m}];
CoefficientList[F[x,n],x][[-1]]]

(seq=Table[type5[n]-A001004[n],{n,3,20}])//Union

Table[A001399[n-6]+A001399[n-7]+(A056342[n-1]-1)+A001399[n-8]+A001004[n],{n,3,40}]

Length[seq=Import["~/b375617.txt","Table"][[3;;-2,2]]]

seq

FindLinearRecurrence[seq]//Head//Timing

FindGeneratingFunction[seq,x]//Head//Timing