Message Boards Message Boards

[GIF] Rolling (Circles rolling inside a circle)

Circles rolling inside a circle

This one is pretty simple: take two circles of radius 1/2 rolling inside a unit circle and track a point on each circle's perimeter. The points turn out to follow straight lines, and the challenge is to make this seem both surprising and obvious (and also to fit it all under 3 MB). Not sure if I succeeded, but that was the idea, anyway.

Here's the code:

smoothstep[x_] := 3 x^2 - 2 x^3;

With[{a = 1, b = 1/2, cols = RGBColor /@ {"#303841", "#f3f6f6"}},
 Manipulate[
  Graphics[{
    Thickness[.0075], cols[[1]],
    Opacity[
     Which[t < 8 ?, 1, 8 ? <= t < 12 ?, 
      1 - smoothstep[(t - 8 ?)/(4 ?)], 
      12 ? <= t < 14 ?, 0, 14 ? <= t <= 18 ?, 
      smoothstep[(t - 14 ?)/(4 ?)]]],
    Table[
     Circle[(a - b) {Cos[t + ? i], Sin[t + ? i]}, b], {i, 0, 1}],
    Opacity[
     Which[t < 6 ?, 0, 6 ? <= t < 8 ?, 
      smoothstep[(t - 6 ?)/(2 ?)], 8 ? <= t < 14 ?, 1,
       14 ? <= t <= 18 ?, 
      1 - smoothstep[(t - 14 ?)/(4 ?)]]],
    Thickness[.01],
    Line[
     Table[(a - b) {Cos[s], Sin[s]} + b {Cos[-(a - b)/b s], Sin[-(a - b)/b s]}, {s, t - 3 ?/4, t, ?/100}],
     VertexColors -> 
      Table[Blend[{Directive[cols[[2]], Opacity[0]], cols[[1]]}, s], {s, 0, 1, 1/75}]],
    Line[
     Table[(a - b) {Cos[s + ?], Sin[s + ?]} + b {Cos[-(a - b)/b s], Sin[-(a - b)/b s]}, {s, t - 3 ?/4, t, ?/100}],
     VertexColors -> 
      Table[Blend[{Directive[cols[[2]], Opacity[0]], cols[[1]]}, s], {s, 0, 1, 1/75}]],
    Opacity[1], cols[[1]], Thickness[.0075], Circle[], 
    PointSize[.03],
    Table[
     Point[(a - b) {Cos[t + i ?], Sin[t + i ?]} + b {Cos[-(a - b)/b t], Sin[-(a - b)/b t]}], {i, 0, 1}]},
   Background -> cols[[-1]], PlotRange -> Sqrt[2], ImageSize -> 540],
  {t, 0, 18 ?}]
 ]
POSTED BY: Clayton Shonkwiler
2 Replies
Sort By:

enter image description here - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming, and consider contributing your work to the The Notebook Archive!

POSTED BY: EDITORIAL BOARD
J. M.
J. M.
Posted 6 years ago

This is a very lovely demonstration of La Hire's line (or the "two-cusp hypocycloid"). A related demonstration can be found in this Mathematica Stack Exchange post.

Having gotten the "name dropping for search engines" out of the way, here's my version of Clayton's code:

With[{a = 1, b = 1/2, cols = RGBColor /@ {"#303841", "#f3f6f6"}},
     DynamicModule[{clist = Map[RGBColor, Transpose[{1 - #, #} & @ Subdivide[75]].
                               {Append[List @@ cols[[2]], 0],
                                Append[List @@ cols[[1]], 1]}], 
                    iF1 = Interpolation[{{{0}, 1, 0}, {{8 ?}, 1, 0}, {{12 ?}, 0, 0},
                                         {{14 ?}, 0, 0}, {{18 ?}, 1, 0}}],
                    iF2 = Interpolation[{{{0}, 0, 0}, {{6 ?}, 0, 0}, {{8 ?}, 1, 0},
                                         {{14 ?}, 1, 0}, {{18 ?}, 0, 0}}]}, 
                   Manipulate[Graphics[{{Directive[Thickness[.0075],
                                                   Append[cols[[1]], iF1[t]]],
                                        Table[Circle[ReIm[(a - b) Exp[I (t + ? i)]],
                                                     b], {i, 0, 1}]},
                                        {Directive[Opacity[iF2[t]], Thickness[.01]],
                                         Line[ReIm[Table[(a - b) Exp[I s] +
                                                         b Exp[-I (a - b)/b s],
                                                        {s, t - 3 ?/4, t, ?/100}]], 
                                              VertexColors -> clist],
                                         Line[ReIm[Table[(a - b) Exp[I (s + ?)] +
                                                         b Exp[-I (a - b)/b s],
                                                        {s, t - 3 ?/4, t, ?/100}]],
                                              VertexColors -> clist]},
                                        {Directive[cols[[1]], Thickness[.0075]],
                                         Circle[]},
                                        {Directive[cols[[1]], PointSize[.03]],
                                         Point[ReIm[Table[(a - b) Exp[I (t + i ?)] +
                                                          b Exp[-I (a - b)/b t],
                                                          {i, 0, 1}]]]}},
                                Background -> cols[[-1]], PlotRange -> Sqrt[2],
                                ImageSize -> 540], {t, 0, 18 ?}]]]

Notes on the code, in no particular order:

  1. I often prefer the complex formulation whenever I deal with epi- or hypocycloids; that way, I don't have to worry about whether I used the same argument in the sine and cosine for the components.

  2. Since smoothstep was only being used here for keyframing purposes, it is more compact and equivalent to directly construct a piecewise Hermite interpolant instead, which Interpolation[] has no trouble doing. (If you need further convincing, compare the InterpolatingFunction[] in my version and the Which[]-based function in Clayton's version in a plot.)

  3. The snippet Append[List @@ color, 0] effectively adds an alpha channel to color.

  4. Since the list of colors used in VertexColors does not change, one can just generate the list once and then plug it into the Manipulate[] with DynamicModule[]. (Note also the slightly different method to get a pile of linearly interpolated colors all at once.)
POSTED BY: J. M.
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Tag limit exceeded
Note: Only the first five people you tag will receive an email notification; the other tagged names will appear as links to their profiles.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract