Regular Polytopes
in Higher Space

version 1.25, May 3, 2000

by Russell Towle
rtowle@neworld.net

with ConvexHull3D by Dr. Wouter L. J. MEEUSSEN

Introduction

Please note that the examples within the Introduction, and the notebook at large, require evaluation of all Initialization cells. This can be effected with the menu Kernel : Evaluation : Evaluate Initialization.

Foreword

Version 1.25 introduces much faster and better methods to obtain the solid sections of convex and star polytopes. Various other small changes have been made.—Russell Towle, May, 2000.

This notebook was inspired by H.S.M. Coxeter’s Regular Polytopes (Dover, 1973). Most constructions for the vertices of the regular polytopes in four dimensions follow those in Regular Polytopes exactly. My acquaintance with the book began in 1984, when, after communicating details of work with the polar zonohedra to Jean Pedersen at the University of Santa Clara in California, she directed me to Regular Polytopes. Acquiring it, I read all that had to do with polar zonohedra, and quickly found that under special conditions they are isometric, orthogonal shadows of hypercubes. My beloved rhombic solids had obtained many new and startling dimensions. Here an n=5 polar zonohedron, the convex hull of an orthogonal projection of a 5-cube, is constructed and displayed from three viewpoints.

proj=Map[#[[{1,2,5}]]&, xyCube[5] ];
Show[ zaq=Graphics3D[ ConvexHull3D[ proj ] ],
ViewPoint->{0,0,2}];
Show[ zaq,
ViewPoint->{0,-2,0}];
Show[ zaq,
ViewPoint->{-2,0,0}];

The challenge presented by Regular Polytopes was considerable. Having managed to avoid the study of mathematics entirely, since junior high school, and having only a very limited and ad hoc command of trigonometry, the going was slow. Yet the challenge could not be refused. Some of the most interesting problems which had arisen with the polar zonohedra, having to do with their dissection into rhombic hexahedra, and a general expression giving their volume, appeared to involve their hypercubic “parents” in higher space. Two years ago I turned to the task of finding the vertices of the regular polytopes in four dimensions, using Mathematica. Early in 1999 I considered the regular polyhedra and their close relatives, and found simple constructions for these. The same methods proved applicable to polytopes in higher space, so work on my “Regular Polytopes” notebook resumed in June of 1999. The construction of solid shadows was greatly simplified by use of Dr. Wouter Meeussen’s ConvexHull3D algorithm.

	In the development of this notebook I received constant advice and support from a former student and colleague of Professor Coxeter’s, George Olshevsky. He is engaged in enumerating the uniform polytopes in four dimensions, of which there are thousands (the count now stands at 8,184). A uniform polyhedron may be defined as a polyhedron bounded by regular polygons, and possessing symmetries such that any vertex can be carried into any other vertex. A uniform polytope in four dimensions is defined as a polytope bounded by uniform polyhedra, and possessing symmetries such that any vertex can be carried into any other vertex.
	
	I also received important help from George Beck of Wolfram Research; Richard Koch of Oregon State University; and Martin Kraus. Eric Weisstein was kind enough to review the notebook. I owe many thanks to them all, and special thanks to Stephen Wolfram, who has quietly forwarded my interest in polyhedra and polytopes.

Polygons, Polyhedra, Polytopes

Among the infinitude of polygons which may be constructed in the plane, or polyhedra in three dimensions, or polytopes in higher spaces, it is natural to focus upon the more symmetrical figures. This “restriction of scope” is not always frankly acknowledged, and rarely even examined; yet in essence, when so naturally limiting ourselves in this way, it is not only polygons, polyhedra, and polytopes which command our interest, but symmetry. Symmetry is all the more important within the context of this notebook, for nearly all the methods employed depend utterly upon the symmetries of the figures, and would fail on less-symmetrical, or asymmetrical, inputs.

	When a polytope is regular, it embodies an underlying symmetry group. For instance, of the nine regular polyhedra in three dimensions—the five Platonic solids and the four Kepler-Poinsot solids—there are but three underlying symmetry groups: the tetrahedral, octahedral, and icosahedral.

	In Chapter 7 of RP, Coxeter writes
	
“POLYTOPE is the general term of the sequence
	point, segment, polygon, polyhedron, ... .
Many simple properties of polytopes may be inferred by pure analogy: e.g., 2 points bound a segment, 4 segments bound a square, 6 squares a cube, 8 cubes a hyper-cube, and so on.”

To illustrate the above, consider the isometric projection of a 4-cube or tesseract into the {x, y} plane. All 16 vertices, 32 edges, 24 square faces, and 8 cubic “cells” are visible.

a=Map[#[[{1,2}]]&, xyCube[4] ];
b=Map[#[[{1,2}]]&, edgefind[ xyCube[4] ], {2}];
Show[
 Graphics[{
  Line /@ b,
  RGBColor[1,0,0],AbsolutePointSize[5],Point /@ a
 }],AspectRatio->Automatic];

Coxeter continues: “ … we define a polytope as a finite … region of n-dimensional space enclosed by a finite number of hyperplanes. … The part of the polytope that lies in one of the hyperplanes is called a cell.”

	Here “hyperplane” refers to the infinite (n-1)-dimensional subspace which contains a cell, for instance, the hyperplanes bounding a polygon are the infinite lines which contain its sides. When referring to the fourth dimension, or the third, or the nth, I will often write “R4” or “R3” or “Rn.”

	Since the term “4-polytope” would arise so often in the following discussion and in the notebook at large, I adopt George Olshevsky’s polychoron; plural, polychora. He writes:
	
	POLYCHORON (plural: polychora) is my term for a four-dimensional polytope,
analogous to polygon in two dimensions and polyhedron in three. The only other
name for such a figure that I’ve seen in the literature, “polyhedroid,” seems
rather uninspired and inappropriate, because, first, it’s too close to the term
for a three-dimensional polytope, and second, the ending -oid connotes similarity
or resemblance. A four-dimensional polytope resembles a polyhedron no more than a
polyhedron resembles a polygon, and should therefore have a similarly distinctive
root following the poly-. The Greek root choros means “room,” “place,” or
“space,” describing the three-dimensional polytopes, or cells, that make up the
polychoron.

	Thus polychora are bounded by polyhedra, and in space of n dimensions, an n-polytope is bounded by (n-1)-dimensional polytopes. These are called the cells of the polytope. The cells of cells are (n-2)-dimensional polytopes, and the cells of these are (n-3)-dimensional polytopes. Thus we obtain a descending series of elements, ending with the points which bound a single edge. The regular polytopes were discovered before 1852 by the Swiss mathematician, Ludwig Schläfli. His Schläfli symbol, for a regular polytope is quite useful; in R4 we denote a polychoron as {p, q, r}; but let us begin in R2.
	
	Of all the equilateral polygons, those which are also equiangular are called “regular.” Suppose there are p sides; then a rotation of 2kπ / p {k = 0, 1, …, (p - 1)} about the center carries the p-gon into itself. So also does the reflection in a line joining a vertex to the opposite vertex (p even) or opposite mid-edge point (p odd). Altogether there are 2p such rotations and reflections which form the dihedral group [p], of order 2p. The rotations and reflections are the “symmetry operations” of the group, and the number of distinct operations is the “order” of the group (see Chapter 3 of RP). The Schläfli symbol for a regular convex polygon is just {p}. However, a regular polygon need not be convex: there are any number of star polygons, such as the pentagram, {5/2}, whose edges intersect one another.
	
	Although there is an infinite number of regular convex polygons, there are only five regular convex polyhedra. These are the Platonic solids: {3, 3} (tetrahedron), {3, 4} (octahedron), {4, 3} (cube), {3, 5} (icosahedron), and {5, 3} (pentagonal dodecahedron). Here the Schläfli symbol {p, q} means that the polyhedron is bounded by p-gons, q at each vertex. That is, there is only one type of face; it is a regular convex polygon; and the vertices are all surrounded alike. These all arise during construction of the regular polychora, and we may as well review them now.

Show[ celldual[ nSimplex[4], -nSimplex[4] ][[1]],
PlotLabel->"Tetrahedron {3,3}"];
Show[ celldual[ nCube[4], 2*nCross[4] ][[2]],
PlotLabel->"Octahedron {3,4}"];
Show[ celldual[ nCube[4], 2*nCross[4] ][[1]],
PlotLabel->"Cube {4,3}"];
Show[ celldual[ v533,v335 ][[2]],
PlotLabel->"Icosahedron {3,5}"];
Show[ celldual[ v533,v335 ][[1]],
PlotLabel->"Dodecahedron {5,3}"];

There are also four regular star polyhedra, called the Kepler-Poinsot polyhedra: the small stellated dodecahedron {5/2, 5}, great stellated dodecahedron {5/2, 3}, great dodecahedron {5, 5/2}, and great icosahedron {3, 5/2}. Here, when the second member of the Schläfli symbol is 5/2, it signifies that 5 polygons surround a vertex, 2 times over. These all arise during construction of the star polychora, in the ”Solid Shadows of Star Polychora” section.
	
	Of the nine regular polyhedra, only three symmetry groups are involved. The icosahedral group [3, 5]  of order 120 accounts for the four Kepler-Poinsot solids, as well as the pentagonal dodecahedron and icosahedron. The octahedral group [3, 4] of order 48 accounts for the cube and octahedron, and the tetrahedral group [3, 3] of order 24 accounts for the tetrahedron. It is worth noting that an infinite number of polyhedra may be constructed which embody these symmetry groups, but only nine are regular.
	
	In four-dimensional space there are sixteen regular polychora, six convex and ten starry. Before embarking upon a description of these, consider still higher spaces. In five or more dimensions, only three regular polytopes arise: the simplex, cross polytope (or orthoplex), and the hypercube. There are functions which find the vertices of each of these: nSimplex, nCross, and nCube. The latter two benefit from special coordinates suited for projection into the {x,y} plane: xyCross and xyCube. Each of these five functions accepts a single argument, n, the number of dimensions. Here are examples for n=7.

a=Map[#[[{1,2}]]&, nSimplex[7] ];
b=Map[#[[{1,2}]]&, edgefind[ nSimplex[7] ], {2}];
Show[
 Graphics[{
  Line /@ b,
  RGBColor[1,0,0],AbsolutePointSize[4],Point /@ a
 }],
 PlotLabel->"7-simplex {3,3,3,3,3,3}",
 AspectRatio->Automatic];
a=Map[#[[{1,2}]]&, xyCross[7] ];
b=Map[#[[{1,2}]]&, edgefind[ xyCross[7] ], {2}];
Show[
 Graphics[{
  Line /@ b,
  RGBColor[1,0,0],AbsolutePointSize[4],Point /@ a
 }],
 PlotLabel->"7-cross polytope {3,3,3,3,3,4}",
 AspectRatio->Automatic];
a=Map[#[[{1,2}]]&, xyCube[7] ];
b=Map[#[[{1,2}]]&, edgefind[ xyCube[7] ], {2}];
Show[
 Graphics[{
  Line /@ b,
  RGBColor[1,0,0],AbsolutePointSize[4],Point /@ a
 }],
 PlotLabel->"7-cube {4,3,3,3,3,3}",
 AspectRatio->Automatic];

A few words about these three universal polytopes will suffice.

	The simplex is so named because it is the simplest possible polytope in any given space. That is, the triangle is the simplest polygon, and the tetrahedron the simplest polyhedron. A simplex is a pyramid erected into the nth dimension, with an (n-1)-dimensional simplex as its base. Simplexes have n+1 vertices and n+1 cells. The Schläfli symbol is a series of (n-1) 3’s; the Platonic tetrahedron, for instance, is {3, 3}, the 4-simplex, {3,3,3}.
	
	The cross polytope is so named because its 2n vertices are located equidistant from the origin, in both directions, along the Cartesian coordinate axes in n-space. Each such axis is perpendicular to all the others. A cross polytope is bounded by 2^n (n-1)-simplexes, and is a dipyramid erected (in both directions) into the nth dimension, with an (n-1)-dimensional cross polytope as its base. The Schläfli symbol is a series of (n-2) 3’s, followed by one 4; the Platonic octahedron, for instance, is {3, 4}, the 4-cross polytope, {3,3,4}.
	
	The hypercube is the generalization of the square and cube to higher spaces. It has 2^n vertices and is bounded by 2n (n-1)-cubes, and is a prism erected into the nth dimension, with an (n-1)-dimensional hypercube as its base.  The Schläfli symbol is one 4, followed by a series of (n-2) 3’s; the Platonic cube, for instance, is {4, 3}, the 4-cube or tesseract, {4,3,3}. When an n-cube is of unit edge length it is called a measure polytope, for it defines the unit of n-dimensional content, the analogy of length, area, and volume.
	
	Within the context of polytopes and symmetry, the subject of duality is essential. For instance, “the dual” or “the reciprocal” of a regular polyhedron {p, q} is another polyhedron, {q, p}. That is, the polyhedron bounded by p-gons, q at each vertex, is reciprocal to the polyhedron bounded by q-gons, p at each vertex. If {p, q} has 8 vertices, 12 edges, and 6 faces (as does the cube, {4, 3}) then {q, p} has 6 vertices, 12 edges, and 8 faces (as does the octahedron, {3, 4}). In constructing the regular polychora, we may easily obtain such dual pairs of polyhedra, in reciprocal positions.

Show[ celldual[ nSimplex[4], -nSimplex[4] ][[3]],
PlotLabel->"Dual Tetrahedra {3,3}"];
Show[ celldual[ nCube[4], 2*nCross[4] ][[3]],
PlotLabel->"Cube {4,3} and Octahedron {3,4}"];
Show[ celldual[ v533,v335 ][[3]],
PlotLabel->"Dodecahedron {5, 3} and Icosahedron {3,5}"];

The regular polygons are self-dual, as are the regular simplexes; for their Schläfli symbols are palindromes, and read the same left to right as right to left. In the regular polytopes, every vertex is surrounded alike; the mid-points of the edges emanating from any one vertex of the polytope are the vertices of an (n-1)-dimensional polytope called the vertex figure. For instance, the vertex figures of the Platonic cube, dodecahedron, and tetrahedron are equilateral triangles, while the vertex figure of the octahedron is a square, and of the icosahedron, a pentagon. These are made quite evident in the depictions of reciprocal polyhedra above. Of regular polytopes in general, we shall see that the cells of a polytope are the duals of its dual’s vertex figure.

	With the concept of the vertex figure established, we can define what is meant by a “regular” polytope. In Chapter 7.5 of RP Coxeter writes
	
	“Beginning with the regular polygons {3}, {4}, {5}, …, we can define a regular polytope inductively, as follows. A polytope [of more than two dimensions] … is said to be regular if its cells are regular and there is a regular vertex figure at every vertex.”
	
	Simple geometry ensures one consequence of the above definition: the cells are all equal, and the vertex figures are all equal (see Chapter 2.1 of RP). By example, the Archimedean polyhedra are equilateral, but have more than one type of bounding regular polygon; all vertices are indeed surrounded alike, but the vertex figures cannot be equilateral, and from this standpoint alone cannot be regular. The Schläfli symbol for a regular polytope contains the Schläfli symbols for its cells and vertex figures; the situation in space of n dimensions is more complicated, but we will confine ourselves to the regular polychora in four dimensions, which are the primary focus of this notebook.

The Six Regular Convex Polychora. Truncation; Rectification.

The regular polychoron {p, q, r} has solid cells {p, q} and vertex figures {q, r}. Two polyhedral cells {p, q} meet at each face {p}, and r of these cells surround each edge. If the vertex figure {q, r} has V vertices, then V edges meet at every vertex; and if the vertex figure {q, r} has F faces, then F cells {p, q} surround each vertex of {p, q, r}. For the cells of the vertex figure at any vertex O are the vertex figures of the cells which surround O. Let us examine the six regular convex polychora in turn. These are (with the global names for their vertex-sets given, after the Schläfli symbol):
	
	1. The regular simplex or 5-cell, {3,3,3}; v333.
	2. The regular cross polytope or 16-cell, {3,3,4}; v334.
	3. The regular hypercube, tesseract, or 8-cell, {4,3,3}; v433.
	4. The 24-cell, {3,4,3}; vi343 and vii343.
	5. The 600-cell, {3,3,5}; v335.
	6. The 120-cell, {5,3,3}; v533.

Using the cellfigure and vertexfigure functions, we can show the cells meeting at a vertex, the vertex figure of that vertex, and then both together (using a function which “hollows out” the faces of the cells to reveal the vertex figure within). Since the cells meeting at a vertex appear to be a single polyhedron, we explode them apart slightly. (Note: the ten star polychora require special methods; information about the numbers of vertices, edges, faces, and cells is found in the Solid Shadows of Star Polychora section of this notebook.)

Simplex or 5-cell, {3,3,3}

	The regular 4-simplex is bounded by 5 vertices, 10 edges, 10 triangles, and 5 tetrahedra. Since its vertex figure is a tetrahedron, and tetrahedra have 4 faces, 4 tetrahedra meet at each vertex.

v1=v333;(*set polychoron*)
v2=-v333;(*its dual*)
pt=2*N[unit[{.25,-2,0}]];(*set ViewPoint*)

r=mag[ v1[[1]] ];

Show[Map[trans[#, .5*cent[ Flatten[parse[#],1] ] ]&, cellfigure[ v1, v2 ]],
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
PlotLabel->"cells at a vertex",
ViewPoint->pt];

Show[{vertexfigure[ v1 ]},
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
PlotLabel->"vertex figure",
ViewPoint->pt];

Show[
{hollowPolygon[cellfigure[ v1, v2 ],1,4],
vertexfigure[ v1 ]},
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
PlotLabel->"cells and vertex figure",
ViewPoint->pt];

Cross Polytope or 16-cell, {3,3,4}

	The regular 4-cross polytope is bounded by 8 vertices, 24 edges, 32 triangles, and 16 tetrahedra. Since its vertex figure is an octahedron, and octahedra have 8 faces, 8 tetrahedra meet at each vertex.

v1=v334;(*set polychoron*)
v2=v433;(*its dual*)
pt=2*N[unit[{1,-1,.5}]];(*set ViewPoint*)

r=mag[ v1[[1]] ];

Show[Map[trans[#, 1*cent[ vunion[Flatten[parse[#],1]] ] ]&, cellfigure[ v1, v2 ]],
Boxed->False,
PlotLabel->"cells at a vertex",
ViewPoint->pt];

Show[{vertexfigure[ v1 ]},
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
PlotLabel->"vertex figure",
ViewPoint->pt];

Show[
{hollowPolygon[cellfigure[ v1, v2 ],1,4],
vertexfigure[ v1 ]},
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
PlotLabel->"cells and vertex figure",
ViewPoint->pt];

Tesseract or 8-cell {4,3,3}

	The regular 4-cube is bounded by 16 vertices, 32 edges, 24 squares, and 8 cubes. Since its vertex figure is a tetrahedron, and tetrahedra have 4 faces, 4 cubes meet at each vertex.

v1=v433;(*set polychoron*)
v2=v334;(*its dual*)
pt=2*N[unit[{1,-2,0}]];(*set ViewPoint*)

r=mag[ v1[[1]] ];

Show[
Map[trans[#, .5*cent[ Flatten[parse[#],1] ] ]&, cellfigure[ v1, v2 ]],
Boxed->False,
PlotLabel->"cells at a vertex",
ViewPoint->pt];

Show[{vertexfigure[ v1 ]},
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
PlotLabel->"vertex figure",
ViewPoint->pt];

Show[
{hollowPolygon[cellfigure[ v1, v2 ],1,4],
vertexfigure[ v1 ]},
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
PlotLabel->"cells and vertex figure",
ViewPoint->pt];

24-cell {3,4,3}

	The 24-cell is bounded by 24 vertices, 96 edges, 96 triangles, and 24 octahedra. Since its vertex figure is a cube, and cubes have 6 faces, 6 octahedra meet at each vertex. Its Schläfli symbol is a palindrome, so it is self-dual.

v1=vi343;(*set polychoron*)
v2=vii343;(*its dual*)
pt=2*N[unit[{1,-2,0}]];(*set ViewPoint*)

r=mag[ v1[[1]] ];

Show[
Map[trans[#, .5*cent[ Flatten[parse[#],1] ] ]&, cellfigure[ v1, v2 ]],
Boxed->False,
PlotLabel->"cells at a vertex",
ViewPoint->pt];

Show[{vertexfigure[ v1 ]},
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
PlotLabel->"vertex figure",
ViewPoint->pt];

Show[
{hollowPolygon[cellfigure[ v1, v2 ],1,4],
vertexfigure[ v1 ]},
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
PlotLabel->"cells and vertex figure",
ViewPoint->pt];

600-cell {3,3,5}

	The 600-cell is bounded by 120 vertices, 720 edges, 1200 triangles, and 600 tetrahedra. Since its vertex figure is an icosahedron, and icosahedra have 20 faces, 20 tetrahedra meet at each vertex.

v1=v335;(*set polychoron*)
v2=v533;(*its dual*)
pt=2*N[unit[{1,-2,0}]];(*set ViewPoint*)

r=mag[ v1[[1]] ];

Show[
Map[trans[#, .5*cent[ Flatten[parse[#],1] ] ]&, cellfigure[ v1, v2 ]],
Boxed->False,
PlotLabel->"cells at a vertex",
ViewPoint->pt];

Show[{vertexfigure[ v1 ]},
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
PlotLabel->"vertex figure",
ViewPoint->pt];

Show[
{hollowPolygon[cellfigure[ v1, v2 ],1,4],
vertexfigure[ v1 ]},
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
PlotLabel->"cells and vertex figure",
ViewPoint->pt];

120-cell {5,3,3}

	The 120-cell is bounded by 600 vertices, 1200 edges, 720 pentagons, and 120 pentagonal dodecahedra. Since its vertex figure is an tetrahedron, and tetrahedra have 4 faces, 4 dodecahedra meet at each vertex.

v1=v533;(*set polychoron*)
v2=v335;(*its dual*)
pt=2*N[unit[{1,-2,0}]];(*set ViewPoint*)

r=mag[ v1[[1]] ];

Show[
Map[trans[#, .5*cent[ Flatten[parse[#],1] ] ]&, cellfigure[ v1, v2 ]],
Boxed->False,
PlotLabel->"cells at a vertex",
ViewPoint->pt];

Show[{vertexfigure[ v1 ]},
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
PlotLabel->"vertex figure",
ViewPoint->pt];

Show[
{hollowPolygon[cellfigure[ v1, v2 ],1,4],
vertexfigure[ v1 ]},
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
PlotLabel->"cells and vertex figure",
ViewPoint->pt];

Of the six regular convex polychora, five are typically regarded as being analogous to the Platonic solids: the 4-simplex, a hyper-tetrahedron, the 4-cross polytope, a hyper-octahedron, the 4-cube, a hyper-cube, the 600-cell, a hyper-icosahedron, and the 120-cell, a hyper-dodecahedron. The 24-cell, {3,4,3}, has no perfect analogy in higher or lower spaces. One construction for the 24-cell evokes comparison with Kepler’s rhombic dodecahedron. Given two equal cubes, we construct this dodecahedron by cutting one cube into six congruent square pyramids, and attaching these to the six squares bounding the other cube. Similarly, given two equal tesseracts, we can construct the 24-cell by cutting one tesseract into eight congruent cubic pyramids, and attaching these to the eight cubes bounding the other tesseract.

Rectified and Truncated forms

The midpoints of the edges of a regular polytope are the vertices of the related “rectified” polytope. We may prepend an “r” to the Schläfli symbol to denote such a figure. For instance, the rectified tetrahedron r{3,3} is an octahedron {3,4}, while r{3,4} and r{4,3} both give the Archimedean cuboctahedron, and r{3,5} and r{5,3} both give the Archimedean icosidodecahedron. Such rectified forms are bounded by a combination of rectified cells and vertex figures. Thus a rectified polychoron r{p,q,r} is bounded by r{p,q}’s and by {q,r}’s. For instance, r{3,3,5} is bounded by 600 truncated tetrahedra (truncated cells) and 120 icosahedra (vertex figures). From rectification of the six regular polychora we only obtain five new polychora, however, for the rectified 4-orthoplex, r{3,3,4}, is the 24-cell, {3,4,3}.
	
	If we truncate each {p} of a regular polychoron {p,q,r} to give a regular {2p}, we obtain the related “truncated” polychoron, denoted by t{p,q,r}. Its cells are truncated {p,q}’s and vertex figures {q,r}. For instance, t{5,3,3} is bounded by 120 truncated pentagonal dodecahedra (truncated cells) and 600 tetrahedra (vertex figures). From rectification of the six regular convex polychora we obtain six new polychora. My favorite is a zonochoron, the truncated 24-cell, t{3,4,3}. Its 48 cells are all zonohedra: 24 truncated octahedra and 24 cubes.

Simple Methods: Vertices, Edges, Faces, and Cells

Recall first that the vertices of the six regular convex polychora have been given “Schläfli-symbol-like” names, such as v333 (dual is -v333), v334 (dual is v433), v433 (dual is v334), vi343 (dual is vii343), v335 (dual is v533), and v533 (dual is v335). The last two polychora in the list above, the 600-cell and 120-cell, are much more complicated than the rest. Every process of section and projection (or the discovery of edges, or faces, or cells) takes much longer with these two polytopes, than with the rest.

	Broadly, the methods used are not only simple, but brute-force, in nature. Again and again we look for sets of points at some distance from a given point, and in this way find the edges, or the faces, or the polyhedra bounding a polychoron.

	It is worth noting that many procedures might have been cast as functions. For instance, the details of orthogonal projection might have been hidden within the workings of a project[ polychoron_, viewpoint_] function. In this and many other cases I chose to leave the methods open to view, so that one must often evaluate several cells in sequence, to obtain the final result. It seemed to me that the geometry of the fourth dimension is quite challenging enough, without shrouding the many steps needed to gain this or that goal, within the confines of a function which makes it seem like one easy leap.

	The symmetries of the sixteen regular polychora enable a much simpler and more direct approach to their construction, and to the creation of sections and projections, than would be possible with an arbitrary polychoron. I have followed the constructions for the vertices of the six regular convex polychora, as given in Regular Polytopes, exactly; and these are cast in such a form that a polychoron and its dual are in reciprocal positions. An immediate consequence of this is that we can easily find the vertices {p, q, r}’s bounding polyhedra, by selecting those vertices of {p, q, r} closest to each vertex of {r, q, p} in turn. This is the approach taken by the cellfind function, which accepts two arguments: a polychoron and its dual. The mag function, returning the magnitude of an n-vector, is used in cellfind and in fact throughout the notebook; . We shall also visit the facefind and edgefind functions. Of these three functions, cellfind and edgefind operate successfully upon any regular convex polytope, but facefind is limited to regular convex polychora. When facefind is applied to a 5-dimensional polytope, it returns a list of the vertices of the polyhedra bounding that polytope, not its faces.

??cellfind

Let’s apply cellfind to one of the simpler polychora, the hypercube.

cellfind[ v433, v334 ]

The facefind function follows a similar tack; for if a polychoron and its dual are in reciprocal position, then the edge-centers of one are at minimum distance to the faces of the other. Like cellfind, facefind accepts two arguments: a polychoron and its dual.

??facefind

Let’s apply facefind to one of the simpler polychora, the hypercube.

facefind[ v433, v334]

The edgefind function departs from the two functions above. It will operate upon any regular polytope. It finds the edges in a loop through the list of vertices, except at each given vertex in turn, it searches only among vertices not already passed in the loop. It requires only one argument, the vertices of the polytope for which the edges are sought.

??edgefind

Let’s apply edgefind to one of the simpler polychora, the hypercube.

edgefind[ v433 ]

More on Methods: Coordinates, Projections, Shadows

At the outset it must be grasped that the orthogonal projection of a convex n-polytope into an s-space, s<n, is always a convex s-polytope (neglecting the cases when s=0 or s=1, and “convexity” cannot apply). The orthogonal shadow of a convex polychoron, cast into an s-space, when s=3, is a convex polyhedron (with its interior); and when s=2, it is a convex polygon (with its interior). The shadow of a convex polytope is the convex hull of its projection.

	We may apply Cartesian coordinates to space of n dimensions, such that any point (vector) is represented by an ordered n-tuple of real numbers. The n real numbers are called the components of the vector. The vertices of a polychoron are a list of ordered 4-tuples, as in the 4-simplex, below.

nSimplex[4]

For some reason I chose “w” as the name for my fourth dimension, so I conceive a point in R4 to have {x, y, z, w} coordinates. In space of n dimensions we may have n mutually perpendicular lines; the coordinate axes provide an example. Many types of projection into lower spaces exist; for instance, Mathematica uses a perspective transformation, and removes hidden detail, when displaying Graphics3D objects. The simplest type of projection, however, is orthogonal projection into the coordinate hyperplanes. For instance, given a point in R3 with {x,y,z} coordinates, we obtain the orthogonal projection into the {x,y} hyperplane by dropping the z component. By dropping the y component we project into the {x,z} plane, and so on. Moreover, by dropping both y and z components, we obtain the orthogonal projection into the x axis.

	In Rn there are exactly n coordinate (n-1)-hyperplanes. In R4 we have four coordinate 3-spaces into which we can project: we can select the first, second, and third, or the first, second, and fourth, or the first, third, and fourth, or the second, third and fourth, components. This is easily effected in Mathematica.

(*project into {x,y,z} 3-space*)
Map[ #[[{1,2,3}]]&, nSimplex[4] ]

We must pay attention to Level specifications when projecting the edges, faces, or polyhedra bounding a polychoron.

(*project into {x,y} 2-space*)
e1 = edgefind[ nSimplex[4] ];
Show[
 Graphics[
  Line /@ Map[ #[[{1,2}]]&, e1, {2}]
 ],
AspectRatio->Automatic];

During the evolution of this notebook, I was at first restricted to projecting into the coordinate hyperplanes. However, I was determined to make projections of the regular polychora into the 3-spaces orthogonal to their principal axes of symmetry. There are four such axes, defined by the vectors from the center of the polychoron to a vertex, edge center, face center, and cell center. Two methods eventually arose. In the first we rotate the entire polychoron until the specified axis (vector) falls into coincidence with the w axis. Projection into the {x,y,z} 3-space follows immediately, by dropping the w coordinate.

	The second method is used more often. Given the specified axis, a vector in R4, we use Mathematica’s NullSpace function to obtain basis vectors for a 3-space perpendicular to that axis. An undocumented feature of NullSpace makes it especially well-suited for this: when supplied with inexact inputs, it returns not only basis vectors, but orthogonal basis vectors.

(*an arbitrary point in R4*)
pt = {1, 2.11, 3.12, -4.14}

bas = NullSpace[ {N[ pt ]} ]

(*what are the magnitudes of the basis vectors?*)
Map[mag[#]&, bas]

The test for orthogonality between two vectors in Rn is that their dot product is zero. Let us test the basis vectors obtained above.

(*orthogonal to specified axis?*)
Chop[ Dot[ pt, # ],.000001 ]& /@ bas

(*orthogonal to one another?*)
Chop[ Dot[ bas[[1]], bas[[2]] ],.000001 ]
Chop[ Dot[ bas[[1]], bas[[3]] ],.000001 ]
Chop[ Dot[ bas[[2]], bas[[3]] ],.000001 ]

We project a 4-cube into the 3-space given by basis vectors “bas” as follows.

(*the vertices we project*)
nCube[4]

(*after projection into the 3-space*)
Map[ Dot[ bas, # ]&, nCube[4] ]

q1=vunion[ Map[ Dot[ bas, # ]&, nCube[4] ] ];(*project*)
q2=Graphics3D[ConvexHull3D[q1]];(*build shadow*)
Show[ q2,
Boxed->False];(*display*)

Note that the projection of the vertices is effected by taking the dot product of “bas” with each vertex in turn. In this way the 4-tuples of the tesseract are contracted into the 3-tuples of its projection. The vunion function finds the Union of a set of n-vectors. It is often useful to discard duplicates from a list of points; in this case, the ConvexHull3D function can at times fail when given point sets containing duplicates, so we weed them out.

Still To Do

There is much left to do, many problems left unsolved, and much that might have been added to this notebook, if time and space permitted. I have constructed the regular space-fillings in four dimensions, of which there are three, {4,3,3,4}, {3,3,4,3}, and {3,4,3,3}. But their projections into three dimensions do not please me, so these have been left out. There are many regular compounds in the fourth dimensions, to which I have scarcely given a glance.
	
	Several problems remain unsolved. For instance, considerable effort went into constructing “special” vertices for the six regular convex polychora, in order to obtain their most-symmetrical plane projections. Yet it would be far more satisfying to make the projections ab initio instead of appealing to special rules. Typically the regular polychora have two different Petrie polygons, and the problem is: project the polychoron into a plane in which a Petrie polygon is regular.
	
	Another unsolved problem is the construction of the duoprisms, which are the “rectangular product” of two polygons as set forth in Chapter 7 of Regular Polytopes. When the two polygons are regular, the duoprism is a uniform polychoron. Again, from any uniform polyhedron we may erect a prism or a pyramid into the fourth dimension. All such prisms and some of the pyramids are uniform polychora. My own interests incline me towards construction of various zonochora, polychora bounded entirely by zonohedra.

Initialization

Off[General::spell]
Off[General::spell1]

ConvexHull3D

Dr. Wouter Meeussen’s ConvexHull3D, ancillary functions, and his remarks about these, are found below.

(*cross product between two vectors in R3*)
mycross[ {ax_, ay_, az_}, {bx_, by_, bz_} ] :=
   {ay bz - az by, az bx - ax bz, ax by - ay bx}

myOrdering[z_List]:=(Sort[Transpose[{z,Range[Length[z]]}]]//Transpose) [[2]]

norm[vec_List]:=Sqrt[vec.vec]
bary[pts_]:=1/Length[pts] Plus@@pts

For points "vi" in 3D space, given as vi : {Real_,Real_,Real_}, the following function defines a plane :

plane[{v1_,v2_,v3_},v_]:=Det[{(v-v1),(v1-v2),(v2-v3)}]

This provides the angle between (v2-v1) and (v3-v2), useful only in the case of four or more coplanar points:

ang2[{v1_List,v2_List},v2_]:=1.
ang2[{v1_List,v2_List},v1_]:=-1.
ang2[{v1_List,v2_List},v3_List]:= (v2-v1).(v3-v2)/mag[v2-v1]/mag[v3-v2]

ang[{v1_List,v2_List},v2_|v1_]:=1.
ang[{v1_List,v2_List},v3_List]:=(v2-v1).(v3-v2)/norm[v2-v1]/norm[v3-v2]

ch2D[indices_List]:=Module[{pts,cen,dis,idx,xfar,far,xsec,hull},
pts=points[[indices]];
cen=bary[pts];
dis=norm[#-cen]& /@ pts;
idx=myOrdering[dis];
xfar=Last[idx];far=pts[[xfar]];
xsec=Sort[{10+  ang2[{cen,far},pts[[#]] ]-10.,
	norm[(far-pts[[#]])] ,#} &/@idx][[-2,-1]];
hull={xfar,xsec};
FixedPoint[Last[AppendTo[hull, 
Sort[ {10+ang[  pts[[Take[hull,-2] ]],
pts[[#]] ]-10.,
norm[(pts[[ Last[hull] ]] -pts[[#]])] ,#} &/@idx] [[-3,-1]] ] ]&,0,
SameTest->(First[hull]==#2 &)];
indices[[Drop[hull,-1]]]]

The plane has a sign, which we will need. All distances from points v on the same side of the plane {v1,v2,v3} have the same sign. It can be "+" or "-", dependent on the right or left circulation of the set {v1,v2,v3} as seen from the origin.

test[tria:{_Integer,_Integer,_Integer}]:=
If[Unequal@@tria && Chop[norm[
mycross[ points[[ tria[[1]] ]]-points[[ tria[[2]] ]], 
 points[[ tria[[1]] ]] - points[[ tria[[3]] ]] ] ],.00001 ]=!=0,
	Block[{i=1,oneside=True},res={};
	 While[(oneside = Or[FreeQ[res,-1],FreeQ[res,1]])&&i<=n,
	  res={res,If[FreeQ[tria,i], Sign@Chop[plane[points[[tria]], points[[i]] ],.00001],0]};
	 i++];(*end While*)
		oneside],(*end Block*)
False](*end If*)

ConvexHull3D::usage = "ConvexHull3D[inputpoints] accepts a list of
points {x,y,z} in three dimensions, and returns the convex hull
of those points, as a list of convex Polygons.";

ConvexHull3D[inputpoints_]:=
Module[{distx,far,crosx,nix,it,faces,legs,cen,
testable,badones,disordered,circulation,testing},
points=N[inputpoints];
n=Length[points];
cen=Plus @@ points /n;
cenpoints=(#-cen)& /@ points;
distx=Reverse[myOrdering[(#.#)&/@cenpoints]];
far=distx[[1]];
crosx= Reverse[myOrdering[1/(1+2 norm/@((points[[far]]-#)& /@ points))* 						(norm[#-cen]& /@ points +
norm/@( mycross[(points[[far]]-cen) ,(#-cen) ]& /@ points ))	]];

nix=True;i=1;badones={};
While[nix&&i<=n-1,j=1;
	While[ j<=n-1 && (nix=Not[test[it={far,crosx[[i]],crosx[[j]]}]]),j++];
i++];

If[Count[res,0,-1]>3,
	it=ch2D[disordered=Flatten[Position[Flatten[res],0]] ]; 
	badones=Complement[disordered,it]
];

faces={it};
oldlegs=legs={};
faces=Union@Flatten[{faces,{it}},1];
legs=Split[Sort[Sort/@Flatten[Partition[#~Append~First[#],2,1]&/@faces,1]]];
legs=Flatten[DeleteCases[legs,{_List,_List}],1];

While[legs=!={}&&legs=!=oldlegs,
	oldlegs=legs;
	faces=Union[Flatten[{faces,{it}},1]];
	legs=Split[Sort[Sort/@Flatten[Partition[#~Append~First[#],2,1]&/@faces,1]]];
	legs=Flatten[DeleteCases[legs,{q_List,q_List..}],1];
testing=First@Select[faces, (!FreeQ[#, legs[[1,1]] ]&& !FreeQ[#,legs[[1,2]] ])&];

nix=True;
j=1; testable=DeleteCases[distx,Alternatives@@Join[testing,badones]];
	While[j<=Length[testable] &&
	(nix=Not[test[it=Flatten[{legs[[1]],testable[[j]]}] ] ]),j++];
	disordered={};
	If[Count[res,0,-1]>3,
		it=ch2D[disordered=Flatten[Position[Flatten[res],0] ] ]; 
		badones=Union[Flatten[{badones,Complement[disordered,it]}] ]
	];
	faces=Union@Flatten[{faces,{it}},1];
	legs=Split[
		Sort[
			Sort /@ Flatten[ Partition[#~Append~First[#],2,1]& /@ faces,1]
			]
		];
legs=Flatten[DeleteCases[legs,{q_List,q_List..}],1]
];(*endwhile*)

circulation=Sign[Chop[plane[Take[#,3]/.k_Integer:>points[[k]],cen], .00001]]&/@faces; 
faces=MapThread[List,{faces,circulation}]/.{poly_List,1}:>Reverse[poly]/.
{poly_List,-1}:>poly;
(Polygon /@ (inputpoints[[#]]& /@
Sort[FixedPoint[RotateLeft,#,
	SameTest->(First[#2]==Min[#2]&)]&/@faces]))
]

Plane Hull

convexhull2D[pts_]:=
Block[{cen,dis,idx,xfar,far,xsec,hull},
cen=cent[pts];
dis=mag[#-cen]& /@ pts;
idx=myOrdering[dis];
xfar=Last[idx];
far=pts[[xfar]];
xsec=Sort[{10+  ang2[{cen,far},pts[[#]] ]-10.,
	mag[(far-pts[[#]])] ,#} &/@idx][[-2,-1]];
hull={xfar,xsec};

FixedPoint[Last[AppendTo[hull, 
Sort[ {10+ang[  pts[[Take[hull,-2] ]],
pts[[#]] ]-10.,
mag[(pts[[ Last[hull] ]] -pts[[#]])] ,#} &/@idx] [[-3,-1]] ] ]&,0,
SameTest->(First[hull]==#2 &)];
pts[[ Drop[hull,-1] ]]
]

Code snippets

mag::usage = "mag[v_] returns the norm or magnitude of
the n-vector 'v'.";
mag[v_]:= N[Sqrt[v.v]]

unit::usage = "unit[v_] returns the unit vector in
the direction of the n-vector 'v'.";
unit[v_]:=v/mag[v]

cent::usage = "cent[v_] returns the centroid of the list
of n-vectors 'v'.";
cent[v_]:=Plus@@v/Length[v]

slowvunion::usage = "slowvunion[v] returns the union of a list of n-vectors.
It is slow but infallible.";

slowvunion[v_]:=
Union[Chop[v, .000001],
SameTest->((Sign[#1]==Sign[#2]) &&
( Chop[#1-#2, .000001]==Table[0,{Length[ v[[1]] ]}] ) &)]

(*Carl Woll's vector union*)
tol=.000001;
vunion1[v_]:= Union[v, SameTest->(Max[Abs[#1 - #2]] < tol &)] 
vunion[v_]:= Module[{r},
r = Split[Sort[Chop[v,.000001]], (Abs[#1[[1]] - #2[[1]]] < tol &)];
Flatten[vunion1 /@ r, 1]]

(*transforms Graphics3D polyhedron into a list of Head-less polygons*)
parse[poly_] := Cases[Level[poly,{-3}],{{_,_,_}..}]

(*from Graphics:Shapes*)
trans[shape_, vec_List] :=
Block[{tvec = N[vec]},
  shape /. { poly:Polygon[_] :> Map[(tvec + #)&, poly, {2}],
		   ln:Line[_] :> Map[(tvec + #)&, ln, {2}],
		   pt:Point[_] :> Map[(tvec + #)&, pt,{1}] }
]

(*polysort orders the vertices of regular polygons*)
siv[v_, exist_, thenew_] := Block[{srt, targ, n}, 
   n = Length[v]; srt = Flatten[Join[exist, Position[v, thenew]]]; 
    targ = Complement[Range[n], srt]; {srt, targ}]

polysort[v_List] := Block[{ed, srt, targ, pt, n}, 
   n = Length[v]; ed = Min[(N[mag[First[v] - #1]] & ) /@ Rest[v]]; 
    pt = v[[1]]; {srt, targ} = siv[v, {}, pt]; While[Length[srt] < n, 
     pt = First[Select[v[[targ]], N[mag[pt - #1] - ed] < 0.001 & ]]; 
      {srt, targ} = siv[v, srt, pt]]; v[[srt]]]

tau=N[GoldenRatio];

(*given vertices of regular pentagon, returns inscribed pentagram*)
(*pentagram is broken into central pentagon and five triangles*)
pentagram[gon_] := Block[{p, p1, p2, g1}, 
   p = Partition[Join[gon[[{1, 3, 5, 2, 4}]], {gon[[1]]}], 2, 1]; 
    p1 = ((#1[[2]] - #1[[1]])/tau & ) /@ p; 
    p2 = Table[p[[i,1]] + p1[[i]], {i, Length[p]}]; 
    g1 = Min[Union[(mag[p[[1,1]] - #1] & ) /@ p2, 
       SameTest -> (Chop[#1 - #2,.000001] == 0 & )]]; 
    Join[ {polysort[p2]}, 
      Table[Join[{p[[i,1]]}, Select[p2, 
          Abs[mag[p[[i,1]] - #1] - g1] < 0.01 & ]], {i, 5}] ](*end Join*)
]

(*test for degenerate 3D triangle*)
areatest[gon_]:=Chop[ mag[ mycross[ gon[[2]]-gon[[1]], gon[[3]]-gon[[2]] ] ],.000001 ]>0

(*given a list of points, subtract all from the first*)
diff[v_List]:=Map[(v[[1]]-#)&, v]

hollowPolygon::usage = "hollowPolygon[poly_, k_, w_] accepts a
Graphics3D polyhedron as input, and returns a polyhedron with a hole
similar in shape to each polygon cut out from the center. The 'k'
variable governs whether the strips at the edges tilt in our out or
(when k=1) do not tilt. The 'w' variable governs how wide the strips are;
larger w gives narrower strips.";

hollowface[face_List, k_, w_] := Block[{apex, i, f = Length[face]}, 
   apex = N[(k*Plus @@ face)/f]; rad = w/Sin[Pi/f]; 
    Table[Polygon[{(apex - face[[i]])/rad + face[[i]], face[[i]], 
       face[[Mod[i, f] + 1]], (apex - face[[Mod[i, f] + 1]])/rad + 
        face[[Mod[i, f] + 1]]}], {i, f}]]
        
hollowPolygon[poly_, k_:1, w_:2] := 
  Flatten[poly /. Polygon[x_] :> hollowface[x, k, w]] /; NumberQ[N[k]]

faceproject::usage = "faceproject[poly,dual,view] projects into a 3-space
all polygons bounding the polychoron 'poly' with dual 'dual' and
viewpoint 'view'. It also projects the edges and vertices.";

faceproject[poly_,dual_,view_]:=
Block[{c1,c2,c3,c4,gbas},
gbas=NullSpace[ {N[view]} ];
c1=facefind[poly,dual];
c2=Map[polysort[#]&, c1];
c3=Map[Chop[gbas.#,.000001]&, c2, {2}];
c4=Map[Polygon[#]&, c3 ];
 Graphics3D[
  {EdgeForm[],c4,
  AbsoluteThickness[.5],Line /@ Map[ Dot[ gbas, # ]&, edgefind[poly], {2}],
  AbsolutePointSize[4],RGBColor[1,0,0],Point /@ vunion[Map[ Chop[Dot[ gbas, # ],.000001]&, poly]]}
 ]
]

(*given ordered vertices of a polygon, returns edges*)
toedges[poly_]:=Partition[Join[poly,{First@poly}],2,1]

Simplexes, Cross Polytopes, Hypercubes

See Chapters 8.7 and 13.4 of Regular Polytopes,
H.S.M. Coxeter, Dover, 1973.

nCube::usage = "nCube[n] gives the 2^n vertices
of an n-dimensional cube centered upon the origin,
of edge length 2, and with its bounding hyperplanes
parallel to the coordinate hyperplanes.";

nCube[n_]:= Flatten[
Table[Permutations[Join[Table[1,{j}],Table[-1,{n-j}]]],
{j,0,n}],1]

xyCube::usage = "xyCube[n] gives the 2^n vertices
of an n-dimensional cube centered upon the origin,
of edge length Sqrt[2n], such that the projection
into the {x,y} plane is isometric.";

xyCube[n_]:=zonotope[Take[xyCross[n],n]]

nCross::usage = "nCross[n] gives the 2n vertices
of an n-dimensional cross polytope or orthoplex,
centered upon the origin, of edge length Sqrt[2],
and unit circumradius.";

nCross[n_]:= Join[-IdentityMatrix[n],IdentityMatrix[n]]

xyCross::usage = "xyCross[n] gives the 2^n vertices
of an n-dimensional cross polytope centered upon the origin,
of edge length Sqrt[n], such that the projection
into the {x,y} plane is especially symmetrical.";

xyCross[n_]:=(*as per 13.4 Regular Polytopes*)
Block[{a,r,k},
a=N[Table[
Flatten[Table[{Cos[(2*r-1) Pi k/n],Sin[(2*r-1) Pi k/n]},
	{r,Floor[n/2]}]],{k,2*n}]];
If[OddQ[n],Table[Join[a[[k]],{N[((-1)^k)/Sqrt[2]]}],{k,2*n}],a]
]

nSimplex::usage = "nSimplex[n] gives the (n+1) vertices
of an n-simplex of edge Sqrt[n+1].";

nSimplex[n_]:=
Block[{a,r,k},
a=N[Table[
Flatten[Table[{Cos[2 Pi k r/(n+1)],Sin[2 Pi k r/(n+1)]},
	{r,Floor[n/2]}]],{k,0,n}]];
If[OddQ[n],Table[Join[a[[k]],{N[((-1)^k)/Sqrt[2]]}],{k,n+1}],a]
]

zonotope::usage = "zonotope[vectors] accepts a list of n-vectors
'vectors'. It returns 2^(Length[vectors]) n-vectors,
which are the projection (possibly oblique) of the vertices of a
(Length[vectors])-orthotope into the n-space.
Example: zonotope[{{1,0,0},{0,1,0},{0,0,1}}] returns
the vertices of a 3-cube.";

zonotope[vectors_List]:=(nCube[Length[vectors]].vectors)

Edges, Faces, Cells

edgefind::usage = "edgefind[poly] returns the edges
of equilateral regular polytopes.";

edgefind[poly_]:=
Block[{a,b},
b=First@Union[ Map[mag[First@poly-#]&, Rest@poly],
SameTest->(Chop[#1-#2,.000001]==0&)];
Flatten[Table[
a=Drop[poly,i-1];
{First@a,#}& /@ Select[Rest@a, Abs[ mag[First@a-#] - b ]<.001&],
{i,Length[poly]}],1]
]

facefind::usage = "facefind[poly,dual] returns the polygons
bounding the regular convex polychoron 'poly'.";

facefind[poly_,dual_]:=
Block[{a,d,f1},
Print["There are ",Length[poly]," vertices altogether"];
a=rectify[dual];
d=First@Union[Map[mag[First@a-#]&, poly],
SameTest->(Chop[#1 - #2,.000001]==0 &)];
f1=Table[
Select[poly,Abs[ mag[a[[k]]-#] - d ]<.001&],
{k,Length[a]}];
Print["There are ",Length[f1]," polygons with ",Length[ f1[[1]] ]," vertices"];
f1
]

cellfind::usage = "cellfind[poly,dual] returns the vertices
of polyhedra bounding the regular convex polychoron 'poly'.";

cellfind[poly_,dual_]:=
Block[{v,v1,d1,c1},
v=poly;
Print["There are ",Length[v]," vertices altogether"];

v1=dual;(*the dual*)
d1=First@Union[ Map[mag[v1[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];

c1=Table[
Select[v, Abs[ mag[v1[[ i ]]-#] - d1 ]<.001&],
{i,Length[v1]}];

Print["There are ",Length[c1]," polyhedra with ",Length[ c1[[1]] ]," vertices"];

c1
]

cellfacefind::usage = "cellfacefind[poly,dual] returns the polygons
bounding polyhedra bounding the regular convex polychoron 'poly'.";

cellfacefind[poly_,dual_]:=
Block[{a,c1,c2,d}, 
a=rectify[dual];
d=First@Union[Map[N[mag[First@a-#]]&, poly],
SameTest->(Chop[#1 - #2,.000001]==0 &)];
c1=Table[
Select[poly,Abs[ N[mag[a[[k]]-#]] - d ]<.001&],
{k,Length[a]}];
d=First@Union[Map[mag[dual[[1]]-cent[#]]&, c1],
SameTest->(Chop[#1 - #2,.000001]==0 &)];
c2=Table[
Select[c1, Abs[ mag[dual[[k]]-cent[#] ] - d ]<.001&],
{k,Length[dual]}];
Print["There are ",Length[c2]," cells, each cell bounded by ",
First@Union[Map[Length,c2]]," polygons, each polygon bounded by ",
First@Union[ Map[Length, c2[[1]] ] ]," sides."];
c2
]

edgespan::usage = "edgespan[poly,d] finds the edges of length 'd'
in the polytope 'poly'. It is like 'edgefind' with a distance argument.";

edgespan[poly_,d_] :=
Block[{a, b},  
 Flatten[
 Table[a = Drop[poly, i - 1]; 
   ({First[a], #1} & ) /@ Select[Rest[a], 
    Abs[mag[First[a] - #1] - d] < 0.001 & ], 
 {i, Length[poly]}],1]
]

4D Rotation Matrices

xymat[t_]:={{Cos[t],Sin[t],0,0}, {-Sin[t],Cos[t],0,0},
{0, 0, 1, 0}, {0,0,0,1}}

yzmat[t_]:={{1,0,0,0}, {0,Cos[t],Sin[t],0},
{0,-Sin[t],Cos[t],0}, {0,0,0,1}}
	
zxmat[t_]:={{Cos[t],0,-Sin[t],0}, {0,1,0,0},
{Sin[t],0,Cos[t],0}, {0,0,0,1}}

xwmat[t_]:={{Cos[t],0,0,Sin[t]}, {0,1,0,0},
{0,0,1,0}, {-Sin[t],0,0,Cos[t]}}

ywmat[t_]:={{1,0,0,0}, {0,Cos[t],0,-Sin[t]},
{0,0,1,0}, {0,Sin[t],0,Cos[t]}}

zwmat[t_]:={{1,0,0,0}, {0,1,0,0},
{0,0,Cos[t],-Sin[t]}, {0,0,Sin[t],Cos[t]}}

(*Below, Richard Koch's algorithm to return a rotation matrix to bring an arbitrary {x,y,z,w} into coincidence with {0,0,0,w}.*)

twk[v_, f_] := With[
{
a=((v . f) - (e4 . f) (e4 . v)) / (1 - (f . e4)^2),
b=((v . e4) - (v. f) (e4 . f)) / (1 - (f . e4)^2)
},
v - (a + b) f + (a + 2 b (f . e4) - b) e4
]

r4Matrix[f_] := Block[
{q,
e1 = {1, 0, 0, 0},
e2 = {0, 1, 0, 0},
e3 = {0, 0, 1, 0},
e4 = {0, 0, 0, 1}},
q=N[unit[f]];
Transpose[{twk[e1,q], twk[e2,q], twk[e3,q], twk[e4,q]}]
]

r4Matrix::usage = "r4Matrix[{x,y,z,w}] gives the rotation matrix needed to rotate a point in R4 into coincidence with the w axis, {0,0,0,1}. Not all of {x,y,z} can be zero.";

ViewPoints, Edges, Truncation, Rectification, Sectioning

vertvpt[polychoron_]:=N[ First@polychoron ]

edgevpt[polychoron_]:=
Block[{a},
a=First@Union[(mag[First@polychoron - #1] & ) /@ Rest@polychoron, 
        SameTest -> (Chop[#1 - #2,.000001] == 0 & )];
b=Select[Rest@polychoron, 
    Abs[mag[First@polychoron - #1] - a] < 0.001 & ];
N[ cent[ {First@polychoron, First@b} ] ]
]

facevpt[polychoron_,dual_]:=edgevpt[dual]

cellvpt[polychoron_,dual_]:=vertvpt[dual]

(*for R4mat*)
rvertvpt[polychoron_]:=First@Select[polychoron,Chop[#[[3]],.000001]!=0&]

redgevpt[polychoron_]:=
Block[{a},
a=First@Union[(mag[First@polychoron - #1] & ) /@ Rest@polychoron, 
        SameTest -> (Chop[#1 - #2,.000001] == 0 & )];
First@Select[
	N[(cent[{First@polychoron, #1}] & )] /@ Select[Rest@polychoron, 
    Abs[mag[First@polychoron - #1] - a] < 0.001 & ],
    Chop[#[[3]],.000001]!=0&]
]

rfacevpt[polychoron_,dual_]:=redgevpt[dual]

rcellvpt[polychoron_,dual_]:=rvertvpt[dual]

vedgecenter::usage = "vedgecenter[tr,par] gets the center
of an edge of a 'vertex-figure-type'-cell of the truncated
or rectified convex polychoron with vertices 'tr',
derived from the parent polychoron 'par'.";

vedgecent[tr_,par_]:=
Block[{d,vfig},
d=First@Union[ Map[mag[par[[1]]-#]&, tr],
SameTest->(Abs[#1-#2]<.001&)];
vfig=Select[tr, Abs[ mag[par[[1]]-#] - d]<.001&];
cent[First@edgefind[vfig]]
]

vfacecenter::usage = "vfacecenter[tr,par] gets the center
of a face of a 'vertex-figure-type'-cell of the truncated
or rectified convex polychoron with vertices 'tr',
derived from the parent polychoron 'par'.";

vfacecent[tr_,par_]:=
Block[{d,vfig,a,b,s,t},
d=First@Union[ Map[mag[par[[1]]-#]&, tr],
SameTest->(Abs[#1-#2]<.001&)];
vfig=Select[tr, Abs[ mag[par[[ 1 ]]-#] - d ]<.001&];
a=First@edgefind[vfig];
b=mag[ a[[1]]-a[[2]] ];
s=Select[vfig, Abs[ mag[vfig[[ 1 ]]-#] - b ]<.001&];
t=Join[{vfig[[1]]},Take[s,2]];

If[tr==truncate[vi343,3] || tr == truncate[vii343, 3] || tr == rectify[vi343],
	(*{3,4,3}*)
	vpt=cent[
	Join[t,Select[Rest@vfig,
	Abs[ mag[t[[ 2 ]]-#] - b ]<.001 &&
	Abs[ mag[t[[ 3 ]]-#] - b ]<.001&]]
	],
	(*Else*)
	vpt=cent[t]
]
]

truncate::usage = "truncate[v, n] accepts the vertices of the
regular convex polytope 'v' bounded by polygons with 'n'
sides, and returns the vertices of the semi-regular convex
polytope bounded in part by regular 2n-gons.";

truncate[v_,n_]:= Flatten[Map[loc[#,n]&, edgefind[v] ],1]

loc[v_List,n_]:=
Block[{a,b,c,d,e},
a=(v[[2]]-v[[1]]);
d=mag[a];(*length of edge*)
r1=(mag[a]/(2*Sin[Pi/n]));(*circumradius*)
r2=(r1*Cos[Pi/n])/Cos[Pi/(2*n)];(*second circumradius*)
e=r2*2*Sin[Pi/(2*n)];(*inscribed edge length*)
b=(d-e)/2;
{v[[1]]+(unit[a]*b),v[[2]]-(unit[a]*b)} 
]

rectify::usage = "rectify[v] accepts the vertices of the
regular convex polytope 'v' and returns the midpoints of
its edges.";

rectify[v_]:= Map[ cent[#]&, edgefind[v] ]

(*find the section, if it exists, of a segment '{p, q}'
by the subspace perpendicular to the unit vector 'vec'
at distance 'dist' from the origin*)

section[{p_,q_}, dist_, vec_]:=
Block[{t,num,num2,denom},
num=Chop[(dist-vec.p),.000001];
num2=Chop[(dist-vec.q),.000001];
If[num==num2==0,{p,q},
   If[num==0, p,
   denom=Chop[(vec.(q-p)),.000001];
     If[denom==0,
     t = Infinity,
     t = Chop[num/denom, .000001]];
   If[(t >= 0) && (t <= 1.00000001), p + t*(q-p)]
   ]
]

]

(*find the section, if it exists, of a segment '{p, q}'
by the subspace perpendicular to the unit vector {0,0,0,1}
at distance 'dist' from the origin*)

wsection[{p_,q_}, dist_]:=
Block[{t,num,denom},
num=Chop[(dist-p[[4]]), .001];
If[num==0, p,
denom=Chop[(q[[4]]-p[[4]]), .001];
If[denom==0,
t = Infinity,
t = num/denom]; 
If[(t >= 0) && (t <= 1), p + t*(q - p)]
](*end if*)
]

(*find the distance from the point 'pt' to the plane
(or n-1)-space) with unit normal 'norm' at distance 'dist'
from the origin.*)

ptspace[pt_,norm_,dist_]:=Abs[(pt.norm)+dist]

Vertex Figures, Cells Meeting at a Vertex, All Cells

cellfigure[v_, dual_]:= (*makes cells at vertex figure*)
Block[{a,b,c,d,c1,d1,vpt,v1,gbas,cells,r},

d1=First@Union[ Map[mag[dual[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];

c1=Table[
Select[v, Abs[ mag[dual[[ i ]]-#] - d1 ]<.001&],
{i,Length[dual]}];

vpt=v[[1]];

gbas=NullSpace[ {N[vpt]} ];

cells=Select[c1,MemberQ[#,vpt]&];

Table[
r=Map[ Dot[ gbas, # ]&, cells[[k]] ];
Graphics3D[ConvexHull3D[r]],
{k,Length[cells]}]
]

vertexfigure[v_]:= (*makes undistorted vertex figure*)
Block[{a,b,c,d,d1,vpt,q,q1,gbas,r},

d1=First@Union[ Map[mag[v[[1]]-#]&, Rest@v],
SameTest->(Abs[#1-#2]<.001&)];

vert=First@v;

q=Select[v,Abs[mag[vert-#]-d1]<.001&];
q1=Map[vert+((#-vert)/2)&,q];

gbas=N[unit[#]]& /@ NullSpace[ {N[vert]} ];

r=Map[ Dot[ gbas, # ]&, q1 ];
Graphics3D[ConvexHull3D[r]]
]

celldual::usage = "celldual[poly,dual] constructs an unforeshortened cell
of the regular convex polychoron 'poly', and its dual (the polyhedron determined by the endpoints of the edges meeting at a vertex of the dual). The function returns a list of three Graphics3D objects,
{cell, dual of cell, {cell, dual of cell}}.";

celldual[poly_,dual_]:=
Block[{d1,d2,cell,dualcell,gbas,r,q1,q2},

d1=First@Union[ Map[mag[dual[[1]]-#]&, poly],
SameTest->(Abs[#1-#2]<.001&)];
cell=Select[poly, Abs[ mag[dual[[ 1 ]]-#] - d1 ]<.001&];

d2=First@Union[ Map[mag[dual[[1]]-#]&, Rest@dual],
SameTest->(Abs[#1-#2]<.001&)];
dualcell=Select[Rest@dual, Abs[ mag[dual[[ 1 ]]-#] - d2 ]<.001&];

gbas=N[unit[#]]& /@ NullSpace[{ N[ dual[[1]] ] }];

r=vunion[ Map[ Dot[ gbas, # ]&, cell ] ];
q1=Graphics3D[ConvexHull3D[r]];

r=vunion[ Map[ Dot[ gbas, # ]&, dualcell ] ];
q2=Graphics3D[ConvexHull3D[r]];

{q1,q2,{q1,q2}}
]

Vertices of Regular Convex Polychora

(*the vertices of {4,3,3}*)
v433=nCube[4];

(*the vertices of {3,3,4}*)
v334=nCross[4];

(*the vertices of {3,3,3}*)
v333=nSimplex[4];

(*The vertices of {3,4,3}, as midpoints
of the edges of the 4-orthoplex*)
vi343=rectify[2*v334];

(*The vertices of the reciprocal {3,4,3}*)
vii343=Join[nCube[4],Permutations[{2,0,0,0}],Permutations[{-2,0,0,0}]];

evenperms={{1, 2, 3, 4}, {3, 1, 2, 4}, {2, 3, 1, 4}, {4, 2, 1, 3}, 
  {1, 4, 2, 3}, {2, 1, 4, 3}, {1, 3, 4, 2}, {4, 1, 3, 2}, 
  {3, 4, 1, 2}, {4, 3, 2, 1}, {2, 4, 3, 1}, {3, 2, 4, 1}};

(*The vertices of {3,3,5} as per Section 8.7 p.157 RP*)

Block[{t,a,b,c},
t=(1+5^.5)/2;

a=Union[ Map[{t,1,1/t,0}*#&,nCube[4] ] ];
b=Flatten[Table[Map[a[[k,#]]&, evenperms],{k,Length[a]}],1];
c=Join[nCube[4],Permutations[{2,0,0,0}],Permutations[{-2,0,0,0}]];
v335=Union[Join[b,c]];(*vertices named "v335"*)
](*end Block*)

(*the vertices of {5,3,3} as per Section 8.7 p.157 RP*)

Block[{t,a,b,c,d},
t=(1+5^.5)/2;

a=Union[ Map[{t^2,t^-2,1,0}*#&,nCube[4] ] ];
b=Flatten[Table[Map[a[[k,#]]&, evenperms],{k,Length[a]}],1];

a=Union[ Map[{5^.5,t^-1,t,0}*#&,nCube[4] ] ];
c=Flatten[Table[Map[a[[k,#]]&, evenperms],{k,Length[a]}],1];

a=Union[ Map[{2,1,t,t^-1}*#&,nCube[4] ] ];
d=Flatten[Table[Map[a[[k,#]]&, evenperms],{k,Length[a]}],1];

a=
Join[
Union[Flatten[Map[Permutations,Map[Join[#,{0,0}]&,2*nCube[2]]],1]],
Union[Flatten[Map[Permutations,Map[{5^.5,1,1,1}*#&,nCube[4]]],1]],
Union[Flatten[Map[Permutations,Map[{t,t,t,t^-2}*#&,nCube[4]]],1]],
Union[Flatten[Map[Permutations,Map[{t^2,t^-1,t^-1,t^-1}*#&,nCube[4]]],1]]
];

v533=Join[a,b,c,d];(*vertices named "v533"*)
](*end Block*)

Special Vertices for {5,3,3}

vii533={{-0.9164494541944656, -0.09632271904275573, 
   0.03547032122601772, 0.07966764585583214}, 
  {-0.9164494541944654, 0.09632271904275588, 
   0.035470321226017495, -0.07966764585583247}, 
  {-0.8763962154337788, -0.28475839209841197, 
   -0.08293887632543677, -0.026948474501559724}, 
  {-0.8763962154337788, -0.026948474501559253, 
   -0.08293887632543599, 0.2847583920984126}, 
  {-0.8763962154337788, 0.026948474501559405, 
   -0.08293887632543676, -0.2847583920984126}, 
  {-0.8763962154337788, 0.284758392098412, 
   -0.08293887632543682, 0.02694847450155955}, 
  {-0.8628477583173166, -0.1558534332999856, 
   0.26711366620555893, 0.1289049587984262}, 
  {-0.8628477583173166, 0.15585343329998574, 
   0.26711366620555876, -0.12890495879842653}, 
  {-0.8516419525201596, -0.20857260465425861, 
   -0.1561197849928364, -0.25217615234274204}, 
  {-0.8516419525201596, 0.2085726046542587, 
   -0.15611978499283585, 0.2521761523427421}, 
  {-0.8297200884106035, 0, 0.4102771266706327, 0}, 
  {-0.811588713759473, -0.33184379819857385, 
   -0.2745289825442909, 0.11224988561150279}, 
  {-0.811588713759473, -0.17250850648690919, 
   -0.2745289825442903, 0.30489532369701483}, 
  {-0.811588713759473, 0.17250850648690927, 
   -0.27452898254429087, -0.30489532369701466}, 
  {-0.811588713759473, 0.3318437981985739, 
   -0.27452898254429114, -0.11224988561150281}, 
  {-0.7980402566430109, -0.46074875699700013, 
   0.07552355998670458, -0.043603547688483534}, 
  {-0.7980402566430108, -0.043603547688482854, 
   0.07552355998670515, 0.46074875699700085}, 
  {-0.7980402566430108, 0.04360354768848303, 
   0.0755235599867039, -0.46074875699700113}, 
  {-0.7980402566430107, 0.46074875699700024, 
   0.07552355998670464, 0.04360354768848287}, 
  {-0.789666849649917, -0.3810811111411678, 
   0.2918679291191782, 0.05271917135427235}, 
  {-0.7896668496499168, -0.1232711935443152, 
   0.29186792911917814, 0.3644260379542447}, 
  {-0.7896668496499168, 0.12327119354431533, 
   0.2918679291191773, -0.36442603795424516}, 
  {-0.7896668496499167, 0.381081111141168, 
   0.29186792911917825, -0.05271917135427302}, 
  {-0.7715354749987862, -0.20857260465425867, 
   -0.3929381800957454, -0.25217615234274177}, 
  {-0.7715354749987862, 0.2085726046542587, 
   -0.392938180095745, 0.25217615234274193}, 
  {-0.7579870178823241, 0.33747756345268504, 
   -0.042885637564749224, 0.40802958564272784}, 
  {-0.757987017882324, -0.337477563452685, 
   -0.0428856375647502, -0.40802958564272784}, 
  {-0.7467812120851671, -0.28475839209841214, 
   -0.46611908876314545, -0.026948474501559384}, 
  {-0.7467812120851671, -0.026948474501559343, 
   -0.46611908876314484, 0.2847583920984124}, 
  {-0.7467812120851671, 0.02694847450155938, 
   -0.46611908876314523, -0.28475839209841225}, 
  {-0.7467812120851671, 0.28475839209841214, 
   -0.46611908876314545, 0.026948474501559384}, 
  {-0.7360651537727679, -0.1289049587984263, 
   0.5235112740987194, -0.15585343329998608}, 
  {-0.7360651537727679, 0.12890495879842634, 
   0.5235112740987197, 0.15585343329998594}, 
  {-0.724859347975611, -0.49333099675267067, 
   0.1002778229003233, -0.2791246268443016}, 
  {-0.724859347975611, 0.1816241301526993, 
   0.1002778229003243, 0.5369345444411543}, 
  {-0.7248593479756109, -0.18162413015269918, 
   0.10027782290032286, -0.5369345444411546}, 
  {-0.7248593479756109, 0.4933309967526708, 
   0.10027782290032401, 0.27912462684430095}, 
  {-0.7113108908591489, -0.36442603795424433, 
   0.45033036543131955, -0.12327119354431582}, 
  {-0.7113108908591488, -0.052719171354272815, 
   0.45033036543131894, -0.38108111114116866}, 
  {-0.7113108908591488, 0.05271917135427289, 
   0.4503303654313195, 0.38108111114116827}, 
  {-0.7113108908591488, 0.36442603795424444, 
   0.4503303654313199, 0.12327119354431518}, 
  {-0.7067279733244805, -0.09632271904275588, 
   -0.5845282863146002, 0.0796676458558323}, 
  {-0.7067279733244805, 0.09632271904275588, 
   -0.5845282863146002, -0.07966764585583232}, 
  {-0.6931795162080183, -0.5369345444411536, 
   -0.2344757437836042, 0.1816241301526993}, 
  {-0.6931795162080183, -0.2791246268443009, 
   -0.23447574378360314, 0.49333099675267117}, 
  {-0.6931795162080183, 0.27912462684430095, 
   -0.23447574378360425, -0.4933309967526709}, 
  {-0.6931795162080183, 0.5369345444411536, 
   -0.23447574378360442, -0.1816241301526993}, 
  {-0.6848061092149244, -0.6166021902969859, 
   -0.018131374651130627, 0.08530141110994316}, 
  {-0.6848061092149244, -0.1994569809884686, 
   -0.018131374651129805, 0.5896537157954271}, 
  {-0.6848061092149242, 0.1994569809884687, 
   -0.01813137465113139, -0.5896537157954271}, 
  {-0.6848061092149242, 0.616602190296986, 
   -0.01813137465113073, -0.08530141110994369}, 
  {-0.6712576520984622, -0.4876972314985596, 
   0.3319211678798653, 0.2411548444099289}, 
  {-0.6712576520984622, -0.328361939786895, 
   0.3319211678798651, 0.433800282495441}, 
  {-0.6712576520984621, -0.4338002824954408, 
   0.33192116787986453, -0.32836193978689576}, 
  {-0.6712576520984621, -0.24115484440992907, 
   0.33192116787986387, -0.48769723149856037}, 
  {-0.6712576520984621, 0.2411548444099291, 
   0.3319211678798649, 0.4876972314985599}, 
  {-0.6712576520984621, 0.3283619397868951, 
   0.3319211678798644, -0.43380028249544134}, 
  {-0.6712576520984621, 0.4338002824954409, 
   0.33192116787986525, 0.328361939786895}, 
  {-0.6712576520984621, 0.4876972314985597, 
   0.3319211678798652, -0.24115484440992943}, 
  {-0.6283720145337124, -0.33747756345268504, 
   -0.4260658500024585, -0.40802958564272757}, 
  {-0.6283720145337124, 0.33747756345268504, 
   -0.42606585000245806, 0.4080295856427277}, 
  {-0.6199986075406185, -0.5043523046854832, 
   -0.20972148086998466, 0.41714520930851745}, 
  {-0.6199986075406185, 0.41714520930851734, 
   -0.20972148086998443, 0.5043523046854835}, 
  {-0.6199986075406185, 0.5043523046854832, 
   -0.20972148086998538, -0.41714520930851734}, 
  {-0.6199986075406184, -0.4171452093085174, 
   -0.2097214808699852, -0.5043523046854834}, 
  {-0.6064501504241564, -0.6332572634839095, 
   0.14033106166101078, 0.2612917760085313}, 
  {-0.6064501504241564, -0.37544734588705686, 
   0.14033106166101098, 0.5729986426085033}, 
  {-0.6064501504241564, 0.3754473458870569, 
   0.14033106166100978, -0.5729986426085034}, 
  {-0.6064501504241562, 0.6332572634839095, 
   0.1403310616610107, -0.2612917760085318}, 
  {-0.5883187757730257, -0.46074875699700035, 
   -0.5444750475539135, -0.04360354768848221}, 
  {-0.5883187757730257, -0.04360354768848291, 
   -0.5444750475539117, 0.4607487569970016}, 
  {-0.5883187757730257, 0.04360354768848296, 
   -0.5444750475539126, -0.46074875699700096}, 
  {-0.5883187757730257, 0.4607487569970003, 
   -0.5444750475539133, 0.043603547688483194}, 
  {-0.5845282863146002, -0.07966764585583232, 
   0.7067279733244805, -0.09632271904275588}, 
  {-0.5845282863146002, 0.0796676458558323, 
   0.7067279733244805, 0.09632271904275588}, 
  {-0.5663969116634696, -0.6693213616512589, 
   0.02192186410955571, -0.2957797000312249}, 
  {-0.5663969116634696, -0.5638830189427131, 
   0.02192186410955657, 0.46638252225111154}, 
  {-0.5663969116634696, -0.16496905696577563, 
   0.02192186410955518, -0.7129249093397424}, 
  {-0.5663969116634696, 0.16496905696577568, 
   0.0219218641095571, 0.7129249093397423}, 
  {-0.5663969116634696, 0.5638830189427131, 
   0.02192186410955585, -0.46638252225111143}, 
  {-0.5663969116634695, 0.669321361651259, 
   0.021921864109556252, 0.29577970003122434}, 
  {-0.5551911058663126, -0.616602190296986, 
   -0.40131158708883974, 0.08530141110994416}, 
  {-0.5551911058663126, -0.19945698098846867, 
   -0.4013115870888375, 0.589653715795428}, 
  {-0.5551911058663126, 0.1994569809884687, 
   -0.40131158708883885, -0.5896537157954274}, 
  {-0.5551911058663126, 0.616602190296986, 
   -0.4013115870888396, -0.08530141110994317}, 
  {-0.5444750475539135, -0.4607487569970003, 
   0.5883187757730257, -0.043603547688484116}, 
  {-0.5444750475539134, -0.043603547688482985, 
   0.5883187757730254, 0.46074875699700046}, 
  {-0.5444750475539134, 0.043603547688483, 
   0.5883187757730248, -0.4607487569970007}, 
  {-0.5444750475539133, 0.46074875699700035, 
   0.5883187757730257, 0.043603547688482416}, 
  {-0.5416426487498505, -0.7455071490954124, 
   -0.051259044557843754, -0.0705520221900426}, 
  {-0.5416426487498505, -0.07055202219004233, 
   -0.0512590445578424, 0.745507149095413}, 
  {-0.5416426487498505, 0.07055202219004242, 
   -0.051259044557844385, -0.7455071490954128}, 
  {-0.5416426487498504, 0.7455071490954124, 
   -0.05125904455784365, 0.07055202219004209}, 
  {-0.5235112740987199, -0.15585343329998574, 
   -0.7360651537727678, 0.12890495879842706}, 
  {-0.5235112740987199, 0.15585343329998577, 
   -0.736065153772768, -0.12890495879842562}, 
  {-0.5197207846402944, -0.5369345444411537, 
   0.5151378671056259, 0.18162413015269813}, 
  {-0.5197207846402944, -0.27912462684430106, 
   0.5151378671056256, 0.4933309967526709}, 
  {-0.5197207846402944, 0.2791246268443011, 
   0.5151378671056251, -0.4933309967526711}, 
  {-0.5197207846402943, 0.5369345444411538, 
   0.5151378671056259, -0.18162413015269985}, 
  {-0.5151378671056259, -0.49333099675267084, 
   -0.5197207846402945, -0.2791246268443003}, 
  {-0.5151378671056259, -0.1816241301526993, 
   -0.5197207846402935, -0.5369345444411544}, 
  {-0.5151378671056259, 0.18162413015269935, 
   -0.5197207846402926, 0.536934544441155}, 
  {-0.5151378671056259, 0.49333099675267084, 
   -0.5197207846402943, 0.2791246268443013}, 
  {-0.5015894099891638, -0.31052908895112563, 
   -0.1696682421092986, -0.6927879777411396}, 
  {-0.5015894099891638, 0.31052908895112563, 
   -0.16966824210929715, 0.6927879777411399}, 
  {-0.5015894099891638, 0.6222359555510971, 
   -0.16966824210929832, 0.43497806014428675}, 
  {-0.5015894099891637, -0.6222359555510971, 
   -0.16966824210929876, -0.4349780601442869}, 
  {-0.4796675458796078, -0.572998642608503, 
   0.39672866955417085, -0.3754473458870571}, 
  {-0.47966754587960764, 0.26129177600853154, 
   0.3967286695541709, 0.6332572634839098}, 
  {-0.4796675458796076, -0.2612917760085316, 
   0.3967286695541701, -0.6332572634839101}, 
  {-0.47966754587960747, 0.5729986426085031, 
   0.3967286695541713, 0.3754473458870566}, 
  {-0.46611908876314545, -0.28475839209841214, 
   0.7467812120851671, -0.026948474501560307}, 
  {-0.46611908876314545, -0.026948474501559384, 
   0.746781212085167, 0.28475839209841214}, 
  {-0.46611908876314545, 0.026948474501559377, 
   0.746781212085167, -0.28475839209841214}, 
  {-0.46611908876314545, 0.28475839209841214, 
   0.746781212085167, 0.0269484745015591}, 
  {-0.46153617122847707, 0.07055202219004239, 
   -0.28807743966075244, -0.745507149095413}, 
  {-0.461536171228477, -0.7455071490954124, 
   -0.28807743966075317, -0.0705520221900416}, 
  {-0.461536171228477, -0.07055202219004232, 
   -0.2880774396607504, 0.7455071490954138}, 
  {-0.461536171228477, 0.7455071490954124, 
   -0.28807743966075305, 0.07055202219004258}, 
  {-0.45033036543132005, -0.381081111141168, 
   -0.7113108908591488, 0.05271917135427433}, 
  {-0.45033036543132005, -0.12327119354431525, 
   -0.7113108908591474, 0.36442603795424605}, 
  {-0.45033036543132005, 0.12327119354431529, 
   -0.7113108908591483, -0.3644260379542442}, 
  {-0.45033036543132, 0.38108111114116805, 
   -0.711310890859149, -0.0527191713542719}, 
  {-0.43678190831485797, -0.5638830189427132, 
   -0.3612583483281526, 0.4663825222511114}, 
  {-0.4367819083148579, -0.16496905696577568, 
   -0.3612583483281521, -0.7129249093397426}, 
  {-0.4367819083148579, 0.16496905696577574, 
   -0.3612583483281506, 0.7129249093397432}, 
  {-0.4367819083148579, 0.5638830189427132, 
   -0.361258348328153, -0.4663825222511114}, 
  {-0.43678190831485786, -0.669321361651259, 
   -0.361258348328153, -0.2957797000312239}, 
  {-0.43678190831485786, 0.6693213616512589, 
   -0.36125834832815285, 0.29577970003122483}, 
  {-0.4260658500024587, -0.40802958564272745, 
   0.6283720145337126, 0.33747756345268415}, 
  {-0.4260658500024587, 0.4080295856427274, 
   0.6283720145337124, -0.3374775634526853}, 
  {-0.414860044205302, -0.7724556235969717, 
   0.20513856333531683, 0.21420636990836903}, 
  {-0.414860044205302, -0.7185586745938529, 
   0.20513856333531638, -0.3553104142884546}, 
  {-0.4148600442053018, -0.2142063699083697, 
   0.2051385633353155, -0.7724556235969722}, 
  {-0.4148600442053018, 0.21420636990836972, 
   0.205138563335317, 0.772455623596972}, 
  {-0.4148600442053018, 0.3553104142884545, 
   0.2051385633353158, -0.7185586745938534}, 
  {-0.41486004420530176, -0.35531041428845456, 
   0.20513856333531677, 0.7185586745938533}, 
  {-0.4148600442053017, 0.772455623596972, 
   0.2051385633353166, -0.21420636990837025}, 
  {-0.41486004420530165, 0.718558674593853, 
   0.20513856333531677, 0.35531041428845417}, 
  {-0.4102771266706333, 0, -0.8297200884106035, 0}, 
  {-0.4013115870888398, -0.5896537157954267, 
   0.5551911058663127, -0.19945698098846976}, 
  {-0.4013115870888396, -0.08530141110994337, 
   0.5551911058663117, -0.6166021902969864}, 
  {-0.4013115870888396, 0.08530141110994338, 
   0.5551911058663123, 0.6166021902969862}, 
  {-0.4013115870888395, 0.5896537157954267, 
   0.5551911058663126, 0.19945698098846817}, 
  {-0.3967286695541713, -0.37544734588705686, 
   -0.47966754587960614, 0.5729986426085041}, 
  {-0.39672866955417124, -0.6332572634839096, 
   -0.4796675458796078, 0.2612917760085322}, 
  {-0.3967286695541712, 0.37544734588705686, 
   -0.47966754587960714, -0.5729986426085036}, 
  {-0.39672866955417113, 0.6332572634839096, 
   -0.4796675458796076, -0.2612917760085314}, 
  {-0.3929381800957456, -0.25217615234274166, 
   0.7715354749987863, 0.20857260465425773}, 
  {-0.3929381800957456, 0.25217615234274166, 
   0.771535474998786, -0.20857260465425895}, 
  {-0.37480680544461525, -0.8418298681381682, 
   0.08672936578386212, 0.009115623665789212}, 
  {-0.3748068054446151, 0.1668747412327983, 
   0.08672936578386103, -0.825174794951245}, 
  {-0.37480680544461503, -0.16687474123279827, 
   0.08672936578386264, 0.825174794951245}, 
  {-0.374806805444615, 0.8418298681381683, 
   0.08672936578386191, -0.009115623665790426}, 
  {-0.3612583483281531, -0.712924909339742, 
   0.43678190831485814, 0.16496905696577405}, 
  {-0.361258348328153, -0.46638252225111143, 
   0.43678190831485764, -0.5638830189427131}, 
  {-0.3612583483281529, -0.29577970003122467, 
   0.4367819083148576, 0.6693213616512591}, 
  {-0.3612583483281529, 0.29577970003122467, 
   0.4367819083148571, -0.6693213616512593}, 
  {-0.3612583483281529, 0.4663825222511114, 
   0.43678190831485797, 0.5638830189427131}, 
  {-0.3612583483281528, 0.712924909339742, 
   0.4367819083148578, -0.16496905696577646}, 
  {-0.35005254253099594, -0.6602057379854691, 
   0.013548457116462562, 0.5460501681069437}, 
  {-0.35005254253099594, 0.660205737985469, 
   0.013548457116462048, -0.5460501681069437}, 
  {-0.3319211678798655, -0.32836193978689504, 
   -0.6712576520984609, 0.43380028249544245}, 
  {-0.3319211678798654, -0.4876972314985597, 
   -0.6712576520984621, 0.2411548444099304}, 
  {-0.3319211678798654, -0.43380028249544095, 
   -0.6712576520984628, -0.3283619397868929}, 
  {-0.3319211678798654, -0.24115484440992915, 
   -0.6712576520984622, -0.4876972314985588}, 
  {-0.33192116787986536, 0.24115484440992915, 
   -0.6712576520984608, 0.48769723149856137}, 
  {-0.3319211678798653, 0.3283619397868951, 
   -0.6712576520984617, -0.43380028249544067}, 
  {-0.3319211678798653, 0.4338002824954409, 
   -0.6712576520984618, 0.328361939786896}, 
  {-0.33192116787986525, 0.4876972314985597, 
   -0.6712576520984623, -0.24115484440992813}, 
  {-0.30999930377030926, -0.4497274490641878, 
   -0.10486074043499297, -0.7398733838413014}, 
  {-0.30999930377030926, 0.44972744906418777, 
   -0.10486074043499194, 0.7398733838413014}, 
  {-0.30999930377030926, 0.6423728871496995, 
   -0.1048607404349925, 0.5805380921296367}, 
  {-0.3099993037703092, -0.6423728871496995, 
   -0.10486074043499291, -0.5805380921296368}, 
  {-0.2964508466538474, -0.8251747949512446, 
   0.24519180209600366, -0.16687474123279886}, 
  {-0.2964508466538471, -0.009115623665789871, 
   0.24519180209600255, -0.8418298681381686}, 
  {-0.2964508466538471, 0.009115623665789913, 
   0.24519180209600366, 0.8418298681381684}, 
  {-0.2964508466538469, 0.8251747949512447, 
   0.24519180209600333, 0.16687474123279775}, 
  {-0.2918679291191787, -0.36442603795424444, 
   -0.7896668496499174, -0.1232711935443124}, 
  {-0.2918679291191787, -0.0527191713542729, 
   -0.7896668496499171, -0.3810811111411663}, 
  {-0.29186792911917864, 0.05271917135427295, 
   -0.7896668496499153, 0.3810811111411703}, 
  {-0.2918679291191786, 0.36442603795424444, 
   -0.7896668496499166, 0.12327119354431693}, 
  {-0.2880774396607534, -0.7455071490954124, 
   0.46153617122847734, -0.07055202219004389}, 
  {-0.28807743966075305, -0.07055202219004238, 
   0.46153617122847673, 0.7455071490954125}, 
  {-0.28807743966075305, 0.07055202219004239, 
   0.46153617122847623, -0.7455071490954127}, 
  {-0.28807743966075294, 0.7455071490954124, 
   0.46153617122847695, 0.07055202219004159}, 
  {-0.274528982544291, 0.11224988561150279, 
   0.8115887137594727, 0.3318437981985743}, 
  {-0.2745289825442909, -0.30489532369701455, 
   0.8115887137594728, -0.17250850648691046}, 
  {-0.2745289825442909, -0.11224988561150279, 
   0.8115887137594727, -0.3318437981985741}, 
  {-0.2745289825442909, 0.30489532369701455, 
   0.8115887137594726, 0.17250850648690946}, 
  {-0.2699460650096226, -0.6602057379854691, 
   -0.22326993798644695, 0.5460501681069436}, 
  {-0.2699460650096225, 0.660205737985469, 
   -0.22326993798644737, -0.5460501681069436}, 
  {-0.2671136662055596, -0.12890495879842634, 
   -0.8628477583173172, -0.15585343329998286}, 
  {-0.2671136662055595, 0.1289049587984264, 
   -0.8628477583173163, 0.15585343329998785}, 
  {-0.2563976078931605, -0.7891106967838954, 
   0.1267826045445489, 0.39019673480695743}, 
  {-0.25639760789316046, -0.7019036014069294, 
   0.12678260454454843, -0.5313007791870427}, 
  {-0.2563976078931604, 0.39019673480695793, 
   0.12678260454454932, 0.7891106967838953}, 
  {-0.25639760789316035, -0.5313007791870428, 
   0.1267826045445491, 0.7019036014069295}, 
  {-0.25639760789316035, -0.39019673480695793, 
   0.12678260454454823, -0.7891106967838954}, 
  {-0.25639760789316035, 0.5313007791870427, 
   0.1267826045445486, -0.7019036014069294}, 
  {-0.25639760789316035, 0.7019036014069294, 
   0.12678260454454876, 0.5313007791870425}, 
  {-0.2563976078931603, 0.7891106967838953, 
   0.1267826045445486, -0.3901967348069582}, 
  {-0.24519180209600344, 0.16687474123279825, 
   -0.29645084665384663, -0.8251747949512451}, 
  {-0.2451918020960034, -0.16687474123279825, 
   -0.296450846653845, 0.8251747949512459}, 
  {-0.2451918020960034, 0.8418298681381682, 
   -0.296450846653847, -0.00911562366578983}, 
  {-0.24519180209600328, -0.8418298681381682, 
   -0.29645084665384713, 0.009115623665790759}, 
  {-0.23447574378360425, -0.4933309967526708, 
   0.6931795162080183, -0.27912462684430206}, 
  {-0.23447574378360422, 0.1816241301526993, 
   0.6931795162080181, 0.5369345444411541}, 
  {-0.2344757437836042, -0.1816241301526993, 
   0.6931795162080181, -0.536934544441154}, 
  {-0.23447574378360414, 0.4933309967526708, 
   0.693179516208018, 0.2791246268443011}, 
  {-0.22326993798644734, -0.5460501681069437, 
   0.2699460650096222, -0.660205737985469}, 
  {-0.22326993798644723, 0.5460501681069436, 
   0.2699460650096226, 0.6602057379854689}, 
  {-0.20972148086998516, -0.41714520930851734, 
   0.6199986075406183, -0.5043523046854834}, 
  {-0.20972148086998513, 0.5043523046854833, 
   0.6199986075406182, -0.41714520930851784}, 
  {-0.2097214808699851, -0.5043523046854833, 
   0.6199986075406188, 0.4171452093085162}, 
  {-0.20972148086998504, 0.41714520930851734, 
   0.6199986075406182, 0.5043523046854836}, 
  {-0.20513856333531677, -0.35531041428845445, 
   -0.4148600442053003, 0.7185586745938539}, 
  {-0.20513856333531666, -0.21420636990836975, 
   -0.41486004420530126, -0.7724556235969723}, 
  {-0.20513856333531666, 0.21420636990836978, 
   -0.41486004420530015, 0.7724556235969728}, 
  {-0.20513856333531666, 0.35531041428845445, 
   -0.41486004420530126, -0.7185586745938535}, 
  {-0.20513856333531666, 0.718558674593853, 
   -0.41486004420530165, 0.3553104142884549}, 
  {-0.20513856333531663, -0.718558674593853, 
   -0.414860044205302, -0.35531041428845356}, 
  {-0.2051385633353166, -0.7724556235969718, 
   -0.414860044205302, 0.21420636990837044}, 
  {-0.2051385633353166, 0.7724556235969717, 
   -0.41486004420530176, -0.21420636990836966}, 
  {-0.19159010621885458, -0.9013605823953981, 
   -0.06480750167430559, 0.058352936608383574}, 
  {-0.19159010621885458, 0.22640545549002816, 
   -0.064807501674306, -0.8744121078938387}, 
  {-0.19159010621885453, -0.22640545549002813, 
   -0.06480750167430485, 0.8744121078938388}, 
  {-0.19159010621885447, 0.9013605823953981, 
   -0.06480750167430589, -0.05835293660838435}, 
  {-0.16966824210929854, -0.6927879777411395, 
   0.5015894099891642, 0.31052908895112397}, 
  {-0.16966824210929843, 0.4349780601442868, 
   0.5015894099891636, -0.6222359555510973}, 
  {-0.16966824210929837, -0.4349780601442868, 
   0.5015894099891639, 0.6222359555510969}, 
  {-0.16966824210929835, 0.6927879777411395, 
   0.5015894099891633, -0.3105290889511263}, 
  {-0.15611978499283624, -0.25217615234274166, 
   0.85164195252016, 0.20857260465425664}, 
  {-0.15611978499283624, 0.25217615234274166, 
   0.8516419525201594, -0.2085726046542593}, 
  {-0.1403310616610109, -0.2612917760085316, 
   -0.6064501504241564, -0.6332572634839088}, 
  {-0.14033106166101086, -0.5729986426085031, 
   -0.6064501504241572, -0.37544734588705453}, 
  {-0.1403310616610108, 0.2612917760085316, 
   -0.606450150424155, 0.6332572634839113}, 
  {-0.1403310616610108, 0.5729986426085031, 
   -0.6064501504241558, 0.37544734588705797}, 
  {-0.12678260454454876, -0.5313007791870427, 
   -0.25639760789316, 0.7019036014069294}, 
  {-0.1267826045445487, -0.39019673480695793, 
   -0.2563976078931604, -0.7891106967838954}, 
  {-0.1267826045445487, 0.39019673480695793, 
   -0.2563976078931598, 0.7891106967838954}, 
  {-0.1267826045445487, 0.7019036014069294, 
   -0.25639760789316024, 0.5313007791870428}, 
  {-0.12678260454454868, 0.5313007791870427, 
   -0.25639760789316046, -0.7019036014069294}, 
  {-0.12678260454454865, -0.7891106967838954, 
   -0.25639760789316046, 0.3901967348069579}, 
  {-0.12678260454454865, -0.7019036014069294, 
   -0.2563976078931605, -0.5313007791870425}, 
  {-0.12678260454454865, 0.7891106967838953, 
   -0.25639760789316035, -0.39019673480695805}, 
  {-0.11840919755145476, -0.8687783426397276, 
   -0.04005323876068648, 0.29387401576420163}, 
  {-0.11840919755145472, 0.4516331333312103, 
   -0.04005323876068681, -0.7982263204496853}, 
  {-0.1184091975514547, -0.4516331333312104, 
   -0.040053238760686304, 0.7982263204496854}, 
  {-0.11840919755145465, 0.8687783426397275, 
   -0.04005323876068677, -0.2938740157642024}, 
  {-0.10486074043499272, -0.7398733838413014, 
   0.3099993037703096, 0.44972744906418705}, 
  {-0.10486074043499258, 0.5805380921296367, 
   0.30999930377030904, -0.6423728871496998}, 
  {-0.10486074043499255, -0.5805380921296368, 
   0.3099993037703094, 0.6423728871496993}, 
  {-0.10486074043499252, 0.7398733838413013, 
   0.30999930377030893, -0.44972744906418827}, 
  {-0.10027782290032423, -0.5369345444411537, 
   -0.7248593479756108, 0.18162413015270246}, 
  {-0.1002778229003242, -0.27912462684430095, 
   -0.7248593479756098, 0.49333099675267233}, 
  {-0.10027782290032405, 0.27912462684430106, 
   -0.7248593479756105, -0.4933309967526705}, 
  {-0.10027782290032398, 0.5369345444411537, 
   -0.7248593479756111, -0.18162413015269793}, 
  {-0.08672936578386198, -0.009115623665789906, 
   -0.3748068054446145, -0.8418298681381688}, 
  {-0.08672936578386198, 0.00911562366578994, 
   -0.37480680544461337, 0.8418298681381693}, 
  {-0.08672936578386195, 0.8251747949512447, 
   -0.37480680544461487, 0.16687474123279847}, 
  {-0.08672936578386181, -0.8251747949512447, 
   -0.37480680544461525, -0.16687474123279727}, 
  {-0.08293887632543642, 0.28475839209841214, 
   0.8763962154337784, 0.026948474501559128}, 
  {-0.0829388763254364, -0.026948474501559377, 
   0.8763962154337788, 0.28475839209841136}, 
  {-0.0829388763254364, 0.02694847450155939, 
   0.8763962154337784, -0.2847583920984127}, 
  {-0.08293887632543637, -0.28475839209841214, 
   0.876396215433779, -0.026948474501561598}, 
  {-0.0755235599867051, -0.46074875699700035, 
   -0.7980402566430111, -0.04360354768847819}, 
  {-0.07552355998670503, 0.04360354768848299, 
   -0.7980402566430109, -0.4607487569969986}, 
  {-0.075523559986705, -0.04360354768848293, 
   -0.7980402566430093, 0.4607487569970026}, 
  {-0.07552355998670489, 0.46074875699700035, 
   -0.7980402566430107, 0.04360354768848497}, 
  {-0.0648075016743061, -0.8744121078938387, 
   0.19159010621885486, -0.2264054554900285}, 
  {-0.06480750167430585, -0.05835293660838396, 
   0.19159010621885605, -0.901360582395398}, 
  {-0.06480750167430585, 0.05835293660838399, 
   0.19159010621885522, 0.9013605823953981}, 
  {-0.06480750167430575, 0.8744121078938387, 
   0.19159010621885442, 0.22640545549002788}, 
  {-0.051259044557844045, -0.7455071490954124, 
   0.5416426487498507, -0.07055202219004522}, 
  {-0.05125904455784372, -0.07055202219004239, 
   0.5416426487498519, 0.745507149095411}, 
  {-0.051259044557843705, 0.07055202219004235, 
   0.5416426487498504, -0.7455071490954124}, 
  {-0.051259044557843594, 0.7455071490954125, 
   0.5416426487498504, 0.07055202219004159}, 
  {-0.04288563756474971, 0.4080295856427274, 
   0.7579870178823237, -0.33747756345268587}, 
  {-0.042885637564749654, -0.4080295856427274, 
   0.7579870178823246, 0.33747756345268276}, 
  {-0.04005323876068682, -0.7982263204496853, 
   0.1184091975514548, -0.45163313333121025}, 
  {-0.040053238760686734, -0.293874015764202, 
   0.11840919755145624, -0.8687783426397275}, 
  {-0.040053238760686734, 0.293874015764202, 
   0.11840919755145542, 0.8687783426397278}, 
  {-0.04005323876068668, 0.7982263204496853, 
   0.11840919755145471, 0.45163313333121036}, 
  {-0.035470321226018314, -0.07966764585583225, 
   -0.9164494541944661, -0.096322719042753}, 
  {-0.035470321226018245, 0.07966764585583233, 
   -0.9164494541944652, 0.09632271904275799}, 
  {-0.02192186410955621, -0.29577970003122456, 
   -0.5663969116634686, 0.6693213616512598}, 
  {-0.021921864109556183, -0.46638252225111143, 
   -0.5663969116634704, -0.5638830189427115}, 
  {-0.02192186410955616, -0.7129249093397418, 
   -0.5663969116634695, 0.16496905696577827}, 
  {-0.02192186410955614, 0.4663825222511114, 
   -0.5663969116634691, 0.563883018942714}, 
  {-0.0219218641095561, 0.2957797000312246, 
   -0.566396911663469, -0.6693213616512594}, 
  {-0.021921864109556058, 0.712924909339742, 
   -0.5663969116634695, -0.16496905696577524}, 
  {-0.01813137465113073, -0.5896537157954267, 
   0.6848061092149241, -0.1994569809884713}, 
  {-0.018131374651130613, 0.08530141110994333, 
   0.6848061092149256, 0.616602190296985}, 
  {-0.018131374651130565, -0.08530141110994338, 
   0.684806109214924, -0.6166021902969863}, 
  {-0.018131374651130516, 0.5896537157954267, 
   0.684806109214924, 0.19945698098846854}, 
  {-0.01354845711646216, 0.5460501681069436, 
   -0.3500525425309958, 0.6602057379854691}, 
  {-0.013548457116462131, -0.5460501681069437, 
   -0.35005254253099605, -0.6602057379854689}, 
  {0, -0.9214975139940005, 0, -0.08720709537696639}, 
  {0, -0.08720709537696596, 0, 0.9214975139940005}, 
  {0, 0.08720709537696597, 0, -0.9214975139940004}, 
  {0, 0.9214975139940005, 0, 0.0872070953769656}, 
  {0.013548457116462048, -0.5460501681069437, 
   0.35005254253099605, -0.660205737985469}, 
  {0.013548457116462187, 0.5460501681069436, 
   0.35005254253099594, 0.660205737985469}, 
  {0.018131374651130516, -0.5896537157954267, 
   -0.6848061092149249, -0.19945698098846446}, 
  {0.01813137465113053, -0.08530141110994338, 
   -0.6848061092149242, -0.6166021902969852}, 
  {0.0181313746511306, 0.08530141110994342, 
   -0.6848061092149228, 0.6166021902969876}, 
  {0.01813137465113064, 0.5896537157954267, 
   -0.6848061092149238, 0.19945698098847006}, 
  {0.02192186410955589, -0.712924909339742, 
   0.56639691166347, 0.16496905696577246}, 
  {0.021921864109556072, -0.46638252225111143, 
   0.5663969116634695, -0.5638830189427133}, 
  {0.021921864109556113, 0.2957797000312246, 
   0.5663969116634693, -0.6693213616512592}, 
  {0.021921864109556127, -0.29577970003122467, 
   0.5663969116634712, 0.6693213616512573}, 
  {0.021921864109556176, 0.4663825222511114, 
   0.5663969116634695, 0.5638830189427135}, 
  {0.021921864109556183, 0.712924909339742, 
   0.5663969116634693, -0.16496905696577663}, 
  {0.03547032122601829, 0.0796676458558323, 
   0.9164494541944653, 0.0963227190427548}, 
  {0.03547032122601833, -0.07966764585583228, 
   0.9164494541944654, -0.09632271904275752}, 
  {0.0400532387606867, 0.7982263204496853, 
   -0.11840919755145457, 0.45163313333121047}, 
  {0.040053238760686706, -0.293874015764202, 
   -0.11840919755145313, -0.8687783426397275}, 
  {0.040053238760686706, 0.293874015764202, 
   -0.11840919755145395, 0.8687783426397278}, 
  {0.04005323876068674, -0.7982263204496853, 
   -0.11840919755145485, -0.45163313333121025}, 
  {0.042885637564749536, -0.4080295856427274, 
   -0.7579870178823238, 0.3374775634526874}, 
  {0.0428856375647498, 0.4080295856427274, 
   -0.7579870178823243, -0.33747756345268387}, 
  {0.05125904455784368, -0.07055202219004233, 
   -0.5416426487498494, 0.7455071490954133}, 
  {0.05125904455784368, 0.07055202219004236, 
   -0.5416426487498498, -0.7455071490954128}, 
  {0.05125904455784373, 0.7455071490954124, 
   -0.5416426487498504, 0.07055202219004293}, 
  {0.05125904455784376, -0.7455071490954125, 
   -0.5416426487498505, -0.07055202219003948}, 
  {0.0648075016743058, 0.8744121078938387, 
   -0.19159010621885433, 0.22640545549002813}, 
  {0.06480750167430581, -0.05835293660838396, 
   -0.19159010621885295, -0.901360582395398}, 
  {0.06480750167430581, 0.05835293660838399, 
   -0.19159010621885378, 0.9013605823953981}, 
  {0.06480750167430593, -0.8744121078938387, 
   -0.19159010621885464, -0.22640545549002788}, 
  {0.07552355998670496, -0.46074875699700035, 
   0.7980402566430108, -0.043603547688486746}, 
  {0.07552355998670499, -0.043603547688483006, 
   0.7980402566430123, 0.4607487569969982}, 
  {0.075523559986705, 0.04360354768848297, 
   0.7980402566430105, -0.4607487569970009}, 
  {0.07552355998670501, 0.46074875699700035, 
   0.7980402566430105, 0.043603547688482444}, 
  {0.08293887632543627, -0.2847583920984121, 
   -0.876396215433779, -0.026948474501555374}, 
  {0.0829388763254364, 0.026948474501559412, 
   -0.8763962154337795, -0.2847583920984099}, 
  {0.08293887632543642, -0.026948474501559364, 
   -0.8763962154337783, 0.28475839209841347}, 
  {0.08293887632543648, 0.28475839209841214, 
   -0.8763962154337787, 0.026948474501561154}, 
  {0.08672936578386159, -0.8251747949512447, 
   0.37480680544461514, -0.1668747412328002}, 
  {0.08672936578386192, 0.009115623665789899, 
   0.3748068054446167, 0.8418298681381668}, 
  {0.08672936578386195, -0.009115623665789933, 
   0.3748068054446166, -0.8418298681381682}, 
  {0.08672936578386206, 0.8251747949512447, 
   0.3748068054446149, 0.16687474123279775}, 
  {0.10027782290032405, -0.5369345444411537, 
   0.7248593479756112, 0.18162413015269546}, 
  {0.10027782290032407, 0.27912462684430106, 
   0.7248593479756107, -0.49333099675267134}, 
  {0.10027782290032411, 0.5369345444411537, 
   0.7248593479756107, -0.18162413015270035}, 
  {0.10027782290032412, -0.27912462684430106, 
   0.7248593479756128, 0.4933309967526681}, 
  {0.10486074043499247, -0.5805380921296368, 
   -0.3099993037703093, 0.6423728871496994}, 
  {0.10486074043499256, -0.7398733838413014, 
   -0.30999930377030926, 0.4497274490641877}, 
  {0.10486074043499258, 0.5805380921296367, 
   -0.30999930377030926, -0.6423728871496995}, 
  {0.10486074043499258, 0.7398733838413013, 
   -0.30999930377030915, -0.44972744906418793}, 
  {0.1184091975514546, -0.8687783426397276, 
   0.04005323876068697, 0.29387401576420163}, 
  {0.11840919755145461, -0.4516331333312105, 
   0.040053238760686394, 0.7982263204496854}, 
  {0.1184091975514547, 0.45163313333121036, 
   0.040053238760686886, -0.7982263204496853}, 
  {0.11840919755145471, 0.8687783426397275, 
   0.04005323876068667, -0.2938740157642024}, 
  {0.1267826045445485, -0.7891106967838954, 
   0.25639760789316074, 0.3901967348069572}, 
  {0.1267826045445486, -0.7019036014069294, 
   0.25639760789316046, -0.5313007791870427}, 
  {0.12678260454454862, -0.5313007791870428, 
   0.25639760789316024, 0.7019036014069293}, 
  {0.12678260454454868, -0.390196734806958, 
   0.25639760789316196, -0.7891106967838953}, 
  {0.12678260454454868, 0.39019673480695793, 
   0.2563976078931605, 0.7891106967838953}, 
  {0.12678260454454868, 0.5313007791870427, 
   0.25639760789316035, -0.7019036014069296}, 
  {0.1267826045445487, 0.7891106967838953, 
   0.2563976078931601, -0.3901967348069584}, 
  {0.12678260454454873, 0.7019036014069294, 
   0.25639760789316035, 0.5313007791870427}, 
  {0.14033106166101067, -0.5729986426085031, 
   0.6064501504241561, -0.3754473458870586}, 
  {0.1403310616610108, 0.2612917760085315, 
   0.6064501504241576, 0.6332572634839087}, 
  {0.14033106166101084, -0.2612917760085316, 
   0.6064501504241561, -0.63325726348391}, 
  {0.1403310616610109, 0.5729986426085031, 
   0.6064501504241562, 0.37544734588705697}, 
  {0.15611978499283616, -0.25217615234274166, 
   -0.8516419525201593, 0.20857260465426122}, 
  {0.1561197849928363, 0.25217615234274166, 
   -0.8516419525201598, -0.20857260465425756}, 
  {0.16966824210929832, -0.6927879777411395, 
   -0.5015894099891636, 0.3105290889511274}, 
  {0.16966824210929832, -0.4349780601442868, 
   -0.5015894099891638, 0.622235955551097}, 
  {0.16966824210929843, 0.4349780601442868, 
   -0.5015894099891638, -0.6222359555510971}, 
  {0.16966824210929843, 0.6927879777411395, 
   -0.5015894099891638, -0.3105290889511254}, 
  {0.19159010621885442, -0.9013605823953981, 
   0.06480750167430607, 0.058352936608383574}, 
  {0.19159010621885442, -0.22640545549002822, 
   0.06480750167430568, 0.8744121078938387}, 
  {0.19159010621885453, 0.2264054554900281, 
   0.06480750167430763, -0.8744121078938386}, 
  {0.19159010621885453, 0.9013605823953981, 
   0.06480750167430578, -0.05835293660838435}, 
  {0.20513856333531638, -0.7724556235969718, 
   0.414860044205302, 0.21420636990836744}, 
  {0.20513856333531647, -0.718558674593853, 
   0.41486004420530165, -0.35531041428845594}, 
  {0.20513856333531658, -0.35531041428845467, 
   0.4148600442053031, 0.7185586745938515}, 
  {0.20513856333531663, -0.21420636990836978, 
   0.4148600442053033, -0.7724556235969717}, 
  {0.20513856333531663, 0.2142063699083697, 
   0.4148600442053034, 0.7724556235969704}, 
  {0.20513856333531663, 0.3553104142884545, 
   0.41486004420530165, -0.7185586745938533}, 
  {0.2051385633353167, 0.7724556235969717, 
   0.41486004420530154, -0.21420636990837041}, 
  {0.20513856333531671, 0.718558674593853, 
   0.41486004420530176, 0.3553104142884542}, 
  {0.20972148086998496, -0.5043523046854833, 
   -0.6199986075406183, 0.41714520930851906}, 
  {0.20972148086998504, -0.41714520930851734, 
   -0.6199986075406192, -0.5043523046854816}, 
  {0.20972148086998507, 0.4171452093085174, 
   -0.6199986075406179, 0.5043523046854841}, 
  {0.20972148086998516, 0.5043523046854833, 
   -0.6199986075406185, -0.41714520930851695}, 
  {0.22326993798644715, -0.5460501681069438, 
   -0.26994606500962237, -0.6602057379854689}, 
  {0.22326993798644723, 0.5460501681069436, 
   -0.2699460650096225, 0.6602057379854691}, 
  {0.23447574378360408, -0.4933309967526708, 
   -0.6931795162080189, -0.2791246268442975}, 
  {0.23447574378360414, -0.1816241301526993, 
   -0.6931795162080189, -0.5369345444411523}, 
  {0.2344757437836042, 0.1816241301526993, 
   -0.6931795162080179, 0.5369345444411544}, 
  {0.23447574378360422, 0.4933309967526708, 
   -0.6931795162080179, 0.27912462684430217}, 
  {0.24519180209600308, -0.8418298681381683, 
   0.2964508466538471, 0.009115623665787873}, 
  {0.24519180209600328, -0.1668747412327984, 
   0.29645084665384835, 0.8251747949512434}, 
  {0.24519180209600336, 0.16687474123279825, 
   0.2964508466538488, -0.8251747949512446}, 
  {0.24519180209600341, 0.8418298681381682, 
   0.29645084665384697, -0.009115623665790423}, 
  {0.25639760789316024, -0.7019036014069295, 
   -0.1267826045445486, -0.5313007791870427}, 
  {0.25639760789316024, -0.5313007791870429, 
   -0.126782604544549, 0.7019036014069295}, 
  {0.25639760789316024, -0.3901967348069581, 
   -0.12678260454454676, -0.7891106967838953}, 
  {0.25639760789316035, 0.39019673480695793, 
   -0.12678260454454865, 0.7891106967838952}, 
  {0.25639760789316035, 0.5313007791870427, 
   -0.1267826045445485, -0.7019036014069294}, 
  {0.25639760789316035, 0.7019036014069294, 
   -0.1267826045445487, 0.5313007791870428}, 
  {0.25639760789316035, 0.7891106967838953, 
   -0.12678260454454862, -0.3901967348069581}, 
  {0.2563976078931604, -0.7891106967838954, 
   -0.12678260454454865, 0.390196734806958}, 
  {0.26711366620555954, -0.12890495879842637, 
   0.8628477583173166, -0.1558534332999874}, 
  {0.26711366620555954, 0.12890495879842637, 
   0.8628477583173164, 0.1558534332999847}, 
  {0.2699460650096224, -0.6602057379854691, 
   0.22326993798644712, 0.5460501681069435}, 
  {0.2699460650096225, 0.660205737985469, 
   0.22326993798644723, -0.5460501681069438}, 
  {0.27452898254429076, -0.30489532369701455, 
   -0.8115887137594733, -0.17250850648690597}, 
  {0.2745289825442908, -0.11224988561150279, 
   -0.8115887137594735, -0.33184379819857246}, 
  {0.2745289825442909, 0.11224988561150279, 
   -0.8115887137594726, 0.33184379819857457}, 
  {0.2745289825442909, 0.30489532369701455, 
   -0.8115887137594726, 0.17250850648691032}, 
  {0.28807743966075305, -0.0705520221900425, 
   -0.4615361712284767, 0.7455071490954126}, 
  {0.28807743966075305, 0.07055202219004235, 
   -0.461536171228477, -0.7455071490954124}, 
  {0.28807743966075305, 0.7455071490954124, 
   -0.4615361712284769, 0.07055202219004282}, 
  {0.28807743966075317, -0.7455071490954124, 
   -0.461536171228477, -0.07055202219003986}, 
  {0.2918679291191786, -0.36442603795424444, 
   0.7896668496499166, -0.12327119354431813}, 
  {0.2918679291191786, 0.05271917135427288, 
   0.7896668496499183, 0.38108111114116594}, 
  {0.29186792911917864, -0.052719171354272926, 
   0.7896668496499165, -0.3810811111411686}, 
  {0.29186792911917864, 0.36442603795424444, 
   0.7896668496499164, 0.12327119354431502}, 
  {0.296450846653847, -0.009115623665789933, 
   -0.24519180209600172, -0.8418298681381681}, 
  {0.296450846653847, 0.009115623665789802, 
   -0.24519180209600286, 0.8418298681381684}, 
  {0.296450846653847, 0.8251747949512447, 
   -0.2451918020960032, 0.16687474123279838}, 
  {0.29645084665384724, -0.8251747949512446, 
   -0.2451918020960036, -0.16687474123279766}, 
  {0.3099993037703091, -0.6423728871496998, 
   0.10486074043499283, -0.5805380921296369}, 
  {0.3099993037703091, -0.449727449064188, 
   0.10486074043499445, -0.7398733838413013}, 
  {0.3099993037703092, 0.44972744906418777, 
   0.10486074043499259, 0.7398733838413012}, 
  {0.3099993037703092, 0.6423728871496995, 
   0.10486074043499241, 0.5805380921296367}, 
  {0.33192116787986525, -0.4876972314985597, 
   0.6712576520984622, 0.24115484440992627}, 
  {0.3319211678798653, -0.433800282495441, 
   0.6712576520984618, -0.3283619397868969}, 
  {0.3319211678798653, 0.24115484440992907, 
   0.6712576520984634, 0.4876972314985587}, 
  {0.3319211678798653, 0.3283619397868951, 
   0.6712576520984617, -0.4338002824954415}, 
  {0.3319211678798653, 0.4876972314985597, 
   0.6712576520984619, -0.24115484440992996}, 
  {0.33192116787986536, -0.3283619397868951, 
   0.6712576520984639, 0.4338002824954383}, 
  {0.33192116787986536, -0.24115484440992915, 
   0.6712576520984618, -0.4876972314985599}, 
  {0.33192116787986536, 0.4338002824954409, 
   0.6712576520984619, 0.3283619397868952}, 
  {0.3500525425309958, -0.6602057379854692, 
   -0.013548457116462471, 0.5460501681069437}, 
  {0.35005254253099594, 0.660205737985469, 
   -0.013548457116461979, -0.5460501681069437}, 
  {0.3612583483281528, -0.46638252225111154, 
   -0.4367819083148578, -0.5638830189427131}, 
  {0.36125834832815285, -0.2957797000312248, 
   -0.4367819083148575, 0.6693213616512591}, 
  {0.36125834832815285, 0.2957797000312246, 
   -0.43678190831485786, -0.669321361651259}, 
  {0.36125834832815285, 0.46638252225111143, 
   -0.4367819083148579, 0.5638830189427133}, 
  {0.3612583483281529, 0.712924909339742, 
   -0.43678190831485786, -0.1649690569657754}, 
  {0.361258348328153, -0.712924909339742, 
   -0.43678190831485775, 0.16496905696577802}, 
  {0.3748068054446149, -0.1668747412327985, 
   -0.08672936578386174, 0.8251747949512449}, 
  {0.374806805444615, 0.16687474123279825, 
   -0.08672936578386019, -0.8251747949512445}, 
  {0.374806805444615, 0.8418298681381683, 
   -0.08672936578386188, -0.00911562366578994}, 
  {0.37480680544461514, -0.8418298681381682, 
   -0.086729365783862, 0.009115623665790364}, 
  {0.39293818009574555, -0.25217615234274166, 
   -0.771535474998786, 0.20857260465426056}, 
  {0.39293818009574566, 0.2521761523427416, 
   -0.7715354749987862, -0.20857260465425834}, 
  {0.3967286695541711, -0.6332572634839098, 
   0.4796675458796076, 0.2612917760085298}, 
  {0.3967286695541711, -0.3754473458870571, 
   0.4796675458796089, 0.5729986426085015}, 
  {0.39672866955417113, 0.3754473458870569, 
   0.47966754587960747, -0.5729986426085033}, 
  {0.39672866955417113, 0.6332572634839096, 
   0.4796675458796074, -0.26129177600853204}, 
  {0.40131158708883957, -0.08530141110994341, 
   -0.5551911058663126, -0.616602190296986}, 
  {0.40131158708883957, 0.08530141110994327, 
   -0.5551911058663122, 0.6166021902969863}, 
  {0.4013115870888396, -0.5896537157954267, 
   -0.5551911058663126, -0.1994569809884663}, 
  {0.4013115870888396, 0.5896537157954267, 
   -0.5551911058663125, 0.1994569809884693}, 
  {0.4102771266706333, 0, 0.8297200884106035, 0}, 
  {0.4148600442053016, -0.2142063699083699, 
   -0.20513856333531477, -0.7724556235969717}, 
  {0.41486004420530165, -0.3553104142884548, 
   -0.2051385633353166, 0.7185586745938533}, 
  {0.4148600442053017, -0.7185586745938531, 
   -0.2051385633353166, -0.355310414288454}, 
  {0.4148600442053017, 0.2142063699083696, 
   -0.20513856333531624, 0.772455623596972}, 
  {0.4148600442053017, 0.3553104142884545, 
   -0.20513856333531652, -0.718558674593853}, 
  {0.4148600442053017, 0.718558674593853, 
   -0.20513856333531666, 0.3553104142884547}, 
  {0.4148600442053017, 0.7724556235969717, 
   -0.20513856333531658, -0.21420636990836978}, 
  {0.41486004420530187, -0.7724556235969717, 
   -0.2051385633353167, 0.21420636990837016}, 
  {0.4260658500024586, -0.40802958564272745, 
   -0.6283720145337122, 0.3374775634526869}, 
  {0.4260658500024587, 0.4080295856427274, 
   -0.6283720145337125, -0.3374775634526847}, 
  {0.43678190831485775, -0.669321361651259, 
   0.3612583483281527, -0.2957797000312262}, 
  {0.4367819083148578, -0.5638830189427133, 
   0.36125834832815273, 0.4663825222511113}, 
  {0.43678190831485786, -0.16496905696577585, 
   0.3612583483281541, -0.712924909339742}, 
  {0.43678190831485786, 0.16496905696577563, 
   0.36125834832815457, 0.7129249093397405}, 
  {0.43678190831485786, 0.5638830189427131, 
   0.3612583483281529, -0.46638252225111154}, 
  {0.43678190831485786, 0.6693213616512589, 
   0.36125834832815296, 0.29577970003122434}, 
  {0.45033036543131993, -0.38108111114116805, 
   0.7113108908591488, 0.05271917135427025}, 
  {0.45033036543132, -0.12327119354431529, 
   0.7113108908591504, 0.364426037954242}, 
  {0.45033036543132, 0.12327119354431526, 
   0.7113108908591486, -0.36442603795424483}, 
  {0.45033036543132005, 0.381081111141168, 
   0.7113108908591488, -0.052719171354273536}, 
  {0.46153617122847684, -0.7455071490954125, 
   0.2880774396607529, -0.07055202219004393}, 
  {0.4615361712284769, -0.07055202219004252, 
   0.28807743966075444, 0.745507149095411}, 
  {0.46153617122847695, 0.07055202219004221, 
   0.2880774396607545, -0.7455071490954124}, 
  {0.46153617122847695, 0.7455071490954124, 
   0.28807743966075305, 0.0705520221900421}, 
  {0.46611908876314534, -0.28475839209841214, 
   -0.7467812120851669, -0.02694847450155749}, 
  {0.4661190887631454, -0.026948474501559384, 
   -0.7467812120851671, 0.28475839209841214}, 
  {0.4661190887631454, 0.026948474501559384, 
   -0.7467812120851671, -0.28475839209841214}, 
  {0.46611908876314545, 0.28475839209841214, 
   -0.7467812120851671, 0.026948474501559704}, 
  {0.4796675458796074, -0.2612917760085317, 
   -0.3967286695541709, -0.6332572634839098}, 
  {0.4796675458796075, -0.5729986426085032, 
   -0.39672866955417113, -0.3754473458870564}, 
  {0.4796675458796075, 0.26129177600853143, 
   -0.3967286695541709, 0.6332572634839098}, 
  {0.4796675458796075, 0.5729986426085031, 
   -0.39672866955417113, 0.37544734588705714}, 
  {0.5015894099891636, -0.6222359555510973, 
   0.16966824210929865, -0.43497806014428686}, 
  {0.5015894099891636, -0.31052908895112596, 
   0.16966824210929998, -0.6927879777411395}, 
  {0.5015894099891637, 0.31052908895112563, 
   0.16966824210929843, 0.6927879777411394}, 
  {0.5015894099891637, 0.6222359555510971, 
   0.16966824210929826, 0.43497806014428675}, 
  {0.5151378671056257, -0.4933309967526709, 
   0.5197207846402941, -0.2791246268443026}, 
  {0.5151378671056258, -0.18162413015269946, 
   0.5197207846402939, -0.536934544441154}, 
  {0.5151378671056258, 0.1816241301526992, 
   0.5197207846402958, 0.5369345444411524}, 
  {0.5151378671056258, 0.4933309967526708, 
   0.5197207846402943, 0.2791246268443008}, 
  {0.5197207846402943, -0.5369345444411537, 
   -0.5151378671056257, 0.18162413015270154}, 
  {0.5197207846402943, -0.27912462684430117, 
   -0.5151378671056255, 0.4933309967526709}, 
  {0.5197207846402943, 0.279124626844301, 
   -0.5151378671056259, -0.4933309967526708}, 
  {0.5197207846402943, 0.5369345444411537, 
   -0.5151378671056259, -0.18162413015269885}, 
  {0.5235112740987198, 0.15585343329998574, 
   0.7360651537727678, -0.12890495879842673}, 
  {0.5235112740987199, -0.15585343329998574, 
   0.736065153772768, 0.12890495879842528}, 
  {0.5416426487498504, -0.07055202219004261, 
   0.05125904455784393, 0.7455071490954126}, 
  {0.5416426487498504, 0.0705520221900422, 
   0.05125904455784517, -0.7455071490954124}, 
  {0.5416426487498504, 0.7455071490954124, 
   0.051259044557843705, 0.07055202219004247}, 
  {0.5416426487498505, -0.7455071490954124, 
   0.05125904455784362, -0.07055202219004199}, 
  {0.5444750475539133, -0.46074875699700024, 
   -0.5883187757730255, -0.0436035476884807}, 
  {0.5444750475539133, -0.0436035476884831, 
   -0.5883187757730253, 0.4607487569970005}, 
  {0.5444750475539133, 0.043603547688482965, 
   -0.5883187757730257, -0.4607487569970003}, 
  {0.5444750475539134, 0.4607487569970003, 
   -0.5883187757730257, 0.0436035476884834}, 
  {0.5551911058663124, -0.6166021902969862, 
   0.40131158708883946, 0.08530141110994183}, 
  {0.5551911058663125, -0.1994569809884689, 
   0.4013115870888408, 0.5896537157954254}, 
  {0.5551911058663125, 0.616602190296986, 
   0.4013115870888396, -0.08530141110994367}, 
  {0.5551911058663126, 0.19945698098846856, 
   0.4013115870888394, -0.5896537157954268}, 
  {0.5663969116634694, -0.5638830189427133, 
   -0.02192186410955702, 0.4663825222511114}, 
  {0.5663969116634694, -0.164969056965776, 
   -0.021921864109554545, -0.712924909339742}, 
  {0.5663969116634695, -0.6693213616512591, 
   -0.02192186410955592, -0.29577970003122434}, 
  {0.5663969116634695, 0.16496905696577557, 
   -0.0219218641095557, 0.7129249093397421}, 
  {0.5663969116634695, 0.5638830189427131, 
   -0.02192186410955603, -0.4663825222511113}, 
  {0.5663969116634695, 0.6693213616512589, 
   -0.02192186410955624, 0.2957797000312247}, 
  {0.5845282863146001, -0.07966764585583232, 
   -0.7067279733244805, -0.09632271904275588}, 
  {0.5845282863146001, 0.0796676458558323, 
   -0.7067279733244805, 0.09632271904275588}, 
  {0.5883187757730255, -0.4607487569970004, 
   0.5444750475539133, -0.04360354768848454}, 
  {0.5883187757730256, -0.04360354768848301, 
   0.5444750475539148, 0.46074875699699896}, 
  {0.5883187757730256, 0.043603547688482805, 
   0.544475047553913, -0.46074875699700046}, 
  {0.5883187757730256, 0.46074875699700035, 
   0.5444750475539134, 0.043603547688482694}, 
  {0.6064501504241562, -0.3754473458870572, 
   -0.14033106166101136, 0.5729986426085033}, 
  {0.6064501504241562, 0.37544734588705697, 
   -0.14033106166101075, -0.5729986426085031}, 
  {0.6064501504241562, 0.6332572634839096, 
   -0.14033106166101086, -0.2612917760085315}, 
  {0.6064501504241563, -0.6332572634839096, 
   -0.14033106166101145, 0.2612917760085319}, 
  {0.6199986075406183, -0.5043523046854834, 
   0.2097214808699842, 0.41714520930851734}, 
  {0.6199986075406183, -0.4171452093085177, 
   0.2097214808699851, -0.5043523046854835}, 
  {0.6199986075406183, 0.5043523046854833, 
   0.20972148086998518, -0.4171452093085173}, 
  {0.6199986075406184, 0.4171452093085173, 
   0.209721480869985, 0.5043523046854832}, 
  {0.6283720145337124, -0.3374775634526852, 
   0.4260658500024584, -0.40802958564272757}, 
  {0.6283720145337124, 0.337477563452685, 
   0.4260658500024587, 0.4080295856427274}, 
  {0.6712576520984619, -0.24115484440992943, 
   -0.33192116787986564, -0.48769723149855937}, 
  {0.671257652098462, -0.43380028249544117, 
   -0.33192116787986564, -0.3283619397868943}, 
  {0.671257652098462, -0.3283619397868952, 
   -0.33192116787986553, 0.433800282495441}, 
  {0.671257652098462, 0.24115484440992901, 
   -0.3319211678798651, 0.4876972314985599}, 
  {0.671257652098462, 0.3283619397868951, 
   -0.3319211678798655, -0.4338002824954409}, 
  {0.671257652098462, 0.4338002824954409, 
   -0.3319211678798654, 0.3283619397868952}, 
  {0.671257652098462, 0.4876972314985597, 
   -0.3319211678798654, -0.24115484440992901}, 
  {0.6712576520984621, -0.4876972314985597, 
   -0.331921167879866, 0.24115484440992943}, 
  {0.6848061092149241, -0.19945698098846898, 
   0.0181313746511301, 0.5896537157954268}, 
  {0.6848061092149241, 0.19945698098846856, 
   0.01813137465113037, -0.5896537157954268}, 
  {0.6848061092149241, 0.616602190296986, 
   0.018131374651130558, -0.08530141110994327}, 
  {0.6848061092149242, -0.616602190296986, 
   0.018131374651129965, 0.0853014111099437}, 
  {0.6931795162080181, -0.5369345444411537, 
   0.23447574378360364, 0.1816241301526992}, 
  {0.6931795162080181, -0.27912462684430117, 
   0.23447574378360336, 0.4933309967526708}, 
  {0.6931795162080181, 0.5369345444411537, 
   0.23447574378360414, -0.1816241301526993}, 
  {0.6931795162080182, 0.27912462684430084, 
   0.234475743783604, -0.4933309967526709}, 
  {0.7067279733244803, -0.09632271904275588, 
   0.5845282863146001, 0.0796676458558323}, 
  {0.7067279733244803, 0.09632271904275588, 
   0.5845282863146001, -0.0796676458558323}, 
  {0.7113108908591487, -0.05271917135427304, 
   -0.45033036543132055, -0.3810811111411676}, 
  {0.7113108908591487, 0.05271917135427277, 
   -0.45033036543131966, 0.38108111114116816}, 
  {0.7113108908591487, 0.36442603795424444, 
   -0.45033036543132, 0.1232711935443154}, 
  {0.7113108908591488, -0.36442603795424455, 
   -0.4503303654313206, -0.12327119354431446}, 
  {0.7248593479756108, -0.493330996752671, 
   -0.1002778229003244, -0.2791246268443003}, 
  {0.7248593479756108, -0.1816241301526997, 
   -0.10027782290032468, -0.5369345444411535}, 
  {0.7248593479756109, 0.18162413015269913, 
   -0.10027782290032382, 0.536934544441154}, 
  {0.7248593479756109, 0.4933309967526708, 
   -0.10027782290032418, 0.27912462684430117}, 
  {0.7360651537727678, -0.1289049587984265, 
   -0.5235112740987204, -0.1558534332999853}, 
  {0.7360651537727678, 0.12890495879842634, 
   -0.5235112740987198, 0.15585343329998577}, 
  {0.746781212085167, -0.28475839209841214, 
   0.46611908876314545, -0.026948474501559384}, 
  {0.746781212085167, -0.026948474501559384, 
   0.46611908876314545, 0.28475839209841214}, 
  {0.746781212085167, 0.026948474501559225, 
   0.4661190887631451, -0.28475839209841225}, 
  {0.746781212085167, 0.28475839209841214, 
   0.46611908876314545, 0.026948474501559377}, 
  {0.7579870178823239, -0.3374775634526855, 
   0.04288563756474917, -0.4080295856427272}, 
  {0.757987017882324, 0.337477563452685, 
   0.042885637564749626, 0.4080295856427274}, 
  {0.7715354749987862, -0.2085726046542588, 
   0.3929381800957453, -0.25217615234274177}, 
  {0.7715354749987862, 0.20857260465425864, 
   0.39293818009574566, 0.2521761523427416}, 
  {0.7896668496499166, -0.1232711935443154, 
   -0.2918679291191788, 0.36442603795424455}, 
  {0.7896668496499166, 0.12327119354431515, 
   -0.29186792911917925, -0.364426037954244}, 
  {0.7896668496499166, 0.38108111114116805, 
   -0.29186792911917864, -0.052719171354272766}, 
  {0.7896668496499167, -0.38108111114116805, 
   -0.29186792911917975, 0.052719171354273675}, 
  {0.7980402566430107, -0.46074875699700035, 
   -0.07552355998670612, -0.04360354768848221}, 
  {0.7980402566430107, -0.043603547688483096, 
   -0.07552355998670514, 0.4607487569970004}, 
  {0.7980402566430107, 0.04360354768848268, 
   -0.07552355998670589, -0.460748756997}, 
  {0.7980402566430107, 0.46074875699700024, 
   -0.07552355998670499, 0.04360354768848311}, 
  {0.8115887137594728, -0.3318437981985739, 
   0.27452898254429037, 0.11224988561150273}, 
  {0.8115887137594728, -0.17250850648690935, 
   0.27452898254429037, 0.3048953236970145}, 
  {0.8115887137594728, 0.17250850648690919, 
   0.27452898254429053, -0.30489532369701466}, 
  {0.8115887137594728, 0.3318437981985739, 
   0.2745289825442908, -0.11224988561150279}, 
  {0.8297200884106033, 0, -0.4102771266706338, 0}, 
  {0.8516419525201595, -0.20857260465425892, 
   0.15611978499283546, -0.2521761523427413}, 
  {0.8516419525201595, 0.20857260465425867, 
   0.15611978499283632, 0.25217615234274166}, 
  {0.8628477583173164, -0.15585343329998588, 
   -0.26711366620556054, 0.12890495879842678}, 
  {0.8628477583173164, 0.15585343329998563, 
   -0.2671136662055601, -0.1289049587984259}, 
  {0.8763962154337787, -0.28475839209841225, 
   0.08293887632543537, -0.026948474501558996}, 
  {0.8763962154337787, -0.026948474501559377, 
   0.08293887632543592, 0.2847583920984121}, 
  {0.8763962154337787, 0.0269484745015591, 
   0.08293887632543555, -0.2847583920984118}, 
  {0.8763962154337787, 0.28475839209841214, 
   0.0829388763254364, 0.026948474501559412}, 
  {0.9164494541944653, -0.096322719042756, 
   -0.03547032122601931, 0.0796676458558327}, 
  {0.9164494541944653, 0.09632271904275576, 
   -0.03547032122601881, -0.07966764585583182}};

POV Export Code

Some of this code was abstracted and modified from Roman Maeder’s POV-Ray.m package.

tosegs[gon_] := Table[Take[RotateLeft[gon, i], 2], {i, Length[gon]}]

edgedex[vertlist_, hedron_] := Block[{e1, e2}, 
   e1 = Flatten[(tosegs[#1] & ) /@ hedron, 1]; 
    e2 = Partition[Flatten[Table[{Position[vertlist, e1[[i,1]]], 
         Position[vertlist, e1[[i,2]]]}, {i, Length[e1]}]], 2]; 
    Union[Sort /@ e2]]

tected = Unprotect[Infix];
Infix[_[e_], h_:Null] := e;
Protect[ Evaluate[tected] ];

(* optional text followed by numbers, FortranForm with 5 digits *)

ndig = 5;
nForm[r_] := NumberForm[Chop[r,.000001], ndig];

writeNums[file_, txt_:"", r_?NumberQ] :=
    Write[file, txt, " ", nForm[r]]
writeNums[file_, txt_:"", r_List] :=
    Write[file, txt, " ", Infix[nForm /@ r, " "]]

(* turn n-gon into list of triangles *)

toTriangles[vlist_List] /; Length[vlist] == 3 := {vlist}

(* treat 4gons specially for efficiency *)

toTriangles[vlist_List] /; Length[vlist] == 4 :=
	{vlist[[{1, 2, 3}]], vlist[[{3, 4, 1}]]}

(* general case: use center of gravity as additional vertex *)
(* in this way, some nonconvex polygons can also be rendered correctly *)

toTriangles[vlist_List] :=
    Module[{bary = (Plus @@ vlist)/Length[vlist], circ},
        circ = Partition[ Append[vlist, First[vlist]], 2, 1 ];
        Apply[ {#1, #2, bary}&, circ, {1} ]
    ]
    
Ball[x_List,r_]:={x,r}

Rod[x_List,r_]:={x,r}

cyllmake[txt_:"", r_List] /; Length[r] == 2 :=
    SequenceForm[txt,"{", "<", Infix[nForm /@ r[[1,1]], ", "], ">",
    ",", "<", Infix[nForm /@ r[[1,2]], ", "], ">"," ",r[[2]],"}" ]
    
ballmake[txt_:"", r_List] /; Length[r] == 2 :=
    SequenceForm[txt,"{", "<", Infix[nForm /@ r[[1]], ", "], ">",
    " ",r[[2]],"}" ]
    
facemake[txt_:"", r_List] /; Length[r] == 3 :=
    SequenceForm[txt,"{", "<", Infix[nForm /@ r[[1]], ", "], ">",
    ",", "<", Infix[nForm /@ r[[2]], ", "], ">",
    ",", "<", Infix[nForm /@ r[[3]], ", "], ">","}" ]

Volume code

(*the volume of a convex polyhedron containing the origin within*)
hullvol[poly_]:=
Block[{a},
(*first divide faces into triangles*)
a=Flatten[Map[toTriangles[#]&,parse[ poly] ],1];
(*sum one-sixth the volumes of the determined parallelpipeds*)
N[Plus @@ Flatten[Map[(Abs[Minors[#, 3]]/6)&, a]]]
]

Canonical Solid Shadows

Introduction

The regular convex polychora have four principal types of symmetry axis, and the projections into 3-spaces orthogonal to these may be called the “canonical” projections. In effect we look at the polychora from those four symmetrical directions, and speak of vertex-, edge-, face-, and cell-first projections. Here we construct the symmetrical orthogonal shadows, a “shadow” being the convex hull of a given projection. Dr. Wouter Meeussen’s ConvexHull3D function is employed almost throughout. Since {3,3,5} and {5,3,3} have 120 and 600 vertices, respectively, constructing shadows is somewhat slow. This is all the more true with the truncated and rectified forms derived from these two “pentagonal” polychora; for these

	With {5,3,3}, a different approach is taken, to save time. A faceproject function is applied, in which all the faces are found and projected.
	
	 The truncated and rectified forms of {3,3,5} and {5,3,3} have so many vertices, we appeal to the method of building shadows from the projections of cells, first removing hidden detail. Even with a reasonably fast computer this may take an hour or more for t{5,3,3} or r{5,3,3}. The truncated and rectified polychora have also a broader palette of symmetrical viewpoints. Let the “parent” be the polychoron which is truncated or rectified: then we can choose among vertex-first, parent-edge-first, vertex-figure-type-edge-first, parent-polygon-first, vertex-figure-polygon-first, parent-cell-first, and vertex-figure-cell-first, viewpoints.

{3,3,3} or 5-cell; the regular simplex (Subscript[α, 4])

v1=v333;(*the polychoron we project*)
v2=-v333;(*the dual polychoron*)

Choose a ViewPoint

vpt=vertvpt[v1];(*vertex-first*)

vpt=edgevpt[v1];(*edge-first*)

vpt=facevpt[v1,v2];(*face-first*)

vpt=cellvpt[v1,v2];(*polyhedron-first*)

Build Shadow, Project Edges and Vertices

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v1] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v1], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}];

Array of Canonical Shadows

vpt={vertvpt[v1],edgevpt[v1],facevpt[v1,v2],cellvpt[v1,v2]}

zaq=Table[
gbas=N[unit[#]]& /@ NullSpace[ {N[vpt[[k]]]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v1] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v1], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}],
{k,Length[vpt]}];

Show[GraphicsArray[zaq],
Background->GrayLevel[0]];

{3,3,4} or 16-cell; the regular orthoplex (Subscript[β, 4])

v1=v334;(*the polychoron we project*)
v2=v433;(*the dual polychoron*)

Choose a ViewPoint

vpt=vertvpt[v1];(*vertex-first*)

vpt=edgevpt[v1];(*edge-first*)

vpt=facevpt[v1,v2];(*face-first*)

vpt=cellvpt[v1,v2];(*polyhedron-first*)

Build Shadow, Project Edges and Vertices

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v1] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v1], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}];

Array of Canonical Shadows

vpt={vertvpt[v1],edgevpt[v1],facevpt[v1,v2],cellvpt[v1,v2]}

zaq=Table[
gbas=N[unit[#]]& /@ NullSpace[ {N[vpt[[k]]]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v1] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v1], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}],
{k,Length[vpt]}];

Show[GraphicsArray[zaq],
Background->GrayLevel[0]];

{4,3,3} or 8-cell; the regular 4-cube (Subscript[γ, 4])

v1=v433;(*the polychoron we project*)
v2=v334;(*the dual polychoron*)

Choose a ViewPoint

vpt=vertvpt[v1];(*vertex-first*)

vpt=edgevpt[v1];(*edge-first*)

vpt=facevpt[v1,v2];(*face-first*)

vpt=cellvpt[v1,v2];(*polyhedron-first*)

Build Shadow, Project Edges and Vertices

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v1] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v1], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}];

Array of Canonical Shadows

vpt={vertvpt[v1],edgevpt[v1],facevpt[v1,v2],cellvpt[v1,v2]}

zaq=Table[
gbas=N[unit[#]]& /@ NullSpace[ {N[vpt[[k]]]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v1] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v1], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}],
{k,Length[vpt]}];

Show[GraphicsArray[zaq],
Background->GrayLevel[0]];

{3,4,3} or 24-cell

v1=vi343;(*the polychoron we project*)
v2=vii343;(*the dual polychoron*)

Choose a ViewPoint

vpt=vertvpt[v1];(*vertex-first*)

vpt=edgevpt[v1];(*edge-first*)

vpt=facevpt[v1,v2];(*face-first*)

vpt=cellvpt[v1,v2];(*polyhedron-first*)

Build Shadow, Project Edges and Vertices

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v1] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v1], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->2*unit[{.5,-.25,1}]];

Array of Canonical Shadows

vpt={vertvpt[v1],edgevpt[v1],facevpt[v1,v2],cellvpt[v1,v2]}

zaq=Table[
gbas=N[unit[#]]& /@ NullSpace[ {N[vpt[[k]]]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v1] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v1], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->2*unit[{.5,-1.25,1}]],
{k,Length[vpt]}];

Show[GraphicsArray[zaq],
Background->GrayLevel[0]];

{3,3,5} or 600-cell

v1=v335;(*the polychoron we project*)
v2=v533;(*the dual polychoron*)

Choose a ViewPoint

vpt=vertvpt[v1];(*vertex-first*)

vpt=edgevpt[v1];(*edge-first*)

vpt=facevpt[v1,v2];(*face-first*)

vpt=cellvpt[v1,v2];(*polyhedron-first*)

Build Shadow, Project Edges and Vertices

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v1] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v1], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}];

Array of Canonical Shadows

vpt={vertvpt[v1],edgevpt[v1],facevpt[v1,v2],cellvpt[v1,v2]}

zaq=Table[
gbas=N[unit[#]]& /@ NullSpace[ {N[vpt[[k]]]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v1] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v1], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}],
{k,Length[vpt]}];

Show[GraphicsArray[zaq],
Background->GrayLevel[0]];

{5,3,3} or 120-cell

v1=v533;(*the polychoron we project*)
v2=v335;(*the dual polychoron*)

Choose a ViewPoint

vpt=vertvpt[v1];(*vertex-first*)

vpt=edgevpt[v1];(*edge-first*)

vpt=facevpt[v1,v2];(*face-first*)

vpt=cellvpt[v1,v2];(*polyhedron-first*)

Build Shadow, Project Edges and Vertices

Since ConvexHull3D works too slowly when given all 600 vertices of {5,3,3}, we appeal to the faceproject function and obtain equivalent results. This is still slow, 155 seconds on my computer. All 720 pentagons bounding {5,3,3} are found and projected. The edges and vertices are added. This method provides an opportunity to view the interior structure of the projection, using PlotRange. We can see if the dodecahedra fall into coincidence, or interpenetrate.

Show[ zaq=faceproject[ v533, v335, vpt ],
Boxed->False,
ViewPoint->{2,-.25,1}]

r=mag[v533[[1]]];(*circumradius*)
Show[ zaq,
Boxed->False,
PlotRange->{{-r,r},{0,r},{-r,r}},
ViewPoint->{0,-2,0}];

Array of Canonical Shadows

vpt={vertvpt[v1],edgevpt[v1],facevpt[v1,v2],cellvpt[v1,v2]}

zaq=Table[
Show[faceproject[ v533, v335, vpt[[k]] ],
Boxed->False,
ViewPoint->{2,-.25,1}],
{k,Length[vpt]}];

Show[GraphicsArray[zaq],
Background->GrayLevel[0]];

t{3,3,3}

v=truncate[v333,3];
v1=v333;(*the polychoron we truncate*)
v2=-v333;(*the dual polychoron*)

Choose a ViewPoint

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers*)

vpt=rfacevpt[v1,v2];(*opposite truncated face centers*)

vpt=rcellvpt[v1,v2];(*opposite truncated cell centers*)

Build Shadow, Project Edges and Vertices

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}];

Array of Canonical Shadows

vpt={vertvpt[v],edgevpt[v1],vedgecent[v,v1],
facevpt[v1,v2],vfacecent[v,v1],cellvpt[v,v2],cellvpt[v,v1]}

zaq=Table[
gbas=N[unit[#]]& /@ NullSpace[ {N[vpt[[k]]]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}],
{k,Length[vpt]}];

Show[GraphicsArray[zaq],
Background->GrayLevel[0]];

t{3,3,4}

v=truncate[v334,3];
v1=v334;(*the polychoron we truncate*)
v2=v433;(*the dual polychoron*)

Choose a ViewPoint

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers*)

vpt=rfacevpt[v1,v2];(*opposite truncated face centers*)

vpt=rcellvpt[v1,v2];(*opposite truncated cell centers*)

Build Shadow, Project Edges and Vertices

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}];

Array of Canonical Shadows

vpt={vertvpt[v],edgevpt[v1],vedgecent[v,v1],
facevpt[v1,v2],vfacecent[v,v1],cellvpt[v,v2],cellvpt[v,v1]}

zaq=Table[
gbas=N[unit[#]]& /@ NullSpace[ {N[vpt[[k]]]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}],
{k,Length[vpt]}];

Show[GraphicsArray[zaq],
Background->GrayLevel[0]];

t{4,3,3}

v=truncate[v433,4];
v1=v433;(*the polychoron we truncate*)
v2=v334;(*the dual polychoron*)

Choose a ViewPoint

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers*)

vpt=rfacevpt[v1,v2];(*opposite truncated face centers*)

vpt=rcellvpt[v1,v2];(*opposite truncated cell centers*)

Build Shadow, Project Edges and Vertices

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}];

Array of Canonical Shadows

vpt={vertvpt[v],edgevpt[v1],vedgecent[v,v1],
facevpt[v1,v2],vfacecent[v,v1],cellvpt[v,v2],cellvpt[v,v1]}

zaq=Table[
gbas=N[unit[#]]& /@ NullSpace[ {N[vpt[[k]]]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}],
{k,Length[vpt]}];

Show[GraphicsArray[zaq],
Background->GrayLevel[0]];

t{3,4,3}

v=truncate[vi343,3];
v1=vi343;(*the polychoron we truncate*)
v2=vii343;(*the dual polychoron*)

Choose a ViewPoint

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers*)

vpt=rfacevpt[v1,v2];(*opposite truncated face centers*)

vpt=rcellvpt[v1,v2];(*opposite truncated cell centers*)

Build Shadow, Project Edges and Vertices

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}];

Array of Canonical Shadows

vpt={vertvpt[v],edgevpt[v1],vedgecent[v,v1],
facevpt[v1,v2],vfacecent[v,v1],cellvpt[v,v2],cellvpt[v,v1]}

zaq=Table[
gbas=N[unit[#]]& /@ NullSpace[ {N[vpt[[k]]]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}],
{k,Length[vpt]}];

Show[GraphicsArray[zaq],
Background->GrayLevel[0]];

t{3,3,5}: Hidden-detail method

Select Polychoron,  find Cells

v=truncate[v335,3];(*the polychoron we will project*)
Print["There are ",Length[v]," vertices."];
v1=v335;(*the polychoron we truncate*)
v2=v533;(*the dual*)

d1=First@Union[ Map[mag[v1[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of vertex-figure-cells are distant ",d1," from a vertex of the polychoron we truncate."];

d2=First@Union[ Map[mag[v2[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of truncated cells are distant ",d2," from a vertex of the dual."];

c1=Table[
Select[v, Chop[ mag[v1[[ i ]]-#] - d1,.000001 ]==0&],
{i,Length[v1]}];
Print["There are ",Length[c1]," vertex-figure-polyhedra with ",Length[ c1[[1]] ]," vertices."];
c2=Table[
Select[v, Chop[ mag[v2[[ i ]]-#] - d2,.000001 ]==0&],
{i,Length[v2]}];
Print["There are ",Length[c2]," truncated polyhedra with ",Length[ c2[[1]] ]," vertices."];

Choose a ViewPoint,  find Basis Vectors

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers*)

vpt=rfacevpt[v1,v2];(*opposite truncated face centers*)

vpt=rcellvpt[v1,v2];(*opposite truncated cell centers*)

gbas=NullSpace[ {N[vpt]} ]

Construct Cell Shadows

b1=Select[c1,
Chop[Dot[vpt,cent[#]],.000001]>0&];
Length[b1]

zaq1=(*make all projected visible cells of the first type*)
Table[
r=vunion[ Map[ Dot[ gbas, # ]&, b1[[ i ]] ] ];
Graphics3D[ConvexHull3D[r]],
{i,Length[b1]}];

Show[zaq1[[1]]];

b2=Select[c2,
Chop[Dot[vpt,cent[#]],.000001]>0&];
Length[b2]

zaq2=(*make all projected visible cells of the second type*)
Table[
r=Map[ Dot[ gbas, # ]&, b2[[ i ]] ];
Graphics3D[ConvexHull3D[r]],
{i,Length[b2]}];

Show[zaq2[[1]]];

Sort Shadows by Distance from Origin

zaq=Join[zaq1,zaq2];(*merge cell lists*)
t=Map[{(*sort according to distance from origin*)
mag[ Chop[ cent[ Level[parse[#],{-2}] ],.000001 ] ],
Flatten[Position[zaq,#]],
Chop[ cent[ Level[parse[#],{-2}] ],.000001 ]}&, zaq];
chik=Split[Sort[t,#1[[1]]<#2[[1]]&],TrueQ[(Abs[#1[[1]]-#2[[1]]]<.0001)]&];

Print["There are ",Length[chik]," distinct sets of polyhedra"];

xaq=Table[
q=vunion[ #[[1]]& /@ (RotateLeft[#,2]& /@ chik[[j]]) ];
r=Sort[Map[#[[1]]&, Table[
First /@ Position[chik[[j]], q[[i]] ],
{i,Length[q]}] ] ];
zaq[[ Flatten[ Map[First[ #[[2]] ]&, chik[[j]][[r]] ] ] ]],
{j,Length[chik]}];

s11=Map[Length,xaq];
Print["There are ",s11," polyhedra in the various sets"];
Print["There are ",Plus@@s11," polyhedra in the complete shadow"];

Display Complete Shadow, Central Shadow, Exploded Cell Shadows

(*optional vertex-first ViewPoint*)
pt=2*unit[ First@vunion[Flatten[parse[xaq[[1]]],1]] ];

g1=Show[zaq,(*the complete shadow*)
Boxed->False,
ViewPoint->pt];

g2=Show[xaq[[{1,2}]],(*the innermost polyhedron or polyhedra*)
Boxed->False,
ViewPoint->pt];

a=.25;(*set translation variable; explode cell shadows apart*)
qq=Table[
t=Map[Chop[ cent[ Level[parse[#],{-2}] ],.000001 ]&, xaq[[i]] ];
Table[trans[xaq[[i]][[j]],t[[j]]*a],{j,Length[t]}],
{i,Length[xaq]}
];
g3=Show[ qq,(*the exploded cell shadows*)
Boxed->False,
ViewPoint->pt];

Show[(*the three images above*)
GraphicsArray[{g1,g2,g3},GraphicsSpacing->-.20],
Background->GrayLevel[.1]
];

Display Sequential Construction of the Shadow

(*the sequential building of the complete shadow*)
r=mag[ v[[1]] ];
seq=Table[Show[xaq[[ Range[i] ]],
PlotRange->{{-r,r},{-r,r},{-r,r}},
ViewPoint->{0,0,2},
Boxed->False],
{i,Length[xaq]}];

For the purposes of a GraphicsArray, partitioning the sequence may be best. Supposing the sequence is twelve images in length, we might write “Partition[seq,4]” instead of just “seq”.

Length[seq]

Show[(*show all stages of the sequential building*)
GraphicsArray[Partition[seq,10],GraphicsSpacing->-.10],
Background->GrayLevel[0]
];

t{5,3,3}: Hidden-detail method

Select Polychoron,  find Cells

v=truncate[v533,5];(*the polychoron we will project*)
Print["There are ",Length[v]," vertices."];
v1=v533;(*the polychoron we truncate*)
v2=v335;(*the dual*)

d1=First@Union[ Map[mag[v1[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of vertex-figure-cells are distant ",d1," from a vertex of the polychoron we truncate."];

d2=First@Union[ Map[mag[v2[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of truncated cells are distant ",d2," from a vertex of the dual."];

c1=Table[
Select[v, Chop[ mag[v1[[ i ]]-#] - d1,.000001 ]==0&],
{i,Length[v1]}];
Print["There are ",Length[c1]," vertex-figure-polyhedra with ",Length[ c1[[1]] ]," vertices."];
c2=Table[
Select[v, Chop[ mag[v2[[ i ]]-#] - d2,.000001 ]==0&],
{i,Length[v2]}];
Print["There are ",Length[c2]," truncated polyhedra with ",Length[ c2[[1]] ]," vertices."];

Choose a ViewPoint,  find Basis Vectors

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers*)

vpt=rfacevpt[v1,v2];(*opposite truncated face centers*)

vpt=rcellvpt[v1,v2];(*opposite truncated cell centers*)

gbas=NullSpace[ {N[vpt]} ]

Construct Cell Shadows

b1=Select[c1,
Chop[Dot[vpt,cent[#]],.000001]>0&];
Length[b1]

zaq1=(*make all projected visible cells of the first type*)
Table[
r=Map[ Dot[ gbas, # ]&, b1[[ i ]] ];
Graphics3D[ConvexHull3D[r]],
{i,Length[b1]}];

Show[zaq1[[1]]];

b2=Select[c2,
Chop[Dot[vpt,cent[#]],.000001]>0&];
Length[b2]

zaq2=(*make all projected visible cells of the second type*)
Table[
r=Map[ Dot[ gbas, # ]&, b2[[ i ]] ];
Graphics3D[ConvexHull3D[r]],
{i,Length[b2]}];

Show[zaq2[[1]]];

Sort Shadows by Distance from Origin

zaq=Join[zaq1,zaq2];(*merge cell lists*)
t=Map[{(*sort according to distance from origin*)
mag[ Chop[ cent[ Level[parse[#],{-2}] ],.000001 ] ],
Flatten[Position[zaq,#]],
Chop[ cent[ Level[parse[#],{-2}] ],.000001 ]}&, zaq];
chik=Split[Sort[t,#1[[1]]<#2[[1]]&],TrueQ[(Abs[#1[[1]]-#2[[1]]]<.0001)]&];

Print["There are ",Length[chik]," distinct sets of polyhedra"];

xaq=Table[
q=vunion[ #[[1]]& /@ (RotateLeft[#,2]& /@ chik[[j]]) ];
r=Sort[Map[#[[1]]&, Table[
First /@ Position[chik[[j]], q[[i]] ],
{i,Length[q]}] ] ];
zaq[[ Flatten[ Map[First[ #[[2]] ]&, chik[[j]][[r]] ] ] ]],
{j,Length[chik]}];

s11=Map[Length,xaq];
Print["There are ",s11," polyhedra in the various sets"];
Print["There are ",Plus@@s11," polyhedra in the complete shadow"];

Display Complete Shadow, Central Shadow, Exploded Cell Shadows

(*optional vertex-first ViewPoint*)
pt=2*unit[ First@vunion[Flatten[parse[xaq[[1]]],1]] ];

g1=Show[zaq,(*the complete shadow*)
Boxed->False,
ViewPoint->pt];

g2=Show[xaq[[{1,2}]],(*the innermost polyhedron or polyhedra*)
Boxed->False,
ViewPoint->pt];

a=.25;(*set translation variable; explode cell shadows apart*)
qq=Table[
t=Map[Chop[ cent[ Level[parse[#],{-2}] ],.000001 ]&, xaq[[i]] ];
Table[trans[xaq[[i]][[j]],t[[j]]*a],{j,Length[t]}],
{i,Length[xaq]}
];
g3=Show[ qq,(*the exploded cell shadows*)
Boxed->False,
ViewPoint->pt];

Show[(*the three images above*)
GraphicsArray[{g1,g2,g3},GraphicsSpacing->-.20],
Background->GrayLevel[.1]
];

Display Sequential Construction of the Shadow

(*the sequential building of the complete shadow*)
r=mag[ v[[1]] ];
seq=Table[Show[xaq[[ Range[i] ]],
PlotRange->{{-r,r},{-r,r},{-r,r}},
ViewPoint->pt,
Boxed->False],
{i,Length[xaq]}];

For the purposes of a GraphicsArray, partitioning the sequence may be best. Supposing the sequence is twelve images in length, we might write “Partition[seq,4]” instead of just “seq”.

Length[seq]

Show[(*show all stages of the sequential building*)
GraphicsArray[Partition[seq,5],GraphicsSpacing->-.20],
Background->GrayLevel[0]
];

r{3,3,3}

v=rectify[v333];
v1=v333;(*the polychoron we truncate*)
v2=-v333;(*the dual polychoron*)

Choose a ViewPoint

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers (rectified vertex first)*)

vpt=rfacevpt[v1,v2];(*opposite rectified face centers*)

vpt=rcellvpt[v1,v2];(*opposite rectified cell centers*)

Build Shadow, Project Edges and Vertices

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}];

Array of Canonical Shadows

vpt={vertvpt[v],edgevpt[v1],vedgecent[v,v1],
facevpt[v1,v2],vfacecent[v,v1],cellvpt[v,v2],cellvpt[v,v1]}

zaq=Table[
gbas=N[unit[#]]& /@ NullSpace[ {N[vpt[[k]]]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}],
{k,Length[vpt]}];

Show[GraphicsArray[zaq],
Background->GrayLevel[0]];

r{3,3,4}

v=rectify[v334];
v1=v334;(*the polychoron we truncate*)
v2=v433;(*the dual polychoron*)

Choose a ViewPoint

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers (rectified vertex first)*)

vpt=rfacevpt[v1,v2];(*opposite rectified face centers*)

vpt=rcellvpt[v1,v2];(*opposite rectified cell centers*)

Build Shadow, Project Edges and Vertices

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}];

Array of Canonical Shadows

vpt={vertvpt[v],edgevpt[v1],vedgecent[v,v1],
facevpt[v1,v2],vfacecent[v,v1],cellvpt[v,v2],cellvpt[v,v1]}

zaq=Table[
gbas=N[unit[#]]& /@ NullSpace[ {N[vpt[[k]]]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}],
{k,Length[vpt]}];

Show[GraphicsArray[zaq],
Background->GrayLevel[0]];

r{4,3,3}

v=rectify[v433];
v1=v433;(*the polychoron we truncate*)
v2=v334;(*the dual polychoron*)

Choose a ViewPoint

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers (rectified vertex first)*)

vpt=rfacevpt[v1,v2];(*opposite rectified face centers*)

vpt=rcellvpt[v1,v2];(*opposite rectified cell centers*)

Build Shadow, Project Edges and Vertices

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}];

Array of Canonical Shadows

vpt={vertvpt[v],edgevpt[v1],vedgecent[v,v1],
facevpt[v1,v2],vfacecent[v,v1],cellvpt[v,v2],cellvpt[v,v1]}

zaq=Table[
gbas=N[unit[#]]& /@ NullSpace[ {N[vpt[[k]]]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}],
{k,Length[vpt]}];

Show[GraphicsArray[zaq],
Background->GrayLevel[0]];

r{3,4,3}

v=rectify[vi343];
v1=vi343;(*the polychoron we truncate*)
v2=vii343;(*the dual polychoron*)

Choose a ViewPoint

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers (rectified vertex first)*)

vpt=rfacevpt[v1,v2];(*opposite rectified face centers*)

vpt=rcellvpt[v1,v2];(*opposite rectified cell centers*)

Build Shadow, Project Edges and Vertices

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}];

Array of Canonical Shadows

vpt={vertvpt[v],edgevpt[v1],vedgecent[v,v1],
facevpt[v1,v2],vfacecent[v,v1],cellvpt[v,v2],cellvpt[v,v1]}

zaq=Table[
gbas=N[unit[#]]& /@ NullSpace[ {N[vpt[[k]]]} ];(*basis vectors*)

q=vunion[ Map[ Dot[ gbas, # ]&, v] ];(*remove duplicates*)
qv3=Graphics3D[ConvexHull3D[q]];(*build shadow*)

qv2=Graphics3D[{AbsoluteThickness[1],Line /@ Map[ Dot[ gbas, # ]&, edgefind[v], {2}]}];(*project edges*)

(*projected vertices*)
qv1=Graphics3D[{AbsolutePointSize[4],Point /@ q}];

Show[{qv3,qv2,qv1},
Boxed->False,
ViewPoint->{2,-.25,1}],
{k,Length[vpt]}];

Show[GraphicsArray[zaq],
Background->GrayLevel[0]];

r{3,3,5}: Hidden-detail method

Select Polychoron,  find Cells

v=rectify[v335];(*the polychoron we will project*)
Print["There are ",Length[v]," vertices."];
v1=v335;(*the polychoron we rectify*)
v2=v533;(*the dual*)

d1=First@Union[ Map[mag[v1[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of vertex-figure-cells are distant ",d1," from a vertex of the polychoron we truncate."];

d2=First@Union[ Map[mag[v2[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of truncated cells are distant ",d2," from a vertex of the dual."];

c1=Table[
Select[v, Chop[ mag[v1[[ i ]]-#] - d1,.000001 ]==0&],
{i,Length[v1]}];
Print["There are ",Length[c1]," vertex-figure-polyhedra with ",Length[ c1[[1]] ]," vertices."];
c2=Table[
Select[v, Chop[ mag[v2[[ i ]]-#] - d2,.000001 ]==0&],
{i,Length[v2]}];
Print["There are ",Length[c2]," rectified polyhedra with ",Length[ c2[[1]] ]," vertices."];

Choose a ViewPoint,  find Basis Vectors

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers (rectified vertex first)*)

vpt=rfacevpt[v1,v2];(*opposite rectified face centers*)

vpt=rcellvpt[v1,v2];(*opposite rectified cell centers*)

gbas=NullSpace[ {N[vpt]} ]

Construct Cell Shadows

b1=Select[c1,
Chop[Dot[vpt,cent[#]],.000001]>0&];
Length[b1]

zaq1=(*make all projected visible cells of the first type*)
Table[
r=Map[ Dot[ gbas, # ]&, b1[[ i ]] ];
Graphics3D[ConvexHull3D[r]],
{i,Length[b1]}];

Show[zaq1];

b2=Select[c2,
Chop[Dot[vpt,cent[#]],.000001]>0&];
Length[b2]

zaq2=(*make all projected visible cells of the second type*)
Table[
r=Map[ Dot[ gbas, # ]&, b2[[ i ]] ];
Graphics3D[ConvexHull3D[r]],
{i,Length[b2]}];

Show[zaq2[[1]]];

Sort Shadows by Distance from Origin

zaq=Join[zaq1,zaq2];(*merge cell lists*)
t=Map[{(*sort according to distance from origin*)
mag[ Chop[ cent[ Level[parse[#],{-2}] ],.000001 ] ],
Flatten[Position[zaq,#]],
Chop[ cent[ Level[parse[#],{-2}] ],.000001 ]}&, zaq];
chik=Split[Sort[t,#1[[1]]<#2[[1]]&],TrueQ[(Abs[#1[[1]]-#2[[1]]]<.0001)]&];

Print["There are ",Length[chik]," distinct sets of polyhedra"];

xaq=Table[
q=vunion[ #[[1]]& /@ (RotateLeft[#,2]& /@ chik[[j]]) ];
r=Sort[Map[#[[1]]&, Table[
First /@ Position[chik[[j]], q[[i]] ],
{i,Length[q]}] ] ];
zaq[[ Flatten[ Map[First[ #[[2]] ]&, chik[[j]][[r]] ] ] ]],
{j,Length[chik]}];

s11=Map[Length,xaq];
Print["There are ",s11," polyhedra in the various sets"];
Print["There are ",Plus@@s11," polyhedra in the complete shadow"];

Display Complete Shadow, Central Shadow, Exploded Cell Shadows

(*optional vertex-first ViewPoint*)
pt=2*unit[ First@vunion[Flatten[parse[xaq[[1]]],1]] ];

g1=Show[zaq,(*the complete shadow*)
Boxed->False,
ViewPoint->pt];

g2=Show[xaq[[{1}]],(*the innermost polyhedron or polyhedra*)
Boxed->False,
ViewPoint->pt];

a=.25;(*set translation variable; explode cell shadows apart*)
qq=Table[
t=Map[Chop[ cent[ Level[parse[#],{-2}] ],.000001 ]&, xaq[[i]] ];
Table[trans[xaq[[i]][[j]],t[[j]]*a],{j,Length[t]}],
{i,Length[xaq]}
];
g3=Show[ qq,(*the exploded cell shadows*)
Boxed->False,
ViewPoint->pt];

Show[(*the three images above*)
GraphicsArray[{g1,g2,g3},GraphicsSpacing->-.20],
Background->GrayLevel[.1]
];

Display Sequential Construction of the Shadow

(*the sequential building of the complete shadow*)
r=mag[ v[[1]] ];
seq=Table[Show[xaq[[ Range[i] ]],
PlotRange->{{-r,r},{-r,r},{-r,r}},
ViewPoint->pt,
Boxed->False],
{i,Length[xaq]}];

For the purposes of a GraphicsArray, partitioning the sequence may be best. Supposing the sequence is twelve images in length, we might write “Partition[seq,4]” instead of just “seq”.

Length[seq]

Show[(*show all stages of the sequential building*)
GraphicsArray[Partition[seq,7],GraphicsSpacing->-.20],
Background->GrayLevel[0]
];

r{5,3,3}: Hidden-detail method

Select Polychoron,  find Cells

v=rectify[v533];(*the polychoron we will project*)
Print["There are ",Length[v]," vertices."];
v1=v533;(*the polychoron we rectify*)
v2=v335;(*the dual*)

d1=First@Union[ Map[mag[v1[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of vertex-figure-cells are distant ",d1," from a vertex of the polychoron we rectify."];

d2=First@Union[ Map[mag[v2[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of rectified cells are distant ",d2," from a vertex of the dual."];

c1=Table[
Select[v, Chop[ mag[v1[[ i ]]-#] - d1,.000001 ]==0&],
{i,Length[v1]}];
Print["There are ",Length[c1]," vertex-figure-polyhedra with ",Length[ c1[[1]] ]," vertices."];
c2=Table[
Select[v, Chop[ mag[v2[[ i ]]-#] - d2,.000001 ]==0&],
{i,Length[v2]}];
Print["There are ",Length[c2]," rectified polyhedra with ",Length[ c2[[1]] ]," vertices."];

Choose a ViewPoint,  find Basis Vectors

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers (rectified vertex first)*)

vpt=rfacevpt[v1,v2];(*opposite rectified face centers*)

vpt=rcellvpt[v1,v2];(*opposite rectified cell centers*)

gbas=NullSpace[ {N[vpt]} ]

Construct Cell Shadows

b1=Select[c1,
Chop[Dot[vpt,cent[#]],.000001]>0&];
Length[b1]

zaq1=(*make all projected visible cells of the first type*)
Table[
r=vunion[ Map[ Dot[ gbas, # ]&, b1[[ i ]] ] ];
Graphics3D[ConvexHull3D[r]],
{i,Length[b1]}];

Show[zaq1];

b2=Select[c2,
Chop[Dot[vpt,cent[#]],.000001]>0&];
Length[b2]

zaq2=(*make all projected visible cells of the second type*)
Table[
r=Map[ Dot[ gbas, # ]&, b2[[ i ]] ];
Graphics3D[ConvexHull3D[r]],
{i,Length[b2]}];

Show[zaq2[[1]]];

Sort Shadows by Distance from Origin

zaq=Join[zaq1,zaq2];(*merge cell lists*)
t=Map[{(*sort according to distance from origin*)
mag[ Chop[ cent[ Level[parse[#],{-2}] ],.000001 ] ],
Flatten[Position[zaq,#]],
Chop[ cent[ Level[parse[#],{-2}] ],.000001 ]}&, zaq];
chik=Split[Sort[t,#1[[1]]<#2[[1]]&],TrueQ[(Abs[#1[[1]]-#2[[1]]]<.0001)]&];

Print["There are ",Length[chik]," distinct sets of polyhedra"];

xaq=Table[
q=vunion[ #[[1]]& /@ (RotateLeft[#,2]& /@ chik[[j]]) ];
r=Sort[Map[#[[1]]&, Table[
First /@ Position[chik[[j]], q[[i]] ],
{i,Length[q]}] ] ];
zaq[[ Flatten[ Map[First[ #[[2]] ]&, chik[[j]][[r]] ] ] ]],
{j,Length[chik]}];

s11=Map[Length,xaq];
Print["There are ",s11," polyhedra in the various sets"];
Print["There are ",Plus@@s11," polyhedra in the complete shadow"];

Display Complete Shadow, Central Shadow, Exploded Cell Shadows

(*optional vertex-first ViewPoint*)
pt=2*unit[ First@vunion[Flatten[parse[xaq[[1]]],1]] ];

g1=Show[zaq,(*the complete shadow*)
Boxed->False,
ViewPoint->pt];

g2=Show[xaq[[{1}]],(*the innermost polyhedron or polyhedra*)
Boxed->False,
ViewPoint->pt];

a=.25;(*set translation variable; explode cell shadows apart*)
qq=Table[
t=Map[Chop[ cent[ Level[parse[#],{-2}] ],.000001 ]&, xaq[[i]] ];
Table[trans[xaq[[i]][[j]],t[[j]]*a],{j,Length[t]}],
{i,Length[xaq]}
];
g3=Show[ qq,(*the exploded cell shadows*)
Boxed->False,
ViewPoint->pt];

Show[(*the three images above*)
GraphicsArray[{g1,g2,g3},GraphicsSpacing->-.20],
Background->GrayLevel[.1]
];

Display Sequential Construction of the Shadow

(*the sequential building of the complete shadow*)
r=mag[ v[[1]] ];
seq=Table[Show[xaq[[ Range[i] ]],
PlotRange->{{-r,r},{-r,r},{-r,r}},
ViewPoint->pt,
Boxed->False],
{i,Length[xaq]}];

For the purposes of a GraphicsArray, partitioning the sequence may be best. Supposing the sequence is twelve images in length, we might write “Partition[seq,4]” instead of just “seq”.

Length[seq]

Show[(*show all stages of the sequential building*)
GraphicsArray[Partition[seq,5],GraphicsSpacing->-.20],
Background->GrayLevel[0]
];

Hidden-Detail-Removed Projections

Introduction

The removal of hidden detail under orthogonal projection is a difficult subject, here presented in its simplest terms, as it applies to those simplest polytopes, the regular convex polytopes.

	In space of n dimensions, an (n-1)-space divides the n-space into two half-spaces. Any (n-1)-space has a surface normal, a vector perpendicular to the (n-1)-space and pointing into one half-space or the other. The familiar cross product between two vectors v1 and v2, in three dimensions, gives the surface normal of the triangle determined by those vectors. The sign of the normal vector is reversed by the order in which the cross product is taken: that is, Cross[ v1, v2 ] has the opposite sign as Cross[ v2, v1 ].

v1={1,2,3};
v2={1,-1,1};
Cross[v1, v2]
Cross[v2, v1]

If the polygons bounding a convex polyhedron have consistently ordered vertices, say, counter-clockwise as seen from outside the polyhedron, then the surface normals obtained are also consistent and the order may be chosen so that all normal vectors point to the outside of the polyhedron. Now suppose we wish to obtain the orthogonal projection of only those polygons visible from any given viewpoint in the 3-space. By finding the dot product between the viewpoint vector and surface normals, and checking signs, we will find that the polygons fall into two or three sets:
	
	1. Sign is greater than zero: angle between polygon normal and view vector is greater than zero degrees and less than 90 degrees: polygon is visible.
	2. Sign is zero: angle between polygon normal and view vector is 90 degrees; polygon is not visible (although some of its edges are visible).
	3. Sign is less than zero: angle between polygon normal and view vector is greater than 90 degrees; polygon is not visible.
	
	When a polyhedron is regular, convex, and centered upon the origin, the removal of hidden detail becomes extremely simple. We may dispense with finding the cross products altogether and rely upon the centers of each face; these are vectors parallel to the outward surface normals and have the same signs. The sign of the dot product of the view vector with these face centers is all we need. The same procedure extends to polytopes in higher space, and in the fourth dimension, where the sign of the cross product of a polyhedron does depend upon the ordering of its vertices, and various problems and work-arounds must arise, when the polychoron is regular, convex, and centered upon the origin, we may merely find the centers of its bounding polyhedra, and check the sign of the dot products between these centers and the view vector.
	
	Let us consider in more detail some analogies involving projections and removal of hidden detail, in three and four dimensions. When we project a convex polyhedron into a plane, having removed hidden detail, the periphery of the projection is a set of line segments or edges bounding a convex polygon; this polygon is the convex hull of the projection, and, with its interior, is the orthogonal shadow of the polyhedron. However, this convex hull is tiled with polygons which fit together perfectly, edge to edge. These are the visible projected faces of the polyhedron. Generally speaking, and always when the polyhedron is regular, the faces closest to the center of the projection are the least foreshortened, while those at the periphery are the most foreshortened. At the extreme the faces degenerate into the edges of the convex hull of the projection. As an example of this, consider the hidden-detail-removed, face-first projection of an ordinary cube; only one of the six squares is visible, but the four sides of this visible square are also edges of four degenerate squares.
	
	When we make a face-first projection of a polyhedron, that particular face is completely unforeshortened. The face-first, hidden-detail-removed projection of the Platonic pentagonal dodecahedron, then, gives one unforeshortened pentagon at the center, surrounded by five equally foreshortened pentagons, the convex hull of the projection being a regular decagon.
	
	Suppose, now, that we are in the plane of the above projection. We cannot see the central pentagon at all; it is hidden from us by the foreshortened pentagons around it, and of these all we see are edges. Perhaps by circling the projection we might deduce that it is an equilateral decagon, and also a regular decagon; but to reconstruct the pentagonal dodecahedron from this would be formidable task. This relates to a curious projective rule: when we look “down” at an (n-1)-dimensional polytope from “up” in an n-space, we see the entire (n-1)-dimensional polytope, and its interior. That is, here in three dimensions, we see all the edges of a polygon, and its interior. In four dimensions, we would be accustomed to seeing all the faces of a polyhedron, and its interior!
	
	The analogy to the pentagonal dodecahedron in four dimensions is the 120-cell, bounded by 120 pentagonal dodecahedra. The analogy to the face-first projection is a cell-first projection, in this case, a pentagonal-dodecahedron-first projection. When hidden detail is removed, we see (in the 4-space) only 45 of the 120 dodecahedra; the others are either entirely on the far side, or have foreshortened into planes. One dodecahedron—the closest to us in the 4-space—is entirely unforeshortened and lies at the center of the projection. It is surrounded by twelve slightly foreshortened dodecahedron; these are further surrounded by twenty more-foreshortened dodecahedra, and then the twelve most-foreshortened dodecahedra close up the convex hull of the projection. In four dimensions we would see all 45 dodecahedra at once. They all lie in a single 3-space. We would see all their faces and all their interiors.
	
	In three dimensions, however, we would see the convex hull. The central dodecahedron, and its twelve neighbors, are entirely hidden from us. However, we can apply various techniques to circumvent our limitations. For instance, we can build up the projection in stages: show the central dodecahedron, then add the twelve surrounding it, and so on. Or we may explode the 45 dodecahedra apart slightly. We may also, in a ray-tracing environment, assign some transparency to the faces, so that we literally see all 45 dodecahedra and their interiors at once, almost as if we were actually in the fourth dimension. However, there is a kind of inversion which distorts the situation: the central dodecahedron is actually closest to the viewpoint in the 4-space, and the outermost dodecahedra are the most distant.

	In the sections below, a standard sequence of steps is followed:

	1. Select the polychoron.
	2. Construct all bounding polyhedra (cells).
	3. Select viewpoint in the 4-space.
	4. Construct all visible cell shadows.
	5. Sort projected cells by distance from the origin in the 3-space.
	6. Display all cells, the central cell or cells, and all cells exploded slightly apart.
	7. Display the sequence of accrued cell shadows, from the center outward to the final hull.
	
	These projections give us the clearest possible representation of how the polyhedra bounding a polychoron fit together. Code to export into POV-Ray is found below. This export can itself be slow with the more complicated figures,

Regular Convex Polychora

Select Polychoron

(*Simplex or 5-cell*)
v=v333;(*the polychoron to be projected*)
v1=-v333;(*the dual*)

(*Cross Polytope or 16-cell*)
v=v334;(*the polychoron to be projected*)
v1=v433;(*the dual*)

(*Tesseract or 8-cell*)
v=v433;(*the polychoron to be projected*)
v1=v334;(*the dual*)

(*24-cell*)
v=vi343;(*the polychoron to be projected*)
v1=vii343;(*the dual*)

(*600-cell*)
v=v335;(*the polychoron to be projected*)
v1=v533;(*the dual*)

(*120-cell*)
v=v533;(*the polychoron to be projected*)
v1=v335;(*the dual*)

Find Cells

Print["There are ",Length[v]," vertices"];
d1=First@Union[ Map[mag[v1[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of any one cell are distant ",d1," from a vertex of the dual"];

c1=Table[
Select[v, Abs[ mag[v1[[ i ]]-#] - d1 ]<.001&],
{i,Length[v1]}];
Print["There are ",Length[c1]," polyhedra with ",Length[ c1[[1]] ]," vertices"];

Choose a ViewPoint

vpt=vertvpt[v];(*vertex-first*)

vpt=edgevpt[v];(*edge-first*)

vpt=facevpt[v,v1];(*face-first*)

vpt=cellvpt[v,v1];(*polyhedron-first*)

Construct Cell Shadows

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

b1=Select[c1, Chop[Dot[vpt,cent[#]],.000001]>0&];
Print["There are ",Length[b1]," visible polyhedra"];

zaq=(*make all projected visible cells*)
Table[
r=Map[ Dot[ gbas, # ]&, b1[[ i ]] ];
Graphics3D[ConvexHull3D[r]],
{i,Length[b1]}];

Show[zaq[[1]]];

t=Map[{(*sort according to distance from origin*)
mag[ Chop[ cent[ Level[parse[#],{-2}] ],.000001 ] ],
Flatten[Position[zaq,#]],
Chop[ cent[ Level[parse[#],{-2}] ],.000001 ]}&, zaq];
chik=Split[Sort[t,#1[[1]]<#2[[1]]&],TrueQ[(Abs[#1[[1]]-#2[[1]]]<.0001)]&];

Print["There are ",Length[chik]," distinct sets of polyhedra"];

xaq=Table[
q=vunion[ #[[1]]& /@ (RotateLeft[#,2]& /@ chik[[j]]) ];
r=Sort[Map[#[[1]]&, Table[
First /@ Position[chik[[j]], q[[i]] ],
{i,Length[q]}] ] ];
zaq[[ Flatten[ Map[First[ #[[2]] ]&, chik[[j]][[r]] ] ] ]],
{j,Length[chik]}];

s11=Map[Length,xaq];
Print["There are ",s11," polyhedra in the various sets"];
Print["There are ",Plus@@s11," polyhedra in the complete shadow"];

Display Complete Shadow, Central Shadow, Exploded Cell Shadows

(*optional vertex-first ViewPoint*)
pt=2*unit[ First@vunion[Flatten[parse[xaq[[1]]],1]] ];

(*set alternate ViewPoint*)
pt=2*unit[{1,0,1}];

g1=Show[zaq,(*the complete shadow*)
Boxed->False,
ViewPoint->pt];

g2=Show[xaq[[1]],(*the innermost polyhedron or polyhedra*)
Boxed->False,
ViewPoint->pt];

<<RealTime3D`

a=.25;(*set translation variable; explode cell shadows apart*)
qq=Table[
t=Map[Chop[ cent[ Level[parse[#],{-2}] ],.000001 ]&, xaq[[i]] ];
Table[trans[xaq[[i]][[j]],t[[j]]*a],{j,Length[t]}],
{i,Length[xaq]}
];
g3=Show[ qq,(*the exploded cell shadows*)
Boxed->False,
ViewPoint->2.5*unit[pt]];

Show[(*the three images above*)
GraphicsArray[{g1,g2,g3},GraphicsSpacing->-.20],
Background->GrayLevel[.1]
];

Display Sequential Construction of the Shadow

(*the sequential building of the complete shadow*)
r=mag[ v[[1]] ];(*the largest diameter, for PlotRange*)
seq=Table[Show[xaq[[ Range[i] ]],
PlotRange->{{-r,r},{-r,r},{-r,r}},
ViewPoint->pt,
Boxed->False],
{i,Length[xaq]}];

Show[(*show all stages of the sequential building*)
GraphicsArray[seq,GraphicsSpacing->-.10],
Background->GrayLevel[0]
];

Truncated Regular Convex Polychora

The syntax for truncate[ ] is truncate[ polychoron, p ] where p is the number of sides of the polygons bounding the polytope.

Select Polychoron

(*Simplex or 5-cell*)
v=truncate[v333,3];(*the polychoron to be projected*)
v1=v333;(*the polychoron we truncate*)
v2=-v333;(*the dual*)

(*Cross Polytope or 16-cell*)
v=truncate[v334,3];(*the polychoron to be projected*)
v1=v334;(*the polychoron we truncate*)
v2=v433;(*the dual*)

(*Tesseract or 8-cell*)
v=truncate[v433,4];(*the polychoron to be projected*)
v1=v433;(*the polychoron we truncate*)
v2=v334;(*the dual*)

(*24-cell*)
v=truncate[vi343,3];(*the polychoron to be projected*)
v1=vi343;(*the polychoron we truncate*)
v2=vii343;(*the dual*)

(*600-cell*)
v=truncate[v335,3];(*the polychoron to be projected*)
v1=v335;(*the polychoron we truncate*)
v2=v533;(*the dual*)

(*120-cell*)
v=truncate[v533,5];(*the polychoron to be projected*)
v1=v533;(*the polychoron we truncate*)
v2=v335;(*the dual*)

Find Cells

Print["There are ",Length[v]," vertices."];

d1=First@Union[ Map[mag[v1[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of vertex-figure-cells are distant ",d1," from a vertex of the polychoron we truncate."];

d2=First@Union[ Map[mag[v2[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of truncated cells are distant ",d2," from a vertex of the dual."];

c1=Table[
Select[v, Abs[ mag[v1[[ i ]]-#] - d1 ]<.001&],
{i,Length[v1]}];
Print["There are ",Length[c1]," vertex-figure-polyhedra with ",Length[ c1[[1]] ]," vertices."];

c2=Table[
Select[v, Abs[ mag[v2[[ i ]]-#] - d2 ]<.001&],
{i,Length[v2]}];
Print["There are ",Length[c2]," truncated polyhedra with ",Length[ c2[[1]] ]," vertices."];

Choose a ViewPoint

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers*)

vpt=rfacevpt[v1,v2];(*opposite truncated face centers*)

vpt=rcellvpt[v1,v2];(*opposite truncated cell centers*)

Construct Cell Shadows

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

b1=Select[c1,
Chop[Dot[vpt,cent[#]],.000001]>0&];
Print["There are ",Length[b1]," vertex-figure-type cells"];

zaq1=(*make all projected visible cells of the first type*)
Table[
r=Map[ Dot[ gbas, # ]&, b1[[ i ]] ];
Graphics3D[ConvexHull3D[r]],
{i,Length[b1]}];

Show[zaq1[[1]]];(*preview*)


b2=Select[c2,
Chop[Dot[vpt,cent[#]],.000001]>0&];
Print["There are ",Length[b2]," truncated cells"];

zaq2=(*make all projected visible cells of the second type*)
Table[
r=Map[ Dot[ gbas, # ]&, b2[[ i ]] ];
Graphics3D[ConvexHull3D[r]],
{i,Length[b2]}];

Show[zaq2[[1]]];(*preview*)

Sort Shadows by Distance from Origin

zaq=Join[zaq1,zaq2];(*merge cell lists*)
t=Map[{(*sort according to distance from origin*)
mag[ Chop[ cent[ Level[parse[#],{-2}] ],.000001 ] ],
Flatten[Position[zaq,#]],
Chop[ cent[ Level[parse[#],{-2}] ],.000001 ]}&, zaq];
chik=Split[Sort[t,#1[[1]]<#2[[1]]&],TrueQ[(Abs[#1[[1]]-#2[[1]]]<.0001)]&];

Print["There are ",Length[chik]," distinct sets of polyhedra"];

xaq=Table[
q=vunion[ #[[1]]& /@ (RotateLeft[#,2]& /@ chik[[j]]) ];
r=Sort[Map[#[[1]]&, Table[
First /@ Position[chik[[j]], q[[i]] ],
{i,Length[q]}] ] ];
zaq[[ Flatten[ Map[First[ #[[2]] ]&, chik[[j]][[r]] ] ] ]],
{j,Length[chik]}];

s11=Map[Length,xaq];
Print["There are ",s11," polyhedra in the various sets"];
Print["There are ",Plus@@s11," polyhedra in the complete shadow"];

Display Complete Shadow, Central Shadow, Exploded Cell Shadows

(*optional vertex-first ViewPoint*)
pt=2*unit[ First@vunion[Flatten[parse[xaq[[1]]],1]] ];

g1=Show[zaq,(*the complete shadow*)
Boxed->False,
ViewPoint->pt];

g2=Show[xaq[[{1}]],(*the innermost polyhedron or polyhedra*)
Boxed->False,
ViewPoint->pt];

a=.25;(*set translation variable; explode cell shadows apart*)
qq=Table[
t=Map[Chop[ cent[ Level[parse[#],{-2}] ],.000001 ]&, xaq[[i]] ];
Table[trans[xaq[[i]][[j]],t[[j]]*a],{j,Length[t]}],
{i,Length[xaq]}
];
g3=Show[ qq,(*the exploded cell shadows*)
Boxed->False,
ViewPoint->pt];

Show[(*the three images above*)
GraphicsArray[{g1,g2,g3},GraphicsSpacing->-.20],
Background->GrayLevel[.1]
];

Display Sequential Construction of the Shadow

(*the sequential building of the complete shadow*)
r=mag[ v[[1]] ];
seq=Table[Show[xaq[[ Range[i] ]],
PlotRange->{{-r,r},{-r,r},{-r,r}},
ViewPoint->{0,0,2},
Boxed->False],
{i,Length[xaq]}];

For the purposes of a GraphicsArray, partitioning the sequence may be best. Supposing the sequence is twelve images in length, we might write “Partition[seq,4]” instead of just “seq”.

Show[(*show all stages of the sequential building*)
GraphicsArray[seq,GraphicsSpacing->-.10],
Background->GrayLevel[0]
];

Rectified Regular Convex Polychora

The syntax for rectify[ ] is rectify[ polychoron ].

	Each of the six convex polychora requires two inputs: the polychoron to be rectified, and its dual. Hence admissible pairs are:
	
	1. v333, -v333.
	2. v334, v433.
	3. v433, v334.
	4. vi343, vii343.
	5. v335, v533.
	6. v533, v335.

Select Polychoron

(*Simplex or 5-cell*)
v=rectify[v333];(*the polychoron to be projected*)
v1=v333;(*the polychoron we truncate*)
v2=-v333;(*the dual*)

(*Cross Polytope or 16-cell*)
v=rectify[v334];(*the polychoron to be projected*)
v1=v334;(*the polychoron we truncate*)
v2=v433;(*the dual*)

(*Tesseract or 8-cell*)
v=rectify[v433];(*the polychoron to be projected*)
v1=v433;(*the polychoron we truncate*)
v2=v334;(*the dual*)

(*24-cell*)
v=rectify[vi343];(*the polychoron to be projected*)
v1=vi343;(*the polychoron we truncate*)
v2=vii343;(*the dual*)

(*600-cell*)
v=rectify[v335];(*the polychoron to be projected*)
v1=v335;(*the polychoron we truncate*)
v2=v533;(*the dual*)

(*120-cell*)
v=rectify[v533];(*the polychoron to be projected*)
v1=v533;(*the polychoron we truncate*)
v2=v335;(*the dual*)

Find Cells

Print["There are ",Length[v]," vertices."];

d1=First@Union[ Map[mag[v1[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of vertex-figure-cells are distant ",d1," from a vertex of the polychoron we truncate."];

d2=First@Union[ Map[mag[v2[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of rectified cells are distant ",d2," from a vertex of the dual."];

c1=Table[
Select[v, Abs[ mag[v1[[ i ]]-#] - d1 ]<.001&],
{i,Length[v1]}];
Print["There are ",Length[c1]," vertex-figure-polyhedra with ",Length[ c1[[1]] ]," vertices."];

c2=Table[
Select[v, Abs[ mag[v2[[ i ]]-#] - d2 ]<.001&],
{i,Length[v2]}];
Print["There are ",Length[c2]," rectified polyhedra with ",Length[ c2[[1]] ]," vertices."];

Choose a ViewPoint

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers (rectified vertex first)*)

vpt=rfacevpt[v1,v2];(*opposite rectified face centers*)

vpt=rcellvpt[v1,v2];(*opposite rectified cell centers*)

Construct Cell Shadows

gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

b1=Select[c1,
Chop[Dot[vpt,cent[#]],.000001]>0&];
Print["There are ",Length[b1]," vertex-figure-type cells"];

zaq1=(*make all projected visible cells of the first type*)
Table[
r=Map[ Dot[ gbas, # ]&, b1[[ i ]] ];
Graphics3D[ConvexHull3D[r]],
{i,Length[b1]}];

Show[zaq1[[1]]];(*preview*)


b2=Select[c2,
Chop[Dot[vpt,cent[#]],.000001]>0&];
Print["There are ",Length[b2]," rectified cells"];

zaq2=(*make all projected visible cells of the second type*)
Table[
r=Map[ Dot[ gbas, # ]&, b2[[ i ]] ];
Graphics3D[ConvexHull3D[r]],
{i,Length[b2]}];

Show[zaq2[[1]]];(*preview*)

Sort Shadows by Distance from Origin

zaq=Join[zaq1,zaq2];(*merge cell lists*)
t=Map[{(*sort according to distance from origin*)
mag[ Chop[ cent[ Level[parse[#],{-2}] ],.000001 ] ],
Flatten[Position[zaq,#]],
Chop[ cent[ Level[parse[#],{-2}] ],.000001 ]}&, zaq];
chik=Split[Sort[t,#1[[1]]<#2[[1]]&],TrueQ[(Abs[#1[[1]]-#2[[1]]]<.0001)]&];

Print["There are ",Length[chik]," distinct sets of polyhedra"];

xaq=Table[
q=vunion[ #[[1]]& /@ (RotateLeft[#,2]& /@ chik[[j]]) ];
r=Sort[Map[#[[1]]&, Table[
First /@ Position[chik[[j]], q[[i]] ],
{i,Length[q]}] ] ];
zaq[[ Flatten[ Map[First[ #[[2]] ]&, chik[[j]][[r]] ] ] ]],
{j,Length[chik]}];

s11=Map[Length,xaq];
Print["There are ",s11," polyhedra in the various sets"];
Print["There are ",Plus@@s11," polyhedra in the complete shadow"];

Display Complete Shadow, Central Shadow, Exploded Cell Shadows

(*optional vertex-first ViewPoint*)
pt=2*unit[ First@vunion[Flatten[parse[xaq[[1]]],1]] ];

g1=Show[zaq,(*the complete shadow*)
Boxed->False,
ViewPoint->pt];

g2=Show[xaq[[1]],(*the innermost polyhedron or polyhedra*)
Boxed->False,
ViewPoint->pt];

a=.25;(*set translation variable; explode cell shadows apart*)
qq=Table[
t=Map[Chop[ cent[ Level[parse[#],{-2}] ],.000001 ]&, xaq[[i]] ];
Table[trans[xaq[[i]][[j]],t[[j]]*a],{j,Length[t]}],
{i,Length[xaq]}
];
g3=Show[ qq,(*the exploded cell shadows*)
Boxed->False,
ViewPoint->pt];

Show[(*the three images above*)
GraphicsArray[{g1,g2,g3},GraphicsSpacing->-.20],
Background->GrayLevel[.1]
];

Display Sequential Construction of the Shadow

(*the sequential building of the complete shadow*)
r=mag[ v[[1]] ];
seq=Table[Show[xaq[[ Range[i] ]],
PlotRange->{{-r,r},{-r,r},{-r,r}},
ViewPoint->{0,0,2},
Boxed->False],
{i,Length[xaq]}];

For the purposes of a GraphicsArray, partitioning the sequence may be best. Supposing the sequence is twelve images in length, we might write “Partition[seq,4]” instead of just “seq”.

Show[(*show all stages of the sequential building*)
GraphicsArray[seq,GraphicsSpacing->-.10],
Background->GrayLevel[0]
];

Animation of Rotations

In four dimensions, rotation occurs around a fixed plane. Here, an animation is created, in which the truncated 24-cell, t{3,4,3}, is rotated about the yz, xz, and xy planes in turn. Hidden detail is removed in the 4-space, so we obtain a set of cubes and truncated octahedra which fit together perfectly to close up the orthogonal shadow. The shadow begins as a non-Archimedean truncated cuboctahedron, morphs into a 4-vertex-truncated Kepler’s rhombic dodecahedron, and then back into a truncated cuboctahedron, but with a different orientation than the first.

	Two angles are split into submultiples, ArcTan Sqrt[.5] or 35.2643 degrees, and 45 degrees. The steps of rotation are twelfths of these.

v=N[truncate[vi343,3]];(*the polychoron we will project*)
Print["There are ",Length[v]," vertices"];
v1=vii343;(*the dual*)
v2=vi343;(*the parent polychoron*)
d1=First@Union[ Map[mag[v1[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)]
d2=First@Union[ Map[mag[v2[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)]

c1=Table[
Select[v, Abs[ mag[v1[[ i ]]-#] - d1 ]<.001&],
{i,Length[v1]}];
Print["There are ",Length[c1]," polyhedra with ",Length[ c1[[1]] ]," vertices"];
c2=Table[
Select[v, Abs[ mag[v2[[ i ]]-#] - d2 ]<.001&],
{i,Length[v2]}];
Print["There are ",Length[c2]," polyhedra with ",Length[ c2[[1]] ]," vertices"];

c3=Join[c1,c2];
Print["There are ",Length[c3]," polyhedra altogether"];

r=N[First@Union[Map[mag[#]&,v]]];(*circumradius*)
Print["The circumradius is ",r];

angle1=N[Pi/4];
angle2=N[ArcTan[Sqrt[.5]]];

vpt={0,0,0,1};
Print["The viewpoint is ",vpt];

poly=Table[

Which[
i<13,

	v2 = Map[xwmat[(i-1)*angle1/12].#&, c3, {2}];
	b1=Select[v2,
	Chop[ Dot[vpt, Chop[cent[#],.000001]],.000001 ]>0&];
	sh1 = Map[#[[{1,2,3}]]&, b1, {2}],
		
i>12 && i<25,

    v11 = Map[xwmat[angle1].#&, c3, {2}];
    v2 = Map[ywmat[(i-13)*angle2/12].#&, v11, {2}];
	b1=Select[v2,
	Chop[ Dot[vpt, Chop[cent[#],.000001]],.000001 ]>0&];
	sh1 = Map[#[[{1,2,3}]]&, b1, {2}],
	
i>24,

    v12 = Map[ywmat[angle2].#&, v11, {2}];
    v2 = Map[zwmat[(i-25)*angle2/12].#&, v12, {2}];
	b1=Select[v2,
	Chop[ Dot[vpt, Chop[cent[#],.000001]],.000001 ]>0&];
	sh1 = Map[#[[{1,2,3}]]&, b1, {2}]
];
 
zaq=(*make all projected visible cells of both types*)
Table[
Graphics3D[ConvexHull3D[ sh1[[k]] ]],
{k,Length[sh1]}];

Show[zaq,
Boxed->False,
Background->GrayLevel[0],
PlotRange->{{-r,r},{-r,r},{-r,r}}],
{i,36}];

Tesseract

Morphs from cube to rectangular box to hexagonal prism to Kepler’s rhombic dodecahedron.

v=v433;(*the polychoron we will project*)
Print["There are ",Length[v]," vertices"];
v1=v334;(*the dual*)
d1=First@Union[ Map[mag[v1[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)]

c1=Table[
Select[v, Abs[ mag[v1[[ i ]]-#] - d1 ]<.001&],
{i,Length[v1]}];
Print["There are ",Length[c1]," polyhedra with ",Length[ c1[[1]] ]," vertices"];

c3=c1;
Print["There are ",Length[c3]," polyhedra altogether"];

r=N[First@Union[Map[mag[#]&,v]]];(*circumradius*)
Print["The circumradius is ",r];

angle1=N[Pi/4];
angle2=N[ArcTan[Sqrt[.5]]];

vpt={0,0,0,1};
Print["The viewpoint is ",vpt];

poly=Table[

Which[
i<13,

	v2 = Map[xwmat[(i-1)*angle1/12].#&, c3, {2}];
	b1=Select[v2,
	Chop[ Dot[vpt, Chop[cent[#],.000001]],.000001 ]>0&];
	sh1 = Map[#[[{1,2,3}]]&, b1, {2}],
		
i>12 && i<25,

    v11 = Map[xwmat[angle1].#&, c3, {2}];
    v2 = Map[ywmat[(i-13)*angle2/12].#&, v11, {2}];
	b1=Select[v2,
	Chop[ Dot[vpt, Chop[cent[#],.000001]],.000001 ]>0&];
	sh1 = Map[#[[{1,2,3}]]&, b1, {2}],
	
i>24,

    v12 = Map[ywmat[angle2].#&, v11, {2}];
    v2 = Map[zwmat[(i-25)*-angle2/12].#&, v12, {2}];
	b1=Select[v2,
	Chop[ Dot[vpt, Chop[cent[#],.000001]],.000001 ]>0&];
	sh1 = Map[#[[{1,2,3}]]&, b1, {2}]
];
 
zaq=(*make all projected visible cells of both types*)
Table[
Graphics3D[ConvexHull3D[ sh1[[k]] ]],
{k,Length[sh1]}];

Show[zaq,
Boxed->False,
Background->GrayLevel[0],
PlotRange->{{-r,r},{-r,r},{-r,r}}],
{i,36}];

POV-Ray Export Example

The following will take a list of polyhedra, the visible cells of a polychoron, say, and write spheres on all vertices, cylinders on edges, and break the faces into triangles, assembling all into a POV-Ray #include file of the specified name. Then a generic scene file is written.

	The first step depends upon whether only one list of visible polyhedra exists (ordinary convex regular polychora), or two (truncated or rectified figures).

Choose this

(*regular convex polychoron*)
qaz=zaq;

... or this

(*truncated or rectified: we have two lists, zaq1 and zaq2*)
qaz=Join[zaq1,zaq2];

To POV spheres, cylinders, and triangles

(*vertices*)
v11=vunion[ Level[ parse[ qaz ], {-2}] ];
Print["There are ",Length[v11]," distinct vertices in the projection"];

(*edges*)
e11=Map[v11[[#]]&,
Union[Sort /@ Flatten[ Map[ edgedex[v11, Chop[parse[#],.000001] ]&, qaz ], 1] ] ];
Print["There are ",Length[e11]," distinct edges in the projection"];

(*faces*)
f11=(Cases[qaz,Polygon[x_],Infinity]/.Polygon[x_]:>x);
Print["There are ",Length[f11]," faces altogether in the projection"];

f22=Map[Chop[cent[#],.000001]&, f11];(*centers of faces*)
v22=vunion[f22];(*distinct centers*)
Print["There are ",Length[v22]," distinct faces in the projection"];
fdex=Flatten[ First /@ (Map[Position[f22,#]&,v22]) ];(*indices of distinct faces*)

(*assemble POV spheres, cylinders, triangles, in lists*)
f1=Map[toTriangles[#]&, f11[[fdex]] ];
q1=Map[Ball[#,R1]&,Chop[v11,.000001]];
q2=Map[Rod[#,R2]&,Chop[e11,.000001]];
balls=ColumnForm[Map[ballmake["sphere",# ]&,q1],Left];
sticks=ColumnForm[Map[cyllmake["cylinder",# ]&,q2],Left];
faces=ColumnForm[Map[facemake["triangle",# ]&,Chop[Flatten[f1,1],.000001]],Left];

Where to write the files?

SetDirectory["Macintosh HD:Desktop Folder:"]

Choose filename

(*set names for scene and #include files to be written*)
s1="t{3,3,5}"
s2=".inc";
s3=".pov";

Write #include file

strm=OpenWrite[ StringJoin[s1,s2],
FormatType->OutputForm,
PageWidth->Infinity];
Write[strm,"#declare RODS = union{"];
Write[strm,sticks];
Write[strm,"}"];
Write[strm,"#declare BALLS = union{"];
Write[strm,balls];
Write[strm,"}"];
Write[strm,"#declare FACES = union{"];
Write[strm,faces];
Write[strm,"}"];
Close[strm]

Write scene file

cam=6*mag[v[[1]]]*unit[{2,-8,5}];(*adjust camera location to circumradius polychoron*)
loc=StringJoin["location ", ToString[SequenceForm["<", Infix[nForm /@ cam, ", "], ">"]]];

(*name of #include file*)
inc=StringJoin["#include \"",StringJoin[s1,s2],"\""];

scene={
"#version 3.0",
"#include \"colors.inc\"",
"#include \"shapes.inc\"",
"#include \"glass.inc\"",
"#include \"metals.inc\"",
"#include \"textures.inc\"",
"#default { texture { pigment {color White} finish {phong 0.01 ambient 0.2 diffuse 0.6} }}",
"",
"global_settings {",
"assumed_gamma 1.8",
"max_trace_level 15",
"}",
"",
"",
"camera {",
loc,
"direction <0, 2, 0>",
"up <0, 0, 1>",
"right <1, 0, 0>",
"sky <0., 0., 1>",
"look_at <0, 0, 0>",
"}",
"",
"light_source {", 
"<0, 0, 100>",
"color rgb <.7, .7, .7>",
"}",
"",
"light_source {", 
"<12, -12, 20>",
"color rgb <.7, .7, .2>",
"}",
"",
"",
"#declare R1 =.035 //spheres",
"#declare R2 =.025  //cylinders",
"",
inc,
"",
"object{RODS texture {",
"pigment { Silver1_Colour }",
"finish {",
"metallic",
"ambient 0.4",
"diffuse 0.35",
"specular 0.85",
"roughness 0.01",
"reflection 0.05",
"brilliance 1.5",
"}",
"}",
"}",
"",
"object{BALLS texture{Gold_Metal}}",
"",
"object{FACES",
"pigment{",
"color rgbf < 0.8, 0.8, 1, 0.975 >", 
"}",
"}",
"",
"",
"plane{z, -4",
"pigment{",
"hexagon",
"color rgb < 0.7, 0.7, 0.7 > ",
"color rgb < 1, 1, 1 > ",
"color rgb < 0.5, 0.5, 0.5 > ",
"rotate<90,0,0>}",
"}",
"",
"sky_sphere{",
"pigment{color rgb < 0.88, 0.62, 0.88 >}", 
"}"};

strm=OpenWrite[ StringJoin[s1,s3],(*write scene with .pov suffix*)
FormatType->OutputForm,
PageWidth->Infinity];
Write[strm,ColumnForm[scene]];	
Close[strm]

Solid Sections

Introduction

Given a polychoron and a vector in R4 we may obtain solid sections orthogonal to the vector. In a complete section, we find all intersections of edges with a given 3-space; in a simplified section, we find only those vertices of the polychoron which lie in a single 3-space. The usual sets of symmetry axes may be chosen. In the Complete Sections sections, an animation is produced. The complete sections are discovered and the animation steps through, from the first section to the center-most complete section. The more complicated polychora, {3,3,5}, {5,3,3}, and their truncated and rectified forms, have complete sections which grow ever more complicated, as the central section is approached. Some patience or a horrendously fast computer will be required to make an animated sequence of complete sections for such polychora.

	Some of the simplified sections of the convex regular polychora are treated in Chapter 13.1 of Regular Polytopes, and the sections are tabulated in Table V, at the end of the book. The results obtained below will be found the agree completely with those given in Table V, except, we “fill in the blanks” and create the convex hulls for every simplified section, and go further, to construct the simplified sections orthogonal to the axes connecting opposite edge and face centers. By adopting the convex hulls of the given point-set as the actual section, we depart from the classic approach as found in Regular Polytopes, where certain simplified sections are regarded as two or more inscribed regular polyhedra.
	
	In May, 2000, faster methods were introduced to find complete sections. Briefly, all polyhedral cells of the polytope were found first, and the complete section was taken as the union of all the polygon sections of these polyhedra. More work is needed, since in some sections two coincident polygons arise; it is desirable to remove duplicate polygons.

Simplified Sections of Regular Convex Polychora

Select Polychoron

(*Simplex or 5-cell*)
v=v333;
v1=-v333;(*dual*)

(*Cross Polytope or 16-cell*)
v=v334;
v1=v433;(*dual*)

(*Tesseract or 8-cell*)
v=v433;
v1=v334;(*dual*)

(*24-cell*)
v=vi343;
v1=vii343;(*dual*)

(*600-cell*)
v=v335;
v1=v533;(*dual*)

(*120-cell*)
v=v533;
v1=v335;(*dual*)

Choose a Symmetry Axis

vpt=rvertvpt[v];(*opposite vertices*)

vpt=redgevpt[v];(*opposite edge centers*)

vpt=rfacevpt[v,v1];(*opposite face centers*)

vpt=rcellvpt[v,v1];(*opposite cell centers*)

Find Edges, Identify Simplified Sections

simp=Reverse[Chop[Union[Map[ptspace[#, unit[vpt], 0]&, v],
SameTest -> (Chop[#1 - #2, .000001] == 0 & )], .000001]]
Print["There are ",Length[simp]," simplified sections at or above the center"];

Construct & Display Simplified Sections

gbas=NullSpace[ {N[ vpt ]} ];(*basis vectors*)
r=mag[ v[[1]] ];(*circumradius, for PlotRange*)

sects=Table[
a=Select[v, Chop[ptspace[#, unit[vpt], simp[[k]]],.000001]==0&];(*get simplified section*)
pts=vunion[ Map[ Dot[ gbas, # ]&, a] ];(*project and remove duplicates*);
zaq=
Which[
Length[pts]==1,(*point*)
 Graphics3D[{AbsolutePointSize[3],Point[ pts[[1]] ]}],
Length[pts]==2,(*segment*)
 Graphics3D[{AbsoluteThickness[3],Line[pts]}],
Length[pts]==3,(*triangle*)
 Graphics3D[Polygon[pts]],
(*polygon*) 
Length[pts]>3 && Union[ Chop[ plane[ pts[[{1,2,3}]],#]&/@  pts,.000001] ]=={0},
 Graphics3D[Polygon[convexhull2D[pts]]],
(*polyhedron*)
Length[pts]>3 && Union[ Chop[ plane[ pts[[{1,2,3}]],#]&/@  pts,.000001] ]!={0},
 Graphics3D[ConvexHull3D[pts]],
Length[pts]==0,{}
];
Show[zaq,
PlotLabel->StringJoin["Simplified Section ",ToString[k],
"\nNumber of points ",ToString[Length[pts]]],
Boxed->True,
PlotRange->{{-r,r},{-r,r},{-r,r}},
ViewPoint->2.25*unit[{1,0,.75}]],
{k,Length[simp]}];

Simplified Sections of Truncated Regular Convex Polychora

Select Polychoron

(*Simplex or 5-cell*)
v=truncate[v333,3];(*the polychoron to be sectioned*)
v1=v333;(*the polychoron we truncate*)
v2=-v333;(*the dual*)

(*Cross Polytope or 16-cell*)
v=truncate[v334,3];(*the polychoron to be sectioned*)
v1=v334;(*the polychoron we truncate*)
v2=v433;(*the dual*)

(*Tesseract or 8-cell*)
v=truncate[v433,4];(*the polychoron to be sectioned*)
v1=v433;(*the polychoron we truncate*)
v2=v334;(*the dual*)

(*24-cell*)
v=truncate[vi343,3];(*the polychoron to be sectioned*)
v1=vi343;(*the polychoron we truncate*)
v2=vii343;(*the dual*)

(*600-cell*)
v=truncate[v335,3];(*the polychoron to be sectioned*)
v1=v335;(*the polychoron we truncate*)
v2=v533;(*the dual*)

(*120-cell*)
v=truncate[v533,5];(*the polychoron to be sectioned*)
v1=v533;(*the polychoron we truncate*)
v2=v335;(*the dual*)

Choose a Symmetry Axis

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers (rectified vertex first)*)

vpt=rfacevpt[v1,v2];(*opposite rectified face centers*)

vpt=rcellvpt[v1,v2];(*opposite rectified cell centers*)

Identify Simplified Sections

simp=Reverse[Chop[Union[Map[ptspace[#, unit[vpt], 0]&, v],
SameTest -> (Chop[#1 - #2, .000001] == 0 & )], .000001]]
Print["There are ",Length[simp]," simplified sections at or above the center"];

Construct & Display Simplified Sections

gbas=NullSpace[ {N[ vpt ]} ];(*basis vectors*)
r=mag[ v[[1]] ];(*circumradius, for PlotRange*)

sects=Table[
a=Select[v, Chop[ptspace[#, unit[vpt], simp[[k]]],.000001]==0&];(*get simplified section*)
pts=vunion[ Map[ Dot[ gbas, # ]&, a] ];(*project and remove duplicates*);
zaq=
Which[
Length[pts]==1,(*point*)
 Graphics3D[{AbsolutePointSize[3],Point[ pts[[1]] ]}],
Length[pts]==2,(*segment*)
 Graphics3D[{AbsoluteThickness[3],Line[pts]}],
Length[pts]==3,(*triangle*)
 Graphics3D[Polygon[pts]],
(*polygon*) 
Length[pts]>3 && Union[ Chop[ plane[ pts[[{1,2,3}]],#]&/@  pts,.000001] ]=={0},
 Graphics3D[Polygon[convexhull2D[pts]]],
(*polyhedron*)
Length[pts]>3 && Union[ Chop[ plane[ pts[[{1,2,3}]],#]&/@  pts,.000001] ]!={0},
 Graphics3D[ConvexHull3D[pts]],
Length[pts]==0,{}
];
Show[zaq,
PlotLabel->StringJoin["Simplified Section ",ToString[k],
"\nNumber of points ",ToString[Length[pts]]],
Boxed->True,
PlotRange->{{-r,r},{-r,r},{-r,r}},
ViewPoint->2.25*unit[{1,0,.75}]],
{k,Length[simp]}];

Simplified Sections of Rectified Regular Convex Polychora

Select Polychoron to be Rectified

(*Simplex or 5-cell*)
v=rectify[v333];(*the polychoron to be sectioned*)
v1=v333;(*the polychoron we rectify*)
v2=-v333;(*the dual*)

(*Cross Polytope or 16-cell*)
v=rectify[v334];(*the polychoron to be sectioned*)
v1=v334;(*the polychoron we rectify*)
v2=v433;(*the dual*)

(*Tesseract or 8-cell*)
v=rectify[v433];(*the polychoron to be sectioned*)
v1=v433;(*the polychoron we rectify*)
v2=v334;(*the dual*)

(*24-cell*)
v=rectify[vi343];(*the polychoron to be sectioned*)
v1=vi343;(*the polychoron we rectify*)
v2=vii343;(*the dual*)

(*600-cell*)
v=rectify[v335];(*the polychoron to be sectioned*)
v1=v335;(*the polychoron we rectify*)
v2=v533;(*the dual*)

(*120-cell*)
v=rectify[v533];(*the polychoron to be sectioned*)
v1=v533;(*the polychoron we rectify*)
v2=v335;(*the dual*)

Choose a Symmetry Axis

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers (rectified vertex first)*)

vpt=rfacevpt[v1,v2];(*opposite rectified face centers*)

vpt=rcellvpt[v1,v2];(*opposite rectified cell centers*)

Identify Simplified Sections

simp=Reverse[Chop[Union[Map[ptspace[#, unit[vpt], 0]&, v],
SameTest -> (Chop[#1 - #2, .000001] == 0 & )], .000001]]
Print["There are ",Length[simp]," simplified sections at or above the center"];

Construct & Display Simplified Sections

gbas=NullSpace[ {N[ vpt ]} ];(*basis vectors*)
r=mag[ v[[1]] ];(*circumradius, for PlotRange*)

sects=Table[
a=Select[v, Chop[ptspace[#, unit[vpt], simp[[k]]],.000001]==0&];(*get simplified section*)
pts=vunion[ Map[ Dot[ gbas, # ]&, a] ];(*project and remove duplicates*);
zaq=
Which[
Length[pts]==1,(*point*)
 Graphics3D[{AbsolutePointSize[3],Point[ pts[[1]] ]}],
Length[pts]==2,(*segment*)
 Graphics3D[{AbsoluteThickness[3],Line[pts]}],
Length[pts]==3,(*triangle*)
 Graphics3D[Polygon[pts]],
(*polygon*) 
Length[pts]>3 && Union[ Chop[ plane[ pts[[{1,2,3}]],#]&/@  pts,.000001] ]=={0},
 Graphics3D[Polygon[convexhull2D[pts]]],
(*polyhedron*)
Length[pts]>3 && Union[ Chop[ plane[ pts[[{1,2,3}]],#]&/@  pts,.000001] ]!={0},
 Graphics3D[ConvexHull3D[pts]],
Length[pts]==0,{}
];
Show[zaq,
PlotLabel->StringJoin["Simplified Section ",ToString[k],
"\nNumber of points ",ToString[Length[pts]]],
Boxed->True,
PlotRange->{{-r,r},{-r,r},{-r,r}},
ViewPoint->2.25*unit[{1,0,.75}]],
{k,Length[simp]}];

Complete Sections of Regular Convex Polychora

Select Polychoron

(*Simplex or 5-cell*)
v1=v333;
v2=-v333;(*dual*)

(*Cross Polytope or 16-cell*)
v1=v334;
v2=v433;(*dual*)

(*Tesseract or 8-cell*)
v1=v433;
v2=v334;(*dual*)

(*24-cell*)
v1=vi343;
v2=vii343;(*dual*)

(*600-cell*)
v1=v335;
v2=v533;(*dual*)

(*120-cell*)
v1=v533;
v2=v335;(*dual*)

Find all cells, and find their edges

cells=cellfind[v1,v2];
cellsegs=Map[edgefind[#]&, cells];

Choose a Symmetry Axis

vpt=rvertvpt[v1];(*opposite vertices*)

vpt=redgevpt[v1];(*opposite edge centers*)

vpt=rfacevpt[v1,v2];(*opposite face centers*)

vpt=rcellvpt[v1,v2];(*opposite cell centers*)

Set Number of Steps to Central Section

numsteps=10;

Construct Sequence of  Sections

basis=NullSpace[ {N[ vpt ]} ];(*basis vectors*)
h=Max[Map[ptspace[#, unit[vpt], 0]&, v1] ];(*what distance to begin sections?*)
r=mag[ v1[[1]] ];(*circumradius, for PlotRange*)
step=h/numsteps;(*distance between sections*)

seq=Table[
  sects=Table[
  pts4=vunion[Cases[
    Map[section[#, h-(i*step), unit[vpt] ]&, cellsegs[[k]] ],
  {_,_,_,_}, Infinity]];
  pts3=Map[ Chop[Dot[ basis, # ],.000001]&, pts4];(*project*);
  If[Length[pts3]>2, Polygon[ convexhull2D[pts3] ] ],
  {k,Length[cellsegs]}];

zaq=Graphics3D[ Cases[sects,Polygon[x_],Infinity] ];
Show[zaq,
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
ViewPoint->{1,-2,1}];
zaq,
{i,numsteps}];(*(2*numsteps)-1 to go all the way through*)

Complete Sections of Truncated Regular Convex Polychora

Select Polychoron

(*Simplex or 5-cell*)
v=truncate[v333,3];(*the polychoron to be sectioned*)
v1=v333;(*the polychoron we truncate*)
v2=-v333;(*the dual*)

(*Cross Polytope or 16-cell*)
v=truncate[v334,3];(*the polychoron to be sectioned*)
v1=v334;(*the polychoron we truncate*)
v2=v433;(*the dual*)

(*Tesseract or 8-cell*)
v=truncate[v433,4];(*the polychoron to be sectioned*)
v1=v433;(*the polychoron we truncate*)
v2=v334;(*the dual*)

(*24-cell*)
v=truncate[vi343,3];(*the polychoron to be sectioned*)
v1=vi343;(*the polychoron we truncate*)
v2=vii343;(*the dual*)

(*600-cell*)
v=truncate[v335,3];(*the polychoron to be sectioned*)
v1=v335;(*the polychoron we truncate*)
v2=v533;(*the dual*)

(*120-cell*)
v=truncate[v533,5];(*the polychoron to be sectioned*)
v1=v533;(*the polychoron we truncate*)
v2=v335;(*the dual*)

Find Cells

Print["There are ",Length[v]," vertices."];

d1=First@Union[ Map[mag[v1[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of vertex-figure-cells are distant ",d1," from a vertex of the polychoron we truncate."];

d2=First@Union[ Map[mag[v2[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of truncated cells are distant ",d2," from a vertex of the dual."];

c1=Table[
Select[v, Abs[ mag[v1[[ i ]]-#] - d1 ]<.001&],
{i,Length[v1]}];
Print["There are ",Length[c1]," vertex-figure-polyhedra with ",Length[ c1[[1]] ]," vertices."];

c2=Table[
Select[v, Abs[ mag[v2[[ i ]]-#] - d2 ]<.001&],
{i,Length[v2]}];
Print["There are ",Length[c2]," truncated polyhedra with ",Length[ c2[[1]] ]," vertices."];

(*find edges of each polyhedral cell*)
cellsegs=Join[ Map[edgefind[#]&, c1], Map[edgefind[#]&, c2] ];

Choose a Symmetry Axis

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers*)

vpt=rfacevpt[v1,v2];(*opposite truncated face centers*)

vpt=rcellvpt[v1,v2];(*opposite truncated cell centers*)

Set Number of Steps to Central Section

numsteps=10;

Construct Sequence of  Sections

basis=NullSpace[ {N[ vpt ]} ];(*basis vectors*)
h=Max[Map[ptspace[#, unit[vpt], 0]&, v] ];(*what distance to begin sections?*)
r=mag[ v[[1]] ];(*circumradius, for PlotRange*)
step=h/numsteps;(*distance between sections*)

seq=Table[
  sects=Table[
  pts4=vunion[Cases[
    Map[section[#, h-(i*step), unit[vpt] ]&, cellsegs[[k]] ],
  {_,_,_,_}, Infinity]];
  pts3=Map[ Chop[Dot[ basis, # ],.000001]&, pts4];(*project*);
  If[Length[pts3]>2, Polygon[ convexhull2D[pts3] ] ],
  {k,Length[cellsegs]}];
zaq=Graphics3D[ Cases[sects,Polygon[_],Infinity] ];
Show[zaq,
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
ViewPoint->{1,-2,1}];
zaq,
{i,numsteps}];(*(2*numsteps)-1 to go all the way through*)

Complete Sections of Rectified Regular Convex Polychora

Select Polychoron to be Rectified

(*Simplex or 5-cell*)
v=rectify[v333];(*the polychoron to be sectioned*)
v1=v333;(*the polychoron we rectify*)
v2=-v333;(*the dual*)

(*Cross Polytope or 16-cell*)
v=rectify[v334];(*the polychoron to be sectioned*)
v1=v334;(*the polychoron we rectify*)
v2=v433;(*the dual*)

(*Tesseract or 8-cell*)
v=rectify[v433];(*the polychoron to be sectioned*)
v1=v433;(*the polychoron we rectify*)
v2=v334;(*the dual*)

(*24-cell*)
v=rectify[vi343];(*the polychoron to be sectioned*)
v1=vi343;(*the polychoron we rectify*)
v2=vii343;(*the dual*)

(*600-cell*)
v=rectify[v335];(*the polychoron to be sectioned*)
v1=v335;(*the polychoron we rectify*)
v2=v533;(*the dual*)

(*120-cell*)
v=rectify[v533];(*the polychoron to be sectioned*)
v1=v533;(*the polychoron we rectify*)
v2=v335;(*the dual*)

Find Cells

Print["There are ",Length[v]," vertices."];

d1=First@Union[ Map[mag[v1[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of vertex-figure-cells are distant ",d1," from a vertex of the polychoron we rectify."];

d2=First@Union[ Map[mag[v2[[1]]-#]&, v],
SameTest->(Abs[#1-#2]<.001&)];
Print["The vertices of rectified cells are distant ",d2," from a vertex of the dual."];

c1=Table[
Select[v, Abs[ mag[v1[[ i ]]-#] - d1 ]<.001&],
{i,Length[v1]}];
Print["There are ",Length[c1]," vertex-figure-polyhedra with ",Length[ c1[[1]] ]," vertices."];

c2=Table[
Select[v, Abs[ mag[v2[[ i ]]-#] - d2 ]<.001&],
{i,Length[v2]}];
Print["There are ",Length[c2]," rectified polyhedra with ",Length[ c2[[1]] ]," vertices."];

(*find edges of each polyhedral cell*)
cellsegs=Join[ Map[edgefind[#]&, c1], Map[edgefind[#]&, c2] ];

Choose a Symmetry Axis

vpt=rvertvpt[v1];(*vertex-figure-first*)

vpt=redgevpt[v1];(*opposite edge centers (rectified vertex first)*)

vpt=rfacevpt[v1,v2];(*opposite rectified face centers*)

vpt=rcellvpt[v1,v2];(*opposite rectified cell centers*)

Set Number of Steps to Central Section

numsteps=10;

Construct Sequence of  Sections

basis=NullSpace[ {N[ vpt ]} ];(*basis vectors*)
h=Max[Map[ptspace[#, unit[vpt], 0]&, v] ];(*what distance to begin sections?*)
r=mag[ v[[1]] ];(*circumradius, for PlotRange*)
step=h/numsteps;(*distance between sections*)

seq=Table[
  sects=Table[
  pts4=vunion[Cases[
    Map[section[#, h-(i*step), unit[vpt] ]&, cellsegs[[k]] ],
  {_,_,_,_}, Infinity]];
  pts3=Map[ Chop[Dot[ basis, # ],.000001]&, pts4];(*project*);
  If[Length[pts3]>2, Polygon[ convexhull2D[pts3] ] ],
  {k,Length[cellsegs]}];
zaq=Graphics3D[ Cases[sects,Polygon[_],Infinity] ];
Show[zaq,
Boxed->False,
PlotRange->{{-r,r},{-r,r},{-r,r}},
ViewPoint->{1,-2,1}];
zaq,
{i,numsteps}];(*(2*numsteps)-1 to go all the way through*)

Plane Projections

Introduction

“Special” vertex coordinates are found for the regular convex polychora, which give the most symmetrical projections into the {x,y} plane. The derived truncated and rectified forms are constructed as well. The constructions closely follow, whenever possible, those set forth in Chapter 13 of Regular Polytopes.

	To see why these coordinates are so “special” evaluate the same examples, substituting “ordinary” coordinates. For instance, with the tesseract, set v=nCube[4] instead of v=xyCube[4].

	The more complicated projections, those of {3, 3, 5} and {5, 3, 3} and especially their derived forms, benefit from output to a high-resolution laser printer. The graphic should be sized as large as possible, and the Line objects should be assigned an AbsoluteThickness of .5 or less for good results on ordinary paper.

{3,3,3} or 5-cell; the regular simplex

The nSimplex function already casts coordinates for all regular simplexes into the special form. Although the example below uses nSimplex[4] (identical to v333), it works as well for any n greater than 2. The truncated and rectified forms are given below.

v=nSimplex[4];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g1=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[5],Point /@ a} ],
AspectRatio->Automatic];

v=truncate[ nSimplex[4], 3 ];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g2=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[5],Point /@ a} ],
AspectRatio->Automatic];

v=rectify[ nSimplex[4] ];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g3=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[5],Point /@ a} ],
AspectRatio->Automatic];

Show[GraphicsArray[{g1,g2,g3},
GraphicsSpacing->.1]];

{3,3,4} or 16-cell; the regular orthoplex

The nCross function does not offer especially symmetrical projections into the {x,y} plane. For that we employ a separate function, xyCross, following Chapter 13.4 of Regular Polytopes. See the Initialization section, “Simplexes, Cross Polytopes, Hypercubes.” The function may be used equally well to obtain plane projections from higher dimensions.

v=xyCross[4];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g1=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[5],Point /@ a} ],
AspectRatio->Automatic];

v=truncate[ xyCross[4], 3 ];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g2=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[5],Point /@ a} ],
AspectRatio->Automatic];

v=rectify[ xyCross[4] ];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g3=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[5],Point /@ a} ],
AspectRatio->Automatic];

Show[GraphicsArray[{g1,g2,g3},
GraphicsSpacing->0]];

{4,3,3} or 8-cell; the regular hypercube

Special coordinates for the tesseract, {4,3,3} were not given in Regular Polytopes. However, I was able to apply zonotope to half the vertices of the special {3,3,4}, and thus obtain the special vertices of {4,3,3}. The “xyCube” function extends to higher spaces, and we obtain the “regular 2n-gon fillled with rhombs in every possible way” described in Regular Polytopes. See the Initialization section, “Simplexes, Cross Polytopes, Hypercubes.”

v=xyCube[4];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g1=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[4],Point /@ a} ],
AspectRatio->Automatic];

v=truncate[ xyCube[4], 4 ];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g2=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[4],Point /@ a} ],
AspectRatio->Automatic];

v=rectify[ xyCube[4] ];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g3=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[4],Point /@ a} ],
AspectRatio->Automatic];

Show[GraphicsArray[{g1,g2,g3},
GraphicsSpacing->0]];

It can be useful to pick out one cell of a polytope when projecting into lower spaces. Here one tesseract of the ten such bounding a 5-cube is shown with blue edges. The method below can be applied to n-dimensional hypercubes, where n >= 3. It may readily be applied to the other regular polychora.

n=5;(*set dimension of hypercube*)
v1=xyCube[n];
v2=xyCross[n];

(*now find one cell*)
d1=First@Union[ Map[N[mag[v2[[1]]-#]]&, v1],
SameTest->(Abs[#1-#2]<.001&)];
c1=Select[v1, Abs[ mag[v2[[1]]-#] - d1 ]<.001&];

(*project*)
a=Map[#[[{1,2}]]&, v1 ];(*vertices*)
b=Map[#[[{1,2}]]&, edgefind[ v1 ], {-2}];(*all edges*)
e1=Map[#[[{1,2}]]&, edgefind[ c1 ],{2}];(*edges of one cell*)

Show[
 Graphics[
  {Line /@ b,
  AbsoluteThickness[2],RGBColor[0,0,1],Line /@ e1,
  RGBColor[1,0,0],AbsolutePointSize[5],Point /@ a}
 ],
AspectRatio->Automatic];

{3,4,3} or 24-cell

Following Chapter 13.5 of Regular Polytopes, we find the special coordinates for the 24-cell, {3,4,3}.

(*evaluate this cell!*)
a=N[Sqrt[2]];
b=N[Sqrt[3]-1];

A=Table[
{a Cos[k Pi/12], a Sin[k Pi/12], b Cos[5 k Pi/12], b Sin[5 k Pi/12]},
{k,0,22,2}];

B=Table[
{b Cos[k Pi/12], b Sin[k Pi/12], a Cos[5 k Pi/12], a Sin[5 k Pi/12]},
{k,1,23,2}];

viii343=Join[A,B];

v=viii343;
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g1=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[4],Point /@ a} ],
AspectRatio->Automatic];

v=truncate[ viii343, 3 ];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g2=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[4],Point /@ a} ],
AspectRatio->Automatic];

v=rectify[ viii343 ];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g3=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[4],Point /@ a} ],
AspectRatio->Automatic];

Show[GraphicsArray[{g1,g2,g3},
GraphicsSpacing->0]];

{3,3,5} or 600-cell

Following Chapter 13.6 of Regular Polytopes, we find the special coordinates for the 600-cell, {3,3,5}, and name them “vii335.” The resulting “triacontagonal” projection into the {x,y} plane apears as the frontpiece in Regular Polytopes. To compare this to the projection obtained from the “ordinary” vertices of the 600-cell, set “v=v335” instead of “v=vii335” below.

“In other words, a, b, c, d are the positive roots of the equation”

s=Solve[(45 x^8 - 90 x^6 + 60 x^4 - 15 x^2 + 1) ==0, x];
Sort[Select[N[x /.s],#>0&],#1>#2&]

“If the circum-radius is 1 … we have”

{a,b,c,d}=
{Sqrt[ (1+3^(-.5) 5^(-.25) GoldenRatio^(3/2)) /2 ],
Sqrt[ (1+3^(-.5) 5^(-.25) GoldenRatio^(-3/2)) /2 ],
Sqrt[ (1-3^(-.5) 5^(-.25) GoldenRatio^(-3/2)) /2 ],
Sqrt[ (1-3^(-.5) 5^(-.25) GoldenRatio^(3/2)) /2 ]}

qA=Table[
{a Cos[k Pi/30], a Sin[k Pi/30], d Cos[11 k Pi/30], d Sin[11 k Pi/30]},
{k,0,58,2}];

qB=Table[
{b Cos[k Pi/30], b Sin[k Pi/30], c Cos[11 k Pi/30], c Sin[11 k Pi/30]},
{k,1,59,2}];

qC=Table[
{c Cos[k Pi/30], c Sin[k Pi/30], -b Cos[11 k Pi/30], -b Sin[11 k Pi/30]},
{k,1,59,2}];

qD=Table[
{d Cos[k Pi/30], d Sin[k Pi/30], -a Cos[11 k Pi/30], -a Sin[11 k Pi/30]},
{k,0,58,2}];

vii335=Join[qA,qB,qC,qD];

v=vii335;(*frontpiece of Regular Polytopes*)
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g1=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[3],Point /@ a} ],
AspectRatio->Automatic];

v=truncate[ vii335, 3 ];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g2=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[3],Point /@ a} ],
AspectRatio->Automatic];

v=rectify[ vii335 ];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g3=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[3],Point /@ a} ],
AspectRatio->Automatic];

{5,3,3} or 120-cell

Special coordinates for the 120-cell, {5,3,3} were not given in Regular Polytopes. However, I was able to find the centers of the 600 tetrahedra bounding the special {3,3,5} and thus obtain the special vertices of {5,3,3}. These are in an initialization cell, so if all initialization cells have been evaluated, the following will give the special projection into the {x,y} plane. The 1200 edges can take a while to render.

	Coxeter writes, in Chapter 13.6, “The vertices of the reciprocal {5, 3, 3}, being the centres of the 600 cells of {3, 3, 5}, project into the centroids of the projected sets of four points … we thus have a plane figure in which 600 points occur on twelve concentric circles (including the outermost), and sixty on each of the remaining eight.” To compare this to the projection obtained from the “ordinary” vertices of the 120-cell, set “v=v533” instead of “v=vii533” below.

v=vii533;
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g1=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[3],Point /@ a} ],
AspectRatio->Automatic];

v=truncate[ vii533, 5 ];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g2=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[3],Point /@ a} ],
AspectRatio->Automatic];

v=rectify[ vii533 ];
a=Map[#[[{1,2}]]&, v ];
b=Map[#[[{1,2}]]&, edgefind[ v ], {-2}];
g3=Show[ Graphics[ {Line /@ b,RGBColor[1,0,0],AbsolutePointSize[3],Point /@ a} ],
AspectRatio->Automatic];

Below the method, albeit clunky, by which the vertices were found.

Special Vertices for {5,3,3}

Construct Special Vertices, {5,3,3}

This method supposes that the special vertices vii335 of {3,3,5} have already been found (see subsection “{3,3,5} or 600-cell” above).

v=vii335;(*"triacontagonal" verts of {3,3,5}*)
Length[v]
d=Union[ Map[mag[v[[1]]-#]&, Rest@v],
SameTest->(Chop[#1-#2,.000001]==0&)]

(*find the 600 tetrahedra of {3,3,5} 12 times over*)
Timing[
allcells=
Table[
a=RotateLeft[v,i];
b1=a[[1]];
b=N[Select[Rest@a, Abs[ mag[b1-#]-N[ d[[1]] ] ]<.001&]];
Table[
b2=b[[k]];
e1={b1,b2};
t=Join[e1,{#}]& /@ Select[b, ( (Abs[ mag[e1[[1]]-#]-N[d[[1]]] ]<.001) && 
(Abs[ mag[e1[[2]]-#]-N[d[[1]]] ]<.001) )&];
tet=Table[
  s=Select[b, ( 
   (Abs[ mag[t[[j,1]]-#]-N[d[[1]]] ]<.001) && 
   (Abs[ mag[t[[j,2]]-#]-N[d[[1]]] ]<.001) && 
   (Abs[ mag[t[[j,3]]-#]-N[d[[1]]] ]<.001) 
  )&];
  {Join[t[[j]], {s[[1]]} ],Join[ t[[j]], {s[[2]]} ]},
{j,Length[t]}];
vunion[ Map[cent[#]&, Flatten[tet,1] ] ],
{k,Length[b]}],
{i,Length[v]}]
][[1]]

(*we went through all 120 verts of {3,3,5}*)
Length[allcells]

(*we found the 600 tetrahedra 12 times over*)
Length[Flatten[allcells,2]]

(*the 600 vertices of {5,3,3}*)
Length[vii533=vunion[ Flatten[allcells,2] ]]

vii533[[1]](*the first vertex*)

Plane Projections of Star Polytopes

Introduction

The regular star polychora are treated in Chapter 14 of Regular Polytopes. Bounded by either Platonic or Kepler-Poinsot polyhedra, their cells interpenetrate, and thus the solid shadows are, for the most part, not good candidates for rendering in Mathematica. By finding the faces bounding each cell however, we can obtain good solid shadows in POV-Ray; see the Solid Shadows of Star Polychora section, below.

	The wireframe projections we obtain are so complicated as to scarcely merit rendering to a computer monitor. The best we can do is to drag out the graphic to, say, 700 (or more) pixels square, then set magnification to 300%, re-render, and retreat to 100%. Given a high-resolution PostScript laser printer, fairly good results can be obtained. Line objects should be assigned an AbsoluteThickness of .5 or less for ordinary paper.
	
	Nine of the ten star polychora can be obtained by faceting {3,3,5}; in other words, they have the same vertices as {3,3,5}. We find the tenth, {5/2,3,3}, by faceting {5,3,3}. In addition, of the ten regular star polychora, several share the same edges:

{3,3,5}, {3,5,5/2}, 5,5/2,5}, and {5,3,5/2} have the same edges.
{3,3,5/2}, {3,5/2,5}, 5/2,5,5/2}, and 5/2,3,5} have the same edges.
{5/2,5,3} and {5,5/2,3} have the same edges.
{5/2,3,3} does not share edges with any other regular polychora.

	Thus there are only four different wireframe projections (into any given plane or 3-space) of the ten regular star polychora, and one of these has already been found (the set containing the edges of {3,3,5}). So only three new edge sets must be found to account for all ten.

{5/2, 3, 3}

The only regular faceting of {5,3,3} is {5/2,3,3}.

v=vii533;

(*distinct distances from one vertex to all others*)
d=Union[ Map[mag[v[[1]]-#]&, Rest@v],
SameTest->(Chop[#1-#2,.000001]==0&)];

(*how many vertices will be found at each distance?*)
d1=Table[Select[Rest@v, Abs[ mag[First@v-#]-d[[i]] ]<.001&],
  {i,Length[d]-1}];(*the last "d" is single antipode*)
Map[Length,d1]

(*edges of {5/2,3,3} connect to verts at 25th distance*)
e1=Flatten[
 Table[
 a=Drop[v,i-1];
 {First@a,#}& /@ Select[Rest@a, Abs[ mag[First@a-#] - d[[25]] ]<.001&],
 {i,Length[v]}],1];

Print["There are ",Length[e1]," edges."];

(*vertices into {x,y}*)
a=Map[#[[{1,2}]]&, v ];

(*edges into {x,y}*)
b=Map[#[[{1,2}]]&, e1, {-2}];

Show[
  Graphics[
  {AbsoluteThickness[.5],Line /@ b,
  RGBColor[1,0,0],AbsolutePointSize[3],Point /@ a}
  ],
AspectRatio->Automatic];

{5, 5/2, 3} and {5/2, 5, 3}

v=vii335;

(*distinct distances from one vertex to all others*)
d=Union[ Map[mag[v[[1]]-#]&, Rest@v],
SameTest->(Chop[#1-#2,.000001]==0&)];

(*how many vertices will be found at each distance?*)
d1=Table[Select[Rest@v, Abs[ mag[First@v-#]-d[[i]] ]<.001&],
  {i,Length[d]-1}];(*the last "d" is single antipode*)
Map[Length,d1]

(*edges connect to verts at 2nd distance*)
e1=Flatten[
 Table[
 a=Drop[v,i-1];
 {First@a,#}& /@ Select[Rest@a, Abs[ mag[First@a-#] - d[[2]] ]<.001&],
 {i,Length[v]}],1];

Print["There are ",Length[e1]," edges."];

(*vertices into {x,y}*)
a=Map[#[[{1,2}]]&, v ];

(*edges into {x,y}*)
b=Map[#[[{1,2}]]&, e1, {-2}];

Show[
  Graphics[
  {AbsoluteThickness[.5],Line /@ b,
  RGBColor[1,0,0],AbsolutePointSize[3],Point /@ a}
  ],
AspectRatio->Automatic];

{3, 3, 5/2}, {3, 5/2, 5}, {5/2, 5, 5/2},  and {5/2, 3, 5}

v=vii335;

(*distinct distances from one vertex to all others*)
d=Union[ Map[mag[v[[1]]-#]&, Rest@v],
SameTest->(Chop[#1-#2,.000001]==0&)];

(*how many vertices will be found at each distance?*)
d1=Table[Select[Rest@v, Abs[ mag[First@v-#]-d[[i]] ]<.001&],
  {i,Length[d]-1}];(*the last "d" is single antipode*)
Map[Length,d1]

(*edges connect to verts at 5th distance*)
e1=Flatten[
 Table[
 a=Drop[v,i-1];
 {First@a,#}& /@ Select[Rest@a, Abs[ mag[First@a-#] - d[[5]] ]<.001&],
 {i,Length[v]}],1];

Print["There are ",Length[e1]," edges."];

(*vertices into {x,y}*)
a=Map[#[[{1,2}]]&, v ];

(*edges into {x,y}*)
b=Map[#[[{1,2}]]&, e1, {-2}];

Show[
  Graphics[
  {AbsoluteThickness[.5],Line /@ b,
  RGBColor[1,0,0],AbsolutePointSize[3],Point /@ a}
  ],
AspectRatio->Automatic];

{3, 5, 5/2}, {5, 5/2, 5}, and {5, 3, 5/2} (and {3, 3, 5})

v=vii335;
e1=edgefind[v];(*all these have the edges of {3,3,5}*)

Print["There are ",Length[e1]," edges."];

(*vertices into {x,y}*)
a=Map[#[[{1,2}]]&, v ];

(*edges into {x,y}*)
b=Map[#[[{1,2}]]&, e1, {-2}];

Show[
  Graphics[
  {AbsoluteThickness[.5],Line /@ b,
  RGBColor[1,0,0],AbsolutePointSize[3],Point /@ a}
  ],
AspectRatio->Automatic];

Solid Shadows of Star Polytopes

Please note that to effect any of the constructions in this section, the input cell below this sentence must be evaluated first.

(*edge centers; must be evaluated*)
vr335=rectify[v335];
vr533=rectify[v533];

Introduction

The ten regular star polychora are bounded by Platonic or Kepler-Poinsot polyhedra, except, none are bounded by cubes or octahedra. Thus a cell can be a tetrahedron {3, 3}, a pentagonal dodecahedron {5, 3}, or an icosahedron{3, 5}; a small stellated dodecahedron {5/2, 5}, a great stellated dodecahedron {5/2, 3}, a great dodecahedron {5, 5/2}, or a great icosahedron {3, 5/2}. Unforeshortened projections of all these are found below.
	
	Various pairs of the star polychora share the same faces:

{3, 3, 5} and {3, 5, 5/2}; {3, 3, 5/2} and {3, 5/2, 5}; {5, 5/2, 5} and {5, 3, 5/2}; {5/2, 5, 5/2} and {5/2, 3, 5}.

	Thus by finding the faces of these four sets we could account for seven of the ten regular star-polychora, and have only {5/2, 3, 3}, {5/2, 5, 3}, and {5, 5/2, 3} to construct separately. All ten will be constructed cell by cell, however. The solid shadows of two polychora with the same faces are indistinguishable. We can only distinguish them by some such device as assigning various colors to their bounding polyhedra, or by showing some few of their cells at a time. This is effected below, where a single unforeshortened cell, two cells sharing a face, and the cells sharing an edge, are shown. Hidden-detail-removed projections might be expected to clarify the situation, but the degree of interpenetration between cells is so extreme that this approach is beyond the rendering capabilities of Mathematica. In fact, most of the shadows themselves are too complicated for display within Mathematica, and we are forced to export into POV-Ray format. (Since this notebook was constructed, I found that Mathematica’s RealTime3D allows display and real-time rotation of these star-polyhedral shadows. An example is provided for each of the ten star polychora.)
	
	To find the faces of an ordinary convex regular polychoron, we can rely upon symmetry. Just as the vertices of one polychoron are the centers of the cells of its dual, so also the edge-centers of one polychoron are the face-centers of its dual. The formal and correct method of finding an inscribed regular polychoron within the vertices of some polychoron is set forth in Chapter 14 of Regular Polytopes. Here we rely upon an additional symmetry, as it were: of the ten regular star polychora, nine can be obtained by faceting {3, 3, 5}. The tenth, {5/2, 3, 3}, can be obtained by faceting {5, 3, 3}. That is to say, nine have the same vertices as {3, 3, 5}, the tenth has the same vertices as {5, 3, 3}.
	
	Each of the constructions below follows the same basic steps, with a few twists thrown in whenever the faces as pentagrams. The common process is somewhat as follows: we know that a triangle of {3, 3, 5} can be found by selecting those vertices closest to an edge-center of {5,3,3}. Thus the 720 edges of {5, 3, 3} give 720 of these closest triangles, and we have found the faces of either {3, 3, 5} or {3, 5, 5/2}. Our interest is in the latter; but consider first, that to find a single tetrahedron of {3, 3, 5} we select those vertices closest to a vertex of {5, 3, 3}. The 120 icosahedra bounding {3, 5, 5/2} are concentric to the 120 vertices of {3, 3, 5}. So, having found the 720 triangles, we measure the distances from any one vertex of {3, 3, 5} to all these triangle centers, and take the Union of these distances. Then we loop through and count the number of triangles at each distinct distance, from our vertex of {3, 3, 5}. We are looking for sets of 20 triangles. If more than one such set appears in the list, we test one against the other by projecting and displaying the two sets.
	
	Having found which distance gives the 20 triangles which bound an icosahedron, we loop through the 120 vertices of {3, 3, 5} and find 120 sets of 20 triangles. Finally, we apply two tests: we find and display two icosahedra sharing a single face, and we find and display the five icosahedra surrounding a single edge.
	
	Each construction gives rise to three lists: 
	
	1. “c1”, the distinct faces, except, when pentagrams, the ordered vertices of the circumscribing pentagon.
	2. “c3”, the bounding polyhedra, each polyhedron a list of faces. When the faces are pentagrams, as in {5/2, 5, 5/2}, for instance, the pentagrams are split into a central pentagon and five congruent isosceles triangles.
	3. “c4”, the vertices of each bounding polyhedron. 
	
	When the faces are pentagons or pentagrams, as with seven of the ten, and the polychoron has the vertices of {3, 3, 5}, as with six of the seven, we do not look for vertices at some distance from an edge-center of {5, 3, 3}, but rather, from an edge-center of {3, 3, 5} itself. We find sets of five vertices at two different distances, yet there are three pentagonal polychora, and three pentagrammic. However, two out of each three share the same faces, so for the two sets of five vertices, we find all six. Each pentagon gives also a pentagram, by connecting alternate vertices; and then having found all the faces, we organize them into separate polyhedra by checking distances from a vertex of {3, 3, 5}. All of these pentagonal/pentagrammic forms have 120 cells, in fact, of all the star polychora, only {3, 3, 5/2} has 600 cells.

{3, 5, 5/2}

{3, 5, 5/2} is bounded by 120 vertices, 720 edges, 1200 triangles, and 120 icosahedra.

(*distances from edge midpoint of {5,3,3} to vertices {3,3,5}*)
d=Union[Map[mag[First@vr533-#]&, v335],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many vertices at each distance?*)
d1=Table[Select[v335, Abs[ mag[vr533[[1]] - #]-d[[i]] ]<.001&],
  {i,Length[d]}];
dn=Map[Length,d1];

Print["There are ",Length[vr533]," triangular faces"];
Print["The vertices of {3,3,5} are at ",Length[d]," distances from an edge center of {5,3,3}"];
Print["There are ",dn," vertices at each distance"];
Print["Triangles are found at the ",Flatten[Position[dn,3]]," distances"];

c1=Table[(*find all triangles at 1st distance*)
Select[v335, Abs[ mag[vr533[[k]]-#] - d[[1]] ]<.001&],
{k,Length[vr533]}];

(*distances from a vertex of {3,3,5} to facecenters*)
d2=Union[Map[mag[First@v335-cent[#]]&, c1],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many triangles will be found at each distance?*)
d3=Table[Select[c1, Abs[ mag[v335[[1]]-cent[#] ]-d2[[i]] ]<.001&],
  {i,Length[d2]}];
dn2=Map[Length,d3];

Print["The triangles are at ",Length[d2]," distances from a vertex of {3,3,5}"];
Print["There are ",dn2," triangles at each distance"];

The second distance shows twenty triangles, the number bounding {3,5}. We test this.

(*obtain basis vectors for projection*)
vpt=v335[[1]];(*use a vertex of {3,3,5}*)
gbas=NullSpace[ {N[vpt]} ];

(*does the second distance give {3,5}?*)
f=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[2]] ]<.001&];

zaq=Graphics3D[ Polygon /@ Map[gbas.#&, f, {2}] ];(*project faces*)
pt=gbas.f[[1,1]];(*vertex-first viewpoint in R3*)
Show[zaq,
ViewPoint->2*unit[pt]];

We have indeed found one of the 120 {3, 5}s bounding {3, 5, 5/2}. Now for the rest. Slowly!

(*the 120 polyhedra as sets of faces*)
c3=Table[Select[c1, Abs[ mag[v335[[k]]-cent[#]] - d2[[2]] ]<.001&],
{k,Length[v335]}];

(*the 120 polyhedra as sets of vertices*)
c4=Map[vunion[ Flatten[#,1] ]&, c3];

Have we discovered {3, 5, 5/2}? Let us find the polyhedra sharing a face.

dex=First /@ Position[ c3, c1[[1]] ]

vpt=cent[ c1[[1]] ];
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[Polygon[#]&, Map[Chop[gbas.#,.000001]&, c3[[dex]], {3}], {2}];
poly=Map[Graphics3D[#]&, c5];
pt=Chop[ gbas.c1[[1,1]],.000001 ](*for ViewPoint*)

Show[ poly,
Boxed->False,
ViewPoint->2*unit[pt]];

A further test: find the polyhedra sharing an edge.

p=edgefind[ c3[[1,1]] ];
pcent=cent[ p[[1]] ];
q=Map[edgefind[#]&, c3,{2}];
dex=Union[ First /@ Position[q, p[[1]] ] ]

vpt=pcent;
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[Polygon[#]&, Map[Chop[gbas.#,.000001]&, c3[[dex]], {3}], {2}];
poly=Map[Graphics3D[#]&, c5];
pt=Chop[ gbas.p[[1,1]],.000001 ];(*for ViewPoint*)

Show[ poly,
Boxed->False,
ViewPoint->2*unit[pt]];

We have made several lists:
1. c1, the 1200 triangles of {3, 5, 5/2}.
2. c3, the 120 icosahedra, as lists of twenty triangles.
3. c4, the 120 icosahedra, as lists of twelve vertices.

The solid shadows of this star polychoron are indistinguishable from those of {3, 3, 5}. Version 4 of Mathematica supports the experimental, OpenGL-based RealTime3D. This works well on some computers, but causes crashes on others. A polyhedron may be rotated in real time by clicking and dragging with the mouse.

<<RealTime3D`

vpt=Chop[cent[ c1[[1]] ],.000001];(*face-first viewpoint*)
gbas=Chop[NullSpace[ {N[vpt]} ],.000001];(*basis vectors*)

c5=Map[Chop[gbas.#,.000001]&, Flatten[c3, 2], {2}];(*project*)
c6=Graphics3D[Map[Polygon[#]&, c5]];

Show[c6,
Boxed->False,
ViewPoint->{0,-2,1}];

{3, 5/2, 5}

{3, 5/2, 5} is bounded by 120 vertices, 720 edges, 1200 triangles, and 120 great icosahedra.

(*distances from edge midpoint of {5,3,3} to vertices {3,3,5}*)
d=Union[Map[mag[First@vr533-#]&, v335],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many vertices at each distance?*)
d1=Table[Select[v335, Abs[ mag[vr533[[1]] - #]-d[[i]] ]<.001&],
  {i,Length[d]}];
dn=Map[Length,d1];

Print["There are ",Length[vr533]," triangular faces"];
Print["The vertices of {3,3,5} are at ",Length[d]," distances from an edge center of {5,3,3}"];
Print["There are ",dn," vertices at each distance"];
Print["Triangles are found at the ",Flatten[Position[dn,3]]," distances"];

c1=Table[(*find all triangles at 7th distance*)
Select[v335, Abs[ mag[vr533[[k]]-#] - d[[7]] ]<.001&],
{k,Length[vr533]}];

(*distances from a vertex of {3,3,5} to facecenters*)
d2=Union[Map[mag[First@v335-cent[#]]&, c1],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many triangles will be found at each distance?*)
d3=Table[Select[c1, Abs[ mag[v335[[1]]-cent[#] ]-d2[[i]] ]<.001&],
  {i,Length[d2]}];
dn2=Map[Length,d3];

Print["The triangles are at ",Length[d2]," distances from a vertex of {3,3,5}"];
Print["There are ",dn2," triangles at each distance"];

The second distance shows twenty triangles, the number bounding {3,5/2}. We test this.

(*obtain basis vectors for projection*)
vpt=v335[[1]];(*use a vertex of {3,3,5}*)
gbas=NullSpace[ {N[vpt]} ];

(*does the second distance give {3,5/2}*)
f=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[2]] ]<.001&];

zaq=Graphics3D[ Polygon /@ Map[gbas.#&, f, {2}] ];(*project faces*)
pt=gbas.f[[1,1]];(*vertex-first viewpoint in R3*)
Show[zaq,
ViewPoint->pt];

We have indeed found one of the 120 {3, 5/2}s bounding {3, 5/2, 5}. Now for the rest. Slowly!

(*the 120 polyhedra as sets of faces*)
c3=Table[Select[c1, Abs[ mag[v335[[k]]-cent[#]] - d2[[2]] ]<.001&],
{k,Length[v335]}];

(*the 120 polyhedra as sets of vertices*)
c4=Map[vunion[ Flatten[#,1] ]&, c3];

Have we discovered {3, 5/2, 5}? Let us find the polyhedra sharing a face.

dex=First /@ Position[ c3, c1[[1]] ]

vpt=cent[ c1[[1]] ]
gbas=NullSpace[ {N[vpt]} ](*basis vectors*)

c5=Map[Polygon[#]&, Map[Chop[gbas.#,.000001]&, c3[[dex]], {3}], {2}];

poly=Map[Graphics3D[#]&, c5]

pt=Chop[ gbas.c1[[1,1]],.000001 ]

Show[ poly,
Boxed->False,
ViewPoint->2*unit[pt]];

A further test: find the polyhedra sharing an edge.

p=edgefind[ c3[[1,1]] ];
pcent=cent[ p[[1]] ];
q=Map[edgefind[#]&, c3,{2}];
dex=Union[ First /@ Position[q, p[[1]] ] ]

vpt=pcent;
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[Polygon[#]&, Map[Chop[gbas.#,.000001]&, c3[[dex]], {3}], {2}];
poly=Map[Graphics3D[#]&, c5];
pt=Chop[ gbas.p[[1,1]],.000001 ];(*for ViewPoint*)

e1=Chop[ gbas.#& /@ p[[1]]*1.5,.000001 ](*the common edge*)

(*do not attempt to display more than one of the polyhedra*)
Show[ {Graphics3D[{Thickness[.01],Line[e1]}],poly[[5]]},
ViewPoint->{0,0,-2},
Boxed->False];

We have made several lists:
1. c1, the 1200 triangles of {3, 5/2, 5}.
2. c3, the 120 great icosahedra, as lists of twenty triangles.
3. c4, the 120 great icosahedra, as lists of twelve vertices.

The solid shadows of this star polychoron cannot be displayed using ordinary methods, however, Version 4 of Mathematica supports the experimental, OpenGL-based RealTime3D. This works well on some computers, but causes crashes on others. A polyhedron may be rotated in real time by clicking and dragging with the mouse.

<<RealTime3D`

vpt=Chop[cent[ c1[[1]] ],.000001];(*face-first viewpoint*)
gbas=Chop[NullSpace[ {N[vpt]} ],.000001];(*basis vectors*)

c5=Map[Chop[gbas.#,.000001]&, Flatten[c3, 2], {2}];(*project*)
c6=Graphics3D[Map[Polygon[#]&, c5]];

Show[c6,
Boxed->False,
ViewPoint->{0,-2,1}];

{3, 3, 5/2}

{3, 3, 5/2} is bounded by 120 vertices, 720 edges, 1200 triangles, and 600 tetrahedra.

(*distances from edge midpoint of {5,3,3} to vertices {3,3,5}*)
d=Union[Map[mag[First@vr533-#]&, v335],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many vertices at each distance?*)
d1=Table[Select[v335, Abs[ mag[vr533[[1]] - #]-d[[i]] ]<.001&],
  {i,Length[d]}];
dn=Map[Length,d1];

Print["There are ",Length[vr533]," triangular faces"];
Print["The vertices of {3,3,5} are at ",Length[d]," distances from an edge center of {5,3,3}"];
Print["There are ",dn," vertices at each distance"];
Print["Triangles are found at the ",Flatten[Position[dn,3]]," distances"];

c1=Table[(*find all triangles at 7th distance*)
Select[v335, Abs[ mag[vr533[[k]]-#] - d[[7]] ]<.001&],
{k,Length[vr533]}];

(*distances from a vertex of {5,3,3} to facecenters*)
d2=Union[Map[mag[First@v533-cent[#]]&, c1],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many triangles will be found at each distance?*)
d3=Table[Select[c1, Abs[ mag[v533[[1]]-cent[#] ]-d2[[i]] ]<.001&],
  {i,Length[d2]}];
dn2=Map[Length,d3];

Print["The triangles are at ",Length[d2]," distances from a vertex of {5,3,3}"];
Print["There are ",dn2," triangles at each distance"];

The 1st and 15th distances show four triangles, the number bounding a tetrahedron. We test this.

vpt=v533[[1]];(*center of a triangle set*)
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

(*15th distance gives tetrahedron*)
f1=Select[c1, Abs[ mag[v533[[1]]-cent[#]] - d2[[1]] ]<.001&];
f2=Select[c1, Abs[ mag[v533[[1]]-cent[#]] - d2[[15]] ]<.001&];
zaq1=Graphics3D[ Polygon /@ Map[gbas.#&, f1, {2}] ];
zaq2=Graphics3D[ Polygon /@ Map[gbas.#&, f2, {2}] ];
Show[zaq1];
Show[zaq2];

We have indeed found one of the 600 {3, 3}s bounding {3, 3, 5/2}. Now for the rest. Slowly!

(*the 600 polyhedra as sets of faces*)
c3=Table[Select[c1, Abs[ mag[v533[[k]]-cent[#]] - d2[[15]] ]<.001&],
{k,Length[v533]}];

(*the 600 polyhedra as sets of vertices*)
c4=Map[vunion[ Flatten[#,1] ]&, c3];

Have we discovered {3, 3, 5/2}? Let us find the polyhedra sharing a face.

dex=First /@ Position[ c3, c1[[1]] ]

vpt=cent[ c1[[1]] ];
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[Polygon[#]&, Map[Chop[gbas.#,.000001]&, c3[[dex]], {3}], {2}];
poly=Map[Graphics3D[#]&, c5];
pt=Chop[ gbas.c1[[1,1]],.000001 ];(*ViewPoint*)

Show[ poly,
Boxed->False,
ViewPoint->2*unit[pt]];

A further test: find the polyhedra sharing an edge.

p=edgefind[ c3[[1,1]] ];
pcent=cent[ p[[1]] ];
q=Map[edgefind[#]&, c3,{2}];
dex=Union[ First /@ Position[q, p[[1]] ] ]

vpt=pcent;
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[Polygon[#]&, Map[Chop[gbas.#,.000001]&, c3[[dex]], {3}], {2}];
poly=Map[Graphics3D[#]&, c5];
pt=Chop[ gbas.p[[1,1]],.000001 ](*for ViewPoint*)

e1=Chop[ gbas.#& /@ p[[1]]*2 ](*the common edge*)

Show[ {Graphics3D[Line[e1]],poly},
Boxed->False,
ViewPoint->2*unit[pt]];

We have made several lists:
1. c1, the 1200 triangles of {3, 3, 5/2}.
2. c3, the 600 tetrahedra, as lists of four triangles.
3. c4, the 600 great tetrahedra, as lists of four vertices.

The solid shadows of this star polychoron cannot be displayed using ordinary methods, however, Version 4 of Mathematica supports the experimental, OpenGL-based RealTime3D. This works well on some computers, but causes crashes on others. A polyhedron may be rotated in real time by clicking and dragging with the mouse.

Length[c1]

gbas.c1[[1]]

<<RealTime3D`

vpt=Chop[ v335[[1]],.000001];(*face-first viewpoint*)
gbas=Chop[NullSpace[ {N[vpt]} ]];(*basis vectors*)

c5=Map[Chop[gbas.#,.000001]&, c1, {2}];(*project*)
c6=Graphics3D[Map[Polygon[#]&, c5]];

Show[c6,
Boxed->False,
ViewPoint->{0,-2,2}];

{5, 5/2, 5}

{5, 5/2, 5} is bounded by 120 vertices, 720 edges, 720 pentagons, and 120 great dodecahedra.

(*distances from edge midpoint of {3,3,5} to vertices {3,3,5}*)
d=Union[Map[mag[First@vr335-#]&, v335],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many vertices at each distance?*)
d1=Table[Select[v335, Abs[ mag[vr335[[1]] - #]-d[[i]] ]<.001&],
  {i,Length[d]}];
dn=Map[Length,d1];

Print["There are ",Length[vr335]," pentagonal faces"];
Print["The vertices of {3,3,5} are at ",Length[d]," distances from an edge center of {3,3,5}"];
Print["There are ",dn," vertices at each distance"];
Print["Pentagons are found at the ",Flatten[Position[dn,5]]," distances"];

c1=Table[(*find all pentagons at 2nd distance*)
Select[v335, Abs[ mag[vr335[[k]]-#] - d[[2]] ]<.001&],
{k,Length[vr335]}];

(*distances from a vertex of {3,3,5} to facecenters*)
d2=Union[Map[mag[First@v335-cent[#]]&, c1],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many polygons will be found at each distance?*)
d3=Table[Select[c1, Abs[ mag[v335[[1]]-cent[#] ]-d2[[i]] ]<.001&],
  {i,Length[d2]}];
dn2=Map[Length,d3];

Print["The pentagons are at ",Length[d2]," distances from a vertex of {3,3,5}"];
Print["There are ",dn2," pentagons at each distance"];

The 1st and 4th distances show twelve pentagons, the number bounding a great dodecahedron. We test these.

vpt=v335[[1]];(*center of a pentagon set*)
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

(*1st distance gives great dodecahedron*)
f1=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[1]] ]<.001&];
f2=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[4]] ]<.001&];
p1=Map[ gbas.#&, f1, {2}];
p2=Map[ gbas.#&, f2, {2}];
zaq1=Graphics3D[ Polygon[polysort[#]]& /@ p1 ];
zaq2=Graphics3D[ Polygon[polysort[#]]& /@ p2 ];
Show[zaq1];
Show[zaq2];

We have indeed found one of the 120 {5, 5/2}s bounding {5, 5/2, 5}. Now for the rest. Slowly!

(*the 120 polyhedra as sets of faces*)
c13=Table[Select[c1, Abs[ mag[v335[[k]]-cent[#]] - d2[[1]] ]<.001&],
{k,Length[v335]}];(*unordered polygon vertices*)
c3=Map[polysort[#]&, c13, {2}];(*ordered polygon vertices*)

(*the 120 polyhedra as sets of vertices*)
c4=Map[vunion[ Flatten[#,1] ]&, c3];

Have we discovered {5, 5/2, 5}? Let us find the polyhedra sharing a face.

dex=First /@ Position[ c3, polysort[ c1[[1]] ] ]

vpt=cent[ c1[[1]] ];
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[Polygon[#]&, Map[Chop[gbas.#,.000001]&, c3[[dex]], {3}], {2}];
poly=Map[Graphics3D[#]&, c5];
pt=Chop[ gbas.c1[[1,1]],.000001 ];(*ViewPoint*)

Show[ poly,
Boxed->False,
ViewPoint->2*unit[pt]];

A further test: find the polyhedra sharing an edge.

p=edgefind[ c3[[1,1]] ];
pcent=cent[ p[[1]] ];
q=Map[edgefind[#]&, c3,{2}];
dex=Union[ First /@ Position[q, p[[1]] ] ]

vpt=pcent;
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

qaz=Map[polysort[#]&, c3[[dex]], {2}];
c5=Map[Polygon[#]&, Map[Chop[gbas.#,.000001]&, qaz, {3}], {2}];
poly=Map[Graphics3D[#]&, c5];
pt=Chop[ gbas.p[[1,1]],.000001 ](*for ViewPoint*)

e1=Chop[ gbas.#& /@ p[[1]]*3 ](*the common edge*)

Show[ {Graphics3D[{Thickness[.015],Line[e1]}],poly[[{1,2,3,4,5}]]},
ViewPoint->2*unit[pt]-{-.2,-.2,0},
Boxed->False];

We have made several lists:
1. c1, the 720 pentagons of {5, 5/2, 5}.
2. c3, the 120 great dodecahedra, as lists of twelve pentagons.
3. c4, the 120 great dodecahedra, as lists of twenty vertices.

The solid shadows of this star polychoron cannot be displayed using ordinary methods, however, Version 4 of Mathematica supports the experimental, OpenGL-based RealTime3D. This works well on some computers, but causes crashes on others. A polyhedron may be rotated in real time by clicking and dragging with the mouse.

<<RealTime3D`

vpt=Chop[cent[ c1[[1]] ],.000001];(*face-first viewpoint*)
gbas=Chop[NullSpace[ {N[vpt]} ]];(*basis vectors*)

c5=Map[Chop[gbas.#,.000001]&, Flatten[c3, 2], {2}];(*project*)
c6=Graphics3D[Map[Polygon[#]&, c5]];

Show[c6,
Boxed->False,
ViewPoint->{0,-2,1}];

{5, 3, 5/2}

{5, 3, 5/2} is bounded by 120 vertices, 720 edges, 720 pentagons, and 120 dodecahedra.

(*distances from edge midpoint of {3,3,5} to vertices {3,3,5}*)
d=Union[Map[mag[First@vr335-#]&, v335],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many vertices at each distance?*)
d1=Table[Select[v335, Abs[ mag[vr335[[1]] - #]-d[[i]] ]<.001&],
  {i,Length[d]}];
dn=Map[Length,d1];

Print["There are ",Length[vr335]," pentagonal faces"];
Print["The vertices of {3,3,5} are at ",Length[d]," distances from an edge center of {3,3,5}"];
Print["There are ",dn," vertices at each distance"];
Print["Pentagons are found at the ",Flatten[Position[dn,5]]," distances"];

c1=Table[(*find all pentagons at 2nd distance*)
Select[v335, Abs[ mag[vr335[[k]]-#] - d[[2]] ]<.001&],
{k,Length[vr335]}];

(*distances from a vertex of {3,3,5} to facecenters*)
d2=Union[Map[mag[First@v335-cent[#]]&, c1],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many polygons will be found at each distance?*)
d3=Table[Select[c1, Abs[ mag[v335[[1]]-cent[#] ]-d2[[i]] ]<.001&],
  {i,Length[d2]}];
dn2=Map[Length,d3];

Print["The pentagons are at ",Length[d2]," distances from a vertex of {3,3,5}"];
Print["There are ",dn2," pentagons at each distance"];

The 1st and 4th distances show twelve pentagons, the number bounding a dodecahedron. We test these.

vpt=v335[[1]];(*center of a pentagon set*)
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

(*4th distance gives dodecahedron*)
f1=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[1]] ]<.001&];
f2=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[4]] ]<.001&];
p1=Map[ gbas.#&, f1, {2}];
p2=Map[ gbas.#&, f2, {2}];
zaq1=Graphics3D[ Polygon[polysort[#]]& /@ p1 ];
zaq2=Graphics3D[ Polygon[polysort[#]]& /@ p2 ];
Show[zaq1];
Show[zaq2];

We have indeed found one of the 120 {5, 3}s bounding {5, 3, 5/2}. Now for the rest. Slowly!

(*the 120 polyhedra as sets of faces*)
c13=Table[Select[c1, Abs[ mag[v335[[k]]-cent[#]] - d2[[4]] ]<.001&],
{k,Length[v335]}];(*unordered polygon vertices*)
c3=Map[polysort[#]&, c13, {2}];(*ordered polygon vertices*)

(*the 120 polyhedra as sets of vertices*)
c4=Map[vunion[ Flatten[#,1] ]&, c3];

Have we discovered {5, 3, 5/2}? Let us find the polyhedra sharing a face.

dex=First /@ Position[ c3, polysort[ c1[[1]] ] ]

vpt=cent[ c1[[1]] ];
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[Polygon[#]&, Map[Chop[gbas.#,.000001]&, c3[[dex]], {3}], {2}];
poly=Map[Graphics3D[#]&, c5];
pt=Chop[ gbas.c1[[1,1]],.000001 ];(*ViewPoint*)

Show[ poly,
Boxed->False,
ViewPoint->2*unit[pt]];

A further test: find the polyhedra sharing an edge.

p=edgefind[ c3[[1,1]] ];
pcent=cent[ p[[1]] ];
q=Map[edgefind[#]&, c3,{2}];
dex=Union[ First /@ Position[q, p[[1]] ] ]

vpt=pcent;
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

qaz=Map[polysort[#]&, c3[[dex]], {2}];
c5=Map[Polygon[#]&, Map[Chop[gbas.#,.000001]&, qaz, {3}], {2}];
poly=Map[Graphics3D[#]&, c5];
pt=Chop[ gbas.p[[1,1]],.000001 ](*for ViewPoint*)

e1=Chop[ gbas.#& /@ p[[1]]*3,.000001 ](*the common edge*)

Show[ {Graphics3D[{Thickness[.015],Line[e1]}],poly},
ViewPoint->2*unit[pt]-{-.2,-.2,0},
Boxed->False];

Show[ {Graphics3D[{Thickness[.015],Line[e1]}],poly},
ViewPoint->{-2,-1,0},
Boxed->False];

We have made several lists:
1. c1, the 720 pentagons of {5, 3, 5/2}.
2. c3, the 120 dodecahedra, as lists of twelve pentagons.
3. c4, the 120 dodecahedra, as lists of twenty vertices.

The solid shadows of this star polychoron cannot be displayed using ordinary methods, however, Version 4 of Mathematica supports the experimental, OpenGL-based RealTime3D. This works well on some computers, but causes crashes on others. A polyhedron may be rotated in real time by clicking and dragging with the mouse.

<<RealTime3D`

vpt=Chop[cent[ c1[[1]] ],.000001];(*face-first viewpoint*)
gbas=Chop[NullSpace[ {N[vpt]} ],.000001];(*basis vectors*)

c5=Map[Chop[gbas.#,.000001]&, Flatten[c3, 2], {2}];(*project*)
c6=Graphics3D[Map[Polygon[#]&, c5]];

Show[c6,
Boxed->False,
ViewPoint->{0,-2,1}];

{5, 5/2, 3}

{5, 5/2, 3} is bounded by 120 vertices, 1200 edges, 720 pentagons, and 120 great dodecahedra.

(*distances from edge midpoint of {3,3,5} to vertices {3,3,5}*)
d=Union[Map[mag[First@vr335-#]&, v335],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many vertices at each distance?*)
d1=Table[Select[v335, Abs[ mag[vr335[[1]] - #]-d[[i]] ]<.001&],
  {i,Length[d]}];
dn=Map[Length,d1];

Print["There are ",Length[vr335]," pentagonal faces"];
Print["The vertices of {3,3,5} are at ",Length[d]," distances from an edge center of {3,3,5}"];
Print["There are ",dn," vertices at each distance"];
Print["Pentagons are found at the ",Flatten[Position[dn,5]]," distances"];

c1=Table[(*find all pentagons at 5th distance*)
Select[v335, Abs[ mag[vr335[[k]]-#] - d[[5]] ]<.001&],
{k,Length[vr335]}];

(*distances from a vertex of {3,3,5} to facecenters*)
d2=Union[Map[mag[First@v335-cent[#]]&, c1],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many polygons will be found at each distance?*)
d3=Table[Select[c1, Abs[ mag[v335[[1]]-cent[#] ]-d2[[i]] ]<.001&],
  {i,Length[d2]}];
dn2=Map[Length,d3];

Print["The pentagons are at ",Length[d2]," distances from a vertex of {3,3,5}"];
Print["There are ",dn2," pentagons at each distance"];

The 1st and 4th distances show twelve pentagons, the number bounding a great dodecahedron. We test these.

vpt=v335[[1]];(*center of a pentagon set*)
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

(*4th distance gives great dodecahedron*)
f1=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[1]] ]<.001&];
f2=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[4]] ]<.001&];
p1=Map[ gbas.#&, f1, {2}];
p2=Map[ gbas.#&, f2, {2}];
zaq1=Graphics3D[ Polygon[polysort[#]]& /@ p1 ];
zaq2=Graphics3D[ Polygon[polysort[#]]& /@ p2 ];
Show[zaq1];
Show[zaq2];

We have indeed found one of the 120 {5, 5/2}s bounding {5, 5/2, 3}. Now for the rest. Slowly!

(*the 120 polyhedra as sets of faces*)
c13=Table[Select[c1, Abs[ mag[v335[[k]]-cent[#]] - d2[[4]] ]<.001&],
{k,Length[v335]}];(*unordered polygon vertices*)
c3=Map[polysort[#]&, c13, {2}];(*ordered polygon vertices*)

(*the 120 polyhedra as sets of vertices*)
c4=Map[vunion[ Flatten[#,1] ]&, c3];

Have we discovered {5, 5/2, 3}? Let us find the polyhedra sharing a face.

dex=First /@ Position[ c3, polysort[ c1[[1]] ] ]

vpt=cent[ c1[[1]] ];
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[Polygon[#]&, Map[Chop[gbas.#,.000001]&, c3[[dex]], {3}], {2}];
poly=Map[Graphics3D[#]&, c5];
pt=Chop[ gbas.c1[[1,1]],.000001 ];(*ViewPoint*)

Show[ poly,
Boxed->False,
ViewPoint->2*unit[pt]];

A further test: find the polyhedra sharing an edge.

p=edgefind[ c3[[1,1]] ];
pcent=cent[ p[[1]] ];
q=Map[edgefind[#]&, c3,{2}];
dex=Union[ First /@ Position[q, p[[1]] ] ]

vpt=pcent;
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

qaz=Map[polysort[#]&, c3[[dex]], {2}];
c5=Map[Polygon[#]&, Map[Chop[gbas.#,.000001]&, qaz, {3}], {2}];
poly=Map[Graphics3D[#]&, c5];
pt=Chop[ gbas.p[[1,1]],.000001 ](*for ViewPoint*)

e1=Chop[ gbas.#& /@ p[[1]]*3 ](*the common edge*)

Show[ {Graphics3D[{Thickness[.015],Line[e1]}],poly},
ViewPoint->2*unit[pt]-{-.2,-.2,0},
Boxed->False];

We have made several lists:
1. c1, the 720 pentagons of {5, 5/2, 3}.
2. c3, the 120 great dodecahedra, as lists of twelve pentagons.
3. c4, the 120 great dodecahedra, as lists of twenty vertices.

The solid shadows of this star polychoron cannot be displayed using ordinary methods, however, Version 4 of Mathematica supports the experimental, OpenGL-based RealTime3D. This works well on some computers, but causes crashes on others. A polyhedron may be rotated in real time by clicking and dragging with the mouse.

<<RealTime3D`

vpt=Chop[cent[ c1[[1]] ],.000001];(*face-first viewpoint*)
gbas=Chop[NullSpace[ {N[vpt]} ],.000001];(*basis vectors*)

c5=Map[Chop[gbas.#,.000001]&, Flatten[c3, 2], {2}];(*project*)
c6=Graphics3D[Map[Polygon[#]&, c5]];

Show[c6,
Boxed->False,
ViewPoint->{0,-2,1}];

{5/2, 5, 3}

{5/2, 5, 3} is bounded by 120 vertices, 1200 edges, 720 pentagrams, and 120 small stellated dodecahedra.

(*distances from edge midpoint of {3,3,5} to vertices {3,3,5}*)
d=Union[Map[mag[First@vr335-#]&, v335],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many vertices at each distance?*)
d1=Table[Select[v335, Abs[ mag[vr335[[1]] - #]-d[[i]] ]<.001&],
  {i,Length[d]}];
dn=Map[Length,d1];

Print["There are ",Length[vr335]," pentagram faces"];
Print["The vertices of {3,3,5} are at ",Length[d]," distances from an edge center of {3,3,5}"];
Print["There are ",dn," vertices at each distance"];
Print["Pentagrams are found at the ",Flatten[Position[dn,5]]," distances"];

c1=Table[(*find all pentagrams at 2nd distance*)
polysort[ Select[v335, Abs[ mag[vr335[[k]]-#] - d[[2]] ]<.001&] ],
{k,Length[vr335]}];(*not faceted into pentagrams yet*)

(*distances from a vertex of {3,3,5} to facecenters*)
d2=Union[Map[mag[First@v335-cent[#]]&, c1],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many polygons will be found at each distance?*)
d3=Table[Select[c1, Abs[ mag[v335[[1]]-cent[#] ]-d2[[i]] ]<.001&],
  {i,Length[d2]}];
dn2=Map[Length,d3];

Print["The pentagrams are at ",Length[d2]," distances from a vertex of {3,3,5}"];
Print["There are ",dn2," pentagrams at each distance"];

The 1st and 4th distances show twelve pentagrams, the number bounding a small stellated dodecahedron. We test these.

vpt=v335[[1]];(*center of a pentagon set*)
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

(*1st distance gives small stellated dodecahedron*)
f1=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[1]] ]<.001&];
f2=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[4]] ]<.001&];
p1=Map[ gbas.#&, f1, {2}];
p11=pentagram[#]& /@ p1;
p2=Map[ gbas.#&, f2, {2}];
p22=pentagram[#]& /@ p2;
zaq1=Graphics3D[ Map[Polygon[#]&,p11,{2}] ];
zaq2=Graphics3D[ Map[Polygon[#]&,p22,{2}] ];
Show[zaq1];
Show[zaq2];

We have indeed found one of the 120 {5/2, 5}s bounding {5/2, 5, 3}. Now for the rest. Slowly!

(*the 120 polyhedra as sets of faces*)
c13=Table[Select[c1, Abs[ mag[v335[[k]]-cent[#]] - d2[[1]] ]<.001&],
{k,Length[v335]}];(*ordered pentagon vertices*)
c3=Map[pentagram[#]&, c13, {2}];(*pentagrams as six polygons*)

(*the 120 polyhedra as sets of vertices*)
c4=Map[vunion[ Flatten[#,1] ]&, c13];

Have we discovered {5/2, 5, 3}? Let us find the polyhedra sharing a face.

dex=First /@ Position[ c13, c1[[1]] ]

vpt=cent[ c1[[1]] ];
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[Chop[gbas.#,.000001]&, c3[[dex]], {-2}];
c6=Map[Polygon[#]&, c5, {3}];
poly=Map[Graphics3D[#]&, c6];
pt=Chop[ gbas.c1[[1,1]],.000001 ];(*ViewPoint*)

Show[ poly,
Boxed->False,
ViewPoint->2*unit[pt]];

A further test: find the polyhedra sharing an edge.

p2=Map[#[[{1,3,5,2,4}]]&, c13, {2}];
p3=Map[ Partition[ Join[ #, {First@#} ], 2,1]&, p2, {2}];

p=p3[[1,1]];
pcent=cent[ p[[1]] ];
dex=Union[ First /@ Join[Position[p3, p[[1]] ],Position[p3, Reverse[p[[1]]] ]] ]

vpt=pcent;
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[gbas.#&, c3[[dex]], {-2}];
c6=Map[Polygon[#]&, c5, {3}];
poly=Map[Graphics3D[#]&, c6];(*keep them separate for testing*)
pt=Chop[ gbas.p[[1,1]],.000001 ](*for ViewPoint*)

e1=Chop[ gbas.#& /@ p[[1]]*1.1,.000001 ](*the common edge*)

Show[ {Graphics3D[{Thickness[.015],Line[e1]}],poly[[{1,2,3}]]},
ViewPoint->2*unit[pt],
Boxed->False];

We have made several lists:
1. c1, the 720 pentagrams of {5/2, 5, 3}.
2. c3, the 120 small stellated dodecahedra, as lists of twelve pentagrams, each broken into six Polygons.
3. c4, the 120 small stellated dodecahedra, as lists of twelve vertices.

While the solid shadows of this star polychoron can be displayed using ordinary methods, it should be mentioned that Version 4 of Mathematica supports the experimental, OpenGL-based RealTime3D. This works well on some computers, but causes crashes on others. A polyhedron may be rotated in real time by clicking and dragging with the mouse.

	Because the pentagrams are split into central pentagons with five isosceles triangles, and the pentagons never “show” in a projection (nor in the 4-space!), we can reduce rendering overload by display only the projected triangles. This list is further reduced by discarding degenerate triangles without surface area, and some duplicates.

<<RealTime3D`

(*vertex-first*)
vpt=c4[[1,1]]

(*pentagram edge-first*)
epent=Max@Union[Map[mag[First@c1[[1]]-#]&, Rest@c1[[1]] ],
SameTest->(Chop[#1 - #2,.000001]==0 &)]
vpt=cent[Join[{First@c1[[1]]},
  {First@Select[Rest@c1[[1]],Abs[ mag[First@c1[[1]] - #]-epent ]<.001&]}
 ]
]

(*pentagram-first*)
vpt=cent[ c1[[11]] ]

(*polyhedron-first*)
vpt=cent[ c4[[1]] ]

gbas=Chop[NullSpace[ {N[vpt]} ],.000001];(*basis vectors*)
trias=Select[Flatten[c3,2],Length[#]==3&];
Print["There are ",Length[trias]," isosceles triangles"];
c5=Map[Chop[gbas.#,.000001]&, trias, {-2}];(*project*)
f2=Union[Select[c5, areatest[#]&]];(*discard degenerate (and some duplicate) faces*)
Print["There are ",Length[f2]," undegenerate faces in the projection"];
zaq=Graphics3D[Map[Polygon[#]&, f2]];

Show[zaq,
Boxed->False,
ViewPoint->{0,-2,1}];

{5/2, 5, 5/2}

{5/2, 5, 5/2} is bounded by 120 vertices, 720 edges, 720 pentagrams, and 120 small stellated dodecahedra.

(*distances from edge midpoint of {3,3,5} to vertices {3,3,5}*)
d=Union[Map[mag[First@vr335-#]&, v335],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many vertices at each distance?*)
d1=Table[Select[v335, Abs[ mag[vr335[[1]] - #]-d[[i]] ]<.001&],
  {i,Length[d]}];
dn=Map[Length,d1];

Print["There are ",Length[vr335]," pentagram faces"];
Print["The vertices of {3,3,5} are at ",Length[d]," distances from an edge center of {3,3,5}"];
Print["There are ",dn," vertices at each distance"];
Print["Pentagrams are found at the ",Flatten[Position[dn,5]]," distances"];

c1=Table[(*find all pentagrams at 5th distance*)
polysort[ Select[v335, Abs[ mag[vr335[[k]]-#] - d[[5]] ]<.001&] ],
{k,Length[vr335]}];(*not faceted into pentagrams yet*)

(*distances from a vertex of {3,3,5} to facecenters*)
d2=Union[Map[mag[First@v335-cent[#]]&, c1],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many polygons will be found at each distance?*)
d3=Table[Select[c1, Abs[ mag[v335[[1]]-cent[#] ]-d2[[i]] ]<.001&],
  {i,Length[d2]}];
dn2=Map[Length,d3];

Print["The pentagrams are at ",Length[d2]," distances from a vertex of {3,3,5}"];
Print["There are ",dn2," pentagrams at each distance"];

The 1st and 4th distances show twelve pentagrams, the number bounding a small stellated dodecahedron. We test these.

vpt=v335[[1]];(*center of a pentagon set*)
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

(*4th distance gives small stellated dodecahedron*)
f1=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[1]] ]<.001&];
f2=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[4]] ]<.001&];
p1=Map[ gbas.#&, f1, {2}];
p11=pentagram[#]& /@ p1;
p2=Map[ gbas.#&, f2, {2}];
p22=pentagram[#]& /@ p2;
zaq1=Graphics3D[ Map[Polygon[#]&,p11,{2}] ];
zaq2=Graphics3D[ Map[Polygon[#]&,p22,{2}] ];
Show[zaq1];
Show[zaq2];

We have indeed found one of the 120 {5/2, 5}s bounding {5/2, 5, 5/2}. Now for the rest. Slowly!

(*the 120 polyhedra as sets of faces*)
c13=Table[Select[c1, Abs[ mag[v335[[k]]-cent[#]] - d2[[4]] ]<.001&],
{k,Length[v335]}];(*ordered pentagon vertices*)
c3=Map[pentagram[#]&, c13, {2}];(*pentagrams as six polygons*)

(*the 120 polyhedra as sets of vertices*)
c4=Map[vunion[ Flatten[#,1] ]&, c13];

Have we discovered {5/2, 5, 5/2}? Let us find the polyhedra sharing a face.

dex=First /@ Position[ c13, c1[[1]] ]

vpt=cent[ c1[[1]] ];
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[Chop[gbas.#,.000001]&, c3[[dex]], {-2}];
c6=Map[Polygon[#]&, c5, {3}];
poly=Map[Graphics3D[#]&, c6];
pt=Chop[ gbas.c1[[1,1]],.000001 ];(*ViewPoint*)

Show[ poly,
Boxed->False,
ViewPoint->2*unit[pt]];

A further test: find the polyhedra sharing an edge.

p2=Map[#[[{1,3,5,2,4}]]&, c13, {2}];
p3=Map[ Partition[ Join[ #, {First@#} ], 2,1]&, p2, {2}];

p=p3[[1,1]];
pcent=cent[ p[[1]] ];
dex=Union[ First /@ Join[Position[p3, p[[1]] ],Position[p3, Reverse[p[[1]]] ]] ]

vpt=pcent;
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[gbas.#&, c3[[dex]], {-2}];
c6=Map[Polygon[#]&, c5, {3}];
poly=Map[Graphics3D[#]&, c6];(*keep them separate for testing*)
pt=Chop[ gbas.p[[1,1]],.000001 ](*for ViewPoint*)

e1=Chop[ gbas.#& /@ p[[1]]*1.1,.000001 ](*the common edge*)

(*three of five polyhedra*)
Show[ {Graphics3D[{Thickness[.015],Line[e1]}],poly[[{1,3,5}]]},
ViewPoint->2*unit[pt],
Boxed->False];

We have made several lists:
1. c1, the 720 pentagrams of {5/2, 5, 3}.
2. c3, the 120 small stellated dodecahedra, as lists of twelve pentagrams, each broken into six Polygons.
3. c4, the 120 small stellated dodecahedra, as lists of twelve vertices.

The solid shadows of this star polychoron cannot be displayed using ordinary methods, however, Version 4 of Mathematica supports the experimental, OpenGL-based RealTime3D. This works well on some computers, but causes crashes on others. A polyhedron may be rotated in real time by clicking and dragging with the mouse.

	Because the pentagrams are split into central pentagons with five isosceles triangles, and the pentagons never “show” in a projection (nor in the 4-space!), we can reduce rendering overload by display only the projected triangles. This list is further reduced by discarding degenerate triangles without surface area, and some duplicates.

<<RealTime3D`

(*vertex-first*)
vpt=c4[[1,1]]

(*pentagram edge-first*)
epent=Max@Union[Map[mag[First@c1[[1]]-#]&, Rest@c1[[1]] ],
SameTest->(Chop[#1 - #2,.000001]==0 &)]
vpt=cent[Join[{First@c1[[1]]},
  {First@Select[Rest@c1[[1]],Abs[ mag[First@c1[[1]] - #]-epent ]<.001&]}
 ]
]

(*pentagram-first*)
vpt=cent[ c1[[11]] ]

(*polyhedron-first*)
vpt=cent[ c4[[1]] ]

gbas=Chop[NullSpace[ {N[vpt]} ],.000001];(*basis vectors*)
trias=Select[Flatten[c3,2],Length[#]==3&];
Print["There are ",Length[trias]," isosceles triangles"];
c5=Map[Chop[gbas.#,.000001]&, trias, {-2}];(*project*)
f2=Union[Select[c5, areatest[#]&]];(*discard degenerate (and some duplicate) faces*)
Print["There are ",Length[f2]," undegenerate faces in the projection"];
zaq=Graphics3D[Map[Polygon[#]&, f2]];

Show[zaq,
Boxed->False,
ViewPoint->{0,-2,1}];

{5/2, 3, 5}

{5/2, 3, 5} is bounded by 120 vertices, 1200 edges, 720 pentagrams, and 120 great stellated dodecahedra.

(*distances from edge midpoint of {3,3,5} to vertices {3,3,5}*)
d=Union[Map[mag[First@vr335-#]&, v335],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many vertices at each distance?*)
d1=Table[Select[v335, Abs[ mag[vr335[[1]] - #]-d[[i]] ]<.001&],
  {i,Length[d]}];
dn=Map[Length,d1];

Print["There are ",Length[vr335]," pentagram faces"];
Print["The vertices of {3,3,5} are at ",Length[d]," distances from an edge center of {3,3,5}"];
Print["There are ",dn," vertices at each distance"];
Print["Pentagrams are found at the ",Flatten[Position[dn,5]]," distances"];

c1=Table[(*find all pentagrams at 5th distance*)
polysort[ Select[v335, Abs[ mag[vr335[[k]]-#] - d[[5]] ]<.001&] ],
{k,Length[vr335]}];(*not faceted into pentagrams yet*)

(*distances from a vertex of {3,3,5} to facecenters*)
d2=Union[Map[mag[First@v335-cent[#]]&, c1],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many polygons will be found at each distance?*)
d3=Table[Select[c1, Abs[ mag[v335[[1]]-cent[#] ]-d2[[i]] ]<.001&],
  {i,Length[d2]}];
dn2=Map[Length,d3];

Print["The pentagrams are at ",Length[d2]," distances from a vertex of {3,3,5}"];
Print["There are ",dn2," pentagrams at each distance"];

The 1st and 4th distances show twelve pentagrams, the number bounding a great stellated dodecahedron. We test these.

vpt=v335[[1]];(*center of a pentagon set*)
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

(*1st distance gives great stellated dodecahedron*)
f1=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[1]] ]<.001&];
f2=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[4]] ]<.001&];
p1=Map[ gbas.#&, f1, {2}];
p11=pentagram[#]& /@ p1;
p2=Map[ gbas.#&, f2, {2}];
p22=pentagram[#]& /@ p2;
zaq1=Graphics3D[ Map[Polygon[#]&,p11,{2}] ];
zaq2=Graphics3D[ Map[Polygon[#]&,p22,{2}] ];
Show[zaq1];
Show[zaq2];

We have indeed found one of the 120 {5/2, 3}s bounding {5/2, 3, 5}. Now for the rest. Slowly!

(*the 120 polyhedra as sets of faces*)
c13=Table[Select[c1, Abs[ mag[v335[[k]]-cent[#]] - d2[[1]] ]<.001&],
{k,Length[v335]}];(*ordered pentagon vertices*)
c3=Map[pentagram[#]&, c13, {2}];(*pentagrams as six polygons*)

(*the 120 polyhedra as sets of vertices*)
c4=Map[vunion[ Flatten[#,1] ]&, c13];

Have we discovered {5/2, 3, 5}? Let us find the polyhedra sharing a face.

dex=First /@ Position[ c13, c1[[1]] ]

vpt=cent[ c1[[1]] ];
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[Chop[gbas.#,.000001]&, c3[[dex]], {-2}];
c6=Map[Polygon[#]&, c5, {3}];
poly=Map[Graphics3D[#]&, c6];
pt=Chop[ gbas.c1[[1,1]],.000001 ];(*ViewPoint*)

Show[ poly,
Boxed->False,
ViewPoint->2*unit[pt]];

A further test: find the polyhedra sharing an edge.

p2=Map[#[[{1,3,5,2,4}]]&, c13, {2}];
p3=Map[ Partition[ Join[ #, {First@#} ], 2,1]&, p2, {2}];

p=p3[[1,1]];
pcent=cent[ p[[1]] ];
dex=Union[ First /@ Join[Position[p3, p[[1]] ],Position[p3, Reverse[p[[1]]] ]] ]

vpt=pcent;
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[gbas.#&, c3[[dex]], {-2}];
c6=Map[Polygon[#]&, c5, {3}];
poly=Map[Graphics3D[#]&, c6];(*keep them separate for testing*)
pt=Chop[ gbas.p[[1,1]],.000001 ](*for ViewPoint*)

e1=Chop[ gbas.#& /@ p[[1]]*1.1,.000001 ](*the common edge*)

Show[ {Graphics3D[{Thickness[.015],Line[e1]}],poly[[{1,2,3}]]},
ViewPoint->2*unit[pt],
Boxed->False];

We have made several lists:
1. c1, the 720 pentagrams of {5/2, 5, 3}.
2. c3, the 120 small stellated dodecahedra, as lists of twelve pentagrams, each broken into six Polygons.
3. c4, the 120 small stellated dodecahedra, as lists of twelve vertices.

The solid shadows of this star polychoron cannot be displayed using ordinary methods, however, Version 4 of Mathematica supports the experimental, OpenGL-based RealTime3D. This works well on some computers, but causes crashes on others. A polyhedron may be rotated in real time by clicking and dragging with the mouse.

	Because the pentagrams are split into central pentagons with five isosceles triangles, and the pentagons never “show” in a projection (nor in the 4-space!), we can reduce rendering overload by display only the projected triangles. This list is further reduced by discarding degenerate triangles without surface area, and some duplicates.

<<RealTime3D`

(*vertex-first*)
vpt=c4[[1,1]]

(*pentagram edge-first*)
epent=Max@Union[Map[mag[First@c1[[1]]-#]&, Rest@c1[[1]] ],
SameTest->(Chop[#1 - #2,.000001]==0 &)]
vpt=cent[Join[{First@c1[[1]]},
  {First@Select[Rest@c1[[1]],Abs[ mag[First@c1[[1]] - #]-epent ]<.001&]}
 ]
]

(*pentagram-first*)
vpt=cent[ c1[[11]] ]

(*polyhedron-first*)
vpt=cent[ c4[[1]] ]

gbas=Chop[NullSpace[ {N[vpt]} ],.000001];(*basis vectors*)
trias=Select[Flatten[c3,2],Length[#]==3&];
Print["There are ",Length[trias]," isosceles triangles"];
c5=Map[Chop[gbas.#,.000001]&, trias, {-2}];(*project*)
f2=Union[Select[c5, areatest[#]&]];(*discard degenerate (and some duplicate) faces*)
Print["There are ",Length[f2]," undegenerate faces in the projection"];
zaq=Graphics3D[Map[Polygon[#]&, f2]];

Show[zaq,
Boxed->False,
ViewPoint->{0,-2,1}];

{5/2, 3, 3}

{5/2, 3, 3} is bounded by 600 vertices, 1200 edges, 720 pentagrams, and 120 great stellated dodecahedra.

(*distances from edge midpoint of {3,3,5} to vertices {5,3,3}*)
d=Union[Map[mag[First@vr335-#]&, v533],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many vertices at each distance?*)
d1=Table[Select[v533, Abs[ mag[vr335[[1]] - #]-d[[i]] ]<.001&],
  {i,Length[d]}];
dn=Map[Length,d1];

Print["There are ",Length[vr335]," pentagram faces"];
Print["The vertices of {5,3,3} are at ",Length[d]," distances from an edge center of {3,3,5}"];
Print["There are ",dn," vertices at each distance"];
Print["Pentagrams are found at the ",Flatten[Position[dn,5]]," distances"];

c1=Table[(*find all pentagrams at 13th distance*)
polysort[ Select[v533, Abs[ mag[vr335[[k]]-#] - d[[13]] ]<.001&] ],
{k,Length[vr335]}];(*not faceted into pentagrams yet*)

(*distances from a vertex of {3,3,5} to facecenters*)
d2=Union[Map[mag[First@v335-cent[#]]&, c1],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many pentagrams will be found at each distance?*)
d3=Table[Select[c1, Abs[ mag[v335[[1]]-cent[#] ]-d2[[i]] ]<.001&],
  {i,Length[d2]}];
dn2=Map[Length,d3];

Print["The pentagrams are at ",Length[d2]," distances from a vertex of {3,3,5}"];
Print["There are ",dn2," pentagrams at each distance"];

The 1st and 4th distances show twelve pentagrams, the number bounding a great stellated dodecahedron. We test these.

vpt=v335[[1]];(*center of a pentagon set*)
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

(*4th distance gives great stellated dodecahedron*)
f1=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[1]] ]<.001&];
f2=Select[c1, Abs[ mag[v335[[1]]-cent[#]] - d2[[4]] ]<.001&];
p1=Map[ gbas.#&, f1, {2}];
p11=pentagram[#]& /@ p1;
p2=Map[ gbas.#&, f2, {2}];
p22=pentagram[#]& /@ p2;
zaq1=Graphics3D[ Map[Polygon[#]&,p11,{2}] ];
zaq2=Graphics3D[ Map[Polygon[#]&,p22,{2}] ];
Show[zaq1];
Show[zaq2];

We have indeed found one of the 120 {5/2, 3}s bounding {5/2, 3, 3}. Now for the rest. Slowly!

(*the 120 polyhedra as sets of faces*)
c13=Table[Select[c1, Abs[ mag[v335[[k]]-cent[#]] - d2[[4]] ]<.001&],
{k,Length[v335]}];(*ordered pentagon vertices*)
c3=Map[pentagram[#]&, c13, {2}];(*pentagrams as six polygons*)

(*the 120 polyhedra as sets of vertices*)
c4=Map[vunion[ Flatten[#,1] ]&, c13];

Have we discovered {5/2, 3, 3}? Let us find the polyhedra sharing a face.

dex=First /@ Position[ c13, c1[[1]] ]

vpt=cent[ c1[[1]] ];
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[Chop[gbas.#,.000001]&, c3[[dex]], {-2}];
c6=Map[Polygon[#]&, c5, {3}];
poly=Map[Graphics3D[#]&, c6];
pt=Chop[ gbas.c1[[1,1]],.000001 ];(*ViewPoint*)

Show[ poly,
Boxed->False,
ViewPoint->2*unit[pt]];

A further test: find the polyhedra sharing an edge.

p2=Map[#[[{1,3,5,2,4}]]&, c13, {2}];
p3=Map[ Partition[ Join[ #, {First@#} ], 2,1]&, p2, {2}];

p=p3[[1,1]];
pcent=cent[ p[[1]] ];
dex=Union[ First /@ Join[Position[p3, p[[1]] ],Position[p3, Reverse[p[[1]]] ]] ]

vpt=pcent;
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

c5=Map[gbas.#&, c3[[dex]], {-2}];
c6=Map[Polygon[#]&, c5, {3}];
poly=Map[Graphics3D[#]&, c6];(*keep them separate for testing*)
pt=Chop[ gbas.p[[1,1]],.000001 ](*for ViewPoint*)

e1=Chop[ gbas.#& /@ p[[1]]*1.1,.000001 ](*the common edge*)

Show[ {Graphics3D[{Thickness[.015],Line[e1]}],poly[[{1,2,3}]]},
ViewPoint->2*unit[pt],
Boxed->False];

We have made several lists:
1. c1, the 720 pentagrams of {5/2, 5, 3}.
2. c3, the 120 small stellated dodecahedra, as lists of twelve pentagrams, each broken into six Polygons.
3. c4, the 120 small stellated dodecahedra, as lists of twelve vertices.

The solid shadows of this star polychoron cannot be displayed using ordinary methods, however, Version 4 of Mathematica supports the experimental, OpenGL-based RealTime3D. This works well on some computers, but causes crashes on others. A polyhedron may be rotated in real time by clicking and dragging with the mouse.

	Because the pentagrams are split into central pentagons with five isosceles triangles, and the pentagons never “show” in a projection (nor in the 4-space!), we can reduce rendering overload by display only the projected triangles. This list is further reduced by discarding degenerate triangles without surface area, and some duplicates.

<<RealTime3D`

(*vertex-first*)
vpt=c4[[1,1]]

(*pentagram edge-first*)
epent=Max@Union[Map[mag[First@c1[[1]]-#]&, Rest@c1[[1]] ],
SameTest->(Chop[#1 - #2,.000001]==0 &)]
vpt=cent[Join[{First@c1[[1]]},
  {First@Select[Rest@c1[[1]],Abs[ mag[First@c1[[1]] - #]-epent ]<.001&]}
 ]
]

(*pentagram-first*)
vpt=cent[ c1[[11]] ]

(*polyhedron-first*)
vpt=cent[ c4[[1]] ]

gbas=Chop[NullSpace[ {N[vpt]} ],.000001];(*basis vectors*)
trias=Select[Flatten[c3,2],Length[#]==3&];
Print["There are ",Length[trias]," isosceles triangles"];
c5=Map[Chop[gbas.#,.000001]&, trias, {-2}];(*project*)
f2=Union[Select[c5, areatest[#]&]];(*discard degenerate (and some duplicate) faces*)
Print["There are ",Length[f2]," undegenerate faces in the projection"];
zaq=Graphics3D[Map[Polygon[#]&, f2]];

Show[zaq,
Boxed->False,
ViewPoint->{0,-2,1}];

POV-Ray Export Example

The vertices of nine of the ten star polychora are those of {3,3,5}. We choose a viewpoint in the 4-space, project, and remove duplicate or degenerate elements.  The canonical viewpoints are vertex-, edge-, face-, and polyhedron-first. We have the faces and polyhedra in the lists c3 and c4 respectively. We cannot apply edgevpt to c4; we must instead explicitly construct an edge, taking special care when a pentagram is involved.

Canonical Viewpoints

(*vertex-first*)
vpt=c4[[1,1]]
gbas=NullSpace[ {N[vpt]} ](*basis vectors*)

(*edge-first*)
vpt=cent[ First@edgefind[ c3[[1,1]] ] ]
gbas=NullSpace[ {N[vpt]} ](*basis vectors*)

(*face-first*)
vpt=cent[ c3[[1,1]] ]
gbas=NullSpace[ {N[vpt]} ](*basis vectors*)

(*polyhedron-first*)
vpt=cent[ c4[[1]] ]
gbas=NullSpace[ {N[vpt]} ](*basis vectors*)

(*pentagram edge-first*)
epent=Max@Union[Map[mag[First@c1[[1]]-#]&, Rest@c1[[1]] ],
SameTest->(Chop[#1 - #2,.000001]==0 &)]
vpt=cent[Join[{First@c1[[1]]},
  {First@Select[Rest@c1[[1]],Abs[ mag[First@c1[[1]] - #]-epent ]<.001&]}
 ]
]

(*pentagram face-first*)
vpt=cent[ c1[[1]] ]
gbas=NullSpace[ {N[vpt]} ](*basis vectors*)

Projection

Polyhedron-first projection.

(*polyhedron-first*)
vpt=cent[ c4[[1]] ]
gbas=NullSpace[ {N[vpt]} ](*basis vectors*)

v1=Map[gbas.#&, v335];(*projected vertices; use v533 if {5/2,3,3}*)
v2=vunion[v1];
Print["There are ",Length[v2]," distinct vertices in the projection"];

ed=Union[Map[mag[First@c1[[1]]-#]&, Rest@c1[[1]] ],
SameTest->(Chop[#1 - #2,.000001]==0 &)]

(*if not pentagram, ed[[1]], else ed[[2]]*)
e1=edgespan[ v533, ed[[2]] ];(*v335 if not {5/2,3,3}*)
Print["There are ",Length[e1]," edges altogether"];

e11=Map[gbas.#&, e1,{2}];
e12=Select[e11, Chop[ mag[ #[[2]]-#[[1]] ],.000001 ]>0&];(*discard degenerate edges*)
Print["There are ",Length[e12]," undegenerate edges in the projection"];
q1=Map[{cent[#],#}&,e12];
e13=Union[q1,SameTest->((Sign[#1[[1]]]==Sign[#2[[1]]]) && (Chop[#1[[1]]-#2[[1]],.000001]=={0,0,0}) &)];
Print["There are ",Length[e13]," distinct edges in the projection"];
e2=Flatten[Map[Rest[#]&, e13],1];

(*for triangles and pentagons only*)
f11=Map[gbas.#&, c1,{2}];
f12=Select[f11, areatest[#]&];(*discard degenerate faces*)
Print["There are ",Length[f12]," undegenerate faces in the projection"];
q2=Map[{cent[#],#}&,f12];
f13=Union[q2,SameTest->((Sign[#1[[1]]]==Sign[#2[[1]]]) && (Chop[#1[[1]]-#2[[1]],.000001]=={0,0,0}) &)];
Print["There are ",Length[f13]," distinct faces in the projection"];
f2=Flatten[Map[Rest[#]&, f13],1];

(*for pentagrams only*)
f11=Map[gbas.#&, c1,{2}];(*project circumscribing pentagons*)
f12=Select[f11, areatest[#]&];(*discard degenerate faces*)
Print["There are ",Length[f12]," undegenerate faces in the projection"];
q2=Map[{cent[#],#}&,f12];
f13=Union[q2,SameTest->((Sign[#1[[1]]]==Sign[#2[[1]]]) && (Chop[#1[[1]]-#2[[1]],.000001]=={0,0,0}) &)];
Print["There are ",Length[f13]," distinct faces in the projection"];
f14=Flatten[Map[Rest[#]&, f13],1];

dex=Flatten[ Map[First@Position[f11,#]&, f14] ];(*indices of distinct faces*)
f15=Map[pentagram[#]&, c1];(*make pentagrams*)
f16=Map[gbas.#&, f15, {-2}];(*project*)
f2=Flatten[ f16[[dex]], 1];(*final list*)
Print["There are ",Length[f2]," pentagram pieces in the projection"];

We have three lists:
1. v2: distinct projected vertices.
2. e2: distinct and undegenerate projected edges.
3. f2: distinct and undegenerate projected faces.

We shall write POV spheres, cylinders, and triangles for the vertices, edges, and faces.

(*assemble POV spheres, cylinders, triangles, in lists*)
f1=Map[toTriangles[#]&, f2 ];
q1=Map[Ball[#,R1]&,Chop[v2,.000001]];
q2=Map[Rod[#,R2]&,Chop[e2,.000001]];
balls=ColumnForm[Map[ballmake["sphere",# ]&,q1],Left];
sticks=ColumnForm[Map[cyllmake["cylinder",# ]&,q2],Left];
faces=ColumnForm[Map[facemake["triangle",# ]&,Chop[Flatten[f1,1],.000001]],Left];

SetDirectory["Macintosh HD:Desktop Folder:"]

strm=OpenWrite["face{5/2,3,3}.inc",
FormatType->OutputForm,
PageWidth->Infinity];
Write[strm,"#declare RODS = union{"];
Write[strm,sticks];
Write[strm,"}"];
Write[strm,"#declare BALLS = union{"];
Write[strm,balls];
Write[strm,"}"];
Write[strm,"#declare FACES = union{"];
Write[strm,faces];
Write[strm,"}"];
Close[strm]

Sample Scene File

#version 3.0
#include "colors.inc"
#include "shapes.inc"
#include "glass.inc"
#include "metals.inc"
#include "textures.inc"

#default { texture { pigment {color White} finish {phong 0.01 ambient 0.1 diffuse 0.6} }}

global_settings {
	assumed_gamma 1.8
	max_trace_level 5
}


camera {
	location <2, -7, 7>
	direction <0, 2, 0>
	up <0, 0, 1>
	right <4/4, 0, 0>//square aspect ratio
	sky <0., 0., 1>
	look_at <0, 0, 0>
}

light_source { 
	<0, 0, 100>
	color rgb <.7, .7, .7>
//shadowless
}

light_source { 
	<12, -12, 20>
	color rgb <.7, .7, .2>
//shadowless
}

//light_source { <0, 0, 0> color rgb <1, 1, 1>}

#declare R1 =.015 //spheres
#declare R2 =.01  //cylinders

#include "shadow{3,3,5/2}.inc" //give the name of the file

object{RODS texture {
    pigment { Silver1_Colour }
    finish {
        metallic
        ambient 0.4
        diffuse 0.35
        specular 0.85
        roughness 0.01
        reflection 0.05
        brilliance 1.5
    }
}
}
object{BALLS texture{Gold_Metal}}


object{FACES}


plane{z, -4
pigment  {
	hexagon 
	color rgb < 0.7, 0.7, 1 > ,
	color rgb < .5, .5, 1 > ,
	color rgb < 0, 0, 0.5 > 
rotate<90,0,0>}

}

sky_sphere  {
	pigment  {
		color rgb < 0.889998, 0.623011, 0.863340 > 
	}

}

Solid Sections of Star Polytopes

Introduction

The construction of solid sections of star polychora seemed well beyond reach, as I brought the first version of this notebook to a finished state in late September of 1999. Since the sections themselves would often be star polyhedra, or more properly, non-convex polyhedra, ConvexHull3D could never be used. However, as so often is the case, intractable problems can be solved by breaking them into smaller chunks. This is quite literally the approach followed below, with slight variations according to whether the star polychoron is bounded by convex polyhedra, or by star polyhedra with convex faces, or by star polyhedra with star faces (pentagrams, in all these cases).

	In May 2000 I revised and simplified all sectioning methods in this notebook. The new methods are somewhat faster.

	One must first construct the star polychoron, in the “Solid Shadows of Star Polychora” section above. The construction must be followed through until the two lists, c3 and c4, are obtained. These are the cells as lists of faces (c3) and the cells as lists of vertices (c4).

	The essential idea is to break the star polychoron into convex polyhedral chunks and then, for any given distance from the origin, find the convex polygon sections of each of these convex polyhedra. This is especially easy when the star polychoron is bounded by convex polyhedra, for then the cells themselves are the chunks. This method can be applied to {3, 3, 5/2}, {3, 5, 5/2}, and {5, 3, 5/2}.
	
	When the star polychoron is bounded by star polyhedra with convex faces, each such face is made the base of a pyramid with a common apex at the center of the star polyhedron. Then plane sections are found for each of these pyramids. This method can be applied to {3, 5/2, 5}, {5, 5/2, 5}, and {5, 5/2, 3}.
	
	When the star polychoron is bounded by star polyhedra bounded by pentagrams, each pentagram is split into a pentagon and five isosceles triangles, and each of these becomes the base of a pyramid with a common apex at the center of the cell. Thus thousands of convex polyhedra must be sectioned for each particular distance. This method can be applied to {5/2, 5, 5}, {5/2, 5, 3}, {5/2, 5, 5/2}, and {5/2, 3, 3}.
	
	It should be noted that simpler ways to break such star polychora into convex polyhedral chunks exist. Perhaps in a future version of this notebook such methods will be implemented.
	
	The actual construction of the sections is one thing, their display another. If and only if Mathematica's RealTime3D works on your computer, a particular section may be displayed and rotated in real time. Otherwise, one must export to POV-Ray. Examples are provided of creating animations in POV-Ray of a series of sections going all the way through the star polychoron. No attempt is made here to obtain sections orthogonal to an arbitrary vector in the 4-space; they are all taken orthogonal to the vector {0,0,0,1}. With the ordinary coordinates provided for {3, 3, 5} and {5, 3, 3}, the sections obtained have icosahedral symmetry. The POV-Ray animations depend upon the writing of an #include file for each section. In the example 99 such files are written for 99 animation frames. I am only familiar with the Macintosh port of POV-Ray, in which such an animation can be saved directly to QuickTime format. One sets the animation “clock” to run from 1 to 99, and also the frame count. On my computer it takes a couple hours to write the 99 #include files, and a couple of hours to make a 300-pixel-square animation. The result is a lovely morphing of star polyhedra. I particularly recommend {3, 3, 5/2} as a place to begin.
	
	The one star polychoron for which special treatment is required is {5/2, 3, 3}, which is the only one with the vertices of {5, 3, 3} (the others all having the vertices of {3, 3, 5}. The circumradius of {5, 3, 3} is Sqrt[8] or about 2.8, while the circumradius of {3, 3, 5} is 2. Thus the sectioning distances in the loop which creates the #include files must be modified for this one case. It would make more sense to scale {5/2, 3, 3} down to have the same circumradius, perhaps in a future version of this notebook, this will be effected.

Convex Cell Method

Construct One Section

One must first construct the star polytope in the “Solid Shadows” section above!

Note: the vertex-first sections have icosahedral symmetry. Any non-zero vector in the 4-space can be used for vpt.

vpt=c4[[1,1]](*vertex-first*)

vpt=cent[c4[[1]]](*cell-first*)

vpt=cent[{c3[[1,1,2]],c3[[1,1,1]]}](*edge-first*)

vpt=cent[c3[[1,1]]](*face-first*)

basis=NullSpace[ {N[ vpt ]} ](*basis vectors*)
h=Max[Map[ptspace[#, unit[vpt], 0]&, v335] ](*what distance to begin sections?*)

(*make the edges of all convex polyhedra*)
cellsegs=Map[edgefind[#]&, c4];

dist=0;(*set section distance*)

sects=
Table[
  pts4=Cases[Map[section[#, dist, unit[vpt] ]&, cellsegs[[i]] ],
     {_,_,_,_}, Infinity];
  pts3=vunion[ Map[ Chop[Dot[ basis, # ],.000001]&, pts4] ];(*project*);
  If[Length[pts3]>2, Polygon[ convexhull2D[pts3] ] ],
  {i,Length[cellsegs]}];
zaq=Graphics3D[Cases[sects,Polygon[x_],Infinity]];

<<RealTime3D`

(*if and only if RealTime3D works on your computer*)
Show[zaq,
Boxed->False];

Export Animation to POV-Ray

Of course, one must first have constructed the star polytope, before its sections can be found and exported. Next, create a directory to which to write the POV #include files, and tell Mathematica where it is. Choose a vpt (the vector perpendicular to the sectioning 3-space) and choose the number of sections to be found and written to disk; note that the default is 99. A sample POV scene file is appended below.

(*where to write the POV #include files*)
SetDirectory["Macintosh HD:Desktop Folder:test sections"]

Choose a Symmetry Axis

Note: the vertex-first sections have icosahedral symmetry. Any non-zero vector in the 4-space may be chosen; those below give the most symmetrical sections.

vpt=c4[[1,1]](*vertex-first*)

vpt=cent[c4[[1]]](*cell-first*)

vpt=cent[{c3[[1,1,2]],c3[[1,1,1]]}](*edge-first*)

vpt=cent[c3[[1,1]]](*face-first*)

basis=NullSpace[ {N[ vpt ]} ](*basis vectors*)
h=Max[Map[ptspace[#, unit[vpt], 0]&, v335] ](*what distance to begin sections?*)
numframes=99 (*how many frames, starting just inside outermost point*)
hemi=(numframes+1)/2 (*how many frames to central section*)
denom=(numframes+1)/(h*2)

(*make the edges of all convex polyhedra*)
cellsegs=Map[edgefind[#]&, c4];

Do[
dist=(j-hemi)/denom;

sects=
Table[
  pts4=Cases[Map[section[#, dist, unit[vpt] ]&, cellsegs[[i]] ],
     {_,_,_,_}, Infinity];
  pts3=vunion[ Map[ Chop[Dot[ basis, # ],.000001]&, pts4] ];(*project*);
  If[Length[pts3]>2, Polygon[ convexhull2D[pts3] ] ],
{i,Length[cellsegs]}];

poly=Cases[sects,Polygon[x_]:>x,Infinity];
f1=Map[Chop[toTriangles[#],.000001]&, poly];
faces=ColumnForm[Map[facemake["triangle",# ]&,
	Chop[Flatten[f1,1],.000001]],Left];

strm=OpenWrite[StringJoin["section",ToString[j],".inc"],
FormatType->OutputForm,
PageWidth->Infinity];
Write[strm,"#declare STAR = union{"];
Write[strm,faces];
Write[strm,"}"];
Close[strm],
{j,numframes}]

Triangle-Pentagon  Method

Construct One Section

One must first construct the star polytope in the “Solid Shadows” section above!

Note: the vertex-first sections have icosahedral symmetry. Any non-zero vector in the 4-space can be used for vpt.

vpt=c4[[1,1]](*vertex-first*)

vpt=cent[c4[[1]]](*cell-first*)

vpt=cent[{c3[[1,1,2]],c3[[1,1,1]]}](*edge-first*)

vpt=cent[c3[[1,1]]](*face-first*)

basis=NullSpace[ {N[ vpt ]} ](*basis vectors*)
h=Max[Map[ptspace[#, unit[vpt], 0]&, v335] ](*maximum distance to take section*)

(*make the edges of all solid pieces*)
cellsegs=Flatten[Table[
a=Map[edgefind[#]&, c3[[j]] ];
Table[
Join[a[[k]],Map[{cent[c4[[j]]],#}&, vunion[Flatten[a[[k]],1]] ]],
{k,Length[a]}],
{j,Length[c4]}],1];

Length[cellsegs](*how many chunks?*)

dist=0;(*set section distance*)

sects=
Table[
  pts4=Cases[Map[section[#, dist, unit[vpt] ]&, cellsegs[[i]] ],
     {_,_,_,_}, Infinity];
  pts3=vunion[ Map[ Chop[Dot[ basis, # ],.000001]&, pts4] ];(*project*);
  If[Length[pts3]>2, Polygon[ convexhull2D[pts3] ] ],
  {i,Length[cellsegs]}];
zaq=Graphics3D[Cases[sects,Polygon[x_],Infinity]];

<<RealTime3D`

(*If and only if RealTime3D works on your computer!*)
Show[zaq,
Boxed->False];

Export Animation to POV-Ray

Of course, one must first have constructed the star polytope, before its sections can be found and exported. Next, create a directory to which to write the POV #include files, and tell Mathematica where it is. Choose a vpt (the vector perpendicular to the sectioning 3-space) and choose the number of sections to be found and written to disk; note that the default is 99. A sample POV scene file is appended below.

(*where to write the POV #include files*)
SetDirectory["Macintosh HD:Desktop Folder:test sections"]

Choose a Symmetry Axis

Note: the vertex-first sections have icosahedral symmetry. Any non-zero vector in the 4-space may be chosen; those below give the most symmetrical sections.

vpt=c4[[1,1]](*vertex-first*)

vpt=cent[c4[[1]]](*cell-first*)

vpt=cent[{c3[[1,1,2]],c3[[1,1,1]]}](*edge-first*)

vpt=cent[c3[[1,1]]](*face-first*)

basis=NullSpace[ {N[ vpt ]} ](*basis vectors*)
h=Max[Map[ptspace[#, unit[vpt], 0]&, v335] ](*what distance to begin sections?*)
numframes=99 (*how many frames, starting just inside outermost point*)
hemi=(numframes+1)/2 (*how many frames to central section*)
denom=(numframes+1)/(h*2)

(*make the edges of all solid pieces*)
cellsegs=Flatten[Table[
a=Map[edgefind[#]&, c3[[j]] ];
Table[
Join[a[[k]],Map[{cent[c4[[j]]],#}&, vunion[Flatten[a[[k]],1]] ]],
{k,Length[a]}],
{j,Length[c4]}],1];

Length[cellsegs](*how many chunks?*)

Do[
dist=(j-hemi)/denom;

sects=
Table[
  pts4=Cases[Map[section[#, dist, unit[vpt] ]&, cellsegs[[i]] ],
     {_,_,_,_}, Infinity];
  pts3=vunion[ Map[ Chop[Dot[ basis, # ],.000001]&, pts4] ];(*project*);
  If[Length[pts3]>2, Polygon[ convexhull2D[pts3] ] ],
{i,Length[cellsegs]}];

poly=Cases[sects,Polygon[x_]:>x,Infinity];
f1=Map[Chop[toTriangles[#],.000001]&, poly];
faces=ColumnForm[Map[facemake["triangle",# ]&,
	Chop[Flatten[f1,1],.000001]],Left];

strm=OpenWrite[StringJoin["section",ToString[j],".inc"],
FormatType->OutputForm,
PageWidth->Infinity];
Write[strm,"#declare STAR = union{"];
Write[strm,faces];
Write[strm,"}"];
Close[strm],
{j,numframes}]

Pentagram Method

Construct One Section of Pentagrammic Star Polychoron

One must first construct the star polytope in the “Solid Shadows” section above!

Note: the vertex-first of all others, but cell-first sections of {5/2, 3, 3}, have icosahedral symmetry. Any non-zero vector in the 4-space can be used for vpt.

vpt=c4[[1,1]](*vertex-first*)

vpt=cent[c4[[1]]](*cell-first*)

vpt=cent[{c13[[1,1,3]],c13[[1,1,1]]}](*edge-first*)

vpt=cent[c13[[1,1]]](*face-first*)

basis=NullSpace[ {N[ vpt ]} ](*basis vectors*)
h=Max[Map[ptspace[#, unit[vpt], 0]&, v533] ](*what distance to begin sections?*)

dist=0;(*set section distance*)

zaq=Graphics3D[
Flatten[Table[
   pents=Select[Flatten[Chop[c3[[n]],.000001],1],Length[#]==5&];
   trias=Select[Flatten[Chop[c3[[n]],.000001],1],Length[#]==3&];
   q1=Join[ Map[edgefind[#]&, pents],Map[toedges[#]&, trias] ];

    pyramids=Table[
    Join[q1[[k]],Map[{cent[c4[[n]]],#}&, vunion[Flatten[q1[[k]],1]] ]],
    {k,Length[q1]}];

    sects=Table[
    pts4=Cases[Map[section[#, dist, unit[vpt] ]&, pyramids[[i]] ],
     {_,_,_,_}, Infinity];
    pts3=vunion[ Map[ Chop[Dot[ basis, # ],.000001]&, pts4] ];(*project*);
    If[Length[pts3]>2, Polygon[ convexhull2D[pts3] ] ],
    {i,Length[pyramids]}];

   Cases[sects,Polygon[x_],Infinity],
  {n,Length[c4]}],1]
];(*end Graphics3D*)

<<RealTime3D`

(*if and only if RealTime3D works on your computer*)
Show[zaq,
Boxed->False];

Export Animation to POV-Ray

Of course, one must first have constructed the star polytope, before its sections can be found and exported. Next, create a directory to which to write the POV #include files, and tell Mathematica where it is. Choose a vpt (the vector perpendicular to the sectioning 3-space) and choose the number of sections to be found and written to disk; note that the default is 99. A sample POV scene file is appended below.

(*where to write the POV #include files*)
SetDirectory["Macintosh HD:Desktop Folder:test sections"]

Choose a Symmetry Axis

Note: the vertex-first of all others, but cell-first sections of {5/2, 3, 3}, have icosahedral symmetry. Any non-zero vector in the 4-space may be chosen; those below give the most symmetrical sections.

(*which set of vertices?*)
verts=v335;(*v533 if {5/2,3,3}*)

vpt=c4[[1,1]](*vertex-first*)

vpt=cent[c4[[1]]](*cell-first*)

vpt=cent[{c13[[1,1,3]],c13[[1,1,1]]}](*edge-first*)

vpt=cent[c13[[1,1]]](*face-first*)

basis=NullSpace[ {N[ vpt ]} ](*basis vectors*)
h=Max[Map[ptspace[#, unit[vpt], 0]&, verts] ](*what distance to begin sections?*)
numframes=99 (*how many frames, starting just inside outermost point*)
hemi=(numframes+1)/2 (*how many frames to central section*)
denom=(numframes+1)/(h*2)

Do[
dist=(j-hemi)/denom;

  zaq=Flatten[Table[
   pents=Select[Flatten[Chop[c3[[n]],.000001],1],Length[#]==5&];
   trias=Select[Flatten[Chop[c3[[n]],.000001],1],Length[#]==3&];
   q1=Join[ Map[edgefind[#]&, pents],Map[toedges[#]&, trias] ];

    pyramids=Table[
    Join[q1[[k]],Map[{cent[c4[[n]]],#}&, vunion[Flatten[q1[[k]],1]] ]],
    {k,Length[q1]}];

    sects=Table[
    pts4=Cases[Map[section[#, dist, unit[vpt] ]&, pyramids[[i]] ],
     {_,_,_,_}, Infinity];
    pts3=vunion[ Map[ Chop[Dot[ basis, # ],.000001]&, pts4] ];(*project*);
    If[Length[pts3]>2, Polygon[ convexhull2D[pts3] ] ],
    {i,Length[pyramids]}];

   Cases[sects,Polygon[x_]:>x,Infinity],
  {n,Length[c4]}],1];


f1=Map[Chop[toTriangles[#]]&, zaq];
faces=ColumnForm[Map[facemake["triangle",# ]&,
	Chop[Flatten[f1,1],.000001]],Left];

strm=OpenWrite[StringJoin["vertsect",ToString[j],".inc"],
FormatType->OutputForm,
PageWidth->Infinity];
Write[strm,"#declare STAR = union{"];
Write[strm,faces];
Write[strm,"}"];
Close[strm],
{j,numframes}]

Sample Scene File for POV Animation

/*sample scene file to make animation from #include files written by Mathematica*/
/*set POV clock to run from 1 to 119, also POV frame count*/
#version 3.0
#include "colors.inc"
#include "shapes.inc"
#default { texture { pigment {color White} finish {phong 0.001 ambient 0.2 diffuse 0.6} }}

global_settings {
	assumed_gamma 1.8
	max_trace_level 5
}

camera {
	location  <4, -8, 6>
	direction <0, 2, 0>
	up        <0, 0, 1>
	right     <4/4, 0, 0> //aspect ratio, w:h
	sky       <0, 0, 1>
	look_at   <0, 0, 0>
 }

light_source {
	<0, 0, 1000>
	color rgb <.5, .5, .5>
	//shadowless
}

light_source {
	<6, -4, 7>
	color rgb <.5, .5, .5>
	//shadowless
}

light_source {
	<-6, -4, 7>
	color rgb <.5, .5, .5>
	//shadowless
}

/*set POV clock to run from 1 to numframes, also POV frame count*/
#declare NAM = concat("section",str(clock,1,0),".inc") 
/* replace "clock" with a number between 1 and numframes for testing*/

#include NAM

object{STAR
rotate<0,0,clock*2>}//rotate each section a little

The Great Prismosaurus

The Great Prismosaurus is one of many uniform star polychora with the vertices of {3,3,5}. It is bounded by 720 Archimedean pentagonal prisms which intersect one another severely. After finding all 720 prisms, a method is provided to construct a solid shadow, and display using the OpenGL rendering engine. Farther below, export of solid star-polyhedral sections to POV-Ray is offered.

vr335=rectify[v335];(*edge midpoints of {3,3,5}*)

(*distances from edge midpoint of {3,3,5} to vertices {3,3,5}*)
d=Union[Map[mag[First@vr335-#]&, v335],
SameTest->(Chop[#1 - #2,.000001]==0 &)];

(*how many vertices at each distance?*)
d1=Table[Select[v335, Abs[ mag[vr335[[1]] - #]-d[[i]] ]<.001&],
  {i,Length[d]}];
dn=Map[Length,d1];

Print["There are ",Length[vr335]," pentagonal prisms"];
Print["The vertices of {3,3,5} are at ",Length[d]," distances from an edge center of {3,3,5}"];
Print["There are ",dn," vertices at each distance"];
Print["Pentagonal prisms are found at the ",Flatten[Position[dn,10]]," distances"];

c1=Table[(*8th distance gives equilateral right regular prisms*)
Select[v335, Abs[ mag[vr335[[k]]-#] - d[[8]] ]<.001&],
{k,Length[vr335]}];

If an OpenGL rendering environment is available, we can view the shadows directly; below the shadow is taken vertex-first, and hidden detail is removed to reduce length of computation.

vpt=v335[[1]];(*vertex-first*)
gbas=NullSpace[ {N[vpt]} ];(*basis vectors*)

b1=Select[c1, Chop[Dot[vpt,cent[#]],.000001]>0&];
Print["There are ",Length[b1]," visible polyhedra"];

zaq=(*make all projected visible cells*)
Table[
r=Map[ Dot[ gbas, # ]&, b1[[ i ]] ];
ConvexHull3D[r],
{i,Length[b1]}];
(*Show one prism*)
Show[ Graphics3D[ zaq[[1]] ] ];

(*Invoke Mathematica's experimental OpenGL engine*)
<<RealTime3D`

Show[Graphics3D[zaq],
Boxed->False];

Export animation sequence to POV-Ray

By using convexhull2D, we can find the solid sections of the Great Prismosaurus. The same method extends to any polychoron bounded by convex polyhedra, in which we have found the edges of each cell. The intersections of edges with a 3-space give, not a convex polyhedron, but a convex polygon. By finding all such polygons for each sectioning 3-space we find the star-polyhedral sections. Here the sections are taken vertex-first, thus they have icosahedral symmetry.

	For each section a POV #include file is written. In the example below 99 sections are found and 99 #include files are written. A POV scene file which calls these files one by one to make the animation may be found in the “Solid Sections of Star Polytopes” section. To actually make the animation one should set the POV “clock” and “frames” alike to run from 1 to 99. On a fairly fast computer, rendering to 600 pixels square, the animation required 27 hours to make, and the resulting QuickTime movie measured more than 50 MB in size. The result is a morphing of star polyhedra which grow incredibly complicated as the central section is approached.

vpt=v335[[1]]

basis=NullSpace[ {N[ vpt ]} ](*basis vectors*)
h=Max[Map[ptspace[#, unit[vpt], 0]&, v335] ](*what distance to begin sections?*)
numframes=9 (*how many frames, starting just inside outermost point*)
hemi=(numframes+1)/2 (*how many frames to central section*)
denom=(numframes+1)/(h*2)

cellsegs=Map[edgefind[#]&, c1];(*find edges each prism*)

(*where to write the POV #include files*)
SetDirectory["Macintosh HD:Desktop Folder:prismosaurus"]

Do[
dist=(j-hemi)/denom;

sects=
Table[
  pts4=Cases[Map[section[#, dist, unit[vpt] ]&, cellsegs[[i]] ],
     {_,_,_,_}, Infinity];
  pts3=vunion[ Map[ Chop[Dot[ basis, # ],.000001]&, pts4] ];(*project*);
  If[Length[pts3]>2, Polygon[ convexhull2D[pts3] ] ],
{i,Length[cellsegs]}];

poly=Cases[sects,Polygon[x_]:>x,Infinity];
f1=Map[Chop[toTriangles[#],.000001]&, poly];
faces=ColumnForm[Map[facemake["triangle",# ]&,
	Chop[Flatten[f1,1],.000001]],Left];

strm=OpenWrite[StringJoin["section",ToString[j],".inc"],
FormatType->OutputForm,
PageWidth->Infinity];
Write[strm,"#declare STAR = union{"];
Write[strm,faces];
Write[strm,"}"];
Close[strm],
{j,numframes}]

Credits

Dr. Wouter Meeussen wrote the ConvexHull3D function.
w.meeussen.vdmcc@vandemoortele.be

George Olshevsky offered considerable encouragement and crucial insights into the convex polychora. He was my constant guide and arbiter of the correctness (or incorrectness) of my results, throughout the development of this notebook. See his Uniform Polytopes web site at <http://hometown.aol.com/Polycell/uniform.html>.

Richard Koch provided a special rotation matrix. See his homepage at <http://darkwing.uoregon.edu/~koch/> for a Java app which projects the six convex regular polychora.

George Beck offered help from the beginning, in 1997. In particular, he crafted a concise version of the zonotope function, and offered insight on basis vectors. In April 2000 George vastly improved upon my sectioning function.

Martin Kraus showed how NullSpace could be used to find basis vectors, and helped sort out problems with finding a polyhedron’s cross product. See his homepage at <http://wwwvis.informatik.uni-stuttgart.de/~kraus/index.html>.

Carl Woll wrote a much much faster vector union function (vunion), in April 2000.

Eric Weisstein provided beta-testing and identifed a number of problems to correct and possibilities to explore. His remarkable encyclopedia of mathematics is at <http://www.treasure-troves.com/>.

I obtained the rotation matrices from a fascinating thesis written by Steven Hollasch, found online at <http://research.microsoft.com/~hollasch/thesis/>.

Of course, Professor H.S.M. Coxeter inspired this notebook, in which so much was drawn directly from his Regular Polytopes(Dover, 1973). For a sketch of his life, see <http://www.math.toronto.edu/~coxeter/>.