Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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:

factorisation diagrams for 1 to 36

share|improve this question
    
This reminds me of Richard Schwartz's book You Can Count on Monsters. –  Michael Wijaya Oct 6 '12 at 19:31

5 Answers 5

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]:

Factor plot of 30 == 5 * 3 * 2

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

First attempt at replicating factor plot table

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:

Better attempt at factor plot table

share|improve this answer
    
+1 for ConstantArray @@@ -- among other things. ;-) –  Mr.Wizard Oct 7 '12 at 13:12

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

factorization diagrams

share|improve this answer

Let me introduce the following animated approach: enter image description here

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: enter image description here

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.

enter image description here

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.

share|improve this answer
    
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
1  
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
2  
You might enjoy seeing this, which is nearly as good as yours! –  cormullion Nov 5 '12 at 17:09

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

enter image description here

share|improve this answer
    
Again, great! And thanks for refreshing this Q&A, I've not seen it yet. –  Kuba Apr 23 at 20:11
    
Thanks! I'll update it with halirutan's PlotRange improvement. –  Michael Hale Apr 23 at 20:39
    
Damn, that's pretty cool. +1 –  Mr.Wizard Apr 24 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]]

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]

Mathematica graphics

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.