Mathematica 9 is now available
Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2002
*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 2002

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

Search the Archive

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 (?)