Mysterious 3-way Collision of Polygons

*To*: mathgroup at smc.vnet.net*Subject*: [mg32327] Mysterious 3-way Collision of Polygons*From*: "Wolf, Hartmut" <Hartmut.Wolf at t-systems.de>*Date*: Tue, 15 Jan 2002 02:30:03 -0500 (EST)*Sender*: owner-wri-mathgroup at wolfram.com

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