Early Attempt at Finding Gram Matrices

The goal here was to use a formula found by Dylan to construct a massive system of equations and attempt to chuck it into Mathematica’s Solve function in hopes of getting the gram matrix out the other end, but this code at least didn’t end up working particularly well. There is no guarantee that these equations are solvable, which is unfortunate, and I think there are some mistakes or something in this implementation, because it should work with some polyhedra.

Get["https://raw.githubusercontent.com/szhorvat/IGraphM/master/IGInstaller.m"]

<<IGraphM`

Takes adjacency matrix and spits out graph

pgraph[adjmat_]:=PlanarGraph[AdjacencyGraph[adjmat,VertexLabels->"Name"]]

Takes adjacency matrix and spits out dual graph

dgraph[adjmat_]:=PlanarGraph[IGDualGraph[pgraph[adjmat],VertexLabels->"Name"]]

Takes adjacency matrix and spits out dual adjacency matrix

dadjmat[adjmat_]:=Normal[AdjacencyMatrix[dgraph[adjmat]]]

Takes adjacency matrix, graph, dual adjacency matrix, and dual graph and spits out extended gram matrix

exGmat[adjmat_,adjmatg_,adjmatd_,adjmatdg_]:=ArrayFlatten[{{Table[If[i==j,1,If[adjmat[[i,j]]==1,-1,If[i>j,(Subscript[b, j,i]),(Subscript[b, i,j])]]],{i,1,VertexCount[adjmatg]},{j,1,VertexCount[adjmatg]}],Table[If[MemberQ[IGFaces[adjmatg][[j]],i],0,(Subscript[b, i,j+VertexCount[adjmatg]])],{i,VertexCount[adjmatg]},{j,VertexCount[adjmatdg]}]},{Transpose[Table[If[MemberQ[IGFaces[adjmatg][[j]],i],0,(Subscript[b, i,j+VertexCount[adjmatg]])],{i,VertexCount[adjmatg]},{j,VertexCount[adjmatdg]}]],Table[If[i==j,1,If[adjmatd[[i,j]]==1,-1,If[i>j,(Subscript[b, j+VertexCount[adjmatg],i+VertexCount[adjmatg]]),(Subscript[b, i+VertexCount[adjmatg],j+VertexCount[adjmatg]])]]],{i,1,VertexCount[adjmatdg]},{j,1,VertexCount[adjmatdg]}]}}]

Computes entire extended gram matrix just given adjacency graph

fullExGmat[adjmat_]:=exGmat[adjmat,pgraph[adjmat],dadjmat[adjmat],dgraph[adjmat]]

Dylan’s formula: computes (Subscript[α, i,j]) given all bilinear forms between two tangent circles, c1 and c2, and their shared dual circle d

dylanFormula[i_,j_,c1_,c2_,d_]:=d[[i]]d[[j]]+c2[[i]]c2[[j]]-(1/2)(((((d[[i]])^2)+((c2[[i]])^2)-1)/(c1[[i]]+c2[[i]]))(c1[[j]]+c2[[j]])+((((d[[j]])^2)+((c2[[j]])^2)-1)/(c1[[j]]+c2[[j]]))(c1[[i]]+c2[[i]]))

Uses Dylan’s formula and the extended gram matrix to create the equations

eqs[i_,j_,c1_,c2_,d_,Gext_]:=dylanFormula[i,j,c1,c2,d]==Gext[[i,j]]

Creates a list of all relevant variables

allVars[n_,m_]:=Flatten[Table[(Subscript[b, i,j]),{i,n+m},{j,i+1,n+m}]]

Given the adjacency matrix and which three rows/columns to pick (I’d like to eventually automate this; should be pretty easy), gives the extended Gram matrix.
Ignore the warnings, everything actually works. Also we still have the problem with that one other face, but should be fairly easy to fix tomorrow.

findGextGivenAdjacency[adjmat_,c1_,c2_,d_]:=Block[{Gext,c1s,c2s,ds,n,m,rules,assumptions,temp},
n=Length[adjmat];
m=Length[dadjmat[adjmat]];
Gext=fullExGmat[adjmat];
c1s=Gext[[All,c1]];
c2s=Gext[[All,c2]];
ds=Gext[[All,d]];
assumptions=#≤0&/@allVars[n,m];
rules=Solve[Flatten[Table[If[SameQ[Gext[[i,j]],-1]||SameQ[Gext[[i,j]],0],eqs[i,j,c1s,c2s,ds,Gext],True],{i,n+m},{j,n+m}]]//DeleteCases[Indeterminate==__]//DeleteCases[False]//Simplify//DeleteCases[True]][[1]];
temp=Gext/.rules;
temp/.Solve[Det[temp]==0][[1]]]

Same as above, but numerically approximates it.

findGextGivenAdjacencyN[adjmat_,c1_,c2_,d_]:=Block[{Gext,c1s,c2s,ds,n,m,rules,assumptions},
n=Length[adjmat];
m=Length[dadjmat[adjmat]];
Gext=fullExGmat[adjmat];
c1s=Gext[[All,c1]];
c2s=Gext[[All,c2]];
ds=Gext[[All,d]];
assumptions=#≤0&/@allVars[n,m];
rules=NSolve[Flatten[Table[eqs[i,j,c1s,c2s,ds,Gext],{i,n+m},{j,n+m}]]//DeleteCases[Indeterminate==__]//Simplify//DeleteCases[True],Reals];
Select[Gext/.rules,AllTrue[#,#≤0||#==1||SameQ[Head[#],Subscript]&,2]&][[1]]]

It almost works with the tetrahedron.

tetradj=PolyhedronData["Tetrahedron","Skeleton"]//AdjacencyMatrix;

findGextGivenAdjacency[tetradj,1,2,5]//MatrixForm