Community RSS Feed
http://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Geometry sorted by active[GIF] Double Projection (Projected rotating 16-cell)
http://community.wolfram.com/groups/-/m/t/1525648
![Projected rotating 16-cell][1]
**Double Projection**
This is a similar idea to [_J34_][3]: starting with the vertices of the 16-cell (a.k.a. cross polytope, a.k.a. orthoplex) and thinking of them as points on the 3-sphere, I'm applying a rotation, then projecting down to the 2-sphere using the [Hopf map][4]. From there, the difference from _J34_ is that I'm taking those points on the 2-sphere, forming a spherical disk of radius 0.4, then stereographically projecting down to the plane (this last step uses the `ProjectedSphericalCircle[]` function from [_Small Changes_][5] which, given the center and radius of a disk on the sphere, outputs a `Disk[]` in the plane which is its stereographic image).
First of all, we need the Hopf map and the [smootherstep function][6]:
Hopf[{x_, y_, z_, w_}] := {x^2 + y^2 - z^2 - w^2, 2 y z - 2 w x, 2 w y + 2 x z};
smootherstep[t_] := 6 t^5 - 15 t^4 + 10 t^3;
And the vertices of the 16-cell:
sixteencellvertices =
Normalize /@
Flatten[Permutations[{-1, 0, 0, 0}]^# & /@ Range[1, 2], 1];
And then this is the animation code:
With[{pts = Normalize /@ sixteencellvertices, viewpoint = 2 {1, 0, 0},
cols = RGBColor /@ {"#00adb5", "#f8b500", "#1a0841"}},
Manipulate[
Graphics[
{Blend[
cols[[;; 2]], (Floor[t] + Sign[1 - t] smootherstep[Mod[t, 1]])],
Table[
ProjectedSphericalCircle[
RotationMatrix[π/2, {0, 0, 1}].
Hopf[
RotationMatrix[π/2 (Floor[t] + smootherstep[Mod[t, 1]]), {{1, 1, 0, 0}, {0, 0, 1, 1}}].pts[[i]]
],
.4],
{i, 1, Length[pts]}]},
PlotRange -> 3, ImageSize -> 540, Background -> cols[[-1]]],
{t, 0, 2}]
]
Finally, here's an image where I've composited together all of the frames of a similar animation (essentially the same thing without the `smootherstep` function, so it's just a constant-speed rotation):
![All frames of the animation composited together][2]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=circles9.gif&userId=610054
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=circle9Still2.png&userId=610054
[3]: http://community.wolfram.com/groups/-/m/t/1521244
[4]: https://en.wikipedia.org/wiki/Hopf_fibration
[5]: http://community.wolfram.com/groups/-/m/t/1282077
[6]: https://en.wikipedia.org/wiki/SmoothstepClayton Shonkwiler2018-10-21T15:00:28Z[GIF] J34 (Hopf projection of the 600-cell)
http://community.wolfram.com/groups/-/m/t/1521244
![Hopf projection of the 600-cell][1]
_J34_
This shows a rotating 600-cell under the Hopf map. At least for the particular choice of coordinates I'm using, each of the 120 vertices of the 600-cell lies in the same complex line as 3 others, so the initial projection only has 30 vertices (in fact, it is the [pentagonal orthobirotunda][2]). With this particular rotation, two pairs split off before recombining.
Here's the Hopf map, along with the [smoothstep function][3]:
Hopf[{x_, y_, z_, w_}] := {x^2 + y^2 - z^2 - w^2, 2 y z - 2 w x, 2 w y + 2 x z};
smoothstep[x_] := 3 x^2 - 2 x^3;
And the vertices of the 600-cell, defined partially in terms of the vertices of the 8-cell and the 16-cell:
eightcellvertices = Normalize /@ {-1, -1, -1, -1}^# & /@ Tuples[{0, 1}, 4];
sixteencellvertices = Normalize /@ Flatten[Permutations[{-1, 0, 0, 0}]^# & /@ Range[1, 2], 1];
six00cellvertices = Join[sixteencellvertices, 1/2 eightcellvertices,
Flatten[
Outer[
Permute, (1/2 {GoldenRatio, 1, 1/GoldenRatio, 0}*{-1, -1, -1, 0}^Append[#, 1] & /@ Tuples[{0, 1}, 3]),
GroupElements[AlternatingGroup[4]],
1],
1]
];
And, finally, here's the animation:
With[{pts = six00cellvertices, viewpoint = 2 {1, 0, 0},
cols = RGBColor /@ {"#c3f1ff", "#f87d42", "#00136c"}},
Manipulate[
Graphics3D[
Table[
Sphere[Hopf[RotationMatrix[2 π/5 smoothstep[t], pts[[{5, 27}]]].pts[[i]]], .2],
{i, 1, Length[pts]}],
PlotRange -> 1.2, ViewAngle -> π/7, Boxed -> False,
ImageSize -> 540, ViewPoint -> viewpoint,
Background -> cols[[-1]],
Lighting -> {{"Spot", cols[[1]], {{0, 0, -.75}, {0, 0, 1}}, π/2},
{"Spot", cols[[2]], {{0, 0, .75}, {0, 0, -1}}, π/2},
{"Ambient", cols[[-1]], viewpoint}}],
{t, 0, 1}]
]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sphere22q.gif&userId=610054
[2]: https://en.wikipedia.org/wiki/Pentagonal_orthobirotunda
[3]: https://en.wikipedia.org/wiki/SmoothstepClayton Shonkwiler2018-10-19T03:09:23ZThe Octagonal Dodecahedron
http://community.wolfram.com/groups/-/m/t/1520664
On 17 October 2018, [Ivan Neretin discovered the octagonal dodecahedron](https://math.stackexchange.com/questions/2869725/), a toroid made from twelve octagons.
**4**, 6, 8 triangles can make a tetrahedron and up. The [Snub Disphenoid](http://mathworld.wolfram.com/SnubDisphenoid.html) has 12 faces.
**6**, 8, [9](https://en.wikipedia.org/wiki/Herschel_graph), 10 quadrilaterals can make a cube and up. The [Rhombic Dodecahedron](http://mathworld.wolfram.com/RhombicDodecahedron.html) has 12 faces.
**12**, 16, 18, 20 pentagons can make a [tetartoid](http://demonstrations.wolfram.com/TheTetartoid/) or dodecahedron [and up](https://math.stackexchange.com/questions/1609854/).
**7**, 8, 9, 10 hexagons can make make a [Szilassi toroid](http://demonstrations.wolfram.com/TheParametrizedSzilassiPolyhedron/) and [up](http://dmccooey.com/polyhedra/ToroidalRegularHexagonal.html).
**12**, 24 heptagons can make a [heptagonal dodecahedron](http://dmccooey.com/polyhedra/HigherGenus.html) or [Klein quartic 3-torus](http://mathworld.wolfram.com/KleinQuartic.html).
**12** octagons can make an octagonal dodecahedron.
![octagonal dodecahedron][1]
So how did I make that picture? First, I looked through the [Canonical Polyhedra](https://datarepository.wolframcloud.com/resources/Canonical-Polyhedra) resource object for the outer polyhedron. The index turned out to be "8_9".
ResourceObject["Canonical Polyhedra"]
ResourceData["Canonical Polyhedra"][["8_9"]]
It's a geometric object with constraints since it's a [canonical polyhedron](http://demonstrations.wolfram.com/CanonicalPolyhedra/). My WTC talk [Narayama's Cow and Other Algebraic Numbers](https://wtc18.pathable.com/meetings/895905) discussed how to use algebraic number fields to simplify geometrically constrained objects.
1. Get two or more points to simple fixed values.
2. Use RootApproximant[] on remaining points.
3. If remaining points have the same value for NumberFieldDiscriminant[coord^2], the object is in an algebraic number field.
Would the technique I suggested help to make the new object? Turns out it did.
I took the points from "8_9", kept the center at (0,0,0), found an EulerMatrix[] to forced the midpoints of two opposing edges to (0,0,1),(0,0,-1) and force those two edges to be parallel to the x,-y axes.
After using Chop[] in various ways to get 0, 1, and -1 values, I used RootApproximant[] on everything else, then looked at NumberFieldDiscriminant[coord^2] on all reasonable seeming values. The discriminant -104 turned out a lot, and soon I had all coordinates using the algebraic number field based on Root[#^3 - # - 2 &, 1].
I've found these functions useful for algebraic number fields.
FromSqrtSpace[root_, coord_] := Module[{ dim, degree, vector},
dim = Dimensions[coord];
degree = {1, 2}.NumberFieldSignature[root];
vector = (root^Range[0, degree - 1]);
Map[With[{k = (#).vector}, RootReduce[Sign[k] Sqrt[Abs[k]]]] &, coord, {Length[dim] - 1}]];
ToSqrtSpace[root_, coord_] := Module[{dim, order, algebraic},
dim = Dimensions[coord];
order = {1, 2}.NumberFieldSignature[root];
algebraic = Map[Function[x, ToNumberField[Sign[x] RootReduce[x^2], root]], coord,{Length[dim] - 1} ];
Map[Function[x, If[Head[x] === AlgebraicNumber, Last[x], PadRight[{x}, order]]], algebraic, {Length[dim]} ]];
The algebraic number field coordinates, actual coordinates, and faces.
valsV={{{0,1/2,-1/4},{0,0,0},{-1,0,0}},{{-2,0,1},{0,-2,1},{-1,2,-1}},{{0,2,-1},{2,0,-1},{1,-2,1}},{{0,2,-1},{-2,0,1},{1,-2,1}},{{-2,0,1},{0,2,-1},{-1,2,-1}},{{0,-1/2,1/4},{0,0,0},{-1,0,0}},{{0,0,0},{0,1/2,-1/4},{1,0,0}},{{0,0,0},{0,-1/2,1/4},{1,0,0}},{{2,0,-1},{0,2,-1},{-1,2,-1}},{{2,0,-1},{0,-2,1},{-1,2,-1}},{{0,-2,1},{-2,0,1},{1,-2,1}},{{0,-2,1},{2,0,-1},{1,-2,1}}};
p89v = FromSqrtSpace[Root[#^3 - # - 2 &, 1], valsV];
p89F={{1,2,3,4,5},{2,10,12,8,3},{4,7,11,9,5},{6,9,11,12,10},{1,5,9,6},{1,6,10,2},{3,8,7,4},{7,8,12,11}};
Code for the initial picture.
reg=RegionBoundary[RegionDifference[ConvexHullMesh[p89v],ConvexHullMesh[With[{a=.7, b=.6, c=.9},{{a,b,c}, {-a,-b,c},{-b,a,-c}, {b,-a,-c} }]]]];
DiscretizeRegion[reg,MeshCellStyle->{{2,All}->Opacity[.7]}, SphericalRegion-> True, ImageSize-> 600, ViewAngle-> Pi/10]
Showing the original polyhedron and subtracted tetrahedron.
Graphics3D[{EdgeForm[Thick], Opacity[.8], GraphicsComplex[p89v, Polygon[p89F]],
With[{a = .7, b = .6, c = .9}, Polygon[Subsets[{{a, b, c}, {-a, -b, c}, {-b, a, -c}, {b, -a, -c} }, {3}]]]}, Boxed -> False, SphericalRegion -> True, ViewAngle -> Pi/9]
![octagonal dodecahedron][2]
Might be possible to remove the canonical sub-polyhedron constraint and add a constraint that the octagons all have unit area. Or to minimize the ratio of largest/smallest edge.
If you'd like a hexagonal dodecahedron, here's a simple one.
DiscretizeRegion[RegionBoundary[RegionDifference[Region[Cuboid[{0, 0, 0}, {3, 3, 3}]],
RegionUnion[Region[Cuboid[{0, 0, 0}, {2, 2, 2}]], Region[Cuboid[{1, 1, 1}, {3, 3, 3}]]]]],
MaxCellMeasure -> {"Area" -> 0.001}, AccuracyGoal -> 8, PrecisionGoal -> 8]
![hexagonal dodecahedron][3]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=octagonaldodecahedron.jpg&userId=21530
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=octagonaldodecbuild.jpg&userId=21530
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=hexagonaldodecahedron.jpg&userId=21530Ed Pegg2018-10-18T21:43:37ZTwelve Prisms
http://community.wolfram.com/groups/-/m/t/1517102
My friend Gianni Sarcone recently built a 12 prism construction.
![twelve prisms][1]
So I had to build one myself. I also built in in Mathematica. To my surprise, I was able to simplify it down to three points.
base={{4,4,7},{3,6,6},{2,5,8}};
prismp=Join[base,-(Reverse/@base)];
prismf={{1,2,3},{4,5,6},{1,2,4,5},{1,3,6,5},{2,3,6,4}};
tetrahedralGroup ={{{-1,0,0},{0,-1,0},{0,0,1}},{{0,-1,0},{0,0,1},{-1,0,0}},{{0,0,1},{-1,0,0},{0,-1,0}},{{0,0,-1},{1,0,0},{0,-1,0}},{{0,1,0},{0,0,-1},{-1,0,0}},{{1,0,0},{0,1,0},{0,0,1}},{{0,-1,0},{0,0,-1},{1,0,0}},{{-1,0,0},{0,1,0},{0,0,-1}},{{0,0,1},{1,0,0},{0,1,0}},{{1,0,0},{0,-1,0},{0,0,-1}},{{0,0,-1},{-1,0,0},{0,1,0}},{{0,1,0},{0,0,1},{1,0,0}}};
Graphics3D[{Opacity[.8],Table[Polygon[prismp[[#]].tetrahedralGroup[[n]]]&/@prismf,{n,1,12}]}, Boxed-> False, SphericalRegion->True,ImageSize-> {800,800},ViewAngle-> Pi/9]
![twelve prisms][2]
Maybe try out ViewAngle -> Pi/600, ViewPoint -> {200, 0, 0}
![12 prisms from far away][3]
Sweet.
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=twelveprisms.jpg&userId=21530
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=12prismWL.jpg&userId=21530
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=12prismfar.jpg&userId=21530Ed Pegg2018-10-16T22:24:27ZOuter Billiards. How to create a test to skip triangle corner in for loop?
http://community.wolfram.com/groups/-/m/t/1487490
Hey Everyone! I'm currently working on a problem in a course on mathematical modeling concerning Outer Billiards. I'm supposed to write a program that does the following:
> Start with a ball (a point particle) somewhere outside an equilateral triangle with side length equal to 1. You have two possibilities here and you select one of them. When it arrives at the corner it has traveled a distance d1. Then the particle continues in the same direction as before the same distance d1 There it changes direction momentarily and moves towards the other corner. Then the procedure is repeated, at the second corner it has traveled a distance d2 and it continues in the same direction the same distance d2, etc.
One problem that I've encountered is that for some points the trajectory of the point particle crosses the interior of the triangle, which is not allowed. Therefore I would like to create a test inside of my for loop which says that: "IF the trajectory towards a corner crosses the interior of the triangle, move instead to the next corner." Now, my lecturer gave me a hint that one can use determinants in order to make a pretty easy test, but I find it somewhat hard to understand intuitively. So I would like to make another test, but I don't know how exactly. Here is the program that I'm working on:
corner = {{1/2, Sqrt[3] /2}, {0, 0}, {1, 0}};
ourtriangle = Triangle[{corner[[1]], corner[[2]], corner[[3]]}];
p0 = {2, 2};
plotpoints = {p0};
cornerindex = 1;
n = 3;
For[i = 1, i < n, i++,
p1 = 2*corner[[cornerindex]] - p0;
p0 = p1;
AppendTo[plotpoints, p1];
cornerindex = Mod[i, 3] + 1;
]
traj = Table[plotpoints[[i]], {i, n}];
plot1 = Graphics[{Dashed, Line[traj]}];
Show[plot1, Graphics[ourtriangle], Axes -> False]
This yields the following graph:
![enter image description here][1]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Project_1_FINAL.jpg&userId=1487470
So, in this case I would like the trajectory to instead move towards the right-most corner but I really dont know how. Could someone please give me at least a hint?
Thank you all.Victor Galeano2018-10-01T14:08:05Z