(* Mathematica program by Joel Karnofsky (+2010); extracted from <https://cs.nyu.edu/~gottlieb/tr/overflow/2003-dec-2.pdf> by _Hugo Pfoertner_, Nov 01 2020; modified by _Georg Fischer_, Nov 04 2020. In[1]:= Get["a180414.mma.txt"] {2, 4, 8, 16, 36, 80, 194, 506, 1400} Computes 9 terms in ~15s; takes hours for nmax = 10. *) nmax = 8; hGraphs[edges_]:=Flatten[Table[ graph[edges-1,Join[line[1,3,i,2],line[1,i+1,j,2],line[h1,j+1,edges-1,h2]]], {i,3,Floor[(edges+1)/2]},{j,i+1,edges-1},{h1,3,Floor[(i+3)/2]}, {h2,i+1,If[OddQ[i]&&h1==Floor[(i+3)/2],Floor[(j+i+1)/2],j]} ]]; line[first_,second_,nextLast_,last_]/;second>nextLast:={edge[first,last]}; line[first_,second_,nextLast_,last_]:=Join[ {edge[first,second]},edge@@@Partition[Range[second,nextLast],2,1],{edge[last,nextLast]} ]; oneMore[graph[nodes_,edges_]]:=Join[ normalForms[nodes,Rest@Flatten[ Table[Append[edges,edge[i,j]],{i,nodes-1},{j,i+1,nodes}],1]], normalForms[nodes+1,Table[Append[edges,edge[i,nodes+1]],{i,3,nodes}]] ]; normalForms[nodes_,edgeLists_]:=With[{ permRules=With[{list=Range[3,nodes]}, DeleteCases[Thread[list->#],HoldPattern[x_->x_]]&/@Permutations[list] ] }, graph[nodes,normalForm[#/.permRules]]&/@edgeLists ]; normalForm[fullList_]:=First@Map[Sort,Join[fullList,fullList/.{1->2,2->1}],{0,-2}]; lastOne[graph[nodes_,edges_]]:=Rest@Flatten[Table[ graph[nodes,Append[edges,edge[i,j]]],{i,nodes-1},{j,i+1,nodes}],1]; graphs[5]=hGraphs[5]; Do[ graphs[i]=Union@Flatten[Join[hGraphs[i],oneMore/@graphs[i-1]]], {i,6,nmax} ]; graphs[nmax+1]=Union@Flatten[Join[hGraphs[nmax+1],lastOne/@graphs[nmax]]]; resistance[graph[nodes_,edges_]]:=Module[{adjacentEdges,firstEdges,paths}, adjacentEdges=Split[Sort[Join[edges,Reverse/@edges]],First[#1]==First[#2]&]; adjacentNodes=Union/@Map[Last,adjacentEdges,{2}]; If[Min@@(Length/@adjacentNodes)==1,Return[1]]; paths=Reap[nextNode[{1}]][[-1,-1]]; firstEdges=First[adjacentEdges]; 1/Plus@@(x@@@firstEdges/.First@Solve[ Join[ Thread[Plus@@@Apply[x,Partition[#,2,1]&/@paths,{2}]==1 ], Thread[Plus@@@Apply[x,Drop[adjacentEdges,2],{2}]==0] ], x@@@firstEdges, x@@@Complement[edges,firstEdges] ]) ]; nextNode[path_]:=Scan[ If[#==2,Sow[Append[path,2]],If[FreeQ[path,#],nextNode[Append[path,#]]]]&, adjacentNodes[[Last[path]]] ]; x[i_,j_]/;i>j=-x[j,i]; values[1]={1,Infinity};graphs[_]={}; values[n_]:=values[n]=Union@Flatten[{ resistance/@graphs[n], Table[Outer[serialParallel,values[n-i],values[i]],{i,1,Floor[n/2]}] }]; serialParallel[Infinity,Infinity]=Infinity; serialParallel[v1_,v2_]:={v1+v2,1/(1/v1+1/v2)}; Print[Table[Length@values[i], {i,nmax+1}]]; (* 2, 4, 8, 16, 36, 80, 194, 506, 1400, 4039, 12044 In particular, the answer for the original 10 resistor problem is 4039. *)