Re: 3D contour through a point[2]
- To: mathgroup at smc.vnet.net
- Subject: [mg34174] Re: 3D contour through a point[2]
- From: "Allan Hayes" <hay at haystack.demon.co.uk>
- Date: Wed, 8 May 2002 01:57:42 -0400 (EDT)
- References: <ab82gk$nst$1@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
[Apologies if anyone has received this before but my two previous postings
of it on 26/04 and 01/05 , with subject Re: 3D contour through a point[2]
have not appeared on my machine]
Bram Platel has asked if the technique used for 2D lines in my earlier
posting can be used on surfaces.
I give the analogous technique below, but first I should correct an error in
the earlier posting:
g3=DeleteCases[g2,ln_Line/;Min[(#.#&[{.6,.2}-#])&/@ln[[1]]]<0.1,
Infinity];
should be
g3=DeleteCases[g2,ln_Line/;Min[(#.#&[{.6,.2}-#])&/@ln[[1]]]>0.1,
Infinity];
Now for surfaces.
<<Graphics`ContourPlot3D`
Similar technique to 2D except for the grouping stage, see below.
Suppose we want the contour sheet of x y z that goes through
{0.53,-0.75,-0.25}.
First get
g=ContourPlot3D[x y z,
{x,-1,1}, {y,-1,1}, {z,-1,1},
Contours -> {0.53*-0.75*-0.25}]
Now we need to group the polygons into those on the same sheet.
Wrap each polygon in S (just a wrapper for separation)
sg2=S/@g[[1]];
Now collect into sheets
g3=g2//.{a___, b:S[___,Polygon[{___,x_,___}],___],c___,
d:S[___,Polygon[{___,x_,___}],___],e___}:>
{a,c,e,Join[b,d]};
Check
Show[Graphics3D[List@@@g3]
Delete the sheets that don't go close enough to {0.53,-0.75,-0.25}
g4=
DeleteCases[g3,s_S/;Min[(#.#&[{0.53,-0.75,-0.25}-#])&/@Level[s,{-2}]]>0.1
,Infinity];
Check
Show[Graphics3D[{List @@@ g4, PointSize[.05],
Point[{0.53, -0.75, -0.25}]}]]
--
Allan
---------------------
Allan Hayes
Mathematica Training and Consulting
Leicester UK
www.haystack.demon.co.uk
hay at haystack.demon.co.uk
Voice: +44 (0)116 271 4198
Fax: +44 (0)870 164 0565