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

**Re: Does Mathematica really need more printed, introductory documentation?**

**Re: Re: Does Mathematica really need more printed,**

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

**Common Multiple Value Question**