Pi Day 2026: Formulas, Series, and Plots for π

Introduction

  • Happy Pi Day! Today (3/14) we celebrate the most famous mathematical constant: 𝞹 ≈ 3.141592653589793…
  • 𝞹 is irrational and transcendental, appears in circles, waves, probability, physics, and random walks.
  • Wolfram Language (with its built-in 𝞹 constant, excellent rational support, symbolic programming, and vast collection of Number Theory functions) makes experimenting with 𝞹 especially easy and enjoyable.
  • In this document (notebook) we explore a selection of formulas and algorithms.

1. Continued fraction approximation

The built-in Wolfram Language (WL) constant Pi (or π ) can be computed to an arbitrary high precision:

N[Pi, 60]
# 3.14159265358979323846264338327950288419716939937510582097494

Let us compare it with a continued fraction approximation. For example, using the (first) sequence line of On-line Encyclopedia of Integer Sequences (OEIS) A001203 produces π with precision 100:

s = {3, 7, 15, 1, 292, 1, 1, 1, 2, 1, 3, 1, 14, 2, 1, 1, 2, 2, 2, 2, 1, 84, 2, 1, 1, 15, 3, 13, 1, 4, 2, 6, 6, 99, 1, 2, 2, 6, 3, 5, 1, 1, 6, 8, 1, 7, 1, 2, 3, 7, 1, 2, 1, 1, 12, 1, 1, 1, 3, 1, 1, 8, 1, 1, 2, 1, 6, 1, 1, 5, 2, 2, 3, 1, 2, 4, 4, 16, 1, 161, 45, 1, 22, 1,2, 2, 1, 4, 1, 2, 24, 1, 2, 1, 3, 1, 2, 1};
N[FromContinuedFraction[s], 120]
# 3.14159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706808656553677697242141

Here we verify the precision using Wolfram Language:

N[Pi, 200] - %
# -1.0441745026369011477*10^-100

More details can be found in Wolfram MathWorld page “Pi Continued Fraction” , [EW1].


2. Continued fraction terms plots

It is interesting to consider the plotting the terms of continued fraction terms of \pi .

First we ingest the more “pi-terms” from OEIS A001203 (20k terms):

terms = Partition[ToExpression /@ StringSplit[Import["https://oeis.org/A001203/b001203.txt"], Whitespace], 2][[All, 2]];
Length[terms]
# 20000

Here is the summary:

ResourceFunction["RecordsSummary"][terms]
1n16eusjlod5s

Here is an array plot of the first 128 terms of the continued fraction approximating \pi :

mat = IntegerDigits[terms[[1 ;; 128]], 2];
maxDigits = Max[Length /@ mat];
mat = Map[Join[Table[0, maxDigits - Length[#]], #] &, mat];
ArrayPlot[Transpose[mat], Mesh -> True, ImageSize -> 1000]
1oesdxgitoh1u

Next, we show the Pareto principle manifestation of for the continued fraction terms. First we observe that the terms a distribution similar to Benford’s law :

tallyPi = KeySort[AssociationThread @@ Transpose[Tally[terms]]][[1 ;; 16]]/Length[terms];
termsB = RandomVariate[BenfordDistribution[10], 2000];
tallyB = KeySort[AssociationThread @@ Transpose[Tally[termsB]]]/Length[termsB];
data = {tallyPi, tallyB};
data = KeySort /@ Map[KeyMap[ToExpression, #] &, data];
data2 = First /@ Values@Merge[{data[[1]], Join[AssociationThread[Keys[data[[1]]],Null], data[[2]]]}, List];
BarChart[data2,
PlotLabel -> "Pi continued fraction terms vs. Benford's law",
ChartLegends -> {"\[Pi]", "Belford's law"},
PlotTheme -> "Detailed", ImageSize -> Large]
1fyfg7jl5cjof

Here is the Pareto principle plot — ≈5% of the unique term values correspond to ≈80% of the terms:

ResourceFunction["ParetoPrinciplePlot"][
terms,
PlotLabel -> "Pareto principle for Pi continued fraction terms",
ImageSize -> Large]
1cq0xm0gz37sk

3. Classic Infinite Series

Many ways to express π as an infinite sum — some converge slowly, others surprisingly fast.

Leibniz–Gregory series (1671/ Madhava earlier)

WL implementation:

PiLeibniz[n_Integer] := Block[{},
4*Total[Table[(-1)^i/(2 i + 1), {i, 0, n - 1}]]
]
N[PiLeibniz[1000], 20]
# 3.1405926538397929260

Verify with Wolfram Language (again):

N[Pi, 100] - N[PiLeibniz[1000], 1000]
# 0.000999999750000312499046880410106913745780068595381331607486808765908475046461390362862493334446861

Nilakantha series (faster convergence):

0293dofrmrlwe

WL:

PiNilakantha[n_Integer] := Block[{},
3 + 4*Total[Table[(-1)^(i + 1)/(2 i (2 i + 1) (2 i + 2)), {i, 1, n}]]
]
N[PiNilakantha[1000], 20]
# 3.1415926533405420519
N[Pi, 40] - N[PiNilakantha[1000], 40]
# 2.49251186562514647026299317045*10^-10

3. Beautiful Products

Wallis product (1655) — elegant infinite product:

1q0c5okxvywr4

WL running product:

 p = 2.0; 
   Do[
    p *= (2 n)^2/((2 n - 1) (2 n + 1)); 
    If[Divisible[n, 100], 
     Print[Row[{n, " -> ", p/\[Pi], " relative error"}]] 
    ], 
    {n, 1, 1000}]



| 100 | -> | 0.9975155394660373 | relative error |
| 200 | -> | 0.998753895533088 | relative error |
| 300 | -> | 0.9991683995999036 | relative error |
| 400 | -> | 0.9993759752213087 | relative error |
| 500 | -> | 0.9995006243131489 | relative error |
| 600 | -> | 0.9995837669635674 | relative error |
| 700 | -> | 0.9996431757700326 | relative error |
| 800 | -> | 0.9996877439728793 | relative error |
| 900 | -> | 0.9997224150056372 | relative error |
| 1000 | -> | 0.9997501561641055 | relative error |

4. Very Fast Modern Series — Chudnovsky Algorithm

One of the fastest-converging series used in record computations:

0b32wzezevyz0

Each term adds roughly 14 correct digits.


5. Spigot Algorithms — Digits “Drip” One by One

Spigot algorithms compute decimal digits using only integer arithmetic — no floating-point errors accumulate.

The classic Rabinowitz–Wagon spigot (based on a transformed Wallis product) produces base-10 digits sequentially.

Simple (but bounded) version outline in WL:

ClearAll[PiSpigotDigits, PiSpigotString];
PiSpigotDigits[n_Integer?Positive] :=
Module[{len, a, q, x, i, j, nines = 0, predigit = 0, digits = {}},
len = Quotient[10 n, 3] + 1;
a = ConstantArray[2, len];
For[j = 1, j <= n, j++, q = 0;
For[i = len, i >= 1, i--, x = 10 a[[i]] + q i;
a[[i]] = Mod[x, 2 i - 1];
q = Quotient[x, 2 i - 1];];
a[[1]] = Mod[q, 10];
q = Quotient[q, 10];
Which[
q == 9, nines++,
q == 10,
AppendTo[digits, predigit + 1];
digits = Join[digits, ConstantArray[0, nines]];
predigit = 0;
nines = 0,
True,
AppendTo[digits, predigit];
digits = Join[digits, ConstantArray[9, nines]];
predigit = q;
nines = 0];
];
AppendTo[digits, predigit];
Take[digits, n]
];
PiSpigotString[n_Integer?Positive] := Module[{d = PiSpigotDigits[n]}, ToString[d[[2]]] <> "." <> StringJoin[ToString /@ Rest[Rest[d]]]];
PiSpigotString[40]
# "3.14159265358979323846264338327950288419"
N[Pi, 100] - ToExpression[PiSpigotString[40]]
# 0.*10^-38

6. BBP Formula — Hex Digits Without Predecessors

Bailey–Borwein–Plouffe (1995) formula lets you compute the n-th hexadecimal digit of π directly (without earlier digits):

Very popular for distributed π-hunting projects. The best known digit-extraction algorithm .

WL snippet for partial sum (base 16 sense):

ClearAll[BBPTerm, BBPPiPartial, BBPPi]
BBPTerm[k_Integer?NonNegative] := 16^-k (4/(8 k + 1) - 2/(8 k + 4) - 1/(8 k + 5) - 1/(8 k + 6));
BBPPiPartial[n_Integer?NonNegative] := Sum[BBPTerm[k], {k, 0, n}];
BBPPi[prec_Integer?Positive] :=
Module[{n},
n = Ceiling[prec/4] + 5;
N[BBPPiPartial[n], prec]
];
BBPPiPartial[10] // N[#, 20] &
# 3.1415926535897931296
BBPPi[50]
# 3.1415926535897932384626433745157614859702375522676

7. (Instead of) Conclusion

  • π contains (almost surely) every finite sequence of digits — your birthday appears infinitely often.
  • The Feynman point : six consecutive 9s starting at digit 762.
  • Memorization world record > 100,000 digits.
  • π appears in the normal distribution, quantum mechanics, random walks, Buffon’s needle problem (probability ≈ 2/π).

Let us plot a “random walk” using the terms of continued fraction of Pi — the 20k or OEIS A001203 — to determine directions:

ListLinePlot[Reverse /@ AnglePath[terms], PlotStyle -> (AbsoluteThickness[0.6]), ImageSize -> Large, Axes -> False]
0q6uxinid6l9a

Here is a bubble chart based on the path points and term values:

pathWithValues = Flatten /@ Thread[{Reverse /@ Rest[path], terms}];
gr = BubbleChart[pathWithValues, ChartStyle -> "DarkRainbow", AspectRatio -> Automatic, Frame -> False, Axes -> False, PlotTheme -> "Minimal"];
Rasterize[gr, ImageSize -> 900, ImageResolution -> 72]
0q5w8txmqf5en

Remark: The bubble sizes indicate that some of terms are fairly large, but the majority of them are relatively small.

Here is a 3D point plot with of moving average of the 3D path modified to have the logarithms of the term values:

pathWithValuesLog = MapAt[N@*Log10, pathWithValues, {All, 3}];
ListLinePlot3D[MovingAverage[pathWithValuesLog, 200], AspectRatio -> Automatic, PlotRange -> All, ImageSize -> Large, Ticks -> None]
1w4cc4bgx9odc

References

[EW1] Eric Weisstein, “Pi Continued Fraction” , Wolfram MathWorld .

Numerically 2026 is unremarkable yet happy

… and has primitive roots

Introduction

This document (notebook) discusses number theory properties and relationships of the integer 2026.

The integer 2026 is semiprime and a happy number, with 365 as one of its primitive roots. Although 2026 may not be particularly noteworthy in number theory, this provides a great excuse to create various elaborate visualizations that reveal some interesting aspects of the number.

Setup

(*PacletInstall[AntonAntonov/NumberTheoryUtilities]*)
   Needs["AntonAntonov`NumberTheoryUtilities`"]

2026 Is a Happy Semiprime with Primitive Roots

First, 2026 is obviously not prime—it is divisible by 2 —but dividing it by 2 gives a prime, 1013:

PrimeQ[2026/2]

Out[]= True

Hence, 2026 is a semiprime . The integer 1013 is not a Gaussian prime , though:

PrimeQ[1013, GaussianIntegers -> True]

Out[]= False

happy number is a number for which iteratively summing the squares of its digits eventually reaches 1 (e.g., 13 -> 10 -> 1). Here is a check that 2026 is happy:

ResourceFunction["HappyNumberQ"][2026]

Out[]= True

Here is the corresponding trail of digit-square sums:

FixedPointList[Total[IntegerDigits[#]^2] &, 2026]

Out[]= {2026, 44, 32, 13, 10, 1, 1}

Not many years in this century are happy numbers:

Pick[Range[2000, 2100], ResourceFunction["HappyNumberQ"] /@ Range[2000, 2100]]

Out[]= {2003, 2008, 2019, 2026, 2030, 2036, 2039, 2062, 2063, 2080, 2091, 2093}

The decomposition of $2026$ as $2 * 1013$ means the multiplicative group modulo $2026$ has primitive roots. A primitive root exists for an integer $n$ if and only if $n$ is $1$, $2$,$4$, $p^k$ , or $2 p^k$ , where $k$ is an odd prime and $k>0$ .

We can check additional facts about 2026, such as whether it is “square-free” , among other properties. However, let us compare these with the feature-rich 2025 in the next section.

Comparison with 2025

Here is a side-by-side comparison of key number theory properties for 2025 and 2026.

Property20252026Notes
Prime or CompositeCompositeCompositeBoth non-prime.
Prime Factorization3^4 * 5^2 (81 * 25)2 * 10132025 has repeated small primes; 2026 is a semiprime (product of two distinct primes).
Number of Divisors15 (highly composite for its size)4 (1, 2, 1013, 2026)2025 has many divisors; 2026 has very few.
Perfect SquareYes (45^2 = 2025)NoMajor highlight for 2025—rare square year.
Sum of CubesYes (1^3 + 2^3 + … + 9^3 = (1 + … + 9)^2 = 2025)NoIconic property for 2025 (Nicomachus’s theorem).
Happy NumberNo (process leads to cycle including 4)Yes (repeated squared digit sums reach 1)Key point for 2026—its main “happy” trait.
Harshad NumberYes (divisible by 9)No (not divisible by 10)2025 qualifies; 2026 does not.
Primitive RootsNoYesThis is a relatively rare property to have.
Other Notable Traits{(20 + 25)^2 = 2025, Sum of first 45 odd numbers, Deficient number, Many pattern-based representations}{Even number, Deficient number, Few special patterns}2025 is packed with elegant properties; 2026 is more “plain” beyond being happy.
Overall “Interest” LevelHighly interesting—celebrated in math communities for squares, cubes, and patternsRelatively uninteresting—basic semiprime with no standout geometric or sum propertiesReinforces blog’s angle.

To summarize:

  • 2025 stands out as a mathematically rich number, often highlighted in puzzles and articles for its perfect square status and connections to sums of cubes and odd numbers.
  • 2026 , in contrast, has fewer flashy properties — it’s a straightforward even semiprime — but it qualifies as a happy number and it has a primitive root.

Here is a computationally generated comparison table of most of the properties found in the table above:

Dataset@Map[<|"Function" -> #1, "2025" -> #1[2025], "2026" -> #1[2026]|> &, {PrimeQ, CompositeQ, Length@*Divisors, PrimeOmega, EulerPhi, SquareFreeQ, ResourceFunction["HappyNumberQ"],ResourceFunction["HarshadNumberQ"], ResourceFunction["DeficientNumberQ"], PrimitiveRoot}]

Function20252026
PrimeQFalseFalse
CompositeQTrueTrue
-Composition-154
PrimeOmega62
EulerPhi10801012
SquareFreeQFalseTrue
-ResourceFunction-FalseTrue
-ResourceFunction-TrueFalse
-ResourceFunction-TrueTrue
PrimitiveRoot-PrimitiveRoot-3

Phi Number System

Digits of 2026 represented in the Phi number system :

ResourceFunction["PhiNumberSystem"][2026]

Out[]= {15, 13, 10, 6, -6, -11, -16}

Verification:

Total[GoldenRatio^%] // RootReduce

Out[]= 2026

Happy Numbers Trail Graph

Let us create and plot a graph showing the trails of all happy numbers less than or equal to 2026. Below, we identify these numbers and their corresponding trails:

ns = Range[2, 2026];
 AbsoluteTiming[
   trails = Map[FixedPointList[Total[IntegerDigits[#]^2] &, #, 100, SameTest -> (Abs[#1 - #2] < 1*^-10 &)] &, ns]; 
  ]

Out[]= {0.293302, Null}

Here is the corresponding trails graph, highlighting the primes and happy numbers:

happy = First /@ Select[trails, #[[-1]] == 1 &];
 primeToo = Select[happy, PrimeQ];
 joyfulToo = Select[happy, ResourceFunction["HarshadNumberQ"]];
 aColors = Flatten@{Thread[primeToo -> ResourceFunction["HexToColor"]["#006400"]],2026 -> Blue, Thread[joyfulToo -> ResourceFunction["HexToColor"]["#fbb606ff"]], _ -> ResourceFunction["HexToColor"]["#B41E3A"]};
 edges = DeleteDuplicates@Flatten@Map[Rule @@@ Partition[Most[#], 2, 1] &, Select[trails, #[[-1]] == 1 &]];
 vf1[{xc_, yc_}, name_, {w_, h_}] := {(name /. aColors), EdgeForm[name /. aColors], Rectangle[{xc - 2 w, yc - h}, {xc + 2 w, yc + h}], Text[Style[name, 12, White], {xc, yc}]}
 vf2[{xc_, yc_}, name_, {w_, h_}] := {(name /. aColors), EdgeForm[name /. aColors], Disk[{xc, yc}, {2 w, h}], Text[Style[name, 12, White], {xc, yc}]} 
  
 gTrails = 
   Graph[
    edges, 
    VertexStyle -> ResourceFunction["HexToColor"]["#B41E3A"], VertexSize -> 1.8, 
    VertexShapeFunction -> vf2, 
    EdgeStyle -> Directive[ResourceFunction["HexToColor"]["#B41E3A"]], 
    EdgeShapeFunction -> ({ResourceFunction["HexToColor"]["#B41E3A"], Thick, BezierCurve[#1]} &), 
    DirectedEdges -> False, 
    GraphLayout -> "SpringEmbedding", 
    ImageSize -> 1200]

Triangular Numbers

There is a theorem by Gauss stating that any integer can be represented as a sum of at most three triangular numbers. Here we find an “interesting” solution:

sol = FindInstance[{2026 == PolygonalNumber[i] + PolygonalNumber[j] + PolygonalNumber[k], i > 10, j > 10, k > 10}, {i, j, k}, Integers]

Out[]= {{i -> 11, j -> 19, k -> 59}}

Here, we verify the result:

Total[PolygonalNumber /@ sol[[1, All, 2]]]

Out[]= 2026

Chord Diagrams

Here is the number of primitive roots of the multiplication group modulo 2026:

PrimitiveRootList[2026] // Length

Out[]= 440

Here are chord plots [AA2, AAp1, AAp2, AAv1] corresponding to a few selected primitive roots:

Row@Map[Labeled[ChordTrailsPlot[2026, #, PlotStyle -> {AbsoluteThickness[0.01]}, ImageSize -> 400], #] &, {339, 365, 1529}]

Remark: It is interesting that 365 (the number of days in a common calendar year) is a primitive root of the multiplicative group generated by 2026 . Not many years have this property this century; many do not have primitive roots at all.

Pick[Range[2000, 2100], Map[MemberQ[PrimitiveRootList[#], 365] &, Range[2000, 2100]]]

Out[]= {2003, 2026, 2039, 2053, 2063, 2078, 2089}

Quartic Graphs

The number 2026 appears in 18 results of the search “2026 graphs” in «The On-line Encyclopedia of Integer Sequences» . Here is the first result (from 2025-12-17): A033483 , “Number of disconnected 4-valent (or quartic) graphs with n nodes.” Below, we retrieve properties from A033483’s page:

ResourceFunction["OEISSequenceData"]["A033483", "Dataset"][{"IDNumber","IDString", "Name", "Sequence", "Offset"}]

IDNumberIDStringNameSequenceOffset
33483A033483Number of disconnected 4-valent (or quartic) graphs with n nodes.{0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 3, 8, 25, 88, 378, 2026, 13351, 104595, 930586, 9124662, 96699987, …}0

Here, we just get the title:

ResourceFunction["OEISSequenceData"]["A033483", "Name"]

Out[]= "Number of disconnected 4-valent (or quartic) graphs with n nodes."

Here, we get the corresponding sequence:

seq = ResourceFunction["OEISSequenceData"]["A033483", "Sequence"]

Out[]= {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 3, 8, 25, 88, 378, 2026, 13351, 104595, 930586, 9124662, 96699987, 1095469608, 13175272208, 167460699184, 2241578965849, 31510542635443, 464047929509794, 7143991172244290, 114749135506381940, 1919658575933845129, 33393712487076999918, 603152722419661386031}

Here we find the position of 2026 in that sequence:

Position[seq, 2026]

Out[]= {{18}}

Given the title of the sequence and the extracted position of $2026$ , this means that the number of disconnected 4-regular graphs with 17 vertices is $2026$. ($17$ because the sequence offset is $0$.) Let us create a few graphs from that set by using the 5-vertex complete graph $\left(K_5\right.$) and circulant graphs . Here is an example of such a graph:

g1 = Fold[GraphUnion, CompleteGraph[5], {IndexGraph[CompleteGraph[5], 6], IndexGraph[CirculantGraph[7, {1, 2}], 11]}];
GraphPlot[g1, VertexLabels -> "Name", PlotTheme -> "Web", ImagePadding -> 10]

And here is another one:

g2 = GraphUnion[CirculantGraph[12, {1, 5}], IndexGraph[CompleteGraph[5], 13]];
GraphPlot[g1, VertexLabels -> "Name", PlotTheme -> "Web", ImagePadding -> 10]

Here, we check that all vertices have degree 4:

Mean@VertexDegree[g2]

Out[]= 4

Remark: Note that although the plots show disjoint graphs, each graph plot represents a single graph object.

Additional Comments

This section has a few additional (leftover) comments.

  • After I researched and published the blog post “Numeric properties of 2025” , [AA1], in the first few days of 2025, I decided to program additional Number theory functionalities for Raku — see the package “Math::NumberTheory” , [AAp1].
  • Number theory provides many opportunities for visualizations, so I included utilities for some of the popular patterns in “Math::NumberTheory”, [AAp1] and “NumberTheoryUtilities”.
  • The number of years in this century that have primitive roots and have 365 as a primitive root is less than the number of years that are happy numbers.
  • I would say I spent too much time finding a good, suitable, Christmas-themed combination of colors for the trails graph.

References

Articles, blog posts

[AA1] Anton Antonov, “Numeric properties of 2025” , (2025), RakuForPrediction at WordPress .

[AA2] Anton Antonov, “Primitive roots generation trails” , (2025), MathematicaForPrediction at WordPress .

[AA3] Anton Antonov, “Chatbook New Magic Cells” , (2024), RakuForPrediction at WordPress .

[EW1] Eric W. Weisstein, “Quartic Graph” . From MathWorld–A Wolfram Resource .

Notebooks

[AAn1] Anton Antonov, “Primitive roots generation trails” , (2025), Wolfram Community . STAFFPICKS, April 9, 2025​.

[EPn1] Ed Pegg, “Happy 2025 =1³+2³+3³+4³+5³+6³+7³+8³+9³!” , ​Wolfram Community , STAFFPICKS, December 30, 2024​.

Functions, packages, paclets

[AAp1] Anton Antonov, Math::NumberTheory, Raku package , (2025), GitHub/antononcube .

[AAp2] Anton Antonov, NumberTheoryUtilities, Wolfram Language paclet , (2025), Wolfram Language Paclet Repository .

[AAp3] Anton Antonov, JavaScript::D3, Raku package , (2021-2025), GitHub/antononcube .

[AAp4] Anton Antonov, Graph, Raku package , (2024-2025), GitHub/antononcube .

[JFf1] Jesse Friedman, OEISSequenceData, (2019-2024), Wolfram Function Repository.

[MSf1] Michael Solami, HexToColor, (2020), Wolfram Function Repository.

[SHf1] Sander Huisman, HappyNumberQ, (2019), Wolfram Function Repository.

[SHf2] Sander Huisman, HarshadNumberQ, (2023), Wolfram Function Repository.

[WAf1] Wolfram|Alpha Math Team, DeficientNumberQ, (2020-2023), Wolfram Function Repository.

Videos

[AAv1] Anton Antonov, Number theory neat examples in Raku (Set 3) , (2025), YouTube/@AAA4prediction .

Primitive roots generation trails

Introduction

In this blog post (notebook) we show how to make neat chord plots of primitive roots generation sequences. Primitive roots a generators of cyclic multiplicative integer groups modulo . See the built-in Wolfram Language functions PrimitiveRoot and PrimitiveRootList. We follow the ideas presented in “Modular Arithmetic Visualizations” by Peter Karpov.

Remark: The basis representation section follows “Re-exploring the structure of Chinese character images”, [AAn1]; the movie exporting section follows “Rorschach mask animations projected over 3D surfaces”, [AAn2].

Remark: The motivation for finding and making nice primary root trails came from on working on Number theory neat examples discussed in [AAv1, AAv2].

Procedure outline

  1. Try to figure out neat examples to visualize primitive roots.
    1. Browse Wolfram Demonstrations.
    2. Search World Wide Web.
  2. Program a few versions of circle chords based visualization routines.
    1. Called chord trail plots below.
  3. Marvel at chord trail plots for larger moduli.
    1. Make multiple collections of them.
    2. Look into number of primitive roots distributions.
  4. Consider making animations of the collections.
    1. The animations should not be “chaotic” — they should have some inherent visual flow in them.
  5. Consider different ways of sorting chord trail plots.
    1. Using number theoretic arguments.
      1. Yeah, would be nice, but requires too much head scratching and LLM-ing.
    2. Convert plots to images and sort them.
      1. Some might say that that is a “brute force” application.
      2. Simple image sort does not work.
  6. Latent Semantic Analysis (LSA) application.
    1. After failing to sort the chord trail image collections by “simple” means, the idea applying LSA came to mind.
    2. LSA being, of course, a favorite technique that was applied to sorting images multiple times in the past, in different contexts, [AAn1, AAn3, AAn4, AAn5, AAv3].
    3. Also, having a nice (monadic) paclet for doing LSA, [AAp1], helps a lot.
  7. Make the animations and marvel at them.
  8. Export the chord trail plots animations for different moduli to movies and GIFs and upload them.
  9. Make a blog post (notebook).

Chord plot

It is fairly easy to program a chord plot using Graph:

(* Modulus and primivite root*)
n = 509; r = 128; 
(* Coordinates of the chords plot*)
coords = AssociationThread[Range[n], Table[{Cos[2 Pi k/(n - 1) + Pi/2], Sin[2 Pi k/(n - 1) + Pi/2]}, {k, 0, n - 1}]]; 
(* Graph edges *) 
edges = UndirectedEdge @@@ Partition[PowerMod[r, #, n] & /@ Range[n], 2, 1]; 
(*Graph*) 
Graph[edges, VertexCoordinates -> coords, VertexSize -> 0, EdgeStyle -> AbsoluteThickness[0.6]]

0ja9nttj7gvy9

We make the function ChordTrailsGraph (see Section “Setup” below) encapsulating the code above. Here is an example:

ChordTrailsGraph[509, 47, EdgeStyle -> {AbsoluteThickness[0.8`]}, 
 VertexSize -> 0, VertexStyle -> EdgeForm[None], 
 EdgeStyle -> RGBColor[0.6093762755665056`, 0.7055193578067459`, 0.8512829338493225`]]

0w93mw9n87rvn

Instead of using Graph we can just a Graphics plot — again see the definition in “Setup”. Here is an example:

ChordTrails[509, 75, "Color" -> Automatic]

05fw4gbxvzil3

Note that the modular inverse is going to produce the same chord trails plot:

Row[{
   ChordTrails[257, 3, ImageSize -> 300], 
   ChordTrails[257, ModularInverse[3, 257], ImageSize -> 300] 
  }]

0ir0c5f83rko2

Making collections of plots

Here w pick a large enough modulus, we find the primitive roots, and keep only primitive roots that will produce unique chord trail plots:

n = 509;
rs = PrimitiveRootList[n];
Length[rs]
urs = Select[rs, # <= ModularInverse[#, n] &];
urs // Length

(*252*)

(*126*)

Here is the collection using Graph:

AbsoluteTiming[
  gs1 = Association@
      Map[# ->
          ChordTrailsGraph[n, #, EdgeStyle -> {AbsoluteThickness[0.8]},
            VertexSize -> 0, VertexStyle -> EdgeForm[None],
            EdgeStyle -> RGBColor[0.6093762755665056, 0.7055193578067459, 0.8512829338493225],
            ImageSize -> 300] &, urs];
]

(*{0.771692, Null}*)

Here is a sample of plots from the collection:

KeyTake[gs1, {2, 48, 69}]

1aa33rtlvkbnh

Here is the collection using Graphics:

AbsoluteTiming[
  gs2 = Association@Map[# -> ChordTrails[n, #, ImageSize -> 300] &, urs]; 
 ]

(*{1.13483, Null}*)

Here is a sample of plots from the collection (same indexes as above):

KeyTake[gs2, {2, 48, 69}]

1qeiu9fz57as7

Remark: It looks like that using Graph is faster and produces (admittedly, with tweaking options) better looking plots.

Since we want to make an animation of chord-trail plots, we convert the collection of plots into a collection of images:

AbsoluteTiming[
  imgs = Map[Rasterize[#, "Image", RasterSize -> 500, ImageSize -> 600] &, gs2]; 
 ]

(*{15.5664, Null}*)


Generalization

The function ChordTrails can be generalized to take a (pre-computed) chords argument. Here is an example of chords plot that connects integers that are modular inverses of each other:

m = 4000;
chords = Map[If[NumericQ@Quiet@ModularInverse[#, m], {#, ModularInverse[#, m]},Nothing] &, Range[m]];
ChordTrails[m, chords, PlotStyle -> AbsoluteThickness[0.01], ImageSize -> 400]

03q03q9hobjx5

LSAMon application

In order to sort the plots we find dimension reduction basis representation of the corresponding images and sort using that representation. For more details see “Re-exploring the structure of Chinese character images”, [AAn1].

Clear[ImagePreProcessing, ImageToVector];
ImagePreProcessing[img_Image] := ColorNegate@Binarize[img, 0.9];
ImageToVector[img_Image] := Flatten[ImageData[ImagePreProcessing[img]]];
ImageToVector[img_Image, imgSize_] := Flatten[ImageData[ColorConvert[ImageResize[img, imgSize], "Grayscale"]]];
ImageToVector[___] := $Failed;

aCImages = imgs;

AbsoluteTiming[aCImageVecs = ParallelMap[ImageToVector, aCImages];]

(*{0.184429, Null}*)

SeedRandom[32];
MatrixPlot[Partition[#, ImageDimensions[aCImages[[1]]][[2]]]] & /@ RandomSample[aCImageVecs, 3]

1tavxw8a8s8c7
mat = ToSSparseMatrix[SparseArray[Values@aCImageVecs], "RowNames" -> Map[ToString, Keys[aCImageVecs]], "ColumnNames" -> Automatic]

1wjcl3g3a3wd5
SeedRandom[777];
AbsoluteTiming[
  lsaAllObj = 
    LSAMonUnit[]⟹
     LSAMonSetDocumentTermMatrix[mat]⟹
     LSAMonApplyTermWeightFunctions["None", "None", "Cosine"]⟹
     LSAMonExtractTopics["NumberOfTopics" -> 120, Method -> "SVD", "MaxSteps" -> 15, "MinNumberOfDocumentsPerTerm" -> 0]⟹
     LSAMonNormalizeMatrixProduct[Normalized -> Right]; 
 ]

(*{7.56445, Null}*)

In case you want to see the basis (we show just a sample):

lsaAllObj⟹
   LSAMonEcho[Style["Sample of the obtained basis:", Bold, Purple]]⟹
   LSAMonEchoFunctionContext[ImageAdjust[Image[Partition[#, ImageDimensions[aCImages[[1]]][[1]]], ImageSize -> Tiny]] & /@ SparseArray[#H[[{2, 11, 60}, All]]] &];

0vmbr8ahsrf68
1s2uag61bl0wu
W2 = lsaAllObj⟹LSAMonNormalizeMatrixProduct[Normalized -> Right]⟹LSAMonTakeW;
Dimensions[W2]

(*{126, 120}*)

H = lsaAllObj⟹LSAMonNormalizeMatrixProduct[Normalized -> Right]⟹LSAMonTakeH;
Dimensions[H]

(*{120, 250000}*)

AbsoluteTiming[lsClusters = FindClusters[Normal[SparseArray[W2]] -> RowNames[W2], 40, Method -> {"KMeans"}];]
Length@lsClusters
ResourceFunction["RecordsSummary"][Length /@ lsClusters]

(*{0.2576, Null}*)

(*40*)

0i5ilivzw0nl5
matPixels = WeightTermsOfSSparseMatrix[lsaAllObj⟹LSAMonTakeWeightedDocumentTermMatrix, "IDF", "None", "Cosine"];
matTopics = WeightTermsOfSSparseMatrix[lsaAllObj⟹LSAMonNormalizeMatrixProduct[Normalized -> Left]⟹LSAMonTakeW, "None", "None", "Cosine"];

SeedRandom[33];
ind = RandomChoice[Keys[aCImages]];
imgTest = ImagePreProcessing@aCImages[ind];
matImageTest = ToSSparseMatrix[SparseArray@List@ImageToVector[imgTest, ImageDimensions[aCImages[[1]]]], "RowNames" -> Automatic, "ColumnNames" -> Automatic];
(*imgTest*)

H = lsaAllObj⟹LSAMonNormalizeMatrixProduct[Normalized -> Right]⟹LSAMonTakeH;
lsBasis = ImageAdjust[Image[Partition[#, ImageDimensions[aCImages[[1]]][[1]]]]] & /@ SparseArray[H];

matReprsentation = lsaAllObj⟹LSAMonRepresentByTopics[matImageTest]⟹LSAMonTakeValue;
lsCoeff = Normal@SparseArray[matReprsentation[[1, All]]];
ListPlot[MapIndexed[Tooltip[#1, lsBasis[[#2[[1]]]]] &, lsCoeff], Filling -> Axis, PlotRange -> All]

vecReprsentation = lsCoeff . SparseArray[H];
reprImg = Image[Unitize@Clip[#, {0.45, 1}, {0, 1}] &@Rescale[Partition[vecReprsentation, ImageDimensions[aCImages[[1]]][[1]]]]];
GridTableForm[Binarize@Show[#, ImageSize -> 350] & /@ {imgTest, reprImg}, TableHeadings -> {"Test", "Approximated"}]

19gvpmjp7dx8d
W = lsaAllObj⟹LSAMonNormalizeMatrixProduct[Normalized -> Left]⟹LSAMonTakeW;
Dimensions[W]

(*{126, 120}*)

aWVecs = KeyMap[ToExpression, AssociationThread[RowNames[W], Normal[SparseArray[W]]]];

ListPlot[Values@aWVecs[[1 ;; 3]], Filling -> Axis, PlotRange -> All]

0ajyn6ixlitgd
aWVecs2 = Sort[aWVecs];

aWVecs3 = aWVecs[[Ordering[Values@aWVecs]]];

Animate sorted

Here we make the animation of sorted chord trail plots:

ListAnimate[Join[Values[KeyTake[gs, Keys[aWVecs3]]], Reverse@Values[KeyTake[gs, Keys[aWVecs3]]]], DefaultDuration -> 24]

Playing the link to an uploaded movie:

Video["https://www.wolframcloud.com/obj/25b58db2-16f0-4148-9498-d73062387ebb"]


Export

Remark: The code below follows “Rorschach mask animations projected over 3D surfaces”.

Remark: The animations are exported in the subdirectory “AnimatedGIFs”.

Export to MP4 (white background)

lsExportImgs = Join[Values[KeyTake[imgs, Keys[aWVecs2]]], Reverse@Values[KeyTake[imgs, Keys[aWVecs2]]]];

AbsoluteTiming[
  Export[FileNameJoin[{NotebookDirectory[], "AnimatedGIFs", "PrimitiveRoots-" <> ToString[n] <> ".mp4"}], lsExportImgs, "MP4","DisplayDurations" -> 0.05]; 
 ]

Export to GIF (black background)

AbsoluteTiming[
  lsExportImgs2 = ColorNegate[ImageEffect[#, "Decolorization"]] & /@ Values[KeyTake[imgs, Keys[aWVecs2]]]; 
 ]

lsExportImgs2 = Join[lsExportImgs2, Reverse@lsExportImgs2];
lsExportImgs2 // Length

lsExportImgs2[[12]]

AbsoluteTiming[
  Export[FileNameJoin[{NotebookDirectory[], "AnimatedGIFs", "PrimitiveRoots-" <> ToString[n] <> ".gif"}], lsExportImgs2, "GIF", "AnimationRepetitions" -> Infinity, "DisplayDurations" -> 0.05]; 
 ]

Optionally, open the animations directory:

(*FileNameJoin[{NotebookDirectory[],"AnimatedGIFs"}]//SystemOpen*)


Setup

Load paclets

Needs["AntonAntonov`SSparseMatrix`"];
Needs["AntonAntonov`MonadicLatentSemanticAnalysis`"];
Needs["AntonAntonov`MonadicSparseMatrixRecommender`"];
Needs["AntonAntonov`OutlierIdentifiers`"];
Needs["AntonAntonov`DataReshapers`"];

Chord plots definitions

Clear[ChordTrailsGraph];
Options[ChordTrailsGraph] = Options[Graph];
ChordTrailsGraph[n_Integer, r_Integer, opts : OptionsPattern[]] := 
   Block[{coords, edges, g}, 
    coords = AssociationThread[Range[n], Table[{Cos[2 Pi k/(n - 1) + Pi/2], Sin[2 Pi k/(n - 1) + Pi/2]}, {k, 0, n - 1}]]; 
    edges = UndirectedEdge @@@ Partition[PowerMod[r, #, n] & /@ Range[n], 2, 1]; 
    g = Graph[edges, opts, VertexCoordinates -> coords]; 
    g 
   ];

Clear[ChordTrails];
Options[ChordTrails] = Join[{"Color" -> RGBColor[0.4659039108257499, 0.5977704831063181, 0.7964303267504351], PlotStyle -> {}}, Options[Graphics]];
ChordTrails[n_Integer, r_Integer, opts : OptionsPattern[]] :=
  Block[{chords},
   chords = Partition[PowerMod[r, #, n] & /@ Range[n], 2, 1];
   ChordTrails[n, chords, opts]
  ];
ChordTrails[n_Integer, chordsArg : {{_?IntegerQ, _?IntegerQ} ..}, opts : OptionsPattern[]] :=
  Block[{chords = chordsArg, color, plotStyle, coords},
   
   color = OptionValue[ChordTrails, "Color"];
   If[TrueQ[color === Automatic], 
    color = RGBColor[
     0.4659039108257499, 0.5977704831063181, 0.7964303267504351]];
   plotStyle = OptionValue[ChordTrails, PlotStyle];
   If[TrueQ[plotStyle === Automatic], plotStyle = {}];
   plotStyle = Flatten[{plotStyle}];
   
   coords = 
    AssociationThread[Range[n], 
     Table[{Cos[2 Pi k/(n - 1) + Pi/2], Sin[2 Pi k/(n - 1) + Pi/2]}, {k, 0, n - 1}]];
   chords = chords /. {i_Integer :> coords[[i]]};
   Which[
    ColorQ[color],
    Graphics[{Sequence @@ plotStyle, color, Line[chords]}, 
     FilterRules[{opts}, Options[Graphics]]],
    TrueQ[Head[color] === ColorDataFunction],
    Graphics[{Sequence @@ plotStyle, 
      MapIndexed[{color[#2[[1]]/Length[chords]], Line[#1]} &, chords]},
      FilterRules[{opts}, Options[Graphics]]],
    True,
    Echo["Unknown color spec.", "GroupClassChords:"];
    $Failed
    ]
   ];

References

Articles, posts

[PK1] Peter Karpov, “Modular Arithmetic Visualizations”, (2016), Inversed.ru.

Notebooks

[AAn1] Anton Antonov, “Re-exploring the structure of Chinese character images”, (2022), Wolfram Community.

[AAn2] Anton Antonov,  “Rorschach mask animations projected over 3D surfaces”, (2022), Wolfram Community.

[AAn3] Anton Antonov, “Handwritten Arabic characters classifiers comparison”, (2022), Wolfram Community.

[AAn4] Anton Antonov, “LSA methods comparison over random mandalas deconstruction — WL”, (2022), Wolfram Community.

[AAn5] Anton Antonov, “LSA methods comparison over random mandalas deconstruction — Python”, (2022), Wolfram Community.

Paclets

[AAp1] Anton Antonov, “MonadicLatentSemanticAnalysis”, (2023), Wolfram Language Paclet Repository.

Videos

[AAv1] Anton Antonov, “Number theory neat examples in Raku (Set 1)”, (2025), YouTube/@AAA4prediction.

[AAv2] Anton Antonov, “Number theory neat examples in Raku (Set 2)”, (2025), YouTube/@AAA4prediction.

[AAv3] Anton Antonov, “Random Mandalas Deconstruction in R, Python, and Mathematica (Greater Boston useR Meetup, Feb 2022)”, (2022), YouTube/@AAA4prediction.