In[]:=
Plot3D[1,{x,-10,10},{y,-10,10},MeshAll,PlotPoints50]
Out[]=
In[]:=
DiscretizeGraphics[%]
Out[]=
In[]:=
MeshConnectivityGraph[%,2]
Out[]=
LatticeData[
spheres.eps
spheres.eps
icoverts=With[{signs=2Table[IntegerDigits[i,2,3],{i,8}]-1},Union[Flatten[Function[perm,(perm#1&)/@signs]/@NestList[RotateRight,{0,1,GoldenRatio},2],1]]];
norm[vec_]:=
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[(icofaces〚i〛)⋂(icofaces〚j〛)]==2,{{i,j}},{}],{i,20},{j,i+1,20}],2];
SphereLayout[ord_]:=Flatten[{(insideedges[#1,ord]&)/@icofaces,(edgeedges[#1,ord]&)/@icoadjacent},2]
insideedges[face_,order_]:=Map[findpoint[face,#1]&,Flatten[Function[pt,({pt,pt+#1}&)/@Permutations[{2,-1,-1}]]/@(3Flatten[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[face1⋂face2,Complement[face1,face2]];ourface2=Join[face2⋂face1,Complement[face2,face1]];Table[(findpoint[#1,{3k+1,3(order-k)+1,1}]&)/@{ourface1,ourface2},{k,0,order}]]
findpoint[face_,coords_]:=N&Plus@@
#1
norm[#1]
(icoverts〚#1〛&)/@facecoords
Plus@@coords
T=Table[Graphics3D[{AbsoluteThickness[.3],Line/@SphereLayout[i]},BoxedFalse,BoxStyle{AbsoluteDashing[{1,1}],AbsoluteThickness[.25]}],{i,0,3}];
<<"Graphics`Polyhedra`"
Wireframe[l_List]:=(l/.Polygonline)
line[l_List]:=Line[Join[l,{l[[1]]}]]
buckyball=Graphics3DAbsoluteThickness[.25],WireframeFirstTruncatePolyhedron[Icosahedron],,BoxedFalse,BoxStyle{AbsoluteDashing[{1,1}],AbsoluteThickness[.25]};
1
3
Show[GraphicsRow[{T[[1]],buckyball,T[[2]],T[[3]],T[[4]]},-.1]];
PSWrite["spheres.eps",%,1.1NoteColumn];
Hex
Hex
In[]:=
PNHexGrid[w_,h_]:=Block[{width=w+3,nodes},nodes=Join@@Table[i->hexneighbors[i],{j,h},{i,j*width,j*width+w}];MakeTrivalent[nodes]/.(a_->b_List):>(a->{b,hexposition[a]})]
In[]:=
fixup[{x_,y_}]:=x+widthy
In[]:=
hexneighbors[n_]:=With[{x=Mod[n,width],y=Floor[n/width]},fixup/@If[EvenQ[x+y],{{x-1,y},{x,y+1},{x+1,y}},{{x-1,y},{x+1,y},{x,y-1}}]]
In[]:=
hexposition[n_]:=With[{x=Mod[n,width],y=Floor[n/width]},{xSqrt[.75],1.5y-.5Mod[x+y,2]}]
In[]:=
MakeTrivalent[l_]:=With[{n=FixedPoint[removeHairs,l]},FixedPoint[removeBivalent,n]]
In[]:=
removeHairs[l_]:=DeleteCases[DeleteCases[l,_Integer?(Not[MemberQ[First/@l,#]]&),4],_->({_}|{})]
In[]:=
removeBivalent[l:{d___,a_->{b_,c_},e___}]:=(#/.Other[x_,y_]:>x+y-First[#]&)/@({d,e}/.a->Other[b,c])
In[]:=
removeBivalent[l_]:=#/.(a_->{b___,c_,d___,c_,e___}):>(a->{b,c,d,e})&/@l
In[]:=
PNHexGrid[30,30];
In[]:=
Function[p,First[p]#&/@p[[2,1]]]/@%;
In[]:=
Graph[Flatten[%]]
Out[]=
NKS Code
NKS Code