Semiperfect Magic Cube

Author

Eric W. Weisstein
November 29, 2003

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

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

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

Checks of Definition

With[{n=4},
n1=n+1;
Show[Graphics3D[{
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}],
PointSize[.1],
Point/@Table[{i,i,i},{i,n}],
{Red,Point/@Table[{n1-i,i,i},{i,n}]},
{Blue,Point/@Table[{i,n1-i,i},{i,n}]},
{Green,Point/@Table[{i,i,n1-i},{i,n}]}
}],Boxed->False]
]

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[.015],
{
Red,
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}}]
}
}],Boxed->False,PlotRange->All]
]

Examples

Map[SemiperfectQ,
SemiperfectMagicCubes/@Range[3,4],
{2}]

Map[PerfectQ,
SemiperfectMagicCubes/@Range[3,4],
{2}]

Order 3

SemiperfectMagicQ/@SemiperfectMagicCubes[3]

Show[GraphicsArray[Map[
MagicSquarePlot,
SemiperfectMagicCubes[3],
{2}
]],PlotLabel->StyleForm["order 3 semiperfect magic cubes",
FontFamily->"Times",FontSlant->"Italic",FontSize->12]
]

Order 4

Coxeter

Show[GraphicsArray[MagicSquarePlot/@SemiperfectMagicCubes[4][[1]]]]