# Factorisation diagrams

Here is a way to visualize the factorisation of natural numbers. How do we get this or a similar kind of output using Mathematica?

See the list of images generated for number from 1 to 36:

Here is a recursive method using Outer:

FactorPoints[{1}] := {{0, 0}}

FactorPoints[{n_}] :=
3/2 Csc[Pi/n] Through[{Cos, Sin}[# (2 Pi)/n]] & /@ Range[n]

FactorPoints[{n_, rest__}] :=
Flatten[Outer[Plus, 9/4 Csc[Pi/n] FactorPoints[{rest}],
FactorPoints[{n}], 1], 1]

FactorPlot[n_] :=
Graphics[Disk /@
FactorPoints[Sort[Flatten[ConstantArray @@@ FactorInteger[n]]]]]


E.g. FactorPlot[30]:

And Grid[Partition[Table[Show[FactorPlot[n], ImageSize -> 60], {n, 36}], 6], Frame -> All]:

Some manual tweaking will be required to get the same layout as in your example above. In particular, the special case FactorPoints[{2, 2}] should be implemented to get the nice square shape that has been chosen in your original example:

FactorPoints[{2, 2, rest___}] := FactorPoints[{4, rest}]


Then you get very close, except for some choices about orientation of each piece:

Let me introduce the following animated approach:

As you can see, I've slightly changed the way of diagram generation. The main differences are the following.

1. Now the diagrams are more symmetric. This is due to proper rotation after each sudivision.

2. As the main principle is to use factors in decreasing order, I consider 4 as a separate factor and place it before 3.

It is also should be noted that the total area of dots in each diagram is constant.

factorMovie[n_, fpm_, opts___] :=
Module[{k, r0, r1, len, disksat, splitpts, pts, ns, prange, frames,
ptsat, line},
line[t_] := t^2 (-1 + 2 t (7 + 2 t (-5 + 2 t)));
disksat[t_] := Disk[# , r0 (1 - t) + r1 t] & @@@ ptsat[line@t];
ptsat[t_] := {#1 + t len {Sin@#2, Cos@#2}, #2} & @@@ pts;

splitpts[nn_] := Block[{},
r0 = r1;
r1 = r0/Sqrt[nn];
pts =
Sequence @@ Table[{#1, #2 + (2 \[Pi])/nn i}, {i, 0, nn - 1}] & @@@
ptsat[1];
len *= Sin[\[Pi]/k]/(3 Sin[\[Pi]/nn]); k = nn;
];
r0 = 1.5;
len = 5;
prange = 8;
ns = Flatten[
ReplaceRepeated[
Table[#1, {#2}] & @@@
FactorInteger[n], {a___, 2, 2, b___} :> {a, 4, b}]]~Sort~
Greater;
k = ns[[1]];
r1 = r0/Sqrt[k];
AppendTo[ns, ns[[-1]]];
pts = Table[{{0, 0}, (2 \[Pi])/k i}, {i, 0, k - 1}] // N;
frames = {};
Do[
frames =
frames~Join~
Table[Graphics[disksat[t], PlotRange -> prange, opts], {t, 0, 1,
1/fpm}];
splitpts[m],
{m, Rest@ns}
];
frames
];

movies = Table[factorMovie[n, 10, ImageSize -> 80], {n, 2, 36}];
mlen = Max[Length /@ movies];
PrependTo[movies, Table[movies[[1, 1]], {mlen}]];
ms = If[(l = Length[#]) < mlen,
Join[#, Table[#[[-1]], {mlen - l}]], #] & /@ movies;
frames = GraphicsGrid[Partition[#, 6], Frame -> All] & /@
Transpose[ms];
ListAnimate[frames~Join~Reverse@frames,
AnimationDirection -> ForwardBackward]


And finally one more factoring movie for 420:

n = 7 5 4 3
movie = factorMovie[n, 25, ImageSize -> 640];
frames = Join[Table[First@movie, {5}], movie, Table[Last@movie, {5}]];
ListAnimate[frames, 25, AnimationDirection -> ForwardBackward]


UPDATE

I've modified the rules of diagram generation regarding Andrew's comment below. Now the factoring is mathematically strict in a sense that 4 is not considered prime like above.

Here is the animatied version.

I've also cleaned the code but still it needs some tweaking which I don't have time for.

factorMovie[n_, fpm_, opts___] :=
Module[{k, r0, r1, len, disksat, splitpts, pts, ns, prange, frames,
ptsat, line, s},
line[t_] := t^2 (-1 + 2 t (7 + 2 t (-5 + 2 t)));
disksat[t_] := Disk[#, r0 (1 - t) + r1 t] & @@@ ptsat[line@t];
ptsat[t_] := {#1 + t len {Sin@#2, Cos@#2}, #2} & @@@ pts;
splitpts[nn_] := Block[{}, r0 = r1;
r1 = r0/Sqrt[nn];
pts =
Sequence @@
Table[{#1, #2 + \[Pi] (1 + 2 i + nn)/nn }, {i, nn}] & @@@
ptsat[1];
len *=
If[k == nn == 2, (4/9)^(s = 1 - s),
Sin[\[Pi]/k]/(3 Sin[\[Pi]/nn])];
k = nn;
];
r0 = r1 = 1;

prange = 7;
ns = Flatten[Table[#1, {#2}] & @@@ FactorInteger[n]]~Sort~Greater;
k = First@ns;
{len, s} = If[k == 2, {8, 0}, {12, 1}];
pts = {{{0, -len}, 0}};
frames = {};
Do[
splitpts[m];
frames =
frames~Join~
Table[Graphics[disksat[t], PlotRange -> prange, opts], {t, 0, 1,
1/fpm}]
, {m, ns}];
frames
];

movies = Table[factorMovie[n, 8, ImageSize -> 80], {n, 2, 36}];
mlen = Max[Length /@ movies];
PrependTo[movies, Table[movies[[1, 1]], {mlen}]];
ms = If[(l = Length[#]) < mlen,
Join[#, Table[#[[-1]], {mlen - l}]], #] & /@ movies;
frames = GraphicsGrid[Partition[#, 6], Frame -> All] & /@
Transpose[ms];
ListAnimate[frames, AnimationDirection -> ForwardBackward]


And finally this is the modified version of factoring 420.

• Oooo, shiny! +1 – Mr.Wizard Oct 9 '12 at 20:53
• Makes me dizzy ... :( – Meng Lu Oct 9 '12 at 20:56
• Very nice!${}{}{}$ – rm -rf Oct 9 '12 at 21:00
• Excellent work. These are beautiful! I agree, a rotation is the proper solution to get diagram symmetry. Question: Do you really need the special case for n=4 when you have the rotation? – Andrew Moylan Oct 10 '12 at 1:57
• You might enjoy seeing this, which is nearly as good as yours! – cormullion Nov 5 '12 at 17:09

Here's my modest attempt:

shiftMe[g_, 1] := g

shiftMe[g_, {2, tag_Integer?Positive}] := If[OddQ[tag],
Translate[Scale[g, 1/2], #] & /@ {{0, 1}, {0, -1}},
Translate[Scale[g, 1/2], #] & /@ {{1/2, 0}, {-1/2, 0}}]

shiftMe[g_, k_?PrimeQ] := Translate[Scale[g, 1/k],
Through[{Cos, Sin}[2 π #/k - π/(2 k)]]] & /@ Range[0, k - 1] /; k > 2

factorizationDiagram[n_Integer?Positive] := Graphics[Fold[shiftMe,
{Disk[{0, 0}, 1]},
MapIndexed[If[#1 == 2, Prepend[#2, 2], #1] &,
Flatten[ConstantArray @@@ FactorInteger[n]]]]]

Map[factorizationDiagram, Partition[Range[36], 6], {2}] // GraphicsGrid


Szabolcs found a page that does animated transitions between the diagrams in JavaScript here. Here's an iterative implementation of the diagrams and some basic animated transitions between them.

DynamicModule[{shapes, t, n, next, keyframes},
shapes[i_] :=
ColorData["BlueGreenYellow"]@Rescale[a, {1, i}], {a, i}],
Disk /@ First@
Fold[Module[{pts = #[[1]], r = #[[2]],
n = #2}, {Join @@
Table[# + n r Through@{Cos, Sin}[a 2 Pi/n + Pi/2] & /@
RotationTransform[a 2 Pi/n + If[n == 2, Pi/2, 0]]@
pts, {a, n}], n r}] &, {{{0., 0.}}, 1},
Join @@ ConstantArray @@@ FactorInteger@i]};
t = 1;
n = 1;
next[] :=
keyframes =
Thread[{Prepend[#, #[[1]]], #2} & @@ (shapes /@ {n, n + 1})];
next[];
Dynamic[If[(t += .02) >= n + 1, n++; next[]];
Graphics[{Blend[{#[[1]], #2[[1]]}, t - n],
Disk[#[[2, 1]] + (t - n) (#2[[2, 1]] - #[[2, 1]])]} & @@@
keyframes, PlotRange -> t*{{-2, 2}, {-2, 2}}, AspectRatio -> 1,
ImageSize -> 300]]]


• Again, great! And thanks for refreshing this Q&A, I've not seen it yet. – Kuba Apr 23 '14 at 20:11
• Thanks! I'll update it with halirutan's PlotRange improvement. – Michael Hale Apr 23 '14 at 20:39
• Damn, that's pretty cool. +1 – Mr.Wizard Apr 24 '14 at 0:31

This is Andrew's method with a few tweaks of my own. The addition of the adjustment argument should make other customization a bit easier.

f[{1}] = {{0, 0}};

f[{2}] = {{0, -9}, {0, 9}}/8;

f[{2, 2, rest___}] := f[{4, rest}, RotationMatrix[π/4]]