Community RSS Feed
http://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Geometry sorted by active[GIF] Grid (Transformation of the square grid
http://community.wolfram.com/groups/-/m/t/1204826
![Transformation of the square grid][1]
**Grid**
Unlike [_Part of the Journey_][2], [_Play_][3], and [_Limits_][4], this is not a conformal transformation of a regular grid on the plane. Instead, I've taken the square grid, inverse steregraphically projected it to the sphere, then orthogonally projected back to the plane, producing a collection of curves contained in the unit disk. This is not conformal since orthogonal projection does not preserve angles.
In the animation, I'm translating the entire grid by $-t (1,2)$ as $t$ varies from 0 to 1, which is a symmetry of the square grid, and applying the inverse-stereographic-project-then-orthogonally-project transformation.
There are a couple of quirks in the code. First, the `Disk[]` is there because I didn't extend the grid out far enough to actually fill in the center (which would have been computationally expensive); instead I just placed a small disk in the center to cover the hole in the middle. Second, the funny business on `x` in the `Table[]` is because I'm using progressively less precision for the grid lines which cluster in the center in order to cut down on computational complexity that doesn't actually contribute anything visible.
Anyway, here is the code:
InverseStereo[{x_, y_}] := {2 x/(1 + x^2 + y^2), 2 y/(1 + x^2 + y^2), (x^2 + y^2 - 1)/(1 + x^2 + y^2)};
With[{d = 30, cols = RGBColor /@ {"#FF5151", "#000249"}},
Manipulate[
Graphics[
{cols[[1]], Disk[{0, 0}, .07], Thickness[.003],
Line /@ # & /@ (Transpose /@ Table[InverseStereo[# - t {1, 2}][[;; 2]] & /@ {{n, x}, {x, n}},
{n, -d - 0.5, d + 0.5, 1},
{x, Join[Range[-d, -20], Table[-20 + i Abs[n]/40, {i, 1, 1600/Abs[n]}], Range[20, d]]}])},
Background -> cols[[-1]], ImageSize -> 540, PlotRange -> 1.1],
{t, 0., 1}]
]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=stereotiles12c.gif&userId=610054
[2]: http://community.wolfram.com/groups/-/m/t/1171765
[3]: http://community.wolfram.com/groups/-/m/t/1173214
[4]: http://community.wolfram.com/groups/-/m/t/1179440Clayton Shonkwiler2017-10-18T05:10:47Z[GIF] Voronoi visualization
http://community.wolfram.com/groups/-/m/t/1202074
I recently saw a gif showing the [growth of a Voronoi diagram][1] on [this][2] wiki page. This gif shows a Voronoi diagram but restricts each cell to lie in a disk that slowly grows over time.
I decided to recreate this with the Wolfram Language and thought I'd share the code and final result here.
#Visualization
First and foremost, here's the result:
![enter image description here][3]
#Code
First I start off with 20 random points in 2D:
pts = RandomReal[{-1, -1}, {20, 2}];
Then I extract each point's Voronoi cell by calling `VoronoiMesh` and then arranging the primitives to correspond to `pts`.
prims = BoundaryDiscretizeRegion /@ MeshPrimitives[VoronoiMesh[pts], 2];
prims = Table[First[Select[prims, RegionMember[#, p] &]], {p, pts}];
Let's quickly pause to make sure the cells correspond to the correct point.
MapThread[Show[#1, Epilog -> {Red, PointSize[Large], Point[#2]}] &, {prims, pts}][[1 ;; 5]]
![enter image description here][4]
Now that we have the primitives, we can show the scene with disks of radius $r$ by applying `RegionIntersection` at each cell with a disk of radius $r$.
First we will discretize a disk to force `RegionIntersection` to return a `BoundaryMeshRegion`. We will also restrict the intersection to lie in $[-1, 1] \times [-1, 1]$.
disk[{x_, y_}, d_, n_: 100] := BoundaryMeshRegion[CirclePoints[{x, y}, d, n], Line[Mod[Range[n + 1], n, 1]]]
bound = BoundaryDiscretizeRegion[Cuboid[{-1, -1}, {1, 1}]];
Now at radius $r$ we intersect, which I packed into a function. First, here's the code for a single cell. It will take the Voronoi cell, its corresponding point, and a color for styling purposes.
colors = RandomColor[RGBColor[_, _, _, 0.3], 20];
PartialVoronoiCell[r_][p_, cell_, color_] :=
BoundaryMeshRegion[
RegionIntersection[bound, disk[p, r], cell],
MeshCellStyle -> {1 -> Directive[Thick, GrayLevel[.5]], 2 -> color}
]
The main function will effectively map over each point. When $r \leq 0$, we just show the points.
PartialVoronoiCells[_?NonPositive] = Graphics[Point[pts], PlotRange -> {{-1, 1}, {-1, 1}}, PlotRangePadding -> Scaled[.0125]];
PartialVoronoiCells[r_] :=
Show[
MapThread[PartialVoronoiCell[r], {pts, prims, colors}],
Epilog -> Point[pts], PlotRange -> {{-1, 1}, {-1, 1}}, PlotRangePadding -> Scaled[.0125]
]
This function is fast enough to visualize the growth with `Manipulate`.
Manipulate[PartialVoronoiCells[r], {r, 0, 1}]
![enter image description here][5]
[1]: https://en.wikipedia.org/wiki/Voronoi_diagram#/media/File:Voronoi_growth_euclidean.gif
[2]: https://en.wikipedia.org/wiki/Voronoi_diagram
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=voronoi.gif&userId=46025
[4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2017-10-1221.55.07.png&userId=46025
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=screenshot.gif&userId=46025Chip Hurst2017-10-13T02:59:08Z[GIF] Trifolium (Envelope of the trifolium curve)
http://community.wolfram.com/groups/-/m/t/1202255
![Envelope of the trifolium curve][1]
**Trifolium**
The animation shows 800 tangent lines to the trifolium as they slowly move around the curve. In order to make it, I first ran `PlaneCurveData["Trifolium", "ParametricEquations"]` to get the parametrization, which I then rotate to get a vertically-oriented trifolium:
tri[t_] := RotationMatrix[π/6].{-Cos[t] Cos[3 t], -Cos[3 t] Sin[t]};
After that, it's just a matter of creating the tangent lines with `InfiniteLine[]` and choosing some colors. Here's the code:
With[{d = 2 π/800.},
Manipulate[
Show[
Table[
Graphics[{Thickness[.001], Opacity[.8], Hue[Mod[(s + t)/π, 1]],
InfiniteLine[tri[t + s], tri'[t + s]]},
PlotRange -> {{-1.4, 1.4}, {-1.18125`, 1.61875`}}],
{t, 0., π - d, d}],
ImageSize -> 540, Background -> GrayLevel[.1]],
{s, 0, d}]
]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=lem8.gif&userId=610054Clayton Shonkwiler2017-10-13T03:19:40ZPlot a polyhedron/region trapped between 4 planes?
http://community.wolfram.com/groups/-/m/t/1200672
I need to plot the region trapped between 4 planes
x = y = z = x + y + z - 1 = 0.
Here, is the code that I used:
RegionPlot3D[ContourPlot3D[x == 0, {x, 0, 1}, {y, 0, 1}, {z, 0, 1}],
ContourPlot3D[y == 0, {x, 0, 1}, {y, 0, 1}, {z, 0, 1}],
ContourPlot3D[z == 0, {x, 0, 1}, {y, 0, 1}, {z, 0, 1}],
ContourPlot3D[x + y + z - 1 == 0, {x, 0, 1}, {y, 0, 1}, {z, 0, 1}]]
But, there are other extra bits that I do not know how to delete them.Amir Baghban2017-10-09T19:17:40Z