Re: 3D ContourGraphics alternative

*To*: mathgroup at smc.vnet.net*Subject*: [mg65716] Re: [mg65683] 3D ContourGraphics alternative*From*: "David Park" <djmp at earthlink.net>*Date*: Sun, 16 Apr 2006 01:45:21 -0400 (EDT)*Sender*: owner-wri-mathgroup at wolfram.com

It is difficult to understand exactly what your graphic objective is. I will take it that you want to plot the surfaces given by implicit equations. The first surface... z^2 == 1 - (2 - Sqrt[x^2 + y^2])^2 is nothing more than a torus with large radius a == 2 and small radius b == 1. It can be parameterized by.. torus[a_, b_][u_, v_] := {(a + b Cos[v])Cos[u], (a + b Cos[v])Sin[u], b Sin[v]} and plotted with ParametricPlot3D[Evaluate[torus[2, 1][u, v]], {u, 0, 2*Pi}, {v, 0, 2*Pi}]; The second surface... E^z*Cos[x] == Cos[y] can be solved for z z == Log[Cos[y] Sec[x]] in the domain... domain[x_, y_] := Cos[y] Sec[x] > 0 We then plot the function f[x_, y_] := Log[Cos[y] Sec[x]] We can obtain a reasonable plot of this using the Boole function. The only problem is that it shows a zero level surface where it should show nothing. Plot3D[Boole[domain[x, y]]*f[x, y], {x, -3*(Pi/2), 3*(Pi/2)}, {y, -3*(Pi/2), 3*(Pi/2)}, PlotPoints -> {42, 42}, ImageSize -> 450]; With the DrawGraphic package we can eliminate the false zero surface patches by trimming an array of polygons to the region where the function is real. Needs["DrawGraphics`DrawingMaster`"] polygrid = N[MakePolyGrid[{42, 42}, {{-3*(Pi/2), -3*(Pi/2)}, {3*(Pi/2), 3*(Pi/2)}}]]; polys = polygrid // TrimPolygonsBoole[domain]; The following shows the region in the xy plane where the function is real. Draw2D[ {Burlywood, polys, polys // PolygonOutline[Black]}, AspectRatio -> Automatic, Frame -> True, ImageSize -> 300]; The following draws the 3D image plot1 = Draw3DItems[ {polys // RaiseTo3D[f]}, BoxStyle -> Gray, BoxRatios -> {1, 1, 0.7}, PlotRange -> {-1, 1}3, Background -> Linen, ImageSize -> 500]; We can also recognize that the surface exists only in certain square regions. It is the region {x,-Pi/2,Pi,2},{y,-Pi/2,Pi,2} and regions that are shifted in the xy plane by {n1 Pi, n2 Pi} where n1 + n2 is even. We can do the plot this way with... oneregion = Draw3D[f[x, y], {x, -Pi/2, Pi/2}, {y, -Pi/2, Pi/2}]; Draw3DItems[ {Table[If[EvenQ[n1 + n2], oneregion /. DrawingTransform3D[#1 + n1*Pi & , #2 + n2*Pi & , #3 & ], {}], {n1, -1, 1}, {n2, -1, 1}]}, BoxStyle -> Gray, BoxRatios -> {1, 1, 0.7}, PlotRange -> {-1, 1}*3, Background -> Linen, ImageSize -> 500]; David Park djmp at earthlink.net http://home.earthlink.net/~djmp/ From: vasil michev [mailto:michev at gmail.com] To: mathgroup at smc.vnet.net Hello, I need to plot a function of 3 parameters, and later examine different contours of it. To do so, I've already downloaded and tried ImplicitPlot3D and ContourPlot3D, but once I have the plot, say p1 = ImplicitPlot3D[z^2 == 1 - (2 - Sqrt[x^2 + y^2])^2, {x, -3, 3}, {y, -3, 3}, {z, -1, 1}, PlotPoints -> {15, 15, 10}, Passes -> Automatic] I want to be able to work with the 'pl1' plot. With the 'ordinary' Plot3D command the outpur it SurfaceGraphics and I can convert it, or immediately display N contours of it on a single plot using the ContourGraphics function. For example: Show[ContourGraphics[Out[80]], ColorFunction -> Hue, ColorFunctionScaling -> True, ContourShading -> False, Contours -> 11, PlotRange -> {{-10, 10}, {1, 10}, {0.39999, .4}}] But when using ContourPlot3D or ImplicitPlot3D packages the output is more general - Graphics3D, and I cant simply do the trick. Can anyone help me out, is there any package that will do the trick or any other way you can think of doing this? I tried making number of plots with various limitation for z-range, say Show[p1, PlotRange -> {-.00001, 0}, Axes -> True] and that seems to do what I want, but problems occur when I try to convert the output to "ordinary" Graphics object - the range/points are all wrong, probalby scaled (they vary from 0 to 1 only) (If you cant understand me just try the following: p1 = ImplicitPlot3D[E^z Cos[x] == Cos[y], {x, -6, 6}, {y, -6, 6}, {z, -6, 6}, PlotPoints -> {16, 16, 12}, Passes -> 4] pp1 = Show[p1, PlotRange -> {-.00001, 0}, Axes -> True] Show[Graphics[pp1], Axes -> True, PlotRange -> All] and look at the later 2 graphs - they're not quite the same... any help working around this will be much appretiated too) thanks in advance for any help