The Union of reals and removal of duplicates
- To: mathgroup at smc.vnet.net
- Subject: [mg8290] The Union of reals and removal of duplicates
- From: Russell Towle <rustybel at foothill.net>
- Date: Sun, 24 Aug 1997 04:46:31 -0400
- Sender: owner-wri-mathgroup at wolfram.com
Hi all, I have posted questions in the past concerning the Union of real
numbers. This has continued to be an issue for me, but I have succeeded in
finding solutions for some applications of this Union. For instance,
consider the problem of, given an arbitrary Graphics3D polyhedron in
Mathematica, to obtain a list of its vertices, with duplicates dropped; a
list of its polygons, as a list of lists of indices into its vertices; and
a list of its edges, as a list of lists of indices into its vertices. Here
is my solution, where "obj" has been defined, perhaps, as
obj = Polyhedron [ Dodecahedron ]; (*needs the Graphics "polyhedra" package*)
(*****)
Length [h = Level [obj, {-2}] ]; (*how many vertices altogether?*)
Length [g = Union [ r = Rationalize [h, 10^-2] ] ]; (*how many distinct?*)
(*now, what are the indices of the distinct in the altogether?*)
s = Table [Flatten [Position[ r, x_ /; x==g[[i]] ] ], { i, Length [g] } ];
(*go back and get the un-rationalized distinct vertices*)
v = h [[ Map[ First[#]&, s] ] ]; (*vertices*)
(*****)
So far so good. If there is a better, especially faster, way of
accomplishing this, I would be pleased to know it. Below I find the
polygons bounding the polyhedron "obj," and proceed to transform them into
a list of indices into the vertices, "v." I overwrite some previous
variables, such as h, but use some previous variables, such as g (the
Rationalized Union of vertices).
(*****)
Length [h = Level [obj, {-3}] ]; (*how many polygons altogether?*)
h = Rationalize[ h, 10^-2]; (*rationalize them*)
(*now, what are the indices of the distinct in each polygon?*)
s = Table[ Position[ h, x_ /; x==g[[i]] ], {i, Length [g]} ];
(*This gives the indices into g (hence 'v') of the polygons h*)
gons = Table [qq = Position [s, x_List /; First[x]==j ];
Map[ #[[2]]&, Sort[
Table[ Join[{s[[ qq[[i,1]],qq[[i,2]] ]] [[2]]},{qq[[i,1]]} ],
{i, Length[qq]}] ] (*Sort ends here*)
], (*Map ends here*)
{j, Length[h]}];
(*****)
Finally, with the polygons construed as lists of indices into vertices,
find the edges, and remove duplicates. The slowest and most problematical
part of all code is the Table below, given the not very descriptive name,
"c." The indices have already been split into pairs, and it only remains
to find and discard all those cases where the indices {i,j} reappear as
{j,i}. When a polyhedron is very complex (has over, say, twenty or thirty
faces), this Table of Positions can take a very very long time to create.
(*****)
(*find face indices and make edge indices*)
rings = Map[Join[#,{First[#]}]&, gons ];(*add first index to end of list*)
edges = Flatten[ Map[ Partition[#,2,1]&, rings], 1];(*break into pairs*)
(*remove duplicates (indices in reverse order)*)
c=Table[
Position[edges, x_ /; x == edges[[i]] || x == Reverse[edges[[i]]] ],
{i,Length[edges]}];
f=Map[Take[#,1]&, Union[c]];
f=Flatten[f,2];
(*****)
I have used these methods to build a function, wherein an arbitrary
Mathemtica polyhedron is written to POV-Ray format, with spheres on every
vertex, cylinders on every edge, and the faces divided into triangles as
POV likes them. I will post this to MathSource as soon as I find out how
to speed up the removal of edge duplicates.
Russell Towle
Giant Gap Press: books on California history, digital topographic maps
P.O. Box 141
Dutch Flat, California 95714
------------------------------
Voice: (916) 389-2872
e-mail: rustybel at foothill.net
------------------------------