Dear all,

Many have perhaps done the infamous equivalent resistor of a cube question in their physics or (electrical) engineering classes. It is quite tricky as one can not reduce the resistors using the simple series-rule and parallel-rule for resistors. One has to do some more work: use symmetry or linear algebra to get to the right answer. I was actually interested in the equivalent resistor for an icosahedron:

Now imagine that all the edges are replaced by 1-Ohm resistors, what is the equivalent resistor of this network? The way of solving this is by using Kirchhoffs rules.

For every vertex the sum of the current must be 0 (what goes in must go out, otherwise it would accumulate at that vertex). For every edge I can relate the voltages at the ends of the edges (vertices).

V[a] - V[b] = i[a,b] r[a,b]

Since I presume all the resistors to be 1 ohm, this reduces the equation to:

V[a] - V[b] = i[a,b]

where we assume that V is in Volts and i in Amperes (i.e. both in derived SI units without prefixes). By applying a 1 volt difference between opposite ends and figure out how much current will flow we can calculate the equivalent resistance as 1/current.

I programmed this elaborate function to do all of that for me given a polyhedron:

ClearAll[EquivalentResistance,EquivalentResistanceHelper]
EquivalentResistance::invalidstartstop="Start and Stop should be distinct integers between 1 and `1` (inclusive)";
EquivalentResistance[poly_String]:=EquivalentResistance[poly,All]
EquivalentResistance[poly_String,Max]:=Block[{edges,dm,beginend},
    edges=PolyhedronData[poly,"EdgeIndices"];
    dm=DistanceMatrix[PolyhedronData[poly,"VertexCoordinates"]//N];
    beginend=FirstPosition[dm,Max[dm],{2}];
    Dataset[EquivalentResistanceHelper[poly,beginend]]
]
EquivalentResistance[poly_String,All]:=Block[{startsends},
    startsends=Subsets[Union@@PolyhedronData[poly,"EdgeIndices"],{2}];
    Dataset[Association[Thread[startsends->(EquivalentResistanceHelper[poly,#]&/@startsends)]]]
]
EquivalentResistance[poly_String,start_Integer]:=Block[{other},
    other=DeleteCases[Union@@PolyhedronData[poly,"EdgeIndices"],start];
    EquivalentResistance[poly,Thread[{start,other}]]
]
EquivalentResistance[poly_String,startsends:{{_,_}..}]:=Dataset[Association[Thread[startsends->(EquivalentResistanceHelper[poly,#]&/@startsends)]]]
EquivalentResistance[poly_String,{start_Integer,stop_Integer}]:=Dataset[EquivalentResistanceHelper[poly,{start,stop}]]
EquivalentResistanceHelper[poly_String,{start_Integer,stop_Integer}]:=Block[{resistors,edges,inout,begin,end,beginend,vertices,currentrulesin,currentrulesout,currentrules,voltrules,equations,variables,sols,totalcurrent,graphout,eqout,fullsolout,resout,i,V},
    resistors=edges=PolyhedronData[poly,"EdgeIndices"];
    If[1<=start<=Max[edges]\[And]1<=stop<=Max[edges]\[And]start=!=stop,
        {begin,end}=beginend={start,stop};
        edges=Join[edges,inout={{0,begin},{end,Max[edges]+1}}];
        {begin,end}=beginend={0,Max[edges]};
        graphout=HighlightGraph[Graph[UndirectedEdge@@@edges,VertexLabels->"Name",PlotRangePadding->Scaled[.15]],beginend~Join~(Style[#,Red]&/@(UndirectedEdge@@@resistors))];

        vertices=DeleteCases[Union@@edges,Alternatives@@beginend];
        currentrulesout=Table[Select[edges,First[#]==v&],{v,vertices}];
        currentrulesin=Table[Select[edges,Last[#]==v&],{v,vertices}];
        currentrulesin=Total/@Apply[i,currentrulesin,{2}];
        currentrulesout=Total/@Apply[i,currentrulesout,{2}];
        currentrules=Thread[currentrulesin-currentrulesout==0];

        voltrules=Join[V[#1]-V[#2]==i[#1,#2]&@@@edges[[;;-3]],V[#1]==V[#2]&@@@edges[[-2;;]],{V[begin]==1,V[end]==0}];

        equations=Join[voltrules,currentrules];
        variables=DeleteDuplicates[Cases[equations,i[_,_]|V[_],\[Infinity]]];
        sols=Sort@Solve[equations,variables][[1]];

        totalcurrent=i[0,start]/.sols;
        <|"Polyhedron"->poly,"Graph"->graphout,"Start"->start,"Stop"->stop,"Equations"->equations,"Solutions"->sols,"EquivalentResistance"->1/totalcurrent|>
    ,
        Message[EquivalentResistance::invalidstartstop,Max[edges]];
        Abort[]
    ]
]

Two-vertex specification

So how do we call this function? Well, there are several ways:

EquivalentResistance["Cube", {1, 2}]

This will give use the equivalent resistance between vertex 1 and 2 of a cube-network of resistors. It gives back a dataset:

Where the red-edges are 1-ohm resistors and the blue lines are our test-leads with no resistance. You can also see the equations and solutions to those equations:

with as many equations as solutions as it should.

Opposite ends

In addition, one can query the function like:

EquivalentResistance["Cube", Max]

which will find two 'opposite' ends of the cube, and calculate the resistance accordingly:

This is the classical problem many of us have solved in school (5/6 Ohm).

Multiple two-vertex specifications

One can also supply multiple pairs:

EquivalentResistance["Cube", {{1, 2}, {1, 6}, {1, 8}}]

giving a more elaborate dataset back:

Start vertex only

If one supplies only the starting point, it will find the resistance for all the other vertices:

EquivalentResistance["Cube", 3]

in this case it will find all the resistance with starting point 3:

All

Lastly one can specify All (or nothing)

EquivalentResistance["Cube", All] (* same as EquivalentResistance["Cube"] *)

to get a dataset with all possible combinations: 28 cases for a cube (8 edges: Pochhammer[7, 2]/2=28).

Solve original problem

Let's calculate the equivalent resistance for opposite points for all the platonic solids:

Dataset[Normal[EquivalentResistance[#,Max][{"Polyhedron","EquivalentResistance"}]]&/@PolyhedronData["Platonic"]]

giving:

Note that dataset shows numerical approximations of the actual values. The values are actually exact:

Values /@ Normal[%]

giving:

{{Cube,5/6},{Dodecahedron,7/6},{Icosahedron,1/2},{Octahedron,1/2},{Tetrahedron,1/2}}

Other examples

It also works (fast) with larger networks; say a bucky-ball shape:

EquivalentResistance["TruncatedIcosahedron", Max]

We can also make a table for all the non-compound polyhedrons what the equivalent resistances are:

alldata={#,EquivalentResistance[#,Max]["EquivalentResistance"]}&/@Select[Complement[PolyhedronData[],PolyhedronData["Compound"]],StringQ];
SortBy[Append[#,N[Last[#]]]&/@alldata,Last]//Grid

Some observations: some have an equivalent resistance smaller than 1, others bigger than 1. Somehow I would've expected that all would be smaller than 1 (there are always multiple paths to the ends). Also note that one gets very elaborate fractions for the more complex polyhedrons!

Conclusion

I hope you like this short exploration. One can easily extend this to arbitrary networks with arbitrary resistors. The methodology is the same: set up all the 'current rules', set up 'voltage rules', and some boundary conditions and solve it using Solve.