Re: Cropping a surface to a sphere (fun Manipulate example)

• To: mathgroup at smc.vnet.net
• Subject: [mg88278] Re: Cropping a surface to a sphere (fun Manipulate example)
• From: Szabolcs Horvát <szhorvat at gmail.com>
• Date: Wed, 30 Apr 2008 04:26:03 -0400 (EDT)
• Organization: University of Bergen
• References: <fv42mu\$624\$1@smc.vnet.net> <fv6uk6\$rmf\$1@smc.vnet.net>

```David Park wrote:
> This is nice Craig, but unfortunately ContourPlot3D is not the fastest of
> routines. So, on my machine at least, the response is quite slow.
>
> But, looking at the plot, there is obvious symmetry. There appears to be
> only one fundamental surface which is present in 12 copies. So would it be
> possible to use Reduce to obtain a parametrization of one of the surfaces
> and use rotation/reflection geometric transformations to generate all the
> other surfaces? This might then be much faster. For those who are experts in
> group theory, how would one start with the polynomial and then generate the
> set of transformations to create all the surfaces?
>
> I put this forward as a challenge problem for those who might care to take
> it up.
>

Hello,

I don't think that it is possible to construct a formula that represents
only one of the 12 surfaces because this is what the polynomial really
looks like:

poly = -x^4 y^2 + x^2 y^4 + x^4 z^2 - y^4 z^2 - x^2 z^4 + y^2 z^4
Factor[poly]

-(x - y) (x + y) (x - z) (y - z) (x + z) (y + z)

I tried generating only one surface with Plot3D, and then transforming
it, but unfortunately it is still quite slow.  I believe that the
bottleneck is Plot3D, so if someone could find a better way to generate
a single surface, it might be possible to make this run faster.

We can rotate the whole thing by Pi/4 (variable change (x,y) -> (a,b))
to make it suitable for plotting with Plot3D:

Solve[poly == u &&
(x - y)/Sqrt[2] == -a && (x + y)/Sqrt[2] == b, z, {x, y}]

We shall use the following solution:

sol[a_, b_, u_] =
Sqrt[a^2/2 + b^2/2 + Sqrt[2 a^4 b^4 + a b u]/(Sqrt[2] a b)]

Here's what this surface looks like:

Manipulate[
Plot3D[
sol[a, b, u],
{a, 0.002, 3 Sqrt[2]}, {b, 0.002, 3 Sqrt[2]},
RegionFunction -> Function[{x, y, z}, x^2 + y^2 + z^2 < 9],
PlotRange -> All,
BoxRatios -> Automatic],
{u, 0, 1}]

(This is not a very good way to plot it because it goes to infinity at a
== 0 and b == 0.  Perhaps it would be better to tilt it before plotting
to avoid this.)

Let us generate the rotations:

cp = Composition; (* I just don't like to type much *)

{t1, t2, t3} =
Table[RotationTransform[Pi/2, axis],
{axis, {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}}}];

(* These transformations will generate the group that we need: *)

base = {cp[t2, t1], cp[t3, t2], cp[t1, t3]}

(* Generate all rotations with brute-force method: *)

group = FixedPoint[Union@Flatten[{#, Outer[cp, base, #]}] &, base]

And finally assemble everything:

Manipulate[
With[
{gg = GeometricTransformation[
First @ Plot3D[
sol[a, b, u] // Evaluate,
{a, 0.002, 3 Sqrt[2]}, {b, 0.002, 3 Sqrt[2]}, PlotRange -> All,
Mesh -> False,
RegionFunction -> Function[{x, y, z}, x^2 + y^2 + z^2 < 9]
(*, PerformanceGoal -> "Quality" *)],
RotationTransform[Pi/4, {0, 0, 1}]
]},
Graphics3D[GeometricTransformation[gg, #] & /@ group,
Boxed -> False, SphericalRegion -> True]
],
{u, 0, 1}]

One might want to uncomment PerformanceGoal -> "Quality", but it will be
terribly slow.

Compare with the original version:

Manipulate[
ContourPlot3D[poly == u, {x, -3, 3}, {y, -3, 3}, {z, -3, 3},
RegionFunction -> Function[{x, y, z}, x^2 + y^2 + z^2 < 9],
Mesh -> False, Axes -> False, Boxed -> False,
SphericalRegion -> True],
{u, 0, 1}]

Szabolcs

```

• Prev by Date: Re: Does Mathematica really need more printed, introductory documentation?
• Next by Date: Re: Re: Does Mathematica really need more printed,
• Previous by thread: Re: Cropping a surface to a sphere (fun Manipulate example)
• Next by thread: Common Multiple Value Question