Community RSS Feed
http://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Visual Arts sorted by active[GIF] Vitals (Animated von Mises distribution)
http://community.wolfram.com/groups/-/m/t/1199921
![Animated von Mises distribution][1]
**Vitals**
This one is pretty simple: there are 22 rows of dots, translating left or right depending on whether the row number is even or odd. Within each row, you can see the dots as plotting the density of the [von Mises distribution][2]. Specifically, the radius of each dot is the value of the von Mises pdf at that point.
Note that the von Mises distribution is like a Gaussian distribution on the circle. In particular, it is a periodic probability distribution, which is why each row is periodic, showing a total of 5 periods.
Here's the code:
Manipulate[
Show[
GraphicsGrid[
Table[{
Graphics[{
Lighter[ColorData["Rainbow"][1 - (n + 10)/21], .2],
Disk[{#, 0}, PDF[VonMisesDistribution[0, .3], Mod[# + (-1)^n t, 2 π, -π]]] & /@ Range[-4 π, 4 π, π/6]},
PlotRange -> {{-4 π - π/12, 4 π + π/12}, {-.5, .5}}]},
{n, -10, 11}],
Spacings -> {-6, Automatic}], ImageSize -> 600, Background -> GrayLevel[.1],
PlotRangePadding -> {None, Scaled[.0242]}
],
{t, 0, 2 π}]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=dots12sc.gif&userId=610054
[2]: https://en.wikipedia.org/wiki/Von_Mises%E2%80%93Fisher_distributionClayton Shonkwiler2017-10-09T00:55:26Z[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:40Z[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