Re: 3D contour through a point[2]

• To: mathgroup at smc.vnet.net
• Subject: [mg34032] Re: 3D contour through a point[2]
• From: "Allan Hayes" <hay at haystack.demon.co.uk>
• Date: Sat, 27 Apr 2002 00:56:39 -0400 (EDT)
• References: <aab00u\$mdl\$1@smc.vnet.net>
• Sender: owner-wri-mathgroup at wolfram.com

```Bram Platel has aked 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

```

• Prev by Date: Re: Getting File Directory Using Any Platform
• Next by Date: Mathematica EPS to Distiller PDF Font Problem Solved (?)
• Previous by thread: Memory overflow
• Next by thread: Mathematica EPS to Distiller PDF Font Problem Solved (?)