38

23

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:

38

23

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:

29

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:

24

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 – 2012-10-09T20:53:55.700

Makes me dizzy ... :( – Meng Lu – 2012-10-09T20:56:04.870

Very nice!${}{}{}$ – rm -rf – 2012-10-09T21:00:08.957

1Excellent 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 – 2012-10-10T01:57:23.717

@Andrew, thank you, this is a good idea, though it will require to adjust spacing factor for n=2 to get nice pictures. I will update the answer soon. – faleichik – 2012-10-10T12:47:12.570

Amazing! However, you have some spacing issues with lots of 11 and 13 factors that end up with overlapping rings. – s0rce – 2012-10-10T17:58:53.313

Yep, this is the one of issues: need to adjust the rule for subsequent indentations... – faleichik – 2012-10-10T18:06:30.050

Your final animation http://i.stack.imgur.com/5d9Ld.gif is mesmerizing!

– Andrew Moylan – 2012-10-11T20:58:53.8432

You might enjoy seeing this, which is nearly as good as yours!

– cormullion – 2012-11-05T17:09:28.86721

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
```

13

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_] :=
Thread@{Table[
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 – 2014-04-23T20:11:51.000

Thanks! I'll update it with halirutan's PlotRange improvement. – Michael Hale – 2014-04-23T20:39:44.533

Damn, that's pretty cool. +1 – Mr.Wizard – 2014-04-24T00:31:37.963

9

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]]
f[{n_}, adj___] :=
Array[3/2 Csc[π/n] {Cos@#, Sin@#} &[# 2 π/n + π/2] &, n].adj
f[{n_, rest__}, adj___] :=
Tuples@{9/4 Csc[π/n] f[{rest}], f[{n}].adj} ~Total~ {2}
FactorPlot[n_, opts___] :=
Graphics[Disk /@ f[Join @@ ConstantArray @@@ FactorInteger @ n], opts]
Grid[Array[FactorPlot[#, ImageSize -> {90}] &, 36] ~Partition~ 6, Frame -> All]
```

This reminds me of Richard Schwartz's book You Can Count on Monsters.

– Michael Wijaya – 2012-10-06T19:31:37.937