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
- Try to figure out neat examples to visualize primitive roots.
- Browse Wolfram Demonstrations.
- Search World Wide Web.
- Program a few versions of circle chords based visualization routines.
- Called chord trail plots below.
- Marvel at chord trail plots for larger moduli.
- Make multiple collections of them.
- Look into number of primitive roots distributions.
- Consider making animations of the collections.
- The animations should not be “chaotic” — they should have some inherent visual flow in them.
- Consider different ways of sorting chord trail plots.
- Using number theoretic arguments.
- Yeah, would be nice, but requires too much head scratching and LLM-ing.
- Convert plots to images and sort them.
- Some might say that that is a “brute force” application.
- Simple image sort does not work.
- Using number theoretic arguments.
- Latent Semantic Analysis (LSA) application.
- After failing to sort the chord trail image collections by “simple” means, the idea applying LSA came to mind.
- 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].
- Also, having a nice (monadic) paclet for doing LSA, [AAp1], helps a lot.
- Make the animations and marvel at them.
- Export the chord trail plots animations for different moduli to movies and GIFs and upload them.
- 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]]
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`]]
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]
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]
}]
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}]
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}]
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]
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]
mat = ToSSparseMatrix[SparseArray[Values@aCImageVecs], "RowNames" -> Map[ToString, Keys[aCImageVecs]], "ColumnNames" -> Automatic]
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]]] &];
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*)
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"}]
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]
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.
Mathematica for prediction algorithms 
