Services & ResourcesWolfram ForumsMathGroup Archive

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

Re: Mysterious 3-way Collision of Polygons

• To: mathgroup at smc.vnet.net
• Subject: [mg32412] Re: [mg32327] Mysterious 3-way Collision of Polygons
• From: John Fultz <jfultz at wolfram.com>
• Date: Sat, 19 Jan 2002 01:17:01 -0500 (EST)
• References: <200201160830.DAA09689@smc.vnet.net>
• Sender: owner-wri-mathgroup at wolfram.com

This turns out to be a problem not in the rendering of the polygons 
themselves, but in the automatic calculation of the PlotRange.  So, the 
problem is trivial to work around by doing...

g = Show[g1, g2, g3, Boxed -> False, PlotRange->All];

We're looking into this problem for a future release of Mathematica.

Sincerely,

John Fultz
jfultz at wolfram.com
User Interface Group
Wolfram Research, Inc.

> From: Wolf, Hartmut [mailto:Hartmut.Wolf at t-systems.de]
To: mathgroup at smc.vnet.net
>
>
> 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

• References:
  • RE: Mysterious 3-way Collision of Polygons
    • From: "David Park" <djmp@earthlink.net>