Perfect Magic Cube

Author

Eric W. Weisstein
February 24, 2009

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

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

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

Check

sums=With[{n=5},
Show[Graphics3D[{
{GrayLevel[.5],
Table[Line[{{1,i,j},{n,i,j}}],{i,n},{j,n}],
Table[Line[{{i,1,j},{i,n,j}}],{i,n},{j,n}],
Table[Line[{{i,j,1},{i,j,n}}],{i,n},{j,n}]
},
Thickness[.01],
{
Line[{{1,1,1},{n,n,n}}],
Line[{{1,1,n},{n,n,1}}],
Line[{{1,n,1},{n,1,n}}],
Line[{{n,1,1},{1,n,n}}]
},
{
Blue,
Table[Line[{{1,1,j},{n,n,j}}],{j,n}],
Table[Line[{{1,n,j},{n,1,j}}],{j,n}]
},
{
Green,
Table[Line[{{j,1,1},{j,n,n}}],{j,n}],
Table[Line[{{j,1,n},{j,n,1}}],{j,n}]
},
{
Red,
Table[Line[{{1,j,1},{n,j,n}}],{j,n}],
Table[Line[{{1,j,n},{n,j,1}}],{j,n}]
}

}],Boxed->False,PlotRange->All]
]

LiveGraphics3D

<<Utilities`LiveGraphics3D`

WriteLiveForm["perfcubs.m",sums]

Order 2

Length[Permutations[8]]

Count[Function[cube,Nest[Partition[#,2]&,cube,2]]/@Permutations[8],_?PerfectQ]

Order 5

MagicConstant[3,5]

Boyer and Trump

c=PerfectMagicCubes[5][[1]];
colors={Red,Hue[.13],Green,Blue,Violet};
PerfectQ/@{c,c^2}

PerfectMagicCube[5][[3,3,3]]

Show[GraphicsArray[
MapIndexed[MagicSquarePlot[#,TextStyle->{FontColor->colors[[#2[[1]]]],FontFamily->"Times",FontSize->10}]&,c
]
],ImageSize->500]

cube5=With[{n=5},
Show[Graphics3D[{
{GrayLevel[.7],
Table[Line[{{1,-i,-j},{n,-i,-j}}],{i,n},{j,n}],
Table[Line[{{i,-1,-j},{i,-n,-j}}],{i,n},{j,n}],
Table[Line[{{i,-j,-1},{i,-j,-n}}],{i,n},{j,n}]
},
Transpose[{colors,MapIndexed[Text[ToString[#],{1,-1,-1}Reverse[#2]]&,c,{3}]}]
}],Boxed->False,PlotRange->All]
]

cube5=With[{n=5},
Show[Graphics3D[{
Transpose[{colors,MapIndexed[Text[ToString[#],{1,-1,-1}Reverse[#2]]&,c,{3}]}]
}],Boxed->False,PlotRange->All]
]

LiveGraphics3D

<<Utilities`LiveGraphics3D`

WriteLiveForm["perfcub5.m",cube5]

Order 6

MagicConstant[3,6]

Trump

p=PerfectMagicCubes[6][[1]];
colors={Red,Orange,Hue[.12],Green,Blue,Violet};
PerfectQ/@{p,p^2}

Show[GraphicsArray[
Partition[MapIndexed[MagicSquarePlot[#,TextStyle->{FontColor->colors[[#2[[1]]]],FontFamily->"Times",FontSize->10}]&,p
],3]
],ImageSize->500]

cube6=With[{n=6},
Show[Graphics3D[{
{GrayLevel[.7],
Table[Line[{{1,-i,-j},{n,-i,-j}}],{i,n},{j,n}],
Table[Line[{{i,-1,-j},{i,-n,-j}}],{i,n},{j,n}],
Table[Line[{{i,-j,-1},{i,-j,-n}}],{i,n},{j,n}]
},
Transpose[{colors,MapIndexed[Text[ToString[#],{1,-1,-1}Reverse[#2]]&,p,{3}]}]
}],Boxed->False,PlotRange->All]
]

cube6=With[{n=6},
Show[Graphics3D[{
Transpose[{colors,MapIndexed[Text[ToString[#],{1,-1,-1}Reverse[#2]]&,p,{3}]}]
}],Boxed->False,PlotRange->All]
]

LiveGraphics3D

<<Utilities`LiveGraphics3D`

WriteLiveForm["perfcub6.m",cube6]

Order 7

Frost

p=PerfectMagicCubes[7][[1]];
colors={Red,Orange,Hue[.12],Green,Blue,Purple,Violet};
PerfectQ/@{p,p^2}

Show[GraphicsArray[
Partition[MapIndexed[MagicSquarePlot[#,TextStyle->{FontColor->colors[[#2[[1]]]],FontFamily->"Times",FontSize->8}]&,p
],4,4,{1,1},{}]
],ImageSize->500]

cube7=With[{n=7},
Show[Graphics3D[{
{GrayLevel[.7],
Table[Line[{{1,-i,-j},{7,-i,-j}}],{i,7},{j,7}],
Table[Line[{{i,-1,-j},{i,-7,-j}}],{i,7},{j,7}],
Table[Line[{{i,-j,-1},{i,-j,-7}}],{i,7},{j,7}]
},
Transpose[{colors,MapIndexed[Text[ToString[#],{1,-1,-1}Reverse[#2]]&,p,{3}]}]
}],Boxed->False,PlotRange->All]
]

LiveGraphics3D

<<Utilities`LiveGraphics3D`

WriteLiveForm["perfcub7.m",cube7]

Order 8

p=PerfectMagicCubes[8][[1]];
PerfectMagicQ/@{p,p^2}

Show[GraphicsArray[
Partition[MapIndexed[MagicSquarePlot[#,TextStyle->{FontColor->Hue[(#2[[1]]-1)/8.],FontFamily->"Times",FontSize->10}]&,p
],3,3,{1,1},{}]
],ImageSize->500]

Order 9

Not normal

p=PerfectMagicCubes[9][[1]];

PerfectMagicQ/@{p,p^2}

Show[GraphicsArray[
Partition[MapIndexed[MagicSquarePlot[#,TextStyle->{FontColor->Hue[(#2[[1]]-1)/9.],FontFamily->"Times",FontSize->10}]&,p
],3,3,{1,1},{}]
],ImageSize->500]

Order 10

c=With[{n=10},Round[Map[#[[3;;-2]]&,#[[2;;-2]]&/@Take[Partition[Drop[Import["http://cboyer.club.fr/multimagie/PerfectCube10.xls"][[1]],4],n+2],n],{2}]]]

PerfectMagicQ/@{c,c^2}

Show[GraphicsArray[
Partition[MapIndexed[MagicSquarePlot[#,BaseStyle->{FontColor->Hue[(#2[[1]]-1)/9.],FontFamily->"Times",FontSize->9}]&,c
],3,3,{1,1},{}]
],ImageSize->700]

Order 11

Order 12

expr=Import["http://cboyer.club.fr/multimagie/Cube_12-BJ.zip","*"];

c=Round[Map[#[[2;;13]]&,Drop[#,-3]&/@Take[Partition[Drop[expr[[1,1]],5],15],12],{2}]]

PerfectMagicQ/@{c,c^2}

Show[GraphicsArray[
Partition[MapIndexed[MagicSquarePlot[#,BaseStyle->{FontColor->Hue[(#2[[1]]-1)/9.],FontFamily->"Times",FontSize->9}]&,c
],3,3,{1,1},{}]
],ImageSize->700]

Order 25

c=PerfectMagicCubes[25][[1]];
PerfectQ/@{c,c^2,c^3}

PerfectMagicCube[25][[13,13,13]]