In[]:=
CompoundExpression[
]
​​deploy
Wed 1 Nov 2023 19:52:36
Sphere visualization from:
- https://stanislavfort.com/blog/sphere-spilling-out/​
​

Sphere packing visualization in 2D

Cube (-2a,-2a,...,-2a) -> (2a, 2a, ..., 2a)
In[]:=
ClearAll["Global`*"];​​d=2;(*truedimension*)​​​​norm2[vec_]=Total[vec*vec];​​​​visualize[d_]:=Module{},​​(*vec1,vec2determinetheplaneofoursection*)​​vec1={1}~Join~ConstantArray[0,d-1];​​vec2=Normalize[{0}~Join~ConstantArray[1,d-1]];​​mat={vec1,vec2};​​​​a=1;​​​​as=ConstantArray[a,d-1];​​zeros=ConstantArray[0,d];​​​​(*Radiusofinscribedsphere*)​​R=a
d
-1;​​​​(*Cornerspherespassingthroughthesection*)​​c1={-a}~Join~as;​​c2={a}~Join~as;​​c3={-a}~Join~(-as);​​c4={a}~Join~(-as);​​​​sphere[center_,radius_]:=norm2[{x,y}.mat-center]<=
2
radius
;​​cornerSpheres=sphere[#,a]&/@{c1,c2,c3,c4};​​centerSphere=sphere[zeros,R];​​​​spherePlot=RegionPlot@@{centerSphere}~Join~cornerSpheres,x,-
2
a
d
-a,
2
a
d
+a,y,-
2
a
d
-a,
2
a
d
+a,AspectRatio->1,Frame->False;​​​​{c1,c2,c3,c4}=Tuples{-2a,2a},-2a
d-1
,2a
d-1
;​​cubePlot=Graphics[Line[{c1,c2,c4,c3,c1}]];​​​​ShowspherePlot,cubePlot,PlotRange->-2a
d-1
,2a
d-1
,-2a
d-1
,2a
d-1
​​;​​​​visualize[2]​​visualize[3]
Out[]=
Out[]=
In[]:=
pics=Table[visualize[d],{d,2,10}];​​grid=Partition[pics,3];​​GraphicsGrid[grid,Spacings->{0,0}]
Out[]=

Sphere packing visualization in 3D

In[]:=
​​ClearAll["Global`*"];​​​​ClearAll["Global`*"];​​dvis=2;(*visdimension*)​​d=3;(*truedimension*)​​​​norm2[vec_]=Total[vec*vec];​​​​​​(*vec1,vec2determinetheplaneofoursection*)​​vec1={1}~Join~ConstantArray[0,d-1];​​vec2=Normalize[{0}~Join~ConstantArray[1,d-1]];​​mat={vec1,vec2};​​​​as=ConstantArray[a,d-1];​​zeros=0*as;​​zeros=ConstantArray[0,d];​​a=1;​​​​(*Radiusofinscribedsphere*)​​R=a
d
-1;​​​​(*Cornerspherespassingthroughthesection*)​​c1={-a}~Join~as;​​c2={a}~Join~as;​​c3={-a}~Join~(-as);​​c4={a}~Join~(-as);​​​​sphere[center_,radius_]:=norm2[{x,y}.mat-center]<=
2
radius
;​​cornerSpheres=sphere[#,a]&/@{c1,c2,c3,c4};​​centerSphere=sphere[zeros,R];​​​​a=1;​​​​vec1={1}~Join~ConstantArray[0,d-1];​​vec2=Normalize[{0}~Join~ConstantArray[1,d-1]];​​mat={vec1,vec2};​​​​normal=Cross@@mat;​​sphere[center_,radius_]:=And@@{norm2[{x,y,z}-center]<=
2
radius
,normal.{x,y,z}<0};​​cornerSpheres=sphere[#,a]&/@{c1,c2,c3,c4};​​centerSphere=sphere[zeros,R];​​​​(*regionPlot=RegionPlot3D@@{centerSphere}~Join~cornerSpheres,x,-
2
a
d
-a,
2
a
d
+a,y,-
2
a
d
-a,
2
a
d
+a,z,-
2
a
d
-a,
2
a
d
+a,AspectRatio->1,Mesh->None,PlotPoints->50,MaxRecursion->2;​​​​Show[Graphics3D[{Opacity[.5],Cuboid[{-2,-2,-2},{2,2,2}],Opacity[.5]}],regionPlot]​​*)​​​​halfCube=Graphics3D@Polyhedron[{{-2,-2,-2},{2,-2,-2},{2,-2,2},{-2,-2,2},{2,2,2},{-2,2,2}},{{1,2,3,4},{3,4,6,5},{1,2,5,6},{2,3,5},{1,4,6}}];​​​​c1={-a}~Join~as;​​c2={a}~Join~as;​​c3={-a}~Join~(-as);​​c4={a}~Join~(-as);​​​​c5={a,a,-a};​​c6={-a,a,-a};​​​​sphere[center_,radius_]:=norm2[{x,y}.mat-center]<=
2
radius
;​​cornerSpheres=Sphere[#,a]&/@{c1,c2,c3,c4};​​sideSpheres=Sphere[#,a]&/@{c5};​​centerSphere=Sphere[zeros,R];​​​​regionPlot=Graphics3D[cornerSpheres~Join~{Opacity[1]}~Join~sideSpheres~Join~{Opacity[1],RGBColor[0.57`,0.54`,1],centerSphere}];​​Show[regionPlot,halfCube,PlotRange->{{-2,2},{-2,2},{-2,2}}]​​