Cubic Close Packing

Author

Eric W. Weisstein
January 4, 2019

This notebook downloaded from http://mathworld.wolfram.com/notebooks/ComputationalGeometry/CubicClosePacking.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/CubicClosePacking.html.

©2019 Wolfram Research, Inc. except for portions noted otherwise

SC (simple cubic)

ball[c_,r_,x_]:=SquaredEuclideanDistance[c,x]≤r^2

Show[Table[RegionPlot3D[ball[(i {1,0,0}+j{0,1,0}+k{0,0,1}),1/2,{x,y,z}],{x,0,1},{y,0,1},{z,0,1}],{i,-1,1},{j,-1,1},{k,-1,1}]]

Delauney/Voronoi

v=LatticeData["SimpleCubic","MinimalVectors"]//Normal

Graphics3D[Sphere[#,.1]&/@v]

Show[ConvexHullMesh[v],ImageSize->Small]

Show[DelaunayMesh[v],ImageSize->Small]

VoronoiMesh[v]

FCC (face-centered cubic)

https://www.nde-ed.org/EducationResources/CommunityCollege/Materials/Structure/metallic_structures.htm

ball[c_,r_,x_]:=SquaredEuclideanDistance[c,x]≤r^2

g2=Show[With[{r=(Sqrt[2])},
RegionPlot3D[ball[(Sqrt[2])#,1,{x,y,z}],{x,-r,r},{y,-r,r},{z,-r,r}]&/@Join[
{{-1,0,0},{1,0,0},{0,-1,0},{0,1,0},{0,0,-1},{0,0,1}},
Tuples[{-1,1},3]
]
],Boxed->False,Axes->False]

Show[
RegionPlot3D[ball[#,(2^(-1/2)),{x,y,z}],{x,-1,1},{y,-1,1},{z,-1,1}]&/@centers,Boxed->False,Axes->False]

centers=Join[IdentityMatrix[3],-IdentityMatrix[3],Tuples[{-1,1},3]];

g2=Show[With[{r=(Sqrt[2])},RegionPlot3D[ball[(Sqrt[2])#,1,{x,y,z}],{x,-r,r},{y,-r,r},{z,-r,r}]&/@centers],Boxed->False,Axes->False]

Show[Table[RegionPlot3D[ball[(i ({0,1,0}+{0,0,1})+j ({1,0,0}+{0,0,1})+k ({1,0,0}+{0,1,0}))/2,(1/(2(Sqrt[2]))),{x,y,z}],{x,0,1},{y,0,1},{z,0,1}],{i,-1,2},{j,-1,2},{k,-1,2}]]

Delauney/Voronoi

v=LatticeData["FaceCenteredCubic","MinimalVectors"]

Show[DelaunayMesh[v],ImageSize->Small]

VoronoiMesh[v]

v2=Join[
{{-1,0,0},{1,0,0},{0,-1,0},{0,1,0},{0,0,-1},{0,0,1}},
Tuples[{-1,1},3]
]

Show[ConvexHullMesh[v2],ImageSize->Small]

Show[DelaunayMesh[v2],ImageSize->Small]

Schematic

SetDirectory["/Users/eww/Documents/Troves/MathOzTeX/graphics/pdf/"]

g1=Import["ClosePackingFace.pdf"][[1]]

GraphicsRow[{g1,g2},ImageSize->500]

Packing density

N[(π/(3(Sqrt[2])))]

N[(π/(3(Sqrt[2]))),20]

Layers

SetDirectory["/Users/eww/Documents/Troves/MathOzTeX/graphics/eps/"]

g1=Import["ClosePackingTriangle.eps"]

g2=Import["cubpack0.eps"]

Graphic

From Ed Pegg, Jr.
Jan 2019

fcc=Select[Tuples[Range[-2,2],{3}],EvenQ[Total[#]]&]

(*cuboctahedron*)
cov=Select[fcc,Norm[#]==(Sqrt[2])&];
coe=Select[Subsets[cov,{2}],EuclideanDistance@@#==(Sqrt[2])&];

Graphics3D[{Opacity[.5], Sphere[#,Sqrt[2]/2]&/@Select[fcc,Norm[#]≤ Sqrt[2]&], Opacity[1], Green,Tube/@(rde/2), Red,Tube/@(coe) }, Boxed-> False, SphericalRegion-> True, ViewAngle-> Pi/10, ImageSize-> Large]

BCC (body-centered cubic)

https://www.nde-ed.org/EducationResources/CommunityCollege/Materials/Structure/metallic_structures.htm

ball[c_,r_,x_]:=SquaredEuclideanDistance[c,x]≤r^2

Show[With[{r=Sqrt[3]/2},
RegionPlot3D[ball[#,r,{x,y,z}],{x,-r,r},{y,-r,r},{z,-r,r}]&/@Append[Tuples[{-1,1},3],{0,0,0}]],Boxed->False,Axes->False]

Delauney/Voronoi

v=LatticeData["BodyCenteredCubic","MinimalVectors"]

Graphics3D[Sphere[#,.1]&/@v]

Show[ConvexHullMesh[v],ImageSize->Small]

Show[DelaunayMesh[v],ImageSize->Small]

VoronoiMesh[v]

Graphic

From Ed Pegg, Jr.
Jan 2019

bcc=Flatten[{2#,2#+1}&/@Tuples[Range[-1,1],{3}],1];

(*rhombic dodecahedron*)
rdv=Select[bcc, Norm[#]≤2&];
rde=Select[Subsets[rdv,{2}],EuclideanDistance@@#==(Sqrt[3])&];

(*truncated octahedron*)
tov=Select[Tuples[{-1,-1/2,0,1/2,1},{3}],Norm[#]==(Sqrt[5])/2&];
toe=Select[Subsets[tov,{2}],EuclideanDistance@@#==1/(Sqrt[2])&];

Graphics3D[{Opacity[.5], Sphere[#,Sqrt[3]/2]&/@Select[bcc,Norm[#]≤ 2&], Opacity[1], Red,Tube/@rde, Green,Tube/@toe}, Boxed-> False, SphericalRegion-> True, ViewAngle-> Pi/12, ImageSize-> Large]

Packing density

(8/8+1)(4/3)π (r^3)

(((4(r/(Sqrt[3]))))^3)

(((8 π (r^3))/3)/((64 (r^3))/(3 (Sqrt[3]))))

N[%,20]

Centers in the plane

s=Sqrt[3];
h=2Sqrt[2/3];
v=Flatten[{Table[{2x,0,0},{x,3}],
		 Table[{2x+1,s,0},{x,2}],
		{{4,2s,0}},
		{{4,2/3s,h}} ,
		Table[{2x,4/Sqrt[3],-h},{x,3}] ,
		Table[{2x+1,4/Sqrt[3]-s,-h},{x,2}], 
		{{4,4/Sqrt[3]-2s,-h}},
		{{4,2/3s,-2h}}  
},1];

p=Flatten[Table[{i,j},{i,Length[v]},{j,i+1,Length[v]}],1];
d=Table[Expand[(v[[p[[i,1]]]]-v[[p[[i,2]]]]).(v[[p[[i,1]]]]-v[[p[[i,2]]]])],
		{i,Length[p]}];

d

SquareIndices=Position[d,8]//Flatten;
SquareSides=Table[v[[p[[SquareIndices[[i]]]]]],{i,Length[SquareIndices]}];
SquareEdges=Select[SquareSides,#[[1]]+#[[2]]!={8,(4/(Sqrt[3])),-2 (Sqrt[(2/3)])}&];

circ[vv_List]:=Module[{c=Plus@@vv/4,r,t,i,s=1/2/Sqrt[2],n=20},
		r=Table[(vv[[i]]-c)/2,{i,4}];
		{
			Polygon[vv],
			Line[Table[c+r[[1]] Cos[t]+r[[2]] Sin[t],{t,0,2Pi,2Pi/n}]],
			Table[Line[Table[vv[[i]]+s((vv[[addn[i,1,4]]]-vv[[i]]) Cos[t]+(vv[[addn[i,3,4]]] -vv[[i]])Sin[t]),
					{t,0,Pi/2,Pi/(2n)}]],{i,4}]
		}
]

CuboctIndices=Position[d,4]//Flatten;

CuboctSides=Table[v[[p[[CuboctIndices[[i]]]]]],{i,Length[CuboctIndices]}];
cv=Union[Flatten[Table[CuboctSides[[i]],{i,Length[CuboctSides]}],1]].

sphere=Sphere[1,10,10];
sphere=Sphere[];
spheres={
		Table[TranslateShape[sphere,{2x,0,0}],{x,3}],
		Table[TranslateShape[sphere,{2x+1,s,0}],{x,2}],
		TranslateShape[sphere,{4,2s,0}],
		TranslateShape[sphere,{4,2/3s,h}],
		Table[TranslateShape[sphere,{2x,4/Sqrt[3],-h}],{x,3}],
		Table[TranslateShape[sphere,{2x+1,4/Sqrt[3]-s,-h}],{x,2}],
		TranslateShape[sphere,{4,4/Sqrt[3]-2s,-h}],
		TranslateShape[sphere,{4,2/3s,-2h}]
	};

hex[{i_,j_}]:=Module[{k},
		Line[Table[{i+Cos[2Pi k/6],j+Sin[2Pi k/6]},{k,0,6}]]
];

hexpts[{x_,y_},{x0_,y0_}]:=Module[{i,j},
{
			PointSize[.03],
     Table[Point[{x0+3i,y0+Sqrt[3]j}],{i,Ceiling[x/2]},{j,y}],
		  Table[Point[{x0+3i+3/2,y0+Sqrt[3]j+Sqrt[3]/2}],{i,x/2},{j,y}]
		}
];
hexarray[{x_,y_},{x0_,y0_}]:=Module[{i,j},
{
     Table[hex[{x0+3i,y0+Sqrt[3]j}],{i,Ceiling[x/2]},{j,y}],
		  Table[hex[{x0+3i+3/2,y0+Sqrt[3]j+Sqrt[3]/2}],{i,x/2},{j,y}]
		}
]

Show[Graphics[{hexarray[{5,4},{0,0}],
		{RGBColor[0,0,1],hexarray[{5,4},{1,0}]},
		{RGBColor[1,0,0],hexarray[{5,4},{1/2,Sqrt[3]/2}]},
			hexpts[{5,4},{0,0}],
			{RGBColor[0,0,1],hexpts[{5,4},{1,0}]},
			{RGBColor[1,0,0],hexpts[{5,4},{1/2,Sqrt[3]/2}]}
	}],
	AspectRatio->Automatic]

Show[Graphics[{hexarray[{5,4},{0,0}],
		{RGBColor[1,0,0],hexarray[{5,4},{1,0}]},
			hexpts[{5,4},{0,0}],
			{RGBColor[1,0,0],hexpts[{5,4},{1,0}]}
	}],
	AspectRatio->Automatic]

Graphics (old)

V5

<<Graphics`Shapes`

sphere=Sphere[1,10,10];
sphere=Sphere[];
cubic={
Table[TranslateShape[sphere,{-2/Sqrt[3]Cos[2Pi (i+1/4)/3],-2/Sqrt[3]Sin[2Pi (i+1/4)/3],h}],{i,3}],
		sphere,
		Table[TranslateShape[sphere,2{Cos[2Pi i/6],Sin[2Pi i/6],0}],{i,6}],
		Table[TranslateShape[sphere,{2/Sqrt[3]Cos[2Pi (i+1/4)/3],2/Sqrt[3]Sin[2Pi (i+1/4)/3],-h}],{i,3}]
};

aa=Table[{-2/Sqrt[3]Cos[2Pi (i+1/4)/3],-2/Sqrt[3]Sin[2Pi (i+1/4)/3],GoldenRatio},{i,3}];

Show[Graphics3D[Sphere[#,1]&/@Join[aa,Table[2{Cos[2Pi i/6],Sin[2Pi i/6],0},{i,6}],-aa],Boxed->False]]

<<Utilities`LiveGraphics3D`

WriteLiveForm["cubiccl.m",
	Show[Graphics3D[{cubic}],Boxed->False]]

v=Flatten[{
		Table[{-2/Sqrt[3]Cos[2Pi (i+1/4)/3],-2/Sqrt[3]Sin[2Pi (i+1/4)/3],h},{i,3}],
		{{0,0,0}},
		Table[2{Cos[2Pi i/6],Sin[2Pi i/6],0},{i,6}],
		Table[{2/Sqrt[3]Cos[2Pi (i+1/4)/3],2/Sqrt[3]Sin[2Pi (i+1/4)/3],-h},{i,3}]},1];

circ[vv_List]:=Module[{c=Plus@@vv/Length[v],r,t,i,s=1/2,segs=20,n=Length[vv]},
		r=Table[(vv[[i]]-c)/2,{i,n}];
		{
			Polygon[vv],
			Table[Line[Table[vv[[i]]+s((vv[[addn[i,1,n]]]-vv[[i]]) Cos[t]+(vv[[addn[i,-1,n]]] -vv[[i]])Sin[t]),
					{t,0,2Pi/n,Pi/(2segs)}]],{i,n}]
		}
]

norm[v_List]:=v/Sqrt[v.v];
tri[vv_List]:=Module[{c=Plus@@vv/3,r,rr,t,i,s=1,segs=20},
		r=Table[norm[c-vv[[i]]],{i,3}];
		rr=Table[norm[vv[[addn[i,1,3]]]-vv[[addn[i,2,3]]]],{i,3}];
		{
			Polygon[vv],
			Table[Line[Table[vv[[i]]+s(r[[i]] Cos[t]+rr[[i]]Sin[t]),
					{t,-Pi/6,Pi/6,Pi/(3segs)}]],{i,3}]
		}
]

WriteLiveForm["cubicso.m",
	Show[Graphics3D[{circ/@{v[[{1,3,8,9}]],
								v[[{5,6,11,13}]],v[[{2,6,7,3}]],
				v[[{9,10,13,12}]],v[[{1,2,5,10}]],v[[{11,7,8,12}]]},
				tri/@{v[[{1,10,9}]],v[[{10,5,13}]],v[[{6,11,7}]],v[[{7,3,8}]],
	v[[{1,2,3}]],v[[{2,5,6}]],
					v[[{11,12,13}]],v[[{8,9,12}]]}
			}],Boxed->False]]

Show[Graphics3D[{spheres}],Boxed->False,ViewPoint->{0,0,2}]

WriteLiveForm["cubpack1.m",
	Show[Graphics3D[{spheres}],Boxed->False]]

WriteLiveForm["cubpack2.m",
	Show[Graphics3D[{
spheres,
				Polygon/@{v[[{1,7,3,13}]],v[[{6,8,14,10}]],
					v[[{13,14,10,3}]],v[[{3,10,6,7}]],v[[{7,6,8,1}]],
					v[[{1,8,13,14}]]}
	}],Boxed->False]]

WriteLiveForm["cubpack3.m",Show[Graphics3D[circ/@{v[[{1,7,3,13}]],v[[{6,8,14,10}]],
					v[[{13,14,10,3}]],v[[{3,10,6,7}]],v[[{7,6,8,1}]],
					v[[{1,8,13,14}]]}],Boxed->False]]

WriteLiveForm["cubpack4.m",
	Show[NonIntersectingPolygons[Graphics3D[Polygon/@{cv[[{1,6,13}]],cv[[{1,9,13}]],
					cv[[{6,9,13}]],cv[[{1,9,13}]],cv[[{7,10,14}]],
					cv[[{2,10,14}]],cv[[{2,7,14}]],cv[[{2,7,10}]]}]],Boxed->False]]

Show[Graphics3D[
{Polyhedron[Tetrahedron],
Dual[Polyhedron[Tetrahedron]]}],Boxed->False]

Expansion

Show[Graphics3D[Polyhedron[RhombicDodecahedron]],Boxed->False]

WriteLiveForm["cubsqua.m",
Show[Graphics3D[RhombicDodecahedronExact],Boxed->False,ViewPoint->{0.87, 1.96, 2.60},ViewVertical->{0.52, -0.75, 0.39},SphericalRegion->True]]