Re: Mysterious 3-way Collision of Polygons

*To*: mathgroup at smc.vnet.net*Subject*: [mg32344] Re: Mysterious 3-way Collision of Polygons*From*: Jens-Peer Kuska <kuska at informatik.uni-leipzig.de>*Date*: Wed, 16 Jan 2002 03:29:51 -0500 (EST)*Organization*: Universitaet Leipzig*References*: <a20m9t$4ga$1@smc.vnet.net>*Reply-to*: kuska at informatik.uni-leipzig.de*Sender*: owner-wri-mathgroup at wolfram.com

Hi, the simple answer is, send the graphics to MathGL3d and get it back. MathGL3d looks for degeneration in polygons and remove it. In your example Get["MathGL3d`OpenGLViewer`"] g = Show[g1, g2, g3, Boxed -> False]; MVShow3D[g, MVNewScene -> True]; Show[MVGetGraphics3D[]] will fix the problem and FullForm[MVGetGraphics3D[]] gives Graphics3D[ List[List[ Polygon[List[List[2.`, 1.1111111111111112`, 2.`], List[2.`, 2.`, 2.888888888888889`], List[1.`, 1.9999999999999998`, 2.`]]], Polygon[List[List[1.`, 1.9999999999999998`, 2.`], List[2.`, 2.888888888888889`, 2.`], List[2.`, 2.`, 1.1111111111111112`]]], Polygon[List[List[1.`, 1.9999999999999998`, 2.`], List[2.`, 2.`, 1.1111111111111112`], List[2.`, 1.1111111111111112`, 2.`]]]]]] The graphics is also shown correct with the RealTime3D` package and << RealTime3D` Show[g, RenderAll -> False] will just show you the graphics. Regards Jens "Wolf, Hartmut" wrote: > > I'm trying to write a graphics routine which is to be fast as well as > robust. However I've met a serious obstacle doing so. > > These are three Polygons that came out from the routine (among others): > > poly1 = Polygon[{{1., 1.9999999999999998, 2.}, > {1., 2., 1.9999999999999998}, > {2., 2., 1.1111111111111112}, > {2., 1.1111111111111112, 2.}}]; > poly2 = Polygon[{{1., 2., 1.9999999999999998}, > {1., 2., 2.}, > {2., 2.888888888888889, 2.}, > {2., 2., 1.1111111111111112}}]; > poly3 = Polygon[{{2., 1.1111111111111112, 2.}, > {2., 2., 2.888888888888889}, > {1., 2., 2.}, > {1., 1.9999999999999998, 2.}}]; > > They are nearly degenerate, as for each of those, two defining points have > come very close, be that accidentally or caused by numerical imprecision. We > might expect problems with display, however each one shows nicely (and of > course they look like triangles): > > g1 = Show[Graphics3D[poly1]]; > g2 = Show[Graphics3D[poly2]]; > g3 = Show[Graphics3D[poly3]]; > > They also combine in pairs: > > Show[g1, g2, Axes -> True]; > Show[g2, g3, Axes -> True]; > Show[g1, g3, Axes -> True]; > > But not all three together: > > g = Show[g1, g2, g3, Boxed -> False]; > > Just plain nothing. > > Surprisingly, if we make them fully degenerate, e.g. this way: > > Map[Rationalize, g, {4}] // InputForm > > Graphics3D[{Polygon[{{1, 2, 2}, {1, 2, 2}, {2, 2, 10/9}, {2, 10/9, 2}}], > Polygon[{{1, 2, 2}, {1, 2, 2}, {2, 26/9, 2}, {2, 2, 10/9}}], > Polygon[{{2, 10/9, 2}, {2, 2, 26/9}, {1, 2, 2}, {1, 2, 2}}]}, > {Boxed -> False}] > > Show[%, Boxed -> True, Axes -> True]; > > Show[%, ViewPoint -> {4., -1., 1.5}]; > > >From this perspective we see the polygons touch and meet in a single vertex. > This is exactly what should be. > > Rationalizing however is too expensive an operation to be used on many > thousands of polygons. Rounding is much cheaper, but to which "grid > constant", which coarseness? > > Cases[{#, With[{d = #*10.^-$MachinePrecision}, > Subtract @@ Round[d^-1 * {1.9999999999999998, 2.}]*d]} & /@ > N[Range[1, 10000]], > {n_, s_ /; UnsameQ[s, 0]} :> n] > > {1., 2., 3., 4., 5., 6., 7., 12., 14., 15., 31., 41., 43., 44., 58., 63., > 68., 89., 94., 204., 223., 358., 361., 396., 748., 815., 876., 1101., 1212., > > 1553., 1644., 3212., 4341., 4659., 6135., 6732., 7115., 7335., 9636.} > > Show[Map[With[{d = 8.*10.^-$MachinePrecision}, d*Round[d^-1*#]] &, g, {4}], > Boxed -> True]; > > works! > > Show[Map[With[{d = 9636.*10.^-$MachinePrecision}, d*Round[d^-1*#]] &, g, > {4}], > Boxed -> True]; > > doesn't ! > (With Boxed -> True, we now see a diagonal line, the ruins of the box?) Lets > be more specific and ask how much shall we have to dislocate one of the > nearly coinciding points to get a "decent" display. The answer is surprising > (to me at least): > > Show[GraphicsArray[Partition[ > With[{\[Epsilon]=10.^-#},Graphics3D[ > {Polygon[{{1., 2.-\[Epsilon], 2.}, > {1., 2., 2.-\[Epsilon]}, {2., 2., 1.1111111111111112}, > {2., 1.1111111111111112, 2.}}], > Polygon[{{1., 2., 2.-\[Epsilon]}, {1., 2., 2.}, > {2., 2.888888888888889, 2.}, {2., 2., 1.1111111111111112}}], > Polygon[{{2., 1.1111111111111112, 2.}, {2., 2., 2.888888888888889}, > {1., 2., 2.}, {1., 2.-\[Epsilon], 2.}}]}, > {Axes -> True, > PlotLabel->StyleForm[" "<>ToString[\[Epsilon]]<>" ", > Background->Hue[0.3,0.5,1]]} > ]]& /@ Range[16,1,-1], > 3,3,{1,1},{}]]]; > > Except for the first Graph (at exact coincidence of two points), nothing, > even at macroscopic level is acceptable. (Perhaps you might want to have a > closer look at the last but one, the clue might be there, but I have no idea > what happens.) We compare the last graphic with the first one. > > {gok, gepsilon} = {%[[1, 1, 1]], %[[1, -1, 1]]}; > > Show[GraphicsArray[%]]; > > Show[Map[Append[#, ViewPoint -> {4., -1., 1.5}] &, %, {2}]]; > > The supposed to be tetragons have become pentagons and hexagons. > > Watched individually, they look differently and just what they should to be. > > Show[GraphicsArray[ > Graphics3D[#, ViewPoint -> {4., -1., 1.5}] & /@ > gepsilon[[1, {1, 2, 3}]]]]; > > How may I deal with this problem? > -- > Hartmut Wolf