4
$\begingroup$

I want to turn finite integer sequences, or a finite subset, into an elastic bracelet. Below I have answer for how to do this that took me a while to think of how to do. It still isn't perfect as the thicknesses need to be adjusted so they look nicer given the data.

Motivation

The motivation is that there are relatively few finite sequences on OEIS. But a common question about number-theoretic sequences is if they are finite or infinite.

While I have no theoretical underpinnings for this, I noticed if it is finite, we could 'peel' it into a polygon. And the band connecting the point could be treated elastically where the sum of the angles and lengths are preserved except for the length of the elastic band. Then other questions start to emerge. What are the boundary conditions for when a particular finite sequence mapped to a polygon is convex or concave; simple or self-intersecting? Which finite sequences have similar boundary conditions?

When I was imagining this in my head, I kept thinking of an elastic bracelet that my Mom used to have like this:

This is an example of an elastic bracelet with metal parts and a gold/brass sheen.

Improve this question
$\endgroup$
2
  • 1
    $\begingroup$ A lot of work, but what is the motivation? Reminds me of the work of Sreekumar and Nirmalan of the Kerala Agricultural University who won the 2002 Ig Nobel Prize in Mathematics for their research paper "Estimation of the Total Surface Area in Indian Elephants". $\endgroup$ Commented Oct 15 at 10:38
  • 1
    $\begingroup$ There is no logical justification. My intuition is that there are probably a lot of sequences on OEIS that could be related geometrically to another sequence but proving a relationship would be difficult or impossible. Also, there are some sequences that are quasi-periodic that I wonder what the shape would be by wrapping it. Just aesthetics. $\endgroup$ Commented Oct 15 at 11:49

1 Answer 1

Reset to default
4
$\begingroup$

The chosen example data comes were picked to be:

A000926 A003173 A014117 A034884 A046048 A072938

Which have the List Plots:

These are 6 finite sequences of interest to display as example input data.

Made with the code:

A000926\[LetterSpace]data = { 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 12, 13, 15, 16, 18, 21, 22, 24, 25, 28, 30, 33, 37, 40, 42, 45, 48, 57, 58, 60, 70, 72, 78, 85, 88, 93, 102, 105, 112, 120, 130, 133, 165, 168, 177, 190, 210, 232, 240, 253, 273, 280, 312, 330, 345, 357, 385, 408, 462, 520, 760, 840, 1320, 1365, 1848 }; A003173\[LetterSpace]data = {1, 2, 3, 7, 11, 19, 43, 67, 163}; A014117\[LetterSpace]data = {1, 2, 6, 42, 1806}; A046048\[LetterSpace]data = { 47, 62, 77, 127, 142, 157, 207, 222, 237, 287, 302, 317, 367, 382, 397, 447, 462, 477, 527, 542, 557, 607, 622, 687, 702, 752, 767, 782, 847, 862, 927, 942, 992, 1007, 1022, 1087, 1102, 1167, 1182, 1232, 1247, 1327, 1407, 1487, 1567, 1647, 1727, 1807, 2032 }; A072938\[LetterSpace]data = {1, 2, 6, 12, 60, 360, 2520}; A034884\[LetterSpace]data = {2, 3, 4, 6, 8, 10, 12, 14, 15, 16, 18, 20, 24, 28, 30, 32, 36, 40, 42, 48, 54, 56, 60, 72, 80, 84, 90, 96, 108, 120, 126, 132, 140, 144, 168, 180, 192, 210, 216, 240, 252, 288, 300, 336, 360, 420, 480, 504, 540, 720, 840, 1260 }; makePlot[data_, tag_] := ListPlot[ data, PlotRange -> All, PlotStyle -> Black, AxesLabel -> {"n", "aₙ"}, Frame -> True, PlotLabel -> Style[tag, Bold, 16, Black], ImageSize -> 600]; p1 = makePlot[A000926\[LetterSpace]data, "A000926"]; p2 = makePlot[A003173\[LetterSpace]data, "A003173"]; p3 = makePlot[A014117\[LetterSpace]data, "A014117"]; p4 = makePlot[A046048\[LetterSpace]data, "A046048"]; p5 = makePlot[A072938\[LetterSpace]data, "A072938"]; p6 = makePlot[A034884\[LetterSpace]data, "A034884"]; Rasterize[ Labeled[ GraphicsGrid[ Partition[{p1, p2, p3, p4, p5, p6}, 2], Spacings -> {0.8, 6.8}], Style["Finite Sequences of Interest", 24, Bold, Black], Top] ]

Then is what I have so far:

GoldBraceletPlotTextured[pts_List, barWidth_ : .06, ❁_ : 0, beadScale_ : .02] := Module[ {RotateAround, TransformPolygon, EdgeStrip, d = 1024, gold, stripes, specks, gradient, goldtexture, newPts, n, edges, strips, beadR, xMaxWidth, yMaxHeight, \[Tau]}, RotateAround[p_, \[Theta]_, c_] := c + {{Cos[\[Theta]], -Sin[\[Theta]]}, {Sin[\[Theta]], Cos[\[Theta]]}} . (p - c); TransformPolygon[pts0_List, \[Delta]_] := Module[{ang, s, newAng, L, dirs, newPts2}, ang = N@PolygonAngle@Polygon[pts0]; s = Total@Rest@ang; newAng = Join[{First@ang + \[Delta]}, Rest@ang (s - \[Delta])/s]; L = Norm /@ Differences[pts0]; \[Tau] = Pi - newAng; dirs = FoldList[ RotationTransform[#2][#1] &, Normalize[pts0[[2]] - pts0[[1]]], Rest@\[Tau]]; newPts2 = FoldList[#1 + #2[[1]]*#2[[2]] &, pts0[[1]], Transpose[{L, Most@dirs}]]; newPts2]; EdgeStrip[{p1_, p2_}, w_] := Module[{v = p2 - p1, dir, off}, dir = Normalize[v]; off = (w/2)*{-dir[[2]], dir[[1]]}; {p1 - off, p2 - off, p2 + off, p1 + off}]; SeedRandom[1]; gold = RGBColor[0.8314, 0.6863, 0.2157]; stripes = GaussianFilter[ ImageResize[ RandomImage[{1, 1.2}, {1, d}], {d, d}], 3]; specks = ImageAdjust@GaussianFilter[ Image@RandomVariate[ParetoDistribution[0.01, 5.0], {d, d}], 3]; gradient = LinearGradientImage[{Gray, White, Gray}, {d, d}]; goldtexture = ImageAdjust[ ImageAdd[ ImageMultiply[gradient, Image[ ConstantArray[gold, {d, d}]], stripes], specks], .25]; newPts = TransformPolygon[pts, ❁]; n = Length@newPts; edges = Partition[Append[newPts, First@newPts], 2, 1]; strips = EdgeStrip[#, Length[pts]*barWidth] & /@ Most[edges]; xMaxWidth = Max[newPts[[All, 1]]] - Min[newPts[[All, 1]]]; yMaxHeight = Max[newPts[[All, 2]]] - Min[newPts[[All, 2]]]; beadR = beadScale*Mean[Norm /@ Differences[newPts]]; Graphics[{ {EdgeForm[None], CapForm["Round"], Texture[goldtexture], Table[Polygon[strips[[i]], VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}], {i, Length@strips}] }, {AbsoluteThickness[ Max[2, Length[pts]*barWidth*yMaxHeight/xMaxWidth]], CapForm["Round"], Black, Line[Last@edges] }, { EdgeForm[Directive[Black, AbsoluteThickness[1]]], FaceForm[White], Table[ Disk[newPts[[i]], beadR], {i, n}]}}, PlotRange -> All, AspectRatio -> yMaxHeight/xMaxWidth, Frame -> False, Axes -> False, ImageSize -> 800] ]

I can get reasonable looking results. But formatting the thickness so it always shows up correctly is not so easy. Here are some inputs that give reasonably looking results:

IndexPairs[list_] := Transpose[{Range[Length[list]], list}]; GoldBraceletPlotTextured[IndexPairs[A000926\[LetterSpace]data], .5, Pi/2, .2] GoldBraceletPlotTextured[IndexPairs[A003173\[LetterSpace]data], .25, Pi/2, .025] GoldBraceletPlotTextured[IndexPairs[A014117\[LetterSpace]data], 2.5, Pi/2, .025] GoldBraceletPlotTextured[IndexPairs[A046048\[LetterSpace]data], .5, Pi/2, .15] GoldBraceletPlotTextured[IndexPairs[A072938\[LetterSpace]data], 1, 3 Pi/4, .02] GoldBraceletPlotTextured[ IndexPairs[A034884\[LetterSpace]data], .2, Pi, .05]

A clearer example is done with just the points of the regular pentagon:

These are 16 bracelets made from a pentagon.

That was generated with the code:

orderPointsClockwise2D[pts_List, clockwise_ : True] := Module[{pts3, normal, plane, projectedPts, centroid, angles, ord, sorted}, If[ Length[DeleteDuplicates[pts]] < 3, Return[pts] ]; pts3 = Append[#, 0] & /@ pts; normal = Cross[pts3[[2]] - pts3[[1]], pts3[[3]] - pts3[[1]]]; If[normal === {0, 0, 0}, Return[pts]]; plane = First@Ordering[Abs[normal], -1]; projectedPts = Delete[#, plane] & /@ pts3; centroid = Mean[projectedPts]; angles = ArcTan[#[[1]] - centroid[[1]], #[[2]] - centroid[[2]]] & /@ projectedPts; ord = Ordering[angles]; sorted = pts[[ord]]; If[clockwise, Reverse[sorted], sorted]] pts = orderPointsClockwise2D[N[PolygonCoordinates[RegularPolygon[5]]]]; Rasterize[ Partition[Table[ GoldBraceletPlotTextured[pts, .006, ❁, .02], {❁, 0, (15 \[Pi])/8, Pi/8}], 4] // Grid, ImageSize -> 600]
Improve this answer
$\endgroup$

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.