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