Bob Riehemann’s maddening Orange/Apple Peeling problem

Andy Long
April 8th, 2019

Also called the road-building problem, the idea is that you need to build a road on a spherical planet that puts every point on the surface of the planet within  ϵ  of the road. Minimize the length of the road. 

Or you might think about cell phone service: every point should be within ϵ in order to get good reception -- minimize the number of towers (which are placed along the continuous curve).

This is the “apple peeling” curve, I believe, for ϵ/3:

p1=Graphics3D[Sphere[{0,0,0}],Boxed->False];
turns=3/2;
xrho[ϕ_]:=Sin[ϕ]Cos[2 turns ϕ]
yrho[ϕ_]:=Sin[ϕ]Sin[2 turns ϕ]
zrho[ϕ_]:=Cos[ϕ]
p2=ParametricPlot3D[{xrho[ϕ],yrho[ϕ],zrho[ϕ]},{ϕ,0,π}];
Show[p1,p2]

If I recall correctly from the student talk, the length was quoted at 6.9something:

arcLengthOrangePeel=Integrate[Sqrt[(D[xrho[ϕ],ϕ])^2+(D[yrho[ϕ],ϕ])^2+(D[zrho[ϕ],ϕ])^2],{ϕ,0,π}]
N[%]

Now I think that this is at least related to the proposed “apple peeling” curve, for ϵ/3:

p1=Graphics3D[Sphere[{0,0,0}],Boxed->False];
p2=ParametricPlot3D[{Sin[u],0,Cos[u]},{u,0,2π/3}];
latitudeAtPhi[ϕ_,type_]:=ParametricPlot3D[{Sin[ϕ]Cos[ u-ϕ],Sin[ϕ]Sin[ u-ϕ],Cos[ ϕ]},{u,ϕ,ϕ+2π},PlotStyle->type]
p3a=latitudeAtPhi[π/3,Dashed];
p3b=latitudeAtPhi[2π/3,Solid];
Show[p1,p2,p3a,p3b]

Length of this curve is a little longer; I should note, however, that we’re not following a geodesic “around the  horn” -- but we have to stay in contact with the original circle -- which we’re not really doing with open circles, but I guess we’re within ϵ/3 of the points....

arcLengthOrangePeelToo=(Sqrt[3]+2/3)π
N[%]

Here are a few of the circles we’re using to trace out the path: I’d like to make a manipulate command which shows the parts of the sphere blacked out as we move the circle around....

p1=Graphics3D[Sphere[{0,0,0}],Boxed->False];
p2=ParametricPlot3D[{Sin[u],0,Cos[u]},{u,0,2π/3}];
circleAbout[a_,b_,c_,type_]:=
Module[{m=RollPitchYawMatrix[{a,b,c}]},
ParametricPlot3D[Dot[m,{Sin[π/3]Cos[ u-π/3],Sin[π/3]Sin[ u-π/3],Cos[ π/3]}],{u,π/3,π/3+2π},PlotStyle->{Red,type}]
]
p3a=latitudeAtPhi[π/3,Dashed];
p3b=latitudeAtPhi[2π/3,Solid];
p4a=circleAbout[0,π/3,π,Dashed];
p4b=circleAbout[0,2π/3,π,Dashed];
p4c=circleAbout[0,-2π/3,2π,Dashed];
Show[p1,p2,p3a,p3b,p4a,p4b,p4c]

p1=Graphics3D[Sphere[{0,0,0}],Boxed->False];
p2=ParametricPlot3D[{Sin[u],0,Cos[u]},{u,-2π/3,2π/3}];
circleAbout[a_,b_,c_,type_]:=
Module[{m=RollPitchYawMatrix[{a,b,c}]},
ParametricPlot3D[Dot[m,{Sin[π/3]Cos[ u-π/3],Sin[π/3]Sin[ u-π/3],Cos[ π/3]}],{u,π/3,π/3+2π},PlotStyle->{Red,type}]
]
p3a=latitudeAtPhi[π/3,Dashed];
p3b=latitudeAtPhi[2π/3,Solid];
p4a=circleAbout[0,π/3,π,Dashed];
p4b=circleAbout[0,2π/3,0,Dashed];
p4c=circleAbout[0,4π/3,2π,Dashed];
4Pi/3.0 + 2 Pi/3.0
Manipulate[
Show[p1,p2,p3a,p3b,p4a,p4b,p4c,circleAbout[0,asdf,2π,Dashed],PlotLabel->asdf/Pi],
{asdf, 0, 2Pi}
]

Manipulate[
Module[{m=RollPitchYawMatrix[{0,a,0}]},Show[p1,ParametricPlot3D[Dot[m,RollPitchYawMatrix[{0,2π/3,0}],{Sin[π/3]Cos[ u],Sin[π/3]Sin[ u],Cos[π/3]}],{u,π/3,π/3+2π},PlotStyle->{Black,Solid}]
]
],{a,0,2π}
]

Manipulate[
Module[{m=RollPitchYawMatrix[{a,0,0}]},Show[p1,p2,p3a,p3b,p4a,p4b,ParametricPlot3D[Dot[m,RollPitchYawMatrix[{0,2π/3,0}],{Sin[π/3]Cos[ u],Sin[π/3]Sin[ u],Cos[π/3]}],{u,π/3,π/3+2π},PlotStyle->{Black,Solid}]
]
],{a,0,2π}
]

This is my curve when you’ve got a flat orange. Consider small, circular elephants....

f[t_]=-Cos[t];
g[t_]=Sin[t];
p1=Show[
Table[
ParametricPlot[
{n (f[t]-(1+(-1)^n)/(2n)),n*g[t]},
{t,(n-1) Pi,n Pi},
Ticks->None,
PlotRange->{{-6,6},{-6,6}},
PlotStyle->Red
],
{n,1,5,1}
]
]

f[t_]=-Cos[t];
g[t_]=Sin[t];
Manipulate[
Module[{cx,cy,n},
n=Ceiling[time/Pi];
cx=n (f[time]-(1+(-1)^n)/(2n));
cy=n*g[time];
Show[
p1,
ParametricPlot[{f[t]+cx,g[t]+cy},{t,0,2Pi}]
]
],{time,0.01,5*Pi}
]

I need to create a function to draw a circle of certain angular radius on the unit sphere

Manipulate[
Module[{cx,cy,cz,m=RollPitchYawMatrix[{a,0,0}]},Show[p1,p2,p3a,p3b,p4a,p4b,ParametricPlot3D[Dot[m,RollPitchYawMatrix[{0,2π/3,0}],{Sin[π/3]Cos[ u],Sin[π/3]Sin[ u],Cos[π/3]}],{u,π/3,π/3+2π},PlotStyle->{Black,Solid}]
]
],{a,0,2π}
]

This is the real “apple peeling” curve, for ϵ/3:

halfLatitudeAtPhi[ϕ_,rotate_,bend_,type_,th_]:=
Module[{m=RollPitchYawMatrix[{rotate,bend,0}]},
ParametricPlot3D[
Dot[m,{Sin[ϕ]Cos[ u],Sin[ϕ]Sin[ u],Cos[ ϕ]}],
{u,0,π},
PlotStyle->{type,Thickness[th]}]
]
p1=Graphics3D[Sphere[{0,0,0}],Boxed->False];
nturns=3;
pturns=Show[
p1,
Table[
halfLatitudeAtPhi[ϕ,0,0,Red,(ϕ+1)/500],
{ϕ,0,Pi,Pi/nturns}
],
Table[
halfLatitudeAtPhi[ϕ,Pi,Pi/nturns,Blue,(ϕ+1)/500],
{ϕ,0,Pi,Pi/nturns}
]
]

length4=Pi(1.0+Sqrt[2])
length3=Pi Sqrt[3.0]