Digits of Pi in colored spiral

Question

In How to make the digits of π go around in a spiral like this?

it is described how to plot pi in a spiralform (in my case as binary number):

    numbers = 
 Translate[#, {-4.5, -10}] & /@ 
    First[First[
      ImportString[
       ExportString[Style[#, FontSize -> 14, FontFamily -> "Arial"], 
        "PDF"], "PDF"]]] & /@ {"."}~Join~
   CharacterRange["0", "1"]; With[{fontsize = 0.0655, digits = 10000},
  Graphics[
  MapIndexed[
   With[{angle = (-(#2[[1]] - 2) + 
          Switch[#2[[1]], 1, -0.1, 2, 0, _, 0.6]) fontsize}, 
     With[{scale = (1 - 1.5 fontsize)^(-angle/(2 Pi))}, 
      GeometricTransformation[numbers[[# + 2]], 
       RightComposition[ScalingTransform[{1, 1} 0.1 fontsize*scale], 
        TranslationTransform[{0, scale}], 
        RotationTransform[Pi/4 + angle]]]]] &, 
   Insert[First@RealDigits[Pi, 2, digits], -1, 2]], 
  PlotRange -> {{-1.1, 1.1}, {-1.1, 1.1}}]]

I'm looking for a solution without the explicit numbers, but with each digit expressed as a color. Like in this example:

The code you posted fails with a number of errors including: First::normal: Nonatomic expression expected at position 1 in First[]. — flinty, Nov 28 '23 at 13:00
When i run the code, it shows also the Errors, but nevertheless finaly generates the spiral. — ralf_7, Nov 28 '23 at 13:03

score 19 · Answer 1 · edited Nov 29 '23 at 01:58

At first we define the Archimedean spiral in parametric form

a := 0;
b := 0.3;
r[t_] := a + b t;
x[t_] := r[t]*Cos[t];
y[t_] := r[t]*Sin[t];

Next, generate a list of points with distance exactly $2\times$radius of the circle.

{sol, samples} = 
  Reap[NDSolve[{l'[t] == Sqrt[r[t]^2 + b^2], l[0] == 0, 
     WhenEvent[Mod[l[t], 2] == 0, Sow[t]]}, l, {t, 0, 1000}]];
nt = Dimensions[samples] // Last;
styles = ColorData[10, "ColorList"][[1 ;; 10]];
digits = RealDigits[N[Pi, nt]][[1]];

Finally, plot the data

np=500;
Graphics[
 Table[ti = samples[[1, i]]; {styles[[digits[[i]] + 1]], 
    Disk[{x[ti], y[ti]}]}, {i, np}] // Flatten]

Here is the plot for a larger number of points:

And even larger number of points (10000) and a different style

generated with

styles = ColorData[24, "ColorList"][[1 ;; 10]];
np=10000;
Graphics[Table[ti = samples[[1, i]]; {styles[[digits[[i]] + 1]], 
    Disk[{x[ti], y[ti]}]}, {i, np}] // Flatten]

PS: if matching colour if a concern you can use

brew = Blend[{{0, RGBColor[7/11, 0, 1/7]}, {1/17, 
     RGBColor[10/13, 1/9, 1/7]}, {31/255, 
     RGBColor[7/8, 1/4, 1/6]}, {47/255, 
     RGBColor[13/14, 5/13, 1/4]}, {21/85, 
     RGBColor[31/32, 5/9, 4/13]}, {79/255, 
     RGBColor[46/47, 7/10, 2/5]}, {19/51, 
     RGBColor[46/47, 5/6, 9/17]}, {37/85, 
     RGBColor[1, 10/11, 5/8]}, {127/255, RGBColor[1, 1, 3/4]}, {143/
     255, RGBColor[10/11, 22/23, 7/8]}, {53/85, 
     RGBColor[5/6, 11/12, 17/18]}, {35/51, 
     RGBColor[7/10, 6/7, 10/11]}, {191/255, 
     RGBColor[4/7, 10/13, 6/7]}, {69/85, 
     RGBColor[3/7, 21/32, 4/5]}, {223/255, 
     RGBColor[1/3, 8/15, 11/15]}, {239/255, 
     RGBColor[1/4, 5/13, 2/3]}, {1, RGBColor[1/5, 3/13, 3/5]}}, #1] &

and

styles = brew /@ Subdivide[0, 1, 9];

to get

Looks just like what they wanted! This looks especially interesting if you use a rational number like 79/31 instead of Pi, because you'll get cool patterns. — flinty, Nov 28 '23 at 22:39
They are the colours of Brewer https://colorbrewer2.org/#type=diverging&scheme=RdYlBu&n=9 very commonly used in python for instance. — chris, Nov 29 '23 at 07:27

Syed · Answer 2 · 2023-11-30T08:43:20.363

Using ArcLength and MapThread:

Clear["Global`*"];
f[t_] := {t Sin[t], t Cos[t]};
ArcLength[f[u], {u, 0, t}]

1/2 (t Sqrt[1 + t^2] + ArcSinh[t])

Define a function:

arclen[t_] := 1/2 (t Sqrt[1 + t^2] + ArcSinh[t])

Define color rules:

rules = Thread[
  Rule[Range[0, 9], ColorData[20, "ColorList"][[1 ;; 10]]]]

n = 5000;
spts = x /. First /@ NSolve[arclen[x] == #, x, Reals] & /@ 
   Range[1, 2 n E, 2 E];
Graphics[{MapThread[{#2, Disk[{#1 Cos[#1], #1 Sin[#1]}, E]} &
   , {
    spts
    , Reverse@(First@RealDigits[[Pi], 10, n] /. rules)
    }
   ]
  }]

EDIT

~~It seems to hang up for n=10000 but I can't figure out the exact reason for it.~~

The computation can be sped up with:

spts = x /. 
     First /@ NSolve[arclen[x] == #, x, Reals, 
       VerifySolutions -> False, WorkingPrecision -> 5] & /@ Range[1, 2 n E, 2 E];

Result:

azerbajdzan · Accepted Answer · 2023-11-29T19:55:44.880

p defines how many disks there are in each revolution and do number of revolutions.

p = 100;
do = 90;
d = First@RealDigits[Pi, 10, do p + 1];
ru = {0 -> {165, 0, 38}, 1 -> {215, 48, 39}, 2 -> {244, 109, 67}, 
   3 -> {253, 174, 97}, 4 -> {254, 224, 144}, 5 -> {224, 243, 248}, 
   6 -> {171, 217, 233}, 7 -> {116, 173, 209}, 8 -> {69, 117, 180}, 
   9 -> {49, 54, 149}};
Graphics[{RGBColor@(#[[3]]/255), Disk[#[[1]], #[[2]]]} & /@ 
  Table[{{Sin[n*2 \[Pi]], Cos[n*2 \[Pi]]}*2 (1 + (2 \[Pi])/p)^-n, (
    2 \[Pi] (1 + (2 \[Pi])/p)^-n)/(p + \[Pi]), 
    d[[1 + n p]] /. ru}, {n, 0, do, 1/p}]]
Clear[p, d, do, ru]

q defines number of revolutions and do total number of disks. do should be manually adjusted to fit q.

(*{q,do}={10,313};
{q,do}={20,1255};
{q,do}={30,2826};
{q,do}={40,5025};
{q,do}={50,7852};*)
{q, do} = {50, 7852};
d = First@RealDigits[Pi, 10, 100000];
ru = {0 -> {165, 0, 38}, 1 -> {215, 48, 39}, 2 -> {244, 109, 67}, 
   3 -> {253, 174, 97}, 4 -> {254, 224, 144}, 5 -> {224, 243, 248}, 
   6 -> {171, 217, 233}, 7 -> {116, 173, 209}, 8 -> {69, 117, 180}, 
   9 -> {49, 54, 149}};
pos = NestList[
   x /. FindRoot[
      Total[({Sin[x], 
            Cos[x]}*(1 - x/(2 \[Pi] q)) - ({Sin[#], 
             Cos[#]}*(1 - #/(2 \[Pi] q))))^2] == (1/q)^2, {x, # + 
        1}] &, 0, do];
n = 1;
Graphics[Table[{RGBColor[((d[[n++]] /. ru)/255)], 
   Disk[{Sin[x], Cos[x]}*(1 - x/(2 \[Pi] q)), 1/q/2]}, {x, pos}]]
Clear[q, d, ru, pos, n, do]

score 4 · Answer 4 · answered Nov 28 '23 at 16:38

Clear["Global`*"]

data = Table[
   {r Cos[100. Sqrt[r]], r Sin[100. Sqrt[r]]}, {r, 1/4, Pi, 5/5000}];

n = Length[data];

styles = ColorData[97, "ColorList"][[1 ;; 10]];

digits = Reverse[RealDigits[N[Pi, n]][[1]]];

Legended[
 Graphics[
  Tooltip[
     Style[Point[#[[1]]], #[[2]]], #[[3]]] & /@ 
   Transpose[{data, styles[[# + 1]] & /@ digits, digits}]],
 PointLegend[styles, Range[0, 9]]]

score 1 · Answer 5 · answered Nov 28 '23 at 20:52

This is going to require someone with much more Graphics knowledge than me, but we can start by creating a spiral of points and coloring based off digit:


cols = ColorData[3, "ColorList"];
colRule = Thread[Range[0, 9] -> cols];
cyclicLength = 75;
n = 10 cyclicLength;
digs = RealDigits[Pi, 10, n] // First;
ptSize = 0.02;
pointsColoredByDigit = 
  MapIndexed[{# /. colRule, PointSize[ptSize], 
     Point[Flatten@{Ceiling[#2/cyclicLength]*
         Cos[ (2 Pi #2)/cyclicLength], 
        Ceiling[#2/cyclicLength]*Sin[(2 Pi #2)/cyclicLength]}]} &, 
   digs];
Graphics@pointsColoredByDigit

Mathematica graphics

There are a couple of parameters here you can mess with:

The colors that each digit are mapped to (colRule). I didn't put too much thought into this, I just used the 10 colors of indexed color scheme 3.
The number of points that sit at the same radius. I chose this to be 75, but the result can look quite different depending on this parameter value
The point size. I tried to make it so that all the points were touching like they are in the graphic, but I couldn't quite match this aesthetic.

Digits of Pi in colored spiral

5 Answers5