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