Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2006
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2006

[Date Index] [Thread Index] [Author Index]

Search the Archive

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



  • Prev by Date: Re: Union, Sort at different levels of a list
  • Next by Date: Resetting Mathematica
  • Previous by thread: 3D ContourGraphics alternative
  • Next by thread: Re: 3D ContourGraphics alternative