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