Posts tagged: Mathematica

"The knot is structurally independent of the substrate that carries it.
All information in the knot occurs in its relationship with the ambient space.”
-
Louis Kauffman

Mathematica code:

r[t_] := {Sin[t] + 2 Sin[2*t], Cos[t] - 2 Cos[2*t], -Sin[3*t]};T[t_] := 1/Norm[r'[t]]*r'[t];U[t_] := 1/Norm[r''[t]]*r''[t];V[t_] := Cross[T[t], U[t]];W[a_, d_, t_] := r[t] + d*Cos[a]*U[t] + d*Sin[a]*V[t]Manipulate[With[{d = .5, M = 124, Q = 124}, Graphics3D[  Table[    GraphicsComplex[     Flatten[Table[      W[(a + s)*2 Pi/3, d, t + s*8*Pi/M],     {t, {j*2 Pi/M, (j + 1) 2 Pi/M}}, {a, 0, 2, 1}], 1],      Polygon[{{1, 2, 5, 4}, {2, 3, 6, 5}, {3, 1, 4, 6}}]],  {j, 0, Q, 1}], Lighting -> "Neutral", Boxed -> False, ViewPoint -> Above,  ImageSize -> 600, PlotRange -> 3.5]],{s, 0, 1}]

Inspired by an exhibit in the Gallery Room in Antichamber

Mathematica code:

v[x_, y_, z_] =   Flatten[Table[ {(-1)^i*x, (-1)^j*y, (-1)^k*z}, {i, 0, 1}, {j, 0,      1}, {k, 0, 1} ], 2];f = {{1 , 2 , 4 , 3  }, {1 , 2 , 6 , 5  }, {5 , 6 , 8 , 7  }, { 3, 4 ,     8 , 7  }, { 1, 3 , 7 , 5 }, { 2, 4 , 8 , 6  } };G[x_, y_, z_, s_, H_ , t_] := Table[  Translate[   Rotate[    GraphicsComplex[v[x, y, z], Polygon[f]],    h (Cos[t] + 1) Pi/4, {0 , 0, 1 }],   {0, 0, s*h}],  {h, 1, H}]Manipulate[  Graphics3D[   G[2, 2, .1, .25, 30, t],   Lighting -> "Neutral", ViewPoint -> Front, ViewAngle -> 35 Degree,   Boxed -> False, ImageSize -> 500],  {t, 0, Pi}]
Filed under: #GIF  #Mathematica  #Antichamber

Mathematica code:

v[a_] :=  {{Cos[a], 0},  {0, Sin[a]},  {Sin[a], Cos[a] + Sin[a]},  {0, 2 Cos[a] + Sin[a]},  {Cos[a], 2 Cos[a] + 2 Sin[a]},  {Cos[a] + Sin[a], Cos[a] + 2 Sin[a]},  {Cos[a] + 2 Sin[a], 2 Cos[a] + 2 Sin[a]},  {2 Cos[a] + 2 Sin[a], 2 Cos[a] + Sin[a]},  {2 Cos[a] + Sin[a], Cos[a] + Sin[a]},  {2 Cos[a] + 2 Sin[a], Sin[a]},  {Cos[a] + 2 Sin[a], 0},  {Cos[a] + Sin[a], Cos[a]}}q[a_, b_, f_, w0_, w1_, w2_, w3_, t_] := {{GrayLevel[b + f*Sin[2 Pi (w0 + t)]],    Polygon[{v[a][[12]], v[a][[1]], v[a][[2]], v[a][[3]]}]},  {GrayLevel[b - f*Sin[2 Pi (w1 + t)]],    Polygon[{v[a][[3]], v[a][[4]], v[a][[5]], v[a][[6]]}]},  {GrayLevel[b - f*Sin[2 Pi (w2 + t)]],    Polygon[{v[a][[9]], v[a][[10]], v[a][[11]], v[a][[12]]}]},  {GrayLevel[b + f*Sin[2 Pi (w3 + t)]],    Polygon[{v[a][[6]], v[a][[7]], v[a][[8]], v[a][[9]]}]},  {Thick, GrayLevel[b + f], Line[{v[a][[1]], v[a][[2]], v[a][[3]]}]},  {Thick, GrayLevel[b - f], Line[{v[a][[3]], v[a][[12]], v[a][[1]]}]},  {Thick, GrayLevel[b - f], Line[{v[a][[3]], v[a][[4]], v[a][[5]]}]},  {Thick, GrayLevel[b + f], Line[{v[a][[5]], v[a][[6]], v[a][[3]]}]},  {Thick, GrayLevel[b + f], Line[{v[a][[11]], v[a][[12]], v[a][[9]]}]},  {Thick, GrayLevel[b - f], Line[{v[a][[9]], v[a][[10]], v[a][[11]]}]},  {Thick, GrayLevel[b - f], Line[{v[a][[9]], v[a][[6]], v[a][[7]]}]},  {Thick, GrayLevel[b + f], Line[{v[a][[9]], v[a][[8]], v[a][[7]]}]}}Manipulate[ With[{pr = 6, h = 2, v = 3, b = .8, f = .2, w0 = 0, w1 = 1/8, w2 = 2/8, w3 = 3/8, a = .9},  Graphics[   Table[    Translate[     Table[      Translate[       q[a, b, f, w0 + x/4 + y/4, w1 + x/4 + y/4, w2 + x/4 + y/4, w3 + x/4 + y/4, t],       y {0, Sin[a] + 2 Cos[a] + Sin[a]}],      {y, -v - 1, v, 1}],     x {2 Cos[a] + 2 Sin[a], 0}],    {x, -h - 1, h, 1}], PlotRange -> {{-pr, pr}, {-7/5 pr, 7/5 pr}}, Background -> GrayLevel[b], ImageSize -> 500]], {t, 0, .95, .05 }]
Filed under: #tilings  #wavy  #GIF  #Mathematica

In last weeks post, we saw how the motion of particles that move along straight lines creates the illusion of a spinning circle. This time we actually let the individual particles move in circular paths and observe various patterns that result when the relative phase of each particle is varied. Here, “phase” just means where along the circular path a certain particle is when compared to the others.

In the first animation, each of the particles arrive at the edge of the black circle at the same time to create the effect of a spinning and contracting/expanding circle.

In the second animation, the particles are phased just right to create the illusion of a circle that slides along the edge of the black circle. This is similar to the Tusi motion from the previous post except in this instance the circle doesn’t spin.

In the third animation, the phases are adjusted to make it seem like the particles move along a straight line that spins around, but really each particle is still only moving along a circular path. This is a somewhat opposite effect from the Tusi motion where the particles were always moving along straight lines.

Inspired by the not-Tusi-couple.

Mathematica code:

Manipulate[ Graphics[  {{Black,    Disk[{0, 0}, 1.05]},   Table[    Rotate[     {White, Opacity[o],      Circle[{.525, 0}, .525]},     n*2 Pi/m, {0, 0}],    {n, 1, m, 1}],   Table[    Rotate[     {White,      Disk[       .525 {1 + Cos[-2 Pi (p*n/m + t)], Sin[-2 Pi (p*n/m + t)]}, .02]},     n*2 Pi/m, {0, 0}],    {n, 1, m, 1}]},  PlotRange -> 1.1, ImageSize -> 500], {{m, 8, "circles"}, 1, 20, 1}, {{o, .5, "path opacity"}, 1, 0}, {{p, 0, "phase"}, 0, 2, 1}, {t, 0, 1}]
Filed under: #Tusi  #phase  #circles  #GIF  #Mathematica

These remarks make some interesting observations in reference to a previous post. The intuition here is correct, and the motion displayed in the 2D case can be thought of as a special case of a certain 3D motion when viewed from a particular perspective. Let’s experiment with this idea here.

Its important to note that two properties are at play that make this phenomenon work the way it does. This first of these, as mentioned in the response, is that the white circles do not move back and forth along their respective lines at the same speed. Each white circle actually slows down as it approaches the edge of the black circle, but speeds up as it passes through the center. More specifically, how the velocity of the white circle changes with time can be described as a sine wave. Compare the motion of the white and blue circles in the animation below. The white circle moves back and forth while maintaining the same speed throughout, whereas the blue circle’s motion is sinusoidal.

The other property that the circles must exhibit in order to create the outline of a rolling circle is to reach the edge of the black circle in their respective motions at just the right time. This is accomplished by  spacing them out just right. Consider the case where each of the circles all start at the outer edge at the same time. The resulting motion would just look like this:

Here, the circles velocities do not vary sinusoidally and each moves with constant speed. By having each circle reach the outer edge at different times, the following motion results:

Notice how in this case the white circles do not form the outline of a perfect circle. Now, by keeping the circles spaced out just right, and also having the speeds vary sinusoidally we arrive at the desired effect that we saw in the original post:

Let’s  try to generalize this idea into three dimensions. Instead of circles we’ll use spheres, and instead of circles moving back and forth along a straight line we’ll have the spheres move in a circular orbit. In the animation below, we see a sphere that is orbiting along the outer shell of a larger sphere in a circular path along the outer shell of a larger sphere. Note that the sphere is moving with constant speed. The plane in which the sphere is orbiting is displayed along with a bounding box for a better sense of depth in 3D.

Now we add some more orbiting spheres that also move in circular paths, where each of the paths lies in evenly spaced planes that are all perpendicular to a plane (not shown) that would be parallel to the front-most face of the bounding box.

In the above animation there are 8 spheres that are orbiting, and for each of the 4 planes there is a pair of spheres that orbit within the plane. Let’s now view this same scene looking head-on through the front face of the bounding box:

From this perspective the planes now look like lines since we’re viewing them along their edges. Here, we are taking into account the proper perspective in 3D, and you can tell by noticing that the sizes of the spheres change as they move closer or further away. We can ignore the perspective, and view the scene as projected into 2D  via an orthographic projection yielding the following animation:

It can now be seen that this effect results in exactly what we observed in the 2D case! Something interesting happened though. We  did start with 8 spheres originally but in this view half of them get obscured by the other half since one is in front of the other. If we really wanted to see 8 spheres moving around, we would actually need to work with 16 spheres in total. The following animations use 16 spheres in the same three perspectives we just experimented with, but this time the planes have been removed:

The relationship here between the linear sinusoidal motion in the 2D case and the circular orbit with constant speed in the 3D case can be seen as a generalization of an analogous relationship between the sin function and the unit circle. We wont invest in the details here, but just take a look at this animation for an idea (taken from Wikipedia):

If you would like to see the Mathematica code for the other animations just ask. : )

Filed under: #phase  #circles  #GIF  #Mathematica  #Tusi

Each of the white circles are really just moving back and forth along a straight line. The second animation shows the same exact motion, but with straight lines added to make the linear motion obvious. Inspired by the Tusi-couple.

Mathematica code:

Manipulate[ Graphics[  {{Black,    Disk[{0, 0}, 1.05]},   Table[    {White, Opacity[o],     Line[      Table[1.05 s {Cos[n*2 Pi/m], Sin[n*2 Pi/m]}, {s, -1, 1, 2}]]},    {n, 1, m, 1}],   Table[    {White,     Disk[      Cos[2 Pi (t + n/m)] {Cos[n*2 Pi/m], Sin[n*2 Pi/m]}, .05]},    {n, 1, m, 1}]},  PlotRange -> 1.1, ImageSize -> 500], {{m, 16}, 1, 20, 1}, {{o, .5}, 1, 0}, {t, 0, 1}]
Filed under: #circles  #phase  #GIF  #Mathematica  #Tusi

A Moire pattern inspired by ‘eddying currents

Mathematica code:

Eddy[x_, y_, s_, n_, th_, R_] := Translate[  {Thickness[th], Line[    Table[     If[R == 0,       TransformationFunction[IdentityMatrix[3]],        ReflectionTransform[{0, 1}]]      [{If[Or[Mod[i, 4] == 0, Mod[i, 4] == 1],        Floor[(i + 1)/4], s - Floor[i/4]],        If[Or[Mod[i, 4] == 0, Mod[i, 4] == 3],        Floor[Abs[(i - 1)]/4], s - Floor[i/4]]}],     {i, 0, n, 1}]]},  {x, y}]G[pr_, th_, o_, h_, s_, n_, X_, Y_, t_] := Graphics[{   Table[    Eddy[1 + X*x, 1 + Y*y, s, n, th, Mod[x, 2]],    {x, 0, 8, 1}, {y, 0, 8, 1}],   Translate[    Table[     {Opacity[o], Thickness[th],       Line[       Table[{{i - j*i, j*i}, {i - j*(i - h), h - j*h + j*i}},       {i, -h, h, 1}]]},     {j, 0, 1}],    {-t, -t}]},  PlotRange -> {{0, pr}, {0, 7/5 pr}}, ImageSize -> {500, 700}]
Manipulate[ G[40, .011, 1, 60, 5.25, 11, 7.2, 7.2, t], {t, 1, 1/30, -1/30}]
Filed under: #GIF  #Moire pattern  #Mathematica
Filed under: #kaleidocycle  #GIF  #Mathematica

A collaboration between myself and intothecontinuum who created all the moving parts you see in the gif. You can check out his tumblr here.

in collaboration with Ryan Salge!

An even number of (at least 8) regular tetrahedra can be connected along their edges to form a ring in a way that allows them to be continuously rotated “inside-out” without disconnecting. Such configurations are commonly referred to as kaleidocycles. Shown above are kaleidocycles with 8, 10, and 12 tetrahedra exhibiting 4, 5, and 6-fold rotational symmetry, respectively. There has to be at least 8 regular tetrahedra, because any less would result in the tetrahedra colliding into each other at certain instances of the rotation. You can even make your own paper model using this guide.

Mathematica code:

v1[t_] := {Cos[t], 0, Sin[t]}v2[t_, a_] :=  1/Sqrt[1 + Sin[t]^2 Tan[a]^2] {-Sin[t], -Sin[t] Tan[a], Cos[t]}v3[t_, a_] :=  1/Sqrt[1 + Sin[t]^2 Tan[a]^2] {-Sin[t]^2 Tan[a], 1, Cos[t] Sin[t] Tan[a]}P[t_, a_] := {v3[t, a][[2]]/Tan[a] - v3[t, a][[1]], 0, -v3[t, a][[3]]/2}Q[t_, a_] := {v3[t, a][[2]]/Tan[a], v3[t, a][[2]], v3[t, a][[3]]/2}vertices[t_, a_] := {P[t, a] - Sqrt[2]/2 v1[t], P[t, a] + Sqrt[2]/2 v1[t], Q[t, a] - Sqrt[2]/2 v2[t, a], Q[t, a] + Sqrt[2]/2 v2[t, a]}Tetrahedron[T_, t_, a_, o_] := Table[  {FaceForm[White], Opacity[o], EdgeForm[Thick],   Polygon[    Table[     T[vertices[t, a][[1 + Mod[i + j, 4]]]], {i, 1, 3, 1}]]},  {j, 0, 3, 1}]Kaleidocycle[pr_, t_, n_, o_, A_] := Graphics3D[  Rotate[   Table[    Rotate[     Table[      Tetrahedron[T, t, 2 Pi/n, o],      {T, {TransformationFunction[IdentityMatrix[4]],         ReflectionTransform[{-Sin[2 Pi/n], Cos[2 Pi/n], 0}]}}],     r*4 Pi/n, {0, 0, 1}],    {r, 0, n - 1, 1}],   A*Sin[t], {0, 1, 0}],  PlotRange -> pr, ImageSize -> 500, Axes -> False, Boxed -> False,   Lighting -> "Neutral", ViewPoint -> {0, 0, 2}, Background -> White ]Manipulate[Kaleidocycle[pr, t, n, o, A], {pr, 1.5, 50}, {t, 0, 2 Pi}, {n, 8, 16, 1},{o, 1, 0}, {{A, 0}, 0, 2 Pi}]
Filed under: #GIF  #Mathematica  #kaleidocycle

Made in response to a recent question posted at the Mathematica Stack Exchange.

Mathematica code:

img =
ImageCrop@DensityPlot[
Sin[2 x - 20 Log[2 (Sin[y]^2 + 1), 2]],
{x, 0, 16 Pi}, {y, 0, 32 Pi},
PlotPoints -> 250, ColorFunction -> "SunsetColors",
Frame -> False, ImageSize -> 600]LogPolar[x_, y_] := {Log[Sqrt[x^2 + y^2]], ArcTan[x, y]}d = ImageDimensions[img][[1]]
Manipulate[
ImageResize[
ImageTransformation[
ImageTake[
img,
{1, 14*d/16}, {1 + (2 - 2 t)*d/32, (32 - 2 t)*d/32}],
LogPolar[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}],
500],
{t, 0, 6/7, 1/7}]

Mathematica code:

ID = ImageData[Binarize[Rasterize[Import["Erwin.jpg"], RasterSize -> 100], .7], DataReversed -> True]Tile[k_, rx_, ry_, x_, y_, r_] :=Table[ Translate[  Rotate[   {AbsoluteThickness[k],    Circle[{i, i}, {rx, ry}, {i*Pi, Pi/2 + i*Pi}]},   r, {.5, .5}],  {x, y}], {i, 0, 1, 1}]Parquet[IS_, X_, Y_, u_, v_, k_, rx1_, rx2_, ry1_, ry2_, f_, t_] :=Graphics[ Table[  Tile[ k, rx1 + rx2*x/X, ry1 + ry2/2*(1 + Sin[2 Pi (f*y/Y - t)]), x, y,  ID[[1 + v*y, 1 + u*x]] Pi/2],  {x, 3, X, 1}, {y, 5, Y, 1}], ImageSize -> IS, PlotRange -> {{3, X + 1}, {5, Y + 1}}]Manipulate[Parquet[500, 56, 60, 2, 2, 2, .5, 0, 0, .5, .5, t],{t, 0, 17/18, 1/18}]

In a previous post we experienced what a Truchet tiling looks like. This time, the animations above show what it might be like to look down on a Truchet tiling, but while moving along it in a straight line.

In each of the animations the tiling is really only shifting in one direction (the direction corresponding to “down” when viewed on your screen) as made apparent in the following simple Truchet tiling:

For an increased dramatic effect, the rate of this downward movement in the animations is made to correspond with the frame rate of the GIF in such a way where precisely one row of the tiling leaves our view every frame. This makes the smoothly translating tiling just shown look like this instead:

This explains why the individual tiles seem to be changing orientations in place, and why there appears to be a static grid of horizontal and vertical lines outlining the tiles. Together with the geometry of the configurations in the tilings, this also explains why there seems to be motion in several different directions for any given tiling. Perhaps one might be able to realistically create a similar effect if they manage to run along such a tiling at a rate which corresponds to the "frame rate" of human vision.

Mathematica code:

T[r_, x_, y_] := Translate[  Rotate[   {EdgeForm[Thickness[0]], Polygon[{{1, 0}, {0, 0}, {0, 1}}]},   r, {.5, .5}],  {x, y}]Manipulate[ Graphics[  Table[   T[Mod[a*x + b*y, m] Pi/2, x + h, y + v],   {x, 1, X, 1}, {y, 1, Y + 60, 1}],  PlotRange -> {{1, X}, {1, Y - .1}}, ImageSize -> 500], {{X, 23}, 1, 100, 1}, {{Y, 23}, 1, 100, 1}, {{m, 11}, 1, 100, 1}, {{a, 18}, 1, 100, 1}, {{b, 14}, 1, 100, 1}, {h, 0, 14}, {v, 0, 14}]

Consider tiling the plane using only square tiles like this:

The 4-fold rotational symmetry of the square allows a tile to be placed in the 4 different orientations shown here:

Despite these constraints there are still a lot of different ways to tile the plane. Shown above are a few examples constructed with an algorithm using modular arithmetic. This essentially makes the tiles along different rows follow the same sequence but shifted over by some amount.

Each of the tilings shown are actually periodic and can tile the entire plane.
(e.g. 1, 2, 3, 4)

Tilings of this variety are called Truchet tilings.

Mathematica code:

T[r_, x_, y_] := Translate[  Rotate[   {EdgeForm[Thickness[0]], Polygon[{{1, 0}, {0, 0}, {0, 1}}]},   r, {.5, .5}],  {x, y}]Manipulate[ Graphics[  Table[   T[Mod[a*x + b*y, m] Pi/2, x, y],   {x, 1, X, 1}, {y, 1, Y, 1}],  PlotRange -> {{1, X}, {1, Y - .1}}, ImageSize -> 500], {{X, 29}, 1, 100, 1}, {{Y, 29}, 1, 100, 1}, {{m, 14}, 1, 100, 1}, {{a, 5}, 1, 100, 1}, {{b, 5}, 1, 100, 1}]

Mathematica code:

P[A_, f_, w_, h_, M_, Y_, t_] := Plot[  Table[   A*Sin[f*x + t + n*2 Pi/w] + h*n,   {n, 1, M, 1}], {x, 0, 4 Pi},   PlotStyle -> Directive[Black, AbsoluteThickness[3]],   PlotRange -> {{0, 4 Pi}, {-.3, Y}}, Axes -> False,  AspectRatio -> 5/7, ImageSize -> {700, 500}]Manipulate[ ImageRotate[  P[.35, 1, 28, .6, 57, 35, t],  -Pi/2], {t, 2 Pi, Pi/10, -Pi/10}]
Filed under: #GIF  #Mathematica  #wavy  #waterfall plot