Gömböc

Author

Eric W. Weisstein
November 1, 2023

This notebook downloaded from http://mathworld.wolfram.com/notebooks/SolidGeometry/Gomboc.nb.

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

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

Graphic

GraphicsRow[
With[{opts=Sequence[Boxed->False,Axes->False]},{
Block[{β=0.15},SphericalPlot3D[(((1+4β Sin[θ]Cos[ϕ-5θ]))^(1/4)),θ,ϕ,opts]],
Block[{β=0.17},SphericalPlot3D[(((1+4β Sin[θ]Cos[ϕ-((3π)/2)(Cos[θ]-(((Cos[θ])^3)/3))]))^(1/4)),θ,ϕ,opts]]}],Spacings->-40]

Sloan Gömböc 1

https://arxiv.org/abs/2306.14914

Center of mass requirement

Integrate[((Sin[θ])^3)Exp[I 5θ],{θ,0,π}]

Block[{β=0.15},SphericalPlot3D[(((1+4β Sin[θ]Cos[ϕ-5θ]))^(1/4)),{θ,0,π},{ϕ,0,2π}]]

Plot

Table[SphericalPlot3D[(((1+4β Sin[θ]Cos[ϕ-5θ]))^(1/4)),θ,ϕ],{β,0,.15,.03}]

Manipulate[SphericalPlot3D[(((1+4β Sin[θ]Cos[ϕ-5θ]))^(1/4)),θ,ϕ],{β,0,.15}]

ParametricRegion

(r^4)≤1+4 β sin(θ) cos(ϕ-5 θ)

(x^2+y^2+z^2)^2≤1+4β Sin[ϕ]Cos[θ-5ϕ]/.{ϕ->ArcCos[(z/(Sqrt[(x^2)+(y^2)+(z^2)]))],θ->ArcTan[y,x]}

FullSimplify[%]

FullSimplify[%151/.{x->x/a,y->y/a,z->z/a},a>0]

gomboc1=With[{β=15/100},ImplicitRegion[((((x^2)+(y^2)+(z^2)))^2)≤1+4 (Sqrt[(((x^2)+(y^2))/((x^2)+(y^2)+(z^2)))]) β Sin[5 ArcSin[(z/(Sqrt[(x^2)+(y^2)+(z^2)]))]+ArcTan[y,x]],{x,y,z}]]

Region[gomboc1,Axes->True,Boxed->False,AxesLabel->{"x","y","z"},AxesOrigin->{0,0,0}]

dgomboc1=DiscretizeRegion[gomboc1]

BoundingBox

RegionBounds[dgomboc1]

((((x^2)+(y^2)+(z^2)))^2)≤1+4 (Sqrt[(((x^2)+(y^2))/((x^2)+(y^2)+(z^2)))]) β Sin[5 ArcSin[(z/(Sqrt[(x^2)+(y^2)+(z^2)]))]+ArcTan[y,x]]/.{x->0,y->0}

Maximize[{z,((((x^2)+(y^2)+(z^2)))^2)≤1+4 (Sqrt[(((x^2)+(y^2))/((x^2)+(y^2)+(z^2)))]) β },{x,y,z}]//FullSimplify

gomboc1/.{x->0,y->0}

Centroid

RegionCentroid[N[gomboc1]]//Timing

RegionCentroid[N[gomboc1,20]]//Timing

Integrate[Sin[ϕ]{Cos[θ]Sin[ϕ],Sin[θ]Sin[ϕ],Cos[ϕ]}(1+4β Sin[ϕ]Cos[θ-5ϕ]),{θ,0,2π},{ϕ,0,π}]

Volume

Volume[gomboc1]

Volume[N[gomboc1]]

Volume[DiscretizeRegion[gomboc1]]

Block[{β=0},Integrate[Sin[ϕ]{Cos[θ]Sin[ϕ],Sin[θ]Sin[ϕ],Cos[ϕ]}(1+4β Sin[ϕ]Cos[θ-5ϕ]),{θ,0,2π},{ϕ,0,π},{r,0,(Sqrt[(1+4β Sin[ϕ]Cos[θ-5ϕ])])}]]

Sloan Gömböc 2

Center of mass requirement

Integrate[((Sin[θ])^3)Exp[I ((3π)/2)(Cos[θ]-(((Cos[θ])^3)/3))],{θ,0,π}]

Plot

Table[SphericalPlot3D[(((1+4β Sin[θ]Cos[ϕ-((3π)/2)(Cos[θ]-(((Cos[θ])^3)/3))]))^(1/4)),θ,ϕ],{β,0,.17,.03}]

Manipulate[SphericalPlot3D[(((1+4β Sin[θ]Cos[ϕ-((3π)/2)(Cos[θ]-(((Cos[θ])^3)/3))]))^(1/4)),θ,ϕ],{β,0,.17}]

Region

(x^2+y^2+z^2)^2≤1+4β Sin[ϕ]Cos[θ-((3π)/2)(Cos[ϕ]-(((Cos[ϕ])^3)/3))]/.{ϕ->ArcCos[(z/(Sqrt[(x^2)+(y^2)+(z^2)]))],θ->ArcTan[y,x]}

gomboc2=With[{β=17/100},ImplicitRegion[((((x^2)+(y^2)+(z^2)))^2)≤1+4 (Sqrt[1-((z^2)/((x^2)+(y^2)+(z^2)))]) β Cos[(3/2) π (-((z^3)/(3 ((((x^2)+(y^2)+(z^2)))^(3/2))))+(z/(Sqrt[(x^2)+(y^2)+(z^2)])))-ArcTan[y,x]],{x,y,z}]]

Region[gomboc2,Axes->True,Boxed->False,AxesLabel->{"x","y","z"},AxesOrigin->{0,0,0}]

dr2=DiscretizeRegion[gomboc2]

BoundingBox

RegionBounds[dr2]

Centroid

RegionCentroid[N[gomboc2]]//Timing

RegionCentroid[N[gomboc2,20]]//Timing

Integrate[Sin[ϕ]{Cos[θ]Sin[ϕ],Sin[θ]Sin[ϕ],Cos[ϕ]}1+4β Sin[ϕ]Cos[θ-((3π)/2)(Cos[ϕ]-(((Cos[ϕ])^3)/3))],{θ,0,2π},{ϕ,0,π}]

Volume

Volume[gomboc2]

Volume[N[gomboc2]]

Volume[DiscretizeRegion[gomboc2]]

0-polyhedral Gömböc  (Domokos and Kovacs 2923)

N.B.: 0-polyhedra have their mass uniformly distributed among their vertices

Conway’s Spiral and a Discrete Gomboc with21 Point Masses
Gabor Domokos and Florian Kovacs

(((1,1))^S)

NormSquared[p_,q_]:=(p-q).(p-q)

soln={x,y}/.Solve[Dot[{x,y}-{x0,y0},{x,y}]==0&&NormSquared[{x,y},{0,0}]Tan[q]^2==NormSquared[{x,y},{x0,y0}],{x,y}]//FullSimplify

soln[[1]]

DropPerpendicular[{x0_,y0_},q_]:={Cos[q] (x0 Cos[q]-y0 Sin[q]),Cos[q] (y0 Cos[q]+x0 Sin[q])}

Approximate

qs=Reverse[{19.716,19.716,29.875,44.519,66.173}]Degree

ps=FoldList[DropPerpendicular,{0,1},qs]

Perpendicular:

Dot[#2-#1,#2]&@@@Partition[ps,2,1]

ps=Most@ps

Graphics[{AbsolutePointSize[8],Point[ps],Line[ps]}]

pts={#,0,#2}&@@@ps;

v=Prepend[
Flatten[Table[RotationMatrix[2Pi i/5,{0,0,1}].#&/@Rest[pts],{i,0,4}],1],
pts[[1]]]

Length[v]

Graphics3D[{Opacity[.6],ConvexHullRegion[v]},Boxed->False]

Mean[v]

zc[k_,q_]:=Module[{n=Length[q]},
((1+k Sum[Times@@Cos[Take[q,i]]Cos[Total[Take[q,i]]],{i,n}])/(1+k n))
]

zc[5,Most@qs]

Exact

qsexact=Rationalize[Reverse[{19.716,19.716,29.875,44.519,66.173}]]

psexact=FoldList[DropPerpendicular,{0,1},qsexact Degree];

psexact[[-1]]//N

ptsexact={#,0,#2}&@@@Most[psexact];

vexact=Prepend[
Flatten[Table[RotationMatrix[2Pi i/5,{0,0,1}].#&/@Rest[ptsexact],{i,0,4}],1],
pts[[1]]];

Length[vexact]

Graphics3D[{Opacity[.6],gomboc=ConvexHullRegion[vexact]},Boxed->False]

RootReduce/@FunctionExpand[v[[2]]]

ByteCount[gomboc]

Mean[v]//N

(((1,2))^S)

Graphics3D[{AbsolutePointSize[5],Point[{0,0,0}],Opacity[.2],SU[1,2]=ConvexHullRegion[{{0,374,0},{154,80,0},{124,-32,0},{81,-78,0},{47,-95,0},{24,-100,0},{-24,-100,0},{-47,-95,0},{-81,-78,0},{-124,-32,0},{-154,80,0},{0,-1200,5000}}]},Boxed->False]

Show[%,BoxRatios->1]

Reverse[Length/@List@@SU[1,2]]

(((1,3))^S)

Graphics3D[{AbsolutePointSize[5],Point[{0,0,0}],Opacity[.2],SU[1,3]=ConvexHullRegion[{{0,466,0},{166,70,0},{121,-47,0},{71,-87,0},{35,-100,0},{-35,-100,0},{-71,-87,0},{-121,-47,0},{-166,70,0},{0,-100,-900},{0,-100,900}}]},Boxed->False]

Show[%,BoxRatios->1]

Reverse[Length/@List@@SU[1,3]]

(((2,1))^S)

Graphics3D[{AbsolutePointSize[5],Point[{0,0,0}],Opacity[.2],SU[2,1]=ConvexHullRegion[{{0,374.328`,0},{153.589`,80.2023`,20},{124.268`,-32.3675`,14.9819`},{81.1006`,-77.5258`,8.45141`},{46.9121`,-94.4981`,3.41302`},{23.4562`,-100,0},{-23.4562`,-100,0},{-46.9121`,-94.4981`,3.41302`},{-81.1006`,-77.5258`,8.45141`},{-124.268`,-32.3675`,14.9819`},{-153.589`,80.2023`,20}}]},Boxed->False]

Graphics3D[{AbsolutePointSize[5],Point[{0,0,0}],Opacity[.2],SU[2,1]=ConvexHullRegion[Round[10^5{{0,374.328`,0},{153.589`,80.2023`,20},{124.268`,-32.3675`,14.9819`},{81.1006`,-77.5258`,8.45141`},{46.9121`,-94.4981`,3.41302`},{23.4562`,-100,0},{-23.4562`,-100,0},{-46.9121`,-94.4981`,3.41302`},{-81.1006`,-77.5258`,8.45141`},{-124.268`,-32.3675`,14.9819`},{-153.589`,80.2023`,20}}]/10^5]},Boxed->False]

Show[%,BoxRatios->1]

Reverse[Length/@List@@SU[2,1]]

should be {8, 11}

(((3,1))^S)

Graphics3D[{AbsolutePointSize[5],Point[{0,0,0}],Opacity[.2],SU[3,1]=ConvexHullRegion[Round[10^5{{0,334.907`,0},{145.019`,83.7267`,10},{145.019`,0,9.6018`},{94.9161`,-68.9606`,5.40618`},{53.5898`,-92.8203`,2.10256`},{26.7949`,-100,0},{-26.7949`,-100,0},{-53.5898`,-92.8203`,2.10256`},{-94.9161`,-68.9606`,5.40618`},{-145.019`,0,9.6018`},{-145.019`,83.7267`,10}}]/10^5]},Boxed->False]

Show[%,BoxRatios->1]

Reverse[Length/@List@@SU[3,1]]

Should be {8, 11}