Magic Square

Author

Eric W. Weisstein
March 3, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/RecreationalMath/MagicSquare.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/MagicSquare.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Counts

Length/@MagicSquares/@Range[4]

Checks

4×4

And@@(MagicQ/@MagicSquares[4])

Check that they are distinct wrt rotations and reflections

Length[Union[MagicSquares[4],SameTest->RotationReflectionQ]]//Timing

Enumeration

Still a work in progress...

2×2

Length[magic2=Select[Permutations[Range[(2^2)]],MagicQ[Partition[#,2]]&]]//Timing

3×3

Permutations[Range[(3^2)]]//Length

9!

Permutations[Range[(3^2)]]//Developer`PackedArrayQ

(Partition[#,3]&/@Permutations[Range[(3^2)]])//Developer`PackedArrayQ

Length[magic3=Select[Partition[#,3]&/@Permutations[Range[(3^2)]],MagicQ]]//Timing

MatrixForm/@magic3

Union[CanonicalizeArray/@magic3]

4×4

MagicSquares[4]//Length

Length[CanonicalizeArray/@MagicSquares[4]]

16!

Length[magic4=Select[Permutations[Range[(4^2)]],MagicQ[Partition[#,4]&]]]//Timing

<<DiscreteMath`Combinatorica`

Length[l4=With[{n=4},
Select[KSubsets[Range[n^2],n],Plus@@#==n(n^2+1)/2&]
]]//Timing

Length[r4=Select[KSubsets[l4,4],Unequal@@Flatten[#]&]]//Timing

Length[s4=Flatten[Permutations/@r4,1]]//Timing

Length[shifts=Flatten[Outer[List,Sequence@@Table[Range[0,3],{4}]],3]]//Timing

9408 256 124/10^6.

Length[rows=Flatten[Outer[RotateRight@@@Transpose[{##}]&,s4,shifts,1],1]]//Timing

flips=Subsets[Range[3]]

cand=Union[CanonicalizeArray/@Flatten[Function[f,MapAt[Reverse,#,List/@f]]/@flips&/@rows,1]
];

MatrixForm/@Select[cand,MagicQ]

Figure

MagicSquarePlot[MagicSquare[3],TextStyle->{FontFamily->"Times",FontSize->18,FontSlant->"Italic"},Prolog->{
{Red,
Table[Line[{{i,-1},{i,3.1}}],{i,-.5,3}],
Table[Line[{{-1,j},{3.1,j}}],{j,-.5,3}],
Line[{{-.1,-.1},{3.1,3.1}}],
Line[{{-.1,3.1},{3.1,-.1}}]
}
}]

Astrological Magic Squares

Definitions

Jupiter:={
 {4,14,15,1},
 {9,7,6,12},
 {5,11,10,8},
 {16,2,3,13}}
Mars:={
 {11,24,7,20,3},
 {4,12,25,8,16},
 {17,5,13,21,9},
 {10,18,1,14,22},
 {23,6,19,2,15}}
Mercury:={
 {8,58,59,5,4,62,63,1},
 {49,15,14,52,53,11,10,56},
 {41,23,22,44,45,19,18,48},
 {32,34,35,29,28,38,39,25},
 {40,26,27,37,36,30,31,33},
 {17,47,46,20,21,43,42,24},
 {9,55,54,12,13,51,50,16},
 {64,2,3,61,60,6,7,57}}
Moon:={
 {37,78,29,70,21,62,13,54,5},
 {6,38,79,30,71,22,63,14,46},
 {47,7,39,80,31,72,23,55,15},
 {16,48,8,40,81,32,64,24,56},
 {57,17,49,9,41,73,33,65,25},
 {26,58,18,50,1,42,74,34,66},
 {67,27,59,10,51,2,43,75,35},
 {36,68,19,60,11,52,3,44,76},
 {77,28,69,20,61,12,53,4,45}}
Saturn:={
 {4,9,2},
 {3,5,7},
 {8,1,6}}
Sun:={
 {6,32,3,34,35,1},
 {7,11,27,28,8,30},
 {19,14,16,15,23,24},
 {18,20,22,21,17,13},
 {25,29,10,9,26,12},
 {36,5,33,4,2,31}}
Venus:={
 {22,47,16,41,10,35,4},
 {5,23,48,17,42,11,29},
 {30,6,24,49,18,36,12},
 {13,31,7,25,43,19,37},
 {38,14,32,1,26,44,20},
 {21,39,8,33,2,27,45},
 {46,15,40,9,34,3,28}}

Check

astro={Jupiter,Mars,Mercury,Moon,Saturn,Sun,Venus};

MagicQ/@astro

Graphics of Squares

Show[GraphicsArray[Partition[MagicSquarePlot/@astro,
3,3,{1,1},{}]]]

Graphics of Tours

Show[GraphicsArray[Partition[TourPlot/@astro,
3,3,{1,1},{}]]]

Diamond Method

Show[MagicSquarePlot[MagicSquare[5,Method->Diamond]]]

Magic Squares Orders 3-8

And@@MagicQ/@(array=ReplacePart[MagicSquare/@Range[3,8],DuerersMagicSquare,2])

Show[GraphicsArray[Partition[MagicSquarePlot/@array,3]]]

Siamese Method

Show[MagicSquarePlot[m=MagicSquare[5,Method->Siamese]]]

Through[{MagicQ,PanmagicQ}[m]]

Show[MagicSquarePlot[m=MagicSquare[5,Method->Siamese,Ordinary->{2,1},Break->{1,-1}]]]

Through[{MagicQ,PanmagicQ}[m]]

TableForm[Table[{i,Through[{MagicQ,PanmagicQ}[MagicSquare[i,Method->Siamese,Ordinary->{1,-1},Break->{0,1}]]]},{i,3,21,2}],TableDepth->2,TableAlignments->Right]

TableForm[Table[{i,Through[{MagicQ,PanmagicQ}[MagicSquare[i,Method->Siamese,Ordinary->{1,-1},Break->{0,2}]]]},{i,3,21,2}],TableDepth->2,TableAlignments->Right]

TableForm[Table[{i,Through[{MagicQ,PanmagicQ}[MagicSquare[i,Method->Siamese,Ordinary->{2,-1},Break->{1,-1}]]]},{i,3,21,2}],TableDepth->2,TableAlignments->Right]

TableForm[Table[{i,Through[{MagicQ,PanmagicQ}[MagicSquare[i,Method->Siamese,Ordinary->{2,-1},Break->{1,-2}]]]},{i,3,21,2}],TableDepth->2,TableAlignments->Right]

Show[MagicSquarePlot[MagicSquare[8]]]

Show[MagicSquarePlot[MagicSquare[10]]]

Magic Square with Many Square Terms

TraditionalForm[sq={{565^2,23^2,222121},{289^2,425^2,527^2},{373^2,360721,205^2}}]

MagicQ[sq]

BimagicQ[sq]