(* first we make our icosohedron *)icoverts = With[{signs = 2 Table[IntegerDigits[i,2,3],{i,8}] - 1}, Union[Flatten[ Function[perm, perm # & /@ signs] /@ NestList[RotateRight, {0, 1, GoldenRatio}, 2], 1] ] ]norm[vec_] := N[Sqrt[vec . vec]]icoedges = Flatten[Table[ If[norm[icoverts[[i]] - icoverts[[j]] ] < 3, {{i,j}},{}], {i, 12}, {j, i+1, 12}], 2]icofaces = Flatten[Table[ If[MemberQ[icoedges, {a, b}] && MemberQ[icoedges, {b, c}] && MemberQ[icoedges, {a, c}], {{a,b,c}}, {}], {a, 12}, {b, a+1, 12}, {c, b+1, 12}], 3]icoadjacent = Flatten[Table[ If[Length[Intersection[icofaces[[i]], icofaces[[j]]]] == 2, {{i, j}}, {}], {i, 20}, {j, i+1, 20}], 2](* now we draw a hexagonal lattice for each face, and connect them *)domeedges[ord_] := Flatten[ {insideedges[#, ord] & /@ icofaces, edgeedges[#, ord] & /@ icoadjacent}, 2]insideedges[face_, order_] := Map[findpoint[face, #]&, Flatten[ Function[pt, {pt, pt + #} & /@ Permutations[{2, -1, -1}]] /@ (3 Flatten[Table[{i, j, order + 2 - i - j}, {i, order}, {j, order + 1 - i}], 1] - 1), 1], {2}]edgeedges[{faceind1_, faceind2_}, order_] := Module[{face1 = icofaces[[faceind1]], face2 = icofaces[[faceind2]], ourface1, ourface2}, ourface1 = Join[Intersection[face1, face2], Complement[face1, face2]]; ourface2 = Join[Intersection[face2, face1], Complement[face2, face1]]; Table[findpoint[#, {3 k + 1, 3 (order - k) + 1, 1}] & /@ {ourface1, ourface2}, {k, 0, order}]](* this decodes our obscure notation and presses the points onto a sphere *)findpoint[face_, coords_] := (N[# / norm[#]] &) [ Plus @@ ((icoverts[[#]]& /@ face) * coords / (Plus @@ coords))](* now we draw some pictures *)(* order 0: dodecahedron *)Show[Graphics3D[Line /@ domeedges[0]]];(* order 1: soccer ball *)Show[Graphics3D[Line /@ domeedges[1]]];(* top half of soccer ball, viewed from above *)Show[Graphics3D[{Line /@ domeedges[1], Polygon[1.1 {{-1,-1,0},{1,-1,0},{1,1,0},{-1,1,0}}] } ], ViewPoint -> {0,0,5}];(* order 2 *)Show[Graphics3D[Line /@ domeedges[2]]];(* order 2, top half, viewed from above *)Show[Graphics3D[{Line /@ domeedges[2], Polygon[1.1 {{-1,-1,0},{1,-1,0},{1,1,0},{-1,1,0}}] } ], ViewPoint -> {0,0,5}];(* order 3, top half, viewed from above *)Show[Graphics3D[{Line /@ domeedges[3], Polygon[1.1 {{-1,-1,0},{1,-1,0},{1,1,0},{-1,1,0}}] } ], ViewPoint -> {0,0,5}];(* order 3, top half *)Show[Graphics3D[Line /@ domeedges[3]], PlotRange -> 1.1 {{-1, 1}, {-1, 1}, {-.01, 1}}];(* order 4, top half *)Show[Graphics3D[Line /@ domeedges[4]], PlotRange -> 1.1 {{-1, 1}, {-1, 1}, {-.01, 1}}];
{{-1,-GoldenRatio,0},{-1,GoldenRatio,0},{0,-1,-GoldenRatio},{0,-1,GoldenRatio},{0,1,-GoldenRatio},{0,1,GoldenRatio},{1,-GoldenRatio,0},{1,GoldenRatio,0},{-GoldenRatio,0,-1},{-GoldenRatio,0,1},{GoldenRatio,0,-1},{GoldenRatio,0,1}}
{{1,3},{1,4},{1,7},{1,9},{1,10},{2,5},{2,6},{2,8},{2,9},{2,10},{3,5},{3,7},{3,9},{3,11},{4,6},{4,7},{4,10},{4,12},{5,8},{5,9},{5,11},{6,8},{6,10},{6,12},{7,11},{7,12},{8,11},{8,12},{9,10},{11,12}}
{{1,3,7},{1,3,9},{1,4,7},{1,4,10},{1,9,10},{2,5,8},{2,5,9},{2,6,8},{2,6,10},{2,9,10},{3,5,9},{3,5,11},{3,7,11},{4,6,10},{4,6,12},{4,7,12},{5,8,11},{6,8,12},{7,11,12},{8,11,12}}
{{1,2},{1,3},{1,13},{2,5},{2,11},{3,4},{3,16},{4,5},{4,14},{5,10},{6,7},{6,8},{6,17},{7,10},{7,11},{8,9},{8,18},{9,10},{9,14},{11,12},{12,13},{12,17},{13,19},{14,15},{15,16},{15,18},{16,19},{17,20},{18,20},{19,20}}
General::spell1:Possible spelling error: new symbol name "order is similar to existing symbol Order.