Roman Surface

Author

Eric W. Weisstein
June 10, 2014

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Surfaces/RomanSurface.nb.

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

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

Definition

x[t_,p_]:=Cos[t]Sin[p]
y[t_,p_]:=Sin[t]Sin[p]
z[t_,p_]:=Cos[p]

RomanSurface[t_,p_]:={x[t,p]y[t,p],y[t,p]z[t,p],z[t,p]x[t,p]}

RomanSurface[u,v]

Equation

romeqn=(x^2+y^2+z^2-k^2)^2==((z-k)^2-2x^2)((z+k)^2-2y^2);

romsoln=Solve[romeqn,z]

rom1[x_,y_]:=z /. romsoln[[1]] /. k->1
rom2[x_,y_]:=z /. romsoln[[2]] /. k->1

ParametricPlot3D[
  Block[{x=r Cos[t],y=r Sin[t]},{x,y,#[x,y]}],{r,.0001,.9999},{t,0,2Pi},
  Boxed->False,Axes->False,PlotRange->All]&/@{rom1,rom2}

Show[%]

rs=ParametricPlot3D[Evaluate[RomanSurface[t,p]],
  {t,0,2Pi},{p,0,Pi/2},Boxed->False,Axes->False,PlotPoints->{30,30}]

{rs,Show[rs,ViewPoint->{2,2,2}]}

LiveGraphics3D

<<Utilities`LiveGraphics3D`

rs=ParametricPlot3D[Evaluate[RomanSurface[t,p]],
  {t,0,2Pi},{p,0,Pi/2},Boxed->False,Axes->False,PlotPoints->{30,30}]

WriteLiveForm["roman.m",rs]

Equations

Factor/@GroebnerBasis[Join[Thread[{x,y,z}==RomanSurface[u,v]],(Sin[#]^2+Cos[#]^2==1)&/@{u,v}],{x,y,z},{Cos[u],Sin[u],Cos[v],Sin[v]},MonomialOrder->EliminationOrder]

Factor/@GroebnerBasis[Join[Thread[{x,y,z}==a RomanSurface[u,v]],(Sin[#]^2+Cos[#]^2==1)&/@{u,v}],{x,y,z},{Cos[u],Sin[u],Cos[v],Sin[v]},MonomialOrder->EliminationOrder]

eqn=(x^2) (y^2)-a x y z+(x^2) (z^2)+(y^2) (z^2);

With[{r=.5},ContourPlot3D[(x^2) (y^2)+(x^2) (z^2)+(y^2) (z^2)==x y z,{x,-r,r},{y,-r,r},{z,-r,r},PlotPoints->30,MaxRecursion->3]]

With[{r=1},ContourPlot3D[(x^2) (y^2)+(x^2) (z^2)+(y^2) (z^2)==-x y z,{x,-r,r},{y,-r,r},{z,-r,r},PlotPoints->30,MaxRecursion->3]]

With[{r=1},ContourPlot3D[(x^2) (y^2)+(x^2) (z^2)+(y^2) (z^2)==2x y z,{x,-r,r},{y,-r,r},{z,-r,r},PlotPoints->30,MaxRecursion->3]]

With[{r=.5},RegionPlot3D[(x^2) (y^2)-x y z+(x^2) (z^2)+(y^2) (z^2)<0,{x,-r,r},{y,-r,r},{z,-r,r},PlotPoints->50,MaxRecursion->3]]

Properties

Curvatures[a RomanSurface[u,v],{u,v},FullSimplify[#,0<u<2π&&0<v<π/2&&a>0]&]

FullSimplify[PrincipalCurvatures[a RomanSurface[u,v],{u,v}],0<u<2π&&0<v<π/2&&a>0]

Singular Points

Block[{a=1},SingularPoints[eqn,{x,y,z}]]

Union[%]

Block[{a=1},SingularPoints[eqn,{x,y,z},WorkingPrecision->100]]//N

Surface Area

NIntegrate[√((1/256) (9+Cos[4 u] (-1+Cos[4 v])+7 Cos[4 v]) (5+3 Cos[4 u]-8 ((Cos[2 u])^2) Cos[2 v]-2 Cos[4 v] ((Sin[2 u])^2))-(1/4) ((Cos[v])^2) ((Sin[4 u])^2) ((Sin[v])^6)),{u,0,2π},{v,0,π/2}]

NIntegrate[√((1/256) (9+Cos[4 u] (-1+Cos[4 v])+7 Cos[4 v]) (5+3 Cos[4 u]-8 ((Cos[2 u])^2) Cos[2 v]-2 Cos[4 v] ((Sin[2 u])^2))-(1/4) ((Cos[v])^2) ((Sin[4 u])^2) ((Sin[v])^6)),{u,0,2π},{v,0,π/2},PrecisionGoal->6,WorkingPrecision->20]

Integrate[√((1/256) (9+Cos[4 u] (-1+Cos[4 v])+7 Cos[4 v]) (5+3 Cos[4 u]-8 ((Cos[2 u])^2) Cos[2 v]-2 Cos[4 v] ((Sin[2 u])^2))-(1/4) ((Cos[v])^2) ((Sin[4 u])^2) ((Sin[v])^6)),{u,0,2π},{v,0,π/2}]//Timing

Volume

NIntegrate[Boole[(x^2) (y^2)-x y z+(x^2) (z^2)+(y^2) (z^2)<0],{x,-∞,∞},{y,-∞,∞},{z,-∞,∞}]

NIntegrate[Boole[(x^2) (y^2)-x y z+(x^2) (z^2)+(y^2) (z^2)<0],{x,-1,1},{y,-1,1},{z,-1,1}]

Integrate[Boole[(x^2) (y^2)+(x^2) (z^2)+(y^2) (z^2)<a x y z],{x,-∞,∞},{y,-∞,∞},{z,-∞,∞},Assumptions->a>0]//Timing

Centroid

Integrate[{x,y,z}Boole[(x^2) (y^2)+(x^2) (z^2)+(y^2) (z^2)<a x y z],{x,-∞,∞},{y,-∞,∞},{z,-∞,∞},Assumptions->a>0]/(1/6)

Moment of Inertia

(i=With[{ρ=(M/((1/6)(a^3)))},ρ Integrate[{{y^2+z^2,-x y,-x z},
{-x y,z^2+x^2,-y z},
{-x z,-y z,x^2+y^2}}Boole[(x^2) (y^2)+(x^2) (z^2)+(y^2) (z^2)<a x y z],
{x,-∞,∞},{y,-∞,∞},{z,-∞,∞},Assumptions->a>0]
])//Timing

Animation

Show[rs,ViewPoint->{0,2,0},ViewVertical->{1,1,-1}]

<<Graphics`Animation`

SpinShow[rs]

SpinShow[rs]

Boy Surface-Roman Surface Animation

BoyRoman[alpha_,opts___]:=ParametricPlot3D[{
 (Sqrt[2]Cos[2u]Cos[v]^2+Cos[u]Sin[2v])/(2-alpha Sqrt[2]Sin[3u]Sin[2v]),
 (Sqrt[2]Sin[2u]Cos[v]^2-Sin[u]Sin[2v])/(2-alpha Sqrt[2]Sin[3u]Sin[2v]),
 3Cos[v]^2/(2-alpha Sqrt[2]Sin[3u]Sin[2v])},{u,-Pi/2,Pi/2},{v,0,Pi},opts,DisplayFunction->Identity][[1]]

Show[Graphics3D[BoyRoman[0]],Boxed->False]

Show[GraphicsArray[Partition[Graphics3D[BoyRoman[#],Boxed->False]&/@Range[0,1,.2],3]],GraphicsSpacing->{-.1,-.15},ImageSize->500]

Metric Properties

Metric Tensor

MetricTensor[RomanSurface[u,v],{u,v}]//FullSimplify

Christoffel Symbol of the Second Kind

FullSimplify[ChristoffelSymbols[RomanSurface[u,v],{u,v}],a>0]

Vector Properties

eqn=a{Cos[u] Sin[u] Sin[v]^2,Cos[v] Sin[u] Sin[v],Cos[u] Cos[v] Sin[v]};
rules={Abs[x_]^(n_/;Mod[n,2]==0):>x^n};
assum=a>0&&0<u<2π&&0<v<π/2;

Vector Length

Assuming[assum,FullSimplify[Norm[eqn]/.rules]]

Normal Vector

Assuming[assum,FullSimplify[NormalVector[eqn,{u,v}]/.rules]]